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(i)*difi**4
4482           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4483         else if (difi.lt.-drange(i)) then
4484           difi=difi+drange(i)
4485           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4486           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4487         endif
4488 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
4489 C     &    i,itori,rad2deg*phii,
4490 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
4491       enddo
4492 !      write (iout,*) 'edihcnstr',edihcnstr
4493       return
4494       end
4495 c------------------------------------------------------------------------------
4496 #else
4497       subroutine etor(etors,edihcnstr,fact)
4498       implicit real*8 (a-h,o-z)
4499       include 'DIMENSIONS'
4500       include 'DIMENSIONS.ZSCOPT'
4501       include 'COMMON.VAR'
4502       include 'COMMON.GEO'
4503       include 'COMMON.LOCAL'
4504       include 'COMMON.TORSION'
4505       include 'COMMON.INTERACT'
4506       include 'COMMON.DERIV'
4507       include 'COMMON.CHAIN'
4508       include 'COMMON.NAMES'
4509       include 'COMMON.IOUNITS'
4510       include 'COMMON.FFIELD'
4511       include 'COMMON.TORCNSTR'
4512       logical lprn
4513 C Set lprn=.true. for debugging
4514       lprn=.false.
4515 c      lprn=.true.
4516       etors=0.0D0
4517       do i=iphi_start,iphi_end
4518         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4519      &       .or. itype(i).eq.ntyp1) cycle
4520         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4521          if (iabs(itype(i)).eq.20) then
4522          iblock=2
4523          else
4524          iblock=1
4525          endif
4526         itori=itortyp(itype(i-2))
4527         itori1=itortyp(itype(i-1))
4528         phii=phi(i)
4529         gloci=0.0D0
4530 C Regular cosine and sine terms
4531         do j=1,nterm(itori,itori1,iblock)
4532           v1ij=v1(j,itori,itori1,iblock)
4533           v2ij=v2(j,itori,itori1,iblock)
4534           cosphi=dcos(j*phii)
4535           sinphi=dsin(j*phii)
4536           etors=etors+v1ij*cosphi+v2ij*sinphi
4537           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4538         enddo
4539 C Lorentz terms
4540 C                         v1
4541 C  E = SUM ----------------------------------- - v1
4542 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4543 C
4544         cosphi=dcos(0.5d0*phii)
4545         sinphi=dsin(0.5d0*phii)
4546         do j=1,nlor(itori,itori1,iblock)
4547           vl1ij=vlor1(j,itori,itori1)
4548           vl2ij=vlor2(j,itori,itori1)
4549           vl3ij=vlor3(j,itori,itori1)
4550           pom=vl2ij*cosphi+vl3ij*sinphi
4551           pom1=1.0d0/(pom*pom+1.0d0)
4552           etors=etors+vl1ij*pom1
4553 c          if (energy_dec) etors_ii=etors_ii+
4554 c     &                vl1ij*pom1
4555           pom=-pom*pom1*pom1
4556           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4557         enddo
4558 C Subtract the constant term
4559         etors=etors-v0(itori,itori1,iblock)
4560         if (lprn)
4561      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4562      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4563      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
4564         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4565 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4566  1215   continue
4567       enddo
4568 ! 6/20/98 - dihedral angle constraints
4569       edihcnstr=0.0d0
4570       do i=1,ndih_constr
4571         itori=idih_constr(i)
4572         phii=phi(itori)
4573         difi=pinorm(phii-phi0(i))
4574         edihi=0.0d0
4575         if (difi.gt.drange(i)) then
4576           difi=difi-drange(i)
4577           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4578           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4579           edihi=0.25d0*ftors(i)*difi**4
4580         else if (difi.lt.-drange(i)) then
4581           difi=difi+drange(i)
4582           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4583           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4584           edihi=0.25d0*ftors(i)*difi**4
4585         else
4586           difi=0.0d0
4587         endif
4588         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
4589      &    i,itori,rad2deg*phii,
4590      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
4591 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4592 c     &    drange(i),edihi
4593 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4594 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
4595       enddo
4596 !      write (iout,*) 'edihcnstr',edihcnstr
4597       return
4598       end
4599 c----------------------------------------------------------------------------
4600       subroutine etor_d(etors_d,fact2)
4601 C 6/23/01 Compute double torsional energy
4602       implicit real*8 (a-h,o-z)
4603       include 'DIMENSIONS'
4604       include 'DIMENSIONS.ZSCOPT'
4605       include 'COMMON.VAR'
4606       include 'COMMON.GEO'
4607       include 'COMMON.LOCAL'
4608       include 'COMMON.TORSION'
4609       include 'COMMON.INTERACT'
4610       include 'COMMON.DERIV'
4611       include 'COMMON.CHAIN'
4612       include 'COMMON.NAMES'
4613       include 'COMMON.IOUNITS'
4614       include 'COMMON.FFIELD'
4615       include 'COMMON.TORCNSTR'
4616       logical lprn
4617 C Set lprn=.true. for debugging
4618       lprn=.false.
4619 c     lprn=.true.
4620       etors_d=0.0D0
4621       do i=iphi_start,iphi_end-1
4622         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
4623      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4624         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4625      &     goto 1215
4626         itori=itortyp(itype(i-2))
4627         itori1=itortyp(itype(i-1))
4628         itori2=itortyp(itype(i))
4629         phii=phi(i)
4630         phii1=phi(i+1)
4631         gloci1=0.0D0
4632         gloci2=0.0D0
4633         iblock=1
4634         if (iabs(itype(i+1)).eq.20) iblock=2
4635 C Regular cosine and sine terms
4636         do j=1,ntermd_1(itori,itori1,itori2,iblock)
4637           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
4638           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
4639           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
4640           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
4641           cosphi1=dcos(j*phii)
4642           sinphi1=dsin(j*phii)
4643           cosphi2=dcos(j*phii1)
4644           sinphi2=dsin(j*phii1)
4645           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4646      &     v2cij*cosphi2+v2sij*sinphi2
4647           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4648           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4649         enddo
4650         do k=2,ntermd_2(itori,itori1,itori2,iblock)
4651           do l=1,k-1
4652             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
4653             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
4654             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
4655             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
4656             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4657             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4658             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4659             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4660             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4661      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4662             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4663      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4664             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4665      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4666           enddo
4667         enddo
4668         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4669         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4670  1215   continue
4671       enddo
4672       return
4673       end
4674 #endif
4675 c------------------------------------------------------------------------------
4676       subroutine eback_sc_corr(esccor)
4677 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4678 c        conformational states; temporarily implemented as differences
4679 c        between UNRES torsional potentials (dependent on three types of
4680 c        residues) and the torsional potentials dependent on all 20 types
4681 c        of residues computed from AM1 energy surfaces of terminally-blocked
4682 c        amino-acid residues.
4683       implicit real*8 (a-h,o-z)
4684       include 'DIMENSIONS'
4685       include 'DIMENSIONS.ZSCOPT'
4686       include 'COMMON.VAR'
4687       include 'COMMON.GEO'
4688       include 'COMMON.LOCAL'
4689       include 'COMMON.TORSION'
4690       include 'COMMON.SCCOR'
4691       include 'COMMON.INTERACT'
4692       include 'COMMON.DERIV'
4693       include 'COMMON.CHAIN'
4694       include 'COMMON.NAMES'
4695       include 'COMMON.IOUNITS'
4696       include 'COMMON.FFIELD'
4697       include 'COMMON.CONTROL'
4698       logical lprn
4699 C Set lprn=.true. for debugging
4700       lprn=.false.
4701 c      lprn=.true.
4702 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
4703       esccor=0.0D0
4704       do i=itau_start,itau_end
4705         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
4706         esccor_ii=0.0D0
4707         isccori=isccortyp(itype(i-2))
4708         isccori1=isccortyp(itype(i-1))
4709         phii=phi(i)
4710         do intertyp=1,3 !intertyp
4711 cc Added 09 May 2012 (Adasko)
4712 cc  Intertyp means interaction type of backbone mainchain correlation:
4713 c   1 = SC...Ca...Ca...Ca
4714 c   2 = Ca...Ca...Ca...SC
4715 c   3 = SC...Ca...Ca...SCi
4716         gloci=0.0D0
4717         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4718      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
4719      &      (itype(i-1).eq.ntyp1)))
4720      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4721      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
4722      &     .or.(itype(i).eq.ntyp1)))
4723      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
4724      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4725      &      (itype(i-3).eq.ntyp1)))) cycle
4726         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
4727         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
4728      & cycle
4729        do j=1,nterm_sccor(isccori,isccori1)
4730           v1ij=v1sccor(j,intertyp,isccori,isccori1)
4731           v2ij=v2sccor(j,intertyp,isccori,isccori1)
4732           cosphi=dcos(j*tauangle(intertyp,i))
4733           sinphi=dsin(j*tauangle(intertyp,i))
4734            esccor=esccor+v1ij*cosphi+v2ij*sinphi
4735            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4736          enddo
4737 C      write (iout,*)"EBACK_SC_COR",esccor,i
4738 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
4739 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
4740 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
4741         if (lprn)
4742      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4743      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4744      &  (v1sccor(j,1,itori,itori1),j=1,6)
4745      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
4746 c        gsccor_loc(i-3)=gloci
4747        enddo !intertyp
4748       enddo
4749       return
4750       end
4751 c------------------------------------------------------------------------------
4752       subroutine multibody(ecorr)
4753 C This subroutine calculates multi-body contributions to energy following
4754 C the idea of Skolnick et al. If side chains I and J make a contact and
4755 C at the same time side chains I+1 and J+1 make a contact, an extra
4756 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4757       implicit real*8 (a-h,o-z)
4758       include 'DIMENSIONS'
4759       include 'COMMON.IOUNITS'
4760       include 'COMMON.DERIV'
4761       include 'COMMON.INTERACT'
4762       include 'COMMON.CONTACTS'
4763       double precision gx(3),gx1(3)
4764       logical lprn
4765
4766 C Set lprn=.true. for debugging
4767       lprn=.false.
4768
4769       if (lprn) then
4770         write (iout,'(a)') 'Contact function values:'
4771         do i=nnt,nct-2
4772           write (iout,'(i2,20(1x,i2,f10.5))')
4773      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4774         enddo
4775       endif
4776       ecorr=0.0D0
4777       do i=nnt,nct
4778         do j=1,3
4779           gradcorr(j,i)=0.0D0
4780           gradxorr(j,i)=0.0D0
4781         enddo
4782       enddo
4783       do i=nnt,nct-2
4784
4785         DO ISHIFT = 3,4
4786
4787         i1=i+ishift
4788         num_conti=num_cont(i)
4789         num_conti1=num_cont(i1)
4790         do jj=1,num_conti
4791           j=jcont(jj,i)
4792           do kk=1,num_conti1
4793             j1=jcont(kk,i1)
4794             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4795 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4796 cd   &                   ' ishift=',ishift
4797 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4798 C The system gains extra energy.
4799               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4800             endif   ! j1==j+-ishift
4801           enddo     ! kk
4802         enddo       ! jj
4803
4804         ENDDO ! ISHIFT
4805
4806       enddo         ! i
4807       return
4808       end
4809 c------------------------------------------------------------------------------
4810       double precision function esccorr(i,j,k,l,jj,kk)
4811       implicit real*8 (a-h,o-z)
4812       include 'DIMENSIONS'
4813       include 'COMMON.IOUNITS'
4814       include 'COMMON.DERIV'
4815       include 'COMMON.INTERACT'
4816       include 'COMMON.CONTACTS'
4817       double precision gx(3),gx1(3)
4818       logical lprn
4819       lprn=.false.
4820       eij=facont(jj,i)
4821       ekl=facont(kk,k)
4822 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4823 C Calculate the multi-body contribution to energy.
4824 C Calculate multi-body contributions to the gradient.
4825 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4826 cd   & k,l,(gacont(m,kk,k),m=1,3)
4827       do m=1,3
4828         gx(m) =ekl*gacont(m,jj,i)
4829         gx1(m)=eij*gacont(m,kk,k)
4830         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4831         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4832         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4833         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4834       enddo
4835       do m=i,j-1
4836         do ll=1,3
4837           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4838         enddo
4839       enddo
4840       do m=k,l-1
4841         do ll=1,3
4842           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4843         enddo
4844       enddo
4845       esccorr=-eij*ekl
4846       return
4847       end
4848 c------------------------------------------------------------------------------
4849 #ifdef MPL
4850       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4851       implicit real*8 (a-h,o-z)
4852       include 'DIMENSIONS'
4853       integer dimen1,dimen2,atom,indx
4854       double precision buffer(dimen1,dimen2)
4855       double precision zapas
4856       common /contacts_hb/ zapas(3,ntyp,maxres,7),
4857      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
4858      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
4859       num_kont=num_cont_hb(atom)
4860       do i=1,num_kont
4861         do k=1,7
4862           do j=1,3
4863             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4864           enddo ! j
4865         enddo ! k
4866         buffer(i,indx+22)=facont_hb(i,atom)
4867         buffer(i,indx+23)=ees0p(i,atom)
4868         buffer(i,indx+24)=ees0m(i,atom)
4869         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
4870       enddo ! i
4871       buffer(1,indx+26)=dfloat(num_kont)
4872       return
4873       end
4874 c------------------------------------------------------------------------------
4875       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4876       implicit real*8 (a-h,o-z)
4877       include 'DIMENSIONS'
4878       integer dimen1,dimen2,atom,indx
4879       double precision buffer(dimen1,dimen2)
4880       double precision zapas
4881       common /contacts_hb/ zapas(3,ntyp,maxres,7),
4882      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
4883      &         ees0m(ntyp,maxres),
4884      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
4885       num_kont=buffer(1,indx+26)
4886       num_kont_old=num_cont_hb(atom)
4887       num_cont_hb(atom)=num_kont+num_kont_old
4888       do i=1,num_kont
4889         ii=i+num_kont_old
4890         do k=1,7
4891           do j=1,3
4892             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4893           enddo ! j
4894         enddo ! k
4895         facont_hb(ii,atom)=buffer(i,indx+22)
4896         ees0p(ii,atom)=buffer(i,indx+23)
4897         ees0m(ii,atom)=buffer(i,indx+24)
4898         jcont_hb(ii,atom)=buffer(i,indx+25)
4899       enddo ! i
4900       return
4901       end
4902 c------------------------------------------------------------------------------
4903 #endif
4904       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4905 C This subroutine calculates multi-body contributions to hydrogen-bonding
4906       implicit real*8 (a-h,o-z)
4907       include 'DIMENSIONS'
4908       include 'DIMENSIONS.ZSCOPT'
4909       include 'COMMON.IOUNITS'
4910 #ifdef MPL
4911       include 'COMMON.INFO'
4912 #endif
4913       include 'COMMON.FFIELD'
4914       include 'COMMON.DERIV'
4915       include 'COMMON.INTERACT'
4916       include 'COMMON.CONTACTS'
4917 #ifdef MPL
4918       parameter (max_cont=maxconts)
4919       parameter (max_dim=2*(8*3+2))
4920       parameter (msglen1=max_cont*max_dim*4)
4921       parameter (msglen2=2*msglen1)
4922       integer source,CorrelType,CorrelID,Error
4923       double precision buffer(max_cont,max_dim)
4924 #endif
4925       double precision gx(3),gx1(3)
4926       logical lprn,ldone
4927
4928 C Set lprn=.true. for debugging
4929       lprn=.false.
4930 #ifdef MPL
4931       n_corr=0
4932       n_corr1=0
4933       if (fgProcs.le.1) goto 30
4934       if (lprn) then
4935         write (iout,'(a)') 'Contact function values:'
4936         do i=nnt,nct-2
4937           write (iout,'(2i3,50(1x,i2,f5.2))')
4938      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4939      &    j=1,num_cont_hb(i))
4940         enddo
4941       endif
4942 C Caution! Following code assumes that electrostatic interactions concerning
4943 C a given atom are split among at most two processors!
4944       CorrelType=477
4945       CorrelID=MyID+1
4946       ldone=.false.
4947       do i=1,max_cont
4948         do j=1,max_dim
4949           buffer(i,j)=0.0D0
4950         enddo
4951       enddo
4952       mm=mod(MyRank,2)
4953 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4954       if (mm) 20,20,10
4955    10 continue
4956 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4957       if (MyRank.gt.0) then
4958 C Send correlation contributions to the preceding processor
4959         msglen=msglen1
4960         nn=num_cont_hb(iatel_s)
4961         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4962 cd      write (iout,*) 'The BUFFER array:'
4963 cd      do i=1,nn
4964 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4965 cd      enddo
4966         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4967           msglen=msglen2
4968             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4969 C Clear the contacts of the atom passed to the neighboring processor
4970         nn=num_cont_hb(iatel_s+1)
4971 cd      do i=1,nn
4972 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4973 cd      enddo
4974             num_cont_hb(iatel_s)=0
4975         endif
4976 cd      write (iout,*) 'Processor ',MyID,MyRank,
4977 cd   & ' is sending correlation contribution to processor',MyID-1,
4978 cd   & ' msglen=',msglen
4979 cd      write (*,*) 'Processor ',MyID,MyRank,
4980 cd   & ' is sending correlation contribution to processor',MyID-1,
4981 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4982         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
4983 cd      write (iout,*) 'Processor ',MyID,
4984 cd   & ' has sent correlation contribution to processor',MyID-1,
4985 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4986 cd      write (*,*) 'Processor ',MyID,
4987 cd   & ' has sent correlation contribution to processor',MyID-1,
4988 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4989         msglen=msglen1
4990       endif ! (MyRank.gt.0)
4991       if (ldone) goto 30
4992       ldone=.true.
4993    20 continue
4994 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4995       if (MyRank.lt.fgProcs-1) then
4996 C Receive correlation contributions from the next processor
4997         msglen=msglen1
4998         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4999 cd      write (iout,*) 'Processor',MyID,
5000 cd   & ' is receiving correlation contribution from processor',MyID+1,
5001 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5002 cd      write (*,*) 'Processor',MyID,
5003 cd   & ' is receiving correlation contribution from processor',MyID+1,
5004 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5005         nbytes=-1
5006         do while (nbytes.le.0)
5007           call mp_probe(MyID+1,CorrelType,nbytes)
5008         enddo
5009 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5010         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5011 cd      write (iout,*) 'Processor',MyID,
5012 cd   & ' has received correlation contribution from processor',MyID+1,
5013 cd   & ' msglen=',msglen,' nbytes=',nbytes
5014 cd      write (iout,*) 'The received BUFFER array:'
5015 cd      do i=1,max_cont
5016 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5017 cd      enddo
5018         if (msglen.eq.msglen1) then
5019           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5020         else if (msglen.eq.msglen2)  then
5021           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5022           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5023         else
5024           write (iout,*)
5025      & 'ERROR!!!! message length changed while processing correlations.'
5026           write (*,*)
5027      & 'ERROR!!!! message length changed while processing correlations.'
5028           call mp_stopall(Error)
5029         endif ! msglen.eq.msglen1
5030       endif ! MyRank.lt.fgProcs-1
5031       if (ldone) goto 30
5032       ldone=.true.
5033       goto 10
5034    30 continue
5035 #endif
5036       if (lprn) then
5037         write (iout,'(a)') 'Contact function values:'
5038         do i=nnt,nct-2
5039           write (iout,'(2i3,50(1x,i2,f5.2))')
5040      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5041      &    j=1,num_cont_hb(i))
5042         enddo
5043       endif
5044       ecorr=0.0D0
5045 C Remove the loop below after debugging !!!
5046       do i=nnt,nct
5047         do j=1,3
5048           gradcorr(j,i)=0.0D0
5049           gradxorr(j,i)=0.0D0
5050         enddo
5051       enddo
5052 C Calculate the local-electrostatic correlation terms
5053       do i=iatel_s,iatel_e+1
5054         i1=i+1
5055         num_conti=num_cont_hb(i)
5056         num_conti1=num_cont_hb(i+1)
5057         do jj=1,num_conti
5058           j=jcont_hb(jj,i)
5059           do kk=1,num_conti1
5060             j1=jcont_hb(kk,i1)
5061 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5062 c     &         ' jj=',jj,' kk=',kk
5063             if (j1.eq.j+1 .or. j1.eq.j-1) then
5064 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5065 C The system gains extra energy.
5066               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5067               n_corr=n_corr+1
5068             else if (j1.eq.j) then
5069 C Contacts I-J and I-(J+1) occur simultaneously.
5070 C The system loses extra energy.
5071 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5072             endif
5073           enddo ! kk
5074           do kk=1,num_conti
5075             j1=jcont_hb(kk,i)
5076 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5077 c    &         ' jj=',jj,' kk=',kk
5078             if (j1.eq.j+1) then
5079 C Contacts I-J and (I+1)-J occur simultaneously.
5080 C The system loses extra energy.
5081 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5082             endif ! j1==j+1
5083           enddo ! kk
5084         enddo ! jj
5085       enddo ! i
5086       return
5087       end
5088 c------------------------------------------------------------------------------
5089       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5090      &  n_corr1)
5091 C This subroutine calculates multi-body contributions to hydrogen-bonding
5092       implicit real*8 (a-h,o-z)
5093       include 'DIMENSIONS'
5094       include 'DIMENSIONS.ZSCOPT'
5095       include 'COMMON.IOUNITS'
5096 #ifdef MPL
5097       include 'COMMON.INFO'
5098 #endif
5099       include 'COMMON.FFIELD'
5100       include 'COMMON.DERIV'
5101       include 'COMMON.INTERACT'
5102       include 'COMMON.CONTACTS'
5103 #ifdef MPL
5104       parameter (max_cont=maxconts)
5105       parameter (max_dim=2*(8*3+2))
5106       parameter (msglen1=max_cont*max_dim*4)
5107       parameter (msglen2=2*msglen1)
5108       integer source,CorrelType,CorrelID,Error
5109       double precision buffer(max_cont,max_dim)
5110 #endif
5111       double precision gx(3),gx1(3)
5112       logical lprn,ldone
5113
5114 C Set lprn=.true. for debugging
5115       lprn=.false.
5116       eturn6=0.0d0
5117 #ifdef MPL
5118       n_corr=0
5119       n_corr1=0
5120       if (fgProcs.le.1) goto 30
5121       if (lprn) then
5122         write (iout,'(a)') 'Contact function values:'
5123         do i=nnt,nct-2
5124           write (iout,'(2i3,50(1x,i2,f5.2))')
5125      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5126      &    j=1,num_cont_hb(i))
5127         enddo
5128       endif
5129 C Caution! Following code assumes that electrostatic interactions concerning
5130 C a given atom are split among at most two processors!
5131       CorrelType=477
5132       CorrelID=MyID+1
5133       ldone=.false.
5134       do i=1,max_cont
5135         do j=1,max_dim
5136           buffer(i,j)=0.0D0
5137         enddo
5138       enddo
5139       mm=mod(MyRank,2)
5140 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5141       if (mm) 20,20,10
5142    10 continue
5143 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5144       if (MyRank.gt.0) then
5145 C Send correlation contributions to the preceding processor
5146         msglen=msglen1
5147         nn=num_cont_hb(iatel_s)
5148         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5149 cd      write (iout,*) 'The BUFFER array:'
5150 cd      do i=1,nn
5151 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5152 cd      enddo
5153         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5154           msglen=msglen2
5155             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5156 C Clear the contacts of the atom passed to the neighboring processor
5157         nn=num_cont_hb(iatel_s+1)
5158 cd      do i=1,nn
5159 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5160 cd      enddo
5161             num_cont_hb(iatel_s)=0
5162         endif
5163 cd      write (iout,*) 'Processor ',MyID,MyRank,
5164 cd   & ' is sending correlation contribution to processor',MyID-1,
5165 cd   & ' msglen=',msglen
5166 cd      write (*,*) 'Processor ',MyID,MyRank,
5167 cd   & ' is sending correlation contribution to processor',MyID-1,
5168 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5169         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5170 cd      write (iout,*) 'Processor ',MyID,
5171 cd   & ' has sent correlation contribution to processor',MyID-1,
5172 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5173 cd      write (*,*) 'Processor ',MyID,
5174 cd   & ' has sent correlation contribution to processor',MyID-1,
5175 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5176         msglen=msglen1
5177       endif ! (MyRank.gt.0)
5178       if (ldone) goto 30
5179       ldone=.true.
5180    20 continue
5181 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5182       if (MyRank.lt.fgProcs-1) then
5183 C Receive correlation contributions from the next processor
5184         msglen=msglen1
5185         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5186 cd      write (iout,*) 'Processor',MyID,
5187 cd   & ' is receiving correlation contribution from processor',MyID+1,
5188 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5189 cd      write (*,*) 'Processor',MyID,
5190 cd   & ' is receiving correlation contribution from processor',MyID+1,
5191 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5192         nbytes=-1
5193         do while (nbytes.le.0)
5194           call mp_probe(MyID+1,CorrelType,nbytes)
5195         enddo
5196 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5197         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5198 cd      write (iout,*) 'Processor',MyID,
5199 cd   & ' has received correlation contribution from processor',MyID+1,
5200 cd   & ' msglen=',msglen,' nbytes=',nbytes
5201 cd      write (iout,*) 'The received BUFFER array:'
5202 cd      do i=1,max_cont
5203 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5204 cd      enddo
5205         if (msglen.eq.msglen1) then
5206           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5207         else if (msglen.eq.msglen2)  then
5208           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5209           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5210         else
5211           write (iout,*)
5212      & 'ERROR!!!! message length changed while processing correlations.'
5213           write (*,*)
5214      & 'ERROR!!!! message length changed while processing correlations.'
5215           call mp_stopall(Error)
5216         endif ! msglen.eq.msglen1
5217       endif ! MyRank.lt.fgProcs-1
5218       if (ldone) goto 30
5219       ldone=.true.
5220       goto 10
5221    30 continue
5222 #endif
5223       if (lprn) then
5224         write (iout,'(a)') 'Contact function values:'
5225         do i=nnt,nct-2
5226           write (iout,'(2i3,50(1x,i2,f5.2))')
5227      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5228      &    j=1,num_cont_hb(i))
5229         enddo
5230       endif
5231       ecorr=0.0D0
5232       ecorr5=0.0d0
5233       ecorr6=0.0d0
5234 C Remove the loop below after debugging !!!
5235       do i=nnt,nct
5236         do j=1,3
5237           gradcorr(j,i)=0.0D0
5238           gradxorr(j,i)=0.0D0
5239         enddo
5240       enddo
5241 C Calculate the dipole-dipole interaction energies
5242       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5243       do i=iatel_s,iatel_e+1
5244         num_conti=num_cont_hb(i)
5245         do jj=1,num_conti
5246           j=jcont_hb(jj,i)
5247           call dipole(i,j,jj)
5248         enddo
5249       enddo
5250       endif
5251 C Calculate the local-electrostatic correlation terms
5252       do i=iatel_s,iatel_e+1
5253         i1=i+1
5254         num_conti=num_cont_hb(i)
5255         num_conti1=num_cont_hb(i+1)
5256         do jj=1,num_conti
5257           j=jcont_hb(jj,i)
5258           do kk=1,num_conti1
5259             j1=jcont_hb(kk,i1)
5260 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5261 c     &         ' jj=',jj,' kk=',kk
5262             if (j1.eq.j+1 .or. j1.eq.j-1) then
5263 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5264 C The system gains extra energy.
5265               n_corr=n_corr+1
5266               sqd1=dsqrt(d_cont(jj,i))
5267               sqd2=dsqrt(d_cont(kk,i1))
5268               sred_geom = sqd1*sqd2
5269               IF (sred_geom.lt.cutoff_corr) THEN
5270                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5271      &            ekont,fprimcont)
5272 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5273 c     &         ' jj=',jj,' kk=',kk
5274                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5275                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5276                 do l=1,3
5277                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5278                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5279                 enddo
5280                 n_corr1=n_corr1+1
5281 cd               write (iout,*) 'sred_geom=',sred_geom,
5282 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5283                 call calc_eello(i,j,i+1,j1,jj,kk)
5284                 if (wcorr4.gt.0.0d0)
5285      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5286                 if (wcorr5.gt.0.0d0)
5287      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5288 c                print *,"wcorr5",ecorr5
5289 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5290 cd                write(2,*)'ijkl',i,j,i+1,j1
5291                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5292      &               .or. wturn6.eq.0.0d0))then
5293 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5294                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5295 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5296 cd     &            'ecorr6=',ecorr6
5297 cd                write (iout,'(4e15.5)') sred_geom,
5298 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5299 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5300 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5301                 else if (wturn6.gt.0.0d0
5302      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5303 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5304                   eturn6=eturn6+eello_turn6(i,jj,kk)
5305 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5306                 endif
5307               ENDIF
5308 1111          continue
5309             else if (j1.eq.j) then
5310 C Contacts I-J and I-(J+1) occur simultaneously.
5311 C The system loses extra energy.
5312 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5313             endif
5314           enddo ! kk
5315           do kk=1,num_conti
5316             j1=jcont_hb(kk,i)
5317 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5318 c    &         ' jj=',jj,' kk=',kk
5319             if (j1.eq.j+1) then
5320 C Contacts I-J and (I+1)-J occur simultaneously.
5321 C The system loses extra energy.
5322 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5323             endif ! j1==j+1
5324           enddo ! kk
5325         enddo ! jj
5326       enddo ! i
5327       return
5328       end
5329 c------------------------------------------------------------------------------
5330       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5331       implicit real*8 (a-h,o-z)
5332       include 'DIMENSIONS'
5333       include 'COMMON.IOUNITS'
5334       include 'COMMON.DERIV'
5335       include 'COMMON.INTERACT'
5336       include 'COMMON.CONTACTS'
5337       double precision gx(3),gx1(3)
5338       logical lprn
5339       lprn=.false.
5340       eij=facont_hb(jj,i)
5341       ekl=facont_hb(kk,k)
5342       ees0pij=ees0p(jj,i)
5343       ees0pkl=ees0p(kk,k)
5344       ees0mij=ees0m(jj,i)
5345       ees0mkl=ees0m(kk,k)
5346       ekont=eij*ekl
5347       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5348 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5349 C Following 4 lines for diagnostics.
5350 cd    ees0pkl=0.0D0
5351 cd    ees0pij=1.0D0
5352 cd    ees0mkl=0.0D0
5353 cd    ees0mij=1.0D0
5354 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5355 c    &   ' and',k,l
5356 c     write (iout,*)'Contacts have occurred for peptide groups',
5357 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5358 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5359 C Calculate the multi-body contribution to energy.
5360       ecorr=ecorr+ekont*ees
5361       if (calc_grad) then
5362 C Calculate multi-body contributions to the gradient.
5363       do ll=1,3
5364         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5365         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5366      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5367      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5368         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5369      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5370      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5371         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5372         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5373      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5374      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5375         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5376      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5377      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5378       enddo
5379       do m=i+1,j-1
5380         do ll=1,3
5381           gradcorr(ll,m)=gradcorr(ll,m)+
5382      &     ees*ekl*gacont_hbr(ll,jj,i)-
5383      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5384      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5385         enddo
5386       enddo
5387       do m=k+1,l-1
5388         do ll=1,3
5389           gradcorr(ll,m)=gradcorr(ll,m)+
5390      &     ees*eij*gacont_hbr(ll,kk,k)-
5391      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5392      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5393         enddo
5394       enddo
5395       endif
5396       ehbcorr=ekont*ees
5397       return
5398       end
5399 C---------------------------------------------------------------------------
5400       subroutine dipole(i,j,jj)
5401       implicit real*8 (a-h,o-z)
5402       include 'DIMENSIONS'
5403       include 'DIMENSIONS.ZSCOPT'
5404       include 'COMMON.IOUNITS'
5405       include 'COMMON.CHAIN'
5406       include 'COMMON.FFIELD'
5407       include 'COMMON.DERIV'
5408       include 'COMMON.INTERACT'
5409       include 'COMMON.CONTACTS'
5410       include 'COMMON.TORSION'
5411       include 'COMMON.VAR'
5412       include 'COMMON.GEO'
5413       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5414      &  auxmat(2,2)
5415       iti1 = itortyp(itype(i+1))
5416       if (j.lt.nres-1) then
5417         if (itype(j).le.ntyp) then
5418           itj1 = itortyp(itype(j+1))
5419         else
5420           itj=ntortyp+1
5421         endif
5422       else
5423         itj1=ntortyp+1
5424       endif
5425       do iii=1,2
5426         dipi(iii,1)=Ub2(iii,i)
5427         dipderi(iii)=Ub2der(iii,i)
5428         dipi(iii,2)=b1(iii,iti1)
5429         dipj(iii,1)=Ub2(iii,j)
5430         dipderj(iii)=Ub2der(iii,j)
5431         dipj(iii,2)=b1(iii,itj1)
5432       enddo
5433       kkk=0
5434       do iii=1,2
5435         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5436         do jjj=1,2
5437           kkk=kkk+1
5438           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5439         enddo
5440       enddo
5441       if (.not.calc_grad) return
5442       do kkk=1,5
5443         do lll=1,3
5444           mmm=0
5445           do iii=1,2
5446             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5447      &        auxvec(1))
5448             do jjj=1,2
5449               mmm=mmm+1
5450               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5451             enddo
5452           enddo
5453         enddo
5454       enddo
5455       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5456       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5457       do iii=1,2
5458         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5459       enddo
5460       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5461       do iii=1,2
5462         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5463       enddo
5464       return
5465       end
5466 C---------------------------------------------------------------------------
5467       subroutine calc_eello(i,j,k,l,jj,kk)
5468 C
5469 C This subroutine computes matrices and vectors needed to calculate
5470 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5471 C
5472       implicit real*8 (a-h,o-z)
5473       include 'DIMENSIONS'
5474       include 'DIMENSIONS.ZSCOPT'
5475       include 'COMMON.IOUNITS'
5476       include 'COMMON.CHAIN'
5477       include 'COMMON.DERIV'
5478       include 'COMMON.INTERACT'
5479       include 'COMMON.CONTACTS'
5480       include 'COMMON.TORSION'
5481       include 'COMMON.VAR'
5482       include 'COMMON.GEO'
5483       include 'COMMON.FFIELD'
5484       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5485      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5486       logical lprn
5487       common /kutas/ lprn
5488 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5489 cd     & ' jj=',jj,' kk=',kk
5490 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5491       do iii=1,2
5492         do jjj=1,2
5493           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5494           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5495         enddo
5496       enddo
5497       call transpose2(aa1(1,1),aa1t(1,1))
5498       call transpose2(aa2(1,1),aa2t(1,1))
5499       do kkk=1,5
5500         do lll=1,3
5501           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5502      &      aa1tder(1,1,lll,kkk))
5503           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5504      &      aa2tder(1,1,lll,kkk))
5505         enddo
5506       enddo
5507       if (l.eq.j+1) then
5508 C parallel orientation of the two CA-CA-CA frames.
5509         if (i.gt.1 .and. itype(i).le.ntyp) then
5510           iti=itortyp(itype(i))
5511         else
5512           iti=ntortyp+1
5513         endif
5514         itk1=itortyp(itype(k+1))
5515         itj=itortyp(itype(j))
5516         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
5517           itl1=itortyp(itype(l+1))
5518         else
5519           itl1=ntortyp+1
5520         endif
5521 C A1 kernel(j+1) A2T
5522 cd        do iii=1,2
5523 cd          write (iout,'(3f10.5,5x,3f10.5)')
5524 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5525 cd        enddo
5526         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5527      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5528      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5529 C Following matrices are needed only for 6-th order cumulants
5530         IF (wcorr6.gt.0.0d0) THEN
5531         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5532      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5533      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5534         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5535      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5536      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5537      &   ADtEAderx(1,1,1,1,1,1))
5538         lprn=.false.
5539         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5540      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5541      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5542      &   ADtEA1derx(1,1,1,1,1,1))
5543         ENDIF
5544 C End 6-th order cumulants
5545 cd        lprn=.false.
5546 cd        if (lprn) then
5547 cd        write (2,*) 'In calc_eello6'
5548 cd        do iii=1,2
5549 cd          write (2,*) 'iii=',iii
5550 cd          do kkk=1,5
5551 cd            write (2,*) 'kkk=',kkk
5552 cd            do jjj=1,2
5553 cd              write (2,'(3(2f10.5),5x)')
5554 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5555 cd            enddo
5556 cd          enddo
5557 cd        enddo
5558 cd        endif
5559         call transpose2(EUgder(1,1,k),auxmat(1,1))
5560         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5561         call transpose2(EUg(1,1,k),auxmat(1,1))
5562         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5563         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5564         do iii=1,2
5565           do kkk=1,5
5566             do lll=1,3
5567               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5568      &          EAEAderx(1,1,lll,kkk,iii,1))
5569             enddo
5570           enddo
5571         enddo
5572 C A1T kernel(i+1) A2
5573         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5574      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5575      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5576 C Following matrices are needed only for 6-th order cumulants
5577         IF (wcorr6.gt.0.0d0) THEN
5578         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5579      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5580      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(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.,Ug2DtEUg(1,1,k),
5583      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5584      &   ADtEAderx(1,1,1,1,1,2))
5585         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5586      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5587      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5588      &   ADtEA1derx(1,1,1,1,1,2))
5589         ENDIF
5590 C End 6-th order cumulants
5591         call transpose2(EUgder(1,1,l),auxmat(1,1))
5592         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5593         call transpose2(EUg(1,1,l),auxmat(1,1))
5594         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5595         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5596         do iii=1,2
5597           do kkk=1,5
5598             do lll=1,3
5599               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5600      &          EAEAderx(1,1,lll,kkk,iii,2))
5601             enddo
5602           enddo
5603         enddo
5604 C AEAb1 and AEAb2
5605 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5606 C They are needed only when the fifth- or the sixth-order cumulants are
5607 C indluded.
5608         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5609         call transpose2(AEA(1,1,1),auxmat(1,1))
5610         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5611         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5612         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5613         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5614         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5615         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5616         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5617         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5618         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5619         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5620         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5621         call transpose2(AEA(1,1,2),auxmat(1,1))
5622         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5623         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5624         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5625         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5626         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5627         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5628         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5629         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5630         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5631         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5632         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5633 C Calculate the Cartesian derivatives of the vectors.
5634         do iii=1,2
5635           do kkk=1,5
5636             do lll=1,3
5637               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5638               call matvec2(auxmat(1,1),b1(1,iti),
5639      &          AEAb1derx(1,lll,kkk,iii,1,1))
5640               call matvec2(auxmat(1,1),Ub2(1,i),
5641      &          AEAb2derx(1,lll,kkk,iii,1,1))
5642               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5643      &          AEAb1derx(1,lll,kkk,iii,2,1))
5644               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5645      &          AEAb2derx(1,lll,kkk,iii,2,1))
5646               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5647               call matvec2(auxmat(1,1),b1(1,itj),
5648      &          AEAb1derx(1,lll,kkk,iii,1,2))
5649               call matvec2(auxmat(1,1),Ub2(1,j),
5650      &          AEAb2derx(1,lll,kkk,iii,1,2))
5651               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5652      &          AEAb1derx(1,lll,kkk,iii,2,2))
5653               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5654      &          AEAb2derx(1,lll,kkk,iii,2,2))
5655             enddo
5656           enddo
5657         enddo
5658         ENDIF
5659 C End vectors
5660       else
5661 C Antiparallel orientation of the two CA-CA-CA frames.
5662         if (i.gt.1 .and. itype(i).le.ntyp) then
5663           iti=itortyp(itype(i))
5664         else
5665           iti=ntortyp+1
5666         endif
5667         itk1=itortyp(itype(k+1))
5668         itl=itortyp(itype(l))
5669         itj=itortyp(itype(j))
5670         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
5671           itj1=itortyp(itype(j+1))
5672         else
5673           itj1=ntortyp+1
5674         endif
5675 C A2 kernel(j-1)T A1T
5676         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5677      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5678      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5679 C Following matrices are needed only for 6-th order cumulants
5680         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5681      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5682         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5683      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5684      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5685         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5686      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5687      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5688      &   ADtEAderx(1,1,1,1,1,1))
5689         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5690      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5691      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5692      &   ADtEA1derx(1,1,1,1,1,1))
5693         ENDIF
5694 C End 6-th order cumulants
5695         call transpose2(EUgder(1,1,k),auxmat(1,1))
5696         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5697         call transpose2(EUg(1,1,k),auxmat(1,1))
5698         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5699         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5700         do iii=1,2
5701           do kkk=1,5
5702             do lll=1,3
5703               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5704      &          EAEAderx(1,1,lll,kkk,iii,1))
5705             enddo
5706           enddo
5707         enddo
5708 C A2T kernel(i+1)T A1
5709         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5710      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5711      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5712 C Following matrices are needed only for 6-th order cumulants
5713         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5714      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5715         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5716      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5717      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(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.,Ug2DtEUg(1,1,k),
5720      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5721      &   ADtEAderx(1,1,1,1,1,2))
5722         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5723      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5724      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5725      &   ADtEA1derx(1,1,1,1,1,2))
5726         ENDIF
5727 C End 6-th order cumulants
5728         call transpose2(EUgder(1,1,j),auxmat(1,1))
5729         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5730         call transpose2(EUg(1,1,j),auxmat(1,1))
5731         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5732         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5733         do iii=1,2
5734           do kkk=1,5
5735             do lll=1,3
5736               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5737      &          EAEAderx(1,1,lll,kkk,iii,2))
5738             enddo
5739           enddo
5740         enddo
5741 C AEAb1 and AEAb2
5742 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5743 C They are needed only when the fifth- or the sixth-order cumulants are
5744 C indluded.
5745         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5746      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5747         call transpose2(AEA(1,1,1),auxmat(1,1))
5748         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5749         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5750         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5751         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5752         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5753         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5754         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5755         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5756         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5757         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5758         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5759         call transpose2(AEA(1,1,2),auxmat(1,1))
5760         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5761         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5762         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5763         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5764         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5765         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5766         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5767         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5768         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5769         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5770         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5771 C Calculate the Cartesian derivatives of the vectors.
5772         do iii=1,2
5773           do kkk=1,5
5774             do lll=1,3
5775               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5776               call matvec2(auxmat(1,1),b1(1,iti),
5777      &          AEAb1derx(1,lll,kkk,iii,1,1))
5778               call matvec2(auxmat(1,1),Ub2(1,i),
5779      &          AEAb2derx(1,lll,kkk,iii,1,1))
5780               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5781      &          AEAb1derx(1,lll,kkk,iii,2,1))
5782               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5783      &          AEAb2derx(1,lll,kkk,iii,2,1))
5784               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5785               call matvec2(auxmat(1,1),b1(1,itl),
5786      &          AEAb1derx(1,lll,kkk,iii,1,2))
5787               call matvec2(auxmat(1,1),Ub2(1,l),
5788      &          AEAb2derx(1,lll,kkk,iii,1,2))
5789               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5790      &          AEAb1derx(1,lll,kkk,iii,2,2))
5791               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5792      &          AEAb2derx(1,lll,kkk,iii,2,2))
5793             enddo
5794           enddo
5795         enddo
5796         ENDIF
5797 C End vectors
5798       endif
5799       return
5800       end
5801 C---------------------------------------------------------------------------
5802       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5803      &  KK,KKderg,AKA,AKAderg,AKAderx)
5804       implicit none
5805       integer nderg
5806       logical transp
5807       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5808      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5809      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5810       integer iii,kkk,lll
5811       integer jjj,mmm
5812       logical lprn
5813       common /kutas/ lprn
5814       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5815       do iii=1,nderg
5816         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5817      &    AKAderg(1,1,iii))
5818       enddo
5819 cd      if (lprn) write (2,*) 'In kernel'
5820       do kkk=1,5
5821 cd        if (lprn) write (2,*) 'kkk=',kkk
5822         do lll=1,3
5823           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
5824      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
5825 cd          if (lprn) then
5826 cd            write (2,*) 'lll=',lll
5827 cd            write (2,*) 'iii=1'
5828 cd            do jjj=1,2
5829 cd              write (2,'(3(2f10.5),5x)')
5830 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
5831 cd            enddo
5832 cd          endif
5833           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
5834      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
5835 cd          if (lprn) then
5836 cd            write (2,*) 'lll=',lll
5837 cd            write (2,*) 'iii=2'
5838 cd            do jjj=1,2
5839 cd              write (2,'(3(2f10.5),5x)')
5840 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
5841 cd            enddo
5842 cd          endif
5843         enddo
5844       enddo
5845       return
5846       end
5847 C---------------------------------------------------------------------------
5848       double precision function eello4(i,j,k,l,jj,kk)
5849       implicit real*8 (a-h,o-z)
5850       include 'DIMENSIONS'
5851       include 'DIMENSIONS.ZSCOPT'
5852       include 'COMMON.IOUNITS'
5853       include 'COMMON.CHAIN'
5854       include 'COMMON.DERIV'
5855       include 'COMMON.INTERACT'
5856       include 'COMMON.CONTACTS'
5857       include 'COMMON.TORSION'
5858       include 'COMMON.VAR'
5859       include 'COMMON.GEO'
5860       double precision pizda(2,2),ggg1(3),ggg2(3)
5861 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
5862 cd        eello4=0.0d0
5863 cd        return
5864 cd      endif
5865 cd      print *,'eello4:',i,j,k,l,jj,kk
5866 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
5867 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
5868 cold      eij=facont_hb(jj,i)
5869 cold      ekl=facont_hb(kk,k)
5870 cold      ekont=eij*ekl
5871       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
5872       if (calc_grad) then
5873 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
5874       gcorr_loc(k-1)=gcorr_loc(k-1)
5875      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
5876       if (l.eq.j+1) then
5877         gcorr_loc(l-1)=gcorr_loc(l-1)
5878      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5879       else
5880         gcorr_loc(j-1)=gcorr_loc(j-1)
5881      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5882       endif
5883       do iii=1,2
5884         do kkk=1,5
5885           do lll=1,3
5886             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
5887      &                        -EAEAderx(2,2,lll,kkk,iii,1)
5888 cd            derx(lll,kkk,iii)=0.0d0
5889           enddo
5890         enddo
5891       enddo
5892 cd      gcorr_loc(l-1)=0.0d0
5893 cd      gcorr_loc(j-1)=0.0d0
5894 cd      gcorr_loc(k-1)=0.0d0
5895 cd      eel4=1.0d0
5896 cd      write (iout,*)'Contacts have occurred for peptide groups',
5897 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
5898 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
5899       if (j.lt.nres-1) then
5900         j1=j+1
5901         j2=j-1
5902       else
5903         j1=j-1
5904         j2=j-2
5905       endif
5906       if (l.lt.nres-1) then
5907         l1=l+1
5908         l2=l-1
5909       else
5910         l1=l-1
5911         l2=l-2
5912       endif
5913       do ll=1,3
5914 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
5915         ggg1(ll)=eel4*g_contij(ll,1)
5916         ggg2(ll)=eel4*g_contij(ll,2)
5917         ghalf=0.5d0*ggg1(ll)
5918 cd        ghalf=0.0d0
5919         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
5920         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
5921         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
5922         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
5923 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
5924         ghalf=0.5d0*ggg2(ll)
5925 cd        ghalf=0.0d0
5926         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
5927         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
5928         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
5929         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
5930       enddo
5931 cd      goto 1112
5932       do m=i+1,j-1
5933         do ll=1,3
5934 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
5935           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
5936         enddo
5937       enddo
5938       do m=k+1,l-1
5939         do ll=1,3
5940 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
5941           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
5942         enddo
5943       enddo
5944 1112  continue
5945       do m=i+2,j2
5946         do ll=1,3
5947           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
5948         enddo
5949       enddo
5950       do m=k+2,l2
5951         do ll=1,3
5952           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
5953         enddo
5954       enddo
5955 cd      do iii=1,nres-3
5956 cd        write (2,*) iii,gcorr_loc(iii)
5957 cd      enddo
5958       endif
5959       eello4=ekont*eel4
5960 cd      write (2,*) 'ekont',ekont
5961 cd      write (iout,*) 'eello4',ekont*eel4
5962       return
5963       end
5964 C---------------------------------------------------------------------------
5965       double precision function eello5(i,j,k,l,jj,kk)
5966       implicit real*8 (a-h,o-z)
5967       include 'DIMENSIONS'
5968       include 'DIMENSIONS.ZSCOPT'
5969       include 'COMMON.IOUNITS'
5970       include 'COMMON.CHAIN'
5971       include 'COMMON.DERIV'
5972       include 'COMMON.INTERACT'
5973       include 'COMMON.CONTACTS'
5974       include 'COMMON.TORSION'
5975       include 'COMMON.VAR'
5976       include 'COMMON.GEO'
5977       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
5978       double precision ggg1(3),ggg2(3)
5979 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5980 C                                                                              C
5981 C                            Parallel chains                                   C
5982 C                                                                              C
5983 C          o             o                   o             o                   C
5984 C         /l\           / \             \   / \           / \   /              C
5985 C        /   \         /   \             \ /   \         /   \ /               C
5986 C       j| o |l1       | o |              o| o |         | o |o                C
5987 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5988 C      \i/   \         /   \ /             /   \         /   \                 C
5989 C       o    k1             o                                                  C
5990 C         (I)          (II)                (III)          (IV)                 C
5991 C                                                                              C
5992 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5993 C                                                                              C
5994 C                            Antiparallel chains                               C
5995 C                                                                              C
5996 C          o             o                   o             o                   C
5997 C         /j\           / \             \   / \           / \   /              C
5998 C        /   \         /   \             \ /   \         /   \ /               C
5999 C      j1| o |l        | o |              o| o |         | o |o                C
6000 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6001 C      \i/   \         /   \ /             /   \         /   \                 C
6002 C       o     k1            o                                                  C
6003 C         (I)          (II)                (III)          (IV)                 C
6004 C                                                                              C
6005 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6006 C                                                                              C
6007 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6008 C                                                                              C
6009 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6010 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6011 cd        eello5=0.0d0
6012 cd        return
6013 cd      endif
6014 cd      write (iout,*)
6015 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6016 cd     &   ' and',k,l
6017       itk=itortyp(itype(k))
6018       itl=itortyp(itype(l))
6019       itj=itortyp(itype(j))
6020       eello5_1=0.0d0
6021       eello5_2=0.0d0
6022       eello5_3=0.0d0
6023       eello5_4=0.0d0
6024 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6025 cd     &   eel5_3_num,eel5_4_num)
6026       do iii=1,2
6027         do kkk=1,5
6028           do lll=1,3
6029             derx(lll,kkk,iii)=0.0d0
6030           enddo
6031         enddo
6032       enddo
6033 cd      eij=facont_hb(jj,i)
6034 cd      ekl=facont_hb(kk,k)
6035 cd      ekont=eij*ekl
6036 cd      write (iout,*)'Contacts have occurred for peptide groups',
6037 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6038 cd      goto 1111
6039 C Contribution from the graph I.
6040 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6041 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6042       call transpose2(EUg(1,1,k),auxmat(1,1))
6043       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6044       vv(1)=pizda(1,1)-pizda(2,2)
6045       vv(2)=pizda(1,2)+pizda(2,1)
6046       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6047      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6048       if (calc_grad) then
6049 C Explicit gradient in virtual-dihedral angles.
6050       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6051      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6052      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6053       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6054       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6055       vv(1)=pizda(1,1)-pizda(2,2)
6056       vv(2)=pizda(1,2)+pizda(2,1)
6057       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6058      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6059      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6060       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6061       vv(1)=pizda(1,1)-pizda(2,2)
6062       vv(2)=pizda(1,2)+pizda(2,1)
6063       if (l.eq.j+1) then
6064         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6065      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6066      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6067       else
6068         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6069      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6070      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6071       endif
6072 C Cartesian gradient
6073       do iii=1,2
6074         do kkk=1,5
6075           do lll=1,3
6076             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6077      &        pizda(1,1))
6078             vv(1)=pizda(1,1)-pizda(2,2)
6079             vv(2)=pizda(1,2)+pizda(2,1)
6080             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6081      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6082      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6083           enddo
6084         enddo
6085       enddo
6086 c      goto 1112
6087       endif
6088 c1111  continue
6089 C Contribution from graph II
6090       call transpose2(EE(1,1,itk),auxmat(1,1))
6091       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6092       vv(1)=pizda(1,1)+pizda(2,2)
6093       vv(2)=pizda(2,1)-pizda(1,2)
6094       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6095      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6096       if (calc_grad) then
6097 C Explicit gradient in virtual-dihedral angles.
6098       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6099      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6100       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6101       vv(1)=pizda(1,1)+pizda(2,2)
6102       vv(2)=pizda(2,1)-pizda(1,2)
6103       if (l.eq.j+1) then
6104         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6105      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6106      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6107       else
6108         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6109      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6110      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6111       endif
6112 C Cartesian gradient
6113       do iii=1,2
6114         do kkk=1,5
6115           do lll=1,3
6116             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6117      &        pizda(1,1))
6118             vv(1)=pizda(1,1)+pizda(2,2)
6119             vv(2)=pizda(2,1)-pizda(1,2)
6120             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6121      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6122      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6123           enddo
6124         enddo
6125       enddo
6126 cd      goto 1112
6127       endif
6128 cd1111  continue
6129       if (l.eq.j+1) then
6130 cd        goto 1110
6131 C Parallel orientation
6132 C Contribution from graph III
6133         call transpose2(EUg(1,1,l),auxmat(1,1))
6134         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6135         vv(1)=pizda(1,1)-pizda(2,2)
6136         vv(2)=pizda(1,2)+pizda(2,1)
6137         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6138      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6139         if (calc_grad) then
6140 C Explicit gradient in virtual-dihedral angles.
6141         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6142      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6143      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6144         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6145         vv(1)=pizda(1,1)-pizda(2,2)
6146         vv(2)=pizda(1,2)+pizda(2,1)
6147         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6148      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6149      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6150         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6151         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6152         vv(1)=pizda(1,1)-pizda(2,2)
6153         vv(2)=pizda(1,2)+pizda(2,1)
6154         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6155      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6156      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6157 C Cartesian gradient
6158         do iii=1,2
6159           do kkk=1,5
6160             do lll=1,3
6161               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6162      &          pizda(1,1))
6163               vv(1)=pizda(1,1)-pizda(2,2)
6164               vv(2)=pizda(1,2)+pizda(2,1)
6165               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6166      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6167      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6168             enddo
6169           enddo
6170         enddo
6171 cd        goto 1112
6172         endif
6173 C Contribution from graph IV
6174 cd1110    continue
6175         call transpose2(EE(1,1,itl),auxmat(1,1))
6176         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6177         vv(1)=pizda(1,1)+pizda(2,2)
6178         vv(2)=pizda(2,1)-pizda(1,2)
6179         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6180      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6181         if (calc_grad) then
6182 C Explicit gradient in virtual-dihedral angles.
6183         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6184      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6185         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6186         vv(1)=pizda(1,1)+pizda(2,2)
6187         vv(2)=pizda(2,1)-pizda(1,2)
6188         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6189      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6190      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6191 C Cartesian gradient
6192         do iii=1,2
6193           do kkk=1,5
6194             do lll=1,3
6195               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6196      &          pizda(1,1))
6197               vv(1)=pizda(1,1)+pizda(2,2)
6198               vv(2)=pizda(2,1)-pizda(1,2)
6199               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6200      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6201      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6202             enddo
6203           enddo
6204         enddo
6205         endif
6206       else
6207 C Antiparallel orientation
6208 C Contribution from graph III
6209 c        goto 1110
6210         call transpose2(EUg(1,1,j),auxmat(1,1))
6211         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6212         vv(1)=pizda(1,1)-pizda(2,2)
6213         vv(2)=pizda(1,2)+pizda(2,1)
6214         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6215      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6216         if (calc_grad) then
6217 C Explicit gradient in virtual-dihedral angles.
6218         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6219      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6220      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6221         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6222         vv(1)=pizda(1,1)-pizda(2,2)
6223         vv(2)=pizda(1,2)+pizda(2,1)
6224         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6225      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6226      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6227         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6228         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6229         vv(1)=pizda(1,1)-pizda(2,2)
6230         vv(2)=pizda(1,2)+pizda(2,1)
6231         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6232      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6233      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6234 C Cartesian gradient
6235         do iii=1,2
6236           do kkk=1,5
6237             do lll=1,3
6238               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6239      &          pizda(1,1))
6240               vv(1)=pizda(1,1)-pizda(2,2)
6241               vv(2)=pizda(1,2)+pizda(2,1)
6242               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6243      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6244      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6245             enddo
6246           enddo
6247         enddo
6248 cd        goto 1112
6249         endif
6250 C Contribution from graph IV
6251 1110    continue
6252         call transpose2(EE(1,1,itj),auxmat(1,1))
6253         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6254         vv(1)=pizda(1,1)+pizda(2,2)
6255         vv(2)=pizda(2,1)-pizda(1,2)
6256         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6257      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6258         if (calc_grad) then
6259 C Explicit gradient in virtual-dihedral angles.
6260         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6261      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6262         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6263         vv(1)=pizda(1,1)+pizda(2,2)
6264         vv(2)=pizda(2,1)-pizda(1,2)
6265         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6266      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6267      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6268 C Cartesian gradient
6269         do iii=1,2
6270           do kkk=1,5
6271             do lll=1,3
6272               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6273      &          pizda(1,1))
6274               vv(1)=pizda(1,1)+pizda(2,2)
6275               vv(2)=pizda(2,1)-pizda(1,2)
6276               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6277      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6278      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6279             enddo
6280           enddo
6281         enddo
6282       endif
6283       endif
6284 1112  continue
6285       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6286 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6287 cd        write (2,*) 'ijkl',i,j,k,l
6288 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6289 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6290 cd      endif
6291 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6292 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6293 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6294 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6295       if (calc_grad) then
6296       if (j.lt.nres-1) then
6297         j1=j+1
6298         j2=j-1
6299       else
6300         j1=j-1
6301         j2=j-2
6302       endif
6303       if (l.lt.nres-1) then
6304         l1=l+1
6305         l2=l-1
6306       else
6307         l1=l-1
6308         l2=l-2
6309       endif
6310 cd      eij=1.0d0
6311 cd      ekl=1.0d0
6312 cd      ekont=1.0d0
6313 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6314       do ll=1,3
6315         ggg1(ll)=eel5*g_contij(ll,1)
6316         ggg2(ll)=eel5*g_contij(ll,2)
6317 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6318         ghalf=0.5d0*ggg1(ll)
6319 cd        ghalf=0.0d0
6320         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6321         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6322         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6323         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6324 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6325         ghalf=0.5d0*ggg2(ll)
6326 cd        ghalf=0.0d0
6327         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6328         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6329         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6330         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6331       enddo
6332 cd      goto 1112
6333       do m=i+1,j-1
6334         do ll=1,3
6335 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6336           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6337         enddo
6338       enddo
6339       do m=k+1,l-1
6340         do ll=1,3
6341 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6342           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6343         enddo
6344       enddo
6345 c1112  continue
6346       do m=i+2,j2
6347         do ll=1,3
6348           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6349         enddo
6350       enddo
6351       do m=k+2,l2
6352         do ll=1,3
6353           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6354         enddo
6355       enddo
6356 cd      do iii=1,nres-3
6357 cd        write (2,*) iii,g_corr5_loc(iii)
6358 cd      enddo
6359       endif
6360       eello5=ekont*eel5
6361 cd      write (2,*) 'ekont',ekont
6362 cd      write (iout,*) 'eello5',ekont*eel5
6363       return
6364       end
6365 c--------------------------------------------------------------------------
6366       double precision function eello6(i,j,k,l,jj,kk)
6367       implicit real*8 (a-h,o-z)
6368       include 'DIMENSIONS'
6369       include 'DIMENSIONS.ZSCOPT'
6370       include 'COMMON.IOUNITS'
6371       include 'COMMON.CHAIN'
6372       include 'COMMON.DERIV'
6373       include 'COMMON.INTERACT'
6374       include 'COMMON.CONTACTS'
6375       include 'COMMON.TORSION'
6376       include 'COMMON.VAR'
6377       include 'COMMON.GEO'
6378       include 'COMMON.FFIELD'
6379       double precision ggg1(3),ggg2(3)
6380 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6381 cd        eello6=0.0d0
6382 cd        return
6383 cd      endif
6384 cd      write (iout,*)
6385 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6386 cd     &   ' and',k,l
6387       eello6_1=0.0d0
6388       eello6_2=0.0d0
6389       eello6_3=0.0d0
6390       eello6_4=0.0d0
6391       eello6_5=0.0d0
6392       eello6_6=0.0d0
6393 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6394 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6395       do iii=1,2
6396         do kkk=1,5
6397           do lll=1,3
6398             derx(lll,kkk,iii)=0.0d0
6399           enddo
6400         enddo
6401       enddo
6402 cd      eij=facont_hb(jj,i)
6403 cd      ekl=facont_hb(kk,k)
6404 cd      ekont=eij*ekl
6405 cd      eij=1.0d0
6406 cd      ekl=1.0d0
6407 cd      ekont=1.0d0
6408       if (l.eq.j+1) then
6409         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6410         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6411         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6412         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6413         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6414         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6415       else
6416         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6417         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6418         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6419         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6420         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6421           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6422         else
6423           eello6_5=0.0d0
6424         endif
6425         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6426       endif
6427 C If turn contributions are considered, they will be handled separately.
6428       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6429 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6430 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6431 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6432 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6433 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6434 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6435 cd      goto 1112
6436       if (calc_grad) then
6437       if (j.lt.nres-1) then
6438         j1=j+1
6439         j2=j-1
6440       else
6441         j1=j-1
6442         j2=j-2
6443       endif
6444       if (l.lt.nres-1) then
6445         l1=l+1
6446         l2=l-1
6447       else
6448         l1=l-1
6449         l2=l-2
6450       endif
6451       do ll=1,3
6452         ggg1(ll)=eel6*g_contij(ll,1)
6453         ggg2(ll)=eel6*g_contij(ll,2)
6454 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6455         ghalf=0.5d0*ggg1(ll)
6456 cd        ghalf=0.0d0
6457         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6458         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6459         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6460         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6461         ghalf=0.5d0*ggg2(ll)
6462 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6463 cd        ghalf=0.0d0
6464         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6465         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6466         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6467         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6468       enddo
6469 cd      goto 1112
6470       do m=i+1,j-1
6471         do ll=1,3
6472 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6473           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6474         enddo
6475       enddo
6476       do m=k+1,l-1
6477         do ll=1,3
6478 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6479           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6480         enddo
6481       enddo
6482 1112  continue
6483       do m=i+2,j2
6484         do ll=1,3
6485           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6486         enddo
6487       enddo
6488       do m=k+2,l2
6489         do ll=1,3
6490           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6491         enddo
6492       enddo
6493 cd      do iii=1,nres-3
6494 cd        write (2,*) iii,g_corr6_loc(iii)
6495 cd      enddo
6496       endif
6497       eello6=ekont*eel6
6498 cd      write (2,*) 'ekont',ekont
6499 cd      write (iout,*) 'eello6',ekont*eel6
6500       return
6501       end
6502 c--------------------------------------------------------------------------
6503       double precision function eello6_graph1(i,j,k,l,imat,swap)
6504       implicit real*8 (a-h,o-z)
6505       include 'DIMENSIONS'
6506       include 'DIMENSIONS.ZSCOPT'
6507       include 'COMMON.IOUNITS'
6508       include 'COMMON.CHAIN'
6509       include 'COMMON.DERIV'
6510       include 'COMMON.INTERACT'
6511       include 'COMMON.CONTACTS'
6512       include 'COMMON.TORSION'
6513       include 'COMMON.VAR'
6514       include 'COMMON.GEO'
6515       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6516       logical swap
6517       logical lprn
6518       common /kutas/ lprn
6519 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6520 C                                                                              C
6521 C      Parallel       Antiparallel                                             C
6522 C                                                                              C
6523 C          o             o                                                     C
6524 C         /l\           /j\                                                    C
6525 C        /   \         /   \                                                   C
6526 C       /| o |         | o |\                                                  C
6527 C     \ j|/k\|  /   \  |/k\|l /                                                C
6528 C      \ /   \ /     \ /   \ /                                                 C
6529 C       o     o       o     o                                                  C
6530 C       i             i                                                        C
6531 C                                                                              C
6532 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6533       itk=itortyp(itype(k))
6534       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6535       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6536       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6537       call transpose2(EUgC(1,1,k),auxmat(1,1))
6538       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6539       vv1(1)=pizda1(1,1)-pizda1(2,2)
6540       vv1(2)=pizda1(1,2)+pizda1(2,1)
6541       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6542       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6543       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6544       s5=scalar2(vv(1),Dtobr2(1,i))
6545 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6546       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6547       if (.not. calc_grad) return
6548       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6549      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6550      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6551      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6552      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6553      & +scalar2(vv(1),Dtobr2der(1,i)))
6554       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6555       vv1(1)=pizda1(1,1)-pizda1(2,2)
6556       vv1(2)=pizda1(1,2)+pizda1(2,1)
6557       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6558       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6559       if (l.eq.j+1) then
6560         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6561      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6562      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6563      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6564      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6565       else
6566         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6567      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6568      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6569      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6570      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6571       endif
6572       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6573       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6574       vv1(1)=pizda1(1,1)-pizda1(2,2)
6575       vv1(2)=pizda1(1,2)+pizda1(2,1)
6576       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6577      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6578      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6579      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6580       do iii=1,2
6581         if (swap) then
6582           ind=3-iii
6583         else
6584           ind=iii
6585         endif
6586         do kkk=1,5
6587           do lll=1,3
6588             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6589             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6590             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6591             call transpose2(EUgC(1,1,k),auxmat(1,1))
6592             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6593      &        pizda1(1,1))
6594             vv1(1)=pizda1(1,1)-pizda1(2,2)
6595             vv1(2)=pizda1(1,2)+pizda1(2,1)
6596             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6597             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6598      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6599             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6600      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6601             s5=scalar2(vv(1),Dtobr2(1,i))
6602             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6603           enddo
6604         enddo
6605       enddo
6606       return
6607       end
6608 c----------------------------------------------------------------------------
6609       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6610       implicit real*8 (a-h,o-z)
6611       include 'DIMENSIONS'
6612       include 'DIMENSIONS.ZSCOPT'
6613       include 'COMMON.IOUNITS'
6614       include 'COMMON.CHAIN'
6615       include 'COMMON.DERIV'
6616       include 'COMMON.INTERACT'
6617       include 'COMMON.CONTACTS'
6618       include 'COMMON.TORSION'
6619       include 'COMMON.VAR'
6620       include 'COMMON.GEO'
6621       logical swap
6622       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6623      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6624       logical lprn
6625       common /kutas/ lprn
6626 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6627 C                                                                              C
6628 C      Parallel       Antiparallel                                             C
6629 C                                                                              C
6630 C          o             o                                                     C
6631 C     \   /l\           /j\   /                                                C
6632 C      \ /   \         /   \ /                                                 C
6633 C       o| o |         | o |o                                                  C
6634 C     \ j|/k\|      \  |/k\|l                                                  C
6635 C      \ /   \       \ /   \                                                   C
6636 C       o             o                                                        C
6637 C       i             i                                                        C
6638 C                                                                              C
6639 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6640 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6641 C AL 7/4/01 s1 would occur in the sixth-order moment,
6642 C           but not in a cluster cumulant
6643 #ifdef MOMENT
6644       s1=dip(1,jj,i)*dip(1,kk,k)
6645 #endif
6646       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6647       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6648       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6649       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6650       call transpose2(EUg(1,1,k),auxmat(1,1))
6651       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6652       vv(1)=pizda(1,1)-pizda(2,2)
6653       vv(2)=pizda(1,2)+pizda(2,1)
6654       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6655 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6656 #ifdef MOMENT
6657       eello6_graph2=-(s1+s2+s3+s4)
6658 #else
6659       eello6_graph2=-(s2+s3+s4)
6660 #endif
6661 c      eello6_graph2=-s3
6662       if (.not. calc_grad) return
6663 C Derivatives in gamma(i-1)
6664       if (i.gt.1) then
6665 #ifdef MOMENT
6666         s1=dipderg(1,jj,i)*dip(1,kk,k)
6667 #endif
6668         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6669         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6670         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6671         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6672 #ifdef MOMENT
6673         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6674 #else
6675         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6676 #endif
6677 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6678       endif
6679 C Derivatives in gamma(k-1)
6680 #ifdef MOMENT
6681       s1=dip(1,jj,i)*dipderg(1,kk,k)
6682 #endif
6683       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6684       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6685       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6686       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6687       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6688       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6689       vv(1)=pizda(1,1)-pizda(2,2)
6690       vv(2)=pizda(1,2)+pizda(2,1)
6691       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6692 #ifdef MOMENT
6693       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6694 #else
6695       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6696 #endif
6697 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6698 C Derivatives in gamma(j-1) or gamma(l-1)
6699       if (j.gt.1) then
6700 #ifdef MOMENT
6701         s1=dipderg(3,jj,i)*dip(1,kk,k)
6702 #endif
6703         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6704         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6705         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6706         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6707         vv(1)=pizda(1,1)-pizda(2,2)
6708         vv(2)=pizda(1,2)+pizda(2,1)
6709         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6710 #ifdef MOMENT
6711         if (swap) then
6712           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6713         else
6714           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6715         endif
6716 #endif
6717         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6718 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6719       endif
6720 C Derivatives in gamma(l-1) or gamma(j-1)
6721       if (l.gt.1) then
6722 #ifdef MOMENT
6723         s1=dip(1,jj,i)*dipderg(3,kk,k)
6724 #endif
6725         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6726         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6727         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6728         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6729         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6730         vv(1)=pizda(1,1)-pizda(2,2)
6731         vv(2)=pizda(1,2)+pizda(2,1)
6732         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6733 #ifdef MOMENT
6734         if (swap) then
6735           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6736         else
6737           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6738         endif
6739 #endif
6740         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6741 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6742       endif
6743 C Cartesian derivatives.
6744       if (lprn) then
6745         write (2,*) 'In eello6_graph2'
6746         do iii=1,2
6747           write (2,*) 'iii=',iii
6748           do kkk=1,5
6749             write (2,*) 'kkk=',kkk
6750             do jjj=1,2
6751               write (2,'(3(2f10.5),5x)')
6752      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6753             enddo
6754           enddo
6755         enddo
6756       endif
6757       do iii=1,2
6758         do kkk=1,5
6759           do lll=1,3
6760 #ifdef MOMENT
6761             if (iii.eq.1) then
6762               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6763             else
6764               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6765             endif
6766 #endif
6767             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6768      &        auxvec(1))
6769             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6770             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6771      &        auxvec(1))
6772             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6773             call transpose2(EUg(1,1,k),auxmat(1,1))
6774             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6775      &        pizda(1,1))
6776             vv(1)=pizda(1,1)-pizda(2,2)
6777             vv(2)=pizda(1,2)+pizda(2,1)
6778             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6779 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6780 #ifdef MOMENT
6781             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6782 #else
6783             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6784 #endif
6785             if (swap) then
6786               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6787             else
6788               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6789             endif
6790           enddo
6791         enddo
6792       enddo
6793       return
6794       end
6795 c----------------------------------------------------------------------------
6796       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6797       implicit real*8 (a-h,o-z)
6798       include 'DIMENSIONS'
6799       include 'DIMENSIONS.ZSCOPT'
6800       include 'COMMON.IOUNITS'
6801       include 'COMMON.CHAIN'
6802       include 'COMMON.DERIV'
6803       include 'COMMON.INTERACT'
6804       include 'COMMON.CONTACTS'
6805       include 'COMMON.TORSION'
6806       include 'COMMON.VAR'
6807       include 'COMMON.GEO'
6808       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6809       logical swap
6810 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6811 C                                                                              C
6812 C      Parallel       Antiparallel                                             C
6813 C                                                                              C
6814 C          o             o                                                     C
6815 C         /l\   /   \   /j\                                                    C
6816 C        /   \ /     \ /   \                                                   C
6817 C       /| o |o       o| o |\                                                  C
6818 C       j|/k\|  /      |/k\|l /                                                C
6819 C        /   \ /       /   \ /                                                 C
6820 C       /     o       /     o                                                  C
6821 C       i             i                                                        C
6822 C                                                                              C
6823 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6824 C
6825 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6826 C           energy moment and not to the cluster cumulant.
6827       iti=itortyp(itype(i))
6828       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6829         itj1=itortyp(itype(j+1))
6830       else
6831         itj1=ntortyp+1
6832       endif
6833       itk=itortyp(itype(k))
6834       itk1=itortyp(itype(k+1))
6835       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6836         itl1=itortyp(itype(l+1))
6837       else
6838         itl1=ntortyp+1
6839       endif
6840 #ifdef MOMENT
6841       s1=dip(4,jj,i)*dip(4,kk,k)
6842 #endif
6843       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
6844       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6845       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
6846       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6847       call transpose2(EE(1,1,itk),auxmat(1,1))
6848       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
6849       vv(1)=pizda(1,1)+pizda(2,2)
6850       vv(2)=pizda(2,1)-pizda(1,2)
6851       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6852 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6853 #ifdef MOMENT
6854       eello6_graph3=-(s1+s2+s3+s4)
6855 #else
6856       eello6_graph3=-(s2+s3+s4)
6857 #endif
6858 c      eello6_graph3=-s4
6859       if (.not. calc_grad) return
6860 C Derivatives in gamma(k-1)
6861       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
6862       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6863       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
6864       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
6865 C Derivatives in gamma(l-1)
6866       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
6867       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6868       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
6869       vv(1)=pizda(1,1)+pizda(2,2)
6870       vv(2)=pizda(2,1)-pizda(1,2)
6871       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6872       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6873 C Cartesian derivatives.
6874       do iii=1,2
6875         do kkk=1,5
6876           do lll=1,3
6877 #ifdef MOMENT
6878             if (iii.eq.1) then
6879               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
6880             else
6881               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
6882             endif
6883 #endif
6884             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6885      &        auxvec(1))
6886             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6887             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6888      &        auxvec(1))
6889             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6890             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
6891      &        pizda(1,1))
6892             vv(1)=pizda(1,1)+pizda(2,2)
6893             vv(2)=pizda(2,1)-pizda(1,2)
6894             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6895 #ifdef MOMENT
6896             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6897 #else
6898             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6899 #endif
6900             if (swap) then
6901               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6902             else
6903               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6904             endif
6905 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
6906           enddo
6907         enddo
6908       enddo
6909       return
6910       end
6911 c----------------------------------------------------------------------------
6912       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
6913       implicit real*8 (a-h,o-z)
6914       include 'DIMENSIONS'
6915       include 'DIMENSIONS.ZSCOPT'
6916       include 'COMMON.IOUNITS'
6917       include 'COMMON.CHAIN'
6918       include 'COMMON.DERIV'
6919       include 'COMMON.INTERACT'
6920       include 'COMMON.CONTACTS'
6921       include 'COMMON.TORSION'
6922       include 'COMMON.VAR'
6923       include 'COMMON.GEO'
6924       include 'COMMON.FFIELD'
6925       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6926      & auxvec1(2),auxmat1(2,2)
6927       logical swap
6928 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6929 C                                                                              C
6930 C      Parallel       Antiparallel                                             C
6931 C                                                                              C
6932 C          o             o                                                     C
6933 C         /l\   /   \   /j\                                                    C
6934 C        /   \ /     \ /   \                                                   C
6935 C       /| o |o       o| o |\                                                  C
6936 C     \ j|/k\|      \  |/k\|l                                                  C
6937 C      \ /   \       \ /   \                                                   C
6938 C       o     \       o     \                                                  C
6939 C       i             i                                                        C
6940 C                                                                              C
6941 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6942 C
6943 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6944 C           energy moment and not to the cluster cumulant.
6945 cd      write (2,*) 'eello_graph4: wturn6',wturn6
6946       iti=itortyp(itype(i))
6947       itj=itortyp(itype(j))
6948       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6949         itj1=itortyp(itype(j+1))
6950       else
6951         itj1=ntortyp+1
6952       endif
6953       itk=itortyp(itype(k))
6954       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
6955         itk1=itortyp(itype(k+1))
6956       else
6957         itk1=ntortyp+1
6958       endif
6959       itl=itortyp(itype(l))
6960       if (l.lt.nres-1) then
6961         itl1=itortyp(itype(l+1))
6962       else
6963         itl1=ntortyp+1
6964       endif
6965 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
6966 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
6967 cd     & ' itl',itl,' itl1',itl1
6968 #ifdef MOMENT
6969       if (imat.eq.1) then
6970         s1=dip(3,jj,i)*dip(3,kk,k)
6971       else
6972         s1=dip(2,jj,j)*dip(2,kk,l)
6973       endif
6974 #endif
6975       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
6976       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6977       if (j.eq.l+1) then
6978         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
6979         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6980       else
6981         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
6982         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6983       endif
6984       call transpose2(EUg(1,1,k),auxmat(1,1))
6985       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
6986       vv(1)=pizda(1,1)-pizda(2,2)
6987       vv(2)=pizda(2,1)+pizda(1,2)
6988       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6989 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6990 #ifdef MOMENT
6991       eello6_graph4=-(s1+s2+s3+s4)
6992 #else
6993       eello6_graph4=-(s2+s3+s4)
6994 #endif
6995       if (.not. calc_grad) return
6996 C Derivatives in gamma(i-1)
6997       if (i.gt.1) then
6998 #ifdef MOMENT
6999         if (imat.eq.1) then
7000           s1=dipderg(2,jj,i)*dip(3,kk,k)
7001         else
7002           s1=dipderg(4,jj,j)*dip(2,kk,l)
7003         endif
7004 #endif
7005         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7006         if (j.eq.l+1) then
7007           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7008           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7009         else
7010           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7011           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7012         endif
7013         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7014         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7015 cd          write (2,*) 'turn6 derivatives'
7016 #ifdef MOMENT
7017           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7018 #else
7019           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7020 #endif
7021         else
7022 #ifdef MOMENT
7023           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7024 #else
7025           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7026 #endif
7027         endif
7028       endif
7029 C Derivatives in gamma(k-1)
7030 #ifdef MOMENT
7031       if (imat.eq.1) then
7032         s1=dip(3,jj,i)*dipderg(2,kk,k)
7033       else
7034         s1=dip(2,jj,j)*dipderg(4,kk,l)
7035       endif
7036 #endif
7037       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7038       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7039       if (j.eq.l+1) then
7040         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7041         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7042       else
7043         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7044         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7045       endif
7046       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7047       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7048       vv(1)=pizda(1,1)-pizda(2,2)
7049       vv(2)=pizda(2,1)+pizda(1,2)
7050       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7051       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7052 #ifdef MOMENT
7053         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7054 #else
7055         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7056 #endif
7057       else
7058 #ifdef MOMENT
7059         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7060 #else
7061         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7062 #endif
7063       endif
7064 C Derivatives in gamma(j-1) or gamma(l-1)
7065       if (l.eq.j+1 .and. l.gt.1) then
7066         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7067         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7068         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7069         vv(1)=pizda(1,1)-pizda(2,2)
7070         vv(2)=pizda(2,1)+pizda(1,2)
7071         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7072         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7073       else if (j.gt.1) then
7074         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7075         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7076         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7077         vv(1)=pizda(1,1)-pizda(2,2)
7078         vv(2)=pizda(2,1)+pizda(1,2)
7079         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7080         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7081           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7082         else
7083           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7084         endif
7085       endif
7086 C Cartesian derivatives.
7087       do iii=1,2
7088         do kkk=1,5
7089           do lll=1,3
7090 #ifdef MOMENT
7091             if (iii.eq.1) then
7092               if (imat.eq.1) then
7093                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7094               else
7095                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7096               endif
7097             else
7098               if (imat.eq.1) then
7099                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7100               else
7101                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7102               endif
7103             endif
7104 #endif
7105             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7106      &        auxvec(1))
7107             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7108             if (j.eq.l+1) then
7109               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7110      &          b1(1,itj1),auxvec(1))
7111               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7112             else
7113               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7114      &          b1(1,itl1),auxvec(1))
7115               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7116             endif
7117             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7118      &        pizda(1,1))
7119             vv(1)=pizda(1,1)-pizda(2,2)
7120             vv(2)=pizda(2,1)+pizda(1,2)
7121             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7122             if (swap) then
7123               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7124 #ifdef MOMENT
7125                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7126      &             -(s1+s2+s4)
7127 #else
7128                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7129      &             -(s2+s4)
7130 #endif
7131                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7132               else
7133 #ifdef MOMENT
7134                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7135 #else
7136                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7137 #endif
7138                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7139               endif
7140             else
7141 #ifdef MOMENT
7142               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7143 #else
7144               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7145 #endif
7146               if (l.eq.j+1) then
7147                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7148               else
7149                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7150               endif
7151             endif
7152           enddo
7153         enddo
7154       enddo
7155       return
7156       end
7157 c----------------------------------------------------------------------------
7158       double precision function eello_turn6(i,jj,kk)
7159       implicit real*8 (a-h,o-z)
7160       include 'DIMENSIONS'
7161       include 'DIMENSIONS.ZSCOPT'
7162       include 'COMMON.IOUNITS'
7163       include 'COMMON.CHAIN'
7164       include 'COMMON.DERIV'
7165       include 'COMMON.INTERACT'
7166       include 'COMMON.CONTACTS'
7167       include 'COMMON.TORSION'
7168       include 'COMMON.VAR'
7169       include 'COMMON.GEO'
7170       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7171      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7172      &  ggg1(3),ggg2(3)
7173       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7174      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7175 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7176 C           the respective energy moment and not to the cluster cumulant.
7177       eello_turn6=0.0d0
7178       j=i+4
7179       k=i+1
7180       l=i+3
7181       iti=itortyp(itype(i))
7182       itk=itortyp(itype(k))
7183       itk1=itortyp(itype(k+1))
7184       itl=itortyp(itype(l))
7185       itj=itortyp(itype(j))
7186 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7187 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7188 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7189 cd        eello6=0.0d0
7190 cd        return
7191 cd      endif
7192 cd      write (iout,*)
7193 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7194 cd     &   ' and',k,l
7195 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7196       do iii=1,2
7197         do kkk=1,5
7198           do lll=1,3
7199             derx_turn(lll,kkk,iii)=0.0d0
7200           enddo
7201         enddo
7202       enddo
7203 cd      eij=1.0d0
7204 cd      ekl=1.0d0
7205 cd      ekont=1.0d0
7206       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7207 cd      eello6_5=0.0d0
7208 cd      write (2,*) 'eello6_5',eello6_5
7209 #ifdef MOMENT
7210       call transpose2(AEA(1,1,1),auxmat(1,1))
7211       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7212       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7213       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7214 #else
7215       s1 = 0.0d0
7216 #endif
7217       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7218       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7219       s2 = scalar2(b1(1,itk),vtemp1(1))
7220 #ifdef MOMENT
7221       call transpose2(AEA(1,1,2),atemp(1,1))
7222       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7223       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7224       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7225 #else
7226       s8=0.0d0
7227 #endif
7228       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7229       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7230       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7231 #ifdef MOMENT
7232       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7233       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7234       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7235       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7236       ss13 = scalar2(b1(1,itk),vtemp4(1))
7237       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7238 #else
7239       s13=0.0d0
7240 #endif
7241 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7242 c      s1=0.0d0
7243 c      s2=0.0d0
7244 c      s8=0.0d0
7245 c      s12=0.0d0
7246 c      s13=0.0d0
7247       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7248       if (calc_grad) then
7249 C Derivatives in gamma(i+2)
7250 #ifdef MOMENT
7251       call transpose2(AEA(1,1,1),auxmatd(1,1))
7252       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7253       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7254       call transpose2(AEAderg(1,1,2),atempd(1,1))
7255       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7256       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7257 #else
7258       s8d=0.0d0
7259 #endif
7260       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7261       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7262       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7263 c      s1d=0.0d0
7264 c      s2d=0.0d0
7265 c      s8d=0.0d0
7266 c      s12d=0.0d0
7267 c      s13d=0.0d0
7268       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7269 C Derivatives in gamma(i+3)
7270 #ifdef MOMENT
7271       call transpose2(AEA(1,1,1),auxmatd(1,1))
7272       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7273       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7274       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7275 #else
7276       s1d=0.0d0
7277 #endif
7278       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7279       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7280       s2d = scalar2(b1(1,itk),vtemp1d(1))
7281 #ifdef MOMENT
7282       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7283       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7284 #endif
7285       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7286 #ifdef MOMENT
7287       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7288       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7289       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7290 #else
7291       s13d=0.0d0
7292 #endif
7293 c      s1d=0.0d0
7294 c      s2d=0.0d0
7295 c      s8d=0.0d0
7296 c      s12d=0.0d0
7297 c      s13d=0.0d0
7298 #ifdef MOMENT
7299       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7300      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7301 #else
7302       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7303      &               -0.5d0*ekont*(s2d+s12d)
7304 #endif
7305 C Derivatives in gamma(i+4)
7306       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7307       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7308       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7309 #ifdef MOMENT
7310       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7311       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7312       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7313 #else
7314       s13d = 0.0d0
7315 #endif
7316 c      s1d=0.0d0
7317 c      s2d=0.0d0
7318 c      s8d=0.0d0
7319 C      s12d=0.0d0
7320 c      s13d=0.0d0
7321 #ifdef MOMENT
7322       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7323 #else
7324       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7325 #endif
7326 C Derivatives in gamma(i+5)
7327 #ifdef MOMENT
7328       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7329       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7330       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7331 #else
7332       s1d = 0.0d0
7333 #endif
7334       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7335       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7336       s2d = scalar2(b1(1,itk),vtemp1d(1))
7337 #ifdef MOMENT
7338       call transpose2(AEA(1,1,2),atempd(1,1))
7339       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7340       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7341 #else
7342       s8d = 0.0d0
7343 #endif
7344       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7345       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7346 #ifdef MOMENT
7347       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7348       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7349       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7350 #else
7351       s13d = 0.0d0
7352 #endif
7353 c      s1d=0.0d0
7354 c      s2d=0.0d0
7355 c      s8d=0.0d0
7356 c      s12d=0.0d0
7357 c      s13d=0.0d0
7358 #ifdef MOMENT
7359       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7360      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7361 #else
7362       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7363      &               -0.5d0*ekont*(s2d+s12d)
7364 #endif
7365 C Cartesian derivatives
7366       do iii=1,2
7367         do kkk=1,5
7368           do lll=1,3
7369 #ifdef MOMENT
7370             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7371             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7372             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7373 #else
7374             s1d = 0.0d0
7375 #endif
7376             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7377             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7378      &          vtemp1d(1))
7379             s2d = scalar2(b1(1,itk),vtemp1d(1))
7380 #ifdef MOMENT
7381             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7382             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7383             s8d = -(atempd(1,1)+atempd(2,2))*
7384      &           scalar2(cc(1,1,itl),vtemp2(1))
7385 #else
7386             s8d = 0.0d0
7387 #endif
7388             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7389      &           auxmatd(1,1))
7390             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7391             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7392 c      s1d=0.0d0
7393 c      s2d=0.0d0
7394 c      s8d=0.0d0
7395 c      s12d=0.0d0
7396 c      s13d=0.0d0
7397 #ifdef MOMENT
7398             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7399      &        - 0.5d0*(s1d+s2d)
7400 #else
7401             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7402      &        - 0.5d0*s2d
7403 #endif
7404 #ifdef MOMENT
7405             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7406      &        - 0.5d0*(s8d+s12d)
7407 #else
7408             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7409      &        - 0.5d0*s12d
7410 #endif
7411           enddo
7412         enddo
7413       enddo
7414 #ifdef MOMENT
7415       do kkk=1,5
7416         do lll=1,3
7417           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7418      &      achuj_tempd(1,1))
7419           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7420           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7421           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7422           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7423           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7424      &      vtemp4d(1))
7425           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7426           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7427           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7428         enddo
7429       enddo
7430 #endif
7431 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7432 cd     &  16*eel_turn6_num
7433 cd      goto 1112
7434       if (j.lt.nres-1) then
7435         j1=j+1
7436         j2=j-1
7437       else
7438         j1=j-1
7439         j2=j-2
7440       endif
7441       if (l.lt.nres-1) then
7442         l1=l+1
7443         l2=l-1
7444       else
7445         l1=l-1
7446         l2=l-2
7447       endif
7448       do ll=1,3
7449         ggg1(ll)=eel_turn6*g_contij(ll,1)
7450         ggg2(ll)=eel_turn6*g_contij(ll,2)
7451         ghalf=0.5d0*ggg1(ll)
7452 cd        ghalf=0.0d0
7453         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7454      &    +ekont*derx_turn(ll,2,1)
7455         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7456         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7457      &    +ekont*derx_turn(ll,4,1)
7458         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7459         ghalf=0.5d0*ggg2(ll)
7460 cd        ghalf=0.0d0
7461         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7462      &    +ekont*derx_turn(ll,2,2)
7463         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7464         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7465      &    +ekont*derx_turn(ll,4,2)
7466         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7467       enddo
7468 cd      goto 1112
7469       do m=i+1,j-1
7470         do ll=1,3
7471           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7472         enddo
7473       enddo
7474       do m=k+1,l-1
7475         do ll=1,3
7476           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7477         enddo
7478       enddo
7479 1112  continue
7480       do m=i+2,j2
7481         do ll=1,3
7482           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7483         enddo
7484       enddo
7485       do m=k+2,l2
7486         do ll=1,3
7487           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7488         enddo
7489       enddo
7490 cd      do iii=1,nres-3
7491 cd        write (2,*) iii,g_corr6_loc(iii)
7492 cd      enddo
7493       endif
7494       eello_turn6=ekont*eel_turn6
7495 cd      write (2,*) 'ekont',ekont
7496 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7497       return
7498       end
7499 crc-------------------------------------------------
7500       SUBROUTINE MATVEC2(A1,V1,V2)
7501       implicit real*8 (a-h,o-z)
7502       include 'DIMENSIONS'
7503       DIMENSION A1(2,2),V1(2),V2(2)
7504 c      DO 1 I=1,2
7505 c        VI=0.0
7506 c        DO 3 K=1,2
7507 c    3     VI=VI+A1(I,K)*V1(K)
7508 c        Vaux(I)=VI
7509 c    1 CONTINUE
7510
7511       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7512       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7513
7514       v2(1)=vaux1
7515       v2(2)=vaux2
7516       END
7517 C---------------------------------------
7518       SUBROUTINE MATMAT2(A1,A2,A3)
7519       implicit real*8 (a-h,o-z)
7520       include 'DIMENSIONS'
7521       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7522 c      DIMENSION AI3(2,2)
7523 c        DO  J=1,2
7524 c          A3IJ=0.0
7525 c          DO K=1,2
7526 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7527 c          enddo
7528 c          A3(I,J)=A3IJ
7529 c       enddo
7530 c      enddo
7531
7532       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7533       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7534       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7535       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7536
7537       A3(1,1)=AI3_11
7538       A3(2,1)=AI3_21
7539       A3(1,2)=AI3_12
7540       A3(2,2)=AI3_22
7541       END
7542
7543 c-------------------------------------------------------------------------
7544       double precision function scalar2(u,v)
7545       implicit none
7546       double precision u(2),v(2)
7547       double precision sc
7548       integer i
7549       scalar2=u(1)*v(1)+u(2)*v(2)
7550       return
7551       end
7552
7553 C-----------------------------------------------------------------------------
7554
7555       subroutine transpose2(a,at)
7556       implicit none
7557       double precision a(2,2),at(2,2)
7558       at(1,1)=a(1,1)
7559       at(1,2)=a(2,1)
7560       at(2,1)=a(1,2)
7561       at(2,2)=a(2,2)
7562       return
7563       end
7564 c--------------------------------------------------------------------------
7565       subroutine transpose(n,a,at)
7566       implicit none
7567       integer n,i,j
7568       double precision a(n,n),at(n,n)
7569       do i=1,n
7570         do j=1,n
7571           at(j,i)=a(i,j)
7572         enddo
7573       enddo
7574       return
7575       end
7576 C---------------------------------------------------------------------------
7577       subroutine prodmat3(a1,a2,kk,transp,prod)
7578       implicit none
7579       integer i,j
7580       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7581       logical transp
7582 crc      double precision auxmat(2,2),prod_(2,2)
7583
7584       if (transp) then
7585 crc        call transpose2(kk(1,1),auxmat(1,1))
7586 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7587 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7588
7589            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7590      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7591            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7592      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7593            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7594      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7595            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7596      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7597
7598       else
7599 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7600 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7601
7602            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7603      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7604            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7605      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7606            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7607      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7608            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7609      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7610
7611       endif
7612 c      call transpose2(a2(1,1),a2t(1,1))
7613
7614 crc      print *,transp
7615 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7616 crc      print *,((prod(i,j),i=1,2),j=1,2)
7617
7618       return
7619       end
7620 C-----------------------------------------------------------------------------
7621       double precision function scalar(u,v)
7622       implicit none
7623       double precision u(3),v(3)
7624       double precision sc
7625       integer i
7626       sc=0.0d0
7627       do i=1,3
7628         sc=sc+u(i)*v(i)
7629       enddo
7630       scalar=sc
7631       return
7632       end
7633