source/wham/src-M/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       double precision fact(6)
  26 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw,evdw_t)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw,evdw_t)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw,evdw_t)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw,evdw_t)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw,evdw_t)
  47 C      write(iout,*) 'po elektostatyce'
  48 C
  49 C Calculate electrostatic (H-bonding) energy of the main chain.
  50 C
  51   106  call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  52 C            write(iout,*) 'po eelec'
  53
  54 C Calculate excluded-volume interaction energy between peptide groups
  55 C and side chains.
  56 C
  57       call escp(evdw2,evdw2_14)
  58 c
  59 c Calculate the bond-stretching energy
  60 c
  61
  62       call ebond(estr)
  63 C       write (iout,*) "estr",estr
  64 C
  65 C Calculate the disulfide-bridge and other energy and the contributions
  66 C from other distance constraints.
  67 cd    print *,'Calling EHPB'
  68       call edis(ehpb)
  69 cd    print *,'EHPB exitted succesfully.'
  70 C
  71 C Calculate the virtual-bond-angle energy.
  72 C
  73 C      print *,'Bend energy finished.'
  74       call ebend(ebe,ethetacnstr)
  75 cd    print *,'Bend energy finished.'
  76 C
  77 C Calculate the SC local energy.
  78 C
  79       call esc(escloc)
  80 C       print *,'SCLOC energy finished.'
  81 C
  82 C Calculate the virtual-bond torsional energy.
  83 C
  84 cd    print *,'nterm=',nterm
  85       call etor(etors,edihcnstr,fact(1))
  86 C
  87 C 6/23/01 Calculate double-torsional energy
  88 C
  89       call etor_d(etors_d,fact(2))
  90 C
  91 C 21/5/07 Calculate local sicdechain correlation energy
  92 C
  93       call eback_sc_corr(esccor)
  94 C
  95 C 12/1/95 Multi-body terms
  96 C
  97       n_corr=0
  98       n_corr1=0
  99       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 100      &    .or. wturn6.gt.0.0d0) then
 101 c         print *,"calling multibody_eello"
 102          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 103 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 104 c         print *,ecorr,ecorr5,ecorr6,eturn6
 105       endif
 106       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 107          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 108       endif
 109 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 110 #ifdef SPLITELE
 111       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 112      & +wvdwpp*evdw1
 113      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 114      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 115      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 116      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 117      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 118      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 119 #else
 120       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 121      & +welec*fact(1)*(ees+evdw1)
 122      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 123      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 124      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 125      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 126      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 127      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 128 #endif
 129       energia(0)=etot
 130       energia(1)=evdw
 131 #ifdef SCP14
 132       energia(2)=evdw2-evdw2_14
 133       energia(17)=evdw2_14
 134 #else
 135       energia(2)=evdw2
 136       energia(17)=0.0d0
 137 #endif
 138 #ifdef SPLITELE
 139       energia(3)=ees
 140       energia(16)=evdw1
 141 #else
 142       energia(3)=ees+evdw1
 143       energia(16)=0.0d0
 144 #endif
 145       energia(4)=ecorr
 146       energia(5)=ecorr5
 147       energia(6)=ecorr6
 148       energia(7)=eel_loc
 149       energia(8)=eello_turn3
 150       energia(9)=eello_turn4
 151       energia(10)=eturn6
 152       energia(11)=ebe
 153       energia(12)=escloc
 154       energia(13)=etors
 155       energia(14)=etors_d
 156       energia(15)=ehpb
 157       energia(18)=estr
 158       energia(19)=esccor
 159       energia(20)=edihcnstr
 160       energia(21)=evdw_t
 161       energia(24)=ethetacnstr
 162 c detecting NaNQ
 163 #ifdef ISNAN
 164 #ifdef AIX
 165       if (isnan(etot).ne.0) energia(0)=1.0d+99
 166 #else
 167       if (isnan(etot)) energia(0)=1.0d+99
 168 #endif
 169 #else
 170       i=0
 171 #ifdef WINPGI
 172       idumm=proc_proc(etot,i)
 173 #else
 174       call proc_proc(etot,i)
 175 #endif
 176       if(i.eq.1)energia(0)=1.0d+99
 177 #endif
 178 #ifdef MPL
 179 c     endif
 180 #endif
 181       if (calc_grad) then
 182 C
 183 C Sum up the components of the Cartesian gradient.
 184 C
 185 #ifdef SPLITELE
 186       do i=1,nct
 187         do j=1,3
 188           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 189      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 190      &                wbond*gradb(j,i)+
 191      &                wstrain*ghpbc(j,i)+
 192      &                wcorr*fact(3)*gradcorr(j,i)+
 193      &                wel_loc*fact(2)*gel_loc(j,i)+
 194      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 195      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 196      &                wcorr5*fact(4)*gradcorr5(j,i)+
 197      &                wcorr6*fact(5)*gradcorr6(j,i)+
 198      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 199      &                wsccor*fact(2)*gsccorc(j,i)
 200           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 201      &                  wbond*gradbx(j,i)+
 202      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 203      &                  wsccor*fact(2)*gsccorx(j,i)
 204         enddo
 205 #else
 206       do i=1,nct
 207         do j=1,3
 208           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 209      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 210      &                wbond*gradb(j,i)+
 211      &                wcorr*fact(3)*gradcorr(j,i)+
 212      &                wel_loc*fact(2)*gel_loc(j,i)+
 213      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 214      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 215      &                wcorr5*fact(4)*gradcorr5(j,i)+
 216      &                wcorr6*fact(5)*gradcorr6(j,i)+
 217      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 218      &                wsccor*fact(2)*gsccorc(j,i)
 219           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 220      &                  wbond*gradbx(j,i)+
 221      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 222      &                  wsccor*fact(1)*gsccorx(j,i)
 223         enddo
 224 #endif
 225       enddo
 226
 227
 228       do i=1,nres-3
 229         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 230      &   +wcorr5*fact(4)*g_corr5_loc(i)
 231      &   +wcorr6*fact(5)*g_corr6_loc(i)
 232      &   +wturn4*fact(3)*gel_loc_turn4(i)
 233      &   +wturn3*fact(2)*gel_loc_turn3(i)
 234      &   +wturn6*fact(5)*gel_loc_turn6(i)
 235      &   +wel_loc*fact(2)*gel_loc_loc(i)
 236 c     &   +wsccor*fact(1)*gsccor_loc(i)
 237 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 238       enddo
 239       endif
 240       if (dyn_ss) call dyn_set_nss
 241       return
 242       end
 243 C------------------------------------------------------------------------
 244       subroutine enerprint(energia,fact)
 245       implicit real*8 (a-h,o-z)
 246       include 'DIMENSIONS'
 247       include 'DIMENSIONS.ZSCOPT'
 248       include 'COMMON.IOUNITS'
 249       include 'COMMON.FFIELD'
 250       include 'COMMON.SBRIDGE'
 251       double precision energia(0:max_ene),fact(6)
 252       etot=energia(0)
 253       evdw=energia(1)+fact(6)*energia(21)
 254 #ifdef SCP14
 255       evdw2=energia(2)+energia(17)
 256 #else
 257       evdw2=energia(2)
 258 #endif
 259       ees=energia(3)
 260 #ifdef SPLITELE
 261       evdw1=energia(16)
 262 #endif
 263       ecorr=energia(4)
 264       ecorr5=energia(5)
 265       ecorr6=energia(6)
 266       eel_loc=energia(7)
 267       eello_turn3=energia(8)
 268       eello_turn4=energia(9)
 269       eello_turn6=energia(10)
 270       ebe=energia(11)
 271       escloc=energia(12)
 272       etors=energia(13)
 273       etors_d=energia(14)
 274       ehpb=energia(15)
 275       esccor=energia(19)
 276       edihcnstr=energia(20)
 277       estr=energia(18)
 278       ethetacnstr=energia(24)
 279 #ifdef SPLITELE
 280       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 281      &  wvdwpp,
 282      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 283      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 284      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 285      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 286      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 287      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,etot
 288    10 format (/'Virtual-chain energies:'//
 289      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 290      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 291      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 292      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 293      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 294      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 295      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 296      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 297      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 298      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 299      & ' (SS bridges & dist. cnstr.)'/
 300      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 301      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 302      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 303      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 304      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 305      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 306      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 307      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 308      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 309      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 310      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 311      & 'ETOT=  ',1pE16.6,' (total)')
 312 #else
 313       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 314      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 315      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 316      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 317      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 318      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 319      &  edihcnstr,ethetacnstr,ebr*nss,etot
 320    10 format (/'Virtual-chain energies:'//
 321      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 322      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 323      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 324      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 325      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 326      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 327      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 328      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 329      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 330      & ' (SS bridges & dist. cnstr.)'/
 331      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 332      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 333      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 334      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 335      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 336      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 337      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 338      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 339      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 340      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 341      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 342      & 'ETOT=  ',1pE16.6,' (total)')
 343 #endif
 344       return
 345       end
 346 C-----------------------------------------------------------------------
 347       subroutine elj(evdw,evdw_t)
 348 C
 349 C This subroutine calculates the interaction energy of nonbonded side chains
 350 C assuming the LJ potential of interaction.
 351 C
 352       implicit real*8 (a-h,o-z)
 353       include 'DIMENSIONS'
 354       include 'DIMENSIONS.ZSCOPT'
 355       include "DIMENSIONS.COMPAR"
 356       parameter (accur=1.0d-10)
 357       include 'COMMON.GEO'
 358       include 'COMMON.VAR'
 359       include 'COMMON.LOCAL'
 360       include 'COMMON.CHAIN'
 361       include 'COMMON.DERIV'
 362       include 'COMMON.INTERACT'
 363       include 'COMMON.TORSION'
 364       include 'COMMON.ENEPS'
 365       include 'COMMON.SBRIDGE'
 366       include 'COMMON.NAMES'
 367       include 'COMMON.IOUNITS'
 368       include 'COMMON.CONTACTS'
 369       dimension gg(3)
 370       integer icant
 371       external icant
 372 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 373 c ROZNICA z cluster
 374       do i=1,210
 375         do j=1,2
 376           eneps_temp(j,i)=0.0d0
 377         enddo
 378       enddo
 379 cROZNICA
 380
 381       evdw=0.0D0
 382       evdw_t=0.0d0
 383       do i=iatsc_s,iatsc_e
 384         itypi=iabs(itype(i))
 385         if (itypi.eq.ntyp1) cycle
 386         itypi1=iabs(itype(i+1))
 387         xi=c(1,nres+i)
 388         yi=c(2,nres+i)
 389         zi=c(3,nres+i)
 390 C Change 12/1/95
 391         num_conti=0
 392 C
 393 C Calculate SC interaction energy.
 394 C
 395         do iint=1,nint_gr(i)
 396 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 397 cd   &                  'iend=',iend(i,iint)
 398           do j=istart(i,iint),iend(i,iint)
 399             itypj=iabs(itype(j))
 400             if (itypj.eq.ntyp1) cycle
 401             xj=c(1,nres+j)-xi
 402             yj=c(2,nres+j)-yi
 403             zj=c(3,nres+j)-zi
 404 C Change 12/1/95 to calculate four-body interactions
 405             rij=xj*xj+yj*yj+zj*zj
 406             rrij=1.0D0/rij
 407 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 408             eps0ij=eps(itypi,itypj)
 409             fac=rrij**expon2
 410             e1=fac*fac*aa(itypi,itypj)
 411             e2=fac*bb(itypi,itypj)
 412             evdwij=e1+e2
 413             ij=icant(itypi,itypj)
 414 c ROZNICA z cluster
 415             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 416             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 417 c
 418
 419 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 420 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 421 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 422 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 423 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 424 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 425             if (bb(itypi,itypj).gt.0.0d0) then
 426               evdw=evdw+evdwij
 427             else
 428               evdw_t=evdw_t+evdwij
 429             endif
 430             if (calc_grad) then
 431 C
 432 C Calculate the components of the gradient in DC and X
 433 C
 434             fac=-rrij*(e1+evdwij)
 435             gg(1)=xj*fac
 436             gg(2)=yj*fac
 437             gg(3)=zj*fac
 438             do k=1,3
 439               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 440               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 441             enddo
 442             do k=i,j-1
 443               do l=1,3
 444                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 445               enddo
 446             enddo
 447             endif
 448 C
 449 C 12/1/95, revised on 5/20/97
 450 C
 451 C Calculate the contact function. The ith column of the array JCONT will
 452 C contain the numbers of atoms that make contacts with the atom I (of numbers
 453 C greater than I). The arrays FACONT and GACONT will contain the values of
 454 C the contact function and its derivative.
 455 C
 456 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 457 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 458 C Uncomment next line, if the correlation interactions are contact function only
 459             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 460               rij=dsqrt(rij)
 461               sigij=sigma(itypi,itypj)
 462               r0ij=rs0(itypi,itypj)
 463 C
 464 C Check whether the SC's are not too far to make a contact.
 465 C
 466               rcut=1.5d0*r0ij
 467               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 468 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 469 C
 470               if (fcont.gt.0.0D0) then
 471 C If the SC-SC distance if close to sigma, apply spline.
 472 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 473 cAdam &             fcont1,fprimcont1)
 474 cAdam           fcont1=1.0d0-fcont1
 475 cAdam           if (fcont1.gt.0.0d0) then
 476 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 477 cAdam             fcont=fcont*fcont1
 478 cAdam           endif
 479 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 480 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 481 cga             do k=1,3
 482 cga               gg(k)=gg(k)*eps0ij
 483 cga             enddo
 484 cga             eps0ij=-evdwij*eps0ij
 485 C Uncomment for AL's type of SC correlation interactions.
 486 cadam           eps0ij=-evdwij
 487                 num_conti=num_conti+1
 488                 jcont(num_conti,i)=j
 489                 facont(num_conti,i)=fcont*eps0ij
 490                 fprimcont=eps0ij*fprimcont/rij
 491                 fcont=expon*fcont
 492 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 493 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 494 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 495 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 496                 gacont(1,num_conti,i)=-fprimcont*xj
 497                 gacont(2,num_conti,i)=-fprimcont*yj
 498                 gacont(3,num_conti,i)=-fprimcont*zj
 499 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 500 cd              write (iout,'(2i3,3f10.5)')
 501 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 502               endif
 503             endif
 504           enddo      ! j
 505         enddo        ! iint
 506 C Change 12/1/95
 507         num_cont(i)=num_conti
 508       enddo          ! i
 509       if (calc_grad) then
 510       do i=1,nct
 511         do j=1,3
 512           gvdwc(j,i)=expon*gvdwc(j,i)
 513           gvdwx(j,i)=expon*gvdwx(j,i)
 514         enddo
 515       enddo
 516       endif
 517 C******************************************************************************
 518 C
 519 C                              N O T E !!!
 520 C
 521 C To save time, the factor of EXPON has been extracted from ALL components
 522 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 523 C use!
 524 C
 525 C******************************************************************************
 526       return
 527       end
 528 C-----------------------------------------------------------------------------
 529       subroutine eljk(evdw,evdw_t)
 530 C
 531 C This subroutine calculates the interaction energy of nonbonded side chains
 532 C assuming the LJK potential of interaction.
 533 C
 534       implicit real*8 (a-h,o-z)
 535       include 'DIMENSIONS'
 536       include 'DIMENSIONS.ZSCOPT'
 537       include "DIMENSIONS.COMPAR"
 538       include 'COMMON.GEO'
 539       include 'COMMON.VAR'
 540       include 'COMMON.LOCAL'
 541       include 'COMMON.CHAIN'
 542       include 'COMMON.DERIV'
 543       include 'COMMON.INTERACT'
 544       include 'COMMON.ENEPS'
 545       include 'COMMON.IOUNITS'
 546       include 'COMMON.NAMES'
 547       dimension gg(3)
 548       logical scheck
 549       integer icant
 550       external icant
 551 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 552       do i=1,210
 553         do j=1,2
 554           eneps_temp(j,i)=0.0d0
 555         enddo
 556       enddo
 557       evdw=0.0D0
 558       evdw_t=0.0d0
 559       do i=iatsc_s,iatsc_e
 560         itypi=iabs(itype(i))
 561         if (itypi.eq.ntyp1) cycle
 562         itypi1=iabs(itype(i+1))
 563         xi=c(1,nres+i)
 564         yi=c(2,nres+i)
 565         zi=c(3,nres+i)
 566 C
 567 C Calculate SC interaction energy.
 568 C
 569         do iint=1,nint_gr(i)
 570           do j=istart(i,iint),iend(i,iint)
 571             itypj=iabs(itype(j))
 572             if (itypj.eq.ntyp1) cycle
 573             xj=c(1,nres+j)-xi
 574             yj=c(2,nres+j)-yi
 575             zj=c(3,nres+j)-zi
 576             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 577             fac_augm=rrij**expon
 578             e_augm=augm(itypi,itypj)*fac_augm
 579             r_inv_ij=dsqrt(rrij)
 580             rij=1.0D0/r_inv_ij
 581             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 582             fac=r_shift_inv**expon
 583             e1=fac*fac*aa(itypi,itypj)
 584             e2=fac*bb(itypi,itypj)
 585             evdwij=e_augm+e1+e2
 586             ij=icant(itypi,itypj)
 587             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 588      &        /dabs(eps(itypi,itypj))
 589             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 590 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 591 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 592 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 593 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 594 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 595 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 596 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 597             if (bb(itypi,itypj).gt.0.0d0) then
 598               evdw=evdw+evdwij
 599             else
 600               evdw_t=evdw_t+evdwij
 601             endif
 602             if (calc_grad) then
 603 C
 604 C Calculate the components of the gradient in DC and X
 605 C
 606             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 607             gg(1)=xj*fac
 608             gg(2)=yj*fac
 609             gg(3)=zj*fac
 610             do k=1,3
 611               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 612               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 613             enddo
 614             do k=i,j-1
 615               do l=1,3
 616                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 617               enddo
 618             enddo
 619             endif
 620           enddo      ! j
 621         enddo        ! iint
 622       enddo          ! i
 623       if (calc_grad) then
 624       do i=1,nct
 625         do j=1,3
 626           gvdwc(j,i)=expon*gvdwc(j,i)
 627           gvdwx(j,i)=expon*gvdwx(j,i)
 628         enddo
 629       enddo
 630       endif
 631       return
 632       end
 633 C-----------------------------------------------------------------------------
 634       subroutine ebp(evdw,evdw_t)
 635 C
 636 C This subroutine calculates the interaction energy of nonbonded side chains
 637 C assuming the Berne-Pechukas potential of interaction.
 638 C
 639       implicit real*8 (a-h,o-z)
 640       include 'DIMENSIONS'
 641       include 'DIMENSIONS.ZSCOPT'
 642       include "DIMENSIONS.COMPAR"
 643       include 'COMMON.GEO'
 644       include 'COMMON.VAR'
 645       include 'COMMON.LOCAL'
 646       include 'COMMON.CHAIN'
 647       include 'COMMON.DERIV'
 648       include 'COMMON.NAMES'
 649       include 'COMMON.INTERACT'
 650       include 'COMMON.ENEPS'
 651       include 'COMMON.IOUNITS'
 652       include 'COMMON.CALC'
 653       common /srutu/ icall
 654 c     double precision rrsave(maxdim)
 655       logical lprn
 656       integer icant
 657       external icant
 658       do i=1,210
 659         do j=1,2
 660           eneps_temp(j,i)=0.0d0
 661         enddo
 662       enddo
 663       evdw=0.0D0
 664       evdw_t=0.0d0
 665 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 666 c     if (icall.eq.0) then
 667 c       lprn=.true.
 668 c     else
 669         lprn=.false.
 670 c     endif
 671       ind=0
 672       do i=iatsc_s,iatsc_e
 673         itypi=iabs(itype(i))
 674         if (itypi.eq.ntyp1) cycle
 675         itypi1=iabs(itype(i+1))
 676         xi=c(1,nres+i)
 677         yi=c(2,nres+i)
 678         zi=c(3,nres+i)
 679         dxi=dc_norm(1,nres+i)
 680         dyi=dc_norm(2,nres+i)
 681         dzi=dc_norm(3,nres+i)
 682         dsci_inv=vbld_inv(i+nres)
 683 C
 684 C Calculate SC interaction energy.
 685 C
 686         do iint=1,nint_gr(i)
 687           do j=istart(i,iint),iend(i,iint)
 688             ind=ind+1
 689             itypj=iabs(itype(j))
 690             if (itypj.eq.ntyp1) cycle
 691             dscj_inv=vbld_inv(j+nres)
 692             chi1=chi(itypi,itypj)
 693             chi2=chi(itypj,itypi)
 694             chi12=chi1*chi2
 695             chip1=chip(itypi)
 696             chip2=chip(itypj)
 697             chip12=chip1*chip2
 698             alf1=alp(itypi)
 699             alf2=alp(itypj)
 700             alf12=0.5D0*(alf1+alf2)
 701 C For diagnostics only!!!
 702 c           chi1=0.0D0
 703 c           chi2=0.0D0
 704 c           chi12=0.0D0
 705 c           chip1=0.0D0
 706 c           chip2=0.0D0
 707 c           chip12=0.0D0
 708 c           alf1=0.0D0
 709 c           alf2=0.0D0
 710 c           alf12=0.0D0
 711             xj=c(1,nres+j)-xi
 712             yj=c(2,nres+j)-yi
 713             zj=c(3,nres+j)-zi
 714             dxj=dc_norm(1,nres+j)
 715             dyj=dc_norm(2,nres+j)
 716             dzj=dc_norm(3,nres+j)
 717             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 718 cd          if (icall.eq.0) then
 719 cd            rrsave(ind)=rrij
 720 cd          else
 721 cd            rrij=rrsave(ind)
 722 cd          endif
 723             rij=dsqrt(rrij)
 724 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 725             call sc_angular
 726 C Calculate whole angle-dependent part of epsilon and contributions
 727 C to its derivatives
 728             fac=(rrij*sigsq)**expon2
 729             e1=fac*fac*aa(itypi,itypj)
 730             e2=fac*bb(itypi,itypj)
 731             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 732             eps2der=evdwij*eps3rt
 733             eps3der=evdwij*eps2rt
 734             evdwij=evdwij*eps2rt*eps3rt
 735             ij=icant(itypi,itypj)
 736             aux=eps1*eps2rt**2*eps3rt**2
 737             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 738      &        /dabs(eps(itypi,itypj))
 739             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 740             if (bb(itypi,itypj).gt.0.0d0) then
 741               evdw=evdw+evdwij
 742             else
 743               evdw_t=evdw_t+evdwij
 744             endif
 745             if (calc_grad) then
 746             if (lprn) then
 747             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 748             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 749             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 750      &        restyp(itypi),i,restyp(itypj),j,
 751      &        epsi,sigm,chi1,chi2,chip1,chip2,
 752      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 753      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 754      &        evdwij
 755             endif
 756 C Calculate gradient components.
 757             e1=e1*eps1*eps2rt**2*eps3rt**2
 758             fac=-expon*(e1+evdwij)
 759             sigder=fac/sigsq
 760             fac=rrij*fac
 761 C Calculate radial part of the gradient
 762             gg(1)=xj*fac
 763             gg(2)=yj*fac
 764             gg(3)=zj*fac
 765 C Calculate the angular part of the gradient and sum add the contributions
 766 C to the appropriate components of the Cartesian gradient.
 767             call sc_grad
 768             endif
 769           enddo      ! j
 770         enddo        ! iint
 771       enddo          ! i
 772 c     stop
 773       return
 774       end
 775 C-----------------------------------------------------------------------------
 776       subroutine egb(evdw,evdw_t)
 777 C
 778 C This subroutine calculates the interaction energy of nonbonded side chains
 779 C assuming the Gay-Berne potential of interaction.
 780 C
 781       implicit real*8 (a-h,o-z)
 782       include 'DIMENSIONS'
 783       include 'DIMENSIONS.ZSCOPT'
 784       include "DIMENSIONS.COMPAR"
 785       include 'COMMON.GEO'
 786       include 'COMMON.VAR'
 787       include 'COMMON.LOCAL'
 788       include 'COMMON.CHAIN'
 789       include 'COMMON.DERIV'
 790       include 'COMMON.NAMES'
 791       include 'COMMON.INTERACT'
 792       include 'COMMON.ENEPS'
 793       include 'COMMON.IOUNITS'
 794       include 'COMMON.CALC'
 795       include 'COMMON.SBRIDGE'
 796       logical lprn
 797       common /srutu/icall
 798       integer icant
 799       external icant
 800       do i=1,210
 801         do j=1,2
 802           eneps_temp(j,i)=0.0d0
 803         enddo
 804       enddo
 805 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 806       evdw=0.0D0
 807       evdw_t=0.0d0
 808       lprn=.false.
 809 c      if (icall.gt.0) lprn=.true.
 810       ind=0
 811       do i=iatsc_s,iatsc_e
 812         itypi=iabs(itype(i))
 813         if (itypi.eq.ntyp1) cycle
 814         itypi1=iabs(itype(i+1))
 815         xi=c(1,nres+i)
 816         yi=c(2,nres+i)
 817         zi=c(3,nres+i)
 818 C returning the ith atom to box
 819           xi=mod(xi,boxxsize)
 820           if (xi.lt.0) xi=xi+boxxsize
 821           yi=mod(yi,boxysize)
 822           if (yi.lt.0) yi=yi+boxysize
 823           zi=mod(zi,boxzsize)
 824           if (zi.lt.0) zi=zi+boxzsize
 825
 826         dxi=dc_norm(1,nres+i)
 827         dyi=dc_norm(2,nres+i)
 828         dzi=dc_norm(3,nres+i)
 829         dsci_inv=vbld_inv(i+nres)
 830 C
 831 C Calculate SC interaction energy.
 832 C
 833         do iint=1,nint_gr(i)
 834           do j=istart(i,iint),iend(i,iint)
 835             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 836               call dyn_ssbond_ene(i,j,evdwij)
 837               evdw=evdw+evdwij
 838 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 839 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
 840 C triple bond artifac removal
 841              do k=j+1,iend(i,iint)
 842 C search over all next residues
 843               if (dyn_ss_mask(k)) then
 844 C check if they are cysteins
 845 C              write(iout,*) 'k=',k
 846               call triple_ssbond_ene(i,j,k,evdwij)
 847 C call the energy function that removes the artifical triple disulfide
 848 C bond the soubroutine is located in ssMD.F
 849               evdw=evdw+evdwij
 850 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 851 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
 852               endif!dyn_ss_mask(k)
 853              enddo! k
 854             ELSE
 855             ind=ind+1
 856             itypj=iabs(itype(j))
 857             if (itypj.eq.ntyp1) cycle
 858             dscj_inv=vbld_inv(j+nres)
 859             sig0ij=sigma(itypi,itypj)
 860             chi1=chi(itypi,itypj)
 861             chi2=chi(itypj,itypi)
 862             chi12=chi1*chi2
 863             chip1=chip(itypi)
 864             chip2=chip(itypj)
 865             chip12=chip1*chip2
 866             alf1=alp(itypi)
 867             alf2=alp(itypj)
 868             alf12=0.5D0*(alf1+alf2)
 869 C For diagnostics only!!!
 870 c           chi1=0.0D0
 871 c           chi2=0.0D0
 872 c           chi12=0.0D0
 873 c           chip1=0.0D0
 874 c           chip2=0.0D0
 875 c           chip12=0.0D0
 876 c           alf1=0.0D0
 877 c           alf2=0.0D0
 878 c           alf12=0.0D0
 879             xj=c(1,nres+j)
 880             yj=c(2,nres+j)
 881             zj=c(3,nres+j)
 882 C returning jth atom to box
 883           xj=mod(xj,boxxsize)
 884           if (xj.lt.0) xj=xj+boxxsize
 885           yj=mod(yj,boxysize)
 886           if (yj.lt.0) yj=yj+boxysize
 887           zj=mod(zj,boxzsize)
 888           if (zj.lt.0) zj=zj+boxzsize
 889 C checking the distance
 890       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 891       xj_safe=xj
 892       yj_safe=yj
 893       zj_safe=zj
 894       subchap=0
 895 C finding the closest
 896       do xshift=-1,1
 897       do yshift=-1,1
 898       do zshift=-1,1
 899           xj=xj_safe+xshift*boxxsize
 900           yj=yj_safe+yshift*boxysize
 901           zj=zj_safe+zshift*boxzsize
 902           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 903           if(dist_temp.lt.dist_init) then
 904             dist_init=dist_temp
 905             xj_temp=xj
 906             yj_temp=yj
 907             zj_temp=zj
 908             subchap=1
 909           endif
 910        enddo
 911        enddo
 912        enddo
 913        if (subchap.eq.1) then
 914           xj=xj_temp-xi
 915           yj=yj_temp-yi
 916           zj=zj_temp-zi
 917        else
 918           xj=xj_safe-xi
 919           yj=yj_safe-yi
 920           zj=zj_safe-zi
 921        endif
 922
 923             dxj=dc_norm(1,nres+j)
 924             dyj=dc_norm(2,nres+j)
 925             dzj=dc_norm(3,nres+j)
 926 c            write (iout,*) i,j,xj,yj,zj
 927             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 928             rij=dsqrt(rrij)
 929             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
 930             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
 931             if (sss.le.0.0) cycle
 932 C Calculate angle-dependent terms of energy and contributions to their
 933 C derivatives.
 934             call sc_angular
 935             sigsq=1.0D0/sigsq
 936             sig=sig0ij*dsqrt(sigsq)
 937             rij_shift=1.0D0/rij-sig+sig0ij
 938 C I hate to put IF's in the loops, but here don't have another choice!!!!
 939             if (rij_shift.le.0.0D0) then
 940               evdw=1.0D20
 941               return
 942             endif
 943             sigder=-sig*sigsq
 944 c---------------------------------------------------------------
 945             rij_shift=1.0D0/rij_shift
 946             fac=rij_shift**expon
 947             e1=fac*fac*aa(itypi,itypj)
 948             e2=fac*bb(itypi,itypj)
 949             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 950             eps2der=evdwij*eps3rt
 951             eps3der=evdwij*eps2rt
 952             evdwij=evdwij*eps2rt*eps3rt
 953             if (bb(itypi,itypj).gt.0) then
 954               evdw=evdw+evdwij*sss
 955             else
 956               evdw_t=evdw_t+evdwij*sss
 957             endif
 958             ij=icant(itypi,itypj)
 959             aux=eps1*eps2rt**2*eps3rt**2
 960             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 961      &        /dabs(eps(itypi,itypj))
 962             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 963 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 964 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 965 c     &         aux*e2/eps(itypi,itypj)
 966 c            if (lprn) then
 967             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 968             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 969 #ifdef DEBUG
 970             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 971      &        restyp(itypi),i,restyp(itypj),j,
 972      &        epsi,sigm,chi1,chi2,chip1,chip2,
 973      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 974      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 975      &        evdwij
 976              write (iout,*) "partial sum", evdw, evdw_t
 977 #endif
 978 c            endif
 979             if (calc_grad) then
 980 C Calculate gradient components.
 981             e1=e1*eps1*eps2rt**2*eps3rt**2
 982             fac=-expon*(e1+evdwij)*rij_shift
 983             sigder=fac*sigder
 984             fac=rij*fac
 985             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
 986 C Calculate the radial part of the gradient
 987             gg(1)=xj*fac
 988             gg(2)=yj*fac
 989             gg(3)=zj*fac
 990 C Calculate angular part of the gradient.
 991             call sc_grad
 992             endif
 993 C            write(iout,*)  "partial sum", evdw, evdw_t
 994             ENDIF    ! dyn_ss
 995           enddo      ! j
 996         enddo        ! iint
 997       enddo          ! i
 998       return
 999       end
1000 C-----------------------------------------------------------------------------
1001       subroutine egbv(evdw,evdw_t)
1002 C
1003 C This subroutine calculates the interaction energy of nonbonded side chains
1004 C assuming the Gay-Berne-Vorobjev potential of interaction.
1005 C
1006       implicit real*8 (a-h,o-z)
1007       include 'DIMENSIONS'
1008       include 'DIMENSIONS.ZSCOPT'
1009       include "DIMENSIONS.COMPAR"
1010       include 'COMMON.GEO'
1011       include 'COMMON.VAR'
1012       include 'COMMON.LOCAL'
1013       include 'COMMON.CHAIN'
1014       include 'COMMON.DERIV'
1015       include 'COMMON.NAMES'
1016       include 'COMMON.INTERACT'
1017       include 'COMMON.ENEPS'
1018       include 'COMMON.IOUNITS'
1019       include 'COMMON.CALC'
1020       common /srutu/ icall
1021       logical lprn
1022       integer icant
1023       external icant
1024       do i=1,210
1025         do j=1,2
1026           eneps_temp(j,i)=0.0d0
1027         enddo
1028       enddo
1029       evdw=0.0D0
1030       evdw_t=0.0d0
1031 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1032       evdw=0.0D0
1033       lprn=.false.
1034 c      if (icall.gt.0) lprn=.true.
1035       ind=0
1036       do i=iatsc_s,iatsc_e
1037         itypi=iabs(itype(i))
1038         if (itypi.eq.ntyp1) cycle
1039         itypi1=iabs(itype(i+1))
1040         xi=c(1,nres+i)
1041         yi=c(2,nres+i)
1042         zi=c(3,nres+i)
1043         dxi=dc_norm(1,nres+i)
1044         dyi=dc_norm(2,nres+i)
1045         dzi=dc_norm(3,nres+i)
1046         dsci_inv=vbld_inv(i+nres)
1047 C
1048 C Calculate SC interaction energy.
1049 C
1050         do iint=1,nint_gr(i)
1051           do j=istart(i,iint),iend(i,iint)
1052             ind=ind+1
1053             itypj=iabs(itype(j))
1054             if (itypj.eq.ntyp1) cycle
1055             dscj_inv=vbld_inv(j+nres)
1056             sig0ij=sigma(itypi,itypj)
1057             r0ij=r0(itypi,itypj)
1058             chi1=chi(itypi,itypj)
1059             chi2=chi(itypj,itypi)
1060             chi12=chi1*chi2
1061             chip1=chip(itypi)
1062             chip2=chip(itypj)
1063             chip12=chip1*chip2
1064             alf1=alp(itypi)
1065             alf2=alp(itypj)
1066             alf12=0.5D0*(alf1+alf2)
1067 C For diagnostics only!!!
1068 c           chi1=0.0D0
1069 c           chi2=0.0D0
1070 c           chi12=0.0D0
1071 c           chip1=0.0D0
1072 c           chip2=0.0D0
1073 c           chip12=0.0D0
1074 c           alf1=0.0D0
1075 c           alf2=0.0D0
1076 c           alf12=0.0D0
1077             xj=c(1,nres+j)-xi
1078             yj=c(2,nres+j)-yi
1079             zj=c(3,nres+j)-zi
1080             dxj=dc_norm(1,nres+j)
1081             dyj=dc_norm(2,nres+j)
1082             dzj=dc_norm(3,nres+j)
1083             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1084             rij=dsqrt(rrij)
1085 C Calculate angle-dependent terms of energy and contributions to their
1086 C derivatives.
1087             call sc_angular
1088             sigsq=1.0D0/sigsq
1089             sig=sig0ij*dsqrt(sigsq)
1090             rij_shift=1.0D0/rij-sig+r0ij
1091 C I hate to put IF's in the loops, but here don't have another choice!!!!
1092             if (rij_shift.le.0.0D0) then
1093               evdw=1.0D20
1094               return
1095             endif
1096             sigder=-sig*sigsq
1097 c---------------------------------------------------------------
1098             rij_shift=1.0D0/rij_shift
1099             fac=rij_shift**expon
1100             e1=fac*fac*aa(itypi,itypj)
1101             e2=fac*bb(itypi,itypj)
1102             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1103             eps2der=evdwij*eps3rt
1104             eps3der=evdwij*eps2rt
1105             fac_augm=rrij**expon
1106             e_augm=augm(itypi,itypj)*fac_augm
1107             evdwij=evdwij*eps2rt*eps3rt
1108             if (bb(itypi,itypj).gt.0.0d0) then
1109               evdw=evdw+evdwij+e_augm
1110             else
1111               evdw_t=evdw_t+evdwij+e_augm
1112             endif
1113             ij=icant(itypi,itypj)
1114             aux=eps1*eps2rt**2*eps3rt**2
1115             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1116      &        /dabs(eps(itypi,itypj))
1117             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1118 c            eneps_temp(ij)=eneps_temp(ij)
1119 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1120 c            if (lprn) then
1121 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1122 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1123 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1124 c     &        restyp(itypi),i,restyp(itypj),j,
1125 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1126 c     &        chi1,chi2,chip1,chip2,
1127 c     &        eps1,eps2rt**2,eps3rt**2,
1128 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1129 c     &        evdwij+e_augm
1130 c            endif
1131             if (calc_grad) then
1132 C Calculate gradient components.
1133             e1=e1*eps1*eps2rt**2*eps3rt**2
1134             fac=-expon*(e1+evdwij)*rij_shift
1135             sigder=fac*sigder
1136             fac=rij*fac-2*expon*rrij*e_augm
1137 C Calculate the radial part of the gradient
1138             gg(1)=xj*fac
1139             gg(2)=yj*fac
1140             gg(3)=zj*fac
1141 C Calculate angular part of the gradient.
1142             call sc_grad
1143             endif
1144           enddo      ! j
1145         enddo        ! iint
1146       enddo          ! i
1147       return
1148       end
1149 C-----------------------------------------------------------------------------
1150       subroutine sc_angular
1151 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1152 C om12. Called by ebp, egb, and egbv.
1153       implicit none
1154       include 'COMMON.CALC'
1155       erij(1)=xj*rij
1156       erij(2)=yj*rij
1157       erij(3)=zj*rij
1158       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1159       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1160       om12=dxi*dxj+dyi*dyj+dzi*dzj
1161       chiom12=chi12*om12
1162 C Calculate eps1(om12) and its derivative in om12
1163       faceps1=1.0D0-om12*chiom12
1164       faceps1_inv=1.0D0/faceps1
1165       eps1=dsqrt(faceps1_inv)
1166 C Following variable is eps1*deps1/dom12
1167       eps1_om12=faceps1_inv*chiom12
1168 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1169 C and om12.
1170       om1om2=om1*om2
1171       chiom1=chi1*om1
1172       chiom2=chi2*om2
1173       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1174       sigsq=1.0D0-facsig*faceps1_inv
1175       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1176       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1177       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1178 C Calculate eps2 and its derivatives in om1, om2, and om12.
1179       chipom1=chip1*om1
1180       chipom2=chip2*om2
1181       chipom12=chip12*om12
1182       facp=1.0D0-om12*chipom12
1183       facp_inv=1.0D0/facp
1184       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1185 C Following variable is the square root of eps2
1186       eps2rt=1.0D0-facp1*facp_inv
1187 C Following three variables are the derivatives of the square root of eps
1188 C in om1, om2, and om12.
1189       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1190       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1191       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1192 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1193       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1194 C Calculate whole angle-dependent part of epsilon and contributions
1195 C to its derivatives
1196       return
1197       end
1198 C----------------------------------------------------------------------------
1199       subroutine sc_grad
1200       implicit real*8 (a-h,o-z)
1201       include 'DIMENSIONS'
1202       include 'DIMENSIONS.ZSCOPT'
1203       include 'COMMON.CHAIN'
1204       include 'COMMON.DERIV'
1205       include 'COMMON.CALC'
1206       double precision dcosom1(3),dcosom2(3)
1207       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1208       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1209       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1210      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1211       do k=1,3
1212         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1213         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1214       enddo
1215       do k=1,3
1216         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1217       enddo
1218       do k=1,3
1219         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1220      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1221      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1222         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1223      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1224      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1225       enddo
1226 C
1227 C Calculate the components of the gradient in DC and X
1228 C
1229       do k=i,j-1
1230         do l=1,3
1231           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1232         enddo
1233       enddo
1234       return
1235       end
1236 c------------------------------------------------------------------------------
1237       subroutine vec_and_deriv
1238       implicit real*8 (a-h,o-z)
1239       include 'DIMENSIONS'
1240       include 'DIMENSIONS.ZSCOPT'
1241       include 'COMMON.IOUNITS'
1242       include 'COMMON.GEO'
1243       include 'COMMON.VAR'
1244       include 'COMMON.LOCAL'
1245       include 'COMMON.CHAIN'
1246       include 'COMMON.VECTORS'
1247       include 'COMMON.DERIV'
1248       include 'COMMON.INTERACT'
1249       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1250 C Compute the local reference systems. For reference system (i), the
1251 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1252 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1253       do i=1,nres-1
1254 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1255           if (i.eq.nres-1) then
1256 C Case of the last full residue
1257 C Compute the Z-axis
1258             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1259             costh=dcos(pi-theta(nres))
1260             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1261             do k=1,3
1262               uz(k,i)=fac*uz(k,i)
1263             enddo
1264             if (calc_grad) then
1265 C Compute the derivatives of uz
1266             uzder(1,1,1)= 0.0d0
1267             uzder(2,1,1)=-dc_norm(3,i-1)
1268             uzder(3,1,1)= dc_norm(2,i-1)
1269             uzder(1,2,1)= dc_norm(3,i-1)
1270             uzder(2,2,1)= 0.0d0
1271             uzder(3,2,1)=-dc_norm(1,i-1)
1272             uzder(1,3,1)=-dc_norm(2,i-1)
1273             uzder(2,3,1)= dc_norm(1,i-1)
1274             uzder(3,3,1)= 0.0d0
1275             uzder(1,1,2)= 0.0d0
1276             uzder(2,1,2)= dc_norm(3,i)
1277             uzder(3,1,2)=-dc_norm(2,i)
1278             uzder(1,2,2)=-dc_norm(3,i)
1279             uzder(2,2,2)= 0.0d0
1280             uzder(3,2,2)= dc_norm(1,i)
1281             uzder(1,3,2)= dc_norm(2,i)
1282             uzder(2,3,2)=-dc_norm(1,i)
1283             uzder(3,3,2)= 0.0d0
1284             endif
1285 C Compute the Y-axis
1286             facy=fac
1287             do k=1,3
1288               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1289             enddo
1290             if (calc_grad) then
1291 C Compute the derivatives of uy
1292             do j=1,3
1293               do k=1,3
1294                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1295      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1296                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1297               enddo
1298               uyder(j,j,1)=uyder(j,j,1)-costh
1299               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1300             enddo
1301             do j=1,2
1302               do k=1,3
1303                 do l=1,3
1304                   uygrad(l,k,j,i)=uyder(l,k,j)
1305                   uzgrad(l,k,j,i)=uzder(l,k,j)
1306                 enddo
1307               enddo
1308             enddo
1309             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1310             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1311             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1312             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1313             endif
1314           else
1315 C Other residues
1316 C Compute the Z-axis
1317             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1318             costh=dcos(pi-theta(i+2))
1319             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1320             do k=1,3
1321               uz(k,i)=fac*uz(k,i)
1322             enddo
1323             if (calc_grad) then
1324 C Compute the derivatives of uz
1325             uzder(1,1,1)= 0.0d0
1326             uzder(2,1,1)=-dc_norm(3,i+1)
1327             uzder(3,1,1)= dc_norm(2,i+1)
1328             uzder(1,2,1)= dc_norm(3,i+1)
1329             uzder(2,2,1)= 0.0d0
1330             uzder(3,2,1)=-dc_norm(1,i+1)
1331             uzder(1,3,1)=-dc_norm(2,i+1)
1332             uzder(2,3,1)= dc_norm(1,i+1)
1333             uzder(3,3,1)= 0.0d0
1334             uzder(1,1,2)= 0.0d0
1335             uzder(2,1,2)= dc_norm(3,i)
1336             uzder(3,1,2)=-dc_norm(2,i)
1337             uzder(1,2,2)=-dc_norm(3,i)
1338             uzder(2,2,2)= 0.0d0
1339             uzder(3,2,2)= dc_norm(1,i)
1340             uzder(1,3,2)= dc_norm(2,i)
1341             uzder(2,3,2)=-dc_norm(1,i)
1342             uzder(3,3,2)= 0.0d0
1343             endif
1344 C Compute the Y-axis
1345             facy=fac
1346             do k=1,3
1347               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1348             enddo
1349             if (calc_grad) then
1350 C Compute the derivatives of uy
1351             do j=1,3
1352               do k=1,3
1353                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1354      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1355                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1356               enddo
1357               uyder(j,j,1)=uyder(j,j,1)-costh
1358               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1359             enddo
1360             do j=1,2
1361               do k=1,3
1362                 do l=1,3
1363                   uygrad(l,k,j,i)=uyder(l,k,j)
1364                   uzgrad(l,k,j,i)=uzder(l,k,j)
1365                 enddo
1366               enddo
1367             enddo
1368             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1369             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1370             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1371             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1372           endif
1373           endif
1374       enddo
1375       if (calc_grad) then
1376       do i=1,nres-1
1377         vbld_inv_temp(1)=vbld_inv(i+1)
1378         if (i.lt.nres-1) then
1379           vbld_inv_temp(2)=vbld_inv(i+2)
1380         else
1381           vbld_inv_temp(2)=vbld_inv(i)
1382         endif
1383         do j=1,2
1384           do k=1,3
1385             do l=1,3
1386               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1387               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1388             enddo
1389           enddo
1390         enddo
1391       enddo
1392       endif
1393       return
1394       end
1395 C-----------------------------------------------------------------------------
1396       subroutine vec_and_deriv_test
1397       implicit real*8 (a-h,o-z)
1398       include 'DIMENSIONS'
1399       include 'DIMENSIONS.ZSCOPT'
1400       include 'COMMON.IOUNITS'
1401       include 'COMMON.GEO'
1402       include 'COMMON.VAR'
1403       include 'COMMON.LOCAL'
1404       include 'COMMON.CHAIN'
1405       include 'COMMON.VECTORS'
1406       dimension uyder(3,3,2),uzder(3,3,2)
1407 C Compute the local reference systems. For reference system (i), the
1408 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1409 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1410       do i=1,nres-1
1411           if (i.eq.nres-1) then
1412 C Case of the last full residue
1413 C Compute the Z-axis
1414             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1415             costh=dcos(pi-theta(nres))
1416             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1417 c            write (iout,*) 'fac',fac,
1418 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1419             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1420             do k=1,3
1421               uz(k,i)=fac*uz(k,i)
1422             enddo
1423 C Compute the derivatives of uz
1424             uzder(1,1,1)= 0.0d0
1425             uzder(2,1,1)=-dc_norm(3,i-1)
1426             uzder(3,1,1)= dc_norm(2,i-1)
1427             uzder(1,2,1)= dc_norm(3,i-1)
1428             uzder(2,2,1)= 0.0d0
1429             uzder(3,2,1)=-dc_norm(1,i-1)
1430             uzder(1,3,1)=-dc_norm(2,i-1)
1431             uzder(2,3,1)= dc_norm(1,i-1)
1432             uzder(3,3,1)= 0.0d0
1433             uzder(1,1,2)= 0.0d0
1434             uzder(2,1,2)= dc_norm(3,i)
1435             uzder(3,1,2)=-dc_norm(2,i)
1436             uzder(1,2,2)=-dc_norm(3,i)
1437             uzder(2,2,2)= 0.0d0
1438             uzder(3,2,2)= dc_norm(1,i)
1439             uzder(1,3,2)= dc_norm(2,i)
1440             uzder(2,3,2)=-dc_norm(1,i)
1441             uzder(3,3,2)= 0.0d0
1442 C Compute the Y-axis
1443             do k=1,3
1444               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1445             enddo
1446             facy=fac
1447             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1448      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1449      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1450             do k=1,3
1451 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1452               uy(k,i)=
1453 c     &        facy*(
1454      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1455      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1456 c     &        )
1457             enddo
1458 c            write (iout,*) 'facy',facy,
1459 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1460             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1461             do k=1,3
1462               uy(k,i)=facy*uy(k,i)
1463             enddo
1464 C Compute the derivatives of uy
1465             do j=1,3
1466               do k=1,3
1467                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1468      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1469                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1470               enddo
1471 c              uyder(j,j,1)=uyder(j,j,1)-costh
1472 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1473               uyder(j,j,1)=uyder(j,j,1)
1474      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1475               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1476      &          +uyder(j,j,2)
1477             enddo
1478             do j=1,2
1479               do k=1,3
1480                 do l=1,3
1481                   uygrad(l,k,j,i)=uyder(l,k,j)
1482                   uzgrad(l,k,j,i)=uzder(l,k,j)
1483                 enddo
1484               enddo
1485             enddo
1486             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1487             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1488             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1489             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1490           else
1491 C Other residues
1492 C Compute the Z-axis
1493             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1494             costh=dcos(pi-theta(i+2))
1495             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1496             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1497             do k=1,3
1498               uz(k,i)=fac*uz(k,i)
1499             enddo
1500 C Compute the derivatives of uz
1501             uzder(1,1,1)= 0.0d0
1502             uzder(2,1,1)=-dc_norm(3,i+1)
1503             uzder(3,1,1)= dc_norm(2,i+1)
1504             uzder(1,2,1)= dc_norm(3,i+1)
1505             uzder(2,2,1)= 0.0d0
1506             uzder(3,2,1)=-dc_norm(1,i+1)
1507             uzder(1,3,1)=-dc_norm(2,i+1)
1508             uzder(2,3,1)= dc_norm(1,i+1)
1509             uzder(3,3,1)= 0.0d0
1510             uzder(1,1,2)= 0.0d0
1511             uzder(2,1,2)= dc_norm(3,i)
1512             uzder(3,1,2)=-dc_norm(2,i)
1513             uzder(1,2,2)=-dc_norm(3,i)
1514             uzder(2,2,2)= 0.0d0
1515             uzder(3,2,2)= dc_norm(1,i)
1516             uzder(1,3,2)= dc_norm(2,i)
1517             uzder(2,3,2)=-dc_norm(1,i)
1518             uzder(3,3,2)= 0.0d0
1519 C Compute the Y-axis
1520             facy=fac
1521             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1522      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1523      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1524             do k=1,3
1525 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1526               uy(k,i)=
1527 c     &        facy*(
1528      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1529      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1530 c     &        )
1531             enddo
1532 c            write (iout,*) 'facy',facy,
1533 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1534             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1535             do k=1,3
1536               uy(k,i)=facy*uy(k,i)
1537             enddo
1538 C Compute the derivatives of uy
1539             do j=1,3
1540               do k=1,3
1541                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1542      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1543                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1544               enddo
1545 c              uyder(j,j,1)=uyder(j,j,1)-costh
1546 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1547               uyder(j,j,1)=uyder(j,j,1)
1548      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1549               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1550      &          +uyder(j,j,2)
1551             enddo
1552             do j=1,2
1553               do k=1,3
1554                 do l=1,3
1555                   uygrad(l,k,j,i)=uyder(l,k,j)
1556                   uzgrad(l,k,j,i)=uzder(l,k,j)
1557                 enddo
1558               enddo
1559             enddo
1560             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1561             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1562             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1563             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1564           endif
1565       enddo
1566       do i=1,nres-1
1567         do j=1,2
1568           do k=1,3
1569             do l=1,3
1570               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1571               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1572             enddo
1573           enddo
1574         enddo
1575       enddo
1576       return
1577       end
1578 C-----------------------------------------------------------------------------
1579       subroutine check_vecgrad
1580       implicit real*8 (a-h,o-z)
1581       include 'DIMENSIONS'
1582       include 'DIMENSIONS.ZSCOPT'
1583       include 'COMMON.IOUNITS'
1584       include 'COMMON.GEO'
1585       include 'COMMON.VAR'
1586       include 'COMMON.LOCAL'
1587       include 'COMMON.CHAIN'
1588       include 'COMMON.VECTORS'
1589       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1590       dimension uyt(3,maxres),uzt(3,maxres)
1591       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1592       double precision delta /1.0d-7/
1593       call vec_and_deriv
1594 cd      do i=1,nres
1595 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1596 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1597 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1598 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1599 cd     &     (dc_norm(if90,i),if90=1,3)
1600 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1601 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1602 cd          write(iout,'(a)')
1603 cd      enddo
1604       do i=1,nres
1605         do j=1,2
1606           do k=1,3
1607             do l=1,3
1608               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1609               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1610             enddo
1611           enddo
1612         enddo
1613       enddo
1614       call vec_and_deriv
1615       do i=1,nres
1616         do j=1,3
1617           uyt(j,i)=uy(j,i)
1618           uzt(j,i)=uz(j,i)
1619         enddo
1620       enddo
1621       do i=1,nres
1622 cd        write (iout,*) 'i=',i
1623         do k=1,3
1624           erij(k)=dc_norm(k,i)
1625         enddo
1626         do j=1,3
1627           do k=1,3
1628             dc_norm(k,i)=erij(k)
1629           enddo
1630           dc_norm(j,i)=dc_norm(j,i)+delta
1631 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1632 c          do k=1,3
1633 c            dc_norm(k,i)=dc_norm(k,i)/fac
1634 c          enddo
1635 c          write (iout,*) (dc_norm(k,i),k=1,3)
1636 c          write (iout,*) (erij(k),k=1,3)
1637           call vec_and_deriv
1638           do k=1,3
1639             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1640             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1641             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1642             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1643           enddo
1644 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1645 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1646 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1647         enddo
1648         do k=1,3
1649           dc_norm(k,i)=erij(k)
1650         enddo
1651 cd        do k=1,3
1652 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1653 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1654 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1655 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1656 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1657 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1658 cd          write (iout,'(a)')
1659 cd        enddo
1660       enddo
1661       return
1662       end
1663 C--------------------------------------------------------------------------
1664       subroutine set_matrices
1665       implicit real*8 (a-h,o-z)
1666       include 'DIMENSIONS'
1667       include 'DIMENSIONS.ZSCOPT'
1668       include 'COMMON.IOUNITS'
1669       include 'COMMON.GEO'
1670       include 'COMMON.VAR'
1671       include 'COMMON.LOCAL'
1672       include 'COMMON.CHAIN'
1673       include 'COMMON.DERIV'
1674       include 'COMMON.INTERACT'
1675       include 'COMMON.CONTACTS'
1676       include 'COMMON.TORSION'
1677       include 'COMMON.VECTORS'
1678       include 'COMMON.FFIELD'
1679       double precision auxvec(2),auxmat(2,2)
1680 C
1681 C Compute the virtual-bond-torsional-angle dependent quantities needed
1682 C to calculate the el-loc multibody terms of various order.
1683 C
1684       do i=3,nres+1
1685         if (i .lt. nres+1) then
1686           sin1=dsin(phi(i))
1687           cos1=dcos(phi(i))
1688           sintab(i-2)=sin1
1689           costab(i-2)=cos1
1690           obrot(1,i-2)=cos1
1691           obrot(2,i-2)=sin1
1692           sin2=dsin(2*phi(i))
1693           cos2=dcos(2*phi(i))
1694           sintab2(i-2)=sin2
1695           costab2(i-2)=cos2
1696           obrot2(1,i-2)=cos2
1697           obrot2(2,i-2)=sin2
1698           Ug(1,1,i-2)=-cos1
1699           Ug(1,2,i-2)=-sin1
1700           Ug(2,1,i-2)=-sin1
1701           Ug(2,2,i-2)= cos1
1702           Ug2(1,1,i-2)=-cos2
1703           Ug2(1,2,i-2)=-sin2
1704           Ug2(2,1,i-2)=-sin2
1705           Ug2(2,2,i-2)= cos2
1706         else
1707           costab(i-2)=1.0d0
1708           sintab(i-2)=0.0d0
1709           obrot(1,i-2)=1.0d0
1710           obrot(2,i-2)=0.0d0
1711           obrot2(1,i-2)=0.0d0
1712           obrot2(2,i-2)=0.0d0
1713           Ug(1,1,i-2)=1.0d0
1714           Ug(1,2,i-2)=0.0d0
1715           Ug(2,1,i-2)=0.0d0
1716           Ug(2,2,i-2)=1.0d0
1717           Ug2(1,1,i-2)=0.0d0
1718           Ug2(1,2,i-2)=0.0d0
1719           Ug2(2,1,i-2)=0.0d0
1720           Ug2(2,2,i-2)=0.0d0
1721         endif
1722         if (i .gt. 3 .and. i .lt. nres+1) then
1723           obrot_der(1,i-2)=-sin1
1724           obrot_der(2,i-2)= cos1
1725           Ugder(1,1,i-2)= sin1
1726           Ugder(1,2,i-2)=-cos1
1727           Ugder(2,1,i-2)=-cos1
1728           Ugder(2,2,i-2)=-sin1
1729           dwacos2=cos2+cos2
1730           dwasin2=sin2+sin2
1731           obrot2_der(1,i-2)=-dwasin2
1732           obrot2_der(2,i-2)= dwacos2
1733           Ug2der(1,1,i-2)= dwasin2
1734           Ug2der(1,2,i-2)=-dwacos2
1735           Ug2der(2,1,i-2)=-dwacos2
1736           Ug2der(2,2,i-2)=-dwasin2
1737         else
1738           obrot_der(1,i-2)=0.0d0
1739           obrot_der(2,i-2)=0.0d0
1740           Ugder(1,1,i-2)=0.0d0
1741           Ugder(1,2,i-2)=0.0d0
1742           Ugder(2,1,i-2)=0.0d0
1743           Ugder(2,2,i-2)=0.0d0
1744           obrot2_der(1,i-2)=0.0d0
1745           obrot2_der(2,i-2)=0.0d0
1746           Ug2der(1,1,i-2)=0.0d0
1747           Ug2der(1,2,i-2)=0.0d0
1748           Ug2der(2,1,i-2)=0.0d0
1749           Ug2der(2,2,i-2)=0.0d0
1750         endif
1751         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1752           if (itype(i-2).le.ntyp) then
1753             iti = itortyp(itype(i-2))
1754           else
1755             iti=ntortyp+1
1756           endif
1757         else
1758           iti=ntortyp+1
1759         endif
1760         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1761           if (itype(i-1).le.ntyp) then
1762             iti1 = itortyp(itype(i-1))
1763           else
1764             iti1=ntortyp+1
1765           endif
1766         else
1767           iti1=ntortyp+1
1768         endif
1769 cd        write (iout,*) '*******i',i,' iti1',iti
1770 cd        write (iout,*) 'b1',b1(:,iti)
1771 cd        write (iout,*) 'b2',b2(:,iti)
1772 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1773 c        print *,"itilde1 i iti iti1",i,iti,iti1
1774         if (i .gt. iatel_s+2) then
1775           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1776           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1777           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1778           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1779           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1780           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1781           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1782         else
1783           do k=1,2
1784             Ub2(k,i-2)=0.0d0
1785             Ctobr(k,i-2)=0.0d0
1786             Dtobr2(k,i-2)=0.0d0
1787             do l=1,2
1788               EUg(l,k,i-2)=0.0d0
1789               CUg(l,k,i-2)=0.0d0
1790               DUg(l,k,i-2)=0.0d0
1791               DtUg2(l,k,i-2)=0.0d0
1792             enddo
1793           enddo
1794         endif
1795 c        print *,"itilde2 i iti iti1",i,iti,iti1
1796         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1797         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1798         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1799         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1800         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1801         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1802         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1803 c        print *,"itilde3 i iti iti1",i,iti,iti1
1804         do k=1,2
1805           muder(k,i-2)=Ub2der(k,i-2)
1806         enddo
1807         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1808           if (itype(i-1).le.ntyp) then
1809             iti1 = itortyp(itype(i-1))
1810           else
1811             iti1=ntortyp+1
1812           endif
1813         else
1814           iti1=ntortyp+1
1815         endif
1816         do k=1,2
1817           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1818         enddo
1819 C Vectors and matrices dependent on a single virtual-bond dihedral.
1820         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1821         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1822         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1823         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1824         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1825         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1826         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1827         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1828         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1829 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1830 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1831       enddo
1832 C Matrices dependent on two consecutive virtual-bond dihedrals.
1833 C The order of matrices is from left to right.
1834       do i=2,nres-1
1835         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1836         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1837         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1838         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1839         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1840         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1841         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1842         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1843       enddo
1844 cd      do i=1,nres
1845 cd        iti = itortyp(itype(i))
1846 cd        write (iout,*) i
1847 cd        do j=1,2
1848 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1849 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1850 cd        enddo
1851 cd      enddo
1852       return
1853       end
1854 C--------------------------------------------------------------------------
1855       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1856 C
1857 C This subroutine calculates the average interaction energy and its gradient
1858 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1859 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1860 C The potential depends both on the distance of peptide-group centers and on
1861 C the orientation of the CA-CA virtual bonds.
1862 C
1863       implicit real*8 (a-h,o-z)
1864       include 'DIMENSIONS'
1865       include 'DIMENSIONS.ZSCOPT'
1866       include 'COMMON.CONTROL'
1867       include 'COMMON.IOUNITS'
1868       include 'COMMON.GEO'
1869       include 'COMMON.VAR'
1870       include 'COMMON.LOCAL'
1871       include 'COMMON.CHAIN'
1872       include 'COMMON.DERIV'
1873       include 'COMMON.INTERACT'
1874       include 'COMMON.CONTACTS'
1875       include 'COMMON.TORSION'
1876       include 'COMMON.VECTORS'
1877       include 'COMMON.FFIELD'
1878       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1879      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1880       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1881      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1882       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1883 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1884       double precision scal_el /0.5d0/
1885 C 12/13/98
1886 C 13-go grudnia roku pamietnego...
1887       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1888      &                   0.0d0,1.0d0,0.0d0,
1889      &                   0.0d0,0.0d0,1.0d0/
1890 cd      write(iout,*) 'In EELEC'
1891 cd      do i=1,nloctyp
1892 cd        write(iout,*) 'Type',i
1893 cd        write(iout,*) 'B1',B1(:,i)
1894 cd        write(iout,*) 'B2',B2(:,i)
1895 cd        write(iout,*) 'CC',CC(:,:,i)
1896 cd        write(iout,*) 'DD',DD(:,:,i)
1897 cd        write(iout,*) 'EE',EE(:,:,i)
1898 cd      enddo
1899 cd      call check_vecgrad
1900 cd      stop
1901       if (icheckgrad.eq.1) then
1902         do i=1,nres-1
1903           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1904           do k=1,3
1905             dc_norm(k,i)=dc(k,i)*fac
1906           enddo
1907 c          write (iout,*) 'i',i,' fac',fac
1908         enddo
1909       endif
1910       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1911      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1912      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1913 cd      if (wel_loc.gt.0.0d0) then
1914         if (icheckgrad.eq.1) then
1915         call vec_and_deriv_test
1916         else
1917         call vec_and_deriv
1918         endif
1919         call set_matrices
1920       endif
1921 cd      do i=1,nres-1
1922 cd        write (iout,*) 'i=',i
1923 cd        do k=1,3
1924 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1925 cd        enddo
1926 cd        do k=1,3
1927 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1928 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1929 cd        enddo
1930 cd      enddo
1931       num_conti_hb=0
1932       ees=0.0D0
1933       evdw1=0.0D0
1934       eel_loc=0.0d0
1935       eello_turn3=0.0d0
1936       eello_turn4=0.0d0
1937       ind=0
1938       do i=1,nres
1939         num_cont_hb(i)=0
1940       enddo
1941 C      print '(a)','Enter EELEC'
1942 C      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1943       do i=1,nres
1944         gel_loc_loc(i)=0.0d0
1945         gcorr_loc(i)=0.0d0
1946       enddo
1947       do i=iatel_s,iatel_e
1948           if (i.eq.1) then
1949            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
1950      &  .or. itype(i+2).eq.ntyp1) cycle
1951           else
1952         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
1953      &  .or. itype(i+2).eq.ntyp1
1954      &  .or. itype(i-1).eq.ntyp1
1955      &) cycle
1956          endif
1957         if (itel(i).eq.0) goto 1215
1958         dxi=dc(1,i)
1959         dyi=dc(2,i)
1960         dzi=dc(3,i)
1961         dx_normi=dc_norm(1,i)
1962         dy_normi=dc_norm(2,i)
1963         dz_normi=dc_norm(3,i)
1964         xmedi=c(1,i)+0.5d0*dxi
1965         ymedi=c(2,i)+0.5d0*dyi
1966         zmedi=c(3,i)+0.5d0*dzi
1967           xmedi=mod(xmedi,boxxsize)
1968           if (xmedi.lt.0) xmedi=xmedi+boxxsize
1969           ymedi=mod(ymedi,boxysize)
1970           if (ymedi.lt.0) ymedi=ymedi+boxysize
1971           zmedi=mod(zmedi,boxzsize)
1972           if (zmedi.lt.0) zmedi=zmedi+boxzsize
1973         num_conti=0
1974 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1975         do j=ielstart(i),ielend(i)
1976           if (j.eq.1) then
1977            if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
1978      & .or.itype(j+2).eq.ntyp1
1979      &) cycle
1980           else
1981           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
1982      & .or.itype(j+2).eq.ntyp1
1983      & .or.itype(j-1).eq.ntyp1
1984      &) cycle
1985          endif
1986 C
1987 C) cycle
1988           if (itel(j).eq.0) goto 1216
1989           ind=ind+1
1990           iteli=itel(i)
1991           itelj=itel(j)
1992           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1993           aaa=app(iteli,itelj)
1994           bbb=bpp(iteli,itelj)
1995 C Diagnostics only!!!
1996 c         aaa=0.0D0
1997 c         bbb=0.0D0
1998 c         ael6i=0.0D0
1999 c         ael3i=0.0D0
2000 C End diagnostics
2001           ael6i=ael6(iteli,itelj)
2002           ael3i=ael3(iteli,itelj)
2003           dxj=dc(1,j)
2004           dyj=dc(2,j)
2005           dzj=dc(3,j)
2006           dx_normj=dc_norm(1,j)
2007           dy_normj=dc_norm(2,j)
2008           dz_normj=dc_norm(3,j)
2009           xj=c(1,j)+0.5D0*dxj
2010           yj=c(2,j)+0.5D0*dyj
2011           zj=c(3,j)+0.5D0*dzj
2012          xj=mod(xj,boxxsize)
2013           if (xj.lt.0) xj=xj+boxxsize
2014           yj=mod(yj,boxysize)
2015           if (yj.lt.0) yj=yj+boxysize
2016           zj=mod(zj,boxzsize)
2017           if (zj.lt.0) zj=zj+boxzsize
2018       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2019       xj_safe=xj
2020       yj_safe=yj
2021       zj_safe=zj
2022       isubchap=0
2023       do xshift=-1,1
2024       do yshift=-1,1
2025       do zshift=-1,1
2026           xj=xj_safe+xshift*boxxsize
2027           yj=yj_safe+yshift*boxysize
2028           zj=zj_safe+zshift*boxzsize
2029           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2030           if(dist_temp.lt.dist_init) then
2031             dist_init=dist_temp
2032             xj_temp=xj
2033             yj_temp=yj
2034             zj_temp=zj
2035             isubchap=1
2036           endif
2037        enddo
2038        enddo
2039        enddo
2040        if (isubchap.eq.1) then
2041           xj=xj_temp-xmedi
2042           yj=yj_temp-ymedi
2043           zj=zj_temp-zmedi
2044        else
2045           xj=xj_safe-xmedi
2046           yj=yj_safe-ymedi
2047           zj=zj_safe-zmedi
2048        endif
2049           rij=xj*xj+yj*yj+zj*zj
2050             sss=sscale(sqrt(rij))
2051             sssgrad=sscagrad(sqrt(rij))
2052           rrmij=1.0D0/rij
2053           rij=dsqrt(rij)
2054           rmij=1.0D0/rij
2055           r3ij=rrmij*rmij
2056           r6ij=r3ij*r3ij
2057           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2058           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2059           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2060           fac=cosa-3.0D0*cosb*cosg
2061           ev1=aaa*r6ij*r6ij
2062 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2063           if (j.eq.i+2) ev1=scal_el*ev1
2064           ev2=bbb*r6ij
2065           fac3=ael6i*r6ij
2066           fac4=ael3i*r3ij
2067           evdwij=ev1+ev2
2068           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2069           el2=fac4*fac
2070           eesij=el1+el2
2071 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2072 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2073           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2074           ees=ees+eesij
2075           evdw1=evdw1+evdwij*sss
2076 c             write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2077 c     &'evdw1',i,j,evdwij
2078 c     &,iteli,itelj,aaa,evdw1
2079
2080 C              write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2081 c          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2082 c     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2083 c     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2084 c     &      xmedi,ymedi,zmedi,xj,yj,zj
2085 C
2086 C Calculate contributions to the Cartesian gradient.
2087 C
2088 #ifdef SPLITELE
2089           facvdw=-6*rrmij*(ev1+evdwij)*sss
2090           facel=-3*rrmij*(el1+eesij)
2091           fac1=fac
2092           erij(1)=xj*rmij
2093           erij(2)=yj*rmij
2094           erij(3)=zj*rmij
2095           if (calc_grad) then
2096 *
2097 * Radial derivatives. First process both termini of the fragment (i,j)
2098 *
2099           ggg(1)=facel*xj
2100           ggg(2)=facel*yj
2101           ggg(3)=facel*zj
2102           do k=1,3
2103             ghalf=0.5D0*ggg(k)
2104             gelc(k,i)=gelc(k,i)+ghalf
2105             gelc(k,j)=gelc(k,j)+ghalf
2106           enddo
2107 *
2108 * Loop over residues i+1 thru j-1.
2109 *
2110           do k=i+1,j-1
2111             do l=1,3
2112               gelc(l,k)=gelc(l,k)+ggg(l)
2113             enddo
2114           enddo
2115 C          ggg(1)=facvdw*xj
2116 C          ggg(2)=facvdw*yj
2117 C          ggg(3)=facvdw*zj
2118           if (sss.gt.0.0) then
2119           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2120           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2121           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2122           else
2123           ggg(1)=0.0
2124           ggg(2)=0.0
2125           ggg(3)=0.0
2126           endif
2127           do k=1,3
2128             ghalf=0.5D0*ggg(k)
2129             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2130             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2131           enddo
2132 *
2133 * Loop over residues i+1 thru j-1.
2134 *
2135           do k=i+1,j-1
2136             do l=1,3
2137               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2138             enddo
2139           enddo
2140 #else
2141           facvdw=(ev1+evdwij)*sss
2142           facel=el1+eesij
2143           fac1=fac
2144           fac=-3*rrmij*(facvdw+facvdw+facel)
2145           erij(1)=xj*rmij
2146           erij(2)=yj*rmij
2147           erij(3)=zj*rmij
2148           if (calc_grad) then
2149 *
2150 * Radial derivatives. First process both termini of the fragment (i,j)
2151 *
2152           ggg(1)=fac*xj
2153           ggg(2)=fac*yj
2154           ggg(3)=fac*zj
2155           do k=1,3
2156             ghalf=0.5D0*ggg(k)
2157             gelc(k,i)=gelc(k,i)+ghalf
2158             gelc(k,j)=gelc(k,j)+ghalf
2159           enddo
2160 *
2161 * Loop over residues i+1 thru j-1.
2162 *
2163           do k=i+1,j-1
2164             do l=1,3
2165               gelc(l,k)=gelc(l,k)+ggg(l)
2166             enddo
2167           enddo
2168 #endif
2169 *
2170 * Angular part
2171 *
2172           ecosa=2.0D0*fac3*fac1+fac4
2173           fac4=-3.0D0*fac4
2174           fac3=-6.0D0*fac3
2175           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2176           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2177           do k=1,3
2178             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2179             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2180           enddo
2181 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2182 cd   &          (dcosg(k),k=1,3)
2183           do k=1,3
2184             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2185           enddo
2186           do k=1,3
2187             ghalf=0.5D0*ggg(k)
2188             gelc(k,i)=gelc(k,i)+ghalf
2189      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2190      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2191             gelc(k,j)=gelc(k,j)+ghalf
2192      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2193      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2194           enddo
2195           do k=i+1,j-1
2196             do l=1,3
2197               gelc(l,k)=gelc(l,k)+ggg(l)
2198             enddo
2199           enddo
2200           endif
2201
2202           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2203      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2204      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2205 C
2206 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2207 C   energy of a peptide unit is assumed in the form of a second-order
2208 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2209 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2210 C   are computed for EVERY pair of non-contiguous peptide groups.
2211 C
2212           if (j.lt.nres-1) then
2213             j1=j+1
2214             j2=j-1
2215           else
2216             j1=j-1
2217             j2=j-2
2218           endif
2219           kkk=0
2220           do k=1,2
2221             do l=1,2
2222               kkk=kkk+1
2223               muij(kkk)=mu(k,i)*mu(l,j)
2224             enddo
2225           enddo
2226 cd         write (iout,*) 'EELEC: i',i,' j',j
2227 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2228 cd          write(iout,*) 'muij',muij
2229           ury=scalar(uy(1,i),erij)
2230           urz=scalar(uz(1,i),erij)
2231           vry=scalar(uy(1,j),erij)
2232           vrz=scalar(uz(1,j),erij)
2233           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2234           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2235           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2236           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2237 C For diagnostics only
2238 cd          a22=1.0d0
2239 cd          a23=1.0d0
2240 cd          a32=1.0d0
2241 cd          a33=1.0d0
2242           fac=dsqrt(-ael6i)*r3ij
2243 cd          write (2,*) 'fac=',fac
2244 C For diagnostics only
2245 cd          fac=1.0d0
2246           a22=a22*fac
2247           a23=a23*fac
2248           a32=a32*fac
2249           a33=a33*fac
2250 cd          write (iout,'(4i5,4f10.5)')
2251 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2252 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2253 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2254 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2255 cd          write (iout,'(4f10.5)')
2256 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2257 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2258 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2259 cd           write (iout,'(2i3,9f10.5/)') i,j,
2260 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2261           if (calc_grad) then
2262 C Derivatives of the elements of A in virtual-bond vectors
2263           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2264 cd          do k=1,3
2265 cd            do l=1,3
2266 cd              erder(k,l)=0.0d0
2267 cd            enddo
2268 cd          enddo
2269           do k=1,3
2270             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2271             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2272             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2273             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2274             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2275             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2276             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2277             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2278             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2279             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2280             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2281             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2282           enddo
2283 cd          do k=1,3
2284 cd            do l=1,3
2285 cd              uryg(k,l)=0.0d0
2286 cd              urzg(k,l)=0.0d0
2287 cd              vryg(k,l)=0.0d0
2288 cd              vrzg(k,l)=0.0d0
2289 cd            enddo
2290 cd          enddo
2291 C Compute radial contributions to the gradient
2292           facr=-3.0d0*rrmij
2293           a22der=a22*facr
2294           a23der=a23*facr
2295           a32der=a32*facr
2296           a33der=a33*facr
2297 cd          a22der=0.0d0
2298 cd          a23der=0.0d0
2299 cd          a32der=0.0d0
2300 cd          a33der=0.0d0
2301           agg(1,1)=a22der*xj
2302           agg(2,1)=a22der*yj
2303           agg(3,1)=a22der*zj
2304           agg(1,2)=a23der*xj
2305           agg(2,2)=a23der*yj
2306           agg(3,2)=a23der*zj
2307           agg(1,3)=a32der*xj
2308           agg(2,3)=a32der*yj
2309           agg(3,3)=a32der*zj
2310           agg(1,4)=a33der*xj
2311           agg(2,4)=a33der*yj
2312           agg(3,4)=a33der*zj
2313 C Add the contributions coming from er
2314           fac3=-3.0d0*fac
2315           do k=1,3
2316             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2317             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2318             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2319             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2320           enddo
2321           do k=1,3
2322 C Derivatives in DC(i)
2323             ghalf1=0.5d0*agg(k,1)
2324             ghalf2=0.5d0*agg(k,2)
2325             ghalf3=0.5d0*agg(k,3)
2326             ghalf4=0.5d0*agg(k,4)
2327             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2328      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2329             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2330      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2331             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2332      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2333             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2334      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2335 C Derivatives in DC(i+1)
2336             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2337      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2338             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2339      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2340             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2341      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2342             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2343      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2344 C Derivatives in DC(j)
2345             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2346      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2347             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2348      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2349             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2350      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2351             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2352      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2353 C Derivatives in DC(j+1) or DC(nres-1)
2354             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2355      &      -3.0d0*vryg(k,3)*ury)
2356             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2357      &      -3.0d0*vrzg(k,3)*ury)
2358             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2359      &      -3.0d0*vryg(k,3)*urz)
2360             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2361      &      -3.0d0*vrzg(k,3)*urz)
2362 cd            aggi(k,1)=ghalf1
2363 cd            aggi(k,2)=ghalf2
2364 cd            aggi(k,3)=ghalf3
2365 cd            aggi(k,4)=ghalf4
2366 C Derivatives in DC(i+1)
2367 cd            aggi1(k,1)=agg(k,1)
2368 cd            aggi1(k,2)=agg(k,2)
2369 cd            aggi1(k,3)=agg(k,3)
2370 cd            aggi1(k,4)=agg(k,4)
2371 C Derivatives in DC(j)
2372 cd            aggj(k,1)=ghalf1
2373 cd            aggj(k,2)=ghalf2
2374 cd            aggj(k,3)=ghalf3
2375 cd            aggj(k,4)=ghalf4
2376 C Derivatives in DC(j+1)
2377 cd            aggj1(k,1)=0.0d0
2378 cd            aggj1(k,2)=0.0d0
2379 cd            aggj1(k,3)=0.0d0
2380 cd            aggj1(k,4)=0.0d0
2381             if (j.eq.nres-1 .and. i.lt.j-2) then
2382               do l=1,4
2383                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2384 cd                aggj1(k,l)=agg(k,l)
2385               enddo
2386             endif
2387           enddo
2388           endif
2389 c          goto 11111
2390 C Check the loc-el terms by numerical integration
2391           acipa(1,1)=a22
2392           acipa(1,2)=a23
2393           acipa(2,1)=a32
2394           acipa(2,2)=a33
2395           a22=-a22
2396           a23=-a23
2397           do l=1,2
2398             do k=1,3
2399               agg(k,l)=-agg(k,l)
2400               aggi(k,l)=-aggi(k,l)
2401               aggi1(k,l)=-aggi1(k,l)
2402               aggj(k,l)=-aggj(k,l)
2403               aggj1(k,l)=-aggj1(k,l)
2404             enddo
2405           enddo
2406           if (j.lt.nres-1) then
2407             a22=-a22
2408             a32=-a32
2409             do l=1,3,2
2410               do k=1,3
2411                 agg(k,l)=-agg(k,l)
2412                 aggi(k,l)=-aggi(k,l)
2413                 aggi1(k,l)=-aggi1(k,l)
2414                 aggj(k,l)=-aggj(k,l)
2415                 aggj1(k,l)=-aggj1(k,l)
2416               enddo
2417             enddo
2418           else
2419             a22=-a22
2420             a23=-a23
2421             a32=-a32
2422             a33=-a33
2423             do l=1,4
2424               do k=1,3
2425                 agg(k,l)=-agg(k,l)
2426                 aggi(k,l)=-aggi(k,l)
2427                 aggi1(k,l)=-aggi1(k,l)
2428                 aggj(k,l)=-aggj(k,l)
2429                 aggj1(k,l)=-aggj1(k,l)
2430               enddo
2431             enddo
2432           endif
2433           ENDIF ! WCORR
2434 11111     continue
2435           IF (wel_loc.gt.0.0d0) THEN
2436 C Contribution to the local-electrostatic energy coming from the i-j pair
2437           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2438      &     +a33*muij(4)
2439 c          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2440 c          write (iout,'(a6,2i5,0pf7.3)')
2441 c     &            'eelloc',i,j,eel_loc_ij
2442 c          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2443           eel_loc=eel_loc+eel_loc_ij
2444 C Partial derivatives in virtual-bond dihedral angles gamma
2445           if (calc_grad) then
2446           if (i.gt.1)
2447      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2448      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2449      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2450           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2451      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2452      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2453 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2454 cd          write(iout,*) 'agg  ',agg
2455 cd          write(iout,*) 'aggi ',aggi
2456 cd          write(iout,*) 'aggi1',aggi1
2457 cd          write(iout,*) 'aggj ',aggj
2458 cd          write(iout,*) 'aggj1',aggj1
2459
2460 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2461           do l=1,3
2462             ggg(l)=agg(l,1)*muij(1)+
2463      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2464           enddo
2465           do k=i+2,j2
2466             do l=1,3
2467               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2468             enddo
2469           enddo
2470 C Remaining derivatives of eello
2471           do l=1,3
2472             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2473      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2474             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2475      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2476             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2477      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2478             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2479      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2480           enddo
2481           endif
2482           ENDIF
2483           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2484 C Contributions from turns
2485             a_temp(1,1)=a22
2486             a_temp(1,2)=a23
2487             a_temp(2,1)=a32
2488             a_temp(2,2)=a33
2489             call eturn34(i,j,eello_turn3,eello_turn4)
2490           endif
2491 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2492           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2493 C
2494 C Calculate the contact function. The ith column of the array JCONT will
2495 C contain the numbers of atoms that make contacts with the atom I (of numbers
2496 C greater than I). The arrays FACONT and GACONT will contain the values of
2497 C the contact function and its derivative.
2498 c           r0ij=1.02D0*rpp(iteli,itelj)
2499 c           r0ij=1.11D0*rpp(iteli,itelj)
2500             r0ij=2.20D0*rpp(iteli,itelj)
2501 c           r0ij=1.55D0*rpp(iteli,itelj)
2502             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2503             if (fcont.gt.0.0D0) then
2504               num_conti=num_conti+1
2505               if (num_conti.gt.maxconts) then
2506                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2507      &                         ' will skip next contacts for this conf.'
2508               else
2509                 jcont_hb(num_conti,i)=j
2510                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2511      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2512 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2513 C  terms.
2514                 d_cont(num_conti,i)=rij
2515 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2516 C     --- Electrostatic-interaction matrix ---
2517                 a_chuj(1,1,num_conti,i)=a22
2518                 a_chuj(1,2,num_conti,i)=a23
2519                 a_chuj(2,1,num_conti,i)=a32
2520                 a_chuj(2,2,num_conti,i)=a33
2521 C     --- Gradient of rij
2522                 do kkk=1,3
2523                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2524                 enddo
2525 c             if (i.eq.1) then
2526 c                a_chuj(1,1,num_conti,i)=-0.61d0
2527 c                a_chuj(1,2,num_conti,i)= 0.4d0
2528 c                a_chuj(2,1,num_conti,i)= 0.65d0
2529 c                a_chuj(2,2,num_conti,i)= 0.50d0
2530 c             else if (i.eq.2) then
2531 c                a_chuj(1,1,num_conti,i)= 0.0d0
2532 c                a_chuj(1,2,num_conti,i)= 0.0d0
2533 c                a_chuj(2,1,num_conti,i)= 0.0d0
2534 c                a_chuj(2,2,num_conti,i)= 0.0d0
2535 c             endif
2536 C     --- and its gradients
2537 cd                write (iout,*) 'i',i,' j',j
2538 cd                do kkk=1,3
2539 cd                write (iout,*) 'iii 1 kkk',kkk
2540 cd                write (iout,*) agg(kkk,:)
2541 cd                enddo
2542 cd                do kkk=1,3
2543 cd                write (iout,*) 'iii 2 kkk',kkk
2544 cd                write (iout,*) aggi(kkk,:)
2545 cd                enddo
2546 cd                do kkk=1,3
2547 cd                write (iout,*) 'iii 3 kkk',kkk
2548 cd                write (iout,*) aggi1(kkk,:)
2549 cd                enddo
2550 cd                do kkk=1,3
2551 cd                write (iout,*) 'iii 4 kkk',kkk
2552 cd                write (iout,*) aggj(kkk,:)
2553 cd                enddo
2554 cd                do kkk=1,3
2555 cd                write (iout,*) 'iii 5 kkk',kkk
2556 cd                write (iout,*) aggj1(kkk,:)
2557 cd                enddo
2558                 kkll=0
2559                 do k=1,2
2560                   do l=1,2
2561                     kkll=kkll+1
2562                     do m=1,3
2563                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2564                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2565                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2566                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2567                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2568 c                      do mm=1,5
2569 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2570 c                      enddo
2571                     enddo
2572                   enddo
2573                 enddo
2574                 ENDIF
2575                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2576 C Calculate contact energies
2577                 cosa4=4.0D0*cosa
2578                 wij=cosa-3.0D0*cosb*cosg
2579                 cosbg1=cosb+cosg
2580                 cosbg2=cosb-cosg
2581 c               fac3=dsqrt(-ael6i)/r0ij**3
2582                 fac3=dsqrt(-ael6i)*r3ij
2583                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2584                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2585 c               ees0mij=0.0D0
2586                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2587                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2588 C Diagnostics. Comment out or remove after debugging!
2589 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2590 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2591 c               ees0m(num_conti,i)=0.0D0
2592 C End diagnostics.
2593 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2594 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2595                 facont_hb(num_conti,i)=fcont
2596                 if (calc_grad) then
2597 C Angular derivatives of the contact function
2598                 ees0pij1=fac3/ees0pij
2599                 ees0mij1=fac3/ees0mij
2600                 fac3p=-3.0D0*fac3*rrmij
2601                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2602                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2603 c               ees0mij1=0.0D0
2604                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2605                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2606                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2607                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2608                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2609                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2610                 ecosap=ecosa1+ecosa2
2611                 ecosbp=ecosb1+ecosb2
2612                 ecosgp=ecosg1+ecosg2
2613                 ecosam=ecosa1-ecosa2
2614                 ecosbm=ecosb1-ecosb2
2615                 ecosgm=ecosg1-ecosg2
2616 C Diagnostics
2617 c               ecosap=ecosa1
2618 c               ecosbp=ecosb1
2619 c               ecosgp=ecosg1
2620 c               ecosam=0.0D0
2621 c               ecosbm=0.0D0
2622 c               ecosgm=0.0D0
2623 C End diagnostics
2624                 fprimcont=fprimcont/rij
2625 cd              facont_hb(num_conti,i)=1.0D0
2626 C Following line is for diagnostics.
2627 cd              fprimcont=0.0D0
2628                 do k=1,3
2629                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2630                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2631                 enddo
2632                 do k=1,3
2633                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2634                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2635                 enddo
2636                 gggp(1)=gggp(1)+ees0pijp*xj
2637                 gggp(2)=gggp(2)+ees0pijp*yj
2638                 gggp(3)=gggp(3)+ees0pijp*zj
2639                 gggm(1)=gggm(1)+ees0mijp*xj
2640                 gggm(2)=gggm(2)+ees0mijp*yj
2641                 gggm(3)=gggm(3)+ees0mijp*zj
2642 C Derivatives due to the contact function
2643                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2644                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2645                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2646                 do k=1,3
2647                   ghalfp=0.5D0*gggp(k)
2648                   ghalfm=0.5D0*gggm(k)
2649                   gacontp_hb1(k,num_conti,i)=ghalfp
2650      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2651      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2652                   gacontp_hb2(k,num_conti,i)=ghalfp
2653      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2654      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2655                   gacontp_hb3(k,num_conti,i)=gggp(k)
2656                   gacontm_hb1(k,num_conti,i)=ghalfm
2657      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2658      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2659                   gacontm_hb2(k,num_conti,i)=ghalfm
2660      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2661      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2662                   gacontm_hb3(k,num_conti,i)=gggm(k)
2663                 enddo
2664                 endif
2665 C Diagnostics. Comment out or remove after debugging!
2666 cdiag           do k=1,3
2667 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2668 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2669 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2670 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2671 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2672 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2673 cdiag           enddo
2674               ENDIF ! wcorr
2675               endif  ! num_conti.le.maxconts
2676             endif  ! fcont.gt.0
2677           endif    ! j.gt.i+1
2678  1216     continue
2679         enddo ! j
2680         num_cont_hb(i)=num_conti
2681  1215   continue
2682       enddo   ! i
2683 cd      do i=1,nres
2684 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2685 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2686 cd      enddo
2687 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2688 ccc      eel_loc=eel_loc+eello_turn3
2689       return
2690       end
2691 C-----------------------------------------------------------------------------
2692       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2693 C Third- and fourth-order contributions from turns
2694       implicit real*8 (a-h,o-z)
2695       include 'DIMENSIONS'
2696       include 'DIMENSIONS.ZSCOPT'
2697       include 'COMMON.IOUNITS'
2698       include 'COMMON.GEO'
2699       include 'COMMON.VAR'
2700       include 'COMMON.LOCAL'
2701       include 'COMMON.CHAIN'
2702       include 'COMMON.DERIV'
2703       include 'COMMON.INTERACT'
2704       include 'COMMON.CONTACTS'
2705       include 'COMMON.TORSION'
2706       include 'COMMON.VECTORS'
2707       include 'COMMON.FFIELD'
2708       dimension ggg(3)
2709       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2710      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2711      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2712       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2713      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2714       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2715       if (j.eq.i+2) then
2716 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2717 C
2718 C               Third-order contributions
2719 C
2720 C                 (i+2)o----(i+3)
2721 C                      | |
2722 C                      | |
2723 C                 (i+1)o----i
2724 C
2725 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2726 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2727         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2728         call transpose2(auxmat(1,1),auxmat1(1,1))
2729         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2730         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2731 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2732 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2733 cd     &    ' eello_turn3_num',4*eello_turn3_num
2734         if (calc_grad) then
2735 C Derivatives in gamma(i)
2736         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2737         call transpose2(auxmat2(1,1),pizda(1,1))
2738         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2739         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2740 C Derivatives in gamma(i+1)
2741         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2742         call transpose2(auxmat2(1,1),pizda(1,1))
2743         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2744         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2745      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2746 C Cartesian derivatives
2747         do l=1,3
2748           a_temp(1,1)=aggi(l,1)
2749           a_temp(1,2)=aggi(l,2)
2750           a_temp(2,1)=aggi(l,3)
2751           a_temp(2,2)=aggi(l,4)
2752           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2753           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2754      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2755           a_temp(1,1)=aggi1(l,1)
2756           a_temp(1,2)=aggi1(l,2)
2757           a_temp(2,1)=aggi1(l,3)
2758           a_temp(2,2)=aggi1(l,4)
2759           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2760           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2761      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2762           a_temp(1,1)=aggj(l,1)
2763           a_temp(1,2)=aggj(l,2)
2764           a_temp(2,1)=aggj(l,3)
2765           a_temp(2,2)=aggj(l,4)
2766           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2767           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2768      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2769           a_temp(1,1)=aggj1(l,1)
2770           a_temp(1,2)=aggj1(l,2)
2771           a_temp(2,1)=aggj1(l,3)
2772           a_temp(2,2)=aggj1(l,4)
2773           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2774           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2775      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2776         enddo
2777         endif
2778       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
2779 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2780 C
2781 C               Fourth-order contributions
2782 C
2783 C                 (i+3)o----(i+4)
2784 C                     /  |
2785 C               (i+2)o   |
2786 C                     \  |
2787 C                 (i+1)o----i
2788 C
2789 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2790 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2791         iti1=itortyp(itype(i+1))
2792         iti2=itortyp(itype(i+2))
2793         iti3=itortyp(itype(i+3))
2794         call transpose2(EUg(1,1,i+1),e1t(1,1))
2795         call transpose2(Eug(1,1,i+2),e2t(1,1))
2796         call transpose2(Eug(1,1,i+3),e3t(1,1))
2797         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2798         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2799         s1=scalar2(b1(1,iti2),auxvec(1))
2800         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2801         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2802         s2=scalar2(b1(1,iti1),auxvec(1))
2803         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2804         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2805         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2806         eello_turn4=eello_turn4-(s1+s2+s3)
2807 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2808 cd     &    ' eello_turn4_num',8*eello_turn4_num
2809 C Derivatives in gamma(i)
2810         if (calc_grad) then
2811         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2812         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2813         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2814         s1=scalar2(b1(1,iti2),auxvec(1))
2815         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2816         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2817         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2818 C Derivatives in gamma(i+1)
2819         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2820         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2821         s2=scalar2(b1(1,iti1),auxvec(1))
2822         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2823         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2824         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2825         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2826 C Derivatives in gamma(i+2)
2827         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2828         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2829         s1=scalar2(b1(1,iti2),auxvec(1))
2830         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2831         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2832         s2=scalar2(b1(1,iti1),auxvec(1))
2833         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2834         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2835         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2836         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2837 C Cartesian derivatives
2838 C Derivatives of this turn contributions in DC(i+2)
2839         if (j.lt.nres-1) then
2840           do l=1,3
2841             a_temp(1,1)=agg(l,1)
2842             a_temp(1,2)=agg(l,2)
2843             a_temp(2,1)=agg(l,3)
2844             a_temp(2,2)=agg(l,4)
2845             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2846             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2847             s1=scalar2(b1(1,iti2),auxvec(1))
2848             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2849             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2850             s2=scalar2(b1(1,iti1),auxvec(1))
2851             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2852             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2853             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2854             ggg(l)=-(s1+s2+s3)
2855             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2856           enddo
2857         endif
2858 C Remaining derivatives of this turn contribution
2859         do l=1,3
2860           a_temp(1,1)=aggi(l,1)
2861           a_temp(1,2)=aggi(l,2)
2862           a_temp(2,1)=aggi(l,3)
2863           a_temp(2,2)=aggi(l,4)
2864           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2865           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2866           s1=scalar2(b1(1,iti2),auxvec(1))
2867           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2868           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2869           s2=scalar2(b1(1,iti1),auxvec(1))
2870           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2871           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2872           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2873           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2874           a_temp(1,1)=aggi1(l,1)
2875           a_temp(1,2)=aggi1(l,2)
2876           a_temp(2,1)=aggi1(l,3)
2877           a_temp(2,2)=aggi1(l,4)
2878           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2879           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2880           s1=scalar2(b1(1,iti2),auxvec(1))
2881           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2882           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2883           s2=scalar2(b1(1,iti1),auxvec(1))
2884           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2885           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2886           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2887           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2888           a_temp(1,1)=aggj(l,1)
2889           a_temp(1,2)=aggj(l,2)
2890           a_temp(2,1)=aggj(l,3)
2891           a_temp(2,2)=aggj(l,4)
2892           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2893           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2894           s1=scalar2(b1(1,iti2),auxvec(1))
2895           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2896           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2897           s2=scalar2(b1(1,iti1),auxvec(1))
2898           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2899           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2900           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2901           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2902           a_temp(1,1)=aggj1(l,1)
2903           a_temp(1,2)=aggj1(l,2)
2904           a_temp(2,1)=aggj1(l,3)
2905           a_temp(2,2)=aggj1(l,4)
2906           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2907           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2908           s1=scalar2(b1(1,iti2),auxvec(1))
2909           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2910           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2911           s2=scalar2(b1(1,iti1),auxvec(1))
2912           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2913           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2914           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2915           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2916         enddo
2917         endif
2918       endif
2919       return
2920       end
2921 C-----------------------------------------------------------------------------
2922       subroutine vecpr(u,v,w)
2923       implicit real*8(a-h,o-z)
2924       dimension u(3),v(3),w(3)
2925       w(1)=u(2)*v(3)-u(3)*v(2)
2926       w(2)=-u(1)*v(3)+u(3)*v(1)
2927       w(3)=u(1)*v(2)-u(2)*v(1)
2928       return
2929       end
2930 C-----------------------------------------------------------------------------
2931       subroutine unormderiv(u,ugrad,unorm,ungrad)
2932 C This subroutine computes the derivatives of a normalized vector u, given
2933 C the derivatives computed without normalization conditions, ugrad. Returns
2934 C ungrad.
2935       implicit none
2936       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2937       double precision vec(3)
2938       double precision scalar
2939       integer i,j
2940 c      write (2,*) 'ugrad',ugrad
2941 c      write (2,*) 'u',u
2942       do i=1,3
2943         vec(i)=scalar(ugrad(1,i),u(1))
2944       enddo
2945 c      write (2,*) 'vec',vec
2946       do i=1,3
2947         do j=1,3
2948           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2949         enddo
2950       enddo
2951 c      write (2,*) 'ungrad',ungrad
2952       return
2953       end
2954 C-----------------------------------------------------------------------------
2955       subroutine escp(evdw2,evdw2_14)
2956 C
2957 C This subroutine calculates the excluded-volume interaction energy between
2958 C peptide-group centers and side chains and its gradient in virtual-bond and
2959 C side-chain vectors.
2960 C
2961       implicit real*8 (a-h,o-z)
2962       include 'DIMENSIONS'
2963       include 'DIMENSIONS.ZSCOPT'
2964       include 'COMMON.GEO'
2965       include 'COMMON.VAR'
2966       include 'COMMON.LOCAL'
2967       include 'COMMON.CHAIN'
2968       include 'COMMON.DERIV'
2969       include 'COMMON.INTERACT'
2970       include 'COMMON.FFIELD'
2971       include 'COMMON.IOUNITS'
2972       dimension ggg(3)
2973       evdw2=0.0D0
2974       evdw2_14=0.0d0
2975 cd    print '(a)','Enter ESCP'
2976 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2977 c     &  ' scal14',scal14
2978       do i=iatscp_s,iatscp_e
2979         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2980         iteli=itel(i)
2981 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2982 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2983         if (iteli.eq.0) goto 1225
2984         xi=0.5D0*(c(1,i)+c(1,i+1))
2985         yi=0.5D0*(c(2,i)+c(2,i+1))
2986         zi=0.5D0*(c(3,i)+c(3,i+1))
2987 C Returning the ith atom to box
2988           xi=mod(xi,boxxsize)
2989           if (xi.lt.0) xi=xi+boxxsize
2990           yi=mod(yi,boxysize)
2991           if (yi.lt.0) yi=yi+boxysize
2992           zi=mod(zi,boxzsize)
2993           if (zi.lt.0) zi=zi+boxzsize
2994         do iint=1,nscp_gr(i)
2995
2996         do j=iscpstart(i,iint),iscpend(i,iint)
2997           itypj=iabs(itype(j))
2998           if (itypj.eq.ntyp1) cycle
2999 C Uncomment following three lines for SC-p interactions
3000 c         xj=c(1,nres+j)-xi
3001 c         yj=c(2,nres+j)-yi
3002 c         zj=c(3,nres+j)-zi
3003 C Uncomment following three lines for Ca-p interactions
3004           xj=c(1,j)
3005           yj=c(2,j)
3006           zj=c(3,j)
3007 C returning the jth atom to box
3008           xj=mod(xj,boxxsize)
3009           if (xj.lt.0) xj=xj+boxxsize
3010           yj=mod(yj,boxysize)
3011           if (yj.lt.0) yj=yj+boxysize
3012           zj=mod(zj,boxzsize)
3013           if (zj.lt.0) zj=zj+boxzsize
3014       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3015       xj_safe=xj
3016       yj_safe=yj
3017       zj_safe=zj
3018       subchap=0
3019 C Finding the closest jth atom
3020       do xshift=-1,1
3021       do yshift=-1,1
3022       do zshift=-1,1
3023           xj=xj_safe+xshift*boxxsize
3024           yj=yj_safe+yshift*boxysize
3025           zj=zj_safe+zshift*boxzsize
3026           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3027           if(dist_temp.lt.dist_init) then
3028             dist_init=dist_temp
3029             xj_temp=xj
3030             yj_temp=yj
3031             zj_temp=zj
3032             subchap=1
3033           endif
3034        enddo
3035        enddo
3036        enddo
3037        if (subchap.eq.1) then
3038           xj=xj_temp-xi
3039           yj=yj_temp-yi
3040           zj=zj_temp-zi
3041        else
3042           xj=xj_safe-xi
3043           yj=yj_safe-yi
3044           zj=zj_safe-zi
3045        endif
3046           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3047 C sss is scaling function for smoothing the cutoff gradient otherwise
3048 C the gradient would not be continuouse
3049           sss=sscale(1.0d0/(dsqrt(rrij)))
3050           if (sss.le.0.0d0) cycle
3051           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3052           fac=rrij**expon2
3053           e1=fac*fac*aad(itypj,iteli)
3054           e2=fac*bad(itypj,iteli)
3055           if (iabs(j-i) .le. 2) then
3056             e1=scal14*e1
3057             e2=scal14*e2
3058             evdw2_14=evdw2_14+(e1+e2)*sss
3059           endif
3060           evdwij=e1+e2
3061 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3062 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3063 c     &       bad(itypj,iteli)
3064           evdw2=evdw2+evdwij*sss
3065           if (calc_grad) then
3066 C
3067 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3068 C
3069           fac=-(evdwij+e1)*rrij*sss
3070           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3071           ggg(1)=xj*fac
3072           ggg(2)=yj*fac
3073           ggg(3)=zj*fac
3074           if (j.lt.i) then
3075 cd          write (iout,*) 'j<i'
3076 C Uncomment following three lines for SC-p interactions
3077 c           do k=1,3
3078 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3079 c           enddo
3080           else
3081 cd          write (iout,*) 'j>i'
3082             do k=1,3
3083               ggg(k)=-ggg(k)
3084 C Uncomment following line for SC-p interactions
3085 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3086             enddo
3087           endif
3088           do k=1,3
3089             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3090           enddo
3091           kstart=min0(i+1,j)
3092           kend=max0(i-1,j-1)
3093 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3094 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3095           do k=kstart,kend
3096             do l=1,3
3097               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3098             enddo
3099           enddo
3100           endif
3101         enddo
3102         enddo ! iint
3103  1225   continue
3104       enddo ! i
3105       do i=1,nct
3106         do j=1,3
3107           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3108           gradx_scp(j,i)=expon*gradx_scp(j,i)
3109         enddo
3110       enddo
3111 C******************************************************************************
3112 C
3113 C                              N O T E !!!
3114 C
3115 C To save time the factor EXPON has been extracted from ALL components
3116 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3117 C use!
3118 C
3119 C******************************************************************************
3120       return
3121       end
3122 C--------------------------------------------------------------------------
3123       subroutine edis(ehpb)
3124 C
3125 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3126 C
3127       implicit real*8 (a-h,o-z)
3128       include 'DIMENSIONS'
3129       include 'DIMENSIONS.ZSCOPT'
3130       include 'COMMON.SBRIDGE'
3131       include 'COMMON.CHAIN'
3132       include 'COMMON.DERIV'
3133       include 'COMMON.VAR'
3134       include 'COMMON.INTERACT'
3135       include 'COMMON.CONTROL'
3136       include 'COMMON.IOUNITS'
3137       dimension ggg(3)
3138       ehpb=0.0D0
3139 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3140 cd    print *,'link_start=',link_start,' link_end=',link_end
3141 C      write(iout,*) link_end, "link_end"
3142       if (link_end.eq.0) return
3143       do i=link_start,link_end
3144 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3145 C CA-CA distance used in regularization of structure.
3146         ii=ihpb(i)
3147         jj=jhpb(i)
3148 C iii and jjj point to the residues for which the distance is assigned.
3149         if (ii.gt.nres) then
3150           iii=ii-nres
3151           jjj=jj-nres
3152         else
3153           iii=ii
3154           jjj=jj
3155         endif
3156 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3157 C    distance and angle dependent SS bond potential.
3158 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3159 C     & iabs(itype(jjj)).eq.1) then
3160 C       write(iout,*) constr_dist,"const"
3161        if (.not.dyn_ss .and. i.le.nss) then
3162          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3163      & iabs(itype(jjj)).eq.1) then
3164           call ssbond_ene(iii,jjj,eij)
3165           ehpb=ehpb+2*eij
3166            endif !ii.gt.neres
3167         else if (ii.gt.nres .and. jj.gt.nres) then
3168 c Restraints from contact prediction
3169           dd=dist(ii,jj)
3170           if (constr_dist.eq.11) then
3171 C            ehpb=ehpb+fordepth(i)**4.0d0
3172 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3173             ehpb=ehpb+fordepth(i)**4.0d0
3174      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3175             fac=fordepth(i)**4.0d0
3176      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3177 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3178 C     &    ehpb,fordepth(i),dd
3179 C            write(iout,*) ehpb,"atu?"
3180 C            ehpb,"tu?"
3181 C            fac=fordepth(i)**4.0d0
3182 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3183            else
3184           if (dhpb1(i).gt.0.0d0) then
3185             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3186             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3187 c            write (iout,*) "beta nmr",
3188 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3189           else
3190             dd=dist(ii,jj)
3191             rdis=dd-dhpb(i)
3192 C Get the force constant corresponding to this distance.
3193             waga=forcon(i)
3194 C Calculate the contribution to energy.
3195             ehpb=ehpb+waga*rdis*rdis
3196 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3197 C
3198 C Evaluate gradient.
3199 C
3200             fac=waga*rdis/dd
3201           endif !end dhpb1(i).gt.0
3202           endif !end const_dist=11
3203           do j=1,3
3204             ggg(j)=fac*(c(j,jj)-c(j,ii))
3205           enddo
3206           do j=1,3
3207             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3208             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3209           enddo
3210           do k=1,3
3211             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3212             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3213           enddo
3214         else !ii.gt.nres
3215 C          write(iout,*) "before"
3216           dd=dist(ii,jj)
3217 C          write(iout,*) "after",dd
3218           if (constr_dist.eq.11) then
3219             ehpb=ehpb+fordepth(i)**4.0d0
3220      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3221             fac=fordepth(i)**4.0d0
3222      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3223 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3224 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3225 C            print *,ehpb,"tu?"
3226 C            write(iout,*) ehpb,"btu?",
3227 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3228 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3229 C     &    ehpb,fordepth(i),dd
3230            else
3231           if (dhpb1(i).gt.0.0d0) then
3232             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3233             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3234 c            write (iout,*) "alph nmr",
3235 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3236           else
3237             rdis=dd-dhpb(i)
3238 C Get the force constant corresponding to this distance.
3239             waga=forcon(i)
3240 C Calculate the contribution to energy.
3241             ehpb=ehpb+waga*rdis*rdis
3242 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3243 C
3244 C Evaluate gradient.
3245 C
3246             fac=waga*rdis/dd
3247           endif
3248           endif
3249
3250         do j=1,3
3251           ggg(j)=fac*(c(j,jj)-c(j,ii))
3252         enddo
3253 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3254 C If this is a SC-SC distance, we need to calculate the contributions to the
3255 C Cartesian gradient in the SC vectors (ghpbx).
3256         if (iii.lt.ii) then
3257           do j=1,3
3258             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3259             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3260           enddo
3261         endif
3262         do j=iii,jjj-1
3263           do k=1,3
3264             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3265           enddo
3266         enddo
3267         endif
3268       enddo
3269       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3270       return
3271       end
3272 C--------------------------------------------------------------------------
3273       subroutine ssbond_ene(i,j,eij)
3274 C
3275 C Calculate the distance and angle dependent SS-bond potential energy
3276 C using a free-energy function derived based on RHF/6-31G** ab initio
3277 C calculations of diethyl disulfide.
3278 C
3279 C A. Liwo and U. Kozlowska, 11/24/03
3280 C
3281       implicit real*8 (a-h,o-z)
3282       include 'DIMENSIONS'
3283       include 'DIMENSIONS.ZSCOPT'
3284       include 'COMMON.SBRIDGE'
3285       include 'COMMON.CHAIN'
3286       include 'COMMON.DERIV'
3287       include 'COMMON.LOCAL'
3288       include 'COMMON.INTERACT'
3289       include 'COMMON.VAR'
3290       include 'COMMON.IOUNITS'
3291       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3292       itypi=iabs(itype(i))
3293       xi=c(1,nres+i)
3294       yi=c(2,nres+i)
3295       zi=c(3,nres+i)
3296       dxi=dc_norm(1,nres+i)
3297       dyi=dc_norm(2,nres+i)
3298       dzi=dc_norm(3,nres+i)
3299       dsci_inv=dsc_inv(itypi)
3300       itypj=iabs(itype(j))
3301       dscj_inv=dsc_inv(itypj)
3302       xj=c(1,nres+j)-xi
3303       yj=c(2,nres+j)-yi
3304       zj=c(3,nres+j)-zi
3305       dxj=dc_norm(1,nres+j)
3306       dyj=dc_norm(2,nres+j)
3307       dzj=dc_norm(3,nres+j)
3308       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3309       rij=dsqrt(rrij)
3310       erij(1)=xj*rij
3311       erij(2)=yj*rij
3312       erij(3)=zj*rij
3313       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3314       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3315       om12=dxi*dxj+dyi*dyj+dzi*dzj
3316       do k=1,3
3317         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3318         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3319       enddo
3320       rij=1.0d0/rij
3321       deltad=rij-d0cm
3322       deltat1=1.0d0-om1
3323       deltat2=1.0d0+om2
3324       deltat12=om2-om1+2.0d0
3325       cosphi=om12-om1*om2
3326       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3327      &  +akct*deltad*deltat12
3328      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3329 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3330 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3331 c     &  " deltat12",deltat12," eij",eij
3332       ed=2*akcm*deltad+akct*deltat12
3333       pom1=akct*deltad
3334       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3335       eom1=-2*akth*deltat1-pom1-om2*pom2
3336       eom2= 2*akth*deltat2+pom1-om1*pom2
3337       eom12=pom2
3338       do k=1,3
3339         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3340       enddo
3341       do k=1,3
3342         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3343      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3344         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3345      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3346       enddo
3347 C
3348 C Calculate the components of the gradient in DC and X
3349 C
3350       do k=i,j-1
3351         do l=1,3
3352           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3353         enddo
3354       enddo
3355       return
3356       end
3357 C--------------------------------------------------------------------------
3358       subroutine ebond(estr)
3359 c
3360 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3361 c
3362       implicit real*8 (a-h,o-z)
3363       include 'DIMENSIONS'
3364       include 'DIMENSIONS.ZSCOPT'
3365       include 'COMMON.LOCAL'
3366       include 'COMMON.GEO'
3367       include 'COMMON.INTERACT'
3368       include 'COMMON.DERIV'
3369       include 'COMMON.VAR'
3370       include 'COMMON.CHAIN'
3371       include 'COMMON.IOUNITS'
3372       include 'COMMON.NAMES'
3373       include 'COMMON.FFIELD'
3374       include 'COMMON.CONTROL'
3375       logical energy_dec /.false./
3376       double precision u(3),ud(3)
3377       estr=0.0d0
3378       estr1=0.0d0
3379 c      write (iout,*) "distchainmax",distchainmax
3380       do i=nnt+1,nct
3381         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3382 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3383 C          do j=1,3
3384 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3385 C     &      *dc(j,i-1)/vbld(i)
3386 C          enddo
3387 C          if (energy_dec) write(iout,*)
3388 C     &       "estr1",i,vbld(i),distchainmax,
3389 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3390 C        else
3391          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3392         diff = vbld(i)-vbldpDUM
3393          else
3394           diff = vbld(i)-vbldp0
3395 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3396          endif
3397           estr=estr+diff*diff
3398           do j=1,3
3399             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3400           enddo
3401 C        endif
3402 C        write (iout,'(a7,i5,4f7.3)')
3403 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3404       enddo
3405       estr=0.5d0*AKP*estr+estr1
3406 c
3407 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3408 c
3409       do i=nnt,nct
3410         iti=iabs(itype(i))
3411         if (iti.ne.10 .and. iti.ne.ntyp1) then
3412           nbi=nbondterm(iti)
3413           if (nbi.eq.1) then
3414             diff=vbld(i+nres)-vbldsc0(1,iti)
3415 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3416 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3417             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3418             do j=1,3
3419               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3420             enddo
3421           else
3422             do j=1,nbi
3423               diff=vbld(i+nres)-vbldsc0(j,iti)
3424               ud(j)=aksc(j,iti)*diff
3425               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3426             enddo
3427             uprod=u(1)
3428             do j=2,nbi
3429               uprod=uprod*u(j)
3430             enddo
3431             usum=0.0d0
3432             usumsqder=0.0d0
3433             do j=1,nbi
3434               uprod1=1.0d0
3435               uprod2=1.0d0
3436               do k=1,nbi
3437                 if (k.ne.j) then
3438                   uprod1=uprod1*u(k)
3439                   uprod2=uprod2*u(k)*u(k)
3440                 endif
3441               enddo
3442               usum=usum+uprod1
3443               usumsqder=usumsqder+ud(j)*uprod2
3444             enddo
3445 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3446 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3447             estr=estr+uprod/usum
3448             do j=1,3
3449              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3450             enddo
3451           endif
3452         endif
3453       enddo
3454       return
3455       end
3456 #ifdef CRYST_THETA
3457 C--------------------------------------------------------------------------
3458       subroutine ebend(etheta,ethetacnstr)
3459 C
3460 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3461 C angles gamma and its derivatives in consecutive thetas and gammas.
3462 C
3463       implicit real*8 (a-h,o-z)
3464       include 'DIMENSIONS'
3465       include 'DIMENSIONS.ZSCOPT'
3466       include 'COMMON.LOCAL'
3467       include 'COMMON.GEO'
3468       include 'COMMON.INTERACT'
3469       include 'COMMON.DERIV'
3470       include 'COMMON.VAR'
3471       include 'COMMON.CHAIN'
3472       include 'COMMON.IOUNITS'
3473       include 'COMMON.NAMES'
3474       include 'COMMON.FFIELD'
3475       include 'COMMON.TORCNSTR'
3476       common /calcthet/ term1,term2,termm,diffak,ratak,
3477      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3478      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3479       double precision y(2),z(2)
3480       delta=0.02d0*pi
3481 c      time11=dexp(-2*time)
3482 c      time12=1.0d0
3483       etheta=0.0D0
3484 c      write (iout,*) "nres",nres
3485 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3486 c      write (iout,*) ithet_start,ithet_end
3487       do i=ithet_start,ithet_end
3488 C        if (itype(i-1).eq.ntyp1) cycle
3489         if (i.le.2) cycle
3490         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3491      &  .or.itype(i).eq.ntyp1) cycle
3492 C Zero the energy function and its derivative at 0 or pi.
3493         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3494         it=itype(i-1)
3495         ichir1=isign(1,itype(i-2))
3496         ichir2=isign(1,itype(i))
3497          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
3498          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
3499          if (itype(i-1).eq.10) then
3500           itype1=isign(10,itype(i-2))
3501           ichir11=isign(1,itype(i-2))
3502           ichir12=isign(1,itype(i-2))
3503           itype2=isign(10,itype(i))
3504           ichir21=isign(1,itype(i))
3505           ichir22=isign(1,itype(i))
3506          endif
3507          if (i.eq.3) then
3508           y(1)=0.0D0
3509           y(2)=0.0D0
3510           else
3511
3512         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3513 #ifdef OSF
3514           phii=phi(i)
3515 c          icrc=0
3516 c          call proc_proc(phii,icrc)
3517           if (icrc.eq.1) phii=150.0
3518 #else
3519           phii=phi(i)
3520 #endif
3521           y(1)=dcos(phii)
3522           y(2)=dsin(phii)
3523         else
3524           y(1)=0.0D0
3525           y(2)=0.0D0
3526         endif
3527         endif
3528         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3529 #ifdef OSF
3530           phii1=phi(i+1)
3531 c          icrc=0
3532 c          call proc_proc(phii1,icrc)
3533           if (icrc.eq.1) phii1=150.0
3534           phii1=pinorm(phii1)
3535           z(1)=cos(phii1)
3536 #else
3537           phii1=phi(i+1)
3538           z(1)=dcos(phii1)
3539 #endif
3540           z(2)=dsin(phii1)
3541         else
3542           z(1)=0.0D0
3543           z(2)=0.0D0
3544         endif
3545 C Calculate the "mean" value of theta from the part of the distribution
3546 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3547 C In following comments this theta will be referred to as t_c.
3548         thet_pred_mean=0.0d0
3549         do k=1,2
3550             athetk=athet(k,it,ichir1,ichir2)
3551             bthetk=bthet(k,it,ichir1,ichir2)
3552           if (it.eq.10) then
3553              athetk=athet(k,itype1,ichir11,ichir12)
3554              bthetk=bthet(k,itype2,ichir21,ichir22)
3555           endif
3556           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3557         enddo
3558 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3559         dthett=thet_pred_mean*ssd
3560         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3561 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3562 C Derivatives of the "mean" values in gamma1 and gamma2.
3563         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
3564      &+athet(2,it,ichir1,ichir2)*y(1))*ss
3565          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
3566      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
3567          if (it.eq.10) then
3568       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
3569      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
3570         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
3571      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
3572          endif
3573         if (theta(i).gt.pi-delta) then
3574           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3575      &         E_tc0)
3576           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3577           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3578           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3579      &        E_theta)
3580           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3581      &        E_tc)
3582         else if (theta(i).lt.delta) then
3583           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3584           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3585           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3586      &        E_theta)
3587           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3588           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3589      &        E_tc)
3590         else
3591           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3592      &        E_theta,E_tc)
3593         endif
3594         etheta=etheta+ethetai
3595 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
3596 c     &      'ebend',i,ethetai,theta(i),itype(i)
3597 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3598 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3599         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3600         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3601         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3602 c 1215   continue
3603       enddo
3604       ethetacnstr=0.0d0
3605 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
3606       do i=1,ntheta_constr
3607         itheta=itheta_constr(i)
3608         thetiii=theta(itheta)
3609         difi=pinorm(thetiii-theta_constr0(i))
3610         if (difi.gt.theta_drange(i)) then
3611           difi=difi-theta_drange(i)
3612           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3613           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3614      &    +for_thet_constr(i)*difi**3
3615         else if (difi.lt.-drange(i)) then
3616           difi=difi+drange(i)
3617           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3618           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3619      &    +for_thet_constr(i)*difi**3
3620         else
3621           difi=0.0
3622         endif
3623 C       if (energy_dec) then
3624 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
3625 C     &    i,itheta,rad2deg*thetiii,
3626 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
3627 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
3628 C     &    gloc(itheta+nphi-2,icg)
3629         endif
3630       enddo
3631 C Ufff.... We've done all this!!!
3632       return
3633       end
3634 C---------------------------------------------------------------------------
3635       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3636      &     E_tc)
3637       implicit real*8 (a-h,o-z)
3638       include 'DIMENSIONS'
3639       include 'COMMON.LOCAL'
3640       include 'COMMON.IOUNITS'
3641       common /calcthet/ term1,term2,termm,diffak,ratak,
3642      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3643      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3644 C Calculate the contributions to both Gaussian lobes.
3645 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3646 C The "polynomial part" of the "standard deviation" of this part of
3647 C the distribution.
3648         sig=polthet(3,it)
3649         do j=2,0,-1
3650           sig=sig*thet_pred_mean+polthet(j,it)
3651         enddo
3652 C Derivative of the "interior part" of the "standard deviation of the"
3653 C gamma-dependent Gaussian lobe in t_c.
3654         sigtc=3*polthet(3,it)
3655         do j=2,1,-1
3656           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3657         enddo
3658         sigtc=sig*sigtc
3659 C Set the parameters of both Gaussian lobes of the distribution.
3660 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3661         fac=sig*sig+sigc0(it)
3662         sigcsq=fac+fac
3663         sigc=1.0D0/sigcsq
3664 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3665         sigsqtc=-4.0D0*sigcsq*sigtc
3666 c       print *,i,sig,sigtc,sigsqtc
3667 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3668         sigtc=-sigtc/(fac*fac)
3669 C Following variable is sigma(t_c)**(-2)
3670         sigcsq=sigcsq*sigcsq
3671         sig0i=sig0(it)
3672         sig0inv=1.0D0/sig0i**2
3673         delthec=thetai-thet_pred_mean
3674         delthe0=thetai-theta0i
3675         term1=-0.5D0*sigcsq*delthec*delthec
3676         term2=-0.5D0*sig0inv*delthe0*delthe0
3677 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3678 C NaNs in taking the logarithm. We extract the largest exponent which is added
3679 C to the energy (this being the log of the distribution) at the end of energy
3680 C term evaluation for this virtual-bond angle.
3681         if (term1.gt.term2) then
3682           termm=term1
3683           term2=dexp(term2-termm)
3684           term1=1.0d0
3685         else
3686           termm=term2
3687           term1=dexp(term1-termm)
3688           term2=1.0d0
3689         endif
3690 C The ratio between the gamma-independent and gamma-dependent lobes of
3691 C the distribution is a Gaussian function of thet_pred_mean too.
3692         diffak=gthet(2,it)-thet_pred_mean
3693         ratak=diffak/gthet(3,it)**2
3694         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3695 C Let's differentiate it in thet_pred_mean NOW.
3696         aktc=ak*ratak
3697 C Now put together the distribution terms to make complete distribution.
3698         termexp=term1+ak*term2
3699         termpre=sigc+ak*sig0i
3700 C Contribution of the bending energy from this theta is just the -log of
3701 C the sum of the contributions from the two lobes and the pre-exponential
3702 C factor. Simple enough, isn't it?
3703         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3704 C NOW the derivatives!!!
3705 C 6/6/97 Take into account the deformation.
3706         E_theta=(delthec*sigcsq*term1
3707      &       +ak*delthe0*sig0inv*term2)/termexp
3708         E_tc=((sigtc+aktc*sig0i)/termpre
3709      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3710      &       aktc*term2)/termexp)
3711       return
3712       end
3713 c-----------------------------------------------------------------------------
3714       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3715       implicit real*8 (a-h,o-z)
3716       include 'DIMENSIONS'
3717       include 'COMMON.LOCAL'
3718       include 'COMMON.IOUNITS'
3719       common /calcthet/ term1,term2,termm,diffak,ratak,
3720      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3721      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3722       delthec=thetai-thet_pred_mean
3723       delthe0=thetai-theta0i
3724 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3725       t3 = thetai-thet_pred_mean
3726       t6 = t3**2
3727       t9 = term1
3728       t12 = t3*sigcsq
3729       t14 = t12+t6*sigsqtc
3730       t16 = 1.0d0
3731       t21 = thetai-theta0i
3732       t23 = t21**2
3733       t26 = term2
3734       t27 = t21*t26
3735       t32 = termexp
3736       t40 = t32**2
3737       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3738      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3739      & *(-t12*t9-ak*sig0inv*t27)
3740       return
3741       end
3742 #else
3743 C--------------------------------------------------------------------------
3744       subroutine ebend(etheta,ethetacnstr)
3745 C
3746 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3747 C angles gamma and its derivatives in consecutive thetas and gammas.
3748 C ab initio-derived potentials from
3749 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3750 C
3751       implicit real*8 (a-h,o-z)
3752       include 'DIMENSIONS'
3753       include 'DIMENSIONS.ZSCOPT'
3754       include 'COMMON.LOCAL'
3755       include 'COMMON.GEO'
3756       include 'COMMON.INTERACT'
3757       include 'COMMON.DERIV'
3758       include 'COMMON.VAR'
3759       include 'COMMON.CHAIN'
3760       include 'COMMON.IOUNITS'
3761       include 'COMMON.NAMES'
3762       include 'COMMON.FFIELD'
3763       include 'COMMON.CONTROL'
3764       include 'COMMON.TORCNSTR'
3765       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3766      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3767      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3768      & sinph1ph2(maxdouble,maxdouble)
3769       logical lprn /.false./, lprn1 /.false./
3770       etheta=0.0D0
3771 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
3772       do i=ithet_start,ithet_end
3773 C         if (i.eq.2) cycle
3774 C        if (itype(i-1).eq.ntyp1) cycle
3775         if (i.le.2) cycle
3776         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3777      &  .or.itype(i).eq.ntyp1) cycle
3778         if (iabs(itype(i+1)).eq.20) iblock=2
3779         if (iabs(itype(i+1)).ne.20) iblock=1
3780         dethetai=0.0d0
3781         dephii=0.0d0
3782         dephii1=0.0d0
3783         theti2=0.5d0*theta(i)
3784         ityp2=ithetyp((itype(i-1)))
3785         do k=1,nntheterm
3786           coskt(k)=dcos(k*theti2)
3787           sinkt(k)=dsin(k*theti2)
3788         enddo
3789         if (i.eq.3) then
3790           phii=0.0d0
3791           ityp1=nthetyp+1
3792           do k=1,nsingle
3793             cosph1(k)=0.0d0
3794             sinph1(k)=0.0d0
3795           enddo
3796         else
3797         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3798 #ifdef OSF
3799           phii=phi(i)
3800           if (phii.ne.phii) phii=150.0
3801 #else
3802           phii=phi(i)
3803 #endif
3804           ityp1=ithetyp((itype(i-2)))
3805           do k=1,nsingle
3806             cosph1(k)=dcos(k*phii)
3807             sinph1(k)=dsin(k*phii)
3808           enddo
3809         else
3810           phii=0.0d0
3811 c          ityp1=nthetyp+1
3812           do k=1,nsingle
3813             ityp1=ithetyp((itype(i-2)))
3814             cosph1(k)=0.0d0
3815             sinph1(k)=0.0d0
3816           enddo
3817         endif
3818         endif
3819         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3820 #ifdef OSF
3821           phii1=phi(i+1)
3822           if (phii1.ne.phii1) phii1=150.0
3823           phii1=pinorm(phii1)
3824 #else
3825           phii1=phi(i+1)
3826 #endif
3827           ityp3=ithetyp((itype(i)))
3828           do k=1,nsingle
3829             cosph2(k)=dcos(k*phii1)
3830             sinph2(k)=dsin(k*phii1)
3831           enddo
3832         else
3833           phii1=0.0d0
3834 c          ityp3=nthetyp+1
3835           ityp3=ithetyp((itype(i)))
3836           do k=1,nsingle
3837             cosph2(k)=0.0d0
3838             sinph2(k)=0.0d0
3839           enddo
3840         endif
3841 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3842 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3843 c        call flush(iout)
3844         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
3845         do k=1,ndouble
3846           do l=1,k-1
3847             ccl=cosph1(l)*cosph2(k-l)
3848             ssl=sinph1(l)*sinph2(k-l)
3849             scl=sinph1(l)*cosph2(k-l)
3850             csl=cosph1(l)*sinph2(k-l)
3851             cosph1ph2(l,k)=ccl-ssl
3852             cosph1ph2(k,l)=ccl+ssl
3853             sinph1ph2(l,k)=scl+csl
3854             sinph1ph2(k,l)=scl-csl
3855           enddo
3856         enddo
3857         if (lprn) then
3858         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3859      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3860         write (iout,*) "coskt and sinkt"
3861         do k=1,nntheterm
3862           write (iout,*) k,coskt(k),sinkt(k)
3863         enddo
3864         endif
3865         do k=1,ntheterm
3866           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
3867           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
3868      &      *coskt(k)
3869           if (lprn)
3870      &    write (iout,*) "k",k,"
3871      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
3872      &     " ethetai",ethetai
3873         enddo
3874         if (lprn) then
3875         write (iout,*) "cosph and sinph"
3876         do k=1,nsingle
3877           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3878         enddo
3879         write (iout,*) "cosph1ph2 and sinph2ph2"
3880         do k=2,ndouble
3881           do l=1,k-1
3882             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3883      &         sinph1ph2(l,k),sinph1ph2(k,l)
3884           enddo
3885         enddo
3886         write(iout,*) "ethetai",ethetai
3887         endif
3888         do m=1,ntheterm2
3889           do k=1,nsingle
3890             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
3891      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
3892      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
3893      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
3894             ethetai=ethetai+sinkt(m)*aux
3895             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3896             dephii=dephii+k*sinkt(m)*(
3897      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
3898      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
3899             dephii1=dephii1+k*sinkt(m)*(
3900      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
3901      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
3902             if (lprn)
3903      &      write (iout,*) "m",m," k",k," bbthet",
3904      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
3905      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
3906      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
3907      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
3908           enddo
3909         enddo
3910         if (lprn)
3911      &  write(iout,*) "ethetai",ethetai
3912         do m=1,ntheterm3
3913           do k=2,ndouble
3914             do l=1,k-1
3915               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
3916      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
3917      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
3918      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
3919               ethetai=ethetai+sinkt(m)*aux
3920               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3921               dephii=dephii+l*sinkt(m)*(
3922      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
3923      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
3924      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
3925      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
3926               dephii1=dephii1+(k-l)*sinkt(m)*(
3927      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
3928      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
3929      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
3930      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
3931               if (lprn) then
3932               write (iout,*) "m",m," k",k," l",l," ffthet",
3933      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
3934      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
3935      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
3936      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
3937      &            " ethetai",ethetai
3938               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3939      &            cosph1ph2(k,l)*sinkt(m),
3940      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3941               endif
3942             enddo
3943           enddo
3944         enddo
3945 10      continue
3946         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3947      &   i,theta(i)*rad2deg,phii*rad2deg,
3948      &   phii1*rad2deg,ethetai
3949         etheta=etheta+ethetai
3950         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3951         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3952 c        gloc(nphi+i-2,icg)=wang*dethetai
3953         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
3954       enddo
3955 C now constrains
3956       ethetacnstr=0.0d0
3957 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
3958       do i=1,ntheta_constr
3959         itheta=itheta_constr(i)
3960         thetiii=theta(itheta)
3961         difi=pinorm(thetiii-theta_constr0(i))
3962         if (difi.gt.theta_drange(i)) then
3963           difi=difi-theta_drange(i)
3964           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3965           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3966      &    +for_thet_constr(i)*difi**3
3967         else if (difi.lt.-drange(i)) then
3968           difi=difi+drange(i)
3969           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3970           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3971      &    +for_thet_constr(i)*difi**3
3972         else
3973           difi=0.0
3974         endif
3975 C       if (energy_dec) then
3976 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
3977 C     &    i,itheta,rad2deg*thetiii,
3978 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
3979 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
3980 C     &    gloc(itheta+nphi-2,icg)
3981 C        endif
3982       enddo
3983       return
3984       end
3985 #endif
3986 #ifdef CRYST_SC
3987 c-----------------------------------------------------------------------------
3988       subroutine esc(escloc)
3989 C Calculate the local energy of a side chain and its derivatives in the
3990 C corresponding virtual-bond valence angles THETA and the spherical angles
3991 C ALPHA and OMEGA.
3992       implicit real*8 (a-h,o-z)
3993       include 'DIMENSIONS'
3994       include 'DIMENSIONS.ZSCOPT'
3995       include 'COMMON.GEO'
3996       include 'COMMON.LOCAL'
3997       include 'COMMON.VAR'
3998       include 'COMMON.INTERACT'
3999       include 'COMMON.DERIV'
4000       include 'COMMON.CHAIN'
4001       include 'COMMON.IOUNITS'
4002       include 'COMMON.NAMES'
4003       include 'COMMON.FFIELD'
4004       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4005      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4006       common /sccalc/ time11,time12,time112,theti,it,nlobit
4007       delta=0.02d0*pi
4008       escloc=0.0D0
4009 C      write (iout,*) 'ESC'
4010       do i=loc_start,loc_end
4011         it=itype(i)
4012         if (it.eq.ntyp1) cycle
4013         if (it.eq.10) goto 1
4014         nlobit=nlob(iabs(it))
4015 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4016 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4017         theti=theta(i+1)-pipol
4018         x(1)=dtan(theti)
4019         x(2)=alph(i)
4020         x(3)=omeg(i)
4021 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4022
4023         if (x(2).gt.pi-delta) then
4024           xtemp(1)=x(1)
4025           xtemp(2)=pi-delta
4026           xtemp(3)=x(3)
4027           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4028           xtemp(2)=pi
4029           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4030           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4031      &        escloci,dersc(2))
4032           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4033      &        ddersc0(1),dersc(1))
4034           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4035      &        ddersc0(3),dersc(3))
4036           xtemp(2)=pi-delta
4037           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4038           xtemp(2)=pi
4039           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4040           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4041      &            dersc0(2),esclocbi,dersc02)
4042           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4043      &            dersc12,dersc01)
4044           call splinthet(x(2),0.5d0*delta,ss,ssd)
4045           dersc0(1)=dersc01
4046           dersc0(2)=dersc02
4047           dersc0(3)=0.0d0
4048           do k=1,3
4049             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4050           enddo
4051           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4052           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4053      &             esclocbi,ss,ssd
4054           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4055 c         escloci=esclocbi
4056 c         write (iout,*) escloci
4057         else if (x(2).lt.delta) then
4058           xtemp(1)=x(1)
4059           xtemp(2)=delta
4060           xtemp(3)=x(3)
4061           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4062           xtemp(2)=0.0d0
4063           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4064           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4065      &        escloci,dersc(2))
4066           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4067      &        ddersc0(1),dersc(1))
4068           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4069      &        ddersc0(3),dersc(3))
4070           xtemp(2)=delta
4071           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4072           xtemp(2)=0.0d0
4073           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4074           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4075      &            dersc0(2),esclocbi,dersc02)
4076           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4077      &            dersc12,dersc01)
4078           dersc0(1)=dersc01
4079           dersc0(2)=dersc02
4080           dersc0(3)=0.0d0
4081           call splinthet(x(2),0.5d0*delta,ss,ssd)
4082           do k=1,3
4083             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4084           enddo
4085           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4086 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4087 c     &             esclocbi,ss,ssd
4088           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4089 C         write (iout,*) 'i=',i, escloci
4090         else
4091           call enesc(x,escloci,dersc,ddummy,.false.)
4092         endif
4093
4094         escloc=escloc+escloci
4095 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4096             write (iout,'(a6,i5,0pf7.3)')
4097      &     'escloc',i,escloci
4098
4099         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4100      &   wscloc*dersc(1)
4101         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4102         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4103     1   continue
4104       enddo
4105       return
4106       end
4107 C---------------------------------------------------------------------------
4108       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4109       implicit real*8 (a-h,o-z)
4110       include 'DIMENSIONS'
4111       include 'COMMON.GEO'
4112       include 'COMMON.LOCAL'
4113       include 'COMMON.IOUNITS'
4114       common /sccalc/ time11,time12,time112,theti,it,nlobit
4115       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4116       double precision contr(maxlob,-1:1)
4117       logical mixed
4118 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4119         escloc_i=0.0D0
4120         do j=1,3
4121           dersc(j)=0.0D0
4122           if (mixed) ddersc(j)=0.0d0
4123         enddo
4124         x3=x(3)
4125
4126 C Because of periodicity of the dependence of the SC energy in omega we have
4127 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4128 C To avoid underflows, first compute & store the exponents.
4129
4130         do iii=-1,1
4131
4132           x(3)=x3+iii*dwapi
4133
4134           do j=1,nlobit
4135             do k=1,3
4136               z(k)=x(k)-censc(k,j,it)
4137             enddo
4138             do k=1,3
4139               Axk=0.0D0
4140               do l=1,3
4141                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4142               enddo
4143               Ax(k,j,iii)=Axk
4144             enddo
4145             expfac=0.0D0
4146             do k=1,3
4147               expfac=expfac+Ax(k,j,iii)*z(k)
4148             enddo
4149             contr(j,iii)=expfac
4150           enddo ! j
4151
4152         enddo ! iii
4153
4154         x(3)=x3
4155 C As in the case of ebend, we want to avoid underflows in exponentiation and
4156 C subsequent NaNs and INFs in energy calculation.
4157 C Find the largest exponent
4158         emin=contr(1,-1)
4159         do iii=-1,1
4160           do j=1,nlobit
4161             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4162           enddo
4163         enddo
4164         emin=0.5D0*emin
4165 cd      print *,'it=',it,' emin=',emin
4166
4167 C Compute the contribution to SC energy and derivatives
4168         do iii=-1,1
4169
4170           do j=1,nlobit
4171             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4172 cd          print *,'j=',j,' expfac=',expfac
4173             escloc_i=escloc_i+expfac
4174             do k=1,3
4175               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4176             enddo
4177             if (mixed) then
4178               do k=1,3,2
4179                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4180      &            +gaussc(k,2,j,it))*expfac
4181               enddo
4182             endif
4183           enddo
4184
4185         enddo ! iii
4186
4187         dersc(1)=dersc(1)/cos(theti)**2
4188         ddersc(1)=ddersc(1)/cos(theti)**2
4189         ddersc(3)=ddersc(3)
4190
4191         escloci=-(dlog(escloc_i)-emin)
4192         do j=1,3
4193           dersc(j)=dersc(j)/escloc_i
4194         enddo
4195         if (mixed) then
4196           do j=1,3,2
4197             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4198           enddo
4199         endif
4200       return
4201       end
4202 C------------------------------------------------------------------------------
4203       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4204       implicit real*8 (a-h,o-z)
4205       include 'DIMENSIONS'
4206       include 'COMMON.GEO'
4207       include 'COMMON.LOCAL'
4208       include 'COMMON.IOUNITS'
4209       common /sccalc/ time11,time12,time112,theti,it,nlobit
4210       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4211       double precision contr(maxlob)
4212       logical mixed
4213
4214       escloc_i=0.0D0
4215
4216       do j=1,3
4217         dersc(j)=0.0D0
4218       enddo
4219
4220       do j=1,nlobit
4221         do k=1,2
4222           z(k)=x(k)-censc(k,j,it)
4223         enddo
4224         z(3)=dwapi
4225         do k=1,3
4226           Axk=0.0D0
4227           do l=1,3
4228             Axk=Axk+gaussc(l,k,j,it)*z(l)
4229           enddo
4230           Ax(k,j)=Axk
4231         enddo
4232         expfac=0.0D0
4233         do k=1,3
4234           expfac=expfac+Ax(k,j)*z(k)
4235         enddo
4236         contr(j)=expfac
4237       enddo ! j
4238
4239 C As in the case of ebend, we want to avoid underflows in exponentiation and
4240 C subsequent NaNs and INFs in energy calculation.
4241 C Find the largest exponent
4242       emin=contr(1)
4243       do j=1,nlobit
4244         if (emin.gt.contr(j)) emin=contr(j)
4245       enddo
4246       emin=0.5D0*emin
4247
4248 C Compute the contribution to SC energy and derivatives
4249
4250       dersc12=0.0d0
4251       do j=1,nlobit
4252         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4253         escloc_i=escloc_i+expfac
4254         do k=1,2
4255           dersc(k)=dersc(k)+Ax(k,j)*expfac
4256         enddo
4257         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4258      &            +gaussc(1,2,j,it))*expfac
4259         dersc(3)=0.0d0
4260       enddo
4261
4262       dersc(1)=dersc(1)/cos(theti)**2
4263       dersc12=dersc12/cos(theti)**2
4264       escloci=-(dlog(escloc_i)-emin)
4265       do j=1,2
4266         dersc(j)=dersc(j)/escloc_i
4267       enddo
4268       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4269       return
4270       end
4271 #else
4272 c----------------------------------------------------------------------------------
4273       subroutine esc(escloc)
4274 C Calculate the local energy of a side chain and its derivatives in the
4275 C corresponding virtual-bond valence angles THETA and the spherical angles
4276 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4277 C added by Urszula Kozlowska. 07/11/2007
4278 C
4279       implicit real*8 (a-h,o-z)
4280       include 'DIMENSIONS'
4281       include 'DIMENSIONS.ZSCOPT'
4282       include 'COMMON.GEO'
4283       include 'COMMON.LOCAL'
4284       include 'COMMON.VAR'
4285       include 'COMMON.SCROT'
4286       include 'COMMON.INTERACT'
4287       include 'COMMON.DERIV'
4288       include 'COMMON.CHAIN'
4289       include 'COMMON.IOUNITS'
4290       include 'COMMON.NAMES'
4291       include 'COMMON.FFIELD'
4292       include 'COMMON.CONTROL'
4293       include 'COMMON.VECTORS'
4294       double precision x_prime(3),y_prime(3),z_prime(3)
4295      &    , sumene,dsc_i,dp2_i,x(65),
4296      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4297      &    de_dxx,de_dyy,de_dzz,de_dt
4298       double precision s1_t,s1_6_t,s2_t,s2_6_t
4299       double precision
4300      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4301      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4302      & dt_dCi(3),dt_dCi1(3)
4303       common /sccalc/ time11,time12,time112,theti,it,nlobit
4304       delta=0.02d0*pi
4305       escloc=0.0D0
4306       do i=loc_start,loc_end
4307         if (itype(i).eq.ntyp1) cycle
4308         costtab(i+1) =dcos(theta(i+1))
4309         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4310         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4311         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4312         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4313         cosfac=dsqrt(cosfac2)
4314         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4315         sinfac=dsqrt(sinfac2)
4316         it=iabs(itype(i))
4317         if (it.eq.10) goto 1
4318 c
4319 C  Compute the axes of tghe local cartesian coordinates system; store in
4320 c   x_prime, y_prime and z_prime
4321 c
4322         do j=1,3
4323           x_prime(j) = 0.00
4324           y_prime(j) = 0.00
4325           z_prime(j) = 0.00
4326         enddo
4327 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4328 C     &   dc_norm(3,i+nres)
4329         do j = 1,3
4330           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4331           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4332         enddo
4333         do j = 1,3
4334           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4335         enddo
4336 c       write (2,*) "i",i
4337 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4338 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4339 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4340 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4341 c      & " xy",scalar(x_prime(1),y_prime(1)),
4342 c      & " xz",scalar(x_prime(1),z_prime(1)),
4343 c      & " yy",scalar(y_prime(1),y_prime(1)),
4344 c      & " yz",scalar(y_prime(1),z_prime(1)),
4345 c      & " zz",scalar(z_prime(1),z_prime(1))
4346 c
4347 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4348 C to local coordinate system. Store in xx, yy, zz.
4349 c
4350         xx=0.0d0
4351         yy=0.0d0
4352         zz=0.0d0
4353         do j = 1,3
4354           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4355           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4356           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4357         enddo
4358
4359         xxtab(i)=xx
4360         yytab(i)=yy
4361         zztab(i)=zz
4362 C
4363 C Compute the energy of the ith side cbain
4364 C
4365 c        write (2,*) "xx",xx," yy",yy," zz",zz
4366         it=iabs(itype(i))
4367         do j = 1,65
4368           x(j) = sc_parmin(j,it)
4369         enddo
4370 #ifdef CHECK_COORD
4371 Cc diagnostics - remove later
4372         xx1 = dcos(alph(2))
4373         yy1 = dsin(alph(2))*dcos(omeg(2))
4374         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4375         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4376      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4377      &    xx1,yy1,zz1
4378 C,"  --- ", xx_w,yy_w,zz_w
4379 c end diagnostics
4380 #endif
4381         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4382      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4383      &   + x(10)*yy*zz
4384         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4385      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4386      & + x(20)*yy*zz
4387         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4388      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4389      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4390      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4391      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4392      &  +x(40)*xx*yy*zz
4393         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4394      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4395      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4396      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4397      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4398      &  +x(60)*xx*yy*zz
4399         dsc_i   = 0.743d0+x(61)
4400         dp2_i   = 1.9d0+x(62)
4401         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4402      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4403         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4404      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4405         s1=(1+x(63))/(0.1d0 + dscp1)
4406         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4407         s2=(1+x(65))/(0.1d0 + dscp2)
4408         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4409         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4410      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4411 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4412 c     &   sumene4,
4413 c     &   dscp1,dscp2,sumene
4414 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4415         escloc = escloc + sumene
4416 c        write (2,*) "escloc",escloc
4417 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
4418 c     &  zz,xx,yy
4419         if (.not. calc_grad) goto 1
4420 #ifdef DEBUG
4421 C
4422 C This section to check the numerical derivatives of the energy of ith side
4423 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4424 C #define DEBUG in the code to turn it on.
4425 C
4426         write (2,*) "sumene               =",sumene
4427         aincr=1.0d-7
4428         xxsave=xx
4429         xx=xx+aincr
4430         write (2,*) xx,yy,zz
4431         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4432         de_dxx_num=(sumenep-sumene)/aincr
4433         xx=xxsave
4434         write (2,*) "xx+ sumene from enesc=",sumenep
4435         yysave=yy
4436         yy=yy+aincr
4437         write (2,*) xx,yy,zz
4438         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4439         de_dyy_num=(sumenep-sumene)/aincr
4440         yy=yysave
4441         write (2,*) "yy+ sumene from enesc=",sumenep
4442         zzsave=zz
4443         zz=zz+aincr
4444         write (2,*) xx,yy,zz
4445         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4446         de_dzz_num=(sumenep-sumene)/aincr
4447         zz=zzsave
4448         write (2,*) "zz+ sumene from enesc=",sumenep
4449         costsave=cost2tab(i+1)
4450         sintsave=sint2tab(i+1)
4451         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4452         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4453         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4454         de_dt_num=(sumenep-sumene)/aincr
4455         write (2,*) " t+ sumene from enesc=",sumenep
4456         cost2tab(i+1)=costsave
4457         sint2tab(i+1)=sintsave
4458 C End of diagnostics section.
4459 #endif
4460 C
4461 C Compute the gradient of esc
4462 C
4463         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4464         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4465         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4466         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4467         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4468         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4469         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4470         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4471         pom1=(sumene3*sint2tab(i+1)+sumene1)
4472      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4473         pom2=(sumene4*cost2tab(i+1)+sumene2)
4474      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4475         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4476         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4477      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4478      &  +x(40)*yy*zz
4479         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4480         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4481      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4482      &  +x(60)*yy*zz
4483         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4484      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4485      &        +(pom1+pom2)*pom_dx
4486 #ifdef DEBUG
4487         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4488 #endif
4489 C
4490         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4491         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4492      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4493      &  +x(40)*xx*zz
4494         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4495         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4496      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4497      &  +x(59)*zz**2 +x(60)*xx*zz
4498         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4499      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4500      &        +(pom1-pom2)*pom_dy
4501 #ifdef DEBUG
4502         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4503 #endif
4504 C
4505         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4506      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4507      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4508      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4509      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4510      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4511      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4512      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4513 #ifdef DEBUG
4514         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4515 #endif
4516 C
4517         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4518      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4519      &  +pom1*pom_dt1+pom2*pom_dt2
4520 #ifdef DEBUG
4521         write(2,*), "de_dt = ", de_dt,de_dt_num
4522 #endif
4523 c
4524 C
4525        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4526        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4527        cosfac2xx=cosfac2*xx
4528        sinfac2yy=sinfac2*yy
4529        do k = 1,3
4530          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4531      &      vbld_inv(i+1)
4532          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4533      &      vbld_inv(i)
4534          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4535          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4536 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4537 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4538 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4539 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4540          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4541          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4542          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4543          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4544          dZZ_Ci1(k)=0.0d0
4545          dZZ_Ci(k)=0.0d0
4546          do j=1,3
4547            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
4548      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4549            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
4550      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4551          enddo
4552
4553          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4554          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4555          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4556 c
4557          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4558          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4559        enddo
4560
4561        do k=1,3
4562          dXX_Ctab(k,i)=dXX_Ci(k)
4563          dXX_C1tab(k,i)=dXX_Ci1(k)
4564          dYY_Ctab(k,i)=dYY_Ci(k)
4565          dYY_C1tab(k,i)=dYY_Ci1(k)
4566          dZZ_Ctab(k,i)=dZZ_Ci(k)
4567          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4568          dXX_XYZtab(k,i)=dXX_XYZ(k)
4569          dYY_XYZtab(k,i)=dYY_XYZ(k)
4570          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4571        enddo
4572
4573        do k = 1,3
4574 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4575 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4576 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4577 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4578 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4579 c     &    dt_dci(k)
4580 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4581 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4582          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4583      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4584          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4585      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4586          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4587      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4588        enddo
4589 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4590 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4591
4592 C to check gradient call subroutine check_grad
4593
4594     1 continue
4595       enddo
4596       return
4597       end
4598 #endif
4599 c------------------------------------------------------------------------------
4600       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4601 C
4602 C This procedure calculates two-body contact function g(rij) and its derivative:
4603 C
4604 C           eps0ij                                     !       x < -1
4605 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4606 C            0                                         !       x > 1
4607 C
4608 C where x=(rij-r0ij)/delta
4609 C
4610 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4611 C
4612       implicit none
4613       double precision rij,r0ij,eps0ij,fcont,fprimcont
4614       double precision x,x2,x4,delta
4615 c     delta=0.02D0*r0ij
4616 c      delta=0.2D0*r0ij
4617       x=(rij-r0ij)/delta
4618       if (x.lt.-1.0D0) then
4619         fcont=eps0ij
4620         fprimcont=0.0D0
4621       else if (x.le.1.0D0) then
4622         x2=x*x
4623         x4=x2*x2
4624         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4625         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4626       else
4627         fcont=0.0D0
4628         fprimcont=0.0D0
4629       endif
4630       return
4631       end
4632 c------------------------------------------------------------------------------
4633       subroutine splinthet(theti,delta,ss,ssder)
4634       implicit real*8 (a-h,o-z)
4635       include 'DIMENSIONS'
4636       include 'DIMENSIONS.ZSCOPT'
4637       include 'COMMON.VAR'
4638       include 'COMMON.GEO'
4639       thetup=pi-delta
4640       thetlow=delta
4641       if (theti.gt.pipol) then
4642         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4643       else
4644         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4645         ssder=-ssder
4646       endif
4647       return
4648       end
4649 c------------------------------------------------------------------------------
4650       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4651       implicit none
4652       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4653       double precision ksi,ksi2,ksi3,a1,a2,a3
4654       a1=fprim0*delta/(f1-f0)
4655       a2=3.0d0-2.0d0*a1
4656       a3=a1-2.0d0
4657       ksi=(x-x0)/delta
4658       ksi2=ksi*ksi
4659       ksi3=ksi2*ksi
4660       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4661       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4662       return
4663       end
4664 c------------------------------------------------------------------------------
4665       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4666       implicit none
4667       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4668       double precision ksi,ksi2,ksi3,a1,a2,a3
4669       ksi=(x-x0)/delta
4670       ksi2=ksi*ksi
4671       ksi3=ksi2*ksi
4672       a1=fprim0x*delta
4673       a2=3*(f1x-f0x)-2*fprim0x*delta
4674       a3=fprim0x*delta-2*(f1x-f0x)
4675       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4676       return
4677       end
4678 C-----------------------------------------------------------------------------
4679 #ifdef CRYST_TOR
4680 C-----------------------------------------------------------------------------
4681       subroutine etor(etors,edihcnstr,fact)
4682       implicit real*8 (a-h,o-z)
4683       include 'DIMENSIONS'
4684       include 'DIMENSIONS.ZSCOPT'
4685       include 'COMMON.VAR'
4686       include 'COMMON.GEO'
4687       include 'COMMON.LOCAL'
4688       include 'COMMON.TORSION'
4689       include 'COMMON.INTERACT'
4690       include 'COMMON.DERIV'
4691       include 'COMMON.CHAIN'
4692       include 'COMMON.NAMES'
4693       include 'COMMON.IOUNITS'
4694       include 'COMMON.FFIELD'
4695       include 'COMMON.TORCNSTR'
4696       logical lprn
4697 C Set lprn=.true. for debugging
4698       lprn=.false.
4699 c      lprn=.true.
4700       etors=0.0D0
4701       do i=iphi_start,iphi_end
4702         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4703      &      .or. itype(i).eq.ntyp1) cycle
4704         itori=itortyp(itype(i-2))
4705         itori1=itortyp(itype(i-1))
4706         phii=phi(i)
4707         gloci=0.0D0
4708 C Proline-Proline pair is a special case...
4709         if (itori.eq.3 .and. itori1.eq.3) then
4710           if (phii.gt.-dwapi3) then
4711             cosphi=dcos(3*phii)
4712             fac=1.0D0/(1.0D0-cosphi)
4713             etorsi=v1(1,3,3)*fac
4714             etorsi=etorsi+etorsi
4715             etors=etors+etorsi-v1(1,3,3)
4716             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4717           endif
4718           do j=1,3
4719             v1ij=v1(j+1,itori,itori1)
4720             v2ij=v2(j+1,itori,itori1)
4721             cosphi=dcos(j*phii)
4722             sinphi=dsin(j*phii)
4723             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4724             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4725           enddo
4726         else
4727           do j=1,nterm_old
4728             v1ij=v1(j,itori,itori1)
4729             v2ij=v2(j,itori,itori1)
4730             cosphi=dcos(j*phii)
4731             sinphi=dsin(j*phii)
4732             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4733             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4734           enddo
4735         endif
4736         if (lprn)
4737      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4738      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4739      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4740         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4741 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4742       enddo
4743 ! 6/20/98 - dihedral angle constraints
4744       edihcnstr=0.0d0
4745       do i=1,ndih_constr
4746         itori=idih_constr(i)
4747         phii=phi(itori)
4748         difi=phii-phi0(i)
4749         if (difi.gt.drange(i)) then
4750           difi=difi-drange(i)
4751           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4752           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4753         else if (difi.lt.-drange(i)) then
4754           difi=difi+drange(i)
4755           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4756           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4757         endif
4758 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
4759 C     &    i,itori,rad2deg*phii,
4760 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
4761       enddo
4762 !      write (iout,*) 'edihcnstr',edihcnstr
4763       return
4764       end
4765 c------------------------------------------------------------------------------
4766 #else
4767       subroutine etor(etors,edihcnstr,fact)
4768       implicit real*8 (a-h,o-z)
4769       include 'DIMENSIONS'
4770       include 'DIMENSIONS.ZSCOPT'
4771       include 'COMMON.VAR'
4772       include 'COMMON.GEO'
4773       include 'COMMON.LOCAL'
4774       include 'COMMON.TORSION'
4775       include 'COMMON.INTERACT'
4776       include 'COMMON.DERIV'
4777       include 'COMMON.CHAIN'
4778       include 'COMMON.NAMES'
4779       include 'COMMON.IOUNITS'
4780       include 'COMMON.FFIELD'
4781       include 'COMMON.TORCNSTR'
4782       logical lprn
4783 C Set lprn=.true. for debugging
4784       lprn=.false.
4785 c      lprn=.true.
4786       etors=0.0D0
4787       do i=iphi_start,iphi_end
4788         if (i.le.2) cycle
4789         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
4790      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
4791 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4792 C     &       .or. itype(i).eq.ntyp1) cycle
4793         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4794          if (iabs(itype(i)).eq.20) then
4795          iblock=2
4796          else
4797          iblock=1
4798          endif
4799         itori=itortyp(itype(i-2))
4800         itori1=itortyp(itype(i-1))
4801         phii=phi(i)
4802         gloci=0.0D0
4803 C Regular cosine and sine terms
4804         do j=1,nterm(itori,itori1,iblock)
4805           v1ij=v1(j,itori,itori1,iblock)
4806           v2ij=v2(j,itori,itori1,iblock)
4807           cosphi=dcos(j*phii)
4808           sinphi=dsin(j*phii)
4809           etors=etors+v1ij*cosphi+v2ij*sinphi
4810           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4811         enddo
4812 C Lorentz terms
4813 C                         v1
4814 C  E = SUM ----------------------------------- - v1
4815 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4816 C
4817         cosphi=dcos(0.5d0*phii)
4818         sinphi=dsin(0.5d0*phii)
4819         do j=1,nlor(itori,itori1,iblock)
4820           vl1ij=vlor1(j,itori,itori1)
4821           vl2ij=vlor2(j,itori,itori1)
4822           vl3ij=vlor3(j,itori,itori1)
4823           pom=vl2ij*cosphi+vl3ij*sinphi
4824           pom1=1.0d0/(pom*pom+1.0d0)
4825           etors=etors+vl1ij*pom1
4826 c          if (energy_dec) etors_ii=etors_ii+
4827 c     &                vl1ij*pom1
4828           pom=-pom*pom1*pom1
4829           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4830         enddo
4831 C Subtract the constant term
4832         etors=etors-v0(itori,itori1,iblock)
4833         if (lprn)
4834      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4835      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4836      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
4837         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4838 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4839  1215   continue
4840       enddo
4841 ! 6/20/98 - dihedral angle constraints
4842       edihcnstr=0.0d0
4843       do i=1,ndih_constr
4844         itori=idih_constr(i)
4845         phii=phi(itori)
4846         difi=pinorm(phii-phi0(i))
4847         edihi=0.0d0
4848         if (difi.gt.drange(i)) then
4849           difi=difi-drange(i)
4850           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4851           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4852           edihi=0.25d0*ftors(i)*difi**4
4853         else if (difi.lt.-drange(i)) then
4854           difi=difi+drange(i)
4855           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4856           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4857           edihi=0.25d0*ftors(i)*difi**4
4858         else
4859           difi=0.0d0
4860         endif
4861         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
4862      &    i,itori,rad2deg*phii,
4863      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
4864 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4865 c     &    drange(i),edihi
4866 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4867 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
4868       enddo
4869 !      write (iout,*) 'edihcnstr',edihcnstr
4870       return
4871       end
4872 c----------------------------------------------------------------------------
4873       subroutine etor_d(etors_d,fact2)
4874 C 6/23/01 Compute double torsional energy
4875       implicit real*8 (a-h,o-z)
4876       include 'DIMENSIONS'
4877       include 'DIMENSIONS.ZSCOPT'
4878       include 'COMMON.VAR'
4879       include 'COMMON.GEO'
4880       include 'COMMON.LOCAL'
4881       include 'COMMON.TORSION'
4882       include 'COMMON.INTERACT'
4883       include 'COMMON.DERIV'
4884       include 'COMMON.CHAIN'
4885       include 'COMMON.NAMES'
4886       include 'COMMON.IOUNITS'
4887       include 'COMMON.FFIELD'
4888       include 'COMMON.TORCNSTR'
4889       logical lprn
4890 C Set lprn=.true. for debugging
4891       lprn=.false.
4892 c     lprn=.true.
4893       etors_d=0.0D0
4894       do i=iphi_start,iphi_end-1
4895         if (i.le.3) cycle
4896 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
4897 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4898          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
4899      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
4900      &  (itype(i+1).eq.ntyp1)) cycle
4901         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4902      &     goto 1215
4903         itori=itortyp(itype(i-2))
4904         itori1=itortyp(itype(i-1))
4905         itori2=itortyp(itype(i))
4906         phii=phi(i)
4907         phii1=phi(i+1)
4908         gloci1=0.0D0
4909         gloci2=0.0D0
4910         iblock=1
4911         if (iabs(itype(i+1)).eq.20) iblock=2
4912 C Regular cosine and sine terms
4913         do j=1,ntermd_1(itori,itori1,itori2,iblock)
4914           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
4915           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
4916           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
4917           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
4918           cosphi1=dcos(j*phii)
4919           sinphi1=dsin(j*phii)
4920           cosphi2=dcos(j*phii1)
4921           sinphi2=dsin(j*phii1)
4922           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4923      &     v2cij*cosphi2+v2sij*sinphi2
4924           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4925           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4926         enddo
4927         do k=2,ntermd_2(itori,itori1,itori2,iblock)
4928           do l=1,k-1
4929             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
4930             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
4931             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
4932             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
4933             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4934             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4935             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4936             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4937             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4938      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4939             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4940      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4941             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4942      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4943           enddo
4944         enddo
4945         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4946         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4947  1215   continue
4948       enddo
4949       return
4950       end
4951 #endif
4952 c------------------------------------------------------------------------------
4953       subroutine eback_sc_corr(esccor)
4954 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4955 c        conformational states; temporarily implemented as differences
4956 c        between UNRES torsional potentials (dependent on three types of
4957 c        residues) and the torsional potentials dependent on all 20 types
4958 c        of residues computed from AM1 energy surfaces of terminally-blocked
4959 c        amino-acid residues.
4960       implicit real*8 (a-h,o-z)
4961       include 'DIMENSIONS'
4962       include 'DIMENSIONS.ZSCOPT'
4963       include 'COMMON.VAR'
4964       include 'COMMON.GEO'
4965       include 'COMMON.LOCAL'
4966       include 'COMMON.TORSION'
4967       include 'COMMON.SCCOR'
4968       include 'COMMON.INTERACT'
4969       include 'COMMON.DERIV'
4970       include 'COMMON.CHAIN'
4971       include 'COMMON.NAMES'
4972       include 'COMMON.IOUNITS'
4973       include 'COMMON.FFIELD'
4974       include 'COMMON.CONTROL'
4975       logical lprn
4976 C Set lprn=.true. for debugging
4977       lprn=.false.
4978 c      lprn=.true.
4979 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
4980       esccor=0.0D0
4981       do i=itau_start,itau_end
4982         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
4983         esccor_ii=0.0D0
4984         isccori=isccortyp(itype(i-2))
4985         isccori1=isccortyp(itype(i-1))
4986         phii=phi(i)
4987         do intertyp=1,3 !intertyp
4988 cc Added 09 May 2012 (Adasko)
4989 cc  Intertyp means interaction type of backbone mainchain correlation:
4990 c   1 = SC...Ca...Ca...Ca
4991 c   2 = Ca...Ca...Ca...SC
4992 c   3 = SC...Ca...Ca...SCi
4993         gloci=0.0D0
4994         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4995      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
4996      &      (itype(i-1).eq.ntyp1)))
4997      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4998      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
4999      &     .or.(itype(i).eq.ntyp1)))
5000      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5001      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5002      &      (itype(i-3).eq.ntyp1)))) cycle
5003         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5004         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5005      & cycle
5006        do j=1,nterm_sccor(isccori,isccori1)
5007           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5008           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5009           cosphi=dcos(j*tauangle(intertyp,i))
5010           sinphi=dsin(j*tauangle(intertyp,i))
5011            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5012            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5013          enddo
5014 C      write (iout,*)"EBACK_SC_COR",esccor,i
5015 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5016 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5017 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5018         if (lprn)
5019      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5020      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5021      &  (v1sccor(j,1,itori,itori1),j=1,6)
5022      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5023 c        gsccor_loc(i-3)=gloci
5024        enddo !intertyp
5025       enddo
5026       return
5027       end
5028 c------------------------------------------------------------------------------
5029       subroutine multibody(ecorr)
5030 C This subroutine calculates multi-body contributions to energy following
5031 C the idea of Skolnick et al. If side chains I and J make a contact and
5032 C at the same time side chains I+1 and J+1 make a contact, an extra
5033 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5034       implicit real*8 (a-h,o-z)
5035       include 'DIMENSIONS'
5036       include 'COMMON.IOUNITS'
5037       include 'COMMON.DERIV'
5038       include 'COMMON.INTERACT'
5039       include 'COMMON.CONTACTS'
5040       double precision gx(3),gx1(3)
5041       logical lprn
5042
5043 C Set lprn=.true. for debugging
5044       lprn=.false.
5045
5046       if (lprn) then
5047         write (iout,'(a)') 'Contact function values:'
5048         do i=nnt,nct-2
5049           write (iout,'(i2,20(1x,i2,f10.5))')
5050      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5051         enddo
5052       endif
5053       ecorr=0.0D0
5054       do i=nnt,nct
5055         do j=1,3
5056           gradcorr(j,i)=0.0D0
5057           gradxorr(j,i)=0.0D0
5058         enddo
5059       enddo
5060       do i=nnt,nct-2
5061
5062         DO ISHIFT = 3,4
5063
5064         i1=i+ishift
5065         num_conti=num_cont(i)
5066         num_conti1=num_cont(i1)
5067         do jj=1,num_conti
5068           j=jcont(jj,i)
5069           do kk=1,num_conti1
5070             j1=jcont(kk,i1)
5071             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5072 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5073 cd   &                   ' ishift=',ishift
5074 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5075 C The system gains extra energy.
5076               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5077             endif   ! j1==j+-ishift
5078           enddo     ! kk
5079         enddo       ! jj
5080
5081         ENDDO ! ISHIFT
5082
5083       enddo         ! i
5084       return
5085       end
5086 c------------------------------------------------------------------------------
5087       double precision function esccorr(i,j,k,l,jj,kk)
5088       implicit real*8 (a-h,o-z)
5089       include 'DIMENSIONS'
5090       include 'COMMON.IOUNITS'
5091       include 'COMMON.DERIV'
5092       include 'COMMON.INTERACT'
5093       include 'COMMON.CONTACTS'
5094       double precision gx(3),gx1(3)
5095       logical lprn
5096       lprn=.false.
5097       eij=facont(jj,i)
5098       ekl=facont(kk,k)
5099 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5100 C Calculate the multi-body contribution to energy.
5101 C Calculate multi-body contributions to the gradient.
5102 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5103 cd   & k,l,(gacont(m,kk,k),m=1,3)
5104       do m=1,3
5105         gx(m) =ekl*gacont(m,jj,i)
5106         gx1(m)=eij*gacont(m,kk,k)
5107         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5108         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5109         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5110         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5111       enddo
5112       do m=i,j-1
5113         do ll=1,3
5114           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5115         enddo
5116       enddo
5117       do m=k,l-1
5118         do ll=1,3
5119           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5120         enddo
5121       enddo
5122       esccorr=-eij*ekl
5123       return
5124       end
5125 c------------------------------------------------------------------------------
5126 #ifdef MPL
5127       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5128       implicit real*8 (a-h,o-z)
5129       include 'DIMENSIONS'
5130       integer dimen1,dimen2,atom,indx
5131       double precision buffer(dimen1,dimen2)
5132       double precision zapas
5133       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5134      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5135      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5136       num_kont=num_cont_hb(atom)
5137       do i=1,num_kont
5138         do k=1,7
5139           do j=1,3
5140             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5141           enddo ! j
5142         enddo ! k
5143         buffer(i,indx+22)=facont_hb(i,atom)
5144         buffer(i,indx+23)=ees0p(i,atom)
5145         buffer(i,indx+24)=ees0m(i,atom)
5146         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5147       enddo ! i
5148       buffer(1,indx+26)=dfloat(num_kont)
5149       return
5150       end
5151 c------------------------------------------------------------------------------
5152       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5153       implicit real*8 (a-h,o-z)
5154       include 'DIMENSIONS'
5155       integer dimen1,dimen2,atom,indx
5156       double precision buffer(dimen1,dimen2)
5157       double precision zapas
5158       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5159      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5160      &         ees0m(ntyp,maxres),
5161      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5162       num_kont=buffer(1,indx+26)
5163       num_kont_old=num_cont_hb(atom)
5164       num_cont_hb(atom)=num_kont+num_kont_old
5165       do i=1,num_kont
5166         ii=i+num_kont_old
5167         do k=1,7
5168           do j=1,3
5169             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5170           enddo ! j
5171         enddo ! k
5172         facont_hb(ii,atom)=buffer(i,indx+22)
5173         ees0p(ii,atom)=buffer(i,indx+23)
5174         ees0m(ii,atom)=buffer(i,indx+24)
5175         jcont_hb(ii,atom)=buffer(i,indx+25)
5176       enddo ! i
5177       return
5178       end
5179 c------------------------------------------------------------------------------
5180 #endif
5181       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5182 C This subroutine calculates multi-body contributions to hydrogen-bonding
5183       implicit real*8 (a-h,o-z)
5184       include 'DIMENSIONS'
5185       include 'DIMENSIONS.ZSCOPT'
5186       include 'COMMON.IOUNITS'
5187 #ifdef MPL
5188       include 'COMMON.INFO'
5189 #endif
5190       include 'COMMON.FFIELD'
5191       include 'COMMON.DERIV'
5192       include 'COMMON.INTERACT'
5193       include 'COMMON.CONTACTS'
5194 #ifdef MPL
5195       parameter (max_cont=maxconts)
5196       parameter (max_dim=2*(8*3+2))
5197       parameter (msglen1=max_cont*max_dim*4)
5198       parameter (msglen2=2*msglen1)
5199       integer source,CorrelType,CorrelID,Error
5200       double precision buffer(max_cont,max_dim)
5201 #endif
5202       double precision gx(3),gx1(3)
5203       logical lprn,ldone
5204
5205 C Set lprn=.true. for debugging
5206       lprn=.false.
5207 #ifdef MPL
5208       n_corr=0
5209       n_corr1=0
5210       if (fgProcs.le.1) goto 30
5211       if (lprn) then
5212         write (iout,'(a)') 'Contact function values:'
5213         do i=nnt,nct-2
5214           write (iout,'(2i3,50(1x,i2,f5.2))')
5215      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5216      &    j=1,num_cont_hb(i))
5217         enddo
5218       endif
5219 C Caution! Following code assumes that electrostatic interactions concerning
5220 C a given atom are split among at most two processors!
5221       CorrelType=477
5222       CorrelID=MyID+1
5223       ldone=.false.
5224       do i=1,max_cont
5225         do j=1,max_dim
5226           buffer(i,j)=0.0D0
5227         enddo
5228       enddo
5229       mm=mod(MyRank,2)
5230 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5231       if (mm) 20,20,10
5232    10 continue
5233 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5234       if (MyRank.gt.0) then
5235 C Send correlation contributions to the preceding processor
5236         msglen=msglen1
5237         nn=num_cont_hb(iatel_s)
5238         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5239 cd      write (iout,*) 'The BUFFER array:'
5240 cd      do i=1,nn
5241 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5242 cd      enddo
5243         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5244           msglen=msglen2
5245             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5246 C Clear the contacts of the atom passed to the neighboring processor
5247         nn=num_cont_hb(iatel_s+1)
5248 cd      do i=1,nn
5249 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5250 cd      enddo
5251             num_cont_hb(iatel_s)=0
5252         endif
5253 cd      write (iout,*) 'Processor ',MyID,MyRank,
5254 cd   & ' is sending correlation contribution to processor',MyID-1,
5255 cd   & ' msglen=',msglen
5256 cd      write (*,*) 'Processor ',MyID,MyRank,
5257 cd   & ' is sending correlation contribution to processor',MyID-1,
5258 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5259         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5260 cd      write (iout,*) 'Processor ',MyID,
5261 cd   & ' has sent correlation contribution to processor',MyID-1,
5262 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5263 cd      write (*,*) 'Processor ',MyID,
5264 cd   & ' has sent correlation contribution to processor',MyID-1,
5265 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5266         msglen=msglen1
5267       endif ! (MyRank.gt.0)
5268       if (ldone) goto 30
5269       ldone=.true.
5270    20 continue
5271 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5272       if (MyRank.lt.fgProcs-1) then
5273 C Receive correlation contributions from the next processor
5274         msglen=msglen1
5275         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5276 cd      write (iout,*) 'Processor',MyID,
5277 cd   & ' is receiving correlation contribution from processor',MyID+1,
5278 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5279 cd      write (*,*) 'Processor',MyID,
5280 cd   & ' is receiving correlation contribution from processor',MyID+1,
5281 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5282         nbytes=-1
5283         do while (nbytes.le.0)
5284           call mp_probe(MyID+1,CorrelType,nbytes)
5285         enddo
5286 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5287         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5288 cd      write (iout,*) 'Processor',MyID,
5289 cd   & ' has received correlation contribution from processor',MyID+1,
5290 cd   & ' msglen=',msglen,' nbytes=',nbytes
5291 cd      write (iout,*) 'The received BUFFER array:'
5292 cd      do i=1,max_cont
5293 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5294 cd      enddo
5295         if (msglen.eq.msglen1) then
5296           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5297         else if (msglen.eq.msglen2)  then
5298           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5299           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5300         else
5301           write (iout,*)
5302      & 'ERROR!!!! message length changed while processing correlations.'
5303           write (*,*)
5304      & 'ERROR!!!! message length changed while processing correlations.'
5305           call mp_stopall(Error)
5306         endif ! msglen.eq.msglen1
5307       endif ! MyRank.lt.fgProcs-1
5308       if (ldone) goto 30
5309       ldone=.true.
5310       goto 10
5311    30 continue
5312 #endif
5313       if (lprn) then
5314         write (iout,'(a)') 'Contact function values:'
5315         do i=nnt,nct-2
5316           write (iout,'(2i3,50(1x,i2,f5.2))')
5317      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5318      &    j=1,num_cont_hb(i))
5319         enddo
5320       endif
5321       ecorr=0.0D0
5322 C Remove the loop below after debugging !!!
5323       do i=nnt,nct
5324         do j=1,3
5325           gradcorr(j,i)=0.0D0
5326           gradxorr(j,i)=0.0D0
5327         enddo
5328       enddo
5329 C Calculate the local-electrostatic correlation terms
5330       do i=iatel_s,iatel_e+1
5331         i1=i+1
5332         num_conti=num_cont_hb(i)
5333         num_conti1=num_cont_hb(i+1)
5334         do jj=1,num_conti
5335           j=jcont_hb(jj,i)
5336           do kk=1,num_conti1
5337             j1=jcont_hb(kk,i1)
5338 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5339 c     &         ' jj=',jj,' kk=',kk
5340             if (j1.eq.j+1 .or. j1.eq.j-1) then
5341 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5342 C The system gains extra energy.
5343               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5344               n_corr=n_corr+1
5345             else if (j1.eq.j) then
5346 C Contacts I-J and I-(J+1) occur simultaneously.
5347 C The system loses extra energy.
5348 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5349             endif
5350           enddo ! kk
5351           do kk=1,num_conti
5352             j1=jcont_hb(kk,i)
5353 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5354 c    &         ' jj=',jj,' kk=',kk
5355             if (j1.eq.j+1) then
5356 C Contacts I-J and (I+1)-J occur simultaneously.
5357 C The system loses extra energy.
5358 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5359             endif ! j1==j+1
5360           enddo ! kk
5361         enddo ! jj
5362       enddo ! i
5363       return
5364       end
5365 c------------------------------------------------------------------------------
5366       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5367      &  n_corr1)
5368 C This subroutine calculates multi-body contributions to hydrogen-bonding
5369       implicit real*8 (a-h,o-z)
5370       include 'DIMENSIONS'
5371       include 'DIMENSIONS.ZSCOPT'
5372       include 'COMMON.IOUNITS'
5373 #ifdef MPL
5374       include 'COMMON.INFO'
5375 #endif
5376       include 'COMMON.FFIELD'
5377       include 'COMMON.DERIV'
5378       include 'COMMON.INTERACT'
5379       include 'COMMON.CONTACTS'
5380 #ifdef MPL
5381       parameter (max_cont=maxconts)
5382       parameter (max_dim=2*(8*3+2))
5383       parameter (msglen1=max_cont*max_dim*4)
5384       parameter (msglen2=2*msglen1)
5385       integer source,CorrelType,CorrelID,Error
5386       double precision buffer(max_cont,max_dim)
5387 #endif
5388       double precision gx(3),gx1(3)
5389       logical lprn,ldone
5390
5391 C Set lprn=.true. for debugging
5392       lprn=.false.
5393       eturn6=0.0d0
5394 #ifdef MPL
5395       n_corr=0
5396       n_corr1=0
5397       if (fgProcs.le.1) goto 30
5398       if (lprn) then
5399         write (iout,'(a)') 'Contact function values:'
5400         do i=nnt,nct-2
5401           write (iout,'(2i3,50(1x,i2,f5.2))')
5402      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5403      &    j=1,num_cont_hb(i))
5404         enddo
5405       endif
5406 C Caution! Following code assumes that electrostatic interactions concerning
5407 C a given atom are split among at most two processors!
5408       CorrelType=477
5409       CorrelID=MyID+1
5410       ldone=.false.
5411       do i=1,max_cont
5412         do j=1,max_dim
5413           buffer(i,j)=0.0D0
5414         enddo
5415       enddo
5416       mm=mod(MyRank,2)
5417 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5418       if (mm) 20,20,10
5419    10 continue
5420 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5421       if (MyRank.gt.0) then
5422 C Send correlation contributions to the preceding processor
5423         msglen=msglen1
5424         nn=num_cont_hb(iatel_s)
5425         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5426 cd      write (iout,*) 'The BUFFER array:'
5427 cd      do i=1,nn
5428 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5429 cd      enddo
5430         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5431           msglen=msglen2
5432             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5433 C Clear the contacts of the atom passed to the neighboring processor
5434         nn=num_cont_hb(iatel_s+1)
5435 cd      do i=1,nn
5436 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5437 cd      enddo
5438             num_cont_hb(iatel_s)=0
5439         endif
5440 cd      write (iout,*) 'Processor ',MyID,MyRank,
5441 cd   & ' is sending correlation contribution to processor',MyID-1,
5442 cd   & ' msglen=',msglen
5443 cd      write (*,*) 'Processor ',MyID,MyRank,
5444 cd   & ' is sending correlation contribution to processor',MyID-1,
5445 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5446         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5447 cd      write (iout,*) 'Processor ',MyID,
5448 cd   & ' has sent correlation contribution to processor',MyID-1,
5449 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5450 cd      write (*,*) 'Processor ',MyID,
5451 cd   & ' has sent correlation contribution to processor',MyID-1,
5452 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5453         msglen=msglen1
5454       endif ! (MyRank.gt.0)
5455       if (ldone) goto 30
5456       ldone=.true.
5457    20 continue
5458 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5459       if (MyRank.lt.fgProcs-1) then
5460 C Receive correlation contributions from the next processor
5461         msglen=msglen1
5462         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5463 cd      write (iout,*) 'Processor',MyID,
5464 cd   & ' is receiving correlation contribution from processor',MyID+1,
5465 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5466 cd      write (*,*) 'Processor',MyID,
5467 cd   & ' is receiving correlation contribution from processor',MyID+1,
5468 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5469         nbytes=-1
5470         do while (nbytes.le.0)
5471           call mp_probe(MyID+1,CorrelType,nbytes)
5472         enddo
5473 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5474         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5475 cd      write (iout,*) 'Processor',MyID,
5476 cd   & ' has received correlation contribution from processor',MyID+1,
5477 cd   & ' msglen=',msglen,' nbytes=',nbytes
5478 cd      write (iout,*) 'The received BUFFER array:'
5479 cd      do i=1,max_cont
5480 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5481 cd      enddo
5482         if (msglen.eq.msglen1) then
5483           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5484         else if (msglen.eq.msglen2)  then
5485           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5486           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5487         else
5488           write (iout,*)
5489      & 'ERROR!!!! message length changed while processing correlations.'
5490           write (*,*)
5491      & 'ERROR!!!! message length changed while processing correlations.'
5492           call mp_stopall(Error)
5493         endif ! msglen.eq.msglen1
5494       endif ! MyRank.lt.fgProcs-1
5495       if (ldone) goto 30
5496       ldone=.true.
5497       goto 10
5498    30 continue
5499 #endif
5500       if (lprn) then
5501         write (iout,'(a)') 'Contact function values:'
5502         do i=nnt,nct-2
5503           write (iout,'(2i3,50(1x,i2,f5.2))')
5504      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5505      &    j=1,num_cont_hb(i))
5506         enddo
5507       endif
5508       ecorr=0.0D0
5509       ecorr5=0.0d0
5510       ecorr6=0.0d0
5511 C Remove the loop below after debugging !!!
5512       do i=nnt,nct
5513         do j=1,3
5514           gradcorr(j,i)=0.0D0
5515           gradxorr(j,i)=0.0D0
5516         enddo
5517       enddo
5518 C Calculate the dipole-dipole interaction energies
5519       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5520       do i=iatel_s,iatel_e+1
5521         num_conti=num_cont_hb(i)
5522         do jj=1,num_conti
5523           j=jcont_hb(jj,i)
5524           call dipole(i,j,jj)
5525         enddo
5526       enddo
5527       endif
5528 C Calculate the local-electrostatic correlation terms
5529       do i=iatel_s,iatel_e+1
5530         i1=i+1
5531         num_conti=num_cont_hb(i)
5532         num_conti1=num_cont_hb(i+1)
5533         do jj=1,num_conti
5534           j=jcont_hb(jj,i)
5535           do kk=1,num_conti1
5536             j1=jcont_hb(kk,i1)
5537 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5538 c     &         ' jj=',jj,' kk=',kk
5539             if (j1.eq.j+1 .or. j1.eq.j-1) then
5540 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5541 C The system gains extra energy.
5542               n_corr=n_corr+1
5543               sqd1=dsqrt(d_cont(jj,i))
5544               sqd2=dsqrt(d_cont(kk,i1))
5545               sred_geom = sqd1*sqd2
5546               IF (sred_geom.lt.cutoff_corr) THEN
5547                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5548      &            ekont,fprimcont)
5549 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5550 c     &         ' jj=',jj,' kk=',kk
5551                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5552                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5553                 do l=1,3
5554                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5555                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5556                 enddo
5557                 n_corr1=n_corr1+1
5558 cd               write (iout,*) 'sred_geom=',sred_geom,
5559 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5560                 call calc_eello(i,j,i+1,j1,jj,kk)
5561                 if (wcorr4.gt.0.0d0)
5562      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5563                 if (wcorr5.gt.0.0d0)
5564      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5565 c                print *,"wcorr5",ecorr5
5566 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5567 cd                write(2,*)'ijkl',i,j,i+1,j1
5568                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5569      &               .or. wturn6.eq.0.0d0))then
5570 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5571                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5572 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5573 cd     &            'ecorr6=',ecorr6
5574 cd                write (iout,'(4e15.5)') sred_geom,
5575 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5576 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5577 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5578                 else if (wturn6.gt.0.0d0
5579      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5580 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5581                   eturn6=eturn6+eello_turn6(i,jj,kk)
5582 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5583                 endif
5584               ENDIF
5585 1111          continue
5586             else if (j1.eq.j) then
5587 C Contacts I-J and I-(J+1) occur simultaneously.
5588 C The system loses extra energy.
5589 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5590             endif
5591           enddo ! kk
5592           do kk=1,num_conti
5593             j1=jcont_hb(kk,i)
5594 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5595 c    &         ' jj=',jj,' kk=',kk
5596             if (j1.eq.j+1) then
5597 C Contacts I-J and (I+1)-J occur simultaneously.
5598 C The system loses extra energy.
5599 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5600             endif ! j1==j+1
5601           enddo ! kk
5602         enddo ! jj
5603       enddo ! i
5604       return
5605       end
5606 c------------------------------------------------------------------------------
5607       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5608       implicit real*8 (a-h,o-z)
5609       include 'DIMENSIONS'
5610       include 'COMMON.IOUNITS'
5611       include 'COMMON.DERIV'
5612       include 'COMMON.INTERACT'
5613       include 'COMMON.CONTACTS'
5614       double precision gx(3),gx1(3)
5615       logical lprn
5616       lprn=.false.
5617       eij=facont_hb(jj,i)
5618       ekl=facont_hb(kk,k)
5619       ees0pij=ees0p(jj,i)
5620       ees0pkl=ees0p(kk,k)
5621       ees0mij=ees0m(jj,i)
5622       ees0mkl=ees0m(kk,k)
5623       ekont=eij*ekl
5624       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5625 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5626 C Following 4 lines for diagnostics.
5627 cd    ees0pkl=0.0D0
5628 cd    ees0pij=1.0D0
5629 cd    ees0mkl=0.0D0
5630 cd    ees0mij=1.0D0
5631 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5632 c    &   ' and',k,l
5633 c     write (iout,*)'Contacts have occurred for peptide groups',
5634 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5635 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5636 C Calculate the multi-body contribution to energy.
5637       ecorr=ecorr+ekont*ees
5638       if (calc_grad) then
5639 C Calculate multi-body contributions to the gradient.
5640       do ll=1,3
5641         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5642         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5643      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5644      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5645         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5646      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5647      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5648         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5649         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5650      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5651      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5652         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5653      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5654      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5655       enddo
5656       do m=i+1,j-1
5657         do ll=1,3
5658           gradcorr(ll,m)=gradcorr(ll,m)+
5659      &     ees*ekl*gacont_hbr(ll,jj,i)-
5660      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5661      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5662         enddo
5663       enddo
5664       do m=k+1,l-1
5665         do ll=1,3
5666           gradcorr(ll,m)=gradcorr(ll,m)+
5667      &     ees*eij*gacont_hbr(ll,kk,k)-
5668      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5669      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5670         enddo
5671       enddo
5672       endif
5673       ehbcorr=ekont*ees
5674       return
5675       end
5676 C---------------------------------------------------------------------------
5677       subroutine dipole(i,j,jj)
5678       implicit real*8 (a-h,o-z)
5679       include 'DIMENSIONS'
5680       include 'DIMENSIONS.ZSCOPT'
5681       include 'COMMON.IOUNITS'
5682       include 'COMMON.CHAIN'
5683       include 'COMMON.FFIELD'
5684       include 'COMMON.DERIV'
5685       include 'COMMON.INTERACT'
5686       include 'COMMON.CONTACTS'
5687       include 'COMMON.TORSION'
5688       include 'COMMON.VAR'
5689       include 'COMMON.GEO'
5690       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5691      &  auxmat(2,2)
5692       iti1 = itortyp(itype(i+1))
5693       if (j.lt.nres-1) then
5694         if (itype(j).le.ntyp) then
5695           itj1 = itortyp(itype(j+1))
5696         else
5697           itj=ntortyp+1
5698         endif
5699       else
5700         itj1=ntortyp+1
5701       endif
5702       do iii=1,2
5703         dipi(iii,1)=Ub2(iii,i)
5704         dipderi(iii)=Ub2der(iii,i)
5705         dipi(iii,2)=b1(iii,iti1)
5706         dipj(iii,1)=Ub2(iii,j)
5707         dipderj(iii)=Ub2der(iii,j)
5708         dipj(iii,2)=b1(iii,itj1)
5709       enddo
5710       kkk=0
5711       do iii=1,2
5712         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5713         do jjj=1,2
5714           kkk=kkk+1
5715           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5716         enddo
5717       enddo
5718       if (.not.calc_grad) return
5719       do kkk=1,5
5720         do lll=1,3
5721           mmm=0
5722           do iii=1,2
5723             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5724      &        auxvec(1))
5725             do jjj=1,2
5726               mmm=mmm+1
5727               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5728             enddo
5729           enddo
5730         enddo
5731       enddo
5732       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5733       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5734       do iii=1,2
5735         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5736       enddo
5737       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5738       do iii=1,2
5739         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5740       enddo
5741       return
5742       end
5743 C---------------------------------------------------------------------------
5744       subroutine calc_eello(i,j,k,l,jj,kk)
5745 C
5746 C This subroutine computes matrices and vectors needed to calculate
5747 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5748 C
5749       implicit real*8 (a-h,o-z)
5750       include 'DIMENSIONS'
5751       include 'DIMENSIONS.ZSCOPT'
5752       include 'COMMON.IOUNITS'
5753       include 'COMMON.CHAIN'
5754       include 'COMMON.DERIV'
5755       include 'COMMON.INTERACT'
5756       include 'COMMON.CONTACTS'
5757       include 'COMMON.TORSION'
5758       include 'COMMON.VAR'
5759       include 'COMMON.GEO'
5760       include 'COMMON.FFIELD'
5761       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5762      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5763       logical lprn
5764       common /kutas/ lprn
5765 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5766 cd     & ' jj=',jj,' kk=',kk
5767 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5768       do iii=1,2
5769         do jjj=1,2
5770           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5771           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5772         enddo
5773       enddo
5774       call transpose2(aa1(1,1),aa1t(1,1))
5775       call transpose2(aa2(1,1),aa2t(1,1))
5776       do kkk=1,5
5777         do lll=1,3
5778           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5779      &      aa1tder(1,1,lll,kkk))
5780           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5781      &      aa2tder(1,1,lll,kkk))
5782         enddo
5783       enddo
5784       if (l.eq.j+1) then
5785 C parallel orientation of the two CA-CA-CA frames.
5786         if (i.gt.1 .and. itype(i).le.ntyp) then
5787           iti=itortyp(itype(i))
5788         else
5789           iti=ntortyp+1
5790         endif
5791         itk1=itortyp(itype(k+1))
5792         itj=itortyp(itype(j))
5793         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
5794           itl1=itortyp(itype(l+1))
5795         else
5796           itl1=ntortyp+1
5797         endif
5798 C A1 kernel(j+1) A2T
5799 cd        do iii=1,2
5800 cd          write (iout,'(3f10.5,5x,3f10.5)')
5801 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5802 cd        enddo
5803         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5804      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5805      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5806 C Following matrices are needed only for 6-th order cumulants
5807         IF (wcorr6.gt.0.0d0) THEN
5808         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5809      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5810      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5811         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5812      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5813      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5814      &   ADtEAderx(1,1,1,1,1,1))
5815         lprn=.false.
5816         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5817      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5818      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5819      &   ADtEA1derx(1,1,1,1,1,1))
5820         ENDIF
5821 C End 6-th order cumulants
5822 cd        lprn=.false.
5823 cd        if (lprn) then
5824 cd        write (2,*) 'In calc_eello6'
5825 cd        do iii=1,2
5826 cd          write (2,*) 'iii=',iii
5827 cd          do kkk=1,5
5828 cd            write (2,*) 'kkk=',kkk
5829 cd            do jjj=1,2
5830 cd              write (2,'(3(2f10.5),5x)')
5831 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5832 cd            enddo
5833 cd          enddo
5834 cd        enddo
5835 cd        endif
5836         call transpose2(EUgder(1,1,k),auxmat(1,1))
5837         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5838         call transpose2(EUg(1,1,k),auxmat(1,1))
5839         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5840         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5841         do iii=1,2
5842           do kkk=1,5
5843             do lll=1,3
5844               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5845      &          EAEAderx(1,1,lll,kkk,iii,1))
5846             enddo
5847           enddo
5848         enddo
5849 C A1T kernel(i+1) A2
5850         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5851      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5852      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5853 C Following matrices are needed only for 6-th order cumulants
5854         IF (wcorr6.gt.0.0d0) THEN
5855         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5856      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5857      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5858         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5859      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5860      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5861      &   ADtEAderx(1,1,1,1,1,2))
5862         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5863      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5864      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5865      &   ADtEA1derx(1,1,1,1,1,2))
5866         ENDIF
5867 C End 6-th order cumulants
5868         call transpose2(EUgder(1,1,l),auxmat(1,1))
5869         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5870         call transpose2(EUg(1,1,l),auxmat(1,1))
5871         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5872         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5873         do iii=1,2
5874           do kkk=1,5
5875             do lll=1,3
5876               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5877      &          EAEAderx(1,1,lll,kkk,iii,2))
5878             enddo
5879           enddo
5880         enddo
5881 C AEAb1 and AEAb2
5882 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5883 C They are needed only when the fifth- or the sixth-order cumulants are
5884 C indluded.
5885         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5886         call transpose2(AEA(1,1,1),auxmat(1,1))
5887         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5888         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5889         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5890         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5891         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5892         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5893         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5894         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5895         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5896         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5897         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5898         call transpose2(AEA(1,1,2),auxmat(1,1))
5899         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5900         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5901         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5902         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5903         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5904         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5905         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5906         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5907         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5908         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5909         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5910 C Calculate the Cartesian derivatives of the vectors.
5911         do iii=1,2
5912           do kkk=1,5
5913             do lll=1,3
5914               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5915               call matvec2(auxmat(1,1),b1(1,iti),
5916      &          AEAb1derx(1,lll,kkk,iii,1,1))
5917               call matvec2(auxmat(1,1),Ub2(1,i),
5918      &          AEAb2derx(1,lll,kkk,iii,1,1))
5919               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5920      &          AEAb1derx(1,lll,kkk,iii,2,1))
5921               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5922      &          AEAb2derx(1,lll,kkk,iii,2,1))
5923               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5924               call matvec2(auxmat(1,1),b1(1,itj),
5925      &          AEAb1derx(1,lll,kkk,iii,1,2))
5926               call matvec2(auxmat(1,1),Ub2(1,j),
5927      &          AEAb2derx(1,lll,kkk,iii,1,2))
5928               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5929      &          AEAb1derx(1,lll,kkk,iii,2,2))
5930               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5931      &          AEAb2derx(1,lll,kkk,iii,2,2))
5932             enddo
5933           enddo
5934         enddo
5935         ENDIF
5936 C End vectors
5937       else
5938 C Antiparallel orientation of the two CA-CA-CA frames.
5939         if (i.gt.1 .and. itype(i).le.ntyp) then
5940           iti=itortyp(itype(i))
5941         else
5942           iti=ntortyp+1
5943         endif
5944         itk1=itortyp(itype(k+1))
5945         itl=itortyp(itype(l))
5946         itj=itortyp(itype(j))
5947         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
5948           itj1=itortyp(itype(j+1))
5949         else
5950           itj1=ntortyp+1
5951         endif
5952 C A2 kernel(j-1)T A1T
5953         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5954      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5955      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5956 C Following matrices are needed only for 6-th order cumulants
5957         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5958      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5959         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5960      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5961      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5962         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5963      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5964      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5965      &   ADtEAderx(1,1,1,1,1,1))
5966         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5967      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5968      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5969      &   ADtEA1derx(1,1,1,1,1,1))
5970         ENDIF
5971 C End 6-th order cumulants
5972         call transpose2(EUgder(1,1,k),auxmat(1,1))
5973         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5974         call transpose2(EUg(1,1,k),auxmat(1,1))
5975         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5976         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5977         do iii=1,2
5978           do kkk=1,5
5979             do lll=1,3
5980               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5981      &          EAEAderx(1,1,lll,kkk,iii,1))
5982             enddo
5983           enddo
5984         enddo
5985 C A2T kernel(i+1)T A1
5986         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5987      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5988      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5989 C Following matrices are needed only for 6-th order cumulants
5990         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5991      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5992         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5993      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5994      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5995         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5996      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5997      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5998      &   ADtEAderx(1,1,1,1,1,2))
5999         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6000      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6001      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6002      &   ADtEA1derx(1,1,1,1,1,2))
6003         ENDIF
6004 C End 6-th order cumulants
6005         call transpose2(EUgder(1,1,j),auxmat(1,1))
6006         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6007         call transpose2(EUg(1,1,j),auxmat(1,1))
6008         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6009         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6010         do iii=1,2
6011           do kkk=1,5
6012             do lll=1,3
6013               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6014      &          EAEAderx(1,1,lll,kkk,iii,2))
6015             enddo
6016           enddo
6017         enddo
6018 C AEAb1 and AEAb2
6019 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6020 C They are needed only when the fifth- or the sixth-order cumulants are
6021 C indluded.
6022         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6023      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6024         call transpose2(AEA(1,1,1),auxmat(1,1))
6025         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6026         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6027         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6028         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6029         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6030         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6031         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6032         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6033         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6034         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6035         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6036         call transpose2(AEA(1,1,2),auxmat(1,1))
6037         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6038         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6039         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6040         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6041         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6042         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6043         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6044         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6045         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6046         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6047         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6048 C Calculate the Cartesian derivatives of the vectors.
6049         do iii=1,2
6050           do kkk=1,5
6051             do lll=1,3
6052               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6053               call matvec2(auxmat(1,1),b1(1,iti),
6054      &          AEAb1derx(1,lll,kkk,iii,1,1))
6055               call matvec2(auxmat(1,1),Ub2(1,i),
6056      &          AEAb2derx(1,lll,kkk,iii,1,1))
6057               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6058      &          AEAb1derx(1,lll,kkk,iii,2,1))
6059               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6060      &          AEAb2derx(1,lll,kkk,iii,2,1))
6061               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6062               call matvec2(auxmat(1,1),b1(1,itl),
6063      &          AEAb1derx(1,lll,kkk,iii,1,2))
6064               call matvec2(auxmat(1,1),Ub2(1,l),
6065      &          AEAb2derx(1,lll,kkk,iii,1,2))
6066               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6067      &          AEAb1derx(1,lll,kkk,iii,2,2))
6068               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6069      &          AEAb2derx(1,lll,kkk,iii,2,2))
6070             enddo
6071           enddo
6072         enddo
6073         ENDIF
6074 C End vectors
6075       endif
6076       return
6077       end
6078 C---------------------------------------------------------------------------
6079       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6080      &  KK,KKderg,AKA,AKAderg,AKAderx)
6081       implicit none
6082       integer nderg
6083       logical transp
6084       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6085      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6086      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6087       integer iii,kkk,lll
6088       integer jjj,mmm
6089       logical lprn
6090       common /kutas/ lprn
6091       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6092       do iii=1,nderg
6093         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6094      &    AKAderg(1,1,iii))
6095       enddo
6096 cd      if (lprn) write (2,*) 'In kernel'
6097       do kkk=1,5
6098 cd        if (lprn) write (2,*) 'kkk=',kkk
6099         do lll=1,3
6100           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6101      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6102 cd          if (lprn) then
6103 cd            write (2,*) 'lll=',lll
6104 cd            write (2,*) 'iii=1'
6105 cd            do jjj=1,2
6106 cd              write (2,'(3(2f10.5),5x)')
6107 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6108 cd            enddo
6109 cd          endif
6110           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6111      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6112 cd          if (lprn) then
6113 cd            write (2,*) 'lll=',lll
6114 cd            write (2,*) 'iii=2'
6115 cd            do jjj=1,2
6116 cd              write (2,'(3(2f10.5),5x)')
6117 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6118 cd            enddo
6119 cd          endif
6120         enddo
6121       enddo
6122       return
6123       end
6124 C---------------------------------------------------------------------------
6125       double precision function eello4(i,j,k,l,jj,kk)
6126       implicit real*8 (a-h,o-z)
6127       include 'DIMENSIONS'
6128       include 'DIMENSIONS.ZSCOPT'
6129       include 'COMMON.IOUNITS'
6130       include 'COMMON.CHAIN'
6131       include 'COMMON.DERIV'
6132       include 'COMMON.INTERACT'
6133       include 'COMMON.CONTACTS'
6134       include 'COMMON.TORSION'
6135       include 'COMMON.VAR'
6136       include 'COMMON.GEO'
6137       double precision pizda(2,2),ggg1(3),ggg2(3)
6138 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6139 cd        eello4=0.0d0
6140 cd        return
6141 cd      endif
6142 cd      print *,'eello4:',i,j,k,l,jj,kk
6143 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6144 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6145 cold      eij=facont_hb(jj,i)
6146 cold      ekl=facont_hb(kk,k)
6147 cold      ekont=eij*ekl
6148       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6149       if (calc_grad) then
6150 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6151       gcorr_loc(k-1)=gcorr_loc(k-1)
6152      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6153       if (l.eq.j+1) then
6154         gcorr_loc(l-1)=gcorr_loc(l-1)
6155      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6156       else
6157         gcorr_loc(j-1)=gcorr_loc(j-1)
6158      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6159       endif
6160       do iii=1,2
6161         do kkk=1,5
6162           do lll=1,3
6163             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6164      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6165 cd            derx(lll,kkk,iii)=0.0d0
6166           enddo
6167         enddo
6168       enddo
6169 cd      gcorr_loc(l-1)=0.0d0
6170 cd      gcorr_loc(j-1)=0.0d0
6171 cd      gcorr_loc(k-1)=0.0d0
6172 cd      eel4=1.0d0
6173 cd      write (iout,*)'Contacts have occurred for peptide groups',
6174 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6175 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6176       if (j.lt.nres-1) then
6177         j1=j+1
6178         j2=j-1
6179       else
6180         j1=j-1
6181         j2=j-2
6182       endif
6183       if (l.lt.nres-1) then
6184         l1=l+1
6185         l2=l-1
6186       else
6187         l1=l-1
6188         l2=l-2
6189       endif
6190       do ll=1,3
6191 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6192         ggg1(ll)=eel4*g_contij(ll,1)
6193         ggg2(ll)=eel4*g_contij(ll,2)
6194         ghalf=0.5d0*ggg1(ll)
6195 cd        ghalf=0.0d0
6196         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6197         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6198         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6199         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6200 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6201         ghalf=0.5d0*ggg2(ll)
6202 cd        ghalf=0.0d0
6203         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6204         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6205         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6206         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6207       enddo
6208 cd      goto 1112
6209       do m=i+1,j-1
6210         do ll=1,3
6211 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6212           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6213         enddo
6214       enddo
6215       do m=k+1,l-1
6216         do ll=1,3
6217 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6218           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6219         enddo
6220       enddo
6221 1112  continue
6222       do m=i+2,j2
6223         do ll=1,3
6224           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6225         enddo
6226       enddo
6227       do m=k+2,l2
6228         do ll=1,3
6229           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6230         enddo
6231       enddo
6232 cd      do iii=1,nres-3
6233 cd        write (2,*) iii,gcorr_loc(iii)
6234 cd      enddo
6235       endif
6236       eello4=ekont*eel4
6237 cd      write (2,*) 'ekont',ekont
6238 cd      write (iout,*) 'eello4',ekont*eel4
6239       return
6240       end
6241 C---------------------------------------------------------------------------
6242       double precision function eello5(i,j,k,l,jj,kk)
6243       implicit real*8 (a-h,o-z)
6244       include 'DIMENSIONS'
6245       include 'DIMENSIONS.ZSCOPT'
6246       include 'COMMON.IOUNITS'
6247       include 'COMMON.CHAIN'
6248       include 'COMMON.DERIV'
6249       include 'COMMON.INTERACT'
6250       include 'COMMON.CONTACTS'
6251       include 'COMMON.TORSION'
6252       include 'COMMON.VAR'
6253       include 'COMMON.GEO'
6254       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6255       double precision ggg1(3),ggg2(3)
6256 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6257 C                                                                              C
6258 C                            Parallel chains                                   C
6259 C                                                                              C
6260 C          o             o                   o             o                   C
6261 C         /l\           / \             \   / \           / \   /              C
6262 C        /   \         /   \             \ /   \         /   \ /               C
6263 C       j| o |l1       | o |              o| o |         | o |o                C
6264 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6265 C      \i/   \         /   \ /             /   \         /   \                 C
6266 C       o    k1             o                                                  C
6267 C         (I)          (II)                (III)          (IV)                 C
6268 C                                                                              C
6269 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6270 C                                                                              C
6271 C                            Antiparallel chains                               C
6272 C                                                                              C
6273 C          o             o                   o             o                   C
6274 C         /j\           / \             \   / \           / \   /              C
6275 C        /   \         /   \             \ /   \         /   \ /               C
6276 C      j1| o |l        | o |              o| o |         | o |o                C
6277 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6278 C      \i/   \         /   \ /             /   \         /   \                 C
6279 C       o     k1            o                                                  C
6280 C         (I)          (II)                (III)          (IV)                 C
6281 C                                                                              C
6282 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6283 C                                                                              C
6284 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6285 C                                                                              C
6286 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6287 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6288 cd        eello5=0.0d0
6289 cd        return
6290 cd      endif
6291 cd      write (iout,*)
6292 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6293 cd     &   ' and',k,l
6294       itk=itortyp(itype(k))
6295       itl=itortyp(itype(l))
6296       itj=itortyp(itype(j))
6297       eello5_1=0.0d0
6298       eello5_2=0.0d0
6299       eello5_3=0.0d0
6300       eello5_4=0.0d0
6301 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6302 cd     &   eel5_3_num,eel5_4_num)
6303       do iii=1,2
6304         do kkk=1,5
6305           do lll=1,3
6306             derx(lll,kkk,iii)=0.0d0
6307           enddo
6308         enddo
6309       enddo
6310 cd      eij=facont_hb(jj,i)
6311 cd      ekl=facont_hb(kk,k)
6312 cd      ekont=eij*ekl
6313 cd      write (iout,*)'Contacts have occurred for peptide groups',
6314 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6315 cd      goto 1111
6316 C Contribution from the graph I.
6317 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6318 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6319       call transpose2(EUg(1,1,k),auxmat(1,1))
6320       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6321       vv(1)=pizda(1,1)-pizda(2,2)
6322       vv(2)=pizda(1,2)+pizda(2,1)
6323       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6324      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6325       if (calc_grad) then
6326 C Explicit gradient in virtual-dihedral angles.
6327       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6328      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6329      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6330       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6331       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6332       vv(1)=pizda(1,1)-pizda(2,2)
6333       vv(2)=pizda(1,2)+pizda(2,1)
6334       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6335      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6336      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6337       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6338       vv(1)=pizda(1,1)-pizda(2,2)
6339       vv(2)=pizda(1,2)+pizda(2,1)
6340       if (l.eq.j+1) then
6341         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6342      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6343      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6344       else
6345         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6346      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6347      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6348       endif
6349 C Cartesian gradient
6350       do iii=1,2
6351         do kkk=1,5
6352           do lll=1,3
6353             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6354      &        pizda(1,1))
6355             vv(1)=pizda(1,1)-pizda(2,2)
6356             vv(2)=pizda(1,2)+pizda(2,1)
6357             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6358      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6359      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6360           enddo
6361         enddo
6362       enddo
6363 c      goto 1112
6364       endif
6365 c1111  continue
6366 C Contribution from graph II
6367       call transpose2(EE(1,1,itk),auxmat(1,1))
6368       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6369       vv(1)=pizda(1,1)+pizda(2,2)
6370       vv(2)=pizda(2,1)-pizda(1,2)
6371       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6372      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6373       if (calc_grad) then
6374 C Explicit gradient in virtual-dihedral angles.
6375       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6376      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6377       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6378       vv(1)=pizda(1,1)+pizda(2,2)
6379       vv(2)=pizda(2,1)-pizda(1,2)
6380       if (l.eq.j+1) then
6381         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6382      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6383      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6384       else
6385         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6386      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6387      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6388       endif
6389 C Cartesian gradient
6390       do iii=1,2
6391         do kkk=1,5
6392           do lll=1,3
6393             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6394      &        pizda(1,1))
6395             vv(1)=pizda(1,1)+pizda(2,2)
6396             vv(2)=pizda(2,1)-pizda(1,2)
6397             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6398      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6399      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6400           enddo
6401         enddo
6402       enddo
6403 cd      goto 1112
6404       endif
6405 cd1111  continue
6406       if (l.eq.j+1) then
6407 cd        goto 1110
6408 C Parallel orientation
6409 C Contribution from graph III
6410         call transpose2(EUg(1,1,l),auxmat(1,1))
6411         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6412         vv(1)=pizda(1,1)-pizda(2,2)
6413         vv(2)=pizda(1,2)+pizda(2,1)
6414         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6415      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6416         if (calc_grad) then
6417 C Explicit gradient in virtual-dihedral angles.
6418         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6419      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6420      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6421         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6422         vv(1)=pizda(1,1)-pizda(2,2)
6423         vv(2)=pizda(1,2)+pizda(2,1)
6424         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6425      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6426      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6427         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6428         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6429         vv(1)=pizda(1,1)-pizda(2,2)
6430         vv(2)=pizda(1,2)+pizda(2,1)
6431         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6432      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6433      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6434 C Cartesian gradient
6435         do iii=1,2
6436           do kkk=1,5
6437             do lll=1,3
6438               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6439      &          pizda(1,1))
6440               vv(1)=pizda(1,1)-pizda(2,2)
6441               vv(2)=pizda(1,2)+pizda(2,1)
6442               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6443      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6444      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6445             enddo
6446           enddo
6447         enddo
6448 cd        goto 1112
6449         endif
6450 C Contribution from graph IV
6451 cd1110    continue
6452         call transpose2(EE(1,1,itl),auxmat(1,1))
6453         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6454         vv(1)=pizda(1,1)+pizda(2,2)
6455         vv(2)=pizda(2,1)-pizda(1,2)
6456         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6457      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6458         if (calc_grad) then
6459 C Explicit gradient in virtual-dihedral angles.
6460         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6461      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6462         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6463         vv(1)=pizda(1,1)+pizda(2,2)
6464         vv(2)=pizda(2,1)-pizda(1,2)
6465         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6466      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6467      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6468 C Cartesian gradient
6469         do iii=1,2
6470           do kkk=1,5
6471             do lll=1,3
6472               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6473      &          pizda(1,1))
6474               vv(1)=pizda(1,1)+pizda(2,2)
6475               vv(2)=pizda(2,1)-pizda(1,2)
6476               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6477      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6478      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6479             enddo
6480           enddo
6481         enddo
6482         endif
6483       else
6484 C Antiparallel orientation
6485 C Contribution from graph III
6486 c        goto 1110
6487         call transpose2(EUg(1,1,j),auxmat(1,1))
6488         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6489         vv(1)=pizda(1,1)-pizda(2,2)
6490         vv(2)=pizda(1,2)+pizda(2,1)
6491         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6492      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6493         if (calc_grad) then
6494 C Explicit gradient in virtual-dihedral angles.
6495         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6496      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6497      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6498         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6499         vv(1)=pizda(1,1)-pizda(2,2)
6500         vv(2)=pizda(1,2)+pizda(2,1)
6501         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6502      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6503      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6504         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6505         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6506         vv(1)=pizda(1,1)-pizda(2,2)
6507         vv(2)=pizda(1,2)+pizda(2,1)
6508         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6509      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6510      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6511 C Cartesian gradient
6512         do iii=1,2
6513           do kkk=1,5
6514             do lll=1,3
6515               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6516      &          pizda(1,1))
6517               vv(1)=pizda(1,1)-pizda(2,2)
6518               vv(2)=pizda(1,2)+pizda(2,1)
6519               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6520      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6521      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6522             enddo
6523           enddo
6524         enddo
6525 cd        goto 1112
6526         endif
6527 C Contribution from graph IV
6528 1110    continue
6529         call transpose2(EE(1,1,itj),auxmat(1,1))
6530         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6531         vv(1)=pizda(1,1)+pizda(2,2)
6532         vv(2)=pizda(2,1)-pizda(1,2)
6533         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6534      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6535         if (calc_grad) then
6536 C Explicit gradient in virtual-dihedral angles.
6537         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6538      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6539         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6540         vv(1)=pizda(1,1)+pizda(2,2)
6541         vv(2)=pizda(2,1)-pizda(1,2)
6542         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6543      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6544      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6545 C Cartesian gradient
6546         do iii=1,2
6547           do kkk=1,5
6548             do lll=1,3
6549               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6550      &          pizda(1,1))
6551               vv(1)=pizda(1,1)+pizda(2,2)
6552               vv(2)=pizda(2,1)-pizda(1,2)
6553               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6554      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6555      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6556             enddo
6557           enddo
6558         enddo
6559       endif
6560       endif
6561 1112  continue
6562       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6563 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6564 cd        write (2,*) 'ijkl',i,j,k,l
6565 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6566 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6567 cd      endif
6568 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6569 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6570 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6571 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6572       if (calc_grad) then
6573       if (j.lt.nres-1) then
6574         j1=j+1
6575         j2=j-1
6576       else
6577         j1=j-1
6578         j2=j-2
6579       endif
6580       if (l.lt.nres-1) then
6581         l1=l+1
6582         l2=l-1
6583       else
6584         l1=l-1
6585         l2=l-2
6586       endif
6587 cd      eij=1.0d0
6588 cd      ekl=1.0d0
6589 cd      ekont=1.0d0
6590 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6591       do ll=1,3
6592         ggg1(ll)=eel5*g_contij(ll,1)
6593         ggg2(ll)=eel5*g_contij(ll,2)
6594 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6595         ghalf=0.5d0*ggg1(ll)
6596 cd        ghalf=0.0d0
6597         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6598         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6599         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6600         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6601 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6602         ghalf=0.5d0*ggg2(ll)
6603 cd        ghalf=0.0d0
6604         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6605         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6606         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6607         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6608       enddo
6609 cd      goto 1112
6610       do m=i+1,j-1
6611         do ll=1,3
6612 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6613           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6614         enddo
6615       enddo
6616       do m=k+1,l-1
6617         do ll=1,3
6618 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6619           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6620         enddo
6621       enddo
6622 c1112  continue
6623       do m=i+2,j2
6624         do ll=1,3
6625           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6626         enddo
6627       enddo
6628       do m=k+2,l2
6629         do ll=1,3
6630           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6631         enddo
6632       enddo
6633 cd      do iii=1,nres-3
6634 cd        write (2,*) iii,g_corr5_loc(iii)
6635 cd      enddo
6636       endif
6637       eello5=ekont*eel5
6638 cd      write (2,*) 'ekont',ekont
6639 cd      write (iout,*) 'eello5',ekont*eel5
6640       return
6641       end
6642 c--------------------------------------------------------------------------
6643       double precision function eello6(i,j,k,l,jj,kk)
6644       implicit real*8 (a-h,o-z)
6645       include 'DIMENSIONS'
6646       include 'DIMENSIONS.ZSCOPT'
6647       include 'COMMON.IOUNITS'
6648       include 'COMMON.CHAIN'
6649       include 'COMMON.DERIV'
6650       include 'COMMON.INTERACT'
6651       include 'COMMON.CONTACTS'
6652       include 'COMMON.TORSION'
6653       include 'COMMON.VAR'
6654       include 'COMMON.GEO'
6655       include 'COMMON.FFIELD'
6656       double precision ggg1(3),ggg2(3)
6657 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6658 cd        eello6=0.0d0
6659 cd        return
6660 cd      endif
6661 cd      write (iout,*)
6662 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6663 cd     &   ' and',k,l
6664       eello6_1=0.0d0
6665       eello6_2=0.0d0
6666       eello6_3=0.0d0
6667       eello6_4=0.0d0
6668       eello6_5=0.0d0
6669       eello6_6=0.0d0
6670 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6671 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6672       do iii=1,2
6673         do kkk=1,5
6674           do lll=1,3
6675             derx(lll,kkk,iii)=0.0d0
6676           enddo
6677         enddo
6678       enddo
6679 cd      eij=facont_hb(jj,i)
6680 cd      ekl=facont_hb(kk,k)
6681 cd      ekont=eij*ekl
6682 cd      eij=1.0d0
6683 cd      ekl=1.0d0
6684 cd      ekont=1.0d0
6685       if (l.eq.j+1) then
6686         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6687         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6688         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6689         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6690         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6691         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6692       else
6693         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6694         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6695         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6696         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6697         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6698           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6699         else
6700           eello6_5=0.0d0
6701         endif
6702         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6703       endif
6704 C If turn contributions are considered, they will be handled separately.
6705       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6706 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6707 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6708 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6709 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6710 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6711 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6712 cd      goto 1112
6713       if (calc_grad) then
6714       if (j.lt.nres-1) then
6715         j1=j+1
6716         j2=j-1
6717       else
6718         j1=j-1
6719         j2=j-2
6720       endif
6721       if (l.lt.nres-1) then
6722         l1=l+1
6723         l2=l-1
6724       else
6725         l1=l-1
6726         l2=l-2
6727       endif
6728       do ll=1,3
6729         ggg1(ll)=eel6*g_contij(ll,1)
6730         ggg2(ll)=eel6*g_contij(ll,2)
6731 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6732         ghalf=0.5d0*ggg1(ll)
6733 cd        ghalf=0.0d0
6734         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6735         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6736         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6737         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6738         ghalf=0.5d0*ggg2(ll)
6739 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6740 cd        ghalf=0.0d0
6741         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6742         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6743         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6744         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6745       enddo
6746 cd      goto 1112
6747       do m=i+1,j-1
6748         do ll=1,3
6749 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6750           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6751         enddo
6752       enddo
6753       do m=k+1,l-1
6754         do ll=1,3
6755 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6756           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6757         enddo
6758       enddo
6759 1112  continue
6760       do m=i+2,j2
6761         do ll=1,3
6762           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6763         enddo
6764       enddo
6765       do m=k+2,l2
6766         do ll=1,3
6767           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6768         enddo
6769       enddo
6770 cd      do iii=1,nres-3
6771 cd        write (2,*) iii,g_corr6_loc(iii)
6772 cd      enddo
6773       endif
6774       eello6=ekont*eel6
6775 cd      write (2,*) 'ekont',ekont
6776 cd      write (iout,*) 'eello6',ekont*eel6
6777       return
6778       end
6779 c--------------------------------------------------------------------------
6780       double precision function eello6_graph1(i,j,k,l,imat,swap)
6781       implicit real*8 (a-h,o-z)
6782       include 'DIMENSIONS'
6783       include 'DIMENSIONS.ZSCOPT'
6784       include 'COMMON.IOUNITS'
6785       include 'COMMON.CHAIN'
6786       include 'COMMON.DERIV'
6787       include 'COMMON.INTERACT'
6788       include 'COMMON.CONTACTS'
6789       include 'COMMON.TORSION'
6790       include 'COMMON.VAR'
6791       include 'COMMON.GEO'
6792       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6793       logical swap
6794       logical lprn
6795       common /kutas/ lprn
6796 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6797 C                                                                              C
6798 C      Parallel       Antiparallel                                             C
6799 C                                                                              C
6800 C          o             o                                                     C
6801 C         /l\           /j\                                                    C
6802 C        /   \         /   \                                                   C
6803 C       /| o |         | o |\                                                  C
6804 C     \ j|/k\|  /   \  |/k\|l /                                                C
6805 C      \ /   \ /     \ /   \ /                                                 C
6806 C       o     o       o     o                                                  C
6807 C       i             i                                                        C
6808 C                                                                              C
6809 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6810       itk=itortyp(itype(k))
6811       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6812       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6813       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6814       call transpose2(EUgC(1,1,k),auxmat(1,1))
6815       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6816       vv1(1)=pizda1(1,1)-pizda1(2,2)
6817       vv1(2)=pizda1(1,2)+pizda1(2,1)
6818       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6819       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6820       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6821       s5=scalar2(vv(1),Dtobr2(1,i))
6822 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6823       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6824       if (.not. calc_grad) return
6825       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6826      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6827      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6828      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6829      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6830      & +scalar2(vv(1),Dtobr2der(1,i)))
6831       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6832       vv1(1)=pizda1(1,1)-pizda1(2,2)
6833       vv1(2)=pizda1(1,2)+pizda1(2,1)
6834       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6835       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6836       if (l.eq.j+1) then
6837         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6838      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6839      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6840      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6841      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6842       else
6843         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6844      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6845      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6846      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6847      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6848       endif
6849       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6850       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6851       vv1(1)=pizda1(1,1)-pizda1(2,2)
6852       vv1(2)=pizda1(1,2)+pizda1(2,1)
6853       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6854      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6855      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6856      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6857       do iii=1,2
6858         if (swap) then
6859           ind=3-iii
6860         else
6861           ind=iii
6862         endif
6863         do kkk=1,5
6864           do lll=1,3
6865             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6866             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6867             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6868             call transpose2(EUgC(1,1,k),auxmat(1,1))
6869             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6870      &        pizda1(1,1))
6871             vv1(1)=pizda1(1,1)-pizda1(2,2)
6872             vv1(2)=pizda1(1,2)+pizda1(2,1)
6873             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6874             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6875      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6876             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6877      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6878             s5=scalar2(vv(1),Dtobr2(1,i))
6879             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6880           enddo
6881         enddo
6882       enddo
6883       return
6884       end
6885 c----------------------------------------------------------------------------
6886       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6887       implicit real*8 (a-h,o-z)
6888       include 'DIMENSIONS'
6889       include 'DIMENSIONS.ZSCOPT'
6890       include 'COMMON.IOUNITS'
6891       include 'COMMON.CHAIN'
6892       include 'COMMON.DERIV'
6893       include 'COMMON.INTERACT'
6894       include 'COMMON.CONTACTS'
6895       include 'COMMON.TORSION'
6896       include 'COMMON.VAR'
6897       include 'COMMON.GEO'
6898       logical swap
6899       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6900      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6901       logical lprn
6902       common /kutas/ lprn
6903 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6904 C                                                                              C
6905 C      Parallel       Antiparallel                                             C
6906 C                                                                              C
6907 C          o             o                                                     C
6908 C     \   /l\           /j\   /                                                C
6909 C      \ /   \         /   \ /                                                 C
6910 C       o| o |         | o |o                                                  C
6911 C     \ j|/k\|      \  |/k\|l                                                  C
6912 C      \ /   \       \ /   \                                                   C
6913 C       o             o                                                        C
6914 C       i             i                                                        C
6915 C                                                                              C
6916 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6917 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6918 C AL 7/4/01 s1 would occur in the sixth-order moment,
6919 C           but not in a cluster cumulant
6920 #ifdef MOMENT
6921       s1=dip(1,jj,i)*dip(1,kk,k)
6922 #endif
6923       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6924       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6925       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6926       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6927       call transpose2(EUg(1,1,k),auxmat(1,1))
6928       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6929       vv(1)=pizda(1,1)-pizda(2,2)
6930       vv(2)=pizda(1,2)+pizda(2,1)
6931       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6932 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6933 #ifdef MOMENT
6934       eello6_graph2=-(s1+s2+s3+s4)
6935 #else
6936       eello6_graph2=-(s2+s3+s4)
6937 #endif
6938 c      eello6_graph2=-s3
6939       if (.not. calc_grad) return
6940 C Derivatives in gamma(i-1)
6941       if (i.gt.1) then
6942 #ifdef MOMENT
6943         s1=dipderg(1,jj,i)*dip(1,kk,k)
6944 #endif
6945         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6946         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6947         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6948         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6949 #ifdef MOMENT
6950         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6951 #else
6952         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6953 #endif
6954 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6955       endif
6956 C Derivatives in gamma(k-1)
6957 #ifdef MOMENT
6958       s1=dip(1,jj,i)*dipderg(1,kk,k)
6959 #endif
6960       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6961       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6962       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6963       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6964       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6965       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6966       vv(1)=pizda(1,1)-pizda(2,2)
6967       vv(2)=pizda(1,2)+pizda(2,1)
6968       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6969 #ifdef MOMENT
6970       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6971 #else
6972       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6973 #endif
6974 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6975 C Derivatives in gamma(j-1) or gamma(l-1)
6976       if (j.gt.1) then
6977 #ifdef MOMENT
6978         s1=dipderg(3,jj,i)*dip(1,kk,k)
6979 #endif
6980         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6981         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6982         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6983         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6984         vv(1)=pizda(1,1)-pizda(2,2)
6985         vv(2)=pizda(1,2)+pizda(2,1)
6986         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6987 #ifdef MOMENT
6988         if (swap) then
6989           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6990         else
6991           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6992         endif
6993 #endif
6994         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6995 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6996       endif
6997 C Derivatives in gamma(l-1) or gamma(j-1)
6998       if (l.gt.1) then
6999 #ifdef MOMENT
7000         s1=dip(1,jj,i)*dipderg(3,kk,k)
7001 #endif
7002         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7003         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7004         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7005         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7006         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7007         vv(1)=pizda(1,1)-pizda(2,2)
7008         vv(2)=pizda(1,2)+pizda(2,1)
7009         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7010 #ifdef MOMENT
7011         if (swap) then
7012           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7013         else
7014           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7015         endif
7016 #endif
7017         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7018 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7019       endif
7020 C Cartesian derivatives.
7021       if (lprn) then
7022         write (2,*) 'In eello6_graph2'
7023         do iii=1,2
7024           write (2,*) 'iii=',iii
7025           do kkk=1,5
7026             write (2,*) 'kkk=',kkk
7027             do jjj=1,2
7028               write (2,'(3(2f10.5),5x)')
7029      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7030             enddo
7031           enddo
7032         enddo
7033       endif
7034       do iii=1,2
7035         do kkk=1,5
7036           do lll=1,3
7037 #ifdef MOMENT
7038             if (iii.eq.1) then
7039               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7040             else
7041               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7042             endif
7043 #endif
7044             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7045      &        auxvec(1))
7046             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7047             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7048      &        auxvec(1))
7049             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7050             call transpose2(EUg(1,1,k),auxmat(1,1))
7051             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7052      &        pizda(1,1))
7053             vv(1)=pizda(1,1)-pizda(2,2)
7054             vv(2)=pizda(1,2)+pizda(2,1)
7055             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7056 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7057 #ifdef MOMENT
7058             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7059 #else
7060             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7061 #endif
7062             if (swap) then
7063               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7064             else
7065               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7066             endif
7067           enddo
7068         enddo
7069       enddo
7070       return
7071       end
7072 c----------------------------------------------------------------------------
7073       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7074       implicit real*8 (a-h,o-z)
7075       include 'DIMENSIONS'
7076       include 'DIMENSIONS.ZSCOPT'
7077       include 'COMMON.IOUNITS'
7078       include 'COMMON.CHAIN'
7079       include 'COMMON.DERIV'
7080       include 'COMMON.INTERACT'
7081       include 'COMMON.CONTACTS'
7082       include 'COMMON.TORSION'
7083       include 'COMMON.VAR'
7084       include 'COMMON.GEO'
7085       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7086       logical swap
7087 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7088 C                                                                              C
7089 C      Parallel       Antiparallel                                             C
7090 C                                                                              C
7091 C          o             o                                                     C
7092 C         /l\   /   \   /j\                                                    C
7093 C        /   \ /     \ /   \                                                   C
7094 C       /| o |o       o| o |\                                                  C
7095 C       j|/k\|  /      |/k\|l /                                                C
7096 C        /   \ /       /   \ /                                                 C
7097 C       /     o       /     o                                                  C
7098 C       i             i                                                        C
7099 C                                                                              C
7100 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7101 C
7102 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7103 C           energy moment and not to the cluster cumulant.
7104       iti=itortyp(itype(i))
7105       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7106         itj1=itortyp(itype(j+1))
7107       else
7108         itj1=ntortyp+1
7109       endif
7110       itk=itortyp(itype(k))
7111       itk1=itortyp(itype(k+1))
7112       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7113         itl1=itortyp(itype(l+1))
7114       else
7115         itl1=ntortyp+1
7116       endif
7117 #ifdef MOMENT
7118       s1=dip(4,jj,i)*dip(4,kk,k)
7119 #endif
7120       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7121       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7122       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7123       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7124       call transpose2(EE(1,1,itk),auxmat(1,1))
7125       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7126       vv(1)=pizda(1,1)+pizda(2,2)
7127       vv(2)=pizda(2,1)-pizda(1,2)
7128       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7129 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7130 #ifdef MOMENT
7131       eello6_graph3=-(s1+s2+s3+s4)
7132 #else
7133       eello6_graph3=-(s2+s3+s4)
7134 #endif
7135 c      eello6_graph3=-s4
7136       if (.not. calc_grad) return
7137 C Derivatives in gamma(k-1)
7138       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7139       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7140       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7141       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7142 C Derivatives in gamma(l-1)
7143       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7144       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7145       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7146       vv(1)=pizda(1,1)+pizda(2,2)
7147       vv(2)=pizda(2,1)-pizda(1,2)
7148       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7149       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7150 C Cartesian derivatives.
7151       do iii=1,2
7152         do kkk=1,5
7153           do lll=1,3
7154 #ifdef MOMENT
7155             if (iii.eq.1) then
7156               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7157             else
7158               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7159             endif
7160 #endif
7161             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7162      &        auxvec(1))
7163             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7164             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7165      &        auxvec(1))
7166             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7167             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7168      &        pizda(1,1))
7169             vv(1)=pizda(1,1)+pizda(2,2)
7170             vv(2)=pizda(2,1)-pizda(1,2)
7171             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7172 #ifdef MOMENT
7173             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7174 #else
7175             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7176 #endif
7177             if (swap) then
7178               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7179             else
7180               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7181             endif
7182 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7183           enddo
7184         enddo
7185       enddo
7186       return
7187       end
7188 c----------------------------------------------------------------------------
7189       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7190       implicit real*8 (a-h,o-z)
7191       include 'DIMENSIONS'
7192       include 'DIMENSIONS.ZSCOPT'
7193       include 'COMMON.IOUNITS'
7194       include 'COMMON.CHAIN'
7195       include 'COMMON.DERIV'
7196       include 'COMMON.INTERACT'
7197       include 'COMMON.CONTACTS'
7198       include 'COMMON.TORSION'
7199       include 'COMMON.VAR'
7200       include 'COMMON.GEO'
7201       include 'COMMON.FFIELD'
7202       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7203      & auxvec1(2),auxmat1(2,2)
7204       logical swap
7205 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7206 C                                                                              C
7207 C      Parallel       Antiparallel                                             C
7208 C                                                                              C
7209 C          o             o                                                     C
7210 C         /l\   /   \   /j\                                                    C
7211 C        /   \ /     \ /   \                                                   C
7212 C       /| o |o       o| o |\                                                  C
7213 C     \ j|/k\|      \  |/k\|l                                                  C
7214 C      \ /   \       \ /   \                                                   C
7215 C       o     \       o     \                                                  C
7216 C       i             i                                                        C
7217 C                                                                              C
7218 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7219 C
7220 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7221 C           energy moment and not to the cluster cumulant.
7222 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7223       iti=itortyp(itype(i))
7224       itj=itortyp(itype(j))
7225       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7226         itj1=itortyp(itype(j+1))
7227       else
7228         itj1=ntortyp+1
7229       endif
7230       itk=itortyp(itype(k))
7231       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7232         itk1=itortyp(itype(k+1))
7233       else
7234         itk1=ntortyp+1
7235       endif
7236       itl=itortyp(itype(l))
7237       if (l.lt.nres-1) then
7238         itl1=itortyp(itype(l+1))
7239       else
7240         itl1=ntortyp+1
7241       endif
7242 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7243 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7244 cd     & ' itl',itl,' itl1',itl1
7245 #ifdef MOMENT
7246       if (imat.eq.1) then
7247         s1=dip(3,jj,i)*dip(3,kk,k)
7248       else
7249         s1=dip(2,jj,j)*dip(2,kk,l)
7250       endif
7251 #endif
7252       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7253       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7254       if (j.eq.l+1) then
7255         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7256         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7257       else
7258         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7259         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7260       endif
7261       call transpose2(EUg(1,1,k),auxmat(1,1))
7262       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7263       vv(1)=pizda(1,1)-pizda(2,2)
7264       vv(2)=pizda(2,1)+pizda(1,2)
7265       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7266 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7267 #ifdef MOMENT
7268       eello6_graph4=-(s1+s2+s3+s4)
7269 #else
7270       eello6_graph4=-(s2+s3+s4)
7271 #endif
7272       if (.not. calc_grad) return
7273 C Derivatives in gamma(i-1)
7274       if (i.gt.1) then
7275 #ifdef MOMENT
7276         if (imat.eq.1) then
7277           s1=dipderg(2,jj,i)*dip(3,kk,k)
7278         else
7279           s1=dipderg(4,jj,j)*dip(2,kk,l)
7280         endif
7281 #endif
7282         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7283         if (j.eq.l+1) then
7284           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7285           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7286         else
7287           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7288           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7289         endif
7290         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7291         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7292 cd          write (2,*) 'turn6 derivatives'
7293 #ifdef MOMENT
7294           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7295 #else
7296           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7297 #endif
7298         else
7299 #ifdef MOMENT
7300           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7301 #else
7302           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7303 #endif
7304         endif
7305       endif
7306 C Derivatives in gamma(k-1)
7307 #ifdef MOMENT
7308       if (imat.eq.1) then
7309         s1=dip(3,jj,i)*dipderg(2,kk,k)
7310       else
7311         s1=dip(2,jj,j)*dipderg(4,kk,l)
7312       endif
7313 #endif
7314       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7315       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7316       if (j.eq.l+1) then
7317         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7318         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7319       else
7320         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7321         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7322       endif
7323       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7324       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7325       vv(1)=pizda(1,1)-pizda(2,2)
7326       vv(2)=pizda(2,1)+pizda(1,2)
7327       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7328       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7329 #ifdef MOMENT
7330         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7331 #else
7332         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7333 #endif
7334       else
7335 #ifdef MOMENT
7336         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7337 #else
7338         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7339 #endif
7340       endif
7341 C Derivatives in gamma(j-1) or gamma(l-1)
7342       if (l.eq.j+1 .and. l.gt.1) then
7343         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7344         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7345         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7346         vv(1)=pizda(1,1)-pizda(2,2)
7347         vv(2)=pizda(2,1)+pizda(1,2)
7348         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7349         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7350       else if (j.gt.1) then
7351         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7352         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7353         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7354         vv(1)=pizda(1,1)-pizda(2,2)
7355         vv(2)=pizda(2,1)+pizda(1,2)
7356         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7357         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7358           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7359         else
7360           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7361         endif
7362       endif
7363 C Cartesian derivatives.
7364       do iii=1,2
7365         do kkk=1,5
7366           do lll=1,3
7367 #ifdef MOMENT
7368             if (iii.eq.1) then
7369               if (imat.eq.1) then
7370                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7371               else
7372                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7373               endif
7374             else
7375               if (imat.eq.1) then
7376                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7377               else
7378                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7379               endif
7380             endif
7381 #endif
7382             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7383      &        auxvec(1))
7384             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7385             if (j.eq.l+1) then
7386               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7387      &          b1(1,itj1),auxvec(1))
7388               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7389             else
7390               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7391      &          b1(1,itl1),auxvec(1))
7392               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7393             endif
7394             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7395      &        pizda(1,1))
7396             vv(1)=pizda(1,1)-pizda(2,2)
7397             vv(2)=pizda(2,1)+pizda(1,2)
7398             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7399             if (swap) then
7400               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7401 #ifdef MOMENT
7402                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7403      &             -(s1+s2+s4)
7404 #else
7405                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7406      &             -(s2+s4)
7407 #endif
7408                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7409               else
7410 #ifdef MOMENT
7411                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7412 #else
7413                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7414 #endif
7415                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7416               endif
7417             else
7418 #ifdef MOMENT
7419               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7420 #else
7421               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7422 #endif
7423               if (l.eq.j+1) then
7424                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7425               else
7426                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7427               endif
7428             endif
7429           enddo
7430         enddo
7431       enddo
7432       return
7433       end
7434 c----------------------------------------------------------------------------
7435       double precision function eello_turn6(i,jj,kk)
7436       implicit real*8 (a-h,o-z)
7437       include 'DIMENSIONS'
7438       include 'DIMENSIONS.ZSCOPT'
7439       include 'COMMON.IOUNITS'
7440       include 'COMMON.CHAIN'
7441       include 'COMMON.DERIV'
7442       include 'COMMON.INTERACT'
7443       include 'COMMON.CONTACTS'
7444       include 'COMMON.TORSION'
7445       include 'COMMON.VAR'
7446       include 'COMMON.GEO'
7447       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7448      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7449      &  ggg1(3),ggg2(3)
7450       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7451      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7452 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7453 C           the respective energy moment and not to the cluster cumulant.
7454       eello_turn6=0.0d0
7455       j=i+4
7456       k=i+1
7457       l=i+3
7458       iti=itortyp(itype(i))
7459       itk=itortyp(itype(k))
7460       itk1=itortyp(itype(k+1))
7461       itl=itortyp(itype(l))
7462       itj=itortyp(itype(j))
7463 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7464 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7465 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7466 cd        eello6=0.0d0
7467 cd        return
7468 cd      endif
7469 cd      write (iout,*)
7470 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7471 cd     &   ' and',k,l
7472 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7473       do iii=1,2
7474         do kkk=1,5
7475           do lll=1,3
7476             derx_turn(lll,kkk,iii)=0.0d0
7477           enddo
7478         enddo
7479       enddo
7480 cd      eij=1.0d0
7481 cd      ekl=1.0d0
7482 cd      ekont=1.0d0
7483       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7484 cd      eello6_5=0.0d0
7485 cd      write (2,*) 'eello6_5',eello6_5
7486 #ifdef MOMENT
7487       call transpose2(AEA(1,1,1),auxmat(1,1))
7488       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7489       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7490       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7491 #else
7492       s1 = 0.0d0
7493 #endif
7494       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7495       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7496       s2 = scalar2(b1(1,itk),vtemp1(1))
7497 #ifdef MOMENT
7498       call transpose2(AEA(1,1,2),atemp(1,1))
7499       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7500       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7501       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7502 #else
7503       s8=0.0d0
7504 #endif
7505       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7506       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7507       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7508 #ifdef MOMENT
7509       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7510       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7511       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7512       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7513       ss13 = scalar2(b1(1,itk),vtemp4(1))
7514       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7515 #else
7516       s13=0.0d0
7517 #endif
7518 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7519 c      s1=0.0d0
7520 c      s2=0.0d0
7521 c      s8=0.0d0
7522 c      s12=0.0d0
7523 c      s13=0.0d0
7524       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7525       if (calc_grad) then
7526 C Derivatives in gamma(i+2)
7527 #ifdef MOMENT
7528       call transpose2(AEA(1,1,1),auxmatd(1,1))
7529       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7530       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7531       call transpose2(AEAderg(1,1,2),atempd(1,1))
7532       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7533       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7534 #else
7535       s8d=0.0d0
7536 #endif
7537       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7538       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7539       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7540 c      s1d=0.0d0
7541 c      s2d=0.0d0
7542 c      s8d=0.0d0
7543 c      s12d=0.0d0
7544 c      s13d=0.0d0
7545       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7546 C Derivatives in gamma(i+3)
7547 #ifdef MOMENT
7548       call transpose2(AEA(1,1,1),auxmatd(1,1))
7549       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7550       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7551       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7552 #else
7553       s1d=0.0d0
7554 #endif
7555       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7556       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7557       s2d = scalar2(b1(1,itk),vtemp1d(1))
7558 #ifdef MOMENT
7559       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7560       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7561 #endif
7562       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7563 #ifdef MOMENT
7564       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7565       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7566       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7567 #else
7568       s13d=0.0d0
7569 #endif
7570 c      s1d=0.0d0
7571 c      s2d=0.0d0
7572 c      s8d=0.0d0
7573 c      s12d=0.0d0
7574 c      s13d=0.0d0
7575 #ifdef MOMENT
7576       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7577      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7578 #else
7579       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7580      &               -0.5d0*ekont*(s2d+s12d)
7581 #endif
7582 C Derivatives in gamma(i+4)
7583       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7584       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7585       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7586 #ifdef MOMENT
7587       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7588       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7589       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7590 #else
7591       s13d = 0.0d0
7592 #endif
7593 c      s1d=0.0d0
7594 c      s2d=0.0d0
7595 c      s8d=0.0d0
7596 C      s12d=0.0d0
7597 c      s13d=0.0d0
7598 #ifdef MOMENT
7599       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7600 #else
7601       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7602 #endif
7603 C Derivatives in gamma(i+5)
7604 #ifdef MOMENT
7605       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7606       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7607       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7608 #else
7609       s1d = 0.0d0
7610 #endif
7611       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7612       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7613       s2d = scalar2(b1(1,itk),vtemp1d(1))
7614 #ifdef MOMENT
7615       call transpose2(AEA(1,1,2),atempd(1,1))
7616       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7617       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7618 #else
7619       s8d = 0.0d0
7620 #endif
7621       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7622       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7623 #ifdef MOMENT
7624       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7625       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7626       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7627 #else
7628       s13d = 0.0d0
7629 #endif
7630 c      s1d=0.0d0
7631 c      s2d=0.0d0
7632 c      s8d=0.0d0
7633 c      s12d=0.0d0
7634 c      s13d=0.0d0
7635 #ifdef MOMENT
7636       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7637      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7638 #else
7639       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7640      &               -0.5d0*ekont*(s2d+s12d)
7641 #endif
7642 C Cartesian derivatives
7643       do iii=1,2
7644         do kkk=1,5
7645           do lll=1,3
7646 #ifdef MOMENT
7647             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7648             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7649             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7650 #else
7651             s1d = 0.0d0
7652 #endif
7653             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7654             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7655      &          vtemp1d(1))
7656             s2d = scalar2(b1(1,itk),vtemp1d(1))
7657 #ifdef MOMENT
7658             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7659             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7660             s8d = -(atempd(1,1)+atempd(2,2))*
7661      &           scalar2(cc(1,1,itl),vtemp2(1))
7662 #else
7663             s8d = 0.0d0
7664 #endif
7665             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7666      &           auxmatd(1,1))
7667             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7668             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7669 c      s1d=0.0d0
7670 c      s2d=0.0d0
7671 c      s8d=0.0d0
7672 c      s12d=0.0d0
7673 c      s13d=0.0d0
7674 #ifdef MOMENT
7675             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7676      &        - 0.5d0*(s1d+s2d)
7677 #else
7678             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7679      &        - 0.5d0*s2d
7680 #endif
7681 #ifdef MOMENT
7682             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7683      &        - 0.5d0*(s8d+s12d)
7684 #else
7685             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7686      &        - 0.5d0*s12d
7687 #endif
7688           enddo
7689         enddo
7690       enddo
7691 #ifdef MOMENT
7692       do kkk=1,5
7693         do lll=1,3
7694           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7695      &      achuj_tempd(1,1))
7696           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7697           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7698           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7699           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7700           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7701      &      vtemp4d(1))
7702           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7703           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7704           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7705         enddo
7706       enddo
7707 #endif
7708 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7709 cd     &  16*eel_turn6_num
7710 cd      goto 1112
7711       if (j.lt.nres-1) then
7712         j1=j+1
7713         j2=j-1
7714       else
7715         j1=j-1
7716         j2=j-2
7717       endif
7718       if (l.lt.nres-1) then
7719         l1=l+1
7720         l2=l-1
7721       else
7722         l1=l-1
7723         l2=l-2
7724       endif
7725       do ll=1,3
7726         ggg1(ll)=eel_turn6*g_contij(ll,1)
7727         ggg2(ll)=eel_turn6*g_contij(ll,2)
7728         ghalf=0.5d0*ggg1(ll)
7729 cd        ghalf=0.0d0
7730         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7731      &    +ekont*derx_turn(ll,2,1)
7732         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7733         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7734      &    +ekont*derx_turn(ll,4,1)
7735         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7736         ghalf=0.5d0*ggg2(ll)
7737 cd        ghalf=0.0d0
7738         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7739      &    +ekont*derx_turn(ll,2,2)
7740         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7741         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7742      &    +ekont*derx_turn(ll,4,2)
7743         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7744       enddo
7745 cd      goto 1112
7746       do m=i+1,j-1
7747         do ll=1,3
7748           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7749         enddo
7750       enddo
7751       do m=k+1,l-1
7752         do ll=1,3
7753           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7754         enddo
7755       enddo
7756 1112  continue
7757       do m=i+2,j2
7758         do ll=1,3
7759           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7760         enddo
7761       enddo
7762       do m=k+2,l2
7763         do ll=1,3
7764           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7765         enddo
7766       enddo
7767 cd      do iii=1,nres-3
7768 cd        write (2,*) iii,g_corr6_loc(iii)
7769 cd      enddo
7770       endif
7771       eello_turn6=ekont*eel_turn6
7772 cd      write (2,*) 'ekont',ekont
7773 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7774       return
7775       end
7776 crc-------------------------------------------------
7777       SUBROUTINE MATVEC2(A1,V1,V2)
7778       implicit real*8 (a-h,o-z)
7779       include 'DIMENSIONS'
7780       DIMENSION A1(2,2),V1(2),V2(2)
7781 c      DO 1 I=1,2
7782 c        VI=0.0
7783 c        DO 3 K=1,2
7784 c    3     VI=VI+A1(I,K)*V1(K)
7785 c        Vaux(I)=VI
7786 c    1 CONTINUE
7787
7788       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7789       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7790
7791       v2(1)=vaux1
7792       v2(2)=vaux2
7793       END
7794 C---------------------------------------
7795       SUBROUTINE MATMAT2(A1,A2,A3)
7796       implicit real*8 (a-h,o-z)
7797       include 'DIMENSIONS'
7798       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7799 c      DIMENSION AI3(2,2)
7800 c        DO  J=1,2
7801 c          A3IJ=0.0
7802 c          DO K=1,2
7803 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7804 c          enddo
7805 c          A3(I,J)=A3IJ
7806 c       enddo
7807 c      enddo
7808
7809       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7810       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7811       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7812       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7813
7814       A3(1,1)=AI3_11
7815       A3(2,1)=AI3_21
7816       A3(1,2)=AI3_12
7817       A3(2,2)=AI3_22
7818       END
7819
7820 c-------------------------------------------------------------------------
7821       double precision function scalar2(u,v)
7822       implicit none
7823       double precision u(2),v(2)
7824       double precision sc
7825       integer i
7826       scalar2=u(1)*v(1)+u(2)*v(2)
7827       return
7828       end
7829
7830 C-----------------------------------------------------------------------------
7831
7832       subroutine transpose2(a,at)
7833       implicit none
7834       double precision a(2,2),at(2,2)
7835       at(1,1)=a(1,1)
7836       at(1,2)=a(2,1)
7837       at(2,1)=a(1,2)
7838       at(2,2)=a(2,2)
7839       return
7840       end
7841 c--------------------------------------------------------------------------
7842       subroutine transpose(n,a,at)
7843       implicit none
7844       integer n,i,j
7845       double precision a(n,n),at(n,n)
7846       do i=1,n
7847         do j=1,n
7848           at(j,i)=a(i,j)
7849         enddo
7850       enddo
7851       return
7852       end
7853 C---------------------------------------------------------------------------
7854       subroutine prodmat3(a1,a2,kk,transp,prod)
7855       implicit none
7856       integer i,j
7857       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7858       logical transp
7859 crc      double precision auxmat(2,2),prod_(2,2)
7860
7861       if (transp) then
7862 crc        call transpose2(kk(1,1),auxmat(1,1))
7863 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7864 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7865
7866            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7867      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7868            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7869      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7870            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7871      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7872            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7873      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7874
7875       else
7876 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7877 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7878
7879            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7880      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7881            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7882      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7883            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7884      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7885            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7886      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7887
7888       endif
7889 c      call transpose2(a2(1,1),a2t(1,1))
7890
7891 crc      print *,transp
7892 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7893 crc      print *,((prod(i,j),i=1,2),j=1,2)
7894
7895       return
7896       end
7897 C-----------------------------------------------------------------------------
7898       double precision function scalar(u,v)
7899       implicit none
7900       double precision u(3),v(3)
7901       double precision sc
7902       integer i
7903       sc=0.0d0
7904       do i=1,3
7905         sc=sc+u(i)*v(i)
7906       enddo
7907       scalar=sc
7908       return
7909       end
7910 C-----------------------------------------------------------------------
7911       double precision function sscale(r)
7912       double precision r,gamm
7913       include "COMMON.SPLITELE"
7914       if(r.lt.r_cut-rlamb) then
7915         sscale=1.0d0
7916       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
7917         gamm=(r-(r_cut-rlamb))/rlamb
7918         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
7919       else
7920         sscale=0d0
7921       endif
7922       return
7923       end
7924 C-----------------------------------------------------------------------
7925 C-----------------------------------------------------------------------
7926       double precision function sscagrad(r)
7927       double precision r,gamm
7928       include "COMMON.SPLITELE"
7929       if(r.lt.r_cut-rlamb) then
7930         sscagrad=0.0d0
7931       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
7932         gamm=(r-(r_cut-rlamb))/rlamb
7933         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
7934       else
7935         sscagrad=0.0d0
7936       endif
7937       return
7938       end
7939 C-----------------------------------------------------------------------
7940