program test_sf
	use, intrinsic :: iso_fortran_env, only : output_unit, error_unit
	use superfluid_def
	use superfluid_lib

	integer, parameter :: Np = 40
	integer :: i, ierr
	real(dp) :: kF_1, kF_2, k, Tc(max_number_sf_types)

	call sf_startup('../../data',ierr)
    if (failure('startup')) stop

	call sf_load_gaps('ccdk93','gc','ao85',ierr)
    if (failure('load gaps')) stop

	kF_1 = min(sf_tables(neutron_1S0)% kF_min, &
			& sf_tables(neutron_3P2)% kF_min, sf_tables(proton_1S0)% kF_min)
	kF_2 = max(sf_tables(neutron_1S0)% kF_max, &
			&	sf_tables(neutron_3P2)% kF_max, sf_tables(proton_1S0)% kF_max)

	write (output_unit,'(a7,tr8,3(a13,tr2))') 'k/fm^-1','Tc(p 1S0)/GK','Tc(n 1S0)/GK','Tc(n 3P2)/GK'
	write (output_unit,'(7("="),tr8,3(13("="),tr2))')
	do i = 1, Np
		k = kF_1 + (kF_2-kF_1)*real(i-1)/real(Np-1)
		call sf_get_results(k,k,Tc)
		write (output_unit,'(f7.3,tr8,3(tr3,f10.6,tr2))') k, Tc*1.0e-9
	end do

	call sf_shutdown

	contains
        function failure(message)
            character(len=*), intent(in) :: message
            logical :: failure

            failure = (ierr /= 0)
            if (failure)  &
            &   write (error_unit,'(a)') 'failure in '//message
        end function failure

end program test_sf


      SUBROUTINE CLAREF( TYPE, A, LDA, WANTZ, Z, LDZ, BLOCK, IROW1,
     $                   ICOL1, ISTART, ISTOP, ITMP1, ITMP2, LILOZ,
     $                   LIHIZ, VECS, V2, V3, T1, T2, T3 )
*
*  -- ScaLAPACK routine (version 1.7) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     May 28, 1999
*
*     .. Scalar Arguments ..
      LOGICAL            BLOCK, WANTZ
      CHARACTER          TYPE
      INTEGER            ICOL1, IROW1, ISTART, ISTOP, ITMP1, ITMP2, LDA,
     $                   LDZ, LIHIZ, LILOZ
      COMPLEX            T1, T2, T3, V2, V3
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), VECS( * ), Z( LDZ, * )
*     ..
*
*  Purpose
*  =======
*
*  CLAREF applies one or several Householder reflectors of size 3
*     to one or two matrices (if column is specified) on either their
*     rows or columns.
*
*  Arguments
*  =========
*
*  TYPE    (global input) CHARACTER*1
*          If 'R': Apply reflectors to the rows of the matrix
*              (apply from left)
*          Otherwise: Apply reflectors to the columns of the matrix
*          Unchanged on exit.
*
*  A       (global input/output) COMPLEX array, (LDA,*)
*          On entry, the matrix to receive the reflections.
*          The updated matrix on exit.
*
*  LDA     (local input) INTEGER
*          On entry, the leading dimension of A.  Unchanged on exit.
*
*  WANTZ   (global input) LOGICAL
*          If .TRUE., then apply any column reflections to Z as well.
*          If .FALSE., then do no additional work on Z.
*
*  Z       (global input/output) COMPLEX array, (LDZ,*)
*          On entry, the second matrix to receive column reflections.
*          This is changed only if WANTZ is set.
*
*  LDZ     (local input) INTEGER
*          On entry, the leading dimension of Z.  Unchanged on exit.
*
*  BLOCK   (global input) LOGICAL
*          If .TRUE., then apply several reflectors at once and read
*             their data from the VECS array.
*          If .FALSE., apply the single reflector given by V2, V3,
*             T1, T2, and T3.
*
*  IROW1   (local input/output) INTEGER
*          On entry, the local row element of A.
*          Undefined on output.
*
*
*  ICOL1   (local input/output) INTEGER
*          On entry, the local column element of A.
*          Undefined on output.
*
*  ISTART  (global input) INTEGER
*          Specifies the "number" of the first reflector.  This is
*              used as an index into VECS if BLOCK is set.
*              ISTART is ignored if BLOCK is .FALSE..
*
*  ISTOP   (global input) INTEGER
*          Specifies the "number" of the last reflector.  This is
*              used as an index into VECS if BLOCK is set.
*              ISTOP is ignored if BLOCK is .FALSE..
*
*  ITMP1   (local input) INTEGER
*          Starting range into A.  For rows, this is the local
*              first column.  For columns, this is the local first row.
*
*  ITMP2   (local input) INTEGER
*          Ending range into A.  For rows, this is the local last
*              column.  For columns, this is the local last row.
*
*  LILOZ
*  LIHIZ   (local input) INTEGER
*          These serve the same purpose as ITMP1,ITMP2 but for Z
*              when WANTZ is set.
*
*  VECS    (global input) COMPLEX array of size 3*N (matrix size)
*          This holds the size 3 reflectors one after another and this
*              is only accessed when BLOCK is .TRUE.
*
*  V2
*  V3
*  T1
*  T2
*  T3      (global input/output) COMPLEX
*          This holds information on a single size 3 Householder
*              reflector and is read when BLOCK is .FALSE., and
*              overwritten when BLOCK is .TRUE.
*
*  Further Details
*  ===============
*
*  Implemented by:  M. Fahey, May 28, 1999
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            J, K
      COMPLEX            A1, A11, A2, A22, A3, A4, A5, B1, B2, B3, B4,
     $                   B5, H11, H22, SUM, SUM1, SUM2, SUM3, T12, T13,
     $                   T22, T23, T32, T33, TMP1, TMP2, TMP3, V22, V23,
     $                   V32, V33
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MOD
*     ..
*     .. Executable Statements ..
*
      IF( LSAME( TYPE, 'R' ) ) THEN
         IF( BLOCK ) THEN
            DO 30 K = ISTART, ISTOP - MOD( ISTOP-ISTART+1, 3 ), 3
               V2 = VECS( ( K-1 )*3+1 )
               V3 = VECS( ( K-1 )*3+2 )
               T1 = VECS( ( K-1 )*3+3 )
               V22 = VECS( ( K-1 )*3+4 )
               V32 = VECS( ( K-1 )*3+5 )
               T12 = VECS( ( K-1 )*3+6 )
               V23 = VECS( ( K-1 )*3+7 )
               V33 = VECS( ( K-1 )*3+8 )
               T13 = VECS( ( K-1 )*3+9 )
               T2 = T1*V2
               T3 = T1*V3
               T22 = T12*V22
               T32 = T12*V32
               T23 = T13*V23
               T33 = T13*V33
               DO 10 J = ITMP1, ITMP2 - MOD( ITMP2-ITMP1+1, 2 ), 2
                  A1 = A( IROW1, J )
                  A2 = A( IROW1+1, J )
                  A3 = A( IROW1+2, J )
                  A4 = A( IROW1+3, J )
                  A5 = A( IROW1+4, J )
                  B1 = A( IROW1, J+1 )
                  B2 = A( IROW1+1, J+1 )
                  B3 = A( IROW1+2, J+1 )
                  B4 = A( IROW1+3, J+1 )
                  B5 = A( IROW1+4, J+1 )
                  SUM1 = CONJG( T1 )*A1 + CONJG( T2 )*A2 +
     $                   CONJG( T3 )*A3
                  A( IROW1, J ) = A1 - SUM1
                  H11 = A2 - SUM1*V2
                  H22 = A3 - SUM1*V3
                  TMP1 = CONJG( T1 )*B1 + CONJG( T2 )*B2 +
     $                   CONJG( T3 )*B3
                  A( IROW1, J+1 ) = B1 - TMP1
                  A11 = B2 - TMP1*V2
                  A22 = B3 - TMP1*V3
                  SUM2 = CONJG( T12 )*H11 + CONJG( T22 )*H22 +
     $                   CONJG( T32 )*A4
                  A( IROW1+1, J ) = H11 - SUM2
                  H11 = H22 - SUM2*V22
                  H22 = A4 - SUM2*V32
                  TMP2 = CONJG( T12 )*A11 + CONJG( T22 )*A22 +
     $                   CONJG( T32 )*B4
                  A( IROW1+1, J+1 ) = A11 - TMP2
                  A11 = A22 - TMP2*V22
                  A22 = B4 - TMP2*V32
                  SUM3 = CONJG( T13 )*H11 + CONJG( T23 )*H22 +
     $                   CONJG( T33 )*A5
                  A( IROW1+2, J ) = H11 - SUM3
                  A( IROW1+3, J ) = H22 - SUM3*V23
                  A( IROW1+4, J ) = A5 - SUM3*V33
                  TMP3 = CONJG( T13 )*A11 + CONJG( T23 )*A22 +
     $                   CONJG( T33 )*B5
                  A( IROW1+2, J+1 ) = A11 - TMP3
                  A( IROW1+3, J+1 ) = A22 - TMP3*V23
                  A( IROW1+4, J+1 ) = B5 - TMP3*V33
   10          CONTINUE
               DO 20 J = ITMP2 - MOD( ITMP2-ITMP1+1, 2 ) + 1, ITMP2
                  SUM = CONJG( T1 )*A( IROW1, J ) +
     $                  CONJG( T2 )*A( IROW1+1, J ) +
     $                  CONJG( T3 )*A( IROW1+2, J )
                  A( IROW1, J ) = A( IROW1, J ) - SUM
                  H11 = A( IROW1+1, J ) - SUM*V2
                  H22 = A( IROW1+2, J ) - SUM*V3
                  SUM = CONJG( T12 )*H11 + CONJG( T22 )*H22 +
     $                  CONJG( T32 )*A( IROW1+3, J )
                  A( IROW1+1, J ) = H11 - SUM
                  H11 = H22 - SUM*V22
                  H22 = A( IROW1+3, J ) - SUM*V32
                  SUM = CONJG( T13 )*H11 + CONJG( T23 )*H22 +
     $                  CONJG( T33 )*A( IROW1+4, J )
                  A( IROW1+2, J ) = H11 - SUM
                  A( IROW1+3, J ) = H22 - SUM*V23
                  A( IROW1+4, J ) = A( IROW1+4, J ) - SUM*V33
   20          CONTINUE
               IROW1 = IROW1 + 3
   30       CONTINUE
            DO 50 K = ISTOP - MOD( ISTOP-ISTART+1, 3 ) + 1, ISTOP
               V2 = VECS( ( K-1 )*3+1 )
               V3 = VECS( ( K-1 )*3+2 )
               T1 = VECS( ( K-1 )*3+3 )
               T2 = T1*V2
               T3 = T1*V3
               DO 40 J = ITMP1, ITMP2
                  SUM = CONJG( T1 )*A( IROW1, J ) +
     $                  CONJG( T2 )*A( IROW1+1, J ) +
     $                  CONJG( T3 )*A( IROW1+2, J )
                  A( IROW1, J ) = A( IROW1, J ) - SUM
                  A( IROW1+1, J ) = A( IROW1+1, J ) - SUM*V2
                  A( IROW1+2, J ) = A( IROW1+2, J ) - SUM*V3
   40          CONTINUE
               IROW1 = IROW1 + 1
   50       CONTINUE
         ELSE
            DO 60 J = ITMP1, ITMP2
               SUM = CONJG( T1 )*A( IROW1, J ) +
     $               CONJG( T2 )*A( IROW1+1, J ) +
     $               CONJG( T3 )*A( IROW1+2, J )
               A( IROW1, J ) = A( IROW1, J ) - SUM
               A( IROW1+1, J ) = A( IROW1+1, J ) - SUM*V2
               A( IROW1+2, J ) = A( IROW1+2, J ) - SUM*V3
   60       CONTINUE
         END IF
      ELSE
*
*        Do column transforms
*
         IF( BLOCK ) THEN
            DO 90 K = ISTART, ISTOP - MOD( ISTOP-ISTART+1, 3 ), 3
               V2 = VECS( ( K-1 )*3+1 )
               V3 = VECS( ( K-1 )*3+2 )
               T1 = VECS( ( K-1 )*3+3 )
               V22 = VECS( ( K-1 )*3+4 )
               V32 = VECS( ( K-1 )*3+5 )
               T12 = VECS( ( K-1 )*3+6 )
               V23 = VECS( ( K-1 )*3+7 )
               V33 = VECS( ( K-1 )*3+8 )
               T13 = VECS( ( K-1 )*3+9 )
               T2 = T1*V2
               T3 = T1*V3
               T22 = T12*V22
               T32 = T12*V32
               T23 = T13*V23
               T33 = T13*V33
               DO 70 J = ITMP1, ITMP2
                  SUM = T1*A( J, ICOL1 ) + T2*A( J, ICOL1+1 ) +
     $                  T3*A( J, ICOL1+2 )
                  A( J, ICOL1 ) = A( J, ICOL1 ) - SUM
                  H11 = A( J, ICOL1+1 ) - SUM*CONJG( V2 )
                  H22 = A( J, ICOL1+2 ) - SUM*CONJG( V3 )
                  SUM = T12*H11 + T22*H22 + T32*A( J, ICOL1+3 )
                  A( J, ICOL1+1 ) = H11 - SUM
                  H11 = H22 - SUM*CONJG( V22 )
                  H22 = A( J, ICOL1+3 ) - SUM*CONJG( V32 )
                  SUM = T13*H11 + T23*H22 + T33*A( J, ICOL1+4 )
                  A( J, ICOL1+2 ) = H11 - SUM
                  A( J, ICOL1+3 ) = H22 - SUM*CONJG( V23 )
                  A( J, ICOL1+4 ) = A( J, ICOL1+4 ) - SUM*CONJG( V33 )
   70          CONTINUE
               IF( WANTZ ) THEN
                  DO 80 J = LILOZ, LIHIZ
                     SUM = T1*Z( J, ICOL1 ) + T2*Z( J, ICOL1+1 ) +
     $                     T3*Z( J, ICOL1+2 )
                     Z( J, ICOL1 ) = Z( J, ICOL1 ) - SUM
                     H11 = Z( J, ICOL1+1 ) - SUM*CONJG( V2 )
                     H22 = Z( J, ICOL1+2 ) - SUM*CONJG( V3 )
                     SUM = T12*H11 + T22*H22 + T32*Z( J, ICOL1+3 )
                     Z( J, ICOL1+1 ) = H11 - SUM
                     H11 = H22 - SUM*CONJG( V22 )
                     H22 = Z( J, ICOL1+3 ) - SUM*CONJG( V32 )
                     SUM = T13*H11 + T23*H22 + T33*Z( J, ICOL1+4 )
                     Z( J, ICOL1+2 ) = H11 - SUM
                     Z( J, ICOL1+3 ) = H22 - SUM*CONJG( V23 )
                     Z( J, ICOL1+4 ) = Z( J, ICOL1+4 ) -
     $                                 SUM*CONJG( V33 )
   80             CONTINUE
               END IF
               ICOL1 = ICOL1 + 3
   90       CONTINUE
            DO 120 K = ISTOP - MOD( ISTOP-ISTART+1, 3 ) + 1, ISTOP
               V2 = VECS( ( K-1 )*3+1 )
               V3 = VECS( ( K-1 )*3+2 )
               T1 = VECS( ( K-1 )*3+3 )
               T2 = T1*V2
               T3 = T1*V3
               DO 100 J = ITMP1, ITMP2
                  SUM = T1*A( J, ICOL1 ) + T2*A( J, ICOL1+1 ) +
     $                  T3*A( J, ICOL1+2 )
                  A( J, ICOL1 ) = A( J, ICOL1 ) - SUM
                  A( J, ICOL1+1 ) = A( J, ICOL1+1 ) - SUM*CONJG( V2 )
                  A( J, ICOL1+2 ) = A( J, ICOL1+2 ) - SUM*CONJG( V3 )
  100          CONTINUE
               IF( WANTZ ) THEN
                  DO 110 J = LILOZ, LIHIZ
                     SUM = T1*Z( J, ICOL1 ) + T2*Z( J, ICOL1+1 ) +
     $                     T3*Z( J, ICOL1+2 )
                     Z( J, ICOL1 ) = Z( J, ICOL1 ) - SUM
                     Z( J, ICOL1+1 ) = Z( J, ICOL1+1 ) -
     $                                 SUM*CONJG( V2 )
                     Z( J, ICOL1+2 ) = Z( J, ICOL1+2 ) -
     $                                 SUM*CONJG( V3 )
  110             CONTINUE
               END IF
               ICOL1 = ICOL1 + 1
  120       CONTINUE
         ELSE
            DO 130 J = ITMP1, ITMP2
               SUM = T1*A( J, ICOL1 ) + T2*A( J, ICOL1+1 ) +
     $               T3*A( J, ICOL1+2 )
               A( J, ICOL1 ) = A( J, ICOL1 ) - SUM
               A( J, ICOL1+1 ) = A( J, ICOL1+1 ) - SUM*CONJG( V2 )
               A( J, ICOL1+2 ) = A( J, ICOL1+2 ) - SUM*CONJG( V3 )
  130       CONTINUE
         END IF
      END IF
      RETURN
*
*     End of CLAREF
*
      END


! =====================================================================
! subroutine WZ
!
! This subroutine constructs the W and Z vectors associated with
! applying the Sherman-Morrison algorithm (as outline within the
! numerical methods chapter of this thesis). It has been modifed for
! imaginary time propagation.
! ---------------------------------------------------------------------
      subroutine WZ(nP,dT,TPO,W,Z)
      implicit none

      integer :: nP
      double precision :: dT
      double precision :: TPO
      double complex :: W(nP)
      double complex :: Z(nP)

      integer :: i

      W(1) = dcmplx(1.0d0,0.0d0)
      Z(1) = dcmplx(0.5d0*dT*TPO,0.0d0)
      do i = 2, nP-1
         W(i) = dcmplx(0.0d0,0.0d0)
         Z(i) = dcmplx(0.0d0,0.0d0)
      enddo
      W(nP) = dcmplx(1.0d0,0.0d0)
      Z(nP) = dcmplx(0.5d0*dT*TPO,0.0d0)

      return
      end
! =====================================================================


C*****************************  ZTZVEC  ********************************
C
C    pvec := Z^T Z vec :       scr=Z vec; pvec = Z^T scr
C
C    la matrice Z^T (triangolare alta) e' memorizzata nel solito
C    formato (CSR)
C    si usa il prodotto per matrici non simmetriche poiche' Z^T
C    e' triangolare alta
C
C***********************************************************************
      subroutine ztzvec(nequ,nterm,ia,ja,ztmat,vec,scr,pvec)
c
      implicit none
      integer nequ,nterm
cxcx  integer ja(nterm),ia(nequ+1)
      integer ja(*),ia(*)
      integer k,m,mm,i
cxcx  real*8  ztmat(nterm),vec(nequ),pvec(nequ)
cxcx  real*8  scr(nequ)
      real*8  ztmat(*),vec(*),pvec(*)
      real*8  scr(*)
c
c   scr=Z x equivale al prodotto della matrice trasposta per un vettore
c
      do k=1,nequ
         scr(k)=0.0d0
         pvec(k)=0.0d0
      end do
      do k=1,nequ
         m=ia(k)
         mm=ia(k+1)-1
         do i=m,mm
            scr(ja(i))=scr(ja(i))+ztmat(i)*vec(k)
         end do
      end do
c
c  y = Z^T scr equivale al prodotto della matrice per un vettore
c
      do k=1,nequ
         m=ia(k)
         mm=ia(k+1)-1
         do i=m,mm
            pvec(k)=pvec(k)+ztmat(i)*scr(ja(i))
         end do
      end do
c
      return
      end


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine preparation
  use global_variables
  implicit none
  integer :: ikr,ikz,ik

  NKrz = NKr*(2*NKz+1)
  NKrz_ave=NKrz/Nprocs; NKrz_remainder=mod(NKrz,Nprocs)
  if (NKrz_remainder == 0) then
    NKrz_s=NKrz_ave*Myrank+1
    NKrz_e=NKrz_ave*(Myrank+1)
  else
    if (Myrank +1 <= NKrz_remainder) then
      NKrz_s=(NKrz_ave+1)*Myrank+1
      NKrz_e=NKrz_s + (NKrz_ave+1)-1 !(NKrz_ave+1)*(Myrank+1)
    else
      NKrz_s=(NKrz_ave+1)*NKrz_remainder + NKrz_ave*(Myrank-NKrz_remainder)+1
      NKrz_e=NKrz_s + NKrz_ave-1
    end if
  end if

  if(myrank==0)then
    write(*,"(A,2x,I7)")"NKrz=",NKrz
    write(*,"(A,2x,I7)")"NKrz_ave",NKrz_ave
    write(*,"(A,2x,I7)")"NKrz_remainder",NKrz_remainder
  end if
!  write(*,"(9I9)")myrank,NKrz_s,NKrz_e

  allocate(zCt(3,1,NKrz_s:NKrz_e),eps(3,NKrz_s:NKrz_e))
  allocate(kz0(-NKz:NKz),kz(-NKz:NKz),kr(NKr))
  allocate(ikr_table(NKrz),ikz_table(NKrz))
  zCt = 0d0; zCt(1,1,:) = 1d0
  eps = 0d0

! table
  ik = 0
  do ikr = 1,NKr
    do ikz = -NKz,NKz
      ik = ik + 1
      ikr_table(ik) = ikr
      ikz_table(ik) = ikz
    end do
  end do

  dkr = kr_max/dble(NKr)
  dkz = kz_max/dble(NKz)

  do ikz = -NKz,NKz
    kz0(ikz) = dkz*dble(ikz)
  end do
  kz = kz0

  do ikr = 1,NKr
    kr(ikr) = dkr*dble(ikr)
  end do

  do ik = NKrz_s,NKrz_e
    ikr = ikr_table(ik)
    ikz = ikz_table(ik)
    kz(ikz) = kz0(ikz)
    eps(1,ik) = eps_d
    eps(2,ik) = eps_c1 +0.5d0/mass_c1*(kr(ikr)**2+kz(ikz)**2)
    eps(3,ik) = eps_c2 +0.5d0/mass_c2*(kr(ikr)**2+kz(ikz)**2)
  end do

end subroutine preparation


      subroutine runCP_iii(k,i1,i2,i3,f,Gr,Shat4,N0)
      implicit none
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,i1,i2,i3,np
      parameter(np=2)
      double precision f(np),Gr(np,np)
      double complex Shat4(np,z3max,-2:0)

      do ep=-2,0
      Cv(ciii(z3(i1,i2,i3))+N0,ep)=
     . (Shat4(k,z3(i1,i2,i3),ep)
     . -2d0*delta(k,i1)*Cv(czzii(z2(i2,i3))+N0,ep)
     . -2d0*delta(k,i2)*Cv(czzii(z2(i1,i3))+N0,ep)
     . -2d0*delta(k,i3)*Cv(czzii(z2(i1,i2))+N0,ep)
     . -Gr(k,1)*Cv(ciiii(z4(1,i1,i2,i3))+N0,ep)
     . -Gr(k,2)*Cv(ciiii(z4(2,i1,i2,i3))+N0,ep))/f(k)
      enddo

      return
      end


!WRF:MODEL_LAYER:PHYSICS
!
MODULE module_sf_slab

   !---SPECIFY CONSTANTS AND LAYERS FOR SOIL MODEL
   !---SOIL DIFFUSION CONSTANT SET (M^2/S)

   REAL, PARAMETER :: DIFSL=5.e-7

   !---FACTOR TO MAKE SOIL STEP MORE CONSERVATIVE

   REAL , PARAMETER :: SOILFAC=1.25

CONTAINS

!----------------------------------------------------------------
   SUBROUTINE SLAB(T3D,QV3D,P3D,FLHC,FLQC,                      &
                   PSFC,XLAND,TMN,HFX,QFX,LH,TSK,QSFC,CHKLOWQ,  &
                   GSW,GLW,CAPG,THC,SNOWC,EMISS,MAVAIL,         &
                   DELTSM,ROVCP,XLV,lv1,lv2,DTMIN,IFSNOW,       &
                   SVP1,SVP2,SVP3,SVPT0,EP2,                    &
                   KARMAN,EOMEG,STBOLT,                         &
                   TSLB,ZS,DZS,num_soil_layers,radiation,       &
                   P1000mb,                                     &
                   ids,ide, jds,jde, kds,kde,                   &
                   ims,ime, jms,jme, kms,kme,                   &
                   its,ite, jts,jte, kts,kte                    )
!----------------------------------------------------------------
    IMPLICIT NONE
!----------------------------------------------------------------
!
!     SUBROUTINE SLAB CALCULATES THE GROUND TEMPERATURE TENDENCY
!     ACCORDING TO THE RESIDUAL OF THE SURFACE ENERGY BUDGET
!     (BLACKADAR, 1978B).
!
!     CHANGES:
!          FOR SOIL SUB-TIMESTEPS UPDATE SURFACE HFX AND QFX AS TG
!          CHANGES TO PREVENT POSSIBLE INSTABILITY FOR LONG MODEL
!          STEPS (DT > ~200 SEC).
!
!          PUT SNOW COVER CHECK ON SOIL SUB-TIMESTEPS
!
!          MAKE UPPER LIMIT ON SOIL SUB-STEP LENGTH MORE CONSERVATIVE
!
!----------------------------------------------------------------
!-- T3D         temperature (K)
!-- QV3D        3D water vapor mixing ratio (Kg/Kg)
!-- P3D         3D pressure (Pa)
!-- FLHC        exchange coefficient for heat (m/s)
!-- FLQC        exchange coefficient for moisture (m/s)
!-- PSFC        surface pressure (Pa)
!-- XLAND       land mask (1 for land, 2 for water)
!-- TMN         soil temperature at lower boundary (K)
!-- HFX         upward heat flux at the surface (W/m^2)
!-- QFX         upward moisture flux at the surface (kg/m^2/s)
!-- LH          latent heat flux at the surface (W/m^2)
!-- TSK         surface temperature (K)
!-- GSW         downward short wave flux at ground surface (W/m^2)
!-- GLW         downward long wave flux at ground surface (W/m^2)
!-- CAPG        heat capacity for soil (J/K/m^3)
!-- THC         thermal inertia (Cal/cm/K/s^0.5)
!-- SNOWC       flag indicating snow coverage (1 for snow cover)
!-- EMISS       surface emissivity (between 0 and 1)
!-- DELTSM      time step (second)
!-- ROVCP       R/CP
!-- XLV         latent heat of melting (J/kg)
!-- DTMIN       time step (minute)
!-- IFSNOW      ifsnow=1 for snow-cover effects
!-- SVP1        constant for saturation vapor pressure (kPa)
!-- SVP2        constant for saturation vapor pressure (dimensionless)
!-- SVP3        constant for saturation vapor pressure (K)
!-- SVPT0       constant for saturation vapor pressure (K)
!-- EP1         constant for virtual temperature (R_v/R_d - 1) (dimensionless)
!-- EP2         constant for specific humidity calculation
!               (R_d/R_v) (dimensionless)
!-- KARMAN      Von Karman constant
!-- EOMEG       angular velocity of earth's rotation (rad/s)
!-- STBOLT      Stefan-Boltzmann constant (W/m^2/K^4)
!-- TSLB        soil temperature in 5-layer model
!-- ZS          depths of centers of soil layers
!-- DZS         thicknesses of soil layers
!-- num_soil_layers   the number of soil layers
!-- ids         start index for i in domain
!-- ide         end index for i in domain
!-- jds         start index for j in domain
!-- jde         end index for j in domain
!-- kds         start index for k in domain
!-- kde         end index for k in domain
!-- ims         start index for i in memory
!-- ime         end index for i in memory
!-- jms         start index for j in memory
!-- jme         end index for j in memory
!-- kms         start index for k in memory
!-- kme         end index for k in memory
!-- its         start index for i in tile
!-- ite         end index for i in tile
!-- jts         start index for j in tile
!-- jte         end index for j in tile
!-- kts         start index for k in tile
!-- kte         end index for k in tile
!----------------------------------------------------------------
   INTEGER,  INTENT(IN   )   ::     ids,ide, jds,jde, kds,kde,  &
                                    ims,ime, jms,jme, kms,kme,  &
                                    its,ite, jts,jte, kts,kte

   INTEGER, INTENT(IN)       ::     num_soil_layers
   LOGICAL, INTENT(IN)       ::     radiation

   INTEGER,  INTENT(IN   )   ::     IFSNOW

!
   REAL,     INTENT(IN   )   ::     DTMIN,XLV,lv1,lv2,ROVCP,DELTSM

   REAL,     INTENT(IN )     ::     SVP1,SVP2,SVP3,SVPT0
   REAL,     INTENT(IN )     ::     EP2,KARMAN,EOMEG,STBOLT
   REAL,     INTENT(IN )     ::     P1000mb

   REAL,     DIMENSION( ims:ime , jms:jme , 1:num_soil_layers ), &
             INTENT(INOUT)   :: TSLB

   REAL,     DIMENSION(1:num_soil_layers), INTENT(IN)::ZS,DZS

   REAL,    DIMENSION( ims:ime, jms:jme, kms:kme )            , &
            INTENT(IN   )    ::                           QV3D, &
                                                           P3D, &
                                                           T3D
!
   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
            INTENT(IN   )    ::                          SNOWC, &
                                                         XLAND, &
                                                         EMISS, &
                                                        MAVAIL, &
                                                           TMN, &
                                                           GSW, &
                                                           GLW, &
                                                           THC

!CHKLOWQ is declared as memory size
!
   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
            INTENT(INOUT)    ::                            HFX, &
                                                           QFX, &
                                                            LH, &
                                                          CAPG, &
                                                           TSK, &
                                                          QSFC, &
                                                       CHKLOWQ

   REAL,     DIMENSION( ims:ime, jms:jme )                    , &
             INTENT(IN   )               ::               PSFC
!
   REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) ::     &
                                                          FLHC, &
                                                          FLQC

! LOCAL VARS

   REAL,     DIMENSION( its:ite ) ::                      QV1D, &
                                                           P1D, &
                                                           T1D
   REAL,     DIMENSION( its:ite , 1:num_soil_layers ) :: TSLB2D
   INTEGER ::  I,J,n

!$omp parallel do default(shared)   &
!$omp private(i,j,n,t1d,qv1d,p1d,tslb2d)
   DO J=jts,jte

      DO i=its,ite
         T1D(i) =T3D(i,j,1)
         QV1D(i)=QV3D(i,j,1)
         P1D(i) =P3D(i,j,1)
      ENDDO

      DO n=1,num_soil_layers
      DO i=its,ite
         TSLB2D(i,n) = TSLB(i,j,n)
      ENDDO
      ENDDO

! the indices to the PSFC argument in the following call look
! wrong; however, it is correct to call with its (and not ims)
! because of the way PSFC is defined in SLAB1D. Whether *that*
! is a good idea or not, this commenter cannot comment. JM

      CALL SLAB1D(J,T1D,QV1D,P1D,FLHC(ims,j),FLQC(ims,j),       &
           PSFC(ims,j),XLAND(ims,j),TMN(ims,j),HFX(ims,j),      &
           QFX(ims,j),TSK(ims,j),QSFC(ims,j),CHKLOWQ(ims,j),    &
           LH(ims,j),GSW(ims,j),GLW(ims,j),                     &
           CAPG(ims,j),THC(ims,j),SNOWC(ims,j),EMISS(ims,j),    &
           MAVAIL(ims,j),DELTSM,ROVCP,XLV,lv1,lv2,DTMIN,IFSNOW, &
           SVP1,SVP2,SVP3,SVPT0,EP2,KARMAN,EOMEG,STBOLT,        &
           TSLB2D       ,ZS,DZS,num_soil_layers,radiation,      &
           P1000mb,                                             &
           ids,ide, jds,jde, kds,kde,                           &
           ims,ime, jms,jme, kms,kme,                           &
           its,ite, jts,jte, kts,kte                            )

      DO n=1,num_soil_layers
      DO i=its,ite
         TSLB(i,j,n) = TSLB2D(i,n)
      ENDDO
      ENDDO

   ENDDO

   END SUBROUTINE SLAB

!----------------------------------------------------------------
   SUBROUTINE SLAB1D(J,T1D,QV1D,P1D,FLHC,FLQC,                  &
                   PSFCPA,XLAND,TMN,HFX,QFX,TSK,QSFC,CHKLOWQ,   &
                   LH,GSW,GLW,CAPG,THC,SNOWC,EMISS,MAVAIL,      &
                   DELTSM,ROVCP,XLV,lv1,lv2,DTMIN,IFSNOW,       &
                   SVP1,SVP2,SVP3,SVPT0,EP2,                    &
                   KARMAN,EOMEG,STBOLT,                         &
                   TSLB2D,ZS,DZS,num_soil_layers,radiation,     &
                   P1000mb,                                     &
                   ids,ide, jds,jde, kds,kde,                   &
                   ims,ime, jms,jme, kms,kme,                   &
                   its,ite, jts,jte, kts,kte                    )
!----------------------------------------------------------------
    IMPLICIT NONE
!----------------------------------------------------------------
!
!     SUBROUTINE SLAB CALCULATES THE GROUND TEMPERATURE TENDENCY
!     ACCORDING TO THE RESIDUAL OF THE SURFACE ENERGY BUDGET
!     (BLACKADAR, 1978B).
!
!     CHANGES:
!          FOR SOIL SUB-TIMESTEPS UPDATE SURFACE HFX AND QFX AS TG
!          CHANGES TO PREVENT POSSIBLE INSTABILITY FOR LONG MODEL
!          STEPS (DT > ~200 SEC).
!
!          PUT SNOW COVER CHECK ON SOIL SUB-TIMESTEPS
!
!          MAKE UPPER LIMIT ON SOIL SUB-STEP LENGTH MORE CONSERVATIVE
!
!----------------------------------------------------------------

   INTEGER,  INTENT(IN   )   ::     ids,ide, jds,jde, kds,kde,  &
                                    ims,ime, jms,jme, kms,kme,  &
                                    its,ite, jts,jte, kts,kte,J

   INTEGER , INTENT(IN)      ::     num_soil_layers
   LOGICAL,  INTENT(IN   )   ::     radiation

   INTEGER,  INTENT(IN   )   ::     IFSNOW
!
   REAL,     INTENT(IN   )   ::     DTMIN,XLV,lv1,lv2,ROVCP,DELTSM

   REAL,     INTENT(IN )     ::     SVP1,SVP2,SVP3,SVPT0
   REAL,     INTENT(IN )     ::     EP2,KARMAN,EOMEG,STBOLT
   REAL,     INTENT(IN )     ::     P1000mb

   REAL,     DIMENSION( its:ite , 1:num_soil_layers ),          &
             INTENT(INOUT)   :: TSLB2D

   REAL,     DIMENSION(1:num_soil_layers), INTENT(IN)::ZS,DZS

!
   REAL,    DIMENSION( ims:ime )                              , &
            INTENT(INOUT)    ::                            HFX, &
                                                           QFX, &
                                                            LH, &
                                                          CAPG, &
                                                           TSK, &
                                                          QSFC, &
                                                       CHKLOWQ
!
   REAL,    DIMENSION( ims:ime )                              , &
            INTENT(IN   )    ::                          SNOWC, &
                                                         XLAND, &
                                                         EMISS, &
                                                        MAVAIL, &
                                                           TMN, &
                                                           GSW, &
                                                           GLW, &
                                                           THC
!
   REAL,    DIMENSION( its:ite )                              , &
            INTENT(IN   )    ::                           QV1D, &
                                                           P1D, &
                                                           T1D
!
   REAL,     DIMENSION( ims:ime )                             , &
             INTENT(IN   )               ::             PSFCPA

!
   REAL,    DIMENSION( ims:ime ), INTENT(INOUT) ::              &
                                                          FLHC, &
                                                          FLQC
! LOCAL VARS

   REAL,    DIMENSION( its:ite )          ::              PSFC

   REAL,    DIMENSION( its:ite )          ::                    &
                                                           THX, &
                                                            QX, &
                                                          SCR3

   REAL,    DIMENSION( its:ite )          ::            DTHGDT, &
                                                           TG0, &
                                                         THTMN, &
                                                          XLD1, &
                                                         TSCVN, &
                                                          OLTG, &
                                                        UPFLUX, &
                                                            HM, &
                                                          RNET, &
                                                         XINET, &
                                                            QS, &
                                                         DTSDT
!
   REAL, DIMENSION( its:ite, num_soil_layers )        :: FLUX
!
   INTEGER :: I,K,NSOIL,ITSOIL,L,NK,RADSWTCH
   REAL    :: PS,PS1,XLDCOL,TSKX,RNSOIL,RHOG1,RHOG2,RHOG3,LAMDAG
   REAL    :: THG,ESG,QSG,HFXT,QFXT,CS,CSW,LAMG(4),THCON,PL

!----------------------------------------------------------------------
!-----DETERMINE IF ANY POINTS IN COLUMN ARE LAND (RATHER THAN OCEAN)
!       POINTS.  IF NOT, SKIP DOWN TO THE PRINT STATEMENTS SINCE OCEAN
!       SURFACE TEMPERATURES ARE NOT ALLOWED TO CHANGE.
!
! from sfcrad
!----------------------------------------------------------------------
   DATA CSW/4.183E6/
   DATA LAMG/1.407E-8, -1.455E-5, 6.290E-3, 0.16857/

   DO i=its,ite
! in cmb
      PSFC(I)=PSFCPA(I)/1000.
   ENDDO

      DO I=its,ite
! PL cmb
         PL=P1D(I)/1000.
         SCR3(I)=T1D(I)
!         THCON=(100./PL)**ROVCP
         THCON=(P1000mb*0.001/PL)**ROVCP
         THX(I)=SCR3(I)*THCON
         QX(I)=0.
      ENDDO

!     IF(IDRY.EQ.1) GOTO 81
      DO I=its,ite
         QX(I)=QV1D(I)
      ENDDO
   81 CONTINUE

!
!-----THE SLAB THERMAL CAPACITY CAPG(I) ARE DEPENDENT ON:
!     THC(I) - SOIL THERMAL INERTIAL, ONLY.
!
      DO I=its,ite
         CAPG(I)=3.298E6*THC(I)
         IF(num_soil_layers .gt. 1)THEN

! CAPG REPRESENTS SOIL HEAT CAPACITY (J/K/M^3) WHEN DIFSL=5.E-7 (M^2/S)
! TO GIVE A CORRECT THERMAL INERTIA (=CAPG*DIFSL^0.5)

            CAPG(I)=5.9114E7*THC(I)
         ENDIF
      ENDDO
!
      XLDCOL=2.0
      DO 10 I=its,ite
        XLDCOL=AMIN1(XLDCOL,XLAND(I))
   10 CONTINUE
!
      IF(XLDCOL.GT.1.5)GOTO 90
!
!
!-----CONVERT SLAB TEMPERATURE TO POTENTIAL TEMPERATURE AND
!     SET XLD1(I) = 0. FOR OCEAN POINTS:
!
!
      DO 20 I=its,ite
        IF((XLAND(I)-1.5).GE.0)THEN
          XLD1(I)=0.
        ELSE
          XLD1(I)=1.
        ENDIF
   20 CONTINUE
!
!-----CONVERT 'TSK(THETAG)' TO 'TG' FOR 'IUP' CALCULATION ....
!       IF WE ARE USING THE BLACKADAR MULTI-LEVEL (HIGH-RESOLUTION)
!       PBL MODEL
!
      DO 50 I=its,ite
        IF(XLD1(I).LT.0.5)GOTO 50

! PS cmb
        PS=PSFC(I)

! TSK is Temperature at gound sfc
!       TG0(I)=TSK(I)*(PS*0.01)**ROVCP
        TG0(I)=TSK(I)
   50 CONTINUE
!
!-----COMPUTE THE SURFACE ENERGY BUDGET:
!
!     IF(ISOIL.EQ.1)NSOIL=1
      IF(num_soil_layers .gt. 1)NSOIL=1

      IF (radiation) then
        RADSWTCH=1
      ELSE
        RADSWTCH=0
      ENDIF

      DO 70 I=its,ite
        IF(XLD1(I).LT.0.5)GOTO 70
!        OLTG(I)=TSK(I)*(100./PSFC(I))**ROVCP
        OLTG(I)=TSK(I)*(P1000mb*0.001/PSFC(I))**ROVCP
        UPFLUX(I)=RADSWTCH*STBOLT*TG0(I)**4
        XINET(I)=EMISS(I)*(GLW(I)-UPFLUX(I))
        RNET(I)=GSW(I)+XINET(I)
        HM(I)=1.18*EOMEG*(TG0(I)-TMN(I))
!       MOISTURE FLUX CALCULATED HERE (OVERWRITES SFC LAYER VALUE FOR LAND)
                ESG=SVP1*EXP(SVP2*(TG0(I)-SVPT0)/(TG0(I)-SVP3))
                QSG=EP2*ESG/(PSFC(I)-ESG)
                THG=TSK(I)*(100./PSFC(I))**ROVCP
                HFX(I)=FLHC(I)*(THG-THX(I))
                QFX(I)=FLQC(I)*(QSG-QX(I))
                LH(I)=QFX(I)*( lv1-lv2*tsk(I) )
        QS(I)=HFX(I)+QFX(I)*( lv1-lv2*tsk(I) )
!       IF(ISOIL.EQ.0)THEN
        IF(num_soil_layers .EQ. 1)THEN
          DTHGDT(I)=(RNET(I)-QS(I))/CAPG(I)-HM(I)
        ELSE
          DTHGDT(I)=0.
        ENDIF
   70 CONTINUE
!     IF(ISOIL.EQ.1)THEN
      IF(num_soil_layers .gt. 1)THEN
        NSOIL=1+IFIX(SOILFAC*4*DIFSL/DZS(1)*DELTSM/DZS(1))
        RNSOIL=1./FLOAT(NSOIL)
!
!     SOIL SUB-TIMESTEP
!
        DO ITSOIL=1,NSOIL
          DO I=its,ite
             DO L=1,num_soil_layers-1
              IF(XLD1(I).LT.0.5)GOTO 75
              IF(L.EQ.1.AND.ITSOIL.GT.1)THEN
!                PS1=(PSFC(I)*0.01)**ROVCP
                PS1=(PSFCPA(I)/P1000mb)**ROVCP

! for rk scheme A and B are the same
                PS=PSFC(I)
                THG=TSLB2D(I,1)/PS1
                ESG=SVP1*EXP(SVP2*(TSLB2D(I,1)-SVPT0)/(TSLB2D(I,1) &
                    -SVP3))
                QSG=EP2*ESG/(PS-ESG)
!     UPDATE FLUXES FOR NEW GROUND TEMPERATURE
                HFXT=FLHC(I)*(THG-THX(I))
                QFXT=FLQC(I)*(QSG-QX(I))
                QS(I)=HFXT+QFXT*( lv1-lv2*tsk(I) )
!     SUM HFX AND QFX OVER SOIL TIMESTEPS
                HFX(I)=HFX(I)+HFXT
                QFX(I)=QFX(I)+QFXT
              ENDIF
              FLUX(I,1)=RNET(I)-QS(I)
              FLUX(I,L+1)=-DIFSL*CAPG(I)*(TSLB2D(I,L+1)-TSLB2D(I,L))/( &
                          ZS(L+1)-ZS(L))
              DTSDT(I)=-(FLUX(I,L+1)-FLUX(I,L))/(DZS(L)*CAPG(I))
              TSLB2D(I,L)=TSLB2D(I,L)+DTSDT(I)*DELTSM*RNSOIL
              IF(IFSNOW.EQ.1.AND.L.EQ.1)THEN
                IF((SNOWC(I).GT.0..AND.TSLB2D(I,1).GT.273.16))THEN
                  TSLB2D(I,1)=273.16
                ENDIF
              ENDIF
              IF(L.EQ.1)DTHGDT(I)=DTHGDT(I)+RNSOIL*DTSDT(I)
              IF(ITSOIL.EQ.NSOIL.AND.L.EQ.1)THEN
!     AVERAGE HFX AND QFX OVER SOIL TIMESTEPS FOR OUTPUT TO PBL
                HFX(I)=HFX(I)*RNSOIL
                QFX(I)=QFX(I)*RNSOIL
                LH(I)=QFX(I)*( lv1-lv2*tsk(I) )
              ENDIF
   75         CONTINUE
            ENDDO
          ENDDO
        ENDDO
      ENDIF
!
      DO 80 I=its,ite
        IF(XLD1(I).LT.0.5) GOTO 80
        TSKX=TG0(I)+DELTSM*DTHGDT(I)

! TSK is temperature
!       TSK(I)=TSKX*(100./PS1)**ROVCP
        TSK(I)=TSKX
   80 CONTINUE

!
!-----MODIFY THE THE GROUND TEMPERATURE IF THE SNOW COVER EFFECTS ARE
!     CONSIDERED: LIMIT THE GROUND TEMPERATURE UNDER 0 C.
!
      IF(IFSNOW.EQ.0)GOTO 90
      DO 85 I=its,ite
        IF(XLD1(I).LT.0.5)GOTO 85
!       PS1=(PSFC(I)*0.01)**ROVCP
!       TSCVN(I)=TSK(I)*PS1
        TSCVN(I)=TSK(I)
        IF((SNOWC(I).GT.0..AND.TSCVN(I).GT.273.16))THEN
          TSCVN(I)=273.16
        ELSE
          TSCVN(I)=TSCVN(I)
        ENDIF
!       TSK(I)=TSCVN(I)/PS1
        TSK(I)=TSCVN(I)
   85 CONTINUE
!
   90 CONTINUE
      DO I=its,ite
! QSFC and CHKLOWQ needed by Eta PBL
! WA added check for flqc = 0 to accomodate TEMF (and others?)
        if ( FLQC(I) .ne. 0.) then
           QSFC(I)=QX(I)+QFX(I)/FLQC(I)
        else
           QSFC(I) = QX(I)
        end if
        CHKLOWQ(I)=MAVAIL(I)
      ENDDO
!
  140 CONTINUE

   END SUBROUTINE SLAB1D

!================================================================
   SUBROUTINE slabinit(TSK,TMN,                                 &
                       TSLB,ZS,DZS,num_soil_layers,             &
                       allowed_to_read, start_of_simulation,    &
                       ids,ide, jds,jde, kds,kde,               &
                       ims,ime, jms,jme, kms,kme,               &
                       its,ite, jts,jte, kts,kte                )
!----------------------------------------------------------------
   IMPLICIT NONE
!----------------------------------------------------------------
   LOGICAL , INTENT(IN)      ::      allowed_to_read
   LOGICAL , INTENT(IN)      ::      start_of_simulation
   INTEGER, INTENT(IN   )    ::      ids,ide, jds,jde, kds,kde, &
                                     ims,ime, jms,jme, kms,kme, &
                                     its,ite, jts,jte, kts,kte

   INTEGER, INTENT(IN   )    ::      num_soil_layers
!
   REAL,     DIMENSION( ims:ime , 1:num_soil_layers , jms:jme ), INTENT(INOUT) :: TSLB

   REAL,     DIMENSION(1:num_soil_layers), INTENT(IN)  ::  ZS,DZS

   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
            INTENT(IN)    ::                               TSK, &
                                                           TMN

!  LOCAR VAR

   INTEGER                   ::      L,J,I,itf,jtf
   CHARACTER*1024 message

!----------------------------------------------------------------

   itf=min0(ite,ide-1)
   jtf=min0(jte,jde-1)

   END SUBROUTINE slabinit
!-------------------------------------------------------------------

END MODULE module_sf_slab


      SUBROUTINE JACOBI(NESC)
*
*
*       Jacobi escape criterion.
*       ------------------------
*
      INCLUDE 'common6.h'
*
*
*       Specify escape energy (tidal field or isolated system).
      IF (KZ(14).GT.0.AND.KZ(14).LE.2) THEN
          ECRIT = -1.5*(TIDAL(1)*ZMASS**2)**0.333
      ELSE
          ECRIT = 0.0
      END IF
*       Define current mean square velocity (= 0.5 initially).
      V2M = 0.5*ZMASS/RSCALE
*
*       Count all escapers.
      NESC = 0
      DO 60 I = IFIRST,NTOT
          RI2 = (X(1,I) - RDENS(1))**2 + (X(2,I) - RDENS(2))**2 +
     &                                   (X(3,I) - RDENS(3))**2
          VI2 = XDOT(1,I)**2 + XDOT(2,I)**2 + XDOT(3,I)**2
          IF (RI2.GT.RSCALE**2) THEN
              VC2 = ZMASS/SQRT(RI2) + ECRIT
              IF (VI2.LT.VC2) GO TO 60
          ELSE
*       Skip velocities below sqrt(2) times equilibrium value.
              IF (VI2.LT.2.0*V2M + ECRIT) GO TO 60
          END IF
          POTI = 0.0
          DO 55 J = IFIRST,NTOT
              IF (J.EQ.I) GO TO 55
              RIJ2 = 0.0
              DO 52 K = 1,3
                  RIJ2 = RIJ2 + (X(K,I) - X(K,J))**2
   52         CONTINUE
              POTI = POTI + BODY(J)/SQRT(RIJ2)
   55     CONTINUE
          EI = 0.5*VI2 - POTI
          IF (EI.GT.ECRIT) NESC = NESC + 1
   60 CONTINUE
*
      RETURN
*
      END