      SUBROUTINE MB01KD( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA,
     $                   C, LDC, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To perform one of the skew-symmetric rank 2k operations
C
C         C := alpha*A*B' - alpha*B*A' + beta*C,
C
C     or
C
C         C := alpha*A'*B - alpha*B'*A + beta*C,
C
C     where alpha and beta are scalars, C is a real N-by-N skew-
C     symmetric matrix and A, B are N-by-K matrices in the first case
C     and K-by-N matrices in the second case.
C
C     This is a modified version of the vanilla implemented BLAS
C     routine DSYR2K written by Jack Dongarra, Iain Duff,
C     Jeremy Du Croz and Sven Hammarling.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies whether the upper or lower triangular part of
C             the array C is to be referenced, as follows:
C             = 'U':  only the strictly upper triangular part of C is to
C                     be referenced;
C             = 'L':  only the striclty lower triangular part of C is to
C                     be referenced.
C
C     TRANS   CHARACTER*1
C             Specifies the operation to be performed, as follows:
C             = 'N':         C := alpha*A*B' - alpha*B*A' + beta*C;
C             = 'T' or 'C':  C := alpha*A'*B - alpha*B'*A + beta*C.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix C.  N >= 0.
C
C     K       (input) INTEGER
C             If TRANS = 'N' the number of columns of A and B; and if
C             TRANS = 'T' or TRANS = 'C' the number of rows of A and B.
C             K >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. If alpha is zero, or N <= 1, or K = 0,
C             A and B are not referenced.
C
C     A       (input)  DOUBLE PRECISION array, dimension (LDA,KA),
C             where KA is K when TRANS = 'N', and is N otherwise.
C             On entry with TRANS = 'N', the leading N-by-K part of
C             of this array must contain the matrix A.
C             On entry with TRANS = 'T' or TRANS = 'C', the leading
C             K-by-N part of this array must contain the matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.
C             LDA >= MAX(1,N),  if TRANS = 'N';
C             LDA >= MAX(1,K),  if TRANS = 'T' or TRANS = 'C'.
C
C     B       (input)  DOUBLE PRECISION array, dimension (LDB,KB),
C             where KB is K when TRANS = 'N', and is N otherwise.
C             On entry with TRANS = 'N', the leading N-by-K part of
C             of this array must contain the matrix B.
C             On entry with TRANS = 'T' or TRANS = 'C', the leading
C             K-by-N part of this array must contain the matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= MAX(1,N),  if TRANS = 'N';
C             LDB >= MAX(1,K),  if TRANS = 'T' or TRANS = 'C'.
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. If beta is zero C need not be set before
C             entry.
C
C     C       (input/output)  DOUBLE PRECISION array, dimension (LDC,N)
C             On entry with UPLO = 'U', the leading N-by-N part of this
C             array must contain the strictly upper triangular part of
C             the matrix C. The lower triangular part of this array is
C             not referenced.
C             On entry with UPLO = 'L', the leading N-by-N part of this
C             array must contain the strictly lower triangular part of
C             the matrix C. The upper triangular part of this array is
C             not referenced.
C             On exit with UPLO = 'U', the leading N-by-N part of this
C             array contains the strictly upper triangular part of the
C             updated matrix C.
C             On exit with UPLO = 'L', the leading N-by-N part of this
C             array contains the strictly lower triangular part of the
C             updated matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,N)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     NUMERICAL ASPECTS
C
C     Though being almost identical with the vanilla implementation
C     of the BLAS routine DSYR2K the performance of this routine could
C     be significantly lower in the case of vendor supplied, highly
C     optimized BLAS.
C
C     CONTRIBUTORS
C
C     D. Kressner (Technical Univ. Berlin, Germany) and
C     P. Benner (Technical Univ. Chemnitz, Germany), December 2003.
C
C     REVISIONS
C
C     V. Sima, Jan. 2010 (SLICOT version of the HAPACK routine DSKR2K).
C
C     KEYWORDS
C
C     Elementary matrix operations,
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         UPLO, TRANS
      INTEGER           INFO, K, LDA, LDB, LDC, N
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*)
C     .. Local Scalars ..
      LOGICAL           LUP, LTRAN
      INTEGER           I, J, L
      DOUBLE PRECISION  TEMP1, TEMP2
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      LUP   = LSAME( UPLO,  'U' )
      LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( LUP .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( LTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -3
      ELSE IF ( K.LT.0 ) THEN
         INFO = -4
      ELSE IF ( ( .NOT.LTRAN .AND. LDA.LT.N ) .OR. LDA.LT.1 .OR.
     $          (      LTRAN .AND. LDA.LT.K ) ) THEN
         INFO = -7
      ELSE IF ( ( .NOT.LTRAN .AND. LDB.LT.N ) .OR. LDB.LT.1 .OR.
     $          (      LTRAN .AND. LDB.LT.K ) ) THEN
         INFO = -9
      ELSE IF ( LDC.LT.MAX( 1, N ) ) THEN
         INFO = -12
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB01KD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( ( N.LE.1 ) .OR.
     $   ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
C
C     Special case ALPHA = 0.
C
      IF ( ALPHA.EQ.ZERO ) THEN
         IF ( LUP ) THEN
            IF ( BETA.EQ.ZERO ) THEN
               DO 20  J = 2, N
                  DO 10  I = 1, J-1
                     C(I,J) = ZERO
   10             CONTINUE
   20          CONTINUE
            ELSE
               DO 40  J = 2, N
                  DO 30  I = 1, J-1
                     C(I,J) = BETA * C(I,J)
   30             CONTINUE
   40          CONTINUE
            END IF
         ELSE
            IF( BETA.EQ.ZERO ) THEN
               DO 60  J = 1, N-1
                  DO 50  I = J+1, N
                     C(I,J) = ZERO
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 80  J = 1, N-1
                  DO 70  I = J+1, N
                     C(I,J) = BETA * C(I,J)
   70             CONTINUE
   80          CONTINUE
            END IF
         END IF
         RETURN
      END IF
C
C     Normal case.
C
      IF ( .NOT.LTRAN ) THEN
C
C        Update C := alpha*A*B' - alpha*B*A' + beta*C.
C
         IF ( LUP ) THEN
            DO 130  J = 2, N
               IF ( BETA.EQ.ZERO ) THEN
                  DO 90  I = 1, J-1
                     C(I,J) = ZERO
   90             CONTINUE
               ELSE IF ( BETA.NE.ONE ) THEN
                  DO 100  I = 1, J-1
                     C(I,J) = BETA * C(I,J)
  100             CONTINUE
               END IF
               DO 120  L = 1, K
                  IF ( ( A(J,L).NE.ZERO ) .OR.
     $                 ( B(J,L).NE.ZERO ) ) THEN
                     TEMP1 = ALPHA * B(J,L)
                     TEMP2 = ALPHA * A(J,L)
                     DO 110  I = 1, J-1
                        C(I,J) = C(I,J) + A(I,L)*TEMP1 - B(I,L)*TEMP2
  110                CONTINUE
                  END IF
  120          CONTINUE
  130       CONTINUE
         ELSE
            DO 180  J = 1, N-1
               IF ( BETA.EQ.ZERO ) THEN
                  DO 140  I = J+1, N
                     C(I,J) = ZERO
  140             CONTINUE
               ELSE IF ( BETA.NE.ONE ) THEN
                  DO 150  I = J+1, N
                     C(I,J) = BETA * C(I,J)
  150             CONTINUE
               END IF
               DO 170  L = 1, K
                  IF ( ( A(J,L).NE.ZERO ) .OR.
     $                 ( B(J,L).NE.ZERO ) ) THEN
                     TEMP1 = ALPHA * B(J,L)
                     TEMP2 = ALPHA * A(J,L)
                     DO 160  I = J+1, N
                        C(I,J) = C(I,J) + A(I,L)*TEMP1 - B(I,L)*TEMP2
  160                CONTINUE
                  END IF
  170          CONTINUE
  180       CONTINUE
         END IF
      ELSE
C
C        Update C := alpha*A'*B - alpha*B'*A + beta*C.
C
         IF ( LUP ) THEN
            DO 210  J = 2, N
               DO 200  I = 1, J-1
                  TEMP1 = ZERO
                  TEMP2 = ZERO
                  DO 190  L = 1, K
                     TEMP1 = TEMP1 + A(L,I)*B(L,J)
                     TEMP2 = TEMP2 + B(L,I)*A(L,J)
  190             CONTINUE
                  IF ( BETA.EQ.ZERO ) THEN
                     C(I,J) = ALPHA*TEMP1 - ALPHA*TEMP2
                  ELSE
                     C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 - ALPHA*TEMP2
                  END IF
  200          CONTINUE
  210       CONTINUE
         ELSE
            DO 240  J = 1, N-1
               DO 230  I = J+1, N
                  TEMP1 = ZERO
                  TEMP2 = ZERO
                  DO 220, L = 1, K
                     TEMP1 = TEMP1 + A(L,I)*B(L,J)
                     TEMP2 = TEMP2 + B(L,I)*A(L,J)
  220             CONTINUE
                  IF ( BETA.EQ.ZERO ) THEN
                     C(I,J) = ALPHA*TEMP1 - ALPHA*TEMP2
                  ELSE
                     C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 - ALPHA*TEMP2
                  END IF
  230          CONTINUE
  240       CONTINUE
         END IF
      END IF
      RETURN
C *** Last line of MB01KD ***
      END


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

MODULE KINETIC

    USE CONSTANTS
    USE GAUSSIAN
    USE OVERLAP, only: Si

    IMPLICIT NONE

    CONTAINS

        FUNCTION Ki(ac,a1,a2,bc,b1,b2,aa,bb,Ra,Rb,Ra1,Rb1,Ra2,Rb2,Rc,R1,R2,cp)
            ! ----------------------------------------------------------------------------------------------
            ! Compute kinetic energy between two unnormalized Cartesian Gaussian functions along direction i
            ! ----------------------------------------------------------------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: ac, a1, a2, bc, b1, b2       ! Cartesia Gaussian angular momenta
            REAL*8, intent(in) :: aa, bb                        ! Gaussian exponential coefficients
            REAL*8, intent(in) :: Ra, Rb, Ra1, Rb1, Ra2, Rb2    ! Gaussian centers' coordinates
            REAL*8, intent(in) :: Rc, R1, R2                    ! Gaussian product center coordinates
            REAL*8, intent(in) :: cp                            ! Gaussian product coefficient

            ! INTERMEDIATE VARIABLE
            REAL*8 :: k

            ! OUTPUT
            REAL*8 :: Ki

            k = 0.0D0
            k = k + ac * bc * Si(ac - 1,bc - 1,aa,bb,Ra,Rb,Rc)
            k = k - 2 * aa * bc * Si(ac + 1,bc - 1,aa,bb,Ra,Rb,Rc)
            k = k - 2 * ac * bb * Si(ac - 1,bc + 1,aa,bb,Ra,Rb,Rc)
            k = k + 4 * aa * bb * Si(ac + 1,bc + 1,aa,bb,Ra,Rb,Rc)
            k = k * 0.5D0

            Ki = 1
            Ki = Ki * cp * (PI / (aa + bb))**(3.0D0/2.0D0) * k
            Ki = Ki * Si(a1,b1,aa,bb,Ra1,Rb1,R1)
            Ki = Ki * Si(a2,b2,aa,bb,Ra2,Rb2,R2)

        END FUNCTION Ki

        FUNCTION kinetic_coeff(ax,ay,az,bx,by,bz,aa,bb,Ra,Rb) result(K)
            ! -----------------------------------------------------------------
            ! Compute kinetic integral between two Cartesian Gaussian functions
            ! -----------------------------------------------------------------
            !
            ! Source:
            !   The Mathematica Journal
            !   Evaluation of Gaussian Molecular Integrals
            !   II. Kinetic-Energy Integrals
            !   Minhhuy Hô and Julio Manuel Hernández-Pérez
            !
            ! -----------------------------------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: ax, ay, az, bx, by, bz   ! Angular momentum coefficients
            REAL*8, intent(in) :: aa, bb                    ! Exponential Gaussian coefficients
            REAL*8, dimension(3), intent(in) :: Ra, Rb      ! Gaussian centers

            ! INTERMEDIATE VARIABLE
            REAL*8 :: pp                ! Gaussian produc exponential coefficient
            REAL*8, dimension(3) :: Rp  ! Gaussian produc center
            REAL*8 :: cp                ! Gaussian product multiplicative constant

            ! OUTPUT
            REAL*8 :: K

            CALL gaussian_product(aa,bb,Ra,Rb,pp,Rp,cp) ! Compute PP, RP and CP

            K = 0
            K = K + Ki(ax,ay,az,bx,by,bz,aa,bb,Ra(1),Rb(1),Ra(2),Rb(2),Ra(3),Rb(3),Rp(1),Rp(2),Rp(3),cp)    ! Kx
            K = K + Ki(ay,az,ax,by,bz,bx,aa,bb,Ra(2),Rb(2),Ra(3),Rb(3),Ra(1),Rb(1),Rp(2),Rp(3),Rp(1),cp)    ! Ky
            K = K + Ki(az,ax,ay,bz,bx,by,aa,bb,Ra(3),Rb(3),Ra(1),Rb(1),Ra(2),Rb(2),Rp(3),Rp(1),Rp(2),cp)    ! Kz
            K = K * norm(ax,ay,az,aa) * norm(bx,by,bz,bb)

        END FUNCTION kinetic_coeff

        ! --------------
        ! KINETIC MATRIX
        ! --------------
        SUBROUTINE T_kinetic(Kf,c,basis_D,basis_A,basis_L,basis_R,T)
            ! ----------------------------------------------
            ! Compute kinetic matrix between basis function.
            ! ----------------------------------------------

            IMPLICIT NONE

            ! TODO Allow flexibility for basis sets other than STO-3G
            INTEGER, intent(in) :: c ! Number of contractions per basis function

            ! INPUT
            INTEGER, intent(in) :: Kf                       ! Number of basis functions
            REAL*8, dimension(Kf,3), intent(in) :: basis_R  ! Basis set niclear positions
            INTEGER, dimension(Kf,3), intent(in) :: basis_L ! Basis set angular momenta
            REAL*8, dimension(Kf,3), intent(in) :: basis_D  ! Basis set contraction coefficients
            REAL*8, dimension(Kf,3), intent(in) :: basis_A  ! Basis set exponential contraction coefficients

            ! INTERMEDIATE VARIABLES
            INTEGER :: i,j,k,l
            REAL*8 :: tmp

            ! OUTPUT
            REAL*8, dimension(Kf,Kf), intent(out) :: T

            T(:,:) = 0.0D0

            DO i = 1,Kf
                DO j = 1,Kf
                    DO k = 1,c
                        DO l = 1,c
                            tmp = basis_D(i,k) * basis_D(j,l)
                            tmp = tmp * kinetic_coeff(  basis_L(i,1),&  ! lx for basis function i
                                                        basis_L(i,2),&  ! ly for basis function i
                                                        basis_L(i,3),&  ! lz for basis function i
                                                        basis_L(j,1),&  ! lx for basis function j
                                                        basis_L(j,2),&  ! ly for basis function j
                                                        basis_L(j,3),&  ! lz for basis function j
                                                        basis_A(i,k),&  ! Exponential coefficient for basis function i, contraction k
                                                        basis_A(j,l),&  ! Exponential coefficient for basis function j, contraction l
                                                        basis_R(i,:),&  ! Center of basis function i
                                                        basis_R(j,:))   ! Center of basis function j

                            T(i,j) = T(i,j) + tmp
                        END DO ! l
                    END DO ! k
                END DO ! j
            END DO ! i

        END SUBROUTINE T_kinetic

END MODULE KINETIC


c=======================================================================
c
c     GENNF
c
c     Generate random value of Noncentral F distribution
c
c     Generates a random deviate from the  noncentral F (variance ratio)
c     distribution with DFN degrees of freedom in the numerator, and DFD
c     degrees of freedom in the denominator, and noncentrality parameter
c     XNONC.
c
c-----------------------------------------------------------------------
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION gennf(dfn, dfd, xnonc)
c-----------------------------------------------------------------------
c
c     INPUT :
c      dfn   : numerator degrees of freedom (>=1.0)                 double
c      dfd   : denominator degrees of freedom (>0)                  double
c      xnonc : noncentrality parameter (>0)                         double
c
c     Method
c
c     Directly generates ratio of noncentral numerator chisquare variate
c     to central denominator chisquare variate.
c
c-----------------------------------------------------------------------
c
c      include '../stack.h'
c
c     scalar arguments
      DOUBLE PRECISION dfd, dfn, xnonc
c
c     local scalars
      DOUBLE PRECISION xden, xnum
c
c     external functions
c     changed the code to call GENCHI and GENNCH directly
c      DOUBLE PRECISION genchi, gennch
c      EXTERNAL genchi, gennch
      DOUBLE PRECISION sgamma, snorm
      EXTERNAL sgamma, snorm
c
c     executable statements
c     changed the argument checker to allow DFN = 1.0
c     in the same way as GENNCH was changed.
c      GENNF = ( GENNCH( DFN, XNONC ) / DFN ) / ( GENCHI( DFD ) / DFD )
c     changed this to call SGAMMA and SNORM directly
c     xnum = gennch(dfn,xnonc)/dfn
 10   IF (dfn.GE.1.000001) GO TO 20
c     case dfn = 1.0 - here I am treating dfn as exactly 1.0
      xnum = (snorm() + sqrt(xnonc))**2
      GO TO 30
c     case dfn > 1.0
 20   xnum = (2.0*sgamma((dfn-1.0)/2.0) + (snorm()+sqrt(xnonc))**2)/dfn
c
c     xden = genchi(dfd)/dfd
 30   xden = 2.0*sgamma(dfd/2.0)/dfd

c     changed constant so that it will not underflow at compile time
c     while not slowing generator by using double precision or logs.
c      IF (.NOT. (xden.LE. (1.0E-38*xnum))) GO TO 40
      IF (.NOT. (xden.LE. (1.0E-37*xnum))) GO TO 40
      call basout(io,wte,'nf: Generated numbers would cause overflow')
c     next 2 lines changed to maintain truncation of large deviates.
c      WRITE (*,*) ' GENNF returning 1.0E38'
c      gennf = 1.0E38
       call basout(io,wte,' returning 1.0E37')
      gennf = 1.0E37
      GO TO 50

   40 gennf = xnum/xden
   50 RETURN
      END


!*************************************************
! module mod_sabicm
!	SABICM(icm, isel)
!
!*************************************************

module mod_sabicm

	implicit none

contains
!=========
subroutine SABICM(icm, isel)

	use prm_inv
	use prm_var
	use mod_subabic

	implicit none

	integer, intent(in) :: icm
	integer, intent(inout) :: isel

	real(8) :: detc, detf, tn, abic(20), alphalog(20), step, abicmin, offset
	integer :: i, j, imin

!	open(88,file="alpha.opt")
!	read (88,*) ch
	open(89,file="alpha.dat")
	write(89,*) "log(alpha) alpha abic rsq2 sigma" ! detc jct detf jmt jdata"

	step = 0.5d0
	offset = - 4.d0
	abicmin = 1000.d0
	imin = 0

	do j = 1, 2

		if(setalpha < 90.d0) then
			imin = 1
			alphalog(imin) = setalpha
			exit
		end if

		do i = 1, 20
!			read(88,*) isel, alphalog
			alphalog(i) = dble(i-10)*step + offset
			alpha = 10.d0 ** alphalog(i)

!			print *, " ENTER ALPHA "
!			read *, alpha

			CALL RESET(alpha, detc, jdata, jct, jmt)
			CALL FREEMIN(detf, rsq2, jdata, jct, jmt)

			if(icm /= 0) CALL INEQMIN(detf)

			tn = dble(jdata + jct - jmt)

			abic(i) = tn + tn * dlog(2.d0*pi*rsq2/tn) - 2.d0 * (dble(jct) * dlog(alpha) + detc - detf)
			sigma = dsqrt(rsq2/tn)

!			print 600, alphalog(i), abic(i), rsq2, sigma, detc, jct, detf, jmt, jdata
			write(89,'(F6.2,4X,F10.5,4X,F10.3,4X,F10.5,4X,F10.5)') alphalog(i), alpha, abic(i), rsq2, sigma
!			print *, ' ENTER ISEL '
!			print *, ' 0/CHANGE ALPHA :  1/COMPUTE RESULT :  2/STOP '
!			read *, isel

!			if(isel == 0) cycle
!			if(isel == 1) exit
!			if(isel /= 0 .and. isel /= 1) stop 'ERROR (in alpha.opt)'

			if(abic(i) < abicmin) then
				abicmin = abic(i)
				imin = i
			end if

		end do

		write(89,*)

		if(imin == 1 .or. imin == 20) stop 'OUT OF ALPHA REGION: LOG ALPHA = (-9,+1)'
		if(j == 2) exit

		step = 0.1d0
		offset = alphalog(imin)

	end do

	alphalog(1) = alphalog(imin)
	alpha = 10.d0 ** alphalog(1)

	CALL RESET(alpha, detc, jdata, jct, jmt)
	CALL FREEMIN(detf, rsq2, jdata, jct, jmt)

	if(icm /= 0) CALL INEQMIN(detf)

	tn = dble(jdata + jct - jmt)

	abic(1) = tn + tn * dlog(2.d0*pi*rsq2/tn) - 2.d0 * (dble(jct) * dlog(alpha) + detc - detf)
	sigma = dsqrt(rsq2/tn)

	isel = 1

	print 600, alphalog(1), abic(1), rsq2, sigma, detc, jct, detf, jmt, jdata
		  600 FORMAT(/' ','LOG_ALPHA=',F6.3,' ABIC=',F10.3,' RSQ2=',F10.3, &
		     ' SIGMA=',F10.3//' ','DETC= ',E10.4,' JCT= ',I4/' DETF= ',E10.4, &
		     ' JMT= ',I4,12X,' JDATA= ',I4)
	write(89,'(F6.2,4X,F10.5,4X,F10.3,4X,F10.5,4X,F10.5)') alphalog(1), alpha, abic(1), rsq2, sigma

!	close(88)
	close(89)

return
end subroutine SABICM
!=========

end module mod_sabicm


*DECK R9ATN1
      FUNCTION R9ATN1 (X)
C***BEGIN PROLOGUE  R9ATN1
C***SUBSIDIARY
C***PURPOSE  Evaluate ATAN(X) from first order relative accuracy so that
C            ATAN(X) = X + X**3*R9ATN1(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4A
C***TYPE      SINGLE PRECISION (R9ATN1-S, D9ATN1-D)
C***KEYWORDS  ARC TANGENT, ELEMENTARY FUNCTIONS, FIRST ORDER, FNLIB,
C             TRIGONOMETRIC
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate  ATAN(X)  from first order, that is, evaluate
C (ATAN(X)-X)/X**3  with relative error accuracy so that
C        ATAN(X) = X + X**3*R9ATN1(X).
C
C Series for ATN1       on the interval  0.          to  1.00000D+00
C                                        with weighted error   2.21E-17
C                                         log weighted error  16.66
C                               significant figures required  15.44
C                                    decimal places required  17.32
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   780401  DATE WRITTEN
C   890206  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9ATN1
      DIMENSION ATN1CS(21)
      LOGICAL FIRST
      SAVE ATN1CS, NTATN1, XSML, XBIG, XMAX, FIRST
      DATA ATN1CS( 1) /   -.0328399753 5355202E0 /
      DATA ATN1CS( 2) /    .0583343234 3172412E0 /
      DATA ATN1CS( 3) /   -.0074003696 9671964E0 /
      DATA ATN1CS( 4) /    .0010097841 9933728E0 /
      DATA ATN1CS( 5) /   -.0001439787 1635652E0 /
      DATA ATN1CS( 6) /    .0000211451 2648992E0 /
      DATA ATN1CS( 7) /   -.0000031723 2107425E0 /
      DATA ATN1CS( 8) /    .0000004836 6203654E0 /
      DATA ATN1CS( 9) /   -.0000000746 7746546E0 /
      DATA ATN1CS(10) /    .0000000116 4800896E0 /
      DATA ATN1CS(11) /   -.0000000018 3208837E0 /
      DATA ATN1CS(12) /    .0000000002 9019082E0 /
      DATA ATN1CS(13) /   -.0000000000 4623885E0 /
      DATA ATN1CS(14) /    .0000000000 0740552E0 /
      DATA ATN1CS(15) /   -.0000000000 0119135E0 /
      DATA ATN1CS(16) /    .0000000000 0019240E0 /
      DATA ATN1CS(17) /   -.0000000000 0003118E0 /
      DATA ATN1CS(18) /    .0000000000 0000506E0 /
      DATA ATN1CS(19) /   -.0000000000 0000082E0 /
      DATA ATN1CS(20) /    .0000000000 0000013E0 /
      DATA ATN1CS(21) /   -.0000000000 0000002E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  R9ATN1
      IF (FIRST) THEN
         EPS = R1MACH(3)
         NTATN1 = INITS (ATN1CS, 21, 0.1*EPS)
C
         XSML = SQRT (0.1*EPS)
         XBIG = 1.571/SQRT(EPS)
         XMAX = 1.571/EPS
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.1.0) GO TO 20
C
      IF (Y.LE.XSML) R9ATN1 = -1.0/3.0
      IF (Y.LE.XSML) RETURN
C
      R9ATN1 = -0.25 + CSEVL (2.0*Y*Y-1., ATN1CS, NTATN1)
      RETURN
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'R9ATN1',
     +   'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 2, 2)
      IF (Y .GT. XBIG) CALL XERMSG ('SLATEC', 'R9ATN1',
     +   'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 1, 1)
C
      R9ATN1 = (ATAN(X) - X) / X**3
      RETURN
C
      END


            SUBROUTINE FOUR2 (DATA,N,NDIM,ISIGN,IFORM)
C     COOLEY-TUKEY FAST FOURIER TRANSFORM IN USASI BASIC FORTRAN.
C     MULTI-DIMENSIONAL TRANSFORM, EACH DIMENSION A POWER OF TWO,
C     COMPLEX OR REAL DATA.
C     TRANSFORM(K1,K2,...) = SUM(DATA(J1,J2,...)*EXP(ISIGN*2*PI*SQRT(-1)
C     *((J1-1)*(K1-1)/N(1)+(J2-1)*(K2-1)/N(2)+...))), SUMMED FOR ALL
C     J1 AND K1 FROM 1 TO N(1), J2 AND K2 FROM 1 TO N(2),
C     ETC. FOR ALL NDIM SUBSCRIPTS.  NDIM MUST BE POSITIVE AND
C     EACH N(IDIM) MUST BE A POWER OF TWO.  ISIGN IS +1 OR -1.
C     LET NTOT = N(1)*N(2)*...*N(NDIM).  THEN A -1 TRANSFORM
C     FOLLOWED BY A +1 ONE (OR VICE VERSA) RETURNS NTOT
C     TIMES THE ORIGINAL DATA.  IFORM = 1, 0 OR -1, AS DATA IS
C     COMPLEX, REAL OR THE FIRST HALF OF A COMPLEX ARRAY.	TRANSFORM
C     VALUES ARE RETURNED TO ARRAY DATA.  THEY ARE COMPLEX, REAL OR
C     THE FIRST HALF OF A COMPLEX ARRAY, AS IFORM = 1, -1 OR 0.
C     THE TRANSFORM OF A REAL ARRAY (IFORM = 0) DIMENSIONED N(1) BY N(2)
C     BY ... WILL BE RETURNED IN THE SAME ARRAY, NOW CONSIDERED TO
C     BE COMPLEX OF DIMENSIONS N(1)/2+1 BY N(2) BY ....  NOTE THAT IF
C     IFORM = 0 OR -1, N(1) MUST BE EVEN, AND ENOUGH ROOM MUST BE
C     RESERVED.  THE MISSING VALUES MAY BE OBTAINED BY COMPLEX CONJUGA-
C     TION.	THE REVERSE TRANSFORMATION, OF A HALF COMPLEX ARRAY DIMEN-
C     SIONED N(1)/2+1 BY N(2) BY ..., IS ACCOMPLISHED BY SETTING IFORM
C     TO -1.  IN THE N ARRAY, N(1) MUST BE THE TRUE N(1), NOT N(1)/2+1.
C     THE TRANSFORM WILL BE REAL AND RETURNED TO THE INPUT ARRAY.
C     RUNNING TIME IS PROPORTIONAL TO NTOT*LOG2(NTOT), RATHER THAN
C     THE NAIVE NTOT**2.  FURTHERMORE, LESS ERROR IS BUILT UP.
C     WRITTEN BY NORMAN BRENNER OF MIT LINCOLN LABORATORY, JUNE 1968.
C     SEE-- IEEE AUDIO TRANSACTIONS (JUNE 1967), SPECIAL ISSUE ON FFT.
      INCLUDE 'res_par.f90'
      DIMENSION DATA(m_d2), N(1)
      NTOT=1
      DO 10 IDIM=1,NDIM
 10   NTOT=NTOT*N(IDIM)
      IF (IFORM) 70,20,20
 20   NREM=NTOT
      DO 60 IDIM=1,NDIM
      NREM=NREM/N(IDIM)
      NPREV=NTOT/(N(IDIM)*NREM)
      NCURR=N(IDIM)
      IF (IDIM-1+IFORM) 30,30,40
 30   NCURR=NCURR/2
 40   CALL BOTRV (DATA,NPREV,NCURR,NREM)
      CALL COOL2 (DATA,NPREV,NCURR,NREM,ISIGN)
      IF (IDIM-1+IFORM) 50,50,60
 50   CALL FOXRL (DATA,N(1),NREM,ISIGN,IFORM)
      NTOT=(NTOT/N(1))*(N(1)/2+1)
 60   CONTINUE
      RETURN
 70   NTOT=(NTOT/N(1))*(N(1)/2+1)
      NREM=1
      DO 100 JDIM=1,NDIM
      IDIM=NDIM+1-JDIM
      NCURR=N(IDIM)
      IF (IDIM-1) 80,80,90
 80   NCURR=NCURR/2
      CALL FOXRL (DATA,N(1),NREM,ISIGN,IFORM)
      NTOT=NTOT/(N(1)/2+1)*N(1)
 90   NPREV=NTOT/(N(IDIM)*NREM)
      CALL BOTRV (DATA,NPREV,NCURR,NREM)
      CALL COOL2 (DATA,NPREV,NCURR,NREM,ISIGN)
 100  NREM=NREM*N(IDIM)
      RETURN
      END
      SUBROUTINE FOXRL (DATA,N,NREM,ISIGN,IFORM)
C     FOR IFORM = 0, CONVERT THE TRANSFORM OF A DOUBLED-UP REAL ARRAY,
C     CONSIDERED COMPLEX, INTO ITS TRUE TRANSFORM.  SUPPLY ONLY THE
C     FIRST HALF OF THE COMPLEX TRANSFORM, AS THE SECOND HALF HAS
C     CONJUGATE SYMMETRY.  FOR IFORM = -1, CONVERT THE FIRST HALF
C     OF THE TRUE TRANSFORM INTO THE TRANSFORM OF A DOUBLED-UP REAL
C     ARRAY.  N MUST BE EVEN.
C     USING COMPLEX NOTATION AND SUBSCRIPTS STARTING AT ZERO, THE
C     TRANSFORMATION IS--
C     DIMENSION DATA(N,NREM)
C     ZSTP = EXP(ISIGN*2*PI*I/N)
C     DO 10 I2=0,NREM-1
C     DATA(0,I2) = CONJ(DATA(0,I2))*(1+I)
C     DO 10 I1=1,N/4
C     Z = (1+(2*IFORM+1)*I*ZSTP**I1)/2
C     I1CNJ = N/2-I1
C     DIF = DATA(I1,I2)-CONJ(DATA(I1CNJ,I2))
C     TEMP = Z*DIF
C     DATA(I1,I2) = (DATA(I1,I2)-TEMP)*(1-IFORM)
C 10  DATA(I1CNJ,I2) = (DATA(I1CNJ,I2)+CONJ(TEMP))*(1-IFORM)
C     IF I1=I1CNJ, THE CALCULATION FOR THAT VALUE COLLAPSES INTO
C     A SIMPLE CONJUGATION OF DATA(I1,I2).
      INCLUDE 'res_par.f90'
      DIMENSION DATA(m_d2)
      TWOPI=6.283185307*FLOAT(ISIGN)
      IP0=2
      IP1=IP0*(N/2)
      IP2=IP1*NREM
      IF (IFORM) 10,70,70
C     PACK THE REAL INPUT VALUES (TWO PER COLUMN)
 10   J1=IP1+1
      DATA(2)=DATA(J1)
      IF (NREM-1) 70,70,20
 20   J1=J1+IP0
      I2MIN=IP1+1
      DO 60 I2=I2MIN,IP2,IP1
      DATA(I2)=DATA(J1)
      J1=J1+IP0
      IF (N-2) 50,50,30
 30   I1MIN=I2+IP0
      I1MAX=I2+IP1-IP0
      DO 40 I1=I1MIN,I1MAX,IP0
      DATA(I1)=DATA(J1)
      DATA(I1+1)=DATA(J1+1)
 40   J1=J1+IP0
 50   DATA(I2+1)=DATA(J1)
 60   J1=J1+IP0
 70   DO 80 I2=1,IP2,IP1
      TEMPR=DATA(I2)
      DATA(I2)=DATA(I2)+DATA(I2+1)
 80   DATA(I2+1)=TEMPR-DATA(I2+1)
      IF (N-2) 200,200,90
 90   THETA=TWOPI/FLOAT(N)
      SINTH=SIN(THETA/2.)
      ZSTPR=-2.*SINTH*SINTH
      ZSTPI=SIN(THETA)
      ZR=(1.-ZSTPI)/2.
      ZI=(1.+ZSTPR)/2.
      IF (IFORM) 100,110,110
 100  ZR=1.-ZR
      ZI=-ZI
 110  I1MIN=IP0+1
      I1MAX=IP0*(N/4)+1
      DO 190 I1=I1MIN,I1MAX,IP0
      DO 180 I2=I1,IP2,IP1
      I2CNJ=IP0*(N/2+1)-2*I1+I2
      IF (I2-I2CNJ) 150,120,120
 120  IF (ISIGN*(2*IFORM+1)) 130,140,140
 130  DATA(I2+1)=-DATA(I2+1)
 140  IF (IFORM) 170,180,180
 150  DIFR=DATA(I2)-DATA(I2CNJ)
      DIFI=DATA(I2+1)+DATA(I2CNJ+1)
      TEMPR=DIFR*ZR-DIFI*ZI
      TEMPI=DIFR*ZI+DIFI*ZR
      DATA(I2)=DATA(I2)-TEMPR
      DATA(I2+1)=DATA(I2+1)-TEMPI
      DATA(I2CNJ)=DATA(I2CNJ)+TEMPR
      DATA(I2CNJ+1)=DATA(I2CNJ+1)-TEMPI
      IF (IFORM) 160,180,180
 160  DATA(I2CNJ)=DATA(I2CNJ)+DATA(I2CNJ)
      DATA(I2CNJ+1)=DATA(I2CNJ+1)+DATA(I2CNJ+1)
 170  DATA(I2)=DATA(I2)+DATA(I2)
      DATA(I2+1)=DATA(I2+1)+DATA(I2+1)
 180  CONTINUE
      TEMPR=ZR-.5
      ZR=ZSTPR*TEMPR-ZSTPI*ZI+ZR
 190  ZI=ZSTPR*ZI+ZSTPI*TEMPR+ZI
C     RECURSION SAVES TIME, AT A SLIGHT LOSS IN ACCURACY.	IF AVAILABLE,
C     USE DOUBLE PRECISION TO COMPUTE ZR AND ZI.
 200  IF (IFORM) 270,210,210
C     UNPACK THE REAL TRANSFORM VALUES (TWO PER COLUMN)
 210  I2=IP2+1
      I1=I2
      J1=IP0*(N/2+1)*NREM+1
      GO TO 250
 220  DATA(J1)=DATA(I1)
      DATA(J1+1)=DATA(I1+1)
      I1=I1-IP0
      J1=J1-IP0
 230  IF (I2-I1) 220,240,240
 240  DATA(J1)=DATA(I1)
      DATA(J1+1)=0.
 250  I2=I2-IP1
      J1=J1-IP0
      DATA(J1)=DATA(I2+1)
      DATA(J1+1)=0.
      I1=I1-IP0
      J1=J1-IP0
      IF (I2-1) 260,260,230
 260  DATA(2)=0.
 270  RETURN
      END
      SUBROUTINE BOTRV(DATA,NPREV,N,NREM)
C   SHUFFLE THE DATA BY 'BIT REVERSAL'.
C   DIMENSION DATA(NPREV,N,NREM)
C   DATA(I1,I2REV,I3) = DATA(I1,I2,I3), FOR ALL I1 FROM 1 TO
C   NPREV, ALL I2 FROM 1 TO N (WHICH MUST BE A POWER OF TWO), AND
C   ALL I3 FROM 1 TO NREM, WHERE I2REV-1 IS THE BITWISE REVERSAL
C   OF I2-1.  FOR EXAMPLE, N = 32, I2-1 = 10011 AND I2REV-1 = 11001.
C
      INCLUDE 'res_par.f90'
      DIMENSION DATA(m_d2)
      COMPLEX DATA,TEMP
      IP0=1
      IP1=IP0*NPREV
      IP4=IP1*N
      IP5=IP4*NREM
      I4REV=1
      I4MAX=IP4
      DO 60 I4=1,I4MAX,IP1
      IF(I4-I4REV)10,30,30
   10 I1MAX=I4+IP1-IP0
      DO 20 I1=I4,I1MAX,IP0
      DO 20 I5=I1,IP5,IP4
      I5REV=I4REV+I5-I4
      TEMP=DATA(I5)
      DATA(I5)=DATA(I5REV)
   20 DATA(I5REV)=TEMP
   30 IP2=IP4/2
   40 IF(I4REV-IP2)60,60,50
   50 I4REV=I4REV-IP2
      IP2=IP2/2
      IF(IP2-IP1)60,40,40
   60 I4REV=I4REV+IP2
      RETURN
      END
      SUBROUTINE COOL2(DATA,NPREV,N,NREM,ISIGN)
C   FOURIER TRANSFORM, LENGTH N, BY THE COOLEY-TUKEY ALGORITHM, IN
C   PLACE, BIT-REVERSED TO NORMAL ORDER, SANDE-TUKEY PHASE SHIFTS.
C   COMPLEX DATA
C   DIMENSION DATA(NPREV,N,NREM)
C   DATA(I1,J2,I3) = SUM(DATA(I1,I2,I3)CEXP(ISIGNC2CPICIC((I2-1)C
C   (J2-1)/N))), SUMMED OVER I2 = 1 TO N FOR ALL I1 FROM 1 TO
C   NPREV, J2 FROM 1 TO N AND I3 FROM 1 TO NREM.  N MUST BE A
C   POWER OF TWO.  FACTORING N BY FOUR'S DECREASES RUNNING TIME
C   BY ABOUT TWENTY FIVE PERCENT OVER FACTORING BY TWO'S.
C   GENERATING THE PHASE SHIFT FACTORS BY RECURSION SAVES ABOUT
C   TWENTY FIVE PERCENT OVER COMPUTING THEM, WHILE TABLING THEM
C   IS UNLIKELY TO SAVE MORE THAN ANOTHER TEN PERCENT.
C
      INCLUDE 'res_par.f90'
      DIMENSION DATA(m_d2)
      COMPLEX DATA,TEMP,WSTP,W,W2,W3,T0,T1,T2,T3
      TWOPI=6.28318530717958647692*FLOAT(ISIGN)
      IP0=1
      IP1=IP0*NPREV
      IP4=IP1*N
      IP5=IP4*NREM
      IP2=IP1
      NPART=N
   10 IF(NPART-2)50,30,20
   20 NPART=NPART/4
      GO TO 10
C
C   DO A FOURIER TRANSFORM OF LENGTH TWO
C
   30 IP3=IP2*2
      I1MAX=IP1
      DO 40 I1=1,I1MAX,IP0
      DO 40 I5=I1,IP5,IP3
      I3A=I5
      I3B=I3A+IP2
      TEMP=DATA(I3B)
      DATA(I3B)=DATA(I3A)-TEMP
   40 DATA(I3A)=DATA(I3A)+TEMP
      GO TO 140
C
C   DO A FOURIER TRANSFORM OF LENGTH FOUR (WITHOUT BIT REVERSAL)
C
   50 IP3=IP2*4
      THETA=TWOPI/FLOAT(IP3/IP1)
      SINTH=SIN(THETA/2.)
      WSTP=CMPLX(-2.*SINTH*SINTH,SIN(THETA))
C
C   COS(THETA)-1, FOR ACCURACY
C
      W=1.
      DO 130 I2=1,IP2,IP1
       IF(I2-1)70,70,60
   60 W2=W*W
      W3=W2*W
   70 I1MAX=I2+IP1-IP0
      DO 120 I1=I2,I1MAX,IP0
      DO 120 I5=I1,IP5,IP3
      I3A=I5
      I3B=I3A+IP2
      I3C=I3B+IP2
      I3D=I3C+IP2
      IF(I2-1)90,90,80
C
C   MULTIPLY BY THE PHASE SHIFT FACTORS
C
   80 DATA(I3B)=W2*DATA(I3B)
      DATA(I3C)=W*DATA(I3C)
      DATA(I3D)=W3*DATA(I3D)
   90 T0=DATA(I3A)+DATA(I3B)
      T1=DATA(I3A)-DATA(I3B)
      T2=DATA(I3C)+DATA(I3D)
      T3=DATA(I3C)-DATA(I3D)
      DATA(I3A)=T0+T2
      DATA(I3C)=T0-T2
      TEMP=(0.,1.)*T3
      IF(ISIGN)100,100,110
  100 TEMP=-TEMP
  110 DATA(I3B)=T1+TEMP
  120 DATA(I3D)=T1-TEMP
  130 W=W*WSTP+W
  140 IP2=IP3
      IF(IP3-IP4)50,150,150
  150 RETURN
      END


! Generalised Fortran version of original c++ code by TunnaBrain (Benedikt Bitterli) https://github.com/tunabrain/incremental-fluids.

module fluid
  use nrtype

  type FluidQty
    character(len=:), allocatable :: name   ! Variable name.
    real(dp)        , allocatable :: old(:) ! Old value.
    real(dp)        , allocatable :: new(:) ! New value.
    integer         , allocatable :: whd(:) ! Width, height, depth of the simulation domain.
    real(dp)        , allocatable :: ost(:) ! Offset.
    real(dp)                      :: celsiz ! Cell size (area or volume).
  contains
    ! Initialise type.
    procedure :: Init => InitFluidQty
    ! Add fluid flow.
    procedure :: AddFlow2D
    procedure :: AddFlow3D
    generic   :: AddFlow => AddFlow2D, AddFlow3D
    ! Read values.
    procedure :: ReadVal2D
    procedure :: ReadVal3D
    generic   :: ReadVal => ReadVal2D, ReadVal3D
    ! Write values.
    procedure :: WriteNewVal2D
    procedure :: WriteNewVal3D
    generic   :: WriteNewVal => WriteNewVal2D, WriteNewVal3D
    procedure :: WriteOldVal2D
    procedure :: WriteOldVal3D
    generic   :: WriteOldVal => WriteOldVal2D, WriteOldVal3D
    ! Update values.
    procedure :: UpdateVals
    ! Linear interpolate.
    procedure :: Lerp1D
    procedure :: Lerp2D
    procedure :: Lerp3D
    generic   :: Lerp => Lerp1D, Lerp2D, Lerp3D
    ! Integrate.
    procedure :: FEulerVel2D
    procedure :: FEulerVel3D
    generic   :: FEuler => FEulerVel2D, FEulerVel3D
    ! Advect.
    procedure :: Advect2D
    procedure :: Advect3D
    generic   :: Advect => Advect2D, Advect3D
  end type FluidQty

  type FluidSlv
    type(FluidQty) , allocatable :: u(:)     ! Velocities
    type(FluidQty)               :: rho      ! Density array
    integer        , allocatable :: whd(:)   ! Width, height, depth
    real(dp)                     :: celsiz   ! Cell size.
    real(dp)                     :: srho     ! Scalar (fluid) density.
    real(dp)       , allocatable :: prhs(:)  ! Right hand side of pressure equation.
    real(dp)       , allocatable :: p(:)     ! Pressure solution.
    real(dp)                     :: TimeStep, MaxTimeStep, MinTimeStep ! Timesteps
    real(dp)                     :: safety   ! Safety factor for timestep calculation
  contains
    ! Initialise type.
    procedure :: Init => InitFluid
    ! Add flow.
    procedure :: InitFlow2D
    procedure :: InitFlow3D
    generic   :: AddFlow => InitFlow2D, InitFlow3D
    ! Max time step.
    procedure :: MaxTimestep2D
    procedure :: MaxTimestep3D
    ! Build right hand side of pressure solution.
    procedure :: BuildRhs2D
    procedure :: BuildRhs3D
    ! Solve pressure.
    procedure :: GSPSlv2D
    procedure :: GSPSlv3D
    ! Apply pressure.
    procedure :: ApplyPressure2D, ApplyPressure3D
    ! Write values.
    procedure :: WriteArray2D
    procedure :: WriteArray3D
    generic   :: WriteArray => WriteArray2D, WriteArray3D
    !Read values.
    procedure :: ReadArray2D
    procedure :: ReadArray3D
    generic   :: ReadArray => ReadArray2D, ReadArray3D
    ! Write to file.
    procedure :: WriteToFile
  end type FluidSlv

  type Vec2D
    real(dp) :: x(2)
  end type Vec2D

  type Vec2D2
    real(dp) :: x(4)
  end type Vec2D2

  type FluidQty2D
    type(FluidQty) :: FldQty(2)
  end type FluidQty2D

  type Vec3D
    real(dp) :: x(3)
  end type Vec3D

  type Vec3D2
    real(dp) :: x(6)
  end type Vec3D2

  type FluidQty3D
    type(FluidQty) :: FldQty(3)
  end type FluidQty3D

contains

!==============================================================================!
! Tested.
  subroutine InitFluid(FldSlv, names, whd, rho, timestep, scale, safety)
    implicit none
    class(FluidSlv) , intent(out)  :: FldSlv ! Fluid
    character(len=*), dimension(:), intent(in) :: names
    integer         , intent(in)   :: whd(:) ! Width (i), height (j), depth (k)
    real(dp)        , intent(in)   :: rho
    real(dp)        , intent(in)   :: timestep
    real(dp), optional, intent(in) :: scale
    real(dp), optional, intent(in) :: safety
    real(dp), dimension(size(whd)) :: ost    ! Offset
    real(dp), dimension(size(whd)) :: TMPost
    integer                        :: ndim   ! Number of dimensions
    integer                        :: ncells ! Number of cells
    integer, dimension(size(whd))  :: TMncells ! Number of cells for each different quantity
    integer                        :: i      ! Counter

    ! Number of dimensions.
    ndim = size(whd)
    ncells = product(whd) - 1

    ! Set the fluid density.
    FldSlv % srho = rho

    ! Set initial time step.
    FldSlv % TimeStep = timestep
    if(present(safety) .eqv. .true.) then
      FldSlv % MinTimeStep = timestep * safety * 1d-3
      FldSlv % MaxTimeStep = timestep * safety * 1d+3
    else
      FldSlv % MinTimeStep = timestep * 0.8_dp * 1d-3
      FldSlv % MaxTimeStep = timestep * 0.8_dp * 1d+3
    end if

    ! Cell size.
    if(present(scale) .eqv. .true.) then
      FldSlv % celsiz = scale/minval(whd)
    else
      FldSlv % celsiz = 1./minval(whd)
    endif

    ! Safety factor.
    if(present(safety) .eqv. .true.) then
      FldSlv % safety = safety
    else
      FldSlv % safety = 0.8_dp
    endif

    ! Initialise density.
    ! Centered in the grid.
    ost    = 0.5
    call FldSlv % rho % init(trim(names(1)(1:len(names(1)))), whd, ost, FldSlv % celsiz)

    ! Initialise velocities.
    ! Staggered on the grid.
    allocate(FldSlv % u(ndim))
    iv: do i = 1, ndim
      TMncells    = whd
      TMncells(i) = whd(i) + 1
      TMPost    = ost
      TMPost(i) = ost(i) - 0.5
      call FldSlv % u(i) % init(trim(names(i+1)(1:len(names(i+1)))), TMncells, TMPost, FldSlv % celsiz)
    end do iv

    ! Allocate whd (simulation bounds).
    allocate (FldSlv % whd(ndim))
    FldSlv % whd = whd

    ! Allocate the right hand side of pressure solve.
    allocate(FldSlv % prhs(0:ncells))
    !dir$ loop count min(256)
    FldSlv % prhs = 0._dp

    ! Allocate the pressure solution and give initial guess.
    allocate(FldSlv % p(0:ncells))
    !dir$ loop count min(256)
    FldSlv % p = 0._dp
  end subroutine InitFluid
!==============================================================================!

!==============================================================================!
! Tested
  subroutine InitFluidQty(FldQty, name, whd, ost, celsiz)
    implicit none
    character(len=*), intent(in)  :: name   ! Variable name.
    integer,          intent(in)  :: whd(:) ! Width (i), height (j), depth (k)
    real(dp),         intent(in)  :: ost(:) ! Offset
    real(dp),         intent(in)  :: celsiz ! Cell size (area or volume)
    class(FluidQty),  intent(out) :: FldQty ! Fluid Quantity
    integer                       :: ncells ! # of cells = prod(whd)

    ! Check that size(whd) == size(ost).
    check_size: if ( size(whd) /= size(ost) ) then
      write(*,*) " Error: fluid.f08: InitFluidQty: check_size: Variable name = ", name, "."
      write(*,*) " Size(whd) == size(ost); size(whd) = ", size(whd), " size(ost) = ", size(ost)
      stop
    end if check_size

    ! Allocate name.
    allocate(character(len=len(name)):: FldQty % name)
    FldQty % name = name

    ! Width, height, depth
    allocate(FldQty % whd(size(whd)))
    FldQty % whd = whd

    ! Offset
    allocate(FldQty % ost(size(ost)))
    FldQty % ost = ost

    ! Allocate values.
    ncells = product(whd) - 1
    allocate(FldQty % old(0:ncells), FldQty % new(0:ncells))
    !dir$ loop count min(512)
    FldQty % old = 0.
    !dir$ loop count min(512)
    FldQty % new = 0.

    ! Cell size
    FldQty % celsiz = celsiz
  end subroutine InitFluidQty
!==============================================================================!

!==============================================================================!
  ! Initialise flow.
  ! Adds the respective quantities inside the box bounded by the coordinates xi%x.
  ! Tested: 2D
  pure subroutine InitFlow2D(FldSlv, xi, values)
    implicit none
    class(FluidSlv), intent(inout) :: FldSlv
    type(Vec2D2)   , intent(in)    :: xi        ! Coordinates for the vertices of the 2D box.
    real(dp)       , intent(in)    :: values(3) ! value(1) := density, value(2) = Vx, value(3) = Vy.

    call FldSlv % rho    % AddFlow(xi, values(1)  )
    call FldSlv % u(1:2) % AddFlow(xi, values(2:3))
  end subroutine InitFlow2D

  pure subroutine InitFlow3D(FldSlv, xi, values)
    implicit none
    class(FluidSlv), intent(inout) :: FldSlv
    type(Vec3D2)   , intent(in)    :: xi        ! Coordinates for the vertices of the 3D box.
    real(dp)       , intent(in)    :: values(4) ! value(1) := density, value(2) = Vx, value(3) = Vy, value(4) = Vz

    call FldSlv % rho    % AddFlow(xi, values(1)  )
    call FldSlv % u(1:3) % AddFlow(xi, values(2:4))
  end subroutine InitFlow3D
!==============================================================================!

!==============================================================================!
  ! Add relevant quantities to the fluid simulation.
  ! Tested: 2D.
  elemental subroutine AddFlow2D(FldQty, xi, value)
    implicit none
    class(FluidQty), intent(inout) :: FldQty
    type(Vec2D2)   , intent(in)    :: xi ! xi%x(1) = x0, xi%x(2) = x1, xi%x(3) = y0, xi%x(4) = y1
    real(dp)       , intent(in)    :: value
    integer                        :: i, j, ixi(4), idx

    ! (x0,y1) ----------- (x1,y1)
    !         |         |
    !         |         |
    !         |         |
    ! (x0,y0) ----------- (x1,y0)

    ! Set up the simulation bounds.
    bounds: do concurrent (i = 1: 2)
      j = 2*i
      ! Using fortran's standard indexing we need to add 1 to the coordinates if we want to properly account for zero.
      ixi(j-1 : j) = aint( (xi % x(j-1 : j) ) / FldQty % celsiz - FldQty % ost(i) )
    end do bounds

    ! Loop through y.
    ! Start from the maximum value between the desired y0 and 1 (for the cell index) up to the minimum value between the desired y1 and the simulation height.
    ly: do concurrent (j = max(ixi(3), 0): min( ixi(4), FldQty % whd(2)) - 1)
      ! Loop through x.
      ! Start from the maximum value between the desired x0 and 1 (for the cell index) up to the minimum value between the desired x1 and the simulation width.
      lx: do concurrent (i = max(ixi(1), 0): min( ixi(2), FldQty % whd(1)) - 1)
        ! Write value to old value.
        idx = i + FldQty % whd(1)*j
        if ( abs(FldQty % old(idx)) < abs(value) ) FldQty % old(idx) = value
      end do lx
    end do ly
  end subroutine AddFlow2D
!==============================================================================!

!==============================================================================!
  elemental subroutine AddFlow3D(FldQty, xi, value)
    implicit none
    class(FluidQty), intent(inout) :: FldQty
    type(Vec3D2)   , intent(in)    :: xi ! xi%x(1) = x0, xi%x(2) = x1, xi%x(3) = y0, xi%x(4) = y1, xi%x(5) = z0, xi%x(6) = z1
    real(dp)       , intent(in)    :: value
    integer                        :: i, j, k, ixi(6), idx

    ! This is the simulation domain.
    !
    !    (x0,y1,z1)   ------------- (x1,y1,z1)
    !                /|          /|
    !               / |         / |
    !              /  |        /  |
    ! (x0,y1,z0)  -------------   | (x1,y1,z0)
    !             |   |       |   |
    !  (x0,y0,z1) |   --------|--- (x1,y0,z1)
    !             |  /        |  /
    !             | /         | /
    !             |/          |/
    ! (x0,y0,z0)  ------------- (x1,y0,z0)

    bounds: do concurrent (i = 1: 3)
      j = 2*i
      ixi(j-1 : j) = aint( (xi % x(j-1 : j) ) / FldQty % celsiz - FldQty % ost(i) )
    end do bounds

    ! Loop through z.
    ! Start from the maximum value between the desired z0 and 1 (for the cell index) up to the minimum value between the desired z1 and the simulation depth.
    lz: do concurrent (k = max(ixi(5), 0): min(ixi(6), FldQty % whd(3)) - 1)
      ! Loop through y.
      ! Start from the maximum value between the desired y0 and 1 (for the cell index) up to the minimum value between the desired y1 and the simulation height.
      ly: do concurrent (j = max(ixi(3), 0): min(ixi(4), FldQty % whd(2)) - 1)
        ! Loop through x.
        ! Start from the maximum value between the desired x0 and 1 (for the cell index) up to the minimum value between the desired x1 and the simulation width.
        lx: do concurrent (i = max(ixi(1), 0): min(ixi(2), FldQty % whd(1)) - 1)
          ! Write value to old value.
          idx = i + FldQty % whd(1)*j + FldQty % whd(2)*k
          if ( abs(FldQty % old(idx)) < abs(value) ) FldQty % old(idx) = value
        end do lx
      end do ly
    end do lz
  end subroutine AddFlow3D
!==============================================================================!

!==============================================================================!
! Tested: 2D.
  subroutine BuildRhs(FldSlv)
    ! Build Rhs wrapper subroutine.
    ! The actual subroutines build the pressure solution via the negative of the divergence as a forward finite difference (truly horrible). This is not the best way to go about doing this, but it will be fixed in the future.
    implicit none
    class(FluidSlv), intent(inout) :: FldSlv
    integer, allocatable, save     :: ndim ! Number of dimensions.

    ! Allocate ndim and set its value to the number of dimensions.
    if (.not. allocated(ndim)) allocate(ndim, source = size(FldSlv % whd))

    ! Choose 3D or 2D.
    C2D3D: if (ndim == 2) then
      call FldSlv % BuildRhs2D
    else C2D3D
      call FldSlv % BuildRhs3D
    end if C2D3D
  end subroutine BuildRhs
  !==============================================================================!

  !==============================================================================!
  ! Tested: 2D
  pure subroutine BuildRhs2D(FldSlv)
    implicit none
    class(FluidSlv), intent(inout) :: FldSlv
    real(dp)                       :: scale     ! Scaling factor.
    integer                        :: i, j, idx ! Counters and index.

    ! Calculate the scale.
    scale =  1._dp/FldSlv % celsiz

    idx = 0
    ly: do j = 0, FldSlv % whd(2) - 1
      lx: do i = 0, FldSlv % whd(1) - 1
        FldSlv % prhs(idx) = -scale * (                                     &
                                         FldSlv % u(1) % ReadVal(i+1, j  )  &
                                       + FldSlv % u(2) % ReadVal(i  , j+1)  &
                                       - sum(FldSlv % u % ReadVal(i , j  )) &
                                      )
        idx = idx + 1
      end do lx
    end do ly
  end subroutine BuildRhs2D
  !==============================================================================!

  !==============================================================================!
  pure subroutine BuildRhs3D(FldSlv)
    implicit none
    class(FluidSlv), intent(inout) :: FldSlv
    real(dp)                       :: scale
    integer                        :: i, j, k, idx ! Counters and index.

    ! Calculate the scale.
    scale =  1._dp/FldSlv % celsiz
    idx = 0
    lz: do k = 0, FldSlv % whd(3) - 1
      ly: do j = 0, FldSlv % whd(2) - 1
        lx: do i = 0, FldSlv % whd(1) - 1
          FldSlv % prhs(idx) = -scale * (              &
                                           FldSlv % u(1) % ReadVal(i+1, j  , k  )  &
                                         + FldSlv % u(2) % ReadVal(i  , j+1, k  )  &
                                         + FldSlv % u(3) % ReadVal(i  , j  , k+1)  &
                                         - sum(FldSlv % u % ReadVal(i , j  , k  )) &
                                        )
          idx = idx + 1
        end do lx
      end do ly
    end do lz
  end subroutine BuildRhs3D
  !==============================================================================!

  !==============================================================================!
  ! Tested: 2D.
  subroutine GSPSlv2D(FldSlv, MaxIt, DErr)
    ! Gauss-Seidel pressure solve.
    implicit none
    class(FluidSlv), intent(inout) :: FldSlv
    integer        , intent(in)    :: MaxIt  ! Maximum number of iterations.
    real(dp)       , intent(in)    :: DErr   ! Desired error threshold.
    real(dp)                       :: scale, Err ! Scaling factor, iteration error.
    integer                        :: iter, i, j, idx ! Iteration, counters, index
    real(dp)                       :: Diag, OffDiag ! Diagonal and offdiagonal elements of the matrix.
    real(dp)                       :: NewP ! New pressure value.
    integer                        :: AuxWHD(2)

    ! Set scale.
    scale  = FldSlv % TimeStep / (FldSlv % srho * FldSlv % celsiz * FldSlv % celsiz)
    ! Set range for loops.
    AuxWHD = FldSlv % whd - 1

    ! ITERation Loop.
    iterl: do iter = 1, MaxIt
      Err = 0._dp
      ! Loop over y.
      idx = 0
      ly: do j = 0, AuxWHD(2)
        ! Loop over x.
        lx: do i = 0, AuxWHD(1)
          Diag    = 0._dp
          OffDiag = 0._dp

          ! Building the matrix as a five-point stencil. Solid borders, i.e. no fluid is outside of the simulation bounds.

          ! The pressure contribution for each cell depends on its 4 nearest orthogonal neighbours.
          ! For example, cell a22 will receive contributions from cells a12, a23, a33 and a21.
          ! Boundary cells will only receive contributions from the orthogonally placed cells that are found within the simulation bounds. For example, cell a13 will only receive contributions from cells a12 and a23, while cell a21 from cells a11, a22 and a31. This leads to the series of if statements found herein.

          ! y-axis
          ! ^
          ! |__> x-axis
          !
          ! -------------------
          ! | a13 | a23 | a33 |
          ! -------------------
          ! | a12 | a22 | a32 |     --------->   [a11,a21,a31,a12,a22,a32,a13,a23,a33]
          ! -------------------
          ! | a11 | a21 | a31 |
          ! -------------------scale

          ! Exclude Lower X Bound (Exclude cells a11, a12, a13 in the diagram).
          elxb: if (i > 0) then
            Diag    = Diag + scale
            OffDiag = OffDiag - scale * FldSlv % p(idx - 1)
          end if elxb

          ! Exclude Lower X Bound (Exclude cells a13, a23, a33 in the diagram).
          euxb: if (i < AuxWHD(1)) then
            Diag    = Diag + scale
            OffDiag = OffDiag - scale * FldSlv % p(idx + 1)
          end if euxb

          ! Exclude Upper Y Bound (Exclude cells a11, a12, 9 in the diagram).
          elyb: if (j > 0) then
            Diag    = Diag + scale
            OffDiag = OffDiag - scale * FldSlv % p(idx - FldSlv % whd(1))
          end if elyb

          ! Exclude Lower Y Bound (Exclude cells 1, 4, 7 in the diagram).
          euyb: if (j < AuxWHD(2)) then
            Diag    = Diag + scale
            OffDiag = OffDiag - scale * FldSlv % p(idx + FldSlv % whd(1))
          end if euyb

          NewP = (FldSlv % prhs(idx) - OffDiag) / Diag

          Err = max(Err, abs(FldSlv % p(idx) - NewP))

          FldSlv % p(idx) = NewP
          idx = idx + 1
        end do lx
      end do ly

      if (Err < Derr) return
    end do iterl
  end subroutine GSPSlv2D
!==============================================================================!

!==============================================================================!
  subroutine GSPSlv3D(FldSlv, MaxIt, DErr)
    ! Gauss-Seidel pressure solve.
    implicit none
    class(FluidSlv), intent(inout) :: FldSlv
    integer      , intent(in)    :: MaxIt  ! Maximum number of iterations.
    real(dp)     , intent(in)    :: DErr   ! Desired error threshold.
    real(dp)                     :: scale, Err ! Scaling factor, iteration error.
    integer                      :: iter, i, j, k, idx ! Iteration, counters, index
    real(dp)                     :: Diag, OffDiag ! Diagonal and offdiagonal elements of the matrix.
    real(dp)                     :: NewP ! New pressure value.
    integer                      :: AuxWHD(3)

    ! Set scale.
    scale  = FldSlv % TimeStep / (FldSlv % srho * FldSlv % celsiz * FldSlv % celsiz)
    ! Set range for loops.
    AuxWHD = FldSlv % whd - 1

    ! ITERation Loop.
    iterl: do iter = 1, MaxIt
      Err = 0._dp
      idx = 0
      lz: do k = 0, AuxWHD(3)
        ! Loop over y.
        ly: do j = 0, AuxWHD(2)
          ! Loop over x.
          lx: do i = 0, AuxWHD(1)
            Diag    = 0._dp
            OffDiag = 0._dp

            ! Building the matrix as a five-point stencil. Solid borders, i.e. no fluid is outside of the simulation bounds.

            ! The pressure contribution for each cell depends on its 6 nearest othogonal neighbours.
            ! For example, cell a22 will receive contributions from cells a12, a23, a33 and a21.
            ! Boundary cells will only receive contributions from the orthogonally placed cells that are found within the simulation bounds. For example, cell a131 will only receive contributions from cells a121, a231 and a132, while cell a212 from cells a112, a222, a312, a211 and a213. This leads to the series of if statements found herein.

            ! y-axis
            ! ^   z-axis
            ! | /
            ! |__> x-axis
            !
            !                                 3 x 3 x 3 Cube
            !     Front plane                  Middle plane                 Back plane
            ! ----------------------      ----------------------      ----------------------
            ! | a131 | a231 | a331 |      | a132 | a232 | a332 |      | a133 | a233 | a333 |
            ! ----------------------      ----------------------      ----------------------
            ! | a121 | a221 | a321 |      | a122 | a222 | a322 |      | a123 | a223 | a323 |
            ! ----------------------      ----------------------      ----------------------
            ! | a111 | a211 | a311 |      | a112 | a212 | a312 |      | a113 | a213 | a313 |
            ! ----------------------      ----------------------      ----------------------
            !                                        |
            !                                        |
            !                                        | Mapped to
            !                                        |
            !                                        v
            ! [a111,a211,a311,a121,a221,a321,a131,a231,a331,a112,a212,a312,a122,a222,a322,a132,a232,a332,a113,a213,a313,a123,a223,a323,a133,a233,a333]

            ! Exclude Lower X Bound (Exclude cells a11, a12, a13 in the diagram).
            elxb: if (i > 0) then
              Diag    = Diag + scale
              OffDiag = OffDiag - scale * FldSlv % p(idx - 1)
            end if elxb

            ! Exclude Lower X Bound (Exclude cells a13, a23, a33 in the diagram).
            euxb: if (i < AuxWHD(1)) then
              Diag    = Diag + scale
              OffDiag = OffDiag - scale * FldSlv % p(idx + 1)
            end if euxb

            ! Exclude Upper Y Bound (Exclude cells a11, a12, 9 in the diagram).
            elyb: if (j > 0) then
              Diag    = Diag + scale
              OffDiag = OffDiag - scale * FldSlv % p(idx - FldSlv % whd(1))
            end if elyb

            ! Exclude Lower Y Bound (Exclude cells 1, 4, 7 in the diagram).
            euyb: if (j < AuxWHD(2)) then
              Diag    = Diag + scale
              OffDiag = OffDiag - scale * FldSlv % p(idx + FldSlv % whd(1))
            end if euyb

            elzb: if (k > 0) then
              Diag    = Diag + scale
              OffDiag = OffDiag - scale * FldSlv % p(idx - FldSlv % whd(1) * FldSlv % whd(2))
            end if elzb

            euzb: if (k < AuxWHD(3)) then
              Diag    = Diag + scale
              OffDiag = OffDiag - scale * FldSlv % p(idx + FldSlv % whd(1) * FldSlv % whd(2))
            end if euzb

            NewP = (FldSlv % prhs(idx) - OffDiag) / Diag

            Err = max(Err, abs(FldSlv % p(idx) - NewP))

            FldSlv % p(idx) = NewP
            idx = idx + 1
          end do lx
        end do ly
      end do lz

      if (Err < Derr) return
    end do iterl
  end subroutine GSPSlv3D
!==============================================================================!

!==============================================================================!
! Tested: 1D, 2D, 3D.
  pure function Lerp1D(FldQty, yi, x)
    ! Linear intERPolate in 1D.
    ! 1D interpolation between yi(1) < y < yi(4) for 0 < x < 1
    implicit none
    class(FluidQty), intent(in) :: FldQty
    real(dp)       , intent(in) :: yi(2), x
    real(dp)                    :: lerp1d

    Lerp1D = yi(1)*(1._dp - x) + yi(2)*x
  end function Lerp1D
!==============================================================================!

!==============================================================================!
  elemental function Lerp2D(FldQty, xi)
    implicit none
    class(FluidQty), intent(in) :: FldQty
    type(Vec2D)    , intent(in) :: xi ! xi%x(1) = x, xi%x(2) = y
    real(dp)                    :: Lerp2D
    real(dp)                    :: x(2)
    integer                     :: ix(2)
    real(dp)                    :: VtxVal(4) ! VALues at cell VERtices. VtxVal(1) = x00, VtxVal(2) = x10, VtxVal(3) = x01, VtxVal(4) = x11
    integer, parameter          :: ivtc(8) = [0,1,0,1,0,0,1,1] ! Index array of the cell vertex displacements.

    ! x01   -----------   x11
    !       |         |
    !       |         |
    !       |         |
    ! x00   -----------   x10

    ! Clamp coordinates to the boundaries.
    x = min( max(xi % x - FldQty % ost(1:2), 0._dp), real(FldQty % whd(1:2) - 1.001_dp, dp) )

    ! Prepare interpolation values.
    ix = aint( x )
    ! We make sure 0 < x < 1
    x  = x - ix

    ! Values at vertices.
    VtxVal = FldQty % ReadVal(ix(1) + ivtc(1:4), ix(2) + ivtc(5:8))

    Lerp2D = FldQty % Lerp(                        &
                [                                  &
                  ! Lower edge: x00, x10.
                  FldQty % Lerp(VtxVal(1:2),x(1)), &
                  ! Upper edge: x01, x11.
                  FldQty % Lerp(VtxVal(3:4),x(1))  &
                ],                                 &
                x(2)                               &
                          )
  end function Lerp2D
!==============================================================================!

!==============================================================================!
  elemental function Lerp3D(FldQty, xi)
    implicit none
    class(FluidQty), intent(in) :: FldQty
    type(Vec3D),     intent(in) :: xi! xi%x(1) = x, xi%x(2) = y, xi%x(3) = z
    real(dp)                    :: Lerp3D
    real(dp)                    :: x(3)
    integer                     :: ix(3)
    real(dp)                    :: VtxVal(8) ! Values at cell vertices. VtxVal(1) = x000, VtxVal(2) = x100, VtxVal(3) = x010, VtxVal(4) = x110, VtxVal(5) = x001, VtxVal(6) = x101, VtxVal(7) = x011, VtxVal(8) = x111
    integer, parameter          :: ivtc(24) = [0,1,0,1,0,1,0,1,0,0,1,1,0,0,1,1,0,0,0,0,1,1,1,1] ! Index array of the cell vertex displacements.

    !    x011   ------------- x111
    !          /|          /|
    !         / |         / |
    !        /  |        /  |
    ! x010  -------------   | x110
    !       |   |       |   |
    !  x001 |   --------|--- x101
    !       |  /        |  /
    !       | /         | /
    !       |/          |/
    ! x000  ------------- x100

    ! Clamp coordinates to the boundaries.
    x = min( max(xi % x - FldQty % ost(1:3), 0._dp), real(FldQty % whd(1:3) - 1.001_dp, dp) )

    ! Prepare interpolation values.
    ix = aint( x )
    ! We make sure 0 < x < 1
    x  = x - ix

    VtxVal = FldQty % ReadVal(ix(1) + ivtc(1:8), ix(2) + ivtc(9:16), ix(3) + ivtc(17:24))

    Lerp3D = FldQty % Lerp(                            &
                [                                      &
                  ! Front face x000, x100, x010, x110
                  FldQty % Lerp(                       &
                    [                                  &
                      ! Lower edge: x000, x100.
                      FldQty % Lerp(VtxVal(1:2),x(1)), &
                      ! Upper edge: x010, x110.
                      FldQty % Lerp(VtxVal(3:4),x(1))  &
                    ]                                , &
                    x(2)                               &
                               ),                      &
                  ! Back face x001, x101, x011, x111
                  FldQty % Lerp(                       &
                    [                                  &
                      ! Lower edge: x001, x101.
                      FldQty % Lerp(VtxVal(5:6),x(1)), &
                      ! Upper edge: x011, x111.
                      FldQty % Lerp(VtxVal(7:8),x(1))  &
                    ]                                , &
                    x(2)                               &
                              )                        &
                ],                                     &
                x(3)                                   &
                          )
  end function Lerp3D
!==============================================================================!

!==============================================================================!
  subroutine MaxTimestep2D(FldSlv, t)
    implicit none
    class(FluidSlv), intent(inout) :: FldSlv
    real(dp)       , intent(in)    :: t ! Time
    real(dp)                       :: MaxVel, RMSVel ! Max and Root-mean-squared (RMS) Velocity * sqrt(n) at the centre of the grid.
    integer                        :: i, j   ! Counters
    real(dp)                       :: ci, cj ! Center i, center j

    MaxVel = 0.

    ly: do j = 0, FldSlv % whd(2) - 1
      ! Half way to the next y-index.
      cj = j + 0.5
      lx: do i = 0, FldSlv % whd(1) - 1
        ! Half way to the next x-index.
        ci = i + 0.5
        ! Calculate the Root-mean-squared * sqrt(n). Dividing by sqrt(n) is unecessary because n >= 1.
        RMSVel =  sum( FldSlv % u % Lerp(Vec2D([ci, cj])) * FldSlv % u % Lerp(Vec2D([ci, cj])) )
        ! Compare to Maximal Velocity.
        if (RMSVel < MaxVel) cycle lx
        ! Update MaxVel
        MaxVel = RMSVel
      end do lx
    end do ly

    ! Fluid should not flow through more than one cell per iteration.
    FldSlv % TimeStep = FldSlv % safety * FldSlv % celsiz / sqrt(MaxVel)

    ! Clamp Time Step to be within Reasonable Bounds.
    ctsrb: if (FldSlv % TimeStep < FldSlv % MinTimeStep .or. t + FldSlv % TimeStep == t) then
      ! Increase Timestep.
      it: do
        FldSlv % TimeStep = FldSlv % TimeStep + FldSlv % MinTimeStep
        if (t + FldSlv % TimeStep > t) return
      end do it
    else if (FldSlv % TimeStep > FldSlv % MaxTimeStep) then ctsrb
      FldSlv % Timestep = (FldSlv % MinTimeStep + FldSlv % MaxTimeStep)/2.
    end if ctsrb
  end subroutine MaxTimestep2D

  subroutine MaxTimestep3D(FldSlv, t)
    implicit none
    class(FluidSlv), intent(inout) :: FldSlv
    real(dp)       , intent(in)    :: t ! Time
    real(dp)                       :: MaxVel, RMSVel ! Max and Root-mean-squared (RMS) Velocity * sqrt(n) at the centre of the grid.
    integer                        :: i, j, k    ! Counters
    real(dp)                       :: ci, cj, ck ! Center i, center j, center k

    MaxVel = 0.

    lz: do k = 0, FldSlv % whd(3) - 1
      ck = k + 0.5
      ly: do j = 0, FldSlv % whd(2) - 1
        ! Half way to the next y-index.
        cj = j + 0.5
        lx: do i = 0, FldSlv % whd(1) - 1
          ! Half way to the next x-index.
          ci = i + 0.5
          ! Calculate the Root-mean-squared * sqrt(n). Dividing by sqrt(n) is unecessary because n >= 1.
          RMSVel = sum( FldSlv % u % Lerp(Vec3D([ci, cj, ck])) * FldSlv % u % Lerp(Vec3D([ci, cj, ck])) )
          ! Compare to Maximal Velocity.
          cmv: if (RMSVel > MaxVel) then
            ! Update MaxVel
            MaxVel = RMSVel
          else cmv
            cycle lx
          end if cmv
        end do lx
      end do ly
    end do lz

    ! Fluid should not flow through more than one cell per iteration.
    FldSlv % TimeStep = FldSlv % safety * FldSlv % celsiz / sqrt(MaxVel)

    ! Clamp Time Step to be within Reasonable Bounds.
    ctsrb: if (FldSlv % TimeStep < FldSlv % MinTimeStep .or. t + FldSlv % TimeStep == t) then
      ! Increase Timestep.
      it: do
        FldSlv % TimeStep = FldSlv % TimeStep + FldSlv % MinTimeStep
        if (t + FldSlv % TimeStep > t) return
      end do it
    else if (FldSlv % TimeStep > FldSlv % MaxTimeStep) then ctsrb
      FldSlv % Timestep = (FldSlv % MinTimeStep + FldSlv % MaxTimeStep)/2.
    end if ctsrb
  end subroutine MaxTimestep3D

  subroutine FEulerVel2D(FldQty, FldVel, xi, xf, h)
    implicit none
    type(Vec2D)    , intent(in)  :: xi
    real(dp)       , intent(in)  :: h
    class(FluidQty), intent(in)  :: FldQty
    type(FluidQty) , intent(in)  :: FldVel(2)
    real(dp)       , intent(out) :: xf(2)
    real(dp)                     :: vel(2) ! Velocities.

    vel = FldVel % Lerp(xi) / FldQty % celsiz

    xf = xi % x - vel * h
  end subroutine FEulerVel2D

  subroutine FEulerVel3D(FldQty, FldVel, xi, xf, h)
    implicit none
    type(Vec3D)    , intent(in)  :: xi
    real(dp)       , intent(in)  :: h
    class(FluidQty), intent(in)  :: FldQty
    type(FluidQty) , intent(in)  :: FldVel(3)
    real(dp)       , intent(out) :: xf(3)
    real(dp)                     :: vel(3) ! Velocities.

    vel = FldVel % Lerp(xi) / FldQty % celsiz

    xf = xi % x - vel * h
  end subroutine FEulerVel3D

  subroutine Advect2D(FldQty, FldVel, h)
    implicit none
    class(FluidQty) , intent(inout) :: FldQty
    type(FluidQty2D), intent(in)    :: FldVel
    real(dp)        , intent(in)    :: h
    real(dp)                        :: x(2)
    integer                         :: i, j, idx

    ! Loop through y.
    idx = 0
    ly: do j = 0, FldQty % whd(2) - 1
      ! Loop through x.
      lx: do i = 0, FldQty % whd(1) - 1
        x(1) = i + FldQty % ost(1)
        x(2) = j + FldQty % ost(2)
        ! Integrate FldQty.
        call FldQty % FEuler(FldVel % FldQty(:), Vec2D(x), x, h)
        ! Interpolate component from grid and write new value.
        FldQty % new(idx) = FldQty % Lerp(Vec2D(x))
        print*, FldQty % new(idx)
        idx = idx + 1
      end do lx
    end do ly
  end subroutine Advect2D

  subroutine Advect3D(FldQty, FldVel, h)
    implicit none
    class(FluidQty) , intent(inout) :: FldQty
    type(FluidQty3D), intent(inout) :: FldVel
    real(dp)        , intent(in)    :: h
    real(dp)                        :: x(3)
    integer                         :: i, j, k

    ! Loop through z.
    lz: do k = 0, FldQty % whd(3) - 1
      ! Loop through y.
      ly: do j = 0, FldQty % whd(2) - 1
        ! Loop through x.
        lx: do i = 0, FldQty % whd(1) - 1
          x(1) = i + FldQty % ost(1)
          x(2) = j + FldQty % ost(2)
          x(3) = k + FldQty % ost(3)
          ! Integrate FldQty.
          call FldQty % FEuler(FldVel % FldQty(:), Vec3D(x), x, h)
          ! Interpolate component from grid and save the new value.
          call FldQty % WriteNewVal(i, j, k, FldQty % Lerp(Vec3D(x)))
        end do lx
      end do ly
    end do lz
  end subroutine Advect3D

  subroutine ApplyPressure2D(FldSlv)
    implicit none
    class(FluidSlv), intent(inout) :: FldSlv
    real(dp)                       :: scale, sxp ! Scale, scale x pressure.
    integer                        :: i, j, ip1, jp1, idx, idxxp1, idxyp1

    scale = FldSlv % TimeStep / (FldSlv % srho * FldSlv % celsiz)
    !print*, scale

    ! Applies pressure and updates the velocity field.
    idx = 0
    ly: do j = 0, FldSlv % whd(2) - 1
      jp1 = j + 1
      idxxp1 = FldSlv % whd(1) * j
      idxyp1 = FldSlv % whd(1) * jp1
      lx: do i = 0, FldSlv % whd(1) - 1
        ip1 = i + 1
        idxxp1 = ip1 + idxxp1
        idxyp1 = i   + idxyp1
        sxp = scale * FldSlv % p(idx)
        call FldSlv % u % WriteOldVal(i, j, FldSlv % u % ReadVal(i, j) - sxp)
        call FldSlv % u(1) % WriteOldVal(ip1, j  , FldSlv % u(1) % ReadVal(ip1, j  ) + sxp)
        call FldSlv % u(2) % WriteOldVal(i  , jp1, FldSlv % u(2) % ReadVal(i  , jp1) + sxp)
        idx = idx + 1
      end do lx
    end do ly
    ! Set boundary velocities to zero (conservation of mass, nothing comes in or goes out).

    !                               at ix \in [1, width] and iy = height
    !                                              Vy = 0
    !
    !                                           ^     ^     ^
    !                                           |     |     |
    !                             (x0,y1) ------------------------- (x1,y1)
    !                                     |     |     |     |     |
    !                                     |     v     v     v     |
    !                                     |                       |
    !at ix = 1 and iy \in [1, height] <---|--->               <---|--->  at ix = width and iy \in [1, height]
    !            Vx = 0                   |                       |                   Vx = 0
    !                                 <---|--->               <---|--->
    !                                     |                       |
    !                                     |     ^     ^     ^     |
    !                                     |     |     |     |     |
    !                             (x0,y0) ------------------------- (x1,y0)
    !                                           |     |     |
    !                                           v     v     v
    !
    !                                  at ix \in [1, width] and iy = 1
    !                                              Vy = 0

    ! Vertical boundaries.
    !dir$ parallel
    !dir$ loop count min(128)
    vb: do j = 0, FldSlv % whd(2) - 1
      ! Lower x boundary.
      call FldSlv % u(1) % WriteOldVal(0, j, 0._dp)
      ! Upper x boundary
      call FldSlv % u(1) % WriteOldVal(FldSlv % whd(1), j, 0._dp)
    end do vb

    ! Horizontal boundaries.
    !dir$ parallel
    !dir$ loop count min(128)
    hb: do i = 0, FldSlv % whd(1) - 1
      ! Lower y boundary.
      call FldSlv % u(2) % WriteOldVal(i, 0, 0._dp)
      ! Upper y boundary
      call FldSlv % u(2) % WriteOldVal(i, FldSlv % whd(2), 0._dp)
    end do hb

  end subroutine ApplyPressure2D

  subroutine ApplyPressure3D(FldSlv)
    implicit none
    class(FluidSlv), intent(inout) :: FldSlv
    real(dp)                       :: scale, sxp ! Scale, scale x pressure.
    integer                        :: i, j, k, ip1, jp1, kp1, idx

    scale = FldSlv % TimeStep / (FldSlv % srho * FldSlv % celsiz)

    ! Applies pressure and updates the velocity field.
    idx = 0
    lz: do k = 0, FldSlv % whd(3) - 1
      kp1 = k + 1
      ly: do j = 0, FldSlv % whd(2) - 1
        jp1 = j + 1
        lx: do i = 0, FldSlv % whd(1) - 1
          ip1 = i + 1
          sxp = scale * FldSlv % p(idx)
          ! Update velocity field.init
          call FldSlv % u % WriteOldVal(i, j, k, FldSlv % u % ReadVal(i, j, k) - sxp)
          call FldSlv % u(1) % WriteOldVal(ip1, j  , k  , FldSlv % u(1) % ReadVal(ip1, j  , k  ) + sxp)
          call FldSlv % u(2) % WriteOldVal(i  , jp1, k  , FldSlv % u(2) % ReadVal(i  , jp1, k  ) + sxp)
          call FldSlv % u(3) % WriteOldVal(i  , j  , kp1, FldSlv % u(3) % ReadVal(i  , j  , kp1) + sxp)
          idx = idx + 1
        end do lx
      end do ly
    end do lz

    ! Set boundary velocities to zero (conservation of mass, nothing comes in or goes out).
    !        (x0,y1,z1)      -------------------------- (x1,y1,z1)
    !                       /|                       /|
    !                      / |        ^             / |
    !                     /  |        | Vy = 0     /  |
    !                    /   |        |    Vz = 0 /   |
    !                   /    |        |     ↗    /    |
    !                  /     |        |    /    /     |
    !     (x0,y1,z0)  --------------------------      | (x1,y1,z0)
    !                 |      |        v  /     |      |
    !          Vx = 0 |      |          /      |      |  Vx = 0
    !      <----------| ---------->    ↙  <----|----- ----------->
    !                 |      |                 |      |
    !                 |      |       ↗         |      |
    !                 |      |      /          |      |
    !      (x0,y0,z1) |      ------/-----------|------ (x1,y0,z1)
    !                 |     /     /            |     /
    !                 |    /     ↙   ^         |    /
    !                 |   /  Vz = 0  | Vy = 0  |   /
    !                 |  /           |         |  /
    !                 | /                      | /
    !                 |/             |         |/
    !     (x0,y0,z0)  -------------------------- (x1,y0,z0)
    !                                |
    !                                v

    !          XY Front Plane                         XY Back Plane
    ! (x0,y1,z0) ----------- (x1,y1,z0)     (x0,y1,z1) ----------- (x1,y1,z1)
    !            |         |                           |         |
    !            |         |                           |         |
    !            |         |                           |         |
    ! (x0,y0,z0) ----------- (x1,y0,z0)     (x0,y0,z1) ----------- (x1,y0,z1)
    ! Perpendicular velocity is Vz = u(3).
    ! Front Plane: At iz = 1, x \in [1, width] and y \in [1, height], Vz = 0
    ! Back Plane: At iz = depth, x \in [1, width] and y \in [1, height], Vz = 0

    !           YZ Left Plane                        YZ Right Plane
    ! (x0,y1,z1) ----------- (x0,y1,z0)     (x1,y1,z1) ----------- (x1,y1,z0)
    !            |         |                           |         |
    !            |         |                           |         |
    !            |         |                           |         |
    ! (x0,y0,z1) ----------- (x0,y0,z0)     (x1,y0,z1) ----------- (x1,y0,z0)
    ! Perpendicular velocity is Vx = u(1).
    ! Front Plane: At ix = 1, z \in [1, depth] and y \in [1, height], Vx = 0
    ! Back Plane: At ix = width, z \in [1, depth] and y \in [1, height], Vx = 0

    !          XZ Bottom Plane                        XZ Top Plane
    ! (x0,y0,z1) ----------- (x1,y0,z1)     (x0,y1,z1) ----------- (x1,y1,z1)
    !            |         |                           |         |
    !            |         |                           |         |
    !            |         |                           |         |
    ! (x0,y0,z0) ----------- (x1,y0,z0)     (x0,y1,z0) ----------- (x1,y1,z0)
    ! Perpendicular velocity is Vy = u(2).
    ! Front Plane: At iy = 1, z \in [1, depth] and x \in [1, widht], Vy = 0
    ! Back Plane: At iy = height, z \in [1, depth] and x \in [1, widht], Vy = 0

    ! XY Plane Boundaries
    ! Loop through y
    !dir$ parallel
    !dir$ loop count min(64)
    ly2: do j = 0, FldSlv % whd(2) - 1
      ! Loop through x.
      !dir$ parallel
      !dir$ loop count min(64)
      lx2: do i = 0, FldSlv % whd(1) - 1
        ! Front XY plane (iz = 1)
        call FldSlv % u(3) % WriteOldVal(i, j, 1, 0._dp)
        ! Back XY plane (iz = whd(3))
        call FldSlv % u(3) % WriteOldVal(i, j, FldSlv % whd(3), 0._dp)
      end do lx2
    end do ly2

    ! YZ Plane Boundaries.
    ! Loop through z.
    !dir$ parallel
    !dir$ loop count min(64)
    lz2: do k = 0, FldSlv % whd(3) - 1
      ! Loop through y.
      !dir$ parallel
      !dir$ loop count min(64)
      ly3: do j = 0, FldSlv % whd(2) - 1
        ! Left YZ plane (ix = 1)
        call FldSlv % u(1) % WriteOldVal(1, j, k, 0._dp)
        ! Right YZ plane (ix = whd(1))
        call FldSlv % u(1) % WriteOldVal(FldSlv % whd(1), j, k, 0._dp)
      end do ly3
    end do lz2

    ! XZ Plane Boundaries.
    ! Loop through z.
    !dir$ parallel
    !dir$ loop count min(4)
    lz3: do k = 0, FldSlv % whd(3) - 1
      ! Loop through x.
      !dir$ ivdep
      lx3: do i = 0, FldSlv % whd(1) - 1
        ! Bottom XZ plane (iy = 1)
        call FldSlv % u(2) % WriteOldVal(i, 1, k, 0._dp)
        ! Top XZ plane (iy = whd(2))
        call FldSlv % u(2) % WriteOldVal(i, FldSlv % whd(2), k, 0._dp)
      end do lx3
    end do lz3
  end subroutine ApplyPressure3D

  pure function ReadArray2D(FldSlv, array, i, j)
    implicit none
    class(FluidSlv), intent(in) :: FldSlv
    real(dp),        intent(in) :: array(0:)
    integer,         intent(in) :: i, j
    real(dp)                    :: ReadArray2D

    ReadArray2D = array(i + FldSlv % whd(1)*j)
  end function ReadArray2D

  pure function ReadArray3D(FldSlv, array, i, j, k)
    implicit none
    class(FluidSlv), intent(in) :: FldSlv
    real(dp),        intent(in) :: array(0:)
    integer,         intent(in) :: i, j, k
    real(dp)                    :: ReadArray3D

    ReadArray3D = array(i + FldSlv % whd(1)*j + FldSlv % whd(1)*k)
  end function ReadArray3D

  pure subroutine WriteArray2D(FldSlv, array, i, j, value)
    implicit none
    class(FluidSlv), intent(in) :: FldSlv
    real(dp),        intent(inout) :: array(0:)
    integer,         intent(in) :: i, j
    real(dp),        intent(in) :: value

    array(i + FldSlv % whd(1)*j) = value
  end subroutine WriteArray2D

  pure subroutine WriteArray3D(FldSlv, array, i, j, k, value)
    implicit none
    class(FluidSlv), intent(in) :: FldSlv
    real(dp),        intent(inout) :: array(0:)
    integer,         intent(in) :: i, j, k
    real(dp),        intent(in) :: value

    array(i + FldSlv % whd(1)*j + FldSlv % whd(1)*k) = value
  end subroutine WriteArray3D

  elemental function ReadVal2D(FldQty, i, j)
    implicit none
    integer,         intent(in) :: i, j
    class(FluidQty), intent(in) :: FldQty
    real(dp)                    :: ReadVal2D

    ReadVal2D = FldQty % old(i + FldQty % whd(1)*j)
  end function ReadVal2D

  elemental function ReadVal3D(FldQty, i, j, k)
    implicit none
    integer,         intent(in) :: i, j, k
    class(FluidQty), intent(in) :: FldQty
    real(dp)                    :: ReadVal3D

    ReadVal3D = FldQty % old(i + FldQty % whd(1)*j + FldQty % whd(1) * FldQty % whd(2)*k)
  end function ReadVal3D

  elemental subroutine WriteNewVal2D(FldQty, i, j, NewVal)
    implicit none
    integer,         intent(in)    :: i, j
    real(dp),        intent(in)    :: NewVal
    class(FluidQty), intent(inout) :: FldQty

    FldQty % new(i + FldQty % whd(1)*j) = NewVal
  end subroutine WriteNewVal2D

  elemental subroutine WriteNewVal3D(FldQty, i, j, k, NewVal)
    implicit none
    integer,         intent(in)    :: i, j, k
    real(dp),        intent(in)    :: NewVal
    class(FluidQty), intent(inout) :: FldQty

    FldQty % new(i + FldQty % whd(1)*j + FldQty % whd(1) * FldQty % whd(2)*k) = NewVal
  end subroutine WriteNewVal3D

  elemental subroutine WriteOldVal2D(FldQty, i, j, NewVal)
    implicit none
    integer,         intent(in)    :: i, j
    real(dp),        intent(in)    :: NewVal
    class(FluidQty), intent(inout) :: FldQty

    FldQty % old(i + FldQty % whd(1)*j) = NewVal
  end subroutine WriteOldVal2D

  elemental subroutine WriteOldVal3D(FldQty, i, j, k, NewVal)
    implicit none
    integer,         intent(in)    :: i, j, k
    real(dp),        intent(in)    :: NewVal
    class(FluidQty), intent(inout) :: FldQty

    FldQty % old(i + FldQty % whd(1)*j + FldQty % whd(1) * FldQty % whd(2)*k) = NewVal
  end subroutine WriteOldVal3D

  elemental subroutine UpdateVals(FldQty)
    implicit none
    class(FluidQty), intent(inout) :: FldQty
    !dir$ loop count min(256)
    FldQty % old = FldQty % new
    !dir$ loop count min(512)
    FldQty % new = 0.
  end subroutine UpdateVals

  subroutine WriteToFile(FldSlv, unit)
    class(FluidSlv), intent(in)   :: FldSlv
    integer, intent(in), optional :: unit
    integer, allocatable, save    :: ndim
    integer :: i

    if(.not. allocated(ndim)) allocate(ndim, source = size(FldSlv % whd))

    ! Check if Unit is Present.
    cup: if (present(unit)) then
      ! Select Unit.
      su: select case (unit)
        case (1) su
          ! Print density.
          open(unit=unit, file="density.dat", status="replace", access="stream")
          write(unit) FldSlv % rho % old
          close(unit=unit)
        case (2) su
          ! Print velocities.
          open(unit=unit, file="velocity.dat", status="replace", access="stream")
          ! Loop through the Number of DIMensions.
          lndim: do i = 1, ndim
            write(unit) FldSlv % u(i) % old
          end do lndim
          close(unit=unit)
        case (3) su
          ! Print pressures.
          open(unit=unit, file="pressure.dat", status="replace", access="stream")
          write(unit) FldSlv % p
          close(unit=unit)
      end select su
    else cup
      ! If unit is not present. Print everything.
      open(unit=1, file="density.dat", status="replace", access="stream")
      write(1) FldSlv % rho % old
      close(unit=1)

      open(unit=2, file="velocity.dat", status="replace", access="stream")
      ! Loop through the Number of DIMensions.
      lndim2: do i = 1, ndim
        write(2) FldSlv % u(i) % old
      end do lndim2
      close(unit=2)

      open(unit=3, file="pressure.dat", status="replace", access="stream")
      write(3) FldSlv % p
      close(unit=3)
    end if cup
  end subroutine WriteToFile

end module fluid


!
!     ------------------------------------------------------------
!     I N I T M 2
!     ------------------------------------------------------------
!
!     Determine the Rydberg constant, RMASS constant, and
!     initialize the radial grid
!
      SUBROUTINE INITM2(IPROB)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE INOUT_C
      USE PARAM_C
      USE RADIAL_C
      USE RYDBERG_C
      USE COR_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  15:58:56  11/18/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   G l o b a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: IPROB
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      INTEGER, PARAMETER :: NWD = 128
      INTEGER, PARAMETER :: NELEMENT = 50
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: J
      REAL , DIMENSION(NELEMENT) :: MN
      REAL, DIMENSION(NELEMENT - 9) :: FZ
      REAL(DOUBLE) :: ME, RY
      CHARACTER :: YES
!-----------------------------------------------
!
!
      DATA ME/ 548.579903D-6/
      DATA RY/ 109737.31534/
      DATA MN/ 1, 4, 7, 9, 11, 12, 14, 16, 19, 20, 23, 24, 27, 28, 31, 32, 35, &
         40, 39, 40, 45, 48, 51, 52, 55, 56, 59, 58, 63, 64, 69, 74, 75, 80, 79&
         , 84, 85, 88, 89, 90, 93, 98, 99, 102, 103, 108, 107, 114, 115, 120/
!
      DATA FZ/ 163.5, 198.4, 239.6, 283.9, 332.7, 386.1, 444.2, 507.8, 576.4, &
         650.7, 731.2, 817.9, 911.2, 1011.4, 1119.3, 1234.9, 1359.3, 1491.9, &
         1634.4, 1786.6, 1948.7, 2122.7, 2308.2, 2507.4, 2718.5, 2944.3, 3187.5&
         , 3442.2, 3720.3, 4015.4, 4326.6, 4664.8, 5022.4, 5405.9, 5811.9, &
         6245.0, 6706.8, 7201.3, 7728.7, 8296.5, 8889.3/
!

!
! ****   DETERMINE THE RYDBERG CONSTANT AND F(Z) PARAMETER
!
      WRITE (ISCW, '(/1X,A)') ' Default Rydberg constant (y/n)'
!      READ(iread,'(A1)') YES
      YES = 'y'
      IF (YES=='Y' .OR. YES=='y' .AND. INT(Z)<=NELEMENT) THEN
         ZMU = MN(INT(Z))
      ELSE
         WRITE (ISCW, '(1X,A)') 'Enter the mass of the atom'
!         READ(iread,*) ZMU
         ZMU = 200
      ENDIF
      RYDBRG = RY/(1. + ME/ZMU)
      WRITE (6, *) ' Rydberg constant used (cm-1) = ', RYDBRG
      WRITE (6, *)
      IF (IPROB /= 1) THEN
         IF (INT(Z) < 10) THEN
            FZE = 1.566432
         ELSE IF (INT(Z) <= NELEMENT) THEN
            FZE = FZ(INT(Z-9))
         ELSE
            WRITE (ISCW, '(1X,A)') 'Enter the f(Z) value in MHz'
            READ (IREAD, *) FZE
         ENDIF
      ENDIF
      RMASS = ME/ZMU
!
! ****  INITIALIZE THE RADIAL GRID
!
      RHO = -4.0
      DO J = 1, NO
         R(J) = DEXP(RHO)/Z
         RR(J) = R(J)*R(J)
         R2(J) = DSQRT(R(J))
         RHO = RHO + H
      END DO
      RETURN
      END SUBROUTINE INITM2