MODULE mo_ice_shape
  USE mo_submctl, ONLY : spec,pi6,pi
  IMPLICIT NONE

  ! -----------------------------------------------
  ! Container for functions describing the
  ! mass-diameter relationships of particles
  ! -----------------------------------------------

  ! Suggested values for shape parameters for non-spherical ice from Khvorostyanov and Curry 2002
  ! for "Crystal with sector-like branches". Can be specified from SALSA namelist. Mass coeffs changed
  ! to SI units. Also make sure to use SI units when specifying these in the namelist. Pretty much all the
  ! articles report these in non-SI units!

  ! For Mass:
  REAL, SAVE :: iceShapeAlpha = 15.56999e-3
  REAL, SAVE :: iceShapeBeta = 2.02

  ! For cross sectional area
  REAL, SAVE :: iceShapeGamma = 0.55
  REAL, SAVE :: iceShapeSigma = 1.97

  TYPE t_shape_coeffs
     REAL :: alpha, beta, gamma, sigma
  END TYPE t_shape_coeffs

  CONTAINS
    !
    !
    !
    !
    FUNCTION getDiameter(mpri,mrim,numc)
      REAL, INTENT(in) :: mpri, mrim
      REAL, INTENT(in) :: numc
      REAL :: getDiameter

      REAL :: Mtot,     &
              Dth,Mth,      &
              Dgr,Mgr,      &
              Dcr,Mcr,      &
              rho_b,    &
              Fr

      getDiameter = 1.e-9

      IF (numc < 1.e-6) RETURN

      Mtot = ( mpri + mrim )/numc

      Fr = MAX( MIN(mrim/(Mtot*numc),0.99),0.01 )
      rho_b = getBulkRho(Fr)  ! "almost" like graupel density...
      Dth = (pi6*spec%rhoic/iceShapeAlpha)**(1./(iceShapeBeta-3.))
      Dgr = (iceShapeAlpha/(pi6*rho_b))**(1./(3.-iceShapeBeta))
      Dcr = ( (1./(1.-Fr))*iceShapeAlpha/(pi6*rho_b) )**(1./(3.-iceShapeBeta))
      Mth = spec%rhoic*pi6*Dth**3
      Mgr = rho_b*pi6*Dgr**3
      Mcr = rho_b*pi6*Dcr**3

      IF (Mgr < Mth .OR. Mgr > Mcr) WRITE(*,*) 'ICE SHAPE VAARIN', Dth, Dgr, Dcr

      IF ( Mtot < Mth ) THEN
         ! Small spherical particles
         getDiameter = D_spherical(spec%rhoic,Mtot)
      ELSE IF (Mtot >= Mth .AND. Mtot < Mgr) THEN
         ! Dense non-spherical
         getDiameter = D_nonsphericalIce(Mtot)
      ELSE IF (Mtot >= Mgr .AND. Mtot < Mcr) THEN
         ! Graupel
         getDiameter = D_spherical(rho_b,Mtot)
      ELSE IF (Mtot > Mcr) THEN
         ! Partially rimed crystals
         getDiameter = D_nonsphericalRimed(Fr,Mtot)
      ELSE
         WRITE(*,*) 'ICE SHAPE VAARIN 2'
      END IF

    END FUNCTION getDiameter

    !
    !-------------------------------------------------------------
    ! Function getBulkRho
    ! Gets the bulk ice density based on the particle's rime fraction
    ! Note that this simplifies Morrison and Milbrandt 2015 by neglecting
    ! the Eq 17 since at the moment we cannot afford iteration. Thus just
    ! use the bulk rime density. This will reduce some of the response of
    ! the size limits between graupel and non-spherical ice, but this effect
    ! should in most case be secondary to the effect of rime fraction. But still,
    ! this is not the full implementation!
    !
    REAL FUNCTION getBulkRho(Fr)
      REAL, INTENT(in) :: Fr
      getBulkRho = spec%rhori !Fr*spec%rhori + (1.-Fr)*spec%rhoic
    END FUNCTION getBulkRho
    !
    !-------------------------------------------------------------
    ! Function D_nonsphericalIce
    ! Get the diameter (~maximum particle dimension) of non-spherical
    ! ice particles using the coefficients for an m-D relationship.
    !
    REAL FUNCTION D_nonsphericalIce(mass)
      REAL, INTENT(in) :: mass
      D_nonsphericalIce = ( mass/iceShapeAlpha )**(1./iceShapeBeta)
    END FUNCTION D_nonsphericalIce
    !
    !-------------------------------------------------------------
    ! Function D_nonsphericalRimed
    ! Same as above but for large rimed particles
    !
    REAL FUNCTION D_nonsphericalRimed(Fr,mass)
      REAL, INTENT(in) :: Fr
      REAL, INTENT(in) :: mass
      REAL :: hlp
      hlp = 1./(1.-Fr)
      D_nonsphericalRimed = ( mass/(hlp*iceShapeAlpha) )**(1./iceShapeBeta)
    END FUNCTION D_nonsphericalRimed

    !
    !-------------------------------------------------------------
    ! Function D_spherical
    ! Get the diameter of a regular spherical particle with
    ! given density
    !
    REAL FUNCTION D_spherical(rho,mass)
      REAL, INTENT(in) :: rho
      REAL, INTENT(in) :: mass
      D_spherical = ( mass/(pi6*rho) )**(1./3.)
    END FUNCTION D_spherical

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

    SUBROUTINE getShapeCoefficients(ishape,mpri,mrim,numc)
      TYPE(t_shape_coeffs), INTENT(out) :: ishape
      REAL, INTENT(in) :: mpri, mrim
      REAL, INTENT(in) :: numc

      REAL :: Mtot,     &
              Dth,Mth,      &
              Dgr,Mgr,      &
              Dcr,Mcr,      &
              rho_b,    &
              Fr

      ! Initially, set values for spherical
      ishape%alpha = pi6*spec%rhoic
      ishape%beta = 3.
      ishape%gamma = pi/4.
      ishape%sigma = 2.

      IF (numc < 1.e-6) RETURN

      Mtot = ( mpri + mrim )/numc

      Fr = MAX( MIN(mrim/(Mtot*numc),0.99),0.01 )
      rho_b = getBulkRho(Fr)  ! "almost" like graupel density...
      Dth = (pi6*spec%rhoic/iceShapeAlpha)**(1./(iceShapeBeta-3.))
      Dgr = (iceShapeAlpha/(pi6*rho_b))**(1./(3.-iceShapeBeta))
      Dcr = ( (1./(1.-Fr))*iceShapeAlpha/(pi6*rho_b) )**(1./(3.-iceShapeBeta))
      Mth = spec%rhoic*pi6*Dth**3
      Mgr = rho_b*pi6*Dgr**3
      Mcr = rho_b*pi6*Dcr**3

      ! Modify values for non-spherical particles
      IF ( (Mtot >= Mth .AND. Mtot < Mgr) .OR. (Mtot > Mcr) ) THEN
         ishape%alpha = iceShapeAlpha; ishape%beta = iceShapeBeta
         ishape%gamma = iceShapeGamma; ishape%sigma = iceShapeSigma
      END IF

    END SUBROUTINE getShapeCoefficients

END MODULE mo_ice_shape


SUBROUTINE bmat_nonaxi(bee,radius,coord,deriv,fun,iflag,lth)
!
! This subroutine forms the strain-displacement matrix for
! axisymmetric solids subjected to non-axisymmetric loading.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::deriv(:,:),fun(:),coord(:,:)
 REAL(iwp),INTENT(OUT)::bee(:,:),radius
 INTEGER,INTENT(IN)::iflag,lth
 INTEGER::nod,k,l,m,n
 nod=UBOUND(deriv,2)
 bee=0.0_iwp
 radius=SUM(fun*coord(:,1))
 DO m=1,nod
   n=3*m
   k=n-1
   l=k-1
   bee(1,l)=deriv(1,m)
   bee(2,k)=deriv(2,m)
   bee(3,l)=fun(m)/radius
   bee(3,n)=iflag*lth*bee(3,l)
   bee(4,l)=deriv(2,m)
   bee(4,k)=deriv(1,m)
   bee(5,k)=-iflag*lth*fun(m)/radius
   bee(5,n)=deriv(2,m)
   bee(6,l)=bee(5,k)
   bee(6,n)=deriv(1,m)-fun(m)/radius
 END DO
RETURN
END SUBROUTINE bmat_nonaxi


!   =====================================================
subroutine rpt2(ixy,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,asdq,bmasdq,bpasdq)
!   =====================================================
    implicit double precision (a-h,o-z)

!     # Riemann solver in the transverse direction for the acoustics equations.

!     # auxN(1,i) holds rho
!     # auxN(2,i) holds c
!     #  N = 1 for row below
!     #      2 for this row
!     #      3 for row above

!     # Split asdq into down-going flux bmasdq and up-going flux bpasdq.

    dimension     ql(meqn, 1-mbc:maxm+mbc)
    dimension     qr(meqn, 1-mbc:maxm+mbc)
    dimension   asdq(meqn, 1-mbc:maxm+mbc)
    dimension bmasdq(meqn, 1-mbc:maxm+mbc)
    dimension bpasdq(meqn, 1-mbc:maxm+mbc)
    dimension   aux1(maux, 1-mbc:maxm+mbc)
    dimension   aux2(maux, 1-mbc:maxm+mbc)
    dimension   aux3(maux, 1-mbc:maxm+mbc)

    if (ixy == 1) then
        mu = 2
        mv = 3
    else
        mu = 3
        mv = 2
    endif

    do 20 i = 2-mbc, mx+mbc

!        # imp is used to flag whether wave is going to left or right,
!        # since material properties are different on the two sides

        if (imp == 1) then
!            # asdq = amdq, moving to left
            i1 = i-1
        else
!            # asdq = apdq, moving to right
            i1 = i
        endif

!        # The flux difference asdq is split into downward moving part
!        # traveling at speed -c relative to the medium below and
!        # an upward moving part traveling
!        # at speed +c relative to the medium above.

!        # Note that the sum of these parts does not give all of asdq
!        # since there is also reflection at the interfaces which decreases
!        # the flux.

!        # sound speed in each row of cells:
        cm = aux1(2,i1)
        c = aux2(2,i1)
        cp = aux3(2,i1)

!        # impedances:
        zm = aux1(1,i1)*aux1(2,i1)
        zz = aux2(1,i1)*aux2(2,i1)
        zp = aux3(1,i1)*aux3(2,i1)

    !        # transmitted part of down-going wave:
        a1 = (zz*asdq(1,i) + asdq(mv,i)) / (zz + zm)

!        # transmitted part of up-going wave:
        a2 = (asdq(1,i)*zz - asdq(mv,i)) / (zp + zz)

    !        # The down-going flux difference bmasdq is the product  -c * wave

        bmasdq(1,i) = -cm * a1
        bmasdq(mu,i) = 0.d0
        bmasdq(mv,i) = -cm * a1 * zm

    !        # The up-going flux difference bpasdq is the product  c * wave

        bpasdq(1,i) = cp * a2
        bpasdq(mu,i) = 0.d0
        bpasdq(mv,i) = -cp * a2 * zp

    20 END DO

    return
    end subroutine rpt2


      SUBROUTINE slECMA (DATE, RMAT)
*+
*     - - - - - -
*      E C M A
*     - - - - - -
*
*  Form the equatorial to ecliptic rotation matrix - IAU 1980 theory
*  (double precision)
*
*  Given:
*     DATE     dp         TDB (loosely ET) as Modified Julian Date
*                                            (JD-2400000.5)
*  Returned:
*     RMAT     dp(3,3)    matrix
*
*  Reference:
*     Murray,C.A., Vectorial Astrometry, section 4.3.
*
*  Note:
*    The matrix is in the sense   V(ecl)  =  RMAT * V(equ);  the
*    equator, equinox and ecliptic are mean of date.
*
*  Called:  slDEUL
*
*  P.T.Wallace   Starlink   23 August 1996
*
*  Copyright (C) 1996 Rutherford Appleton Laboratory
*
*  License:
*    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 2 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 (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION DATE,RMAT(3,3)

*  Arc seconds to radians
      DOUBLE PRECISION AS2R
      PARAMETER (AS2R=0.484813681109535994D-5)

      DOUBLE PRECISION T,EPS0

*  Interval between basic epoch J2000.0 and current epoch (JC)
      T = (DATE-51544.5D0)/36525D0

*  Mean obliquity
      EPS0 = AS2R*
     :   (84381.448D0+(-46.8150D0+(-0.00059D0+0.001813D0*T)*T)*T)

*  Matrix
      CALL slDEUL('X',EPS0,0D0,0D0,RMAT)

      END


c     ==================================================================
      subroutine setaux(mbc,mx,my,xlower,ylower,
     &                  dx,dy,maux,aux)
c     ==================================================================
c
c     # set auxiliary arrays
c
c     # acoustics in a heterogeneous medium:
c     #  aux(i,j,1) = impedance Z in (i,j) cell
c     #  aux(i,j,2) = sound speed c in (i,j) cell
c
c

      implicit double precision (a-h,o-z)
      double precision aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)
      common /comaux/ p1,c1,p2,c2

      do j = 1-mbc,my+mbc
        do i = 1-mbc,mx+mbc
            xcell = xlower + (i-0.5d0)*dx

            if (xcell .lt. 0.d0) then
                aux(1,i,j) = p1
                aux(2,i,j) = c1
            else
                aux(1,i,j) = p2
                aux(2,i,j) = c2
            endif
        enddo
      enddo

      return
      end


C FISHPAK8 FROM PORTLIB                                  12/30/83
      SUBROUTINE HSTPLR (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1                   ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C      HSTPLR SOLVES THE STANDARD FIVE-POINT FINITE DIFFERENCE
C      APPROXIMATION ON A STAGGERED GRID TO THE HELMHOLTZ EQUATION IN
C      POLAR COORDINATES
C
C      (1/R)(D/DR)(R(DU/DR)) + (1/R**2)(D/DTHETA)(DU/DTHETA)
C
C                      + LAMBDA*U = F(R,THETA)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C             * * * * * *   ON INPUT    * * * * * *
C
C    A,B
C      THE RANGE OF R, I.E. A .LE. R .LE. B.  A MUST BE LESS THAN B AND
C      A MUST BE NON-NEGATIVE.
C
C    M
C      THE NUMBER OF GRID POINTS IN THE INTERVAL (A,B).  THE GRID POINTS
C      IN THE R-DIRECTION ARE GIVEN BY R(I) = A + (I-0.5)DR FOR
C      I=1,2,...,M WHERE DR =(B-A)/M.  M MUST BE GREATER THAN 2.
C
C    MBDCND
C      INDICATES THE TYPE OF BOUNDARY CONDITIONS AT R = A AND R = B.
C
C      = 1  IF THE SOLUTION IS SPECIFIED AT R = A AND R = B.
C
C      = 2  IF THE SOLUTION IS SPECIFIED AT R = A AND THE DERIVATIVE
C           OF THE SOLUTION WITH RESPECT TO R IS SPECIFIED AT R = B.
C           (SEE NOTE 1 BELOW)
C
C      = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO R IS
C           SPECIFIED AT R = A (SEE NOTE 2 BELOW) AND R = B.
C
C      = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO R IS
C           SPECIFIED AT R = A (SEE NOTE 2 BELOW) AND THE SOLUTION IS
C           SPECIFIED AT R = B.
C
C      = 5  IF THE SOLUTION IS UNSPECIFIED AT R = A = 0 AND THE SOLUTION
C           IS SPECIFIED AT R = B.
C
C      = 6  IF THE SOLUTION IS UNSPECIFIED AT R = A = 0 AND THE
C           DERIVATIVE OF THE SOLUTION WITH RESPECT TO R IS SPECIFIED AT
C           R = B.
C
C      NOTE 1:  IF A = 0, MBDCND = 2, AND NBDCND = 0 OR 3, THE SYSTEM OF
C               EQUATIONS TO BE SOLVED IS SINGULAR.  THE UNIQUE SOLUTION
C               IS DETERMINED BY EXTRAPOLATION TO THE SPECIFICATION OF
C               U(0,THETA(1)).  BUT IN THIS CASE THE RIGHT SIDE OF THE
C               SYSTEM WILL BE PERTURBED BY THE CONSTANT PERTRB.
C
C      NOTE 2:  IF A = 0, DO NOT USE MBDCND = 3 OR 4, BUT INSTEAD USE
C               MBDCND = 1,2,5, OR 6.
C
C    BDA
C      A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT SPECIFIES THE BOUNDARY
C      VALUES (IF ANY) OF THE SOLUTION AT R = A.  WHEN MBDCND = 1 OR 2,
C
C               BDA(J) = U(A,THETA(J)) ,          J=1,2,...,N.
C
C      WHEN MBDCND = 3 OR 4,
C
C               BDA(J) = (D/DR)U(A,THETA(J)) ,    J=1,2,...,N.
C
C      WHEN MBDCND = 5 OR 6, BDA IS A DUMMY VARIABLE.
C
C    BDB
C      A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT SPECIFIES THE BOUNDARY
C      VALUES OF THE SOLUTION AT R = B.  WHEN MBDCND = 1,4, OR 5,
C
C               BDB(J) = U(B,THETA(J)) ,          J=1,2,...,N.
C
C      WHEN MBDCND = 2,3, OR 6,
C
C               BDB(J) = (D/DR)U(B,THETA(J)) ,    J=1,2,...,N.
C
C    C,D
C      THE RANGE OF THETA, I.E. C .LE. THETA .LE. D.  C MUST BE LESS
C      THAN D.
C
C    N
C      THE NUMBER OF UNKNOWNS IN THE INTERVAL (C,D).  THE UNKNOWNS IN
C      THE THETA-DIRECTION ARE GIVEN BY THETA(J) = C + (J-0.5)DT,
C      J=1,2,...,N, WHERE DT = (D-C)/N.  N MUST BE GREATER THAN 2.
C
C    NBDCND
C      INDICATES THE TYPE OF BOUNDARY CONDITIONS AT THETA = C
C      AND THETA = D.
C
C      = 0  IF THE SOLUTION IS PERIODIC IN THETA, I.E.
C           U(I,J) = U(I,N+J).
C
C      = 1  IF THE SOLUTION IS SPECIFIED AT THETA = C AND THETA = D
C           (SEE NOTE BELOW).
C
C      = 2  IF THE SOLUTION IS SPECIFIED AT THETA = C AND THE DERIVATIVE
C           OF THE SOLUTION WITH RESPECT TO THETA IS SPECIFIED AT
C           THETA = D (SEE NOTE BELOW).
C
C      = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C           SPECIFIED AT THETA = C AND THETA = D.
C
C      = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C           SPECIFIED AT THETA = C AND THE SOLUTION IS SPECIFIED AT
C           THETA = D (SEE NOTE BELOW).
C
C      NOTE:  WHEN NBDCND = 1, 2, OR 4, DO NOT USE MBDCND = 5 OR 6 (THE
C      FORMER INDICATES THAT THE SOLUTION IS SPECIFIED AT R =  0; THE
C      LATTER INDICATES THE SOLUTION IS UNSPECIFIED AT R = 0).  USE
C      INSTEAD MBDCND = 1 OR 2.
C
C    BDC
C      A ONE DIMENSIONAL ARRAY OF LENGTH M THAT SPECIFIES THE BOUNDARY
C      VALUES OF THE SOLUTION AT THETA = C.   WHEN NBDCND = 1 OR 2,
C
C               BDC(I) = U(R(I),C) ,              I=1,2,...,M.
C
C      WHEN NBDCND = 3 OR 4,
C
C               BDC(I) = (D/DTHETA)U(R(I),C),     I=1,2,...,M.
C
C      WHEN NBDCND = 0, BDC IS A DUMMY VARIABLE.
C
C    BDD
C      A ONE-DIMENSIONAL ARRAY OF LENGTH M THAT SPECIFIES THE BOUNDARY
C      VALUES OF THE SOLUTION AT THETA = D.  WHEN NBDCND = 1 OR 4,
C
C               BDD(I) = U(R(I),D) ,              I=1,2,...,M.
C
C      WHEN NBDCND = 2 OR 3,
C
C               BDD(I) = (D/DTHETA)U(R(I),D) ,    I=1,2,...,M.
C
C      WHEN NBDCND = 0, BDD IS A DUMMY VARIABLE.
C
C    ELMBDA
C      THE CONSTANT LAMBDA IN THE HELMHOLTZ EQUATION.  IF LAMBDA IS
C      GREATER THAN 0, A SOLUTION MAY NOT EXIST.  HOWEVER, HSTPLR WILL
C      ATTEMPT TO FIND A SOLUTION.
C
C    F
C      A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE RIGHT
C      SIDE OF THE HELMHOLTZ EQUATION.  FOR I=1,2,...,M AND J=1,2,...,N
C
C               F(I,J) = F(R(I),THETA(J)) .
C
C      F MUST BE DIMENSIONED AT LEAST M X N.
C
C    IDIMF
C      THE ROW (OR FIRST) DIMENSION OF THE ARRAY F AS IT APPEARS IN THE
C      PROGRAM CALLING HSTPLR.  THIS PARAMETER IS USED TO SPECIFY THE
C      VARIABLE DIMENSION OF F.  IDIMF MUST BE AT LEAST M.
C
C    W
C      A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C      WORK SPACE.  W MAY REQUIRE UP TO 13M + 4N + M*INT(LOG2(N))
C      LOCATIONS.  THE ACTUAL NUMBER OF LOCATIONS USED IS COMPUTED BY
C      HSTPLR AND IS RETURNED IN THE LOCATION W(1).
C
C
C             * * * * * *   ON OUTPUT   * * * * * *
C
C    F
C      CONTAINS THE SOLUTION U(I,J) OF THE FINITE DIFFERENCE
C      APPROXIMATION FOR THE GRID POINT (R(I),THETA(J)) FOR
C      I=1,2,...,M, J=1,2,...,N.
C
C    PERTRB
C      IF A COMBINATION OF PERIODIC, DERIVATIVE, OR UNSPECIFIED
C      BOUNDARY CONDITIONS IS SPECIFIED FOR A POISSON EQUATION
C      (LAMBDA = 0), A SOLUTION MAY NOT EXIST.  PERTRB IS A CON-
C      STANT, CALCULATED AND SUBTRACTED FROM F, WHICH ENSURES
C      THAT A SOLUTION EXISTS.  HSTPLR THEN COMPUTES THIS
C      SOLUTION, WHICH IS A LEAST SQUARES SOLUTION TO THE
C      ORIGINAL APPROXIMATION.  THIS SOLUTION PLUS ANY CONSTANT IS ALSO
C      A SOLUTION; HENCE, THE SOLUTION IS NOT UNIQUE.  THE VALUE OF
C      PERTRB SHOULD BE SMALL COMPARED TO THE RIGHT SIDE F.
C      OTHERWISE, A SOLUTION IS OBTAINED TO AN ESSENTIALLY DIFFERENT
C      PROBLEM.  THIS COMPARISON SHOULD ALWAYS BE MADE TO INSURE THAT
C      A MEANINGFUL SOLUTION HAS BEEN OBTAINED.
C
C    IERROR
C      AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.
C      EXCEPT TO NUMBERS 0 AND 11, A SOLUTION IS NOT ATTEMPTED.
C
C      =  0  NO ERROR
C
C      =  1  A .LT. 0
C
C      =  2  A .GE. B
C
C      =  3  MBDCND .LT. 1 OR MBDCND .GT. 6
C
C      =  4  C .GE. D
C
C      =  5  N .LE. 2
C
C      =  6  NBDCND .LT. 0 OR NBDCND .GT. 4
C
C      =  7  A = 0 AND MBDCND = 3 OR 4
C
C      =  8  A .GT. 0 AND MBDCND .GE. 5
C
C      =  9  MBDCND .GE. 5 AND NBDCND .NE. 0 OR 3
C
C      = 10  IDIMF .LT. M
C
C      = 11  LAMBDA .GT. 0
C
C      = 12  M .LE. 2
C
C      SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY
C      INCORRECT CALL TO HSTPLR, THE USER SHOULD TEST IERROR AFTER
C      THE CALL.
C
C    W
C      W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C
C     * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C     DIMENSION OF   BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C     ARGUMENTS      W(SEE ARGUMENT LIST)
C
C     LATEST         JUNE 1, 1977
C     REVISION
C
C     SUBPROGRAMS    HSTPLR,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2,
C     REQUIRED       COSGEN,MERGE,TRIX,TRI3,PIMACH
C
C     SPECIAL        NONE
C     CONDITIONS
C
C     COMMON         NONE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C
C     SPECIALIST     ROLAND SWEET
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        WRITTEN BY ROLAND SWEET AT NCAR IN FEBRUARY, 1977
C
C     ALGORITHM      THIS SUBROUTINE DEFINES THE FINITE-DIFFERENCE
C                    EQUATIONS, INCORPORATES BOUNDARY DATA, ADJUSTS THE
C                    RIGHT SIDE WHEN THE SYSTEM IS SINGULAR AND CALLS
C                    EITHER POISTG OR GENBUN WHICH SOLVES THE LINEAR
C                    SYSTEM OF EQUATIONS.
C
C     SPACE          8265(DECIMAL) = 20111(OCTAL) LOCATIONS ON THE
C     REQUIRED       NCAR CONTROL DATA 7600
C
C     TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C     ACCURACY       7600 FOR SUBROUTINE HSTPLR IS ROUGHLY PROPORTIONAL
C                    TO M*N*LOG2(N).  SOME TYPICAL VALUES ARE LISTED IN
C                    THE TABLE BELOW.
C                       THE SOLUTION PROCESS EMPLOYED RESULTS IN A LOSS
C                    OF NO MORE THAN FOUR SIGNIFICANT DIGITS FOR N AND M
C                    AS LARGE AS 64.  MORE DETAILED INFORMATION ABOUT
C                    ACCURACY CAN BE FOUND IN THE DOCUMENTATION FOR
C                    SUBROUTINE POISTG WHICH IS THE ROUTINE THAT
C                    ACTUALLY SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32       1-6       1-4         56
C                        64       1-6       1-4        230
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                    ALL MACHINE DEPENDENT CONSTANTS ARE LOCATED IN THE
C                    FUNCTION PIMACH.
C
C     REQUIRED       COS
C     RESIDENT
C     ROUTINES
C
C     REFERENCE      SCHUMANN, U. AND R. SWEET,"A DIRECT METHOD FOR
C                    THE SOLUTION OF POISSON"S EQUATION WITH NEUMANN
C                    BOUNDARY CONDITIONS ON A STAGGERED GRID OF
C                    ARBITRARY SIZE," J. COMP. PHYS. 20(1976),
C                    PP. 171-182.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      DIMENSION       F(IDIMF,1)
      DIMENSION       BDA(1)     ,BDB(1)     ,BDC(1)     ,BDD(1)     ,
     1                W(1)
      IERROR = 0
      IF (A .LT. 0.) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 2) IERROR = 5
      IF (NBDCND.LT.0 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4)) IERROR = 7
      IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8
      IF (MBDCND.GE.5 .AND. NBDCND.NE.0 .AND. NBDCND.NE.3) IERROR = 9
      IF (IDIMF .LT. M) IERROR = 10
      IF (M .LE. 2) IERROR = 12
      IF (IERROR .NE. 0) RETURN
      DELTAR = (B-A)/FLOAT(M)
      DLRSQ = DELTAR**2
      DELTHT = (D-C)/FLOAT(N)
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
      ISW = 1
      MB = MBDCND
      IF (A.EQ.0. .AND. MBDCND.EQ.2) MB = 6
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      IWB = M
      IWC = IWB+M
      IWR = IWC+M
      DO 101 I=1,M
         J = IWR+I
         W(J) = A+(FLOAT(I)-0.5)*DELTAR
         W(I) = (A+FLOAT(I-1)*DELTAR)/DLRSQ
         K = IWC+I
         W(K) = (A+FLOAT(I)*DELTAR)/DLRSQ
         K = IWB+I
         W(K) = (ELMBDA-2./DLRSQ)*W(J)
  101 CONTINUE
      DO 103 I=1,M
         J = IWR+I
         A1 = W(J)
         DO 102 J=1,N
            F(I,J) = A1*F(I,J)
  102    CONTINUE
  103 CONTINUE
C
C     ENTER BOUNDARY DATA FOR R-BOUNDARIES.
C
      GO TO (104,104,106,106,108,108),MB
  104 A1 = 2.*W(1)
      W(IWB+1) = W(IWB+1)-W(1)
      DO 105 J=1,N
         F(1,J) = F(1,J)-A1*BDA(J)
  105 CONTINUE
      GO TO 108
  106 A1 = DELTAR*W(1)
      W(IWB+1) = W(IWB+1)+W(1)
      DO 107 J=1,N
         F(1,J) = F(1,J)+A1*BDA(J)
  107 CONTINUE
  108 GO TO (109,111,111,109,109,111),MB
  109 A1 = 2.*W(IWR)
      W(IWC) = W(IWC)-W(IWR)
      DO 110 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  110 CONTINUE
      GO TO 113
  111 A1 = DELTAR*W(IWR)
      W(IWC) = W(IWC)+W(IWR)
      DO 112 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  112 CONTINUE
C
C     ENTER BOUNDARY DATA FOR THETA-BOUNDARIES.
C
  113 A1 = 2./DLTHSQ
      GO TO (123,114,114,116,116),NP
  114 DO 115 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)-A1*BDC(I)/W(J)
  115 CONTINUE
      GO TO 118
  116 A1 = 1./DELTHT
      DO 117 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)+A1*BDC(I)/W(J)
  117 CONTINUE
  118 A1 = 2./DLTHSQ
      GO TO (123,119,121,121,119),NP
  119 DO 120 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  120 CONTINUE
      GO TO 123
  121 A1 = 1./DELTHT
      DO 122 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  122 CONTINUE
  123 CONTINUE
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 133,125,124
  124 IERROR = 11
      GO TO 133
  125 GO TO (133,133,126,133,133,126),MB
  126 GO TO (127,133,133,127,133),NP
  127 CONTINUE
      ISW = 2
      DO 129 J=1,N
         DO 128 I=1,M
            PERTRB = PERTRB+F(I,J)
  128    CONTINUE
  129 CONTINUE
      PERTRB = PERTRB/(FLOAT(M*N)*0.5*(A+B))
      DO 131 I=1,M
         J = IWR+I
         A1 = PERTRB*W(J)
         DO 130 J=1,N
            F(I,J) = F(I,J)-A1
  130    CONTINUE
  131 CONTINUE
      A2 = 0.
      DO 132 J=1,N
         A2 = A2+F(1,J)
  132 CONTINUE
      A2 = A2/W(IWR+1)
  133 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY  R(I)*DELTHT**2
C
      DO 135 I=1,M
         J = IWR+I
         A1 = DLTHSQ*W(J)
         W(I) = A1*W(I)
         J = IWC+I
         W(J) = A1*W(J)
         J = IWB+I
         W(J) = A1*W(J)
         DO 134 J=1,N
            F(I,J) = A1*F(I,J)
  134    CONTINUE
  135 CONTINUE
      LP = NBDCND
      W(1) = 0.
      W(IWR) = 0.
C
C     CALL POISTG OR GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      IF (LP .EQ. 0) GO TO 136
      CALL POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
      GO TO 137
  136 CALL GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
  137 CONTINUE
      W(1) = W(IWR+1)+3.*FLOAT(M)
      IF (A.NE.0. .OR. MBDCND.NE.2 .OR. ISW.NE.2) GO TO 141
      A1 = 0.
      DO 138 J=1,N
         A1 = A1+F(1,J)
  138 CONTINUE
      A1 = (A1-DLRSQ*A2/16.)/FLOAT(N)
      IF (NBDCND .EQ. 3) A1 = A1+(BDD(1)-BDC(1))/(D-C)
      A1 = BDA(1)-A1
      DO 140 I=1,M
         DO 139 J=1,N
            F(I,J) = F(I,J)+A1
  139    CONTINUE
  140 CONTINUE
  141 CONTINUE
      RETURN
      END
C     CALL POISTG OR GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.


      SUBROUTINE zrhqr(a,m,rtr,rti)
      INTEGER m,MAXM
      REAL a(m+1),rtr(m),rti(m)
      PARAMETER (MAXM=50)
CU    USES balanc,hqr
      INTEGER j,k
      REAL hess(MAXM,MAXM),xr,xi
      if (m.gt.MAXM.or.a(m+1).eq.0.) pause 'bad args in zrhqr'
      do 12 k=1,m
        hess(1,k)=-a(m+1-k)/a(m+1)
        do 11 j=2,m
          hess(j,k)=0.
11      continue
        if (k.ne.m) hess(k+1,k)=1.
12    continue
      call balanc(hess,m,MAXM)
      call hqr(hess,m,MAXM,rtr,rti)
      do 14 j=2,m
        xr=rtr(j)
        xi=rti(j)
        do 13 k=j-1,1,-1
          if(rtr(k).le.xr)goto 1
          rtr(k+1)=rtr(k)
          rti(k+1)=rti(k)
13      continue
        k=0
1       rtr(k+1)=xr
        rti(k+1)=xi
14    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/zrhqr.for


C NCLFORTSTART
      SUBROUTINE DSIMPEQ (NUM,DX,Y,ANS)
      IMPLICIT NONE
      INTEGER  NUM
      DOUBLE PRECISION DX,Y(NUM),ANS
C NCLEND
C
C THE NSSL "simpsn.f" DOES NOT WORK. THIS IS NOW JUST A FRONT-END
C DRIVER THAT ALLOWS THE SAME INTERFACE TO BE USED BUT IT INVOKES
C THE *SLIGHTLY* LESS ACCURATE "simpne.f" TO PERFORM THE INTEGRATION.
C
C SOURCE                 NCAR's NSSL [simpsn.f]
C ARGUMENTS
C
C ON INPUT               DX
C                          A SINGLE VARIABLE SPECIFYING THE INCREMENT
C                          FOR THE EQUALLY SPACED ABSCISSAS.
C
C                        Y
C                          VECTOR OF ORDINATES.
C
C                        NUM
C                          LENGTH OF VECTOR Y (SHOULD BE .GT. 2).
C
C ON OUTPUT              ANS
C                          ANSWER [set to -9999. if error]
C
C ALGORITHM              SIMPSON'S RULE AND LAGRANGIAN INTERPOLATION
C
C ACCURACY               FOR EQUALLY SPACED ABSCISSAE THE ERROR IS
C                        PROPORTIONAL TO  H**4 TIMES THE FOURTH
C                        DERIVATIVE OF F  AT C, WHERE C IS SOME
C                        POINT WITHIN THE LIMITS OF INTEGRATION.
C                        FOR UNEQUALLY SPACED ABSCISSAE THE ERROR
C                        IS PROPORTIONAL TO THE FOURTH DERIVATIVE
C                        OF F AT X TIMES THE FOURTH POWER OF THE
C                        MAXIMUM DISTANCE BETWEEN ADJACENT ABSCISSAE.
C **********************************************************************

C LOCAL
      DOUBLE PRECISION X(NUM)
      INTEGER I

C CREATE A 1D EQUALLY SPACED ARRAY
      DO I=1,NUM
         X(I) = DBLE(I-1)*DX
      END DO

C INVOKE THE SIMPSON RULE FOR UNEQUALLY SPACED DATA
      CALL DSIMPNE2(NUM,X,Y,ANS)

      RETURN
      END
C ========================================================
C NCLFORTSTART
      SUBROUTINE DSIMPNE(NUM,X,Y,YMSG,ANS)
      IMPLICIT NONE
      INTEGER  NUM
      DOUBLE PRECISION X(NUM), Y(NUM), ANS, YMSG
C NCLEND
      INTEGER N,NUSE
      DOUBLE PRECISION XX(NUM), YY(NUM)

C STRIP MSG VALUES
      NUSE = 0
      DO N=1,NUM
         IF (Y(N).NE.YMSG) THEN
             NUSE = NUSE + 1
             XX(NUSE) = X(N)
             YY(NUSE) = Y(N)
         END IF
      END DO

      CALL DSIMPNE2(NUSE,XX,YY,ANS)

      RETURN
      END
C ---------------------------------------------------------
      SUBROUTINE DSIMPNE2(NUM,X,Y,ANS)
      IMPLICIT NONE
      INTEGER  NUM
      DOUBLE PRECISION X(NUM), Y(NUM), ANS
C
C SOURCE                 NCAR's NSSL [simpne.f]
C
C DIMENSION OF           X(NUM),Y(NUM)
C ARGUMENTS
C
C PURPOSE                TO INTEGRATE OVER A GIVEN SET OF ORDINATES
C                        BY ANALYTICALLY INTEGRATING A 3-POINT
C                        LAGRANGIAN INTERPOLATION POLYNOMIAL
C                        FITTING THE ORDINATES.
C
C ARGUMENTS
C
C ON INPUT               X
C                          THIS IS A VECTOR OF LENGTH NUM SPECIFYING
C                          THE UNEQUALLY SPACED ABSCISSAS.
C
C                        Y
C                          VECTOR OF ORDINATES.
C
C                        NUM
C                          LENGTH OF VECTOR Y (SHOULD BE .GT. 2).
C
C **********************************************************************
      DOUBLE PRECISION DEL(3),PI(3),G(3),THIRD,HALF,TWO3R
      DOUBLE PRECISION X1,X2,X3,E,F,FEINTS,DELPRD,SUMT
      INTEGER IER,N,I

      IF (NUM.LE.2) THEN
          IER = 32
          ANS = -9999.D0
          RETURN
      END IF

      IER = 0
      N   = 1
      ANS = 0.D0

      THIRD = 1.D0/3.D0
      HALF  = 1.D0/2.D0
      TWO3R = 2.D0/3.D0

  105 CONTINUE
      X1 = X(N)
      X2 = X(N+1)
      X3 = X(N+2)
      E  = X3*X3 - X1*X1
      F  = X3*X3*X3 - X1*X1*X1
      FEINTS = X3 - X1
      DEL(1) = X3 - X2
      DEL(2) = -FEINTS
      DEL(3) = X2 - X1
      G(1)   = X2 + X3
      G(2)   = X1 + X3
      G(3)   = X1 + X2
      PI(1)  = X2*X3
      PI(2)  = X1*X3
      PI(3)  = X1*X2
      DELPRD = DEL(1)*DEL(2)*DEL(3)

      SUMT = 0.D0
      DO I = 1,3
          SUMT = SUMT + Y(N-1+I)*DEL(I)*
     +           (THIRD*F-G(I)*HALF*E+PI(I)*FEINTS)
      END DO
      ANS = ANS - SUMT/DELPRD

      N = N + 2
      IF (NUM.GT. (N+1)) GO TO 105

      IF (MOD(NUM,2).NE.0) RETURN

      N  = NUM - 2
      X3 = X(NUM)
      X2 = X(NUM-1)
      X1 = X(NUM-2)
      E  = X3*X3 - X2*X2
      F  = X3*X3*X3 - X2*X2*X2
      FEINTS = X3 - X2
      DEL(1) = FEINTS
      DEL(2) = X1 - X3
      DEL(3) = X2 - X1
      G(1)   = X2 + X3
      G(2)   = X1 + X3
      G(3)   = X1 + X2
      PI(1)  = X2*X3
      PI(2)  = X1*X3
      PI(3)  = X1*X2
      DELPRD = DEL(1)*DEL(2)*DEL(3)

  107 SUMT = 0.D0
      DO I = 1,3
          SUMT = SUMT + Y(N-1+I)*DEL(I)*
     +           (THIRD*F-G(I)*HALF*E+PI(I)*FEINTS)
      END DO

      ANS = ANS - SUMT/DELPRD
      RETURN
      END


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##########################################################
c     ##                                                      ##
c     ##  function number  --  convert text string to number  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "number" converts a text numeral into an integer value;
c     the input string must contain only numeric characters
c
c
      function number (string)
      implicit none
      include 'inform.i'
      include 'iounit.i'
      integer i,j,number
      integer first,last,trimtext
      integer digit,place(10)
      character*1 letter
      character*(*) string
      data place  / 1, 10, 100, 1000, 10000, 100000, 1000000,
     &              10000000, 100000000, 1000000000 /
c
c
c     initialize the integer value of number to zero
c
      number = 0
c
c     get the first and last nonblank characters
c
      last = trimtext (string)
      if (last .gt. 10) then
         write (iout,10)
   10    format (' NUMBER  --  Input Text String is Too Long')
         return
      end if
      first = 1
      do i = 1, last
         letter = string(i:i)
         if (letter .ne. ' ') then
            first = i
            goto 20
         end if
      end do
   20 continue
c
c     convert the text numeral into an integer number
c
      j = 0
      do i = last, first, -1
         j = j + 1
         letter = string(i:i)
         if (letter .eq. '0') then
            digit = 0
         else if (letter .eq. '1') then
            digit = 1
         else if (letter .eq. '2') then
            digit = 2
         else if (letter .eq. '3') then
            digit = 3
         else if (letter .eq. '4') then
            digit = 4
         else if (letter .eq. '5') then
            digit = 5
         else if (letter .eq. '6') then
            digit = 6
         else if (letter .eq. '7') then
            digit = 7
         else if (letter .eq. '8') then
            digit = 8
         else if (letter .eq. '9') then
            digit = 9
         else
            if (debug) then
               write (iout,30)
   30          format (/,' NUMBER  --  Non-Numeric Characters Found',
     &                    ' in Numeral String')
            end if
            number = 0
            goto 40
         end if
         number = number + digit * place(j)
      end do
   40 continue
      return
      end


!==============================================================================!
  subroutine Calculate_Vorticity(grid)
!------------------------------------------------------------------------------!
!  Computes the magnitude of the vorticity                                     !
!------------------------------------------------------------------------------!
!  vort = sqrt( 2 * Sij * Sij )                                                !
!  Sij = 1/2 ( dUi/dXj - dUj/dXi )                                             !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Flow_Mod
  use Comm_Mod
  use Les_Mod
  use Rans_Mod
  use Grid_Mod
  use Grad_Mod
  use Work_Mod, only: u_x => r_cell_01,  &
                      u_y => r_cell_02,  &
                      u_z => r_cell_03,  &
                      v_x => r_cell_04,  &
                      v_y => r_cell_05,  &
                      v_z => r_cell_06,  &
                      w_x => r_cell_07,  &
                      w_y => r_cell_08,  &
                      w_z => r_cell_09
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer :: c
!==============================================================================!

  call Comm_Mod_Exchange_Real(grid, u % n)
  call Comm_Mod_Exchange_Real(grid, v % n)
  call Comm_Mod_Exchange_Real(grid, w % n)

  call Grad_Mod_For_Phi(grid, u % n, 1, u_x, .true.)  ! du/dx
  call Grad_Mod_For_Phi(grid, u % n, 2, u_y, .true.)  ! du/dy
  call Grad_Mod_For_Phi(grid, u % n, 3, u_z, .true.)  ! du/dz

  call Grad_Mod_For_Phi(grid, v % n, 1, v_x, .true.)  ! dv/dx
  call Grad_Mod_For_Phi(grid, v % n, 2, v_y, .true.)  ! dv/dy
  call Grad_Mod_For_Phi(grid, v % n, 3, v_z, .true.)  ! dv/dz

  call Grad_Mod_For_Phi(grid, w % n, 1, w_x, .true.)  ! dw/dx
  call Grad_Mod_For_Phi(grid, w % n, 2, w_y, .true.)  ! dw/dy
  call Grad_Mod_For_Phi(grid, w % n, 3, w_z, .true.)  ! dw/dz

  do c = 1, grid % n_cells
    vort(c) = 2.0 * (0.5 * (w_y(c) - v_z(c)))**2  &
            + 2.0 * (0.5 * (w_x(c) - u_z(c)))**2  &
            + 2.0 * (0.5 * (v_x(c) - u_y(c)))**2

    vort(c) = sqrt(abs(2.0 * vort(c)))
  end do

  end subroutine


c SPLINB
	SUBROUTINE SPLINB(N,nx,A)
	implicit real*4 (a-h,o-z)

	include 'PARAMETER'   !por nmax===kn
c	PARAMETER (nmax=1280)
c	dimension a(nx,nx),b(nmax,nmax),c(nmax,nmax),indx(nmax)
	dimension a(nx,nx),b(kn,kn),c(kn,kn),indx(kn)

	do i=1,n		!inicializo a cero
	   do j=1,n
	      a(i,j)=0.d0
	      b(i,j)=0.d0
           end do
	end do

	do i=2,n-1
	   a(i,i)=4.d0          !diagonales
	   b(i,i)=-2.d0
	   a(i,i-1)=1.d0        !bajo la diagonal
	   b(i,i-1)=1.d0
	   a(i,i+1)=1.d0	!sobre la diagonal
	   b(i,i+1)=1.d0
	end do

	a(1,1)=1.d0             !escribo las esquinas
	a(1,2)=-5.d0
	a(1,3)=1.d0
	a(n,n)=1.d0
	a(n,n-1)=-5.d0
	a(n,n-2)=1.d0
	b(1,1)=-5.d-1           !escribo las esquinas
	b(1,2)=1.d0
	b(1,3)=-5.d-1
	b(n,n)=-5.d-1
	b(n,n-1)=1.d0
	b(n,n-2)=-5.d-1

	do i=1,n                !matriz diagonal
	   do j=1,n
	      c(i,j)=0.d0
	   end do
	   c(i,i)=1.d0
	end do

	CALL LUDCMP(A,N,NX,INDX,D)
	do j=1,n
	   CALL LUBKSB(A,N,NX,INDX,c(1,j))
	end do

	do i=1,n
	   do j=1,n
	      a(i,j)=0.d0
              do k=1,n
                 a(i,j)=a(i,j)+c(i,k)*b(k,j)
	      end do
	   end do
	end do

	return
	end


program test_sch1d_osc

! Tests 1D harmonic oscillator ground state minimization (imaginary time
! propagation).

use types, only: dp
use constants, only: i_, pi
use ofdft, only: read_pseudo
use ofdft_fft, only: free_energy, radial_potential_fourier, &
    reciprocal_space_vectors, free_energy_min, real2fourier, integral, &
    fourier2real, real_space_vectors, vtk_save, integralG
use utils, only: loadtxt, stop_error, assert, linspace, strfmt
use splines, only: spline3pars, iixmin, poly3, spline3ders
use interp3d, only: trilinear
use md, only: positions_fcc, positions_bcc
implicit none
integer :: Ng
real(dp), allocatable :: G(:), G2(:)
real(dp), allocatable :: ne(:)
real(dp), allocatable :: Xn(:), Vn(:)
complex(dp), allocatable, dimension(:) :: psi, psiG
real(dp) :: L
integer :: i
integer, parameter :: nelec = 1
real(dp) :: dt, psi_norm, E_tot, omega
integer :: u, u2
real(dp) :: t

Ng = 16

L = 10._dp

allocate(ne(Ng))
allocate(G(Ng), G2(Ng), psi(Ng))
allocate(psiG(Ng))
allocate(Xn(Ng), Vn(Ng))

call real_space_vectors(L, Xn)
call reciprocal_space_vectors(L, G, G2)
omega = 1._dp
Vn = omega**2 * (Xn-L/2)**2 / 2
!Vn = reg_coulomb_x(Xn, 20._dp, L/2)
!psi = gauss_x(Xn, 0.1_dp, L/2, 400._dp)
psi = 1 / L

dt = 1e-2_dp
print *, "dt =", dt

open(newunit=u, file="sch1d_grid.txt", status="replace")
write(u, *) Xn
write(u, *) Vn
close(u)

open(newunit=u, file="sch1d.txt", status="replace")

open(newunit=u2, file="sch1d_psi.txt", status="replace")
write(u2, *) real(psi, dp), aimag(psi)

! Do first step by hand:
print *, "First step"
ne = real(psi*conjg(psi), dp)
psi_norm = integral(L, ne)
print *, "Initial norm of psi:", psi_norm
psi = sqrt(nelec / psi_norm) * psi
ne = real(psi*conjg(psi), dp)
psi_norm = integral(L, ne)
print *, "norm of psi:", psi_norm

t = 0

do i = 1, 600
    t = t + dt
    print *, "iter =", i, "time =", t

    psi = psi * exp(-Vn*dt/2)
    call real2fourier(psi, psiG)
    psiG = psiG * exp(-G2*dt/2)
    call fourier2real(psiG, psi)
    psi = psi * exp(-Vn*dt/2)

    ne = real(psi*conjg(psi), dp)
    psi_norm = integral(L, ne)
    psi = sqrt(nelec / psi_norm) * psi
    ne = real(psi*conjg(psi), dp)
    psi_norm = integral(L, ne)
    print *, "norm of psi:", psi_norm

    call real2fourier(psi, psiG)
    E_tot = 1._dp/2 * integralG(G2*abs(psiG)**2, L) + integral(L, Vn*ne)
    print *, "E_tot       =", E_tot
    print *, "E_tot_exact =", omega/2

    write(u, *) i, t, psi_norm, E_tot
    write(u2, *) real(psi, dp), aimag(psi)

end do
print *, "Done"

close(u)
close(u2)

print *, E_tot - omega/2
call assert(abs(E_tot - omega/2) < 1e-9_dp)

contains

    pure function gauss_x(x, a, x0, k0) result(r)
    real(dp), intent(in) :: x(:), a, x0, k0
    complex(dp) :: r(size(x))
    r = (a * sqrt(pi))**(-0.5_dp) &
            * exp(-0.5_dp * ((x - x0) / a)**2 + i_ * x * k0)
    end function

    pure function reg_coulomb_x(x, alpha, x0) result(V)
    real(dp), intent(in) :: x(:), alpha, x0
    real(dp) :: V(size(x)), r(size(x))
    r = abs(x-x0)
    where (r < 1e-6_dp)
        V = -2*alpha/sqrt(pi)
    else where
        V = -erf(alpha*r)/r
    end where
    end function

end program


	SUBROUTINE GP_DRAZ  ( dir, xm, ym, azim, iret )
C************************************************************************
C* GP_DRAZ								*
C*									*
C* This subroutine transforms a wind direction in N coordinates to the	*
C* correct direction to plot in M coordinates.				*
C*									*
C* GP_DRAZ ( DIR, XM, YM, AZIM, IRET )					*
C*									*
C* Input parameters:							*
C*	DIR		REAL		Input wind direction		*
C*	XM		REAL		Latitude			*
C*	YM		REAL		Longitude			*
C*									*
C* Output parameters:							*
C*	AZIM		REAL		Transformed direction		*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* D.W.Plummer/NCEP	 7/97	From GAZDRM				*
C* S. Jacobs/NCEP	10/98	Copied from GDRAZM			*
C* S. Jacobs/NCEP	10/98	Added call to GQMODE; removed common	*
C* I. Durham/GSC	10/98   Corrected header			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	PARAMETER 	( DISPL = 0.1 )
	REAL		x (2), y (2)
C------------------------------------------------------------------------
C*	Check for map mode.
C
	CALL GQMODE ( igmode, ier )
	IF  ( igmode .eq. 1 )  THEN
C
C*	    Get displacement to use.
C
	    dsp = DISPL
C
C*	    Get local north . . . set point 2 to DSP deg. of lat. north
C*	    of point 1 (note X is lat), then transform to N coordinates.
C
	    x (1) = xm
	    y (1) = ym
	    x (2) = xm + dsp
	    y (2) = ym
C
	    CALL GTRANS ( 'M', 'N', 2, x, y, x, y, ier )
C
C*	    Compute displacement in N coordinates, then get direction
C*	    angle.  ROT > 0 corresponds to north rotated clockwise in
C*	    N coord.  The IF test avoids sending ( 0, 0 ) to ATAN2.
C*	    This occurs when GTRANS does not transform points at the
C*	    edges of a NPG image.  The direction returned (0) is really
C*	    an undefined value.  Since this is at the edge of the image,
C*	    in most cases nothing should be plotted.
C
	    delx = x (2) - x (1)
	    dely = y (2) - y (1)
C
	    IF  ( ( delx .eq. 0. ) .and. ( dely .eq. 0. ) )  THEN
	        dir = 0.
	      ELSE
	        rot  = ATAN2 ( delx, dely )
	        azim = dir - rot * RTD
	    END IF
C*
	END IF
	iret = 0
C*
	RETURN
	END


      SUBROUTINE MB02OD( SIDE, UPLO, TRANS, DIAG, NORM, M, N, ALPHA, A,
     $                   LDA, B, LDB, RCOND, TOL, IWORK, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve (if well-conditioned) one of the matrix equations
C
C        op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
C
C     where alpha is a scalar, X and B are m-by-n matrices, A is a unit,
C     or non-unit, upper or lower triangular matrix and op( A ) is one
C     of
C
C        op( A ) = A   or   op( A ) = A'.
C
C     An estimate of the reciprocal of the condition number of the
C     triangular matrix A, in either the 1-norm or the infinity-norm, is
C     also computed as
C
C        RCOND = 1 / ( norm(A) * norm(inv(A)) ).
C
C     and the specified matrix equation is solved only if RCOND is
C     larger than a given tolerance TOL.  In that case, the matrix X is
C     overwritten on B.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SIDE    CHARACTER*1
C             Specifies whether op( A ) appears on the left or right
C             of X as follows:
C             = 'L':  op( A )*X = alpha*B;
C             = 'R':  X*op( A ) = alpha*B.
C
C     UPLO    CHARACTER*1
C             Specifies whether the matrix A is an upper or lower
C             triangular matrix as follows:
C             = 'U':  A is an upper triangular matrix;
C             = 'L':  A is a lower triangular matrix.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( A ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( A ) = A;
C             = 'T':  op( A ) = A';
C             = 'C':  op( A ) = A'.
C
C     DIAG    CHARACTER*1
C             Specifies whether or not A is unit triangular as follows:
C             = 'U':  A is assumed to be unit triangular;
C             = 'N':  A is not assumed to be unit triangular.
C
C     NORM    CHARACTER*1
C             Specifies whether the 1-norm condition number or the
C             infinity-norm condition number is required:
C             = '1' or 'O':  1-norm;
C             = 'I':         Infinity-norm.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of B.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of B.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar  alpha. When alpha is zero then A is not
C             referenced and B need not be set before entry.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,k),
C             where k is M when SIDE = 'L' and is N when SIDE = 'R'.
C             On entry with UPLO = 'U', the leading k-by-k upper
C             triangular part of this array must contain the upper
C             triangular matrix and the strictly lower triangular part
C             of A is not referenced.
C             On entry with UPLO = 'L', the leading k-by-k lower
C             triangular part of this array must contain the lower
C             triangular matrix and the strictly upper triangular part
C             of A is not referenced.
C             Note that when DIAG = 'U', the diagonal elements of A are
C             not referenced either, but are assumed to be unity.
C
C     LDA     INTEGER
C             The leading dimension of array A.
C             LDA >= max(1,M) when SIDE = 'L';
C             LDA >= max(1,N) when SIDE = 'R'.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading M-by-N part of this array must
C             contain the right-hand side matrix B.
C             On exit, if INFO = 0, the leading M-by-N part of this
C             array contains the solution matrix X.
C             Otherwise, this array is not modified by the routine.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= max(1,M).
C
C     RCOND   (output) DOUBLE PRECISION
C             The reciprocal of the condition number of the matrix A,
C             computed as RCOND = 1/(norm(A) * norm(inv(A))).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used to test for near singularity of
C             the matrix A. If the user sets TOL > 0, then the given
C             value of TOL is used as a lower bound for the reciprocal
C             condition number of that matrix; a matrix whose estimated
C             condition number is less than 1/TOL is considered to be
C             nonsingular. If the user sets TOL <= 0, then an implicitly
C             computed, default tolerance, defined by TOLDEF = k*k*EPS,
C             is used instead, where EPS is the machine precision (see
C             LAPACK Library routine DLAMCH).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (k)
C
C     DWORK   DOUBLE PRECISION array, dimension (3*k)
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             = 1:  the matrix A is numerically singular, i.e. the
C                   condition number estimate of A (in the specified
C                   norm) exceeds 1/TOL.
C
C     METHOD
C
C     An estimate of the reciprocal of the condition number of the
C     triangular matrix A (in the specified norm) is computed, and if
C     this estimate is larger then the given (or default) tolerance,
C     the specified matrix equation is solved using Level 3 BLAS
C     routine DTRSM.
C
C
C     REFERENCES
C
C     None.
C
C     NUMERICAL ASPECTS
C                             2
C     The algorithm requires k N/2 operations.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C
C     REVISIONS
C
C     February 20, 1998.
C
C     KEYWORDS
C
C     Condition number, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, SIDE, TRANS, UPLO
      INTEGER            INFO, LDA, LDB, M, N
      DOUBLE PRECISION   ALPHA, RCOND, TOL
C     .. Array Arguments ..
      INTEGER            IWORK(*)
      DOUBLE PRECISION   A(LDA,*), B(LDB,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL            LSIDE, ONENRM
      INTEGER            NROWA
      DOUBLE PRECISION   TOLDEF
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL           DTRCON, DTRSM, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX
C     .. Executable Statements ..
C
      LSIDE  = LSAME( SIDE, 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN
         INFO = -1
      ELSE IF( ( .NOT.LSAME( UPLO,  'U' ) ).AND.
     $         ( .NOT.LSAME( UPLO,  'L' ) )      )THEN
         INFO = -2
      ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND.
     $         ( .NOT.LSAME( TRANS, 'T' ) ).AND.
     $         ( .NOT.LSAME( TRANS, 'C' ) )      )THEN
         INFO = -3
      ELSE IF( ( .NOT.LSAME( DIAG,  'U' ) ).AND.
     $         ( .NOT.LSAME( DIAG,  'N' ) )      )THEN
         INFO = -4
      ELSE IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
         INFO = -5
      ELSE IF( M.LT.0 )THEN
         INFO = -6
      ELSE IF( N.LT.0 )THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = -10
      ELSE IF( LDB.LT.MAX( 1, M ) )THEN
         INFO = -12
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02OD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( NROWA.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      END IF
C
      TOLDEF = TOL
      IF ( TOLDEF.LE.ZERO )
     $   TOLDEF = DBLE( NROWA*NROWA )*DLAMCH( 'Epsilon' )
C
      CALL DTRCON( NORM, UPLO, DIAG, NROWA, A, LDA, RCOND, DWORK,
     $             IWORK, INFO )
C
      IF ( RCOND.GT.TOLDEF ) THEN
         CALL DTRSM( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, LDA, B,
     $               LDB )
      ELSE
         INFO = 1
      END IF
C *** Last line of MB02OD ***
      END


program supercell
  use structure
  use functions
  implicit none
  real(8) :: a(3,3),la,lb,lc,sina,cosa,cosb,cosr
  real(8),allocatable :: x(:,:),xs(:,:),T(:,:),Pd(:,:)
  integer(1) :: M(3,3),bd(2,3),vertex(3,8)
  integer(2),allocatable :: natom(:)
  integer(1),allocatable :: Pc(:,:)
  character(len=2),allocatable :: atom(:)
  integer(2) :: i,j,k,n,nt,np,na

  read(*,*) M(1,:)
  read(*,*) M(2,:)
  read(*,*) M(3,:)
  M=transpose(M)
  nt=abs(det(M))
  allocate(T(3,nt))
  vertex(:,1)=0
  vertex(:,2:4)=M
  vertex(:,5)=M(:,1)+M(:,2)
  vertex(:,6)=M(:,1)+M(:,3)
  vertex(:,7)=M(:,2)+M(:,3)
  vertex(:,8)=M(:,1)+M(:,2)+M(:,3)
  do i=1,3
    bd(1,i)=maxval(vertex(i,:))
    bd(2,i)=minval(vertex(i,:))
  end do
  np=(bd(1,1)-bd(2,1))*(bd(1,2)-bd(2,2))*(bd(1,3)-bd(2,3))
  allocate(Pc(3,np))
  allocate(Pd(3,np))
  n=0
  do i=bd(2,1),bd(1,1)-1
    do j=bd(2,2),bd(1,2)-1
      do k=bd(2,3),bd(1,3)-1
        n=n+1
        Pc(:,n)=(/ i, j, k /)
      end do
    end do
  end do
  Pd=matmul(inverse(dble(M)),dble(Pc))
  n=0
  do i=1,np
    if ( all(Pd(:,i) > -0.01) .and. all(Pd(:,i) < 0.99) ) then
      n=n+1
      T(:,n)=Pd(:,i)
    end if
  end do
  call readpos(a,x,atom,natom,'POSCAR')
  x=matmul(a,x)
  a=matmul(a,dble(M))
  x=matmul(inverse(a),x)
  na=sum(natom)
  natom=natom*nt
  allocate(xs(3,na*nt))
  n=0
  do i=1,na
    do j=1,nt
      n=n+1
      xs(:,n)=x(:,i)+T(:,j)
    end do
  end do
  xs=xs-floor(xs)
  la=norm(a(:,1))
  lb=norm(a(:,2))
  lc=norm(a(:,3))
  sina=norm(cross(a(:,1),a(:,2)))/(la*lb)
  cosa=dot_product(a(:,1),a(:,2))/(la*lb)
  cosb=dot_product(a(:,1),a(:,3))/(la*lc)
  cosr=dot_product(a(:,2),a(:,3))/(lb*lc)
  a(1,1)=la
  a(2,1)=0
  a(3,1)=0
  a(1,2)=lb*cosa
  a(2,2)=lb*sina
  a(3,2)=0
  a(1,3)=lc*cosr
  a(2,3)=(lc*cosb-a(1,3)*cosa)/sina
  a(3,3)=dsqrt(lc**2-a(1,3)**2-a(2,3)**2)
  call writepos(a,xs,atom,natom,'SPOSCAR')
end program supercell


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief A Fortran 2003 module defining bounding "boxes" for use in
!> geometry.
!>
!> This module presently provides a derived data type for an oriented bounding
!> box (OBB). The OBB is defined by an origin point, an orientation matrix
!> indicating the directions and a vector indicating the extent of the box for
!> each dimension. It is inherently a 3-D object, but can represent a 2-D surface
!> in 3-D space or 2-D space. This is determined by the dimensionality of its
!> member starting point. The module also provides methods for constructing and
!> clearing the OBBoxType, and intersecting it with a line.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE Geom_Box
USE IntrType
USE Geom_Points
USE Geom_Line
USE Geom_Plane
IMPLICIT NONE

PRIVATE
!
!List of public items
PUBLIC OBBoxType
PUBLIC ABBoxType
PUBLIC :: OPERATOR(==)

!> @brief Type for a Box
TYPE OBBoxType
  !> The start corner point
  TYPE(PointType) :: p0
  !> The vector that points in the direction of the first dimension
  REAL(SRK) :: u(3,3)=0.0_SRK
  !> The extent of every dimension
  REAL(SRK) :: e(3)=0.0_SRK
  !
  !List of type bound procedures
  CONTAINS
    !> @copybrief Geom_Box::set_OBBoxType
    !> @copydetail Geom_Box::set_OBBoxType
    PROCEDURE,PASS :: set => set_OBBoxType
    !> @copybrief Geom_Box::clear_OBBoxType
    !> @copydetail Geom_Box::clear_OBBoxType
    PROCEDURE,PASS :: clear => clear_OBBoxType
    !> @copybrief Geom_Box::intersect_OBBoxType_and_LineType
    !> @copydetail Geom_Box::intersect_OBBoxType_and_LineType
    PROCEDURE,PASS :: intersectLine => intersect_OBBoxType_and_LineType
    !> @copybrief Geom_Box::getLines_OBBoxType
    !> @copydetail Geom_Box::getLines_OBBoxType
    PROCEDURE,PASS :: getLines => getLines_OBBoxType
    !> @copybrief Geom_Box::getPlanes_OBBoxType
    !> @copydetail Geom_Box::getPlanes_OBBoxType
    PROCEDURE,PASS :: getPlanes => getPlanes_OBBoxType
    !> @copybrief Geom_Box::inside_OBBoxType
    !> @copydetail Geom_Box::inside_OBBoxType
    PROCEDURE,PASS :: inside => inside_OBBoxType
ENDTYPE OBBoxType

!> @breif Lightweight type for axis-aligned box
!>
!> Derived type for storing a simple axis-aligned box. This is used to bound
!> each of the cuboids for the cartesian mesh overlay.
TYPE :: ABBoxType
  !> Minimum x extent of the box
  REAL(SRK) :: xMin=0.0_SRK
  !> Maximum x extent of the box
  REAL(SRK) :: xMax=0.0_SRK
  !> Minimum y extent of the box
  REAL(SRK) :: yMin=0.0_SRK
  !> Maximum y extent of the box
  REAL(SRK) :: yMax=0.0_SRK
  !> Minimum z extent of the box
  REAL(SRK) :: zMin=0.0_SRK
  !> Maximum z extent of the box
  REAL(SRK) :: zMax=0.0_SRK
  !> Is the origin of our coordinate system inside of the box
  LOGICAL(SBK) :: isOrigin=.FALSE.
  !> Is the box 3D?
  LOGICAL(SBK) :: is3D=.FALSE.
  !> If the box has been assigned values
  LOGICAL(SBK) :: isSet=.FALSE.
!
!List of type bound procedure for the object
  CONTAINS
    !> @copybrief Geom_Box::inside_ABBoxType
    !> @copydetail Geom_Box::inside_ABBoxType
    PROCEDURE,PASS :: inside => inside_ABBoxType
    !> @copybrief Geom_Box::set_ABBoxType
    !> @copydetail Geom_Box::set_ABBoxType
    PROCEDURE,PASS :: set => set_ABBoxType
    !> @copybrief Geom_Box::clear_ABBoxType
    !> @copydetail Geom_Box::clear_ABBoxType
    PROCEDURE,PASS :: clear => clear_ABBoxType
ENDTYPE ABBoxType

!> @brief Generic interface for 'is equal to' operator (==)
!>
!> Adds 'is equal to' capability for OBBox types
INTERFACE OPERATOR(==)
  !> @copybrief Geom_Box::isequal_OBBoxType
  !> @copydetails Geom_Box::isequal_OBBoxType
  MODULE PROCEDURE isequal_OBBoxType
ENDINTERFACE
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief Clears an OBBoxType object's atrributes
!> @param thisOBB the OBBoxType object to clear
!>
  ELEMENTAL SUBROUTINE clear_OBBoxType(thisBox)
    CLASS(OBBoxType),INTENT(INOUT) :: thisBox
    CALL thisBox%p0%clear()
    thisBox%u=0.0_SRK
    thisBox%e=0.0_SRK
  ENDSUBROUTINE clear_OBBoxType
!
!-------------------------------------------------------------------------------
!> @brief Sets a OBBoxType object's atrributes
!> @param box the OBBoxType object to set
!> @param p0 the start corner point of the box
!> @param e_in the extent of every dimension
!> @param u1_in the vector that points to the first dimension
!> @param u2_in the vector that points to the second dimension
!> @param u3_in the vector that points to the third dimension (optional)
!>
!> If the box is in 2D space, the parameter "u3_in" will be useless.
!>
PURE SUBROUTINE set_OBBoxType(thisBox,p0,e_in,u1_in,u2_in,u3_in)
  CLASS(OBBoxType),INTENT(INOUT) :: thisBox
  TYPE(PointType),INTENT(IN) :: p0
  REAL(SRK),INTENT(IN) :: e_in(:)
  REAL(SRK),INTENT(IN) :: u1_in(:)
  REAL(SRK),INTENT(IN) :: u2_in(:)
  REAL(SRK),INTENT(IN),OPTIONAL :: u3_in(:)

  REAL(SRK) :: u1(3),u2(3),u3(3)
  REAL(SRK) :: magn1,magn2,magn3,dotmp1,dotmp2,dotmp3,r
  INTEGER(SIK) :: ndim,nnon0

  CALL thisBox%clear()
  ndim=p0%dim

  IF(SIZE(e_in) >= ndim .AND. SIZE(u1_in) >= ndim .AND. SIZE(u2_in) >= ndim) THEN
    u1=0.0_SRK
    u2=0.0_SRK
    IF(ndim == 2) THEN
      IF(e_in(1) > 0.0_SRK .AND. e_in(2) > 0.0_SRK) THEN
        u1(1)=u1_in(1)
        u1(2)=u1_in(2)
        u2(1)=u2_in(1)
        u2(2)=u2_in(2)

        !Renormalize the vectors
        magn1=u1(1)*u1(1)+u1(2)*u1(2)
        magn2=u2(1)*u2(1)+u2(2)*u2(2)
        IF(.NOT.(magn1 .APPROXEQA. 1._SRK) .AND. magn1 /= 0.0_SRK) THEN
          r=1._SRK/SQRT(magn1)
          u1(1)=u1(1)*r
          u1(2)=u1(2)*r
        ENDIF
        IF(.NOT.(magn2 .APPROXEQA. 1._SRK) .AND. magn2 /= 0.0_SRK) THEN
          r=1._SRK/SQRT(magn2)
          u2(1)=u2(1)*r
          u2(2)=u2(2)*r
        ENDIF
        dotmp1=u1(1)*u2(1)+u1(2)*u2(2)

        !Check that the vector lengths are non-zero and at a right angle
        IF(magn1 > EPSREAL .AND. magn2 > EPSREAL .AND. ABS(dotmp1) < EPSREAL) THEN
          !Assign values to OBB
          thisBox%p0=p0
          thisBox%u(1,1)=u1(1)
          thisBox%u(2,1)=u1(2)
          thisBox%u(1,2)=u2(1)
          thisBox%u(2,2)=u2(2)
          thisBox%e(1)=e_in(1)
          thisBox%e(2)=e_in(2)
        ENDIF
      ENDIF
    ELSEIF(ndim == 3) THEN
      !OBB is 3-D

      !Insure that at least 2 of the extents are non-zero
      nnon0=0
      IF(e_in(1) > 0.0_SRK) nnon0=nnon0+1
      IF(e_in(2) > 0.0_SRK) nnon0=nnon0+1
      IF(e_in(3) > 0.0_SRK) nnon0=nnon0+1
      IF(nnon0 >= 2) THEN
        u1(1)=u1_in(1)
        u1(2)=u1_in(2)
        u1(3)=u1_in(3)
        u2(1)=u2_in(1)
        u2(2)=u2_in(2)
        u2(3)=u2_in(3)

        !Renormalize the vectors
        magn1=u1(1)*u1(1)+u1(2)*u1(2)+u1(3)*u1(3)
        magn2=u2(1)*u2(1)+u2(2)*u2(2)+u2(3)*u2(3)
        IF(.NOT.(magn1 .APPROXEQA. 1._SRK) .AND. magn1 /= 0.0_SRK) THEN
          r=1._SRK/SQRT(magn1)
          u1(1)=u1(1)*r
          u1(2)=u1(2)*r
          u1(3)=u1(3)*r
        ENDIF
        IF(.NOT.(magn2 .APPROXEQA. 1._SRK) .AND. magn2 /= 0.0_SRK) THEN
          r=1._SRK/SQRT(magn2)
          u2(1)=u2(1)*r
          u2(2)=u2(2)*r
          u2(3)=u2(3)*r
        ENDIF
        dotmp1=u1(1)*u2(1)+u1(2)*u2(2)+u1(3)*u2(3)

        magn3=1._SRK
        dotmp2=0._SRK
        dotmp3=0._SRK
        IF(PRESENT(u3_in)) THEN
          !Process u3_in
          u3(1)=u3_in(1)
          u3(2)=u3_in(2)
          u3(3)=u3_in(3)
          magn3=u3(1)*u3(1)+u3(2)*u3(2)+u3(3)*u3(3)
          IF(.NOT.(magn3 .APPROXEQA. 1._SRK) .AND. magn3 /= 0.0_SRK) THEN
            r=1._SRK/SQRT(magn3)
            u3(1)=u3(1)*r
            u3(2)=u3(2)*r
            u3(3)=u3(3)*r
          ENDIF
          dotmp2=u1(1)*u3(1)+u1(2)*u3(2)+u1(3)*u3(3)
          dotmp3=u3(1)*u2(1)+u3(2)*u2(2)+u3(3)*u2(3)
        ELSE
          !Compute u3 as the cross product of u1 and u2
          u3(1)=u1(2)*u2(3)-u1(3)*u2(2)
          u3(2)=u1(3)*u2(1)-u1(1)*u2(3)
          u3(3)=u1(1)*u2(2)-u1(2)*u2(1)
          magn3=u3(1)*u3(1)+u3(2)*u3(2)+u3(3)*u3(3)
          IF(.NOT.(magn3 .APPROXEQA. 1._SRK) .AND. magn3 /= 0.0_SRK) THEN
            r=1._SRK/SQRT(magn3)
            u3(1)=u3(1)*r
            u3(2)=u3(2)*r
            u3(3)=u3(3)*r
          ENDIF
        ENDIF

        !Check that the vector lengths are non-zero and at a right angle
        IF(magn1 /= 0._SRK .AND. magn2 /= 0._SRK &
            .AND. magn3 /= 0._SRK .AND. ABS(dotmp1) < EPSREAL &
            .AND. ABS(dotmp2) < EPSREAL .AND. ABS(dotmp3) < EPSREAL) THEN
          thisBox%p0=p0
          thisBox%u(1,1)=u1(1)
          thisBox%u(2,1)=u1(2)
          thisBox%u(3,1)=u1(3)
          thisBox%u(1,2)=u2(1)
          thisBox%u(2,2)=u2(2)
          thisBox%u(3,2)=u2(3)
          thisBox%u(1,3)=u3(1)
          thisBox%u(2,3)=u3(2)
          thisBox%u(3,3)=u3(3)
          thisBox%e(1)=e_in(1)
          thisBox%e(2)=e_in(2)
          thisBox%e(3)=e_in(3)
        ENDIF
      ENDIF
    ENDIF
  ENDIF
ENDSUBROUTINE set_OBBoxType
!
!-------------------------------------------------------------------------------
!> @brief Determine the point(s) of intersection between an OBB and line
!> segment (if it exists)
!> @param box the box to test to intersection
!> @param line the line segment to test to intersection
!> @param p1 the first intersection which is near to the segment starting point
!> @param p2 the second intersection which is far from the segment starting point
!> @returns @c p1 the line segment of intersection
!> @note a return code is assigned to p1%dim/p2%dim indicating the
!>   type of shortest route segment.
!>   -3: there is no intersection (disjoint) @n
!>   -1: problem with dummy arguments passed to routine @n
!>  > 1: success; an shortest distance was found @n
!>
!> If the two points overlap, it will successfully return two points. If only
!> one point is got, another point status is indicated by %dim.
!>
!> The algorithm for finding the intersection is similar to that outlined
!> in section 5.3.3 of "Real-Time Collision Detection" by Christer Ericson.
!> The problem for the intersection is stated as a ray and an axis-aligned
!> bounding box (AABB) and has been adapted for a segment and an OBB.
!>
ELEMENTAL SUBROUTINE intersect_OBBoxType_and_LineType(thisBox,line,p1,p2)
  CLASS(OBBoxType),INTENT(IN) :: thisBox
  TYPE(LineType),INTENT(IN) :: line
  TYPE(PointType),INTENT(INOUT) :: p1,p2

  REAL(SRK) :: coord(3),dir(3),dir_world(3),coord_new(3)
  REAL(SRK) :: tmin,tmax,invdir,t1,t2,t
  INTEGER(SIK) :: i,ndim

  p1%dim=-1
  p2%dim=-1

  !Check the box and line
  ndim=thisBox%p0%dim
  IF(ndim == line%p1%dim .AND. ndim == line%p2%dim .AND. ndim > 1) THEN
    p1%dim=-3
    p2%dim=-3

    IF(ndim == 2) THEN
!2-D
      !Translate the coordinate into the OBB system.
      dir_world(1)=line%p2%coord(1)-line%p1%coord(1)
      dir_world(2)=line%p2%coord(2)-line%p1%coord(2)

      coord(1)=line%p1%coord(1)-thisBox%p0%coord(1)
      coord(2)=line%p1%coord(2)-thisBox%p0%coord(2)

      dir(1)=dir_world(1)*thisBox%u(1,1)+dir_world(2)*thisBox%u(2,1)
      dir(2)=dir_world(1)*thisBox%u(1,2)+dir_world(2)*thisBox%u(2,2)

      coord_new(1)=coord(1)*thisBox%u(1,1)+coord(2)*thisBox%u(2,1)
      coord_new(2)=coord(1)*thisBox%u(1,2)+coord(2)*thisBox%u(2,2)
    ELSEIF(ndim == 3) THEN
!3-D
      !Translate the coordinate into the OBB system.
      dir_world(1)=line%p2%coord(1)-line%p1%coord(1)
      dir_world(2)=line%p2%coord(2)-line%p1%coord(2)
      dir_world(3)=line%p2%coord(3)-line%p1%coord(3)

      coord(1)=line%p1%coord(1)-thisBox%p0%coord(1)
      coord(2)=line%p1%coord(2)-thisBox%p0%coord(2)
      coord(3)=line%p1%coord(3)-thisBox%p0%coord(3)

      dir(1)=dir_world(1)*thisBox%u(1,1)+dir_world(2)*thisBox%u(2,1)+ &
          dir_world(3)*thisBox%u(3,1)
      dir(2)=dir_world(1)*thisBox%u(1,2)+dir_world(2)*thisBox%u(2,2)+ &
          dir_world(3)*thisBox%u(3,2)
      dir(3)=dir_world(1)*thisBox%u(1,3)+dir_world(2)*thisBox%u(2,3)+ &
          dir_world(3)*thisBox%u(3,3)

      coord_new(1)=coord(1)*thisBox%u(1,1)+coord(2)*thisBox%u(2,1)+ &
          coord(3)*thisBox%u(3,1)
      coord_new(2)=coord(1)*thisBox%u(1,2)+coord(2)*thisBox%u(2,2)+ &
          coord(3)*thisBox%u(3,2)
      coord_new(3)=coord(1)*thisBox%u(1,3)+coord(2)*thisBox%u(2,3)+ &
          coord(3)*thisBox%u(3,3)
    ENDIF

    tmin=-1._SRK
    tmax=1.e30_SRK
    DO i=1,ndim
      IF(ABS(dir(i)) < EPSREAL) THEN
        !If segment is parallel to box, and if the coordinate for that
        !dimension is outside box then there is no intersection
        IF(coord_new(i) < 0._SRK-EPSREAL .OR. &
            coord_new(i) > thisBox%e(i)+EPSREAL) RETURN
      ELSE
        invdir=1._SRK/dir(i)
        t1=(-coord_new(i))*invdir
        t2=(thisBox%e(i)-coord_new(i))*invdir
        !Make t1 be the closer of the two intersections
        IF(t1 > t2) THEN
          t=t2
          t2=t1
          t1=t
        ENDIF
        IF(t1 > tmin) tmin=t1
        IF(t2 < tmax) tmax=t2

        !Exit if intersection with box becomes empty
        IF(tmin > tmax) RETURN
      ENDIF
    ENDDO

    !Segment intersects in all dimensions so compute the points
    !The first point lies on the segment
    p1=thisBox%p0
    p1%coord(1)=line%p1%coord(1)+dir_world(1)*tmin
    p1%coord(2)=line%p1%coord(2)+dir_world(2)*tmin
    IF(ndim == 3) p1%coord(3)=line%p1%coord(3)+dir_world(3)*tmin

    !The second point lies on the segment
    p2=thisBox%p0
    p2%coord(1)=line%p1%coord(1)+dir_world(1)*tmax
    p2%coord(2)=line%p1%coord(2)+dir_world(2)*tmax
    IF(ndim == 3) p2%coord(3)=line%p1%coord(3)+dir_world(3)*tmax
  ENDIF
ENDSUBROUTINE intersect_OBBoxType_and_LineType
!
!-------------------------------------------------------------------------------
!> @brief Returns the lines the make up a OBBoxType object
!> @param box the OBBoxType object to decompose
!> @param lines the array of line types to be returned
!>
!> Only works for 2-D currently.
!>
PURE SUBROUTINE getLines_OBBoxType(thisBox,lines)
 CLASS(OBBoxType),INTENT(INOUT) :: thisBox
 TYPE(LineType),INTENT(OUT),ALLOCATABLE :: lines(:)

 IF(thisBox%p0%dim == 2) THEN
   ALLOCATE(lines(4))
   lines(1)%p1=thisBox%p0
   lines(4)%p2=thisBox%p0
   CALL lines(1)%p2%init(DIM=2,X=thisBox%p0%coord(1)+thisBox%u(1,1)*thisBox%e(1), &
       Y=thisBox%p0%coord(2)+thisBox%u(2,1)*thisBox%e(1))
   lines(2)%p1=lines(1)%p2
   CALL lines(2)%p2%init(DIM=2,X=lines(2)%p1%coord(1)+thisBox%u(1,2)*thisBox%e(2), &
       Y=lines(2)%p1%coord(2)+thisBox%u(2,2)*thisBox%e(2))
   lines(3)%p1=lines(2)%p2
   CALL lines(3)%p2%init(DIM=2,X=thisBox%p0%coord(1)+thisBox%u(1,2)*thisBox%e(2), &
       Y=thisBox%p0%coord(2)+thisBox%u(2,2)*thisBox%e(2))
   lines(4)%p1=lines(3)%p2
 !ELSE
 ENDIF
ENDSUBROUTINE getLines_OBBoxType
!
!-------------------------------------------------------------------------------
!> @brief Returns the lines the make up a OBBoxType object
!> @param box the OBBoxType object to decompose
!> @param lines the array of line types to be returned
!>
!> Only works for 3-D currently.
!>
PURE SUBROUTINE getPlanes_OBBoxType(thisBox,planes)
 CLASS(OBBoxType),INTENT(INOUT) :: thisBox
 TYPE(PlaneType),INTENT(OUT),ALLOCATABLE :: planes(:)
 TYPE(PointType) :: tmpPt

  IF(thisBox%p0%dim == 3) THEN
    ALLOCATE(planes(6))
    planes(1)%v0=thisBox%p0
    planes(1)%n=thisBox%u(:,1)
    planes(2)%v0=thisBox%p0
    planes(1)%n=thisBox%u(:,2)
    planes(3)%v0=thisBox%p0
    planes(1)%n=thisBox%u(:,3)
    CALL tmpPt%init(X=thisBox%p0%coord(1)+thisBox%u(1,1)*thisBox%e(1)+ &
        thisBox%u(1,2)*thisBox%e(2)+thisBox%u(1,3)*thisBox%e(3), &
        Y=thisBox%p0%coord(2)+thisBox%u(2,1)*thisBox%e(1)+ &
        thisBox%u(2,2)*thisBox%e(2)+thisBox%u(2,3)*thisBox%e(3), &
        Z=thisBox%p0%coord(3)+thisBox%u(3,1)*thisBox%e(1)+ &
        thisBox%u(3,2)*thisBox%e(2)+thisBox%u(3,3)*thisBox%e(3))
    planes(4)%v0=tmpPt
    planes(4)%n=thisBox%u(:,1) !Does this need to be made negative?
    planes(5)%v0=tmpPt
    planes(4)%n=thisBox%u(:,2) !Does this need to be made negative?
    planes(6)%v0=tmpPt
    planes(4)%n=thisBox%u(:,3) !Does this need to be made negative?
  !ELSE
  ENDIF
ENDSUBROUTINE getPlanes_OBBoxType
!
!-------------------------------------------------------------------------------
!> @brief Returns the lines the make up a OBBoxType object
!> @param box the OBBoxType object to decompose
!> @param lines the array of line types to be returned
!>
!> Only works for 2-D currently.
!>
ELEMENTAL FUNCTION inside_OBBoxType(thisBox,point) RESULT(bool)
 CLASS(OBBoxType),INTENT(IN) :: thisBox
 TYPE(PointType),INTENT(IN) :: point
 LOGICAL(SBK) :: bool
 TYPE(PointType) :: px,py
 REAL(SRK) :: pxmag,pymag,pxproj,pyproj

  bool=.FALSE.
  IF(point%dim == 2) THEN
    CALL px%init(DIM=2,X=thisBox%u(1,1)*thisBox%e(1), &
        Y=thisBox%u(2,1)*thisBox%e(1))
    CALL py%init(DIM=2,X=thisBox%u(1,2)*thisBox%e(2), &
        Y=thisBox%u(2,2)*thisBox%e(2))
    pxmag=(px%coord(1)-thisBox%p0%coord(1))*(px%coord(1)-thisBox%p0%coord(1))+&
        (px%coord(2)-thisBox%p0%coord(2))*(px%coord(2)-thisBox%p0%coord(2))
    pymag=(py%coord(1)-thisBox%p0%coord(1))*(py%coord(1)-thisBox%p0%coord(1))+&
        (py%coord(2)-thisBox%p0%coord(2))*(py%coord(2)-thisBox%p0%coord(2))
    pxproj=(px%coord(1)-thisBox%p0%coord(1))*(point%coord(1)-thisBox%p0%coord(1))+ &
        (px%coord(2)-thisBox%p0%coord(2))*(point%coord(2)-thisBox%p0%coord(2))
    IF((0.0_SRK .APPROXLE. pxproj) .AND. (pxproj .APPROXLE. pxmag)) THEN
        pyproj=(py%coord(1)-thisBox%p0%coord(1))*(point%coord(1)-thisBox%p0%coord(1))+ &
        (py%coord(2)-thisBox%p0%coord(2))*(point%coord(2)-thisBox%p0%coord(2))
        bool=(0.0_SRK .APPROXLE. pyproj) .AND. (pyproj .APPROXLE. pymag)
    ENDIF
  ELSEIF(point%dim == 3) THEN
  ENDIF
ENDFUNCTION inside_OBBoxType
!
!-------------------------------------------------------------------------------
!> @brief Defines the 'is equal to' operation between two OBBoxes e.g. @c b0==b1
!> @param p0 the first box
!> @param p1 the second box
!> @returns @c bool the boolean result of the operation
!>
!> Function is elemental so it can be used on an array of boxes.
ELEMENTAL FUNCTION isequal_OBBoxType(b0,b1) RESULT(bool)
  TYPE(OBBoxType),INTENT(IN) :: b0,b1
  LOGICAL(SBK) :: bool
  bool=.FALSE.
  IF(b0%p0 == b1%p0 .AND. ALL(b0%u .APPROXEQA. b1%u)) &
      bool=ALL(b0%e.APPROXEQA. b1%e)
ENDFUNCTION isequal_OBBoxType
!
!-------------------------------------------------------------------------------
!> @brief Constructor for the ABBoxType
!> @param thisABB the ABBoxType object to be initialized
!> @param xMin the minimum x-extent of the box
!> @param xMax the maximum x-extent of the box
!> @param yMin the minimum y-extent of the box
!> @param yMax the maximum y-extent of the box
!>
!> This routine sets the attributes of a ABBoxType object.
ELEMENTAL SUBROUTINE set_ABBoxType(thisABB,xMin,xMax,yMin,yMax,zMin,zMax)
  CLASS(ABBoxType),INTENT(INOUT) :: thisABB
  REAL(SRK),INTENT(IN) :: xMin,xMax,yMin,yMax
  REAL(SRK),INTENT(IN),OPTIONAL :: zMin,zMax

  thisABB%xMin=xMin
  thisABB%xMax=xMax
  thisABB%yMin=yMin
  thisABB%yMax=yMax
  IF(PRESENT(zMin) .AND. PRESENT(zMax)) THEN
    thisABB%zMin=zMin
    thisABB%zMax=zMax
    thisABB%is3D=.TRUE.
  ELSE
    thisABB%is3D=.FALSE.
  ENDIF
  thisABB%isSet=.TRUE.
  thisABB%isOrigin=((xMin <= 0.0_SRK) .AND. (xMax >= 0.0_SRK) .AND. &
      (yMin <= 0.0_SRK) .AND. (yMax >= 0.0_SRK))

ENDSUBROUTINE set_ABBoxType
!
!-------------------------------------------------------------------------------
!> @brief Clears the attributes of a ABBoxType object
!> @param thisABB the ABBoxType object to be cleared
!>
ELEMENTAL SUBROUTINE clear_ABBoxType(thisABB)
  CLASS(ABBoxType),INTENT(INOUT) :: thisABB
  thisABB%xMin=0.0_SRK
  thisABB%xMax=0.0_SRK
  thisABB%yMin=0.0_SRK
  thisABB%yMax=0.0_SRK
  thisABB%zMin=0.0_SRK
  thisABB%zMax=0.0_SRK
  thisABB%is3D=.FALSE.
  thisABB%isSet=.FALSE.
  thisABB%isOrigin=.FALSE.
ENDSUBROUTINE clear_ABBoxType
!
!-------------------------------------------------------------------------------
!> @brief Tests if a point is inside a box
!> @param thisABB the box
!> @param p the point
!> @returns inside .TRUE. if p is inside the box.
!>
ELEMENTAL FUNCTION inside_ABBoxType(thisABB,p) RESULT(inside)
  CLASS(ABBoxType),INTENT(IN) :: thisABB
  TYPE(PointType),INTENT(IN) :: p
  REAL(SRK),PARAMETER :: fuzz=1e-6_SRK
  LOGICAL(SBK) :: inside

  inside=.FALSE.
  IF(p%dim > 1) THEN
    inside=((p%coord(1) > thisABB%xMin-fuzz) .AND. &
        (p%coord(1) < thisABB%xMax+fuzz) .AND. &
        (p%coord(2) > thisABB%yMin-fuzz) .AND. &
        (p%coord(2) < thisABB%yMax+fuzz))
  ENDIF
  IF(p%dim == 3 .AND. thisABB%is3D) THEN
    inside=(inside .AND. &
        (p%coord(3) > thisABB%zMin-fuzz) .AND. &
        (p%coord(3) < thisABB%zMax+fuzz))
  ENDIF

ENDFUNCTION inside_ABBoxType
!
ENDMODULE Geom_Box