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