      SUBROUTINE TWOSTR(Sigr,U0,Sq,Wav,Ll,nzp1,nz2,absorbers,S,surface_radiance)
        use photochem_data, only: nz, kj, alb, nw, np, dz
        use photochem_vars, only: Den
        use photochem_wrk, only: QEXTT, W0T, GFT, aersol, rpar

!note i haven't yet done the work to fully abstract particles in this subroutine.
!hydrocarbons are using optical properties files, while sulfate and sulfur are hardcoded.

! in call, from Photo, send WAV(L) in the WAV position, and L in the LL position
!IKN is a printing option, NN is just N as sent to Photo
!S is the returned source function

!   This is my version of the Toon et al. 2-stream code.  (Ref.: JGR
!   94, 16287, 1989).  It vectorizes over height, rather than wavelength,
!   and is designed to work with PRIMS3 and its companion photochemical
!   models.
!
!   For now, at least, it is hardwired as the quadrature approximation.
!   NP is the number of different types of particles

      IMPLICIT NONE

      ! module variables
      ! ...

      ! local varaibles
      real*8, intent(in) :: sigr(nz)
      real*8, intent(in) :: U0
      real*8, intent(in) :: sq(kj,nz,nw)
      real*8, intent(in) :: wav
      integer, intent(in) :: Ll
      integer, intent(in) :: nzp1
      integer, intent(in) :: nz2
      real*8, intent(in) :: absorbers(kj,nz)
      real*8, intent(out) :: S(nz)
      real*8, intent(out) :: surface_radiance

      real*8 tau(NZ) , tauctstr(NZP1) , gt(NZ) , gam1(NZ) , gam2(NZ) &
              & , gam3(NZ) , gam4(NZ) , alam(NZ) , cgam(NZ) , e1(NZ) ,  &
              & e2(NZ) , e3(NZ) , e4(NZ) , cp0(NZ) , cpb(NZ) , cm0(NZ) ,&
              & cmb(NZ) , y1(NZ) , y2(NZ) , w0(NZ) , tausg(NZ) ,        &
              & tausp(NZ) , direct(NZP1) , amean(NZP1) , taug(NZ) ,     &
              & fmt(NZ)
      real*8 a(NZ2) , b(NZ2) , d(NZ2) , e(NZ2) , fup(NZP1) ,         &
              & fdn(NZP1)
      real*8 w0p(np) , qext(np) , tauscat_part(np,NZ) , taup(NZ)
      real*8 tau_part(np,NZ)
      real*8 denom, emlt, et0, etb, facm, facp, gp, gpnew
      integer i, j, k, l, l1, mz2, n,nflag, nzm1
      real*8 pi, sq3, ssfc, taua, taup1, u0m, u0m2, u1, u1m
      integer O

      O = 0
      ! initialize everyting
      tau = 0.d0
      tauctstr = 0.0d0
      gt = 0.d0
      gam1 = 0.d0
      gam2 = 0.d0
      gam3 = 0.d0
      gam4 = 0.d0
      alam = 0.d0
      cgam = 0.d0
      e1 = 0.d0
      e2 = 0.d0
      e3 = 0.d0
      e4 = 0.d0
      cp0 = 0.d0
      cpb = 0.d0
      cm0 = 0.d0
      cmb = 0.d0
      y1 = 0.d0
      y2 = 0.d0
      w0 = 0.d0
      tausg = 0.d0
      tausp = 0.d0
      direct = 0.d0
      amean = 0.d0
      taug = 0.d0
      fmt = 0.d0
      a = 0.d0
      b = 0.d0
      d = 0.d0
      e = 0.d0
      fup = 0.d0
      fdn = 0.d0
      w0p = 0.d0
      qext = 0.d0
      tauscat_part = 0.d0
      taup = 0.d0
      tau_part = 0.d0
      denom = 0.d0
      emlt = 0.d0
      et0 = 0.d0
      etb = 0.d0
      facm = 0.d0
      facp = 0.d0
      gp = 0.d0
      gpnew = 0.d0
      pi = 0.d0
      sq3 = 0.d0
      ssfc = 0.d0
      taua = 0.d0
      taup1 = 0.d0
      u0m = 0.d0
      u0m2 = 0.d0
      u1 = 0.d0
      u1m = 0.d0

      i = 0
      j = 0
      k = 0
      l = 0
      l1 = 0
      mz2 = 0
      n = 0
      nflag = 0
      nzm1 = 0

!this FUP is different from the lower boundary flux terms in Output.f.  Should be fine here.

!     U1 = 0.5  (Eddington value)
      sq3 = SQRT(3.)
      pi = 3.14159
      u1 = 1./sq3
      u0m = 1./U0
      u0m2 = u0m*u0m
      u1m = 1./u1
      nzm1 = NZ - 1
      mz2 = NZ2
      gp = 0.8  !old

!
!   Calculate the optical depths of the different layers.  TAUA is absorption,
!   TAUSG is scattering by gases, TAUSP is scattering by particles, TAUG is
!   extinction due to gases, TAU is total extinction due to gases and
!   particles.
!   Note that the grid for this subroutine is numbered from top to bottom,
!   whereas the main program is numbered from bottom to top.
!   First do gases

      DO i = 1 , NZ
         n = NZP1 - i
         tausp(n) = 0.
         taup(n) = 0.
         tausg(n) = Sigr(i)*DEN(i)*DZ(i)

! Can below be removed?
!orig      TAUA = ( SO3(I)*O3(I) + SO2(I)*O2(I) + SCO2*CO2(I) + SH2O*H2O(I)
!orig     2   + SSO2*FSO2(I) + SS2*S2(I) + SH2S*H2S(I) + SNH3*FNH3(I) )
!orig     3   * DEN(I)*DZ
!orig   TAUG(N) = TAUA + TAUSG(N)

!Sspecies(I) is the species cross section at the given height
!Fspecies are absolute values of species mixing ratios
!so, in my scheme where everything absorbs, this would be:
!a loop over kj (to get all species that absorb (at each height)) -
!of sq*absorbers

         taua = 0.0
         DO j = 1 , kj
            ! IF ( planet.EQ.'WASP12B' ) THEN
            !    IF ( j.LT.9 ) taua = taua + Sq(j,i,Ll)*ABSORBERS(j,i)
            ! ELSE
               taua = taua + Sq(j,i,Ll)*ABSORBERS(j,i)
            ! ENDIF
         ENDDO

         taug(n) = taua*DEN(i)*DZ(i) + tausg(n)

      ENDDO

!   Now do particles.  Must combine their scattering optical depths into a
!   single array in order to calculate W0 and G.  (TAUSP(N))
!   Don't need any arrays for pure absorption.
!   Scale optical depth, W0, and G for the particles using the Delta-
!   Eddington approximation of Joseph et al. (Ref: J. Atmos. Sci. 33,
!   2452, 1976)

!gna - this is the correction for forward scattering: delta eddington approximation

      IF ( np.GT.o ) THEN
                        !REMOVE THE PARTICLE STUFF, YET AGAIN....
!   Particle 1 is sulfate, 2 is S8, 3 is HCAER
         DO k = 1 , np
            w0p(k) = 0.0
            IF ( k.LT.3 ) w0p(k) = 1.
            IF ( k.EQ.2 .AND. Wav.LE.3500. ) w0p(k) = 0.5
                                                  !ACK hardcoded grid
 !      print*, 'K,W0P=', K,W0P
         ENDDO
!here, Kevin uses a formula to compute WOPS and QEXT (fom G0=0.8 and WOP)

         DO j = 1 , np
            DO i = 1 , NZ
               n = NZP1 - i
!-MC Here, we are including correct value of Qext and W0P for hydrocarbons
               IF ( j.GE.3 ) THEN
       !hardcoded for HCAER and HCAER2
                  qext(j) = QEXTT(Ll,i,j)
                  w0p(j) = W0T(Ll,i,j)
               ELSE
       !for sulfate and S8 : valid for large particles only, but this is status quo for now...
                  qext(j) = 2.
       !W0P set above
       !for sulfate and S8, set assymetry factor to GP=0.8 (alt and wl independent)
                  GFT(Ll,i,j) = 0.8
               ENDIF

               taup1 = qext(j)*pi*RPAR(i,j)*RPAR(i,j)*AERSOL(i,j)*DZ(i)
      !particle extinction for each particle at each height
      !not used, but might as well keep
               tau_part(j,i) = taup1
      !particle scattering for each particle at each height
               tauscat_part(j,i) = w0p(j)*taup1
      !TAUSP contains total particle scattering at each height
               tausp(n) = tausp(n) + tauscat_part(j,i)
      !TAUP contains total particle extinction at each height
               taup(n) = taup(n) + taup1
            ENDDO
         ENDDO
      ENDIF

!   Calculate W0 and G by averaging over Rayleigh and Mie scatterers.
!   (scattering due to gases vs. particles)
!   Avoid letting W0 equal exactly 1.
      DO n = 1 , NZ
      !TAU is total extinction (Gas + Rayleigh + Particle)
         tau(n) = taug(n) + taup(n)
      !w0 = total scattering/total extinction
         w0(n) = (tausg(n)+tausp(n))/tau(n)
         w0(n) = min(w0(n),0.999999d0)
!-mab: Was "0.999" before - extra 99s needed for WASP12B convergence

      !GFT is still bottom to top, so needs a switch
         i = NZP1 - n

         gpnew = 0.0
         IF ( np.GT.o ) THEN
                        !REMOVE THE PARTICLE STUFF, YET AGAIN....
            DO k = 1 , np
      !asymmetry factors weighted by particle scattering/total scattering
               gpnew = gpnew + GFT(Ll,i,k)*tauscat_part(k,i)            &
                     & /(tausp(n)+tausg(n))
            ENDDO

      !dont let assymetry factor get larger than 1
            gt(n) = min(gpnew,0.999999d0)
         ELSE
            gt(n) = 0.0
         ENDIF

      ENDDO

!   Delta-Eddington scaling
!-AP I used approximation from Joseph et al. 1976
      DO n = 1 , NZ
         fmt(n) = gt(n)*gt(n)
         tau(n) = tau(n)*(1.-w0(n)*fmt(n))
         w0(n) = w0(n)*(1.-fmt(n))/(1.-w0(n)*fmt(n))
         gt(n) = gt(n)/(1.+gt(n))
      ENDDO
!-AP**************************************************
!
!   Calculate the gamma's, lambda's, and e's
      DO n = 1 , NZ
!     GAM1(N) = (7. - W0(N)*(4.+3.*GT(N)))/4.
!     GAM2(N) = - (1. - W0(N)*(4.-3.*GT(N)))/4.
!     GAM3(N) = (2. - 3.*GT(N)*U0)/4.
!   (Eddington values above; quadrature values below)
!
         gam1(n) = sq3*(2.-w0(n)*(1.+gt(n)))/2.
         gam2(n) = sq3*w0(n)*(1.-gt(n))/2.
         gam3(n) = (1.-sq3*gt(n)*U0)/2.
         IF ( np.EQ.0 ) gam3(n) = (1.-sq3*U0)/2.
         gam4(n) = 1. - gam3(n)

         alam(n) = SQRT(gam1(n)*gam1(n)-gam2(n)*gam2(n))
         cgam(n) = (gam1(n)-alam(n))/gam2(n)
         emlt = EXP(-alam(n)*tau(n))

         e1(n) = 1. + cgam(n)*emlt
         e2(n) = 1. - cgam(n)*emlt
         e3(n) = cgam(n) + emlt
         e4(n) = cgam(n) - emlt
      ENDDO

!   Calculate A, B, and D, i.e. the coefficients of the tridiagonal matrix
!   Top of atmosphere
      a(1) = 0.
      b(1) = e1(1)
      d(1) = -e2(1)

!   Odd coefficients
      DO n = 1 , nzm1
         l = 2*n + 1
         a(l) = e2(n)*e3(n) - e4(n)*e1(n)
         b(l) = e1(n)*e1(n+1) - e3(n)*e3(n+1)
         d(l) = e3(n)*e4(n+1) - e1(n)*e2(n+1)
      ENDDO

!   Even coefficients
      DO n = 1 , nzm1
         l = 2*n
         a(l) = e2(n+1)*e1(n) - e3(n)*e4(n+1)
         b(l) = e2(n)*e2(n+1) - e4(n)*e4(n+1)
         d(l) = e1(n+1)*e4(n+1) - e2(n+1)*e3(n+1)
      ENDDO

!   Bottom of atmosphere
      a(NZ2) = e1(NZ) - alb*e3(NZ)
      b(NZ2) = e2(NZ) - alb*e4(NZ)
      d(NZ2) = 0.

!   Now, set up the RHS of the equation:
!   TAUCTSTR(N) is the optical depth above layer N
      tauctstr(1) = 0.
      DO n = 2 , NZP1
         tauctstr(n) = tauctstr(n-1) + tau(n-1)
      ENDDO
! On last call,
! Print out TAUCTSTR(N), TAU(N), W0(N), GT(N), TAUSG(N), TAUSP(N).
! Also print TAUC at the ground for all wavelengths.

!       IF ( Nn.EQ.1 .AND. Ikn.EQ.1 ) THEN
!       !ACK - check LUN
!          WRITE (22,99001) Wav , tauctstr(NZP1)
! 99001    FORMAT (1X,F6.1,2X,1PE10.3)
!       !ACK - what are these hardcoded wavelengths???
!          IF ( Wav.EQ.1860.5 .OR. Wav.EQ.2010. .OR. Wav.EQ.2116.5 .OR.   &
!             & Wav.EQ.2211. .OR. Wav.EQ.2312.5 .OR. Wav.EQ.2516. .OR.    &
!             & Wav.EQ.3007.5 .OR. Wav.EQ.3900. .OR. Wav.EQ.4500. ) THEN
!       !ACK - check LUN
!             WRITE (20,99002) Wav , U0 , alb
! 99002       FORMAT ('# WAV = ',F6.1,2X,'U0 = ',F6.4,2X,'Rsfc = ',F5.3,/ &
!              &'# TWOSTR: TAUCTSTR(N) is the optical depth above layer N'&
!             & ,/'#  Z',4X,'TAUCTSTR(N)',4X,'TAU(N)',5X,'W0(N)',6X,      &
!             & 'G(N)',6X,'TAUSG(N)',3X,'TAUSP(N)',3X,'N')
!             DO n = 1 , NZ
!                i = NZP1 - n
!       !ACK - check LUN
!                WRITE (20,99003) i , tauctstr(n) , tau(n) , w0(n) ,      &
!                               & gt(n) , tausg(n) , tausp(n) , n
! 99003          FORMAT (1X,I3,1P6E11.3,1X,I3)
!             ENDDO
!       !ACK - check LUN
!             WRITE (20,99004) tauctstr(NZP1)
! 99004       FORMAT ('#  0',1PE11.3)
!          ENDIF
!       ENDIF

!   DIRECT(N) is the direct solar flux at the top of layer N.  Values
!   are normalized to unity.  DIRECT(NZP1) is the direct flux at the ground.
      direct(1) = U0
      DO n = 1 , NZ
         et0 = EXP(-tauctstr(n)/U0)
         etb = et0*EXP(-tau(n)/U0)
         direct(n+1) = etb*U0
         denom = alam(n)*alam(n) - u0m2
         facp = w0(n)*((gam1(n)-u0m)*gam3(n)+gam4(n)*gam2(n))
         facm = w0(n)*((gam1(n)+u0m)*gam4(n)+gam2(n)*gam3(n))

         cp0(n) = et0*facp/denom
         cpb(n) = etb*facp/denom
         cm0(n) = et0*facm/denom
         cmb(n) = etb*facm/denom
      ENDDO
      ssfc = alb*direct(NZP1)

!   Odd coefficients
      e(1) = -cm0(1)
      DO n = 1 , nzm1
         l = 2*n + 1
         e(l) = (cp0(n+1)-cpb(n))*e3(n) + (cmb(n)-cm0(n+1))*e1(n)
      ENDDO

!   Even coefficients
      DO n = 1 , nzm1
         l = 2*n
         e(l) = (cp0(n+1)-cpb(n))*e2(n+1) - (cm0(n+1)-cmb(n))*e4(n+1)
      ENDDO
      e(NZ2) = ssfc - cpb(NZ) + alb*cmb(NZ)

!   Call the tridiagonal solver (from LINPACK).  E is the RHS of the matrix
!   equation on input and is the solution vector Y on output
      CALL SGTSL(mz2,a,b,d,e,nflag)
      IF ( nflag.NE.0 ) PRINT 99005 , nflag
99005 FORMAT (/1X,'Tridiagonal solver failed in TWOSTR, NFLAG =',I4)

      DO n = 1 , NZ
         l = 2*n
         l1 = l - 1
         y1(n) = e(l1)
         y2(n) = e(l)
      ENDDO

!   Calculate the mean intensities, AMEAN(N), at the boundaries between
!   the layers.  AMEAN(N) is the intensity at the top of layer N.
      amean(1) = u1m*(y1(1)*e3(1)-y2(1)*e4(1)+cp0(1)) + 1.
      DO n = 1 , NZ
         amean(n+1) = u1m*(y1(n)*(e1(n)+e3(n))+y2(n)*(e2(n)+e4(n))      &
                    & +cpb(n)+cmb(n)) + direct(n+1)/U0
      ENDDO

!   Reset any AMEAN values that may go negative.  Check error file
!   to be sure this only happens near the ground where AMEAN ~ 0.
      DO n = 1 , NZP1
         IF ( amean(n).LT.0.0 ) THEN
         !ACK - check LUN
!             WRITE (13,99006) Wav , n , amean(n)
! 99006       FORMAT ('WAVE =',F6.1,' AMEAN(',I3,')=',1PE11.3)
            amean(n) = ABS(amean(n))
         ENDIF
      ENDDO

!  Calculate upward and downward fluxes.

      fup(1) = ((y1(1)*e3(1)-y2(1)*e4(1))+cp0(1))
      fdn(1) = direct(1)
      DO n = 1 , NZ
         fup(n+1) = (y1(n)*e1(n)+y2(n)*e2(n)+cpb(n))
         fdn(n+1) = (y1(n)*e3(n)+y2(n)*e4(n)+cmb(n)) + direct(n+1)
      ENDDO

!   Convert back to main program grid.  S(I) is the mean intensity at the
!   midpoint of layer I.
      DO i = 1 , NZ
         n = NZP1 - i
         S(i) = SQRT(amean(n)*amean(n+1))
      ENDDO

      ! surface radiance (Ranjan and Sasselov 2017). photons actually hitting the ground (i think)
      i = nz
      surface_radiance = (y1(i)*e3(i)+y2(i)*e4(i)+cmb(i))/u1 + dexp(-tauctstr(i+1)/u0)

!  Print out the results at a few wavelengths

!       IF ( Nn.EQ.1 .AND. Ikn.EQ.1 ) THEN
!          IF ( Wav.EQ.1860.5 .OR. Wav.EQ.2010. .OR. Wav.EQ.2116.5 .OR.   &
!             & Wav.EQ.2211. .OR. Wav.EQ.2312.5 .OR. Wav.EQ.2516. .OR.    &
!             & Wav.EQ.3007.5 .OR. Wav.EQ.3900. .OR. Wav.EQ.4500. ) THEN
!       !ACK - check LUN
!             WRITE (21,99007) Wav , U0 , alb
! 99007       FORMAT (/'# WAV = ',F6.1,2X,'U0 = ',F6.4,2X,'Rsfc = ',F5.3, &
!                    &/'#  Z',4X,'S(Z)',7X,'Y1',9X,'Y2',9X,'DIRECT',5X,   &
!                    &'AMEAN',6X,'FUP',8X,'FDN',7X,'N')
!             DO n = 1 , NZ
!                i = NZP1 - n
!       !ACK - check LUN
!                WRITE (21,99008) i , S(i) , y1(n) , y2(n) , direct(n) ,  &
!                               & amean(n) , fup(n) , fdn(n) , n
! 99008          FORMAT (1X,I3,1P7E11.3,1X,I3)
!             ENDDO
!       !ACK - check LUN
!             WRITE (21,99009) direct(NZP1) , amean(NZP1) , fup(NZP1) ,   &
!                            & fdn(NZP1)
! 99009       FORMAT ('#',36X,1P4E11.3)
!          ENDIF
!       ENDIF

      END
!-PK ***************************************


      subroutine sx_combine(iflg)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  This subroutine combines the dimensions of a variable, used in
CD1  generating the finite element coefficients. It also breaks
CD1  connections when Boundary Conditions connect nodes.
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/sx_combine.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:44:16   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:20:54   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:15:56   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:28:02   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:12:26   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:47:20 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.3   Mon Mar 31 08:43:36 1997   gaz
CD2 minor changes
CD2
CD2    Rev 1.2   Fri Apr 26 16:33:44 1996   gaz
CD2 major changes including directional componets
CD2
CD2    Rev 1.1   Thu Jan 11 11:53:20 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.0   11/16/95 09:37:50   llt
CD2 Initial revision.
CD2
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  3.1     Finite Element Coefficient Generation
CD3
C***********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
C***********************************************************************

      use davidi
      use comii
      use comfi
      use comgi
      use comei
      use comdi
      use comci
      use combi
      use comdti
      use comai
      implicit none

      real*8, allocatable :: sxtot(:)
c
      real*8  xi,yi,zi,xkb,ykb,zkb,dis2
      real*8  area_dis
      integer iflg,i,i1,i2
      integer jj,kb,neqp1,icon
      integer icode
c
c  return if stress solution enabled
c
      if(istrs.ne.0) return
c
      neqp1=neq+1
      if(iflg.eq.-3) then
c     isotropic minimun storage case
         if(icnl.eq.0) then
            do i=1,nr
               sx(i,1)=sx(i,1)/3.0d00
            enddo
         else
            do i=1,nr
               sx(i,1)=sx(i,1)/2.0d00
            enddo
         endif
      elseif(iflg.eq.-2) then
c     isotropic minimun storage case
c     first combine(from fehm,subroutine anonp)
         allocate(sxtot(nr))
         if(icnl.eq.0) then
            do i=1,nr
               sxtot(i)=(sx(i,1)+sx(i,2)+sx(i,3))/3.0
            enddo
         else
            do i=1,nr
               sxtot(i)=(sx(i,1)+sx(i,2)+sx(i,3))/2.0
            enddo
         endif
         deallocate(sx)
         allocate(sx(nr,1))
         do i=1,nr
            sx(i,1)=sxtot(i)
         enddo
         deallocate(sxtot)
      elseif(iflg.eq.-1) then
c     first combine(from fehm,subroutine anonp)
         do i=1,nr
            sx(i,1)=sx(i,1)+sx(i,2)+sx(i,3)
            sx(i,2)=0.0
            sx(i,3)=0.0
         enddo
c     divide into directional componets
         do i=1,neq
            xi=cord(i,1)
            yi=cord(i,2)
            zi=cord(i,3)
            i1=nelmdg(i)+1
            i2=nelm(i+1)
            do jj=i1,i2
               kb=nelm(jj)
               iw=istrw(jj-neqp1)
               xkb=cord(kb,1)
               ykb=cord(kb,2)
               zkb=cord(kb,3)
               dis2=(xkb-xi)**2+(ykb-yi)**2+(zkb-zi)**2
               if(dis2.gt.0.0) then
                  area_dis=sx(iw,1)
                  sx(iw,1)=area_dis*(xkb-xi)**2/dis2
                  sx(iw,2)=area_dis*(ykb-yi)**2/dis2
                  sx(iw,3)=area_dis*(zkb-zi)**2/dis2
               endif
            enddo
         enddo

      elseif(iflg.eq.0) then
c
c     first combine(from storsx read file)
c
         allocate(sxtot(nr))
c     call mmgetblk ("sxtot","sx_combine",ipsxtot,nr,
c     &        2, icode)
c
         do i=1,nr
c            sxtot(i)=-sqrt(sx(i,1)**2+sx(i,2)**2+sx(i,3)**2)
            sxtot(i) = sx(i,1)+sx(i,2)+sx(i,3)
            sx(i,1)=0.0
            sx(i,2)=0.0
            sx(i,3)=0.0
         enddo
c     divide into directional components
         do i=1,neq
            xi=cord(i,1)
            yi=cord(i,2)
            zi=cord(i,3)
            i1=nelm(i)+1
            i2=nelm(i+1)
            do jj=i1,i2
               kb=nelm(jj)
               iw=istrw(jj-neqp1)
               xkb=cord(kb,1)
               ykb=cord(kb,2)
               if(icnl.eq.0) then
                zkb=cord(kb,3)
                dis2=(xkb-xi)**2+(ykb-yi)**2+(zkb-zi)**2
                if(dis2.gt.0.0) then
                  area_dis=sxtot(iw)
                  sx(iw,1)=area_dis*(xkb-xi)**2/dis2
                  sx(iw,2)=area_dis*(ykb-yi)**2/dis2
                  sx(iw,3)=area_dis*(zkb-zi)**2/dis2
                endif
               else
                dis2=(xkb-xi)**2+(ykb-yi)**2
                 if(dis2.gt.0.0) then
                  area_dis=sxtot(iw)
                  sx(iw,1)=area_dis*(xkb-xi)**2/dis2
                  sx(iw,2)=area_dis*(ykb-yi)**2/dis2
                endif
               endif
            enddo
         enddo
c
c     call mmrelblk ("sxtot","sx_combine",ipsxtot, icode)
         deallocate(sxtot)
c
      else if(iflg.eq.1.and.ianpe.eq.0) then
c
c     break connections for specified pressure nodes to other specified
c     pressure nodes
c
c     check for previously defined mdnodes
c     don't do this for anisotropy
c
c     break connections if neccessary
c     ka(i) lt 0 is pressure BC,ieos(i) lt 0  is large rservoir
c     gaz 4-10-01 (only for ka(i)=-1)
c
c     gaz 10-19-2001 can't all break connections with solid phase yet
C  zvd 09-09-2005 use istrw_itfc instead of istrw to store broken connections
         red_factor(nitfcpairs+1)=0.d0

         if(ice.eq.0) then
            icon=0
            do i=1,neq
               if(ka(i).lt.0.or.ieos(i).lt.0) then
                  i1=nelmdg(i)+1
                  i2=nelm(i+1)
                  do jj=i1,i2
                     kb=nelm(jj)
                     if(ka(kb).lt.0) then
                        istrw_itfc(jj-neqp1)=nitfcpairs+1
                        icon=1
                     endif
                  enddo
               endif
            enddo
            do i=1,neq
               if(ka(i).lt.0.or.ieos(i).lt.0) then
                  i1=nelmdg(i)+1
                  i2=nelm(i+1)
                  do jj=i1,i2
                     kb=nelm(jj)
                     if(ka(kb).ne.0.and.ka(kb).ne.-3) then
                        istrw_itfc(jj-neqp1)=nitfcpairs+1
                        icon=1
                     endif
                  enddo
               endif
            enddo
         else
            icon=0
            do i=1,neq
               if(ka(i).lt.0) then
                  i1=nelmdg(i)+1
                  i2=nelm(i+1)
                  do jj=i1,i2
                     kb=nelm(jj)
                     if(ka(kb).eq.-1) then
                        istrw_itfc(jj-neqp1) = nitfcpairs+1
                        icon=1
                     endif
                  enddo
               endif
            enddo
            do i=1,neq
               if(ka(i).eq.-1) then
                  i1=nelmdg(i)+1
                  i2=nelm(i+1)
                  do jj=i1,i2
                     kb=nelm(jj)
                     if(ka(kb).ne.0.and.ka(kb).ne.-3) then
                        istrw_itfc(jj-neqp1) = nitfcpairs+1
                        icon=1
                     endif
                  enddo
               endif
            enddo
         endif
c
c     write out warning that connections have been broken
c
         if(icon.eq.1) then
            if (iout .ne. 0)
     &           write(iout,*) 'BC to BC connection(s) found ',
     &           '(now set=0.0)'
            if(iptty.ne.0)
     &           write(iptty,*) 'BC to BC connection(s) found ',
     &           '(now set=0.0)'
         endif
c
      else if(iflg.eq.2) then
c
c     set last connection = 0.0
c
         sx(nr,1)=0.0
         sx(nr,2)=0.0
         sx(nr,3)=0.0
      else if(iflg.eq.3) then
c
c     set last connection = 0.0
c
         sx(nr,1)=0.0
      endif
      return
      end


Subroutine ptoh
  Parameter (maxstr=150001)
  Double Precision gxp, gyp, gzp, ftp, pxp, pyp, pzp, pep, pmp
  Double Precision gxp0, gyp0, gzp0, ft0fom, drlocl
  Double Precision enenew, pxnew, pynew, pznew, beta2, gam
  Double Precision ftavg0, gxavg0, gyavg0, gzavg0, bex, bey, bez
  Double Precision pxsgs, pysgs, pzsgs, pesgs, pmsgs, gxsgs, gysgs, gzsgs, ftsgs
  Double Precision xmdiag, px1, py1, pz1, e1, px2, py2, pz2, e2, px3, py3, pz3, e3, xmpair, etot
  Double Precision p1, p2, p3
  Common /loclco/gxp(3), gyp(3), gzp(3), ftp(3), pxp(3), pyp(3), pzp(3), pep(3), pmp(3)
  Common /hmain1/eatt, jatt, natt, nt, np, n0, n01, n10, n11
  Common /hmain2/katt(maxstr, 4), patt(maxstr, 4)
  Common /hjjet2/nsg, njsg(maxstr), iasg(maxstr, 3), k1sg(maxstr, 100), k2sg(maxstr, 100), pxsg(maxstr, 100), pysg(maxstr, 100), pzsg(maxstr, 100), pesg(maxstr, 100), pmsg(maxstr, 100)
  Common /arprnt/arpar1(100), iapar2(50), arint1(100), iaint2(50)
  Common /arprc/itypar(maxstr), gxar(maxstr), gyar(maxstr), gzar(maxstr), ftar(maxstr), pxar(maxstr), pyar(maxstr), pzar(maxstr), pear(maxstr), xmar(maxstr)
  Common /soft/pxsgs(maxstr, 3), pysgs(maxstr, 3), pzsgs(maxstr, 3), pesgs(maxstr, 3), pmsgs(maxstr, 3), gxsgs(maxstr, 3), gysgs(maxstr, 3), gzsgs(maxstr, 3), ftsgs(maxstr, 3), k1sgs(maxstr, 3), k2sgs(maxstr, 3), njsgs(maxstr)
  Common /rndf77/nseed
  Common /anim/nevent, isoft, isflag, izpc
  Common /prtn23/gxp0(3), gyp0(3), gzp0(3), ft0fom
  Common /nzpc/nattzp
  Common /lor/enenew, pxnew, pynew, pznew
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Common /lastt/itimeh, bimp
  Common /hjglbr/nelt, ninthj, nelp, ninp
  Common /arevt/iaevt, iarun, miss
  Common /para7/ioscar, nsmbbbar, nsmmeson
  Common /input1/masspr, massta, iseed, iavoid, dt
  Dimension xmdiag(maxstr), indx(maxstr), ndiag(maxstr)
  Save
  Call coales
  mstj24 = mstj(24)
  mstj(24) = 0
  nuudd = 0
  npich = 0
  nrhoch = 0
  ppi0 = 1.
  prho0 = 0.
  Do isg = 1, nsg
     If (njsgs(isg)/=0) Then
        natt = natt + 1
        k1 = k2sgs(isg, 1)
        k1abs = iabs(k1)
        px1 = pxsgs(isg, 1)
        py1 = pysgs(isg, 1)
        pz1 = pzsgs(isg, 1)
        k2 = k2sgs(isg, 2)
        k2abs = iabs(k2)
        px2 = pxsgs(isg, 2)
        py2 = pysgs(isg, 2)
        pz2 = pzsgs(isg, 2)
        e1 = pesgs(isg, 1)
        e2 = pesgs(isg, 2)
        xmpair = dsqrt((e1+e2)**2-(px1+px2)**2-(py1+py2)**2-(pz1+pz2)**2)
        ibs = 2
        imspin = 0
        If (k1==-k2 .And. iabs(k1)<=2 .And. njsgs(isg)==2) Then
           nuudd = nuudd + 1
           xmdiag(nuudd) = xmpair
           ndiag(nuudd) = natt
        End If
        k3 = 0
        If ((isoft==4 .Or. isoft==5) .And. njsgs(isg)==3) Then
           k3 = k2sgs(isg, 3)
           k3abs = iabs(k3)
           px3 = pxsgs(isg, 3)
           py3 = pysgs(isg, 3)
           pz3 = pzsgs(isg, 3)
           e3 = pesgs(isg, 3)
           xmpair = dsqrt((e1+e2+e3)**2-(px1+px2+px3)**2-(py1+py2+py3)**2-(pz1+pz2+pz3)**2)
        End If
        If (isoft==3 .And. (k1abs>1000 .Or. k2abs>1000)) Then
           If (k1abs>1000) Then
              kdq = k1abs
              kk = k2abs
           Else
              kdq = k2abs
              kk = k1abs
           End If
           ki = mod(kdq/1000, 10)
           kj = mod(kdq/100, 10)
           If (mod(kdq,10)==1) Then
              idqspn = 0
           Else
              idqspn = 1
           End If
           If (kk>ki) Then
              ktemp = kk
              kk = kj
              kj = ki
              ki = ktemp
           Else If (kk>kj) Then
              ktemp = kk
              kk = kj
              kj = ktemp
           End If
           If (ki/=kj .And. ki/=kk .And. kj/=kk) Then
              If (idqspn==0) Then
                 kf = 1000*ki + 100*kk + 10*kj + ibs
              Else
                 kf = 1000*ki + 100*kj + 10*kk + ibs
              End If
           Else If (ki==kj .And. ki==kk) Then
              kf = 1000*ki + 100*kj + 10*kk + 4
           Else
              kf = 1000*ki + 100*kj + 10*kk + ibs
           End If
           If (kf==2112 .Or. kf==2212) Then
              If (abs(sngl(xmpair)-ulmass(kf))>abs(sngl(xmpair)-ulmass(kf+2))) kf = kf + 2
           End If
           If (k1<0) kf = -kf
        Else If ((isoft==4 .Or. isoft==5) .And. njsgs(isg)==3) Then
           If (k1abs>k2abs) Then
              ki = k1abs
              kk = k2abs
           Else
              ki = k2abs
              kk = k1abs
           End If
           If (k3abs>ki) Then
              kj = ki
              ki = k3abs
           Else If (k3abs<kk) Then
              kj = kk
              kk = k3abs
           Else
              kj = k3abs
           End If
           If (ki==kj .And. ki==kk) Then
              ibs = 4
              kf = 1000*ki + 100*kj + 10*kk + ibs
           Else If (ki/=kj .And. ki/=kk .And. kj/=kk) Then
              ibs = 2
              kf1 = 1000*ki + 100*kj + 10*kk + ibs
              kf2 = 1000*ki + 100*kk + 10*kj + ibs
              kf = kf1
              If (abs(sngl(xmpair)-ulmass(kf1))>abs(sngl(xmpair)-ulmass(kf2))) kf = kf2
           Else
              ibs = 2
              kf = 1000*ki + 100*kj + 10*kk + ibs
              If (kf==2112 .Or. kf==2212) Then
                 If (abs(sngl(xmpair)-ulmass(kf))>abs(sngl(xmpair)-ulmass(kf+2))) kf = kf + 2
              End If
           End If
           If (k1<0) kf = -kf
        Else
           If (k1abs==k2abs) Then
              If (k1abs<=2) Then
                 kf = 0
              Else If (k1abs<=3) Then
                 kf = 333
              Else
                 kf = 100*k1abs + 10*k1abs + 2*imspin + 1
              End If
           Else
              If (k1abs>k2abs) Then
                 kmax = k1abs
                 kmin = k2abs
              Else If (k1abs<k2abs) Then
                 kmax = k2abs
                 kmin = k1abs
              End If
              kf = (100*kmax+10*kmin+2*imspin+1)*isign(1, k1+k2)*(-1)**kmax
              If (mod(iabs(kf),10)==1) Then
                 If (abs(sngl(xmpair)-ulmass(iabs(kf)))>abs(sngl(xmpair)-ulmass(iabs(kf)+2))) kf = (iabs(kf)+2)*isign(1, kf)
              End If
           End If
        End If
        itypar(natt) = kf
        katt(natt, 1) = kf
        If (iabs(kf)==211) Then
           npich = npich + 1
        Else If (iabs(kf)==213) Then
           nrhoch = nrhoch + 1
        End If
     End If
  End Do
  If (nuudd/=0) Then
     ppi0 = float(npich/2)/float(nuudd)
     prho0 = float(nrhoch/2)/float(nuudd)
  End If
  npi0 = 0
  Do isg = 1, nsg
     If (k2sgs(isg,1)==-k2sgs(isg,2) .And. iabs(k2sgs(isg,1))<=2 .And. njsgs(isg)==2) Then
        If (ranart(nseed)<=ppi0) npi0 = npi0 + 1
     End If
  End Do
  If (nuudd>1) Then
     Call index1(maxstr, nuudd, xmdiag, indx)
  Else
     indx(1) = 1
  End If
  Do ix = 1, nuudd
     iuudd = indx(ix)
     inatt = ndiag(iuudd)
     If (ix<=npi0) Then
        kf = 111
     Else If (ranart(nseed)<=(prho0/(1-ppi0+0.00001))) Then
        kf = 113
     Else
        If (ranart(nseed)<=0.5) Then
           kf = 221
        Else
           kf = 223
        End If
     End If
     itypar(inatt) = kf
     katt(inatt, 1) = kf
  End Do
  inatt = 0
  If (ioscar==3) Then
     Write (85, 395) iaevt, 3*nsmbbbar + 2*nsmmeson, nsmbbbar, nsmmeson, bimp, nelp, ninp, nelt, ninthj, miss
  End If
  Do isg = 1, nsg
     If (njsgs(isg)/=0) Then
        inatt = inatt + 1
        k1 = k2sgs(isg, 1)
        k1abs = iabs(k1)
        px1 = pxsgs(isg, 1)
        py1 = pysgs(isg, 1)
        pz1 = pzsgs(isg, 1)
        k2 = k2sgs(isg, 2)
        k2abs = iabs(k2)
        px2 = pxsgs(isg, 2)
        py2 = pysgs(isg, 2)
        pz2 = pzsgs(isg, 2)
        e1 = pesgs(isg, 1)
        e2 = pesgs(isg, 2)
        If (njsgs(isg)==2) Then
           pxar(inatt) = sngl(px1+px2)
           pyar(inatt) = sngl(py1+py2)
           pzar(inatt) = sngl(pz1+pz2)
           patt(inatt, 1) = pxar(inatt)
           patt(inatt, 2) = pyar(inatt)
           patt(inatt, 3) = pzar(inatt)
           etot = e1 + e2
           p1 = px1 + px2
           p2 = py1 + py2
           p3 = pz1 + pz2
        Else If ((isoft==4 .Or. isoft==5) .And. njsgs(isg)==3) Then
           px3 = pxsgs(isg, 3)
           py3 = pysgs(isg, 3)
           pz3 = pzsgs(isg, 3)
           e3 = pesgs(isg, 3)
           pxar(inatt) = sngl(px1+px2+px3)
           pyar(inatt) = sngl(py1+py2+py3)
           pzar(inatt) = sngl(pz1+pz2+pz3)
           patt(inatt, 1) = pxar(inatt)
           patt(inatt, 2) = pyar(inatt)
           patt(inatt, 3) = pzar(inatt)
           etot = e1 + e2 + e3
           p1 = px1 + px2 + px3
           p2 = py1 + py2 + py3
           p3 = pz1 + pz2 + pz3
        End If
        xmar(inatt) = ulmass(itypar(inatt))
        kf = katt(inatt, 1)
        If (kf==113 .Or. abs(kf)==213 .Or. kf==221 .Or. kf==223 .Or. abs(kf)==313 .Or. abs(kf)==323 .Or. kf==333 .Or. abs(kf)==1114 .Or. abs(kf)==2114 .Or. abs(kf)==2214 .Or. abs(kf)==2224) Then
           xmar(inatt) = resmass(kf)
        End If
        pear(inatt) = sqrt(pxar(inatt)**2+pyar(inatt)**2+pzar(inatt)**2+xmar(inatt)**2)
        patt(inatt, 4) = pear(inatt)
        eatt = eatt + pear(inatt)
        ipartn = njsgs(isg)
        Do i = 1, ipartn
           ftp(i) = ftsgs(isg, i)
           gxp(i) = gxsgs(isg, i)
           gyp(i) = gysgs(isg, i)
           gzp(i) = gzsgs(isg, i)
           pxp(i) = pxsgs(isg, i)
           pyp(i) = pysgs(isg, i)
           pzp(i) = pzsgs(isg, i)
           pmp(i) = pmsgs(isg, i)
           pep(i) = pesgs(isg, i)
        End Do
        Call locldr(ipartn, drlocl)
        tau0 = arpar1(1)
        ftavg0 = ft0fom + dble(tau0)
        gxavg0 = 0D0
        gyavg0 = 0D0
        gzavg0 = 0D0
        Do i = 1, ipartn
           gxavg0 = gxavg0 + gxp0(i)/ipartn
           gyavg0 = gyavg0 + gyp0(i)/ipartn
           gzavg0 = gzavg0 + gzp0(i)/ipartn
        End Do
        bex = p1/etot
        bey = p2/etot
        bez = p3/etot
        beta2 = bex**2 + bey**2 + bez**2
        gam = 1.D0/dsqrt(1.D0-beta2)
        If (beta2>=0.9999999999999D0) Then
           Write (6, *) '2', bex, bey, bez, beta2, gam
        End If
        Call lorenz(ftavg0, gxavg0, gyavg0, gzavg0, -bex, -bey, -bez)
        gxar(inatt) = sngl(pxnew)
        gyar(inatt) = sngl(pynew)
        gzar(inatt) = sngl(pznew)
        ftar(inatt) = sngl(enenew)
        If (ioscar==3) Then
           Write (85, 313) k2sgs(isg, 1), px1, py1, pz1, pmsgs(isg, 1), inatt, katt(inatt, 1), xmar(inatt)
           Write (85, 312) k2sgs(isg, 2), px2, py2, pz2, pmsgs(isg, 2), inatt, katt(inatt, 1)
           If (njsgs(isg)==3) Write (85, 312) k2sgs(isg, 3), px3, py3, pz3, pmsgs(isg, 3), inatt, katt(inatt, 1)
        End If
     End If
  End Do
  nattzp = natt
  mstj(24) = mstj24
  Return
395 Format (4I8, F10.4, 5I5)
312 Format (I6, 4(1X,F10.3), 1X, I6, 1X, I6)
313 Format (I6, 4(1X,F10.3), 1X, I6, 1X, I6, 1X, F10.3)
End Subroutine ptoh


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> This module provides linear equation solver interface for PARADISO
module hecmw_solver_direct_ClusterMKL
  use hecmw_util
  use m_hecmw_ClusterMKL_wrapper

  private
  public :: hecmw_solve_direct_ClusterMKL

contains

  subroutine hecmw_solve_direct_ClusterMKL(hecMESH,hecMAT)
    implicit none
    type (hecmwST_local_mesh), intent(in) :: hecMESH
    type (hecmwST_matrix    ), intent(inout) :: hecMAT

    call hecmw_clustermkl_wrapper(hecMESH, hecMAT)

  end subroutine hecmw_solve_direct_ClusterMKL

end module hecmw_solver_direct_ClusterMKL


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          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.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testXDMFMesh
#include "UnitTest.h"
USE ISO_FORTRAN_ENV
USE UnitTest
USE IntrType
USE Strings
USE XDMFMesh
IMPLICIT NONE

REAL(SDK) :: two_pins_pin1_vertices(3,109) = RESHAPE( (/ &
    0.0000000000000000_SDK,   0.0000000000000000_SDK,   0.0000000000000000_SDK,&
    2.0000000000000000_SDK,   0.0000000000000000_SDK,   0.0000000000000000_SDK,&
    0.0000000000000000_SDK,   2.0000000000000000_SDK,   0.0000000000000000_SDK,&
    2.0000000000000000_SDK,   2.0000000000000000_SDK,   0.0000000000000000_SDK,&
    1.5000000000000000_SDK,   1.0000000000000000_SDK,   0.0000000000000000_SDK,&
   0.50000000000000000_SDK,   0.0000000000000000_SDK,   0.0000000000000000_SDK,&
    1.0000000000000000_SDK,   0.0000000000000000_SDK,   0.0000000000000000_SDK,&
    1.5000000000000000_SDK,   0.0000000000000000_SDK,   0.0000000000000000_SDK,&
   0.25000000000000000_SDK,   0.0000000000000000_SDK,   0.0000000000000000_SDK,&
   0.75000000000000000_SDK,   0.0000000000000000_SDK,   0.0000000000000000_SDK,&
    1.2500000000000000_SDK,   0.0000000000000000_SDK,   0.0000000000000000_SDK,&
    1.7500000000000000_SDK,   0.0000000000000000_SDK,   0.0000000000000000_SDK,&
    0.0000000000000000_SDK,   1.5000000000000000_SDK,   0.0000000000000000_SDK,&
    0.0000000000000000_SDK,   1.0000000000000000_SDK,   0.0000000000000000_SDK,&
    0.0000000000000000_SDK,  0.50000000000000000_SDK,   0.0000000000000000_SDK,&
    0.0000000000000000_SDK,   1.7500000000000000_SDK,   0.0000000000000000_SDK,&
    0.0000000000000000_SDK,   1.2500000000000000_SDK,   0.0000000000000000_SDK,&
    0.0000000000000000_SDK,  0.75000000000000000_SDK,   0.0000000000000000_SDK,&
    0.0000000000000000_SDK,  0.25000000000000000_SDK,   0.0000000000000000_SDK,&
    2.0000000000000000_SDK,  0.50000000000000000_SDK,   0.0000000000000000_SDK,&
    2.0000000000000000_SDK,   1.0000000000000000_SDK,   0.0000000000000000_SDK,&
    2.0000000000000000_SDK,   1.5000000000000000_SDK,   0.0000000000000000_SDK,&
    2.0000000000000000_SDK,  0.25000000000000000_SDK,   0.0000000000000000_SDK,&
    2.0000000000000000_SDK,  0.75000000000000000_SDK,   0.0000000000000000_SDK,&
    2.0000000000000000_SDK,   1.2500000000000000_SDK,   0.0000000000000000_SDK,&
    2.0000000000000000_SDK,   1.7500000000000000_SDK,   0.0000000000000000_SDK,&
    1.5000000000000000_SDK,   2.0000000000000000_SDK,   0.0000000000000000_SDK,&
    1.0000000000000000_SDK,   2.0000000000000000_SDK,   0.0000000000000000_SDK,&
   0.50000000000000000_SDK,   2.0000000000000000_SDK,   0.0000000000000000_SDK,&
    1.7500000000000000_SDK,   2.0000000000000000_SDK,   0.0000000000000000_SDK,&
    1.2500000000000000_SDK,   2.0000000000000000_SDK,   0.0000000000000000_SDK,&
   0.75000000000000000_SDK,   2.0000000000000000_SDK,   0.0000000000000000_SDK,&
   0.25000000000000000_SDK,   2.0000000000000000_SDK,   0.0000000000000000_SDK,&
    1.3117449009294000_SDK,   1.3909157412340001_SDK,   0.0000000000000000_SDK,&
   0.88873953302183994_SDK,   1.4874639560909000_SDK,   0.0000000000000000_SDK,&
   0.54951556604879004_SDK,   1.2169418695587999_SDK,   0.0000000000000000_SDK,&
   0.54951556604879004_SDK,  0.78305813044121997_SDK,   0.0000000000000000_SDK,&
   0.88873953302183994_SDK,  0.51253604390909002_SDK,   0.0000000000000000_SDK,&
    1.3117449009294000_SDK,  0.60908425876599004_SDK,   0.0000000000000000_SDK,&
    1.4504844339512000_SDK,   1.2169418695587999_SDK,   0.0000000000000000_SDK,&
    1.1112604669782000_SDK,   1.4874639560909000_SDK,   0.0000000000000000_SDK,&
   0.68825509907062998_SDK,   1.3909157412340001_SDK,   0.0000000000000000_SDK,&
   0.50000000000000000_SDK,   1.0000000000000000_SDK,   0.0000000000000000_SDK,&
   0.68825509907062998_SDK,  0.60908425876599004_SDK,   0.0000000000000000_SDK,&
    1.1112604669782000_SDK,  0.51253604390909002_SDK,   0.0000000000000000_SDK,&
    1.4504844339512000_SDK,  0.78305813044121997_SDK,   0.0000000000000000_SDK,&
    1.0000000000000000_SDK,   1.0000000000000000_SDK,   0.0000000000000000_SDK,&
    1.1558724504647000_SDK,   1.1954578706170000_SDK,   0.0000000000000000_SDK,&
    1.2500000000000000_SDK,   1.0000000000000000_SDK,   0.0000000000000000_SDK,&
   0.94436976651091997_SDK,   1.2437319780455001_SDK,   0.0000000000000000_SDK,&
    1.1558724504647000_SDK,  0.80454212938298997_SDK,   0.0000000000000000_SDK,&
   0.77475778302440002_SDK,   1.1084709347794000_SDK,   0.0000000000000000_SDK,&
   0.77475778302440002_SDK,  0.89152906522061004_SDK,   0.0000000000000000_SDK,&
   0.94436976651091997_SDK,  0.75626802195454002_SDK,   0.0000000000000000_SDK,&
   0.39945256244833000_SDK,   1.6005474375516999_SDK,   0.0000000000000000_SDK,&
   0.39945256244833000_SDK,  0.39945256244833000_SDK,   0.0000000000000000_SDK,&
    1.6749575669735000_SDK,  0.67495756697348996_SDK,   0.0000000000000000_SDK,&
    1.6749575669735000_SDK,   1.3250424330265000_SDK,   0.0000000000000000_SDK,&
    1.6076357762794000_SDK,   1.6521790377186001_SDK,   0.0000000000000000_SDK,&
    1.6076357762794000_SDK,  0.34782096228136000_SDK,   0.0000000000000000_SDK,&
    1.2323349413967000_SDK,   1.7035415484495000_SDK,   0.0000000000000000_SDK,&
    1.2323349413967000_SDK,  0.29645845155054001_SDK,   0.0000000000000000_SDK,&
   0.27475778302440002_SDK,  0.89152906522061004_SDK,   0.0000000000000000_SDK,&
   0.27475778302440002_SDK,   1.1084709347794000_SDK,   0.0000000000000000_SDK,&
   0.27475778302440002_SDK,  0.64152906522061004_SDK,   0.0000000000000000_SDK,&
   0.27475778302440002_SDK,   1.3584709347794000_SDK,   0.0000000000000000_SDK,&
   0.94436976651091997_SDK,  0.25626802195454002_SDK,   0.0000000000000000_SDK,&
   0.69436976651091997_SDK,  0.25626802195454002_SDK,   0.0000000000000000_SDK,&
   0.69436976651091997_SDK,   1.7437319780455001_SDK,   0.0000000000000000_SDK,&
   0.94436976651091997_SDK,   1.7437319780455001_SDK,   0.0000000000000000_SDK,&
   0.44972628122415997_SDK,   1.8002737187758000_SDK,   0.0000000000000000_SDK,&
   0.64409604773508999_SDK,   1.5440056968213001_SDK,   0.0000000000000000_SDK,&
   0.64409604773508999_SDK,  0.45599430317870998_SDK,   0.0000000000000000_SDK,&
   0.44972628122415997_SDK,  0.19972628122416000_SDK,   0.0000000000000000_SDK,&
   0.47448406424855999_SDK,   1.4087446535552000_SDK,   0.0000000000000000_SDK,&
   0.19972628122416000_SDK,   1.5502737187758000_SDK,   0.0000000000000000_SDK,&
   0.19972628122416000_SDK,  0.44972628122415997_SDK,   0.0000000000000000_SDK,&
   0.47448406424855999_SDK,  0.59125534644476996_SDK,   0.0000000000000000_SDK,&
    1.8038178881397000_SDK,  0.42391048114067997_SDK,   0.0000000000000000_SDK,&
    1.8038178881397000_SDK,  0.17391048114068000_SDK,   0.0000000000000000_SDK,&
    1.8038178881397000_SDK,   1.8260895188593000_SDK,   0.0000000000000000_SDK,&
    1.8038178881397000_SDK,   1.5760895188593000_SDK,   0.0000000000000000_SDK,&
   0.19972628122416000_SDK,  0.19972628122416000_SDK,   0.0000000000000000_SDK,&
   0.19972628122416000_SDK,   1.8002737187758000_SDK,   0.0000000000000000_SDK,&
    1.5538178881397000_SDK,  0.17391048114068000_SDK,   0.0000000000000000_SDK,&
    1.5538178881397000_SDK,   1.8260895188593000_SDK,   0.0000000000000000_SDK,&
    1.1161674706983999_SDK,  0.14822922577527001_SDK,   0.0000000000000000_SDK,&
    1.0605372372093000_SDK,  0.40449724772981999_SDK,   0.0000000000000000_SDK,&
    1.0605372372093000_SDK,   1.5955027522702001_SDK,   0.0000000000000000_SDK,&
    1.1161674706983999_SDK,   1.8517707742247000_SDK,   0.0000000000000000_SDK,&
    1.5874787834866999_SDK,  0.83747878348673999_SDK,   0.0000000000000000_SDK,&
    1.8374787834866999_SDK,  0.83747878348673999_SDK,   0.0000000000000000_SDK,&
    1.7500000000000000_SDK,   1.0000000000000000_SDK,   0.0000000000000000_SDK,&
    1.8374787834866999_SDK,   1.1625212165133001_SDK,   0.0000000000000000_SDK,&
    1.5874787834866999_SDK,   1.1625212165133001_SDK,   0.0000000000000000_SDK,&
    1.8374787834866999_SDK,   1.4125212165133001_SDK,   0.0000000000000000_SDK,&
    1.8374787834866999_SDK,  0.58747878348673999_SDK,   0.0000000000000000_SDK,&
    1.3661674706983999_SDK,  0.14822922577527001_SDK,   0.0000000000000000_SDK,&
    1.3661674706983999_SDK,   1.8517707742247000_SDK,   0.0000000000000000_SDK,&
    1.4933512339513999_SDK,  0.64202091286973995_SDK,   0.0000000000000000_SDK,&
    1.4933512339513999_SDK,   1.3579790871302999_SDK,   0.0000000000000000_SDK,&
    1.6412966716263999_SDK,  0.51138926462741996_SDK,   0.0000000000000000_SDK,&
    1.6412966716263999_SDK,   1.4886107353725999_SDK,   0.0000000000000000_SDK,&
    1.2720399211630999_SDK,  0.45277135515826000_SDK,   0.0000000000000000_SDK,&
    1.2720399211630999_SDK,   1.5472286448417001_SDK,   0.0000000000000000_SDK,&
    1.4199853588381000_SDK,   1.6778602930840001_SDK,   0.0000000000000000_SDK,&
    1.4199853588381000_SDK,  0.32213970691595001_SDK,   0.0000000000000000_SDK,&
    1.4596903386044000_SDK,   1.5215473894763001_SDK,   0.0000000000000000_SDK,&
    1.4596903386044000_SDK,  0.47845261052367000_SDK,   0.0000000000000000_SDK &
/), (/3, 109/))

INTEGER(SLK) :: two_pins_pin1_cells(7,46) = RESHAPE( (/ &
36,  33,  46,   4,  47,  48,  39,&
36,  34,  46,  33,  49,  47,  40,&
36,   4,  46,  38,  48,  50,  45,&
36,  35,  46,  34,  51,  49,  41,&
36,  36,  46,  35,  52,  51,  42,&
36,  38,  46,  37,  50,  53,  44,&
36,  37,  46,  36,  53,  52,  43,&
36,  13,  36,  35,  62,  42,  63,&
36,  14,  36,  13,  64,  62,  17,&
36,  12,  13,  35,  16,  63,  65,&
36,   5,   6,  37,   9,  66,  67,&
36,  28,  34,  27,  68,  69,  31,&
36,  28,  54,  34,  70,  71,  68,&
36,  37,  55,   5,  72,  73,  67,&
36,  35,  54,  12,  74,  75,  65,&
36,  14,  55,  36,  76,  77,  64,&
36,  19,  59,   1,  78,  79,  22,&
36,   3,  58,  21,  80,  81,  25,&
36,   5,  55,   0,  73,  82,   8,&
36,   0,  55,  14,  82,  76,  18,&
36,  12,  54,   2,  75,  83,  15,&
36,   2,  54,  28,  83,  70,  32,&
36,  34,  54,  35,  71,  74,  41,&
36,  36,  55,  37,  77,  72,  43,&
36,   1,  59,   7,  79,  84,  11,&
36,  26,  58,   3,  85,  80,  29,&
36,   6,  61,  37,  86,  87,  66,&
36,  34,  60,  27,  88,  89,  69,&
36,   4,  56,  20,  90,  91,  92,&
36,  20,  57,   4,  93,  94,  92,&
36,  21,  57,  20,  95,  93,  24,&
36,  20,  56,  19,  91,  96,  23,&
36,   7,  61,   6,  97,  86,  10,&
36,  27,  60,  26,  89,  98,  30,&
36,  38,  56,   4,  99,  90,  45,&
36,   4,  57,  33,  94, 100,  39,&
36,  56,  59,  19, 101,  78,  96,&
36,  21,  58,  57,  81, 102,  95,&
36,  37,  61,  38,  87, 103,  44,&
36,  33,  60,  34, 104,  88,  40,&
36,  26,  60,  58,  98, 105,  85,&
36,  59,  61,   7, 106,  97,  84,&
36,  58,  60,  33, 105, 104, 107,&
36,  38,  61,  59, 103, 106, 108,&
36,  38,  59,  56, 108, 101,  99,&
36,  57,  58,  33, 102, 107, 100 &
/), (/7, 46/))

INTEGER(SNK) :: two_pins_pin1_material_ids(46) = (/ &
0, 0, 0, 0, 0, 0, 0,          &
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 1, 1, 1, 1     &
/)

REAL(SDK) :: three_level_grid_L3_vertices(3,5) = RESHAPE( (/ &
 2.0, 1.5, 0.0,&
 2.0, 1.0, 0.0,&
 3.0, 1.0, 0.0,&
 2.0, 2.0, 0.0,&
 3.0, 2.0, 0.0 &
/), (/3, 5/))

INTEGER(SLK) :: three_level_grid_L3_cells(3,3) = RESHAPE( (/ &
0, 2, 4, &
1, 2, 0, &
3, 0, 4  &
/), (/3, 3/))

CREATE_TEST('XDMF TYPE')
REGISTER_SUBTEST('CLEAR', testClear)
REGISTER_SUBTEST('ASSIGNMENT', testAssign)
REGISTER_SUBTEST('DISTANCE TO LEAF', testDistanceToLeaf)
REGISTER_SUBTEST('RECOMPUTE BOUNDING BOX', testRecomputeBoundingBox)
REGISTER_SUBTEST('IMPORT XDMF MESH', testImportXDMFMesh)
REGISTER_SUBTEST('EXPORT XDMF MESH', testExportXDMFMesh)
FINALIZE_TEST()
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE setup_pin1(mesh)
  TYPE(XDMFMeshType), INTENT(INOUT), TARGET :: mesh
  TYPE(XDMFMeshType), POINTER :: children(:)
  INTEGER(SNK) :: i
  ! Setup a mesh equivalent to gridmesh_two_pins.xdmf, only containing pin1
  mesh%name = "mesh_domain"
  mesh%boundingBox = (/0.0_SDK, 2.0_SDK, 0.0_SDK, 2.0_SDK/)
  ALLOCATE(mesh%children(1))
  children => mesh%children
  ! pin 1
  children(1)%name = "GRID_L1_1_1"
  children(1)%singleTopology = .TRUE.
  children(1)%parent => mesh
  children(1)%boundingBox = (/0.0_SDK, 2.0_SDK, 0.0_SDK, 2.0_SDK/)
  children(1)%vertices = two_pins_pin1_vertices
  ALLOCATE(children(1)%cells(46))
  DO i = 1,46
    ALLOCATE(children(1)%cells(i)%vertex_list(7))
    children(1)%cells(i)%vertex_list(1) = two_pins_pin1_cells(1,i)
    children(1)%cells(i)%vertex_list(2:) = two_pins_pin1_cells(2:,i) + 1
  ENDDO
  children(1)%material_ids = two_pins_pin1_material_ids + 1
  ALLOCATE(children(1)%cell_sets(1))
  ALLOCATE(children(1)%cell_sets(1)%cell_list(46))
  children(1)%cell_sets(1)%name = "Pin_1"
  DO i = 1,46
    children(1)%cell_sets(1)%cell_list(i) = i
  ENDDO
  NULLIFY(children)
ENDSUBROUTINE setup_pin1
!
!-------------------------------------------------------------------------------
SUBROUTINE testClear()
  TYPE(XDMFMeshType) :: mesh
  TYPE(XDMFMeshType),POINTER :: pin1
  INTEGER(SNK) :: i

  CALL setup_pin1(mesh)
  pin1 => mesh%children(1)

  CALL mesh%clear()
  ASSERT(pin1%name == "", "pin1 mesh name is incorrect")
  ASSERT(pin1%singleTopology == .FALSE., "single topology did not reset")
  ASSERT(.NOT.ALLOCATED(pin1%vertices), "Vertices are associated")
  ASSERT(.NOT.ALLOCATED(pin1%cells), "Cells are associated")
  ASSERT(.NOT.ALLOCATED(pin1%material_ids), "materials are associated")
  ASSERT(.NOT.ALLOCATED(pin1%cell_sets), "Cell sets are associated")
  ASSERT(.NOT.ASSOCIATED(pin1%children), "Children are associated")
  ASSERT(.NOT.ASSOCIATED(pin1%parent), "Parent is associated")
  DO i = 1,4
    ASSERT(pin1%boundingBox(i) == 0.0_SDK, "BB not reset")
  ENDDO
  ASSERT(mesh%name == "", "mesh mesh name is incorrect")
  ASSERT(mesh%singleTopology == .FALSE., "single topology did not reset")
  ASSERT(.NOT.ALLOCATED(mesh%vertices), "Vertices are associated")
  ASSERT(.NOT.ALLOCATED(mesh%cells), "Cells are associated")
  ASSERT(.NOT.ALLOCATED(mesh%material_ids), "materials are associated")
  ASSERT(.NOT.ALLOCATED(mesh%cell_sets), "Cell sets are associated")
  ASSERT(.NOT.ASSOCIATED(mesh%children), "Children are associated")
  ASSERT(.NOT.ASSOCIATED(mesh%parent), "Parent is associated")
  DO i = 1,4
    ASSERT(mesh%boundingBox(i) == 0.0_SDK, "BB not reset")
  ENDDO

  NULLIFY(pin1)
ENDSUBROUTINE testClear
!
!-------------------------------------------------------------------------------
SUBROUTINE testAssign()
  TYPE(XDMFMeshType) :: mesh1, mesh2
  TYPE(XDMFMeshType),POINTER :: pin1
  INTEGER(SNK) :: i,j

  CALL setup_pin1(mesh1)
  mesh2 = mesh1
  pin1 => mesh2%children(1)
  ASSERT(mesh2%name == "mesh_domain", "Root mesh name is incorrect")
  ASSERT(ASSOCIATED(mesh2%children), "Children not associated")
  ASSERT(SIZE(mesh2%children)==1, "Wrong number of children")
  ASSERT(mesh2%singleTopology == .FALSE., "mesh2 is single topology")
  ASSERT( (ABS(mesh2%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(mesh2%boundingBox(2) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(mesh2%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(mesh2%boundingBox(4) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")

  ! Check pin1
  ASSERT(pin1%name == "GRID_L1_1_1", "pin1 mesh name is incorrect")
  ASSERT(.NOT.ASSOCIATED(pin1%children), "Children are associated")
  ASSERT(ASSOCIATED(pin1%parent), "Parent not associated")
  ASSERT( (ABS(pin1%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(pin1%boundingBox(2) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(pin1%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(pin1%boundingBox(4) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")
  ASSERT(pin1%parent%name == "mesh_domain", "pin1 parent name is incorrect")
  ASSERT(pin1%singleTopology == .TRUE., "pin1 is not single topology")
  !     pin1 vertices
  ASSERT(ALLOCATED(pin1%vertices), "Vertices not allocated")
  ASSERT(SIZE(pin1%vertices)==109*3, "Wrong number of vertices")
  ASSERT(SIZE(pin1%vertices, DIM=2)==109, "Wrong shape of vertices")
  DO i=1,109
    DO j=1,3
      ASSERT( (ABS(pin1%vertices(j, i) - two_pins_pin1_vertices(j,i)) < 1.0E-9), "Unequal vertices")
    ENDDO
  ENDDO
  !     pin1 cells
  ASSERT(ALLOCATED(pin1%cells), "Cells not allocated")
  ASSERT(SIZE(pin1%cells)==46, "Wrong number of cells")
  DO i=1,46
    ASSERT(SIZE(pin1%cells(i)%vertex_list)==7, "Wrong size for vertex list")
    ASSERT( pin1%cells(i)%vertex_list(1) == two_pins_pin1_cells(1, i), "Wrong cell type")
    DO j=2,7
      ASSERT( pin1%cells(i)%vertex_list(j) == two_pins_pin1_cells(j, i) + 1, "Wrong vertex id")
    ENDDO
  ENDDO
  !     pin1 material_ids
  ASSERT(ALLOCATED(pin1%material_ids), "material_ids not allocated")
  ASSERT(SIZE(pin1%material_ids)==46, "Wrong number of cells")
  DO i=1,46
    ASSERT( pin1%material_ids(i) == two_pins_pin1_material_ids(i) + 1, "Unequal material_id")
  ENDDO
  !     pin1 cell_sets
  ASSERT(ALLOCATED(pin1%cell_sets), "cell_sets not allocated")
  ASSERT(SIZE(pin1%cell_sets)==1, "Wrong number of cell sets")
  ASSERT(SIZE(pin1%cell_sets(1)%cell_list)==46, "Wrong number of cells")
  ASSERT(pin1%cell_sets(1)%name=="Pin_1", "Wrong cell_set name")
  DO i=1,46
    ASSERT( pin1%cell_sets(1)%cell_list(i) == i, "Wrong cells")
  ENDDO

  NULLIFY(pin1)
  CALL mesh1%clear()
  CALL mesh2%clear()
ENDSUBROUTINE testAssign
!
!-------------------------------------------------------------------------------
SUBROUTINE testDistanceToLeaf()
  TYPE(XDMFMeshType) :: mesh
  TYPE(XDMFMeshType),POINTER :: pin1
  INTEGER(SIK) :: i

  CALL setup_pin1(mesh)
  pin1 => mesh%children(1)

  i = mesh%distanceToLeaf()
  ASSERT(i == 1, "Distance to leaf is incorrect")
  i = pin1%distanceToLeaf()
  ASSERT(i == 0, "Distance to leaf is incorrect")

  ! Give the leaf a child, making distance to leaf greater by 1
  ALLOCATE(pin1%children(1))
  i = mesh%distanceToLeaf()
  ASSERT(i == 2, "Distance to leaf is incorrect")
  i = pin1%distanceToLeaf()
  ASSERT(i == 1, "Distance to leaf is incorrect")

  CALL mesh%clear()
  NULLIFY(pin1)
ENDSUBROUTINE testDistanceToLeaf
!
!-------------------------------------------------------------------------------
SUBROUTINE testRecomputeBoundingBox()
  TYPE(XDMFMeshType) :: mesh
  TYPE(XDMFMeshType),POINTER :: pin1

  CALL setup_pin1(mesh)
  pin1 => mesh%children(1)

  ! Check original bounding box
  ASSERT( (ABS(mesh%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(mesh%boundingBox(2) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(mesh%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(mesh%boundingBox(4) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")
  ASSERT( (ABS(pin1%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(pin1%boundingBox(2) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(pin1%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(pin1%boundingBox(4) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")

  ! Check that nothing changes when recomputing
  CALL mesh%recomputeBoundingBox()
  ASSERT( (ABS(mesh%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(mesh%boundingBox(2) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(mesh%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(mesh%boundingBox(4) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")
  ASSERT( (ABS(pin1%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(pin1%boundingBox(2) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(pin1%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(pin1%boundingBox(4) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")

  ! Move a vertex so that it changes the BB.
  ! The old BB was (0,0,2,2). We are moving the corner vertex at (2,2)
  ! to (2.1, 2.2)
  pin1%vertices(1,4) = 2.1_SDK
  pin1%vertices(2,4) = 2.2_SDK
  CALL mesh%recomputeBoundingBox()
  ASSERT( (ABS(mesh%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(mesh%boundingBox(2) - 2.1_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(mesh%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(mesh%boundingBox(4) - 2.2_SDK) < 1.0E-9_SDK), "Incorrect y_max")
  ASSERT( (ABS(pin1%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(pin1%boundingBox(2) - 2.1_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(pin1%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(pin1%boundingBox(4) - 2.2_SDK) < 1.0E-9_SDK), "Incorrect y_max")

  CALL mesh%clear()
  NULLIFY(pin1)
ENDSUBROUTINE testRecomputeBoundingBox
!
!-------------------------------------------------------------------------------
SUBROUTINE testImportXDMFMesh()
  ! Test the various major branches in import logic:
  ! - Levels:       1 vs 2 or more
  ! - Topology:     Mixed vs Single
  ! - Materials:    Yes vs No
  ! - Cell sets:    Yes vs No
  ! -----------------------------------------------------------------------------
  ! | Component   | Variation            | Tested by                           |
  ! ----------------------------------------------------------------------------
  ! | Levels      | 1                    | three_level_grid_IH                 |
  ! | Levels      | 2 or more            | two_pins, three_level_grid          |
  ! | Topology    | Mixed                | three_level_grid_IH                 |
  ! | Topology    | Single               | two_pins, three_level_grid          |
  ! | Materials   | Yes                  | two_pins                            |
  ! | Materials   | No                   | both three_level_grids              |
  ! | Cell sets   | Yes                  | two_pins, three_level_grid_IH       |
  ! | Cell sets   | No                   | three_level_grid                    |
  ! ----------------------------------------------------------------------------
  !
  ! Test case with two pins
  ! - Levels:       2
  ! - Topology:     Single, Triangle_6
  ! - Materials:    Yes
  ! - Cell sets:    Yes
  COMPONENT_TEST('test two pins')
  CALL test_import_two_pins()
  !
  ! Test case with three level grid, explicit hierarchy
  ! Note: the GRID has 3 levels, therefore the mesh has 4 levels
  ! - Levels:       4
  ! - Topology:     Single, Triangle or Quad in each leaf
  ! - Materials:    No
  ! - Cell sets:    No
  COMPONENT_TEST('test three level grid')
  CALL test_import_three_level_grid()
  !
  ! Test case with three level grid but the mesh hierarchy is implied
  ! through cell sets instead of explicitly through XDMF XML
  ! - Levels:       1
  ! - Topology:     Mixed, Triangle and Quad
  ! - Materials:    No
  ! - Cell sets:    Yes
  COMPONENT_TEST('test three level grid w/ implicit hierarchy')
  CALL test_import_three_level_grid_implicit_hierarchy()
ENDSUBROUTINE testImportXDMFMesh
!
!-------------------------------------------------------------------------------
SUBROUTINE test_import_two_pins()
  TYPE(XDMFMeshType) :: mesh, pin1
  TYPE(StringType) :: fname
  INTEGER(SIK) :: i,j

  fname='gridmesh_two_pins.xdmf'
  CALL importXDMFMesh(fname, mesh)
  ! Check correct number of children
  ASSERT(mesh%name == "mesh_domain", "Root mesh name is incorrect")
  ASSERT(ASSOCIATED(mesh%children), "Children not associated")
  ASSERT(SIZE(mesh%children)==2, "Wrong number of children")
  ASSERT( (ABS(mesh%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(mesh%boundingBox(2) - 4.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(mesh%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(mesh%boundingBox(4) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")
  ! Check pin1
  pin1 = mesh%children(1)
  ASSERT(pin1%name == "GRID_L1_1_1", "pin1 mesh name is incorrect")
  ASSERT(.NOT.ASSOCIATED(pin1%children), "Children are associated")
  ASSERT(ASSOCIATED(pin1%parent), "Parent not associated")
  ASSERT(pin1%parent%name == "mesh_domain", "pin1 parent name is incorrect")
  ASSERT(pin1%singleTopology == .TRUE., "pin1 is not single topology")
  ASSERT( (ABS(pin1%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(pin1%boundingBox(2) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(pin1%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(pin1%boundingBox(4) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")
  !     pin1 vertices
  ASSERT(ALLOCATED(pin1%vertices), "Vertices not allocated")
  ASSERT(SIZE(pin1%vertices)==109*3, "Wrong number of vertices")
  ASSERT(SIZE(pin1%vertices, DIM=2)==109, "Wrong shape of vertices")
  DO i=1,109
    DO j=1,3
      ASSERT( (ABS(pin1%vertices(j, i) - two_pins_pin1_vertices(j,i)) < 1.0E-9), "Unequal vertices")
    ENDDO
  ENDDO
  !     pin1 cells
  ASSERT(ALLOCATED(pin1%cells), "Cells not allocated")
  ASSERT(SIZE(pin1%cells)==46, "Wrong number of cells")
  DO i=1,46
    ASSERT(SIZE(pin1%cells(i)%vertex_list)==7, "Wrong size for vertex list")
    ASSERT( pin1%cells(i)%vertex_list(1) == two_pins_pin1_cells(1, i), "Wrong cell type")
    DO j=2,7
      ASSERT( pin1%cells(i)%vertex_list(j) == two_pins_pin1_cells(j, i) + 1, "Wrong vertex id")
    ENDDO
  ENDDO
  !     pin1 material_ids
  ASSERT(ALLOCATED(pin1%material_ids), "material_ids not allocated")
  ASSERT(SIZE(pin1%material_ids)==46, "Wrong number of cells")
  DO i=1,46
    ASSERT( pin1%material_ids(i) == two_pins_pin1_material_ids(i) + 1, "Unequal material_id")
  ENDDO
  !     pin1 cell_sets
  ASSERT(ALLOCATED(pin1%cell_sets), "cell_sets not allocated")
  ASSERT(SIZE(pin1%cell_sets)==1, "Wrong number of cell sets")
  ASSERT(SIZE(pin1%cell_sets(1)%cell_list)==46, "Wrong number of cells")
  ASSERT(pin1%cell_sets(1)%name=="Pin_1", "Wrong cell_set name")
  DO i=1,46
    ASSERT( pin1%cell_sets(1)%cell_list(i) == i, "Wrong cells")
  ENDDO

  CALL mesh%clear()
  CALL pin1%clear()
ENDSUBROUTINE test_import_two_pins
!
!-------------------------------------------------------------------------------
SUBROUTINE test_import_three_level_grid()
  TYPE(XDMFMeshType) :: mesh, L1, L2, L3
  TYPE(StringType) :: fname
  INTEGER(SIK) :: i,j

  fname='gridmesh_three_level_grid.xdmf'
  CALL importXDMFMesh(fname, mesh)

  ASSERT(mesh%name == "three_lvl_grid", "Root mesh name is incorrect")
  ASSERT(ASSOCIATED(mesh%children), "Children not associated")
  ASSERT(SIZE(mesh%children)==1, "Wrong number of children")
  i = mesh%distanceToLeaf()
  ASSERT(i == 3, "Wrong number of levels")
  ASSERT( (ABS(mesh%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(mesh%boundingBox(2) - 4.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(mesh%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(mesh%boundingBox(4) - 4.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")
  ! Check L1
  L1 = mesh%children(1)
  ASSERT(L1%name == "GRID_L1_1_1", "L1 mesh name is incorrect")
  ASSERT(ASSOCIATED(L1%children), "Children are not associated")
  ASSERT(ASSOCIATED(L1%parent), "Parent not associated")
  ASSERT(L1%parent%name == "three_lvl_grid", "L1 parent name is incorrect")
  ASSERT(SIZE(L1%children) == 4, "Wrong number of children")
  i = L1%distanceToLeaf()
  ASSERT(i == 2, "Wrong number of levels")
  ASSERT( (ABS(L1%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(L1%boundingBox(2) - 4.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(L1%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(L1%boundingBox(4) - 4.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")
  ! Check L2_2_1
  L2 = L1%children(2)
  ASSERT(L2%name == "GRID_L2_2_1", "L2 mesh name is incorrect")
  ASSERT(ASSOCIATED(L2%children), "Children are not associated")
  ASSERT(ASSOCIATED(L2%parent), "Parent not associated")
  ASSERT(L2%parent%name == "GRID_L1_1_1", "L2 parent name is incorrect")
  ASSERT(SIZE(L2%children) == 4, "Wrong number of children")
  ASSERT( (ABS(L2%boundingBox(1) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(L2%boundingBox(2) - 4.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(L2%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(L2%boundingBox(4) - 2.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")
  ! Check L3_3_2
  L3 = L2%children(3)
  ASSERT(L3%name == "GRID_L3_3_2", "L3 mesh name is incorrect")
  ASSERT(.NOT. ASSOCIATED(L3%children), "Children are associated")
  ASSERT(ASSOCIATED(L3%parent), "Parent not associated")
  ASSERT(L3%parent%name == "GRID_L2_2_1", "L3 parent name is incorrect")
  !     L3_3_2 vertices
  ASSERT(ALLOCATED(L3%vertices), "Vertices not allocated")
  ASSERT(SIZE(L3%vertices)==5*3, "Wrong number of vertices")
  ASSERT(SIZE(L3%vertices, DIM=2)==5, "Wrong shape of vertices")
  DO i=1,5
    DO j=1,3
      ASSERT( (ABS(L3%vertices(j, i) - three_level_grid_L3_vertices(j,i)) < 1.0E-9), "Unequal vertices")
    ENDDO
  ENDDO
  !     L3_3_2 cells
  ASSERT(ALLOCATED(L3%cells), "Cells not allocated")
  ASSERT(SIZE(L3%cells)==3, "Wrong number of cells")
  ASSERT(L3%singleTopology == .TRUE., "L3 is not single topology")
  DO i=1,3
    ASSERT(SIZE(L3%cells(i)%vertex_list)==4, "Wrong size for vertex list")
    ASSERT( L3%cells(i)%vertex_list(1) == 4, "Wrong cell type, should be triangle=4")
    DO j=2,4
      ASSERT( L3%cells(i)%vertex_list(j) == three_level_grid_L3_cells(j-1, i) + 1, "Wrong vertex id")
    ENDDO
  ENDDO
  ASSERT(.NOT. ALLOCATED(L3%material_ids), "Material IDS are allocated")
  ASSERT(.NOT. ALLOCATED(L3%cell_sets), "Cell sets are allocated")

  CALL mesh%clear()
  CALL L1%clear()
  CALL L2%clear()
  CALL L3%clear()
ENDSUBROUTINE test_import_three_level_grid
!
!-------------------------------------------------------------------------------
SUBROUTINE test_import_three_level_grid_implicit_hierarchy()
  TYPE(XDMFMeshType) :: mesh
  TYPE(StringType) :: fname
  INTEGER(SIK) :: i,j
  INTEGER(SLK),ALLOCATABLE :: cells_ref(:)

  fname='three_level_grid.xdmf'
  CALL importXDMFMesh(fname, mesh)
  ! Check correct number of children
  ASSERT(mesh%name == "three_lvl_grid", "Root mesh name is incorrect")
  ASSERT(.NOT.ASSOCIATED(mesh%children), "Children are associated")
  ASSERT( (ABS(mesh%boundingBox(1) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect x_min")
  ASSERT( (ABS(mesh%boundingBox(2) - 4.0_SDK) < 1.0E-9_SDK), "Incorrect x_max")
  ASSERT( (ABS(mesh%boundingBox(3) - 0.0_SDK) < 1.0E-9_SDK), "Incorrect y_min")
  ASSERT( (ABS(mesh%boundingBox(4) - 4.0_SDK) < 1.0E-9_SDK), "Incorrect y_max")
  ! vertices
  ASSERT(ALLOCATED(mesh%vertices), "Vertices not allocated")
  ASSERT(SIZE(mesh%vertices)==42*3, "Wrong number of vertices")
  ASSERT(SIZE(mesh%vertices, DIM=2)==42, "Wrong shape of vertices")
  ! cells
  ASSERT(ALLOCATED(mesh%cells), "Cells not allocated")
  ASSERT(SIZE(mesh%cells)==46, "Wrong number of cells")
  ASSERT(mesh%singleTopology == .FALSE., "Mesh is single topology")
  ! Spot check cells
  ! Cell 1, quad
  j=1
  ALLOCATE(cells_ref(5))
  cells_ref = (/5, 26, 2, 27, 38/)
  ASSERT(SIZE(mesh%cells(j)%vertex_list)==5, "Wrong size for vertex list")
  DO i=1,5
    ASSERT( mesh%cells(j)%vertex_list(i) == cells_ref(i), "Wrong vertex id or mesh id")
  ENDDO
  ! Cell 4, quad
  j=4
  cells_ref = (/5, 4, 29, 38, 28/)
  ASSERT(SIZE(mesh%cells(j)%vertex_list)==5, "Wrong size for vertex list")
  DO i=1,5
    ASSERT( mesh%cells(j)%vertex_list(i) == cells_ref(i), "Wrong vertex id or mesh id")
  ENDDO
  DEALLOCATE(cells_ref)
  ! Cell 18, tri
  j=18
  ALLOCATE(cells_ref(4))
  cells_ref = (/4, 6, 40, 8/)
  ASSERT(SIZE(mesh%cells(j)%vertex_list)==4, "Wrong size for vertex list")
  DO i=1,4
    ASSERT( mesh%cells(j)%vertex_list(i) == cells_ref(i), "Wrong vertex id or mesh id")
  ENDDO
  DEALLOCATE(cells_ref)
  ASSERT(.NOT. ALLOCATED(mesh%material_ids), "Material IDS are allocated")
  ! Check cell sets
  ASSERT(ALLOCATED(mesh%cell_sets), "Cell sets are allocated")
  ASSERT(SIZE(mesh%cell_sets)==21, "Wrong number of cell sets")
  ASSERT(mesh%cell_sets(6)%name=="GRID_L3_1_1", "Wrong set name")
  ASSERT(SIZE(mesh%cell_sets(6)%cell_list)==4, "Wrong set size")
  DO i =1,4
    ASSERT(mesh%cell_sets(6)%cell_list(i) == i, "Wrong cell id")
  ENDDO

  CALL mesh%clear()
ENDSUBROUTINE test_import_three_level_grid_implicit_hierarchy
!
!-------------------------------------------------------------------------------
SUBROUTINE testExportXDMFMesh()
  !
  ! ****************************************************************************
  ! NOTE:
  !   Since tests run sequentially within the file, to reach this subroutine
  !   without error, import has to be working as intended. If errors occur
  !   within testImportXDMFMesh, those should be addressed first.
  !   Export is verified by importing the exported mesh. This is not
  !   ideal unit test design, but manually setting up all of the meshes of
  !   interest to test the export subroutine would take over a thousand lines
  !   easily.
  ! ****************************************************************************
  !
  ! Test the various major branches in export logic:
  ! - Levels:       1 vs 2 or more
  ! - Topology:     Mixed vs Single
  ! - Materials:    Yes vs No
  ! - Cell sets:    Yes vs No
  ! -----------------------------------------------------------------------------
  ! | Component   | Variation            | Tested by                           |
  ! ----------------------------------------------------------------------------
  ! | Levels      | 1                    | three_level_grid_IH                 |
  ! | Levels      | 2 or more            | two_pins, three_level_grid          |
  ! | Topology    | Mixed                | three_level_grid_IH                 |
  ! | Topology    | Single               | two_pins, three_level_grid          |
  ! | Materials   | Yes                  | two_pins                            |
  ! | Materials   | No                   | both three_level_grids              |
  ! | Cell sets   | Yes                  | two_pins, three_level_grid_IH       |
  ! | Cell sets   | No                   | three_level_grid                    |
  ! ----------------------------------------------------------------------------
  !
  ! Test case with two pins
  ! - Levels:       2
  ! - Topology:     Single, Triangle_6
  ! - Materials:    Yes
  ! - Cell sets:    Yes
  COMPONENT_TEST('test two pins')
  CALL test_export_two_pins()
  !
  ! Test case with three level grid, explicit hierarchy
  ! Note: the GRID has 3 levels, therefore the mesh has 4 levels
  ! - Levels:       4
  ! - Topology:     Single, Triangle or Quad in each leaf
  ! - Materials:    No
  ! - Cell sets:    No
  COMPONENT_TEST('test three level grid')
  CALL test_export_three_level_grid()
  !
  ! Test case with three level grid but the mesh hierarchy is implied
  ! through cell sets instead of explicitly through XDMF XML
  ! - Levels:       1
  ! - Topology:     Mixed, Triangle and Quad
  ! - Materials:    No
  ! - Cell sets:    Yes
  COMPONENT_TEST('test three level grid w/ implicit hierarchy')
  CALL test_export_three_level_grid_implicit_hierarchy()
ENDSUBROUTINE testExportXDMFMesh
!
!-------------------------------------------------------------------------------
SUBROUTINE test_export_two_pins()
  TYPE(XDMFMeshType) :: mesh, pin1, emesh
  TYPE(StringType) :: fname
  INTEGER(SIK) :: i,j

  fname='gridmesh_two_pins.xdmf'
  CALL importXDMFMesh(fname, mesh)

  ! Export
  fname='write_two_pins.xdmf'
  CALL exportXDMFMesh(fname, mesh)
  CALL importXDMFMesh(fname, emesh)
  ASSERT(emesh%name == "mesh_domain", "Root mesh name is incorrect")
  ASSERT(ASSOCIATED(emesh%children), "Children not associated")
  ASSERT(SIZE(emesh%children)==2, "Wrong number of children")
  ! Check pin1
  pin1 = emesh%children(1)
  ASSERT(pin1%name == "GRID_L1_1_1", "pin1 mesh name is incorrect")
  ASSERT(.NOT.ASSOCIATED(pin1%children), "Children are associated")
  ASSERT(ASSOCIATED(pin1%parent), "Parent not associated")
  ASSERT(pin1%parent%name == "mesh_domain", "pin1 parent name is incorrect")
  ASSERT(pin1%singleTopology == .TRUE., "pin1 is not single topology")
  !     pin1 vertices
  ASSERT(ALLOCATED(pin1%vertices), "Vertices not allocated")
  ASSERT(SIZE(pin1%vertices)==109*3, "Wrong number of vertices")
  ASSERT(SIZE(pin1%vertices, DIM=2)==109, "Wrong shape of vertices")
  DO i=1,109
    DO j=1,3
      ASSERT( (ABS(pin1%vertices(j, i) - two_pins_pin1_vertices(j,i)) < 1.0E-9), "Unequal vertices")
    ENDDO
  ENDDO
  !     pin1 cells
  ASSERT(ALLOCATED(pin1%cells), "Cells not allocated")
  ASSERT(SIZE(pin1%cells)==46, "Wrong number of cells")
  DO i=1,46
    ASSERT(SIZE(pin1%cells(i)%vertex_list)==7, "Wrong size for vertex list")
    ASSERT( pin1%cells(i)%vertex_list(1) == two_pins_pin1_cells(1, i), "Wrong cell type")
    DO j=2,7
      ASSERT( pin1%cells(i)%vertex_list(j) == two_pins_pin1_cells(j, i) + 1, "Wrong vertex id")
    ENDDO
  ENDDO
  !     pin1 material_ids
  ASSERT(ALLOCATED(pin1%material_ids), "material_ids not allocated")
  ASSERT(SIZE(pin1%material_ids)==46, "Wrong number of cells")
  DO i=1,46
    ASSERT( pin1%material_ids(i) == two_pins_pin1_material_ids(i) + 1, "Unequal material_id")
  ENDDO
  !     pin1 cell_sets
  ASSERT(ALLOCATED(pin1%cell_sets), "cell_sets not allocated")
  ASSERT(SIZE(pin1%cell_sets)==1, "Wrong number of cell sets")
  ASSERT(SIZE(pin1%cell_sets(1)%cell_list)==46, "Wrong number of cells")
  ASSERT(pin1%cell_sets(1)%name=="Pin_1", "Wrong cell_set name")
  DO i=1,46
    ASSERT( pin1%cell_sets(1)%cell_list(i) == i, "Wrong cells")
  ENDDO

  CALL mesh%clear()
  CALL pin1%clear()
  CALL emesh%clear()
ENDSUBROUTINE test_export_two_pins
!
!-------------------------------------------------------------------------------
SUBROUTINE test_export_three_level_grid()
  TYPE(XDMFMeshType) :: mesh, L1, L2, L3, emesh
  TYPE(StringType) :: fname
  INTEGER(SIK) :: i,j

  fname='gridmesh_three_level_grid.xdmf'
  CALL importXDMFMesh(fname, mesh)

  ! Export
  fname='write_three_level_grid.xdmf'
  CALL exportXDMFMesh(fname, mesh)
  CALL importXDMFMesh(fname, emesh)
  ! Check correct number of children
  ASSERT(emesh%name == "three_lvl_grid", "Root mesh name is incorrect")
  ASSERT(ASSOCIATED(emesh%children), "Children not associated")
  ASSERT(SIZE(emesh%children)==1, "Wrong number of children")
  ! Check L1
  L1 = emesh%children(1)
  ASSERT(L1%name == "GRID_L1_1_1", "L1 mesh name is incorrect")
  ASSERT(ASSOCIATED(L1%children), "Children are not associated")
  ASSERT(ASSOCIATED(L1%parent), "Parent not associated")
  ASSERT(L1%parent%name == "three_lvl_grid", "L1 parent name is incorrect")
  ASSERT(SIZE(L1%children) == 4, "Wrong number of children")
  ! Check L2_2_1
  L2 = L1%children(2)
  ASSERT(L2%name == "GRID_L2_2_1", "L2 mesh name is incorrect")
  ASSERT(ASSOCIATED(L2%children), "Children are not associated")
  ASSERT(ASSOCIATED(L2%parent), "Parent not associated")
  ASSERT(L2%parent%name == "GRID_L1_1_1", "L2 parent name is incorrect")
  ASSERT(SIZE(L2%children) == 4, "Wrong number of children")
  ! Check L3_3_2
  L3 = L2%children(3)
  ASSERT(L3%name == "GRID_L3_3_2", "L3 mesh name is incorrect")
  ASSERT(.NOT. ASSOCIATED(L3%children), "Children are associated")
  ASSERT(ASSOCIATED(L3%parent), "Parent not associated")
  ASSERT(L3%parent%name == "GRID_L2_2_1", "L3 parent name is incorrect")
  !     L3_3_2 vertices
  ASSERT(ALLOCATED(L3%vertices), "Vertices not allocated")
  ASSERT(SIZE(L3%vertices)==5*3, "Wrong number of vertices")
  ASSERT(SIZE(L3%vertices, DIM=2)==5, "Wrong shape of vertices")
  DO i=1,5
    DO j=1,3
      ASSERT( (ABS(L3%vertices(j, i) - three_level_grid_L3_vertices(j,i)) < 1.0E-9), "Unequal vertices")
    ENDDO
  ENDDO
  !     L3_3_2 cells
  ASSERT(ALLOCATED(L3%cells), "Cells not allocated")
  ASSERT(SIZE(L3%cells)==3, "Wrong number of cells")
  ASSERT(L3%singleTopology == .TRUE., "L3 is not single topology")
  DO i=1,3
    ASSERT(SIZE(L3%cells(i)%vertex_list)==4, "Wrong size for vertex list")
    ASSERT( L3%cells(i)%vertex_list(1) == 4, "Wrong cell type, should be triangle=4")
    DO j=2,4
      ASSERT( L3%cells(i)%vertex_list(j) == three_level_grid_L3_cells(j-1, i) + 1, "Wrong vertex id")
    ENDDO
  ENDDO
  ASSERT(.NOT. ALLOCATED(L3%material_ids), "Material IDS are allocated")
  ASSERT(.NOT. ALLOCATED(L3%cell_sets), "Cell sets are allocated")

  CALL mesh%clear()
  CALL L1%clear()
  CALL L2%clear()
  CALL L3%clear()
  CALL emesh%clear()
ENDSUBROUTINE test_export_three_level_grid
!
!-------------------------------------------------------------------------------
SUBROUTINE test_export_three_level_grid_implicit_hierarchy()
  TYPE(XDMFMeshType) :: mesh,emesh
  TYPE(StringType) :: fname
  INTEGER(SIK) :: i,j
  INTEGER(SLK),ALLOCATABLE :: cells_ref(:)

  fname='three_level_grid.xdmf'
  CALL importXDMFMesh(fname, mesh)

  ! Export
  fname='write_three_level_grid_IH.xdmf'
  CALL exportXDMFMesh(fname, mesh)
  CALL importXDMFMesh(fname, emesh)
  ! Check correct number of children
  ASSERT(emesh%name == "three_lvl_grid", "Root mesh name is incorrect")
  ASSERT(.NOT.ASSOCIATED(emesh%children), "Children are associated")
  ! vertices
  ASSERT(ALLOCATED(emesh%vertices), "Vertices not allocated")
  ASSERT(SIZE(emesh%vertices)==42*3, "Wrong number of vertices")
  ASSERT(SIZE(emesh%vertices, DIM=2)==42, "Wrong shape of vertices")
  ! cells
  ASSERT(ALLOCATED(emesh%cells), "Cells not allocated")
  ASSERT(SIZE(emesh%cells)==46, "Wrong number of cells")
  ASSERT(emesh%singleTopology == .FALSE., "Mesh is single topology")
  ! Spot check cells
  ! Cell 1, quad
  j=1
  ALLOCATE(cells_ref(5))
  cells_ref = (/5, 26, 2, 27, 38/)
  ASSERT(SIZE(emesh%cells(j)%vertex_list)==5, "Wrong size for vertex list")
  DO i=1,5
    ASSERT( emesh%cells(j)%vertex_list(i) == cells_ref(i), "Wrong vertex id or mesh id")
  ENDDO
  ! Cell 4, quad
  j=4
  cells_ref = (/5, 4, 29, 38, 28/)
  ASSERT(SIZE(emesh%cells(j)%vertex_list)==5, "Wrong size for vertex list")
  DO i=1,5
    ASSERT( emesh%cells(j)%vertex_list(i) == cells_ref(i), "Wrong vertex id or mesh id")
  ENDDO
  DEALLOCATE(cells_ref)
  ! Cell 18, tri
  j=18
  ALLOCATE(cells_ref(4))
  cells_ref = (/4, 6, 40, 8/)
  ASSERT(SIZE(emesh%cells(j)%vertex_list)==4, "Wrong size for vertex list")
  DO i=1,4
    ASSERT( emesh%cells(j)%vertex_list(i) == cells_ref(i), "Wrong vertex id or mesh id")
  ENDDO
  DEALLOCATE(cells_ref)
  ASSERT(.NOT. ALLOCATED(emesh%material_ids), "Material IDS are allocated")
  ! Check cell sets
  ASSERT(ALLOCATED(emesh%cell_sets), "Cell sets are allocated")
  ASSERT(SIZE(emesh%cell_sets)==21, "Wrong number of cell sets")
  ASSERT(emesh%cell_sets(6)%name=="GRID_L3_1_1", "Wrong set name")
  ASSERT(SIZE(emesh%cell_sets(6)%cell_list)==4, "Wrong set size")
  DO i =1,4
    ASSERT(emesh%cell_sets(6)%cell_list(i) == i, "Wrong cell id")
  ENDDO

  CALL mesh%clear()
  CALL emesh%clear()
ENDSUBROUTINE test_export_three_level_grid_implicit_hierarchy
ENDPROGRAM testXDMFMesh


      subroutine varinit

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine initializes variables for the daily simulation of the
!!    land phase of the hydrologic cycle (the subbasin command loop)

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    deepst(:)   |mm H2O        |depth of water in deep aquifer
!!    ihru        |none          |HRU number
!!    nstep       |none          |number of lines of rainfall data for each
!!                               |day
!!    rainsub(:,:)|mm H2O        |precipitation for the time step during the
!!                               |day in HRU
!!    shallst(:)  |mm H2O        |depth of water in shallow aquifer
!!    sno_hru(:)  |mm H2O        |amount of water stored as snow
!!    sol_sw(:)   |mm H2O        |amount of water stored in soil profile on any
!!                               |given day
!!    subp(:)     |mm H2O        |precipitation for the day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    al5         |none          |fraction of total rainfall that occurs
!!                               |during 0.5h of highest intensity rain
!!    albday      |none          |albedo for the day in HRU
!!    auton       |kg N/ha       |amount of nitrogen applied in auto-fert
!!                               |application
!!    autop       |kg P/ha       |amount of phosphorus applied in auto-fert
!!                               |application
!!    bactlchlp   |# colonies/ha |less persistent bacteria removed from soil
!!                               |surface layer by percolation
!!    bactlchp    |# colonies/ha |persistent bacteria removed from soil surface
!!                               |layer by percolation
!!    bactrolp    |# colonies/ha |less persistent bacteria transported to main
!!                               |channel with surface runoff
!!    bactrop     |# colonies/ha |persistent bacteria transported to main
!!                               |channel with surface runoff
!!    bactsedlp   |# colonies/ha |less persistent bacteria transported with
!!                               |sediment in surface runoff
!!    bactsedp    |# colonies/ha |persistent bacteria transported with
!!                               |sediment in surface runoff
!!    bioday      |kg            |biomass generated on current day in HRU
!!    bsprev      |mm H2O        |surface runoff lagged from prior day of
!!                               |simulation
!!    bssprev     |mm H2O        |lateral flow lagged from prior day of
!!                               |simulation
!!    canev       |mm H2O        |amount of water evaporated from canopy storage
!!    cfertn      |kg N/ha       |amount of nitrogen added to soil in continuous
!!                               |fertilizer operation on day
!!    cfertp      |kg P/ha       |amount of phosphorus added to soil in continuous
!!                               |fertilizer operation on day
!!    crk         |mm H2O        |percolation due to crack flow
!!    deepstp     |mm H2O        |depth of water in deep aquifer in HRU
!!    enratio     |none          |enrichment ratio calculated for day in HRU
!!    ep_day      |mm H2O        |actual amount of transpiration that occurs on
!!                               |day in HRU
!!    ep_max      |mm H2O        |maximum amount of transpiration (plant et)
!!                               |that can occur on day in HRU
!!    es_day      |mm H2O        |actual amount of evaporation (from soil) that
!!                               |occurs on day in HRU
!!    etday       |mm H2O        |actual amount of evapotranspiration that
!!                               |occurs on day in HRU
!!    fertn       |kg N/ha       |total amount of nitrogen added to soil in HRU
!!                               |on day
!!    fertp       |kg P/ha       |total amount of phosphorus added to soil in
!!                               |HRU on day
!!    fixn        |kg N/ha       |amount of nitrogen added to plant biomass via
!!                               |fixation on the day in HRU
!!    grazn       |kg N/ha       |amount of nitrogen added to soil in grazing
!!                               |on the day in HRU
!!    grazp       |kg P/ha       |amount of phosphorus added to soil in grazing
!!                               |on the day in HRU
!!    gwseep      |mm H2O        |amount of water recharging deep aquifer on
!!                               |current day
!!    hhqday(:)   |mm H2O        |surface runoff from HRU for every hour in day
!!    hmntl       |kg N/ha       |amount of nitrogen moving from active
!!                               |organic to nitrate pool in soil profile
!!                               |on current day in HRU
!!    hmptl       |kg P/ha       |amount of phosphorus moving from the
!!                               |organic to labile pool in soil profile
!!                               |on current day in HRU
!!    inflpcp     |mm H2O        |amount of precipitation that infiltrates into
!!                               |soil (enters soil)
!!    lat_pst(:)  |kg pst/ha     |amount of pesticide in lateral flow in HRU for
!!                               |the day
!!    latlyr      |mm H2O        |amount of water in lateral flow in layer in
!!                               |HRU for the day
!!    no3pcp      |kg N/ha       |nitrate added to the soil in rainfall
!!    peakr       |m^3/s         |peak runoff rate for the day in HRU
!!    pet_day     |mm H2O        |potential evapotranspiration for day in HRU
!!    pndev       |m^3 H2O       |evaporation from pond on day
!!    pndflwi     |m^3 H2O       |volume of water flowing into pond on day
!!    pndflwo     |m^3 H2O       |volume of water flowing out of pond on day
!!    pndpcp      |m^3 H2O       |precipitation on pond during day
!!    pndsedc     |metric tons   |net change in sediment in pond during day
!!    pndsedin    |metric tons   |sediment inflow to the pond from HRU
!!    pndsedo     |metric tons   |sediment leaving pond during day
!!    pndsep      |m^3 H2O       |seepage from pond on day
!!    potevmm     |mm H2O        |volume of water evaporated from pothole
!!                               |expressed as depth over HRU
!!    potflwo     |mm H2O        |volume of water released to main channel from
!!                               |pothole exporessed as depth over HRU
!!    potpcpmm    |mm H2O        |precipitation falling on pothole water body
!!                               |expressed as depth over HRU
!!    potsedo     |t/ha          |sediment released to main channel from
!!                               |HRU
!!    potsepmm    |mm H2O        |seepage from pothole expressed as depth over
!!                               |HRU
!!    precipday   |mm H2O        |precipitation for the day in HRU
!!    precipdt(:) |mm H2O        |precipitation for the time step during day
!!    pstsol(:)   |kg pst/ha     |soluble pesticide leached from bottom of
!!                               |soil profile
!!    qday        |mm H2O        |surface runoff loading to main channel for
!!                               |day in HRU
!!    qdfr        |none          |fraction of water yield that is surface
!!                               |runoff
!!    qtile       |mm H2O        |drainage tile flow for day in HRU
!!    revapday    |mm H2O        |amount of water moving from the shallow
!!                               |aquifer into the soil profile or being taken
!!                               |up by plant roots in the shallow aquifer
!!    rmn2tl      |kg N/ha       |amount of nitrogen moving from the fresh
!!                               |organic (residue) to the nitrate(80%) and
!!                               |active organic(20%) pools in soil profile
!!                               |on current day in HRU
!!    rmp1tl      |kg P/ha       |amount of phosphorus moving from the labile
!!                               |mineral pool to the active mineral pool in
!!                               |the soil profile on the current day in the
!!                               |HRU
!!    rmptl       |kg P/ha       |amount of phosphorus moving from the
!!                               |fresh organic (residue) to the labile(80%)
!!                               |and organic(20%) pools in soil profile
!!                               |on current day in HRU
!!    roctl       |kg P/ha       |amount of phosphorus moving from the active
!!                               |mineral pool to the stable mineral pool
!!                               |in the soil profile on the current day in
!!                               |the HRU
!!    rwntl       |kg N/ha       |amount of nitrogen moving from active
!!                               |organic to stable organic pool in soil
!!                               |profile on current day in HRU
!!    sepday      |mm H2O        |percolation from bottom of the soil layer on
!!                               |day in HRU
!!    shallstp    |mm H2O        |depth of water in shallow aquifer in HRU on
!!                               |previous day
!!    snoev       |mm H2O        |amount of water in snow lost through
!!                               |sublimation on current day in HRU
!!    snofall     |mm H2O        |amount of precipitation falling as freezing
!!                               |rain/snow on day in HRU
!!    snomlt      |mm H2O        |amount of water in snow melt for the day in
!!                               |HRU
!!    snoprev     |mm H2O        |amount of water stored as snow on previous day
!!    sol_rd      |mm            |current rooting depth
!!    soxy        |mg/L          |saturation dissolved oxygen concentration
!!    sw_excess   |mm H2O        |amount of water in soil that exceeds field
!!                               |capacity (gravity drained water)
!!    swprev      |mm H2O        |amount of water stored in soil profile in the
!!                               |HRU on the previous day
!!    tloss       |mm H2O        |amount of water removed from surface runoff
!!                               |via transmission losses on day in HRU
!!    twlpnd      |mm H2O        |water lost through seepage from ponds on day
!!                               |in HRU
!!    twlwet      |mm H2O        |water lost through seepage from wetlands on
!!                               |day in HRU
!!    uno3d       |kg N/ha       |plant nitrogen deficiency for day in HRU
!!    usle        |metric tons/ha|daily soil loss predicted with USLE equation
!!    usle_ei     |none          |USLE erodibility index on day for HRU
!!    vpd         |kPa           |vapor pressure deficit
!!    voltot      |mm            |total volume of cracks expressed as depth
!!                               |per unit area
!!    wdntl       |kg N/ha       |amount of nitrogen lost from nitrate pool
!!                               |by denitrification in soil profile on
!!                               |current day in HRU
!!    wetev       |m^3 H2O       |evaporation from wetland for day
!!    wetflwi     |m^3 H2O       |volume of water flowing in wetland on day
!!    wetflwo     |m^3 H2O       |volume of water flowing out wetland on day
!!    wetpcp      |m^3 H2O       |precipitation on wetland for day
!!    wetsedc     |metric tons   |net change in sediment in wetland during day
!!    wetsedi     |metric tons   |sediment loading to wetland for day
!!    wetsedo     |metric tons   |sediment loading from wetland for day
!!    wetsep      |m^3 H2O       |seepage from wetland bottom for day
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    j           |none          |HRU number
!!    ly          |none          |counter
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j, ly

      j = 0
      j = ihru

      !!initialize variables
        al5 = 0.
        albday = 0.
        auton = 0.
        autop = 0.
        bactlchlp = 0.
        bactlchp = 0.
        bactrolp = 0.
        bactrop = 0.
        bactsedlp = 0.
        bactsedp = 0.
        bioday = 0.
        bsprev = 0.
        bssprev = 0.
        canev = 0.
        cfertn = 0.
        cfertp = 0.
        crk = 0.
        deepstp = 0.
        deepstp = deepst(j)
        enratio = 0.
        ep_day = 0.
        ep_max = 0.
        es_day = 0.
        etday = 0.
        fertn = 0.
        fertp = 0.
        fixn = 0.
        grazn = 0.
        grazp = 0.
        gwseep = 0.
        hhqday = 0.
        hmntl = 0.
        hmptl = 0.
        inflpcp = 0.
        lat_pst = 0.
        latlyr = 0.
        lyrtile = 0.
        no3pcp = 0.
        peakr = 0.
        pet_day = 0.
        pndev = 0.
        pndflwi = 0.
        pndflwo = 0.
        pndpcp = 0.
        pndsedc = 0.
        pndsedin = 0.
        pndsedo = 0.

        pndsanin = 0.
        pndsilin = 0.
        pndclain = 0.
        pndsagin = 0.
        pndlagin = 0.
        pndsano = 0.
        pndsilo = 0.
        pndclao = 0.
        pndsago = 0.
        pndlago = 0.

        pndsep = 0.
        potevmm = 0.
        potflwo = 0.
        potpcpmm = 0.
        potsedo = 0.

        potsano = 0.
        potsilo = 0.
        potclao = 0.
        potsago = 0.
        potlago = 0.

        potsepmm = 0.
         precipday = 0.
         precipday = subp(j)
         precipdt = 0.
         if (nstep > 0) then
           do ii = 1, nstep
             precipdt(ii+1) = rainsub(j,ii)
           end do
         end if
        pstsol = 0.
        qday = 0.
        qdfr = 0.
        qtile = 0.
        revapday = 0.
        rmn2tl = 0.
        rmp1tl = 0.
        rmptl = 0.
        roctl = 0.
        rwntl = 0.
        sepday = 0.
        shallstp = 0.
        shallstp = shallst(j)
        snoev = 0.
        snofall = 0.
        snomlt = 0.
        snoprev = 0.
        snoprev = sno_hru(j)
        sol_rd = 0.
        soxy = 0.
        sw_excess = 0.
        swprev = 0.
        swprev = sol_sw(j)
        tloss = 0.
        twlpnd = 0.
        twlwet = 0.
        uno3d = 0.
        usle = 0.
        usle_ei = 0.
        vpd = 0.
        voltot = 0.
        wdntl = 0.
        wetev = 0.
        wetflwi = 0.
        wetflwo = 0.
        wetpcp = 0.
        wetsedc = 0.
        wetsedi = 0.
        wetsedo = 0.
        wetsep = 0.

	!! urban modeling by J.Jeong
	  sedprev = 0.
	  ubnrunoff = 0.
	  irmmdt = 0.
        hhsedy = 0.
        ubntss = 0.

       return
       end