source/cluster/wham/src-M/energy_p_new.F

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