!
! CSvar_Define
!
! Module defining the CRTM CloudScatter module internal
! variable object.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 14-Feb-2012
!                       paul.vandelst@noaa.gov
!

MODULE CSvar_Define

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds           , ONLY: fp
  USE Message_Handler      , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message
  USE Compare_Float_Numbers, ONLY: OPERATOR(.EqualTo.)
  USE File_Utility         , ONLY: File_Open, File_Exists
  USE Binary_File_Utility  , ONLY: Open_Binary_File      , &
                                   WriteGAtts_Binary_File, &
                                   ReadGAtts_Binary_File
  USE CRTM_Interpolation   , ONLY: NPTS      , &
                                   LPoly_type
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Datatypes
  PUBLIC :: CSvar_type
  PUBLIC :: CSinterp_type
  ! Operators
  PUBLIC :: OPERATOR(==)
  ! Procedures
  PUBLIC :: CSvar_Associated
  PUBLIC :: CSvar_Destroy
  PUBLIC :: CSvar_Create
  PUBLIC :: CSvar_Inspect
  PUBLIC :: CSvar_ValidRelease
  PUBLIC :: CSvar_Info
  PUBLIC :: CSvar_DefineVersion
  PUBLIC :: CSvar_InquireFile
  PUBLIC :: CSvar_ReadFile
  PUBLIC :: CSvar_WriteFile

  ! ---------------------
  ! Procedure overloading
  ! ---------------------
  INTERFACE OPERATOR(==)
    MODULE PROCEDURE CSvar_Equal
  END INTERFACE OPERATOR(==)

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
    '$Id: CSvar_Define.f90,v 1.1 2013/04/07 22:56:27 jguo Exp $'
  ! Release and version
  INTEGER, PARAMETER :: CSVAR_RELEASE = 1  ! This determines structure and file formats.
  INTEGER, PARAMETER :: CSVAR_VERSION = 1  ! This is just the default data version.
  ! Close status for write errors
  CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE'
  ! Literal constants
  REAL(fp), PARAMETER :: ZERO = 0.0_fp
  REAL(fp), PARAMETER :: ONE  = 1.0_fp
  ! String lengths
  INTEGER,  PARAMETER :: ML = 256 ! Message length
  INTEGER,  PARAMETER :: SL =  80 ! String length

  ! ---------------------
  ! Structure definitions
  ! ---------------------
  ! The interpolation routine structure
  TYPE :: CSinterp_type
    ! The interpolating polynomials
    TYPE(LPoly_type) :: wlp  ! Frequency
    TYPE(LPoly_type) :: xlp  ! Effective radius
    TYPE(LPoly_type) :: ylp  ! Temperature
    ! The LUT interpolation indices
    INTEGER :: i1, i2        ! Frequency
    INTEGER :: j1, j2        ! Effective radius
    INTEGER :: k1, k2        ! Temperature
    ! The LUT interpolation boundary check
    LOGICAL :: f_outbound    ! Frequency
    LOGICAL :: r_outbound    ! Effective radius
    LOGICAL :: t_outbound    ! Temperature
    ! The interpolation input
    REAL(fp) :: f_int        ! Frequency
    REAL(fp) :: r_int        ! Effective radius
    REAL(fp) :: t_int        ! Temperature
    ! The data to be interpolated
    REAL(fp) :: f(NPTS)      ! Frequency
    REAL(fp) :: r(NPTS)      ! Effective radius
    REAL(fp) :: t(NPTS)      ! Temperature
  END TYPE CSinterp_type

  ! The internal variable definition to hold information
  ! between FWD, TL, AD, and K-matrix calls
  TYPE :: CSvar_type
    ! Allocation indicator
    LOGICAL :: Is_Allocated = .FALSE.
    ! Release and version information
    INTEGER :: Release = CSVAR_RELEASE
    INTEGER :: Version = CSVAR_VERSION
    ! Dimensions
    INTEGER :: n_Legendre_Terms = 0  ! I1
    INTEGER :: n_Phase_Elements = 0  ! I2
    INTEGER :: n_Layers         = 0  ! I3
    INTEGER :: n_Clouds         = 0  ! I4
    ! The interpolating data
    TYPE(CSinterp_type), ALLOCATABLE :: csi(:,:)  ! I3 x I4
    ! The interpolation results
    REAL(fp), ALLOCATABLE :: ke(:,:)          ! I3 x I4  Mass extinction coefficient
    REAL(fp), ALLOCATABLE :: w(:,:)           ! I3 x I4  Single Scatter Albedo
    REAL(fp), ALLOCATABLE :: g(:,:)           ! I3 x I4  Asymmetry factor
    REAL(fp), ALLOCATABLE :: pcoeff(:,:,:,:)  ! 0:I1 x I2 x I3 x I4  Phase coefficients
    ! The accumulated scattering coefficient
    REAL(fp), ALLOCATABLE :: total_bs(:)      ! I3  Volume scattering coefficient
  END TYPE CSvar_type

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                           ## PUBLIC PROCEDURES ##                          ##
!##                                                                            ##
!################################################################################
!################################################################################

  ELEMENTAL FUNCTION CSvar_Associated( self ) RESULT( Status )
    TYPE(CSvar_type), INTENT(IN) :: self
    LOGICAL :: Status
    Status = self%Is_Allocated
  END FUNCTION CSvar_Associated

  ELEMENTAL SUBROUTINE CSvar_Destroy( self )
    TYPE(CSvar_type), INTENT(OUT) :: self
    self%Is_Allocated = .FALSE.
    self%n_Legendre_Terms = 0
    self%n_Phase_Elements = 0
    self%n_Layers         = 0
    self%n_Clouds         = 0
  END SUBROUTINE CSvar_Destroy

  ELEMENTAL SUBROUTINE CSvar_Create( &
    self            , &  ! Output
    n_Legendre_Terms, &  ! Input
    n_Phase_Elements, &  ! Input
    n_Layers        , &  ! Input
    n_Clouds          )  ! Input
    ! Arguments
    TYPE(CSvar_type), INTENT(OUT) :: self
    INTEGER         , INTENT(IN)  :: n_Legendre_Terms
    INTEGER         , INTENT(IN)  :: n_Phase_Elements
    INTEGER         , INTENT(IN)  :: n_Layers
    INTEGER         , INTENT(IN)  :: n_Clouds
    ! Local variables
    INTEGER :: alloc_stat

    ! Check input
    IF ( n_Legendre_Terms < 1 .OR. &
         n_Phase_Elements < 1 .OR. &
         n_Layers         < 1 .OR. &
         n_Clouds         < 1 ) RETURN

    ! Perform the allocation
    ALLOCATE( self%csi(n_Layers, n_Clouds), &
              self%ke(n_Layers, n_Clouds), &
              self%w(n_Layers, n_Clouds), &
              self%g(n_Layers, n_Clouds), &
              self%pcoeff(0:n_Legendre_Terms,n_Phase_Elements,n_Layers, n_Clouds), &
              self%total_bs(n_Layers), &
              STAT = alloc_stat )
    IF ( alloc_stat /= 0 ) RETURN

    ! Initialise dimensions only!
    self%n_Legendre_Terms = n_Legendre_Terms
    self%n_Phase_Elements = n_Phase_Elements
    self%n_Layers         = n_Layers
    self%n_Clouds       = n_Clouds

    ! Set allocation indicator
    self%Is_Allocated = .TRUE.
  END SUBROUTINE CSvar_Create

  SUBROUTINE CSvar_Inspect( self)
    TYPE(CSvar_type), INTENT(IN) :: self
    INTEGER :: i2, i3, i4
    WRITE(*,'(1x,"CSvar OBJECT")')

    ! Release/version info
    WRITE(*,'(3x,"Release.Version     :",1x,i0,".",i0)') self%Release, self%Version

    ! Dimensions
    WRITE(*,'(3x,"n_Legendre_Terms    :",1x,i0)') self%n_Legendre_Terms
    WRITE(*,'(3x,"n_Phase_Elements    :",1x,i0)') self%n_Phase_Elements
    WRITE(*,'(3x,"n_Layers            :",1x,i0)') self%n_Layers
    WRITE(*,'(3x,"n_Clouds            :",1x,i0)') self%n_Clouds
    IF ( .NOT. CSvar_Associated(self) ) RETURN

    ! Data
    WRITE(*,'(3x,"Mass extinction coefficient (ke) :")')
    DO i4 = 1, self%n_Clouds
      WRITE(*,'(5x,"ke Cloud index #",i0)') i4
      WRITE(*,'(5(1x,es13.6,:))') self%ke(:,i4)
    END DO
    WRITE(*,'(3x,"Single scatter albedo (w) :")')
    DO i4 = 1, self%n_Clouds
      WRITE(*,'(5x,"w Cloud index #",i0)') i4
      WRITE(*,'(5(1x,es13.6,:))') self%w(:,i4)
    END DO
    WRITE(*,'(3x,"Asymmetry factor (g) :")')
    DO i4 = 1, self%n_Clouds
      WRITE(*,'(5x,"g Cloud index #",i0)') i4
      WRITE(*,'(5(1x,es13.6,:))') self%g(:,i4)
    END DO
    WRITE(*,'(3x,"Phase coefficients (pcoeff) :")')
    DO i4 = 1, self%n_Clouds
      WRITE(*,'(5x,"pcoeff Cloud index #",i0)') i4
      DO i3 = 1, self%n_Layers
        WRITE(*,'(7x,"pcoeff Layer index #",i0)') i3
        DO i2 = 1, self%n_Phase_Elements
          WRITE(*,'(9x,"pcoeff Phase element index #",i0)') i2
          WRITE(*,'(5(1x,es13.6,:))') self%pcoeff(0:,i2,i3,i4)
        END DO
      END DO
    END DO
    WRITE(*,'(3x,"Volume scattering coefficient (total_bs) :")')
    WRITE(*,'(5(1x,es13.6,:))') self%total_bs
  END SUBROUTINE CSvar_Inspect

  FUNCTION CSvar_ValidRelease( self ) RESULT( IsValid )
    ! Arguments
    TYPE(CSvar_type), INTENT(IN) :: self
    ! Function result
    LOGICAL :: IsValid
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CSvar_ValidRelease'
    ! Local variables
    CHARACTER(ML) :: msg

    ! Set up
    IsValid = .TRUE.

    ! Check release is not too old
    IF ( self%Release < CSVAR_RELEASE ) THEN
      IsValid = .FALSE.
      WRITE( msg,'("An CSvar data update is needed. ", &
                  &"CSvar release is ",i0,". Valid release is ",i0,"." )' ) &
                  self%Release, CSVAR_RELEASE
      CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ); RETURN
    END IF

    ! Check release is not too new
    IF ( self%Release > CSVAR_RELEASE ) THEN
      IsValid = .FALSE.
      WRITE( msg,'("An CSvar software update is needed. ", &
                  &"CSvar release is ",i0,". Valid release is ",i0,"." )' ) &
                  self%Release, CSVAR_RELEASE
      CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ); RETURN
    END IF
  END FUNCTION CSvar_ValidRelease

  SUBROUTINE CSvar_Info( self, Info )
    ! Arguments
    TYPE(CSvar_type), INTENT(IN)  :: self
    CHARACTER(*),     INTENT(OUT) :: Info
    ! Parameters
    INTEGER, PARAMETER :: CARRIAGE_RETURN = 13
    INTEGER, PARAMETER :: LINEFEED = 10
    ! Local variables
    CHARACTER(2000) :: Long_String

    ! Write the required data to the local string
    WRITE( Long_String, &
           '(a,1x,"CSvar RELEASE.VERSION: ",i2,".",i2.2,a,3x, &
           &"N_LEGENDRE_TERMS=",i0,2x,&
           &"N_PHASE_ELEMENTS=",i0,2x,&
           &"N_LAYERS=",i0,2x,&
           &"N_CLOUDS=",i0 )' ) &
           ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), &
           self%Release, self%Version, &
           ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), &
           self%n_Legendre_Terms, &
           self%n_Phase_Elements, &
           self%n_Layers        , &
           self%n_Clouds

    ! Trim the output based on the
    ! dummy argument string length
    Info = Long_String(1:MIN(LEN(Info), LEN_TRIM(Long_String)))
  END SUBROUTINE CSvar_Info

  SUBROUTINE CSvar_DefineVersion( Id )
    CHARACTER(*), INTENT(OUT) :: Id
    Id = MODULE_VERSION_ID
  END SUBROUTINE CSvar_DefineVersion

  FUNCTION CSvar_InquireFile( &
    Filename        , &  ! Input
    n_Legendre_Terms, &  ! Optional output
    n_Phase_Elements, &  ! Optional output
    n_Layers        , &  ! Optional output
    n_Clouds        , &  ! Optional output
    Release         , &  ! Optional output
    Version         , &  ! Optional output
    Title           , &  ! Optional output
    History         , &  ! Optional output
    Comment         ) &  ! Optional output
  RESULT( err_stat )
    ! Arguments
    CHARACTER(*),           INTENT(IN)  :: Filename
    INTEGER     , OPTIONAL, INTENT(OUT) :: n_Legendre_Terms
    INTEGER     , OPTIONAL, INTENT(OUT) :: n_Phase_Elements
    INTEGER     , OPTIONAL, INTENT(OUT) :: n_Layers
    INTEGER     , OPTIONAL, INTENT(OUT) :: n_Clouds
    INTEGER     , OPTIONAL, INTENT(OUT) :: Release
    INTEGER     , OPTIONAL, INTENT(OUT) :: Version
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: History
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Comment
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CSvar_InquireFile'
    ! Function variables
    CHARACTER(ML) :: msg
    CHARACTER(ML) :: io_msg
    INTEGER :: io_stat
    INTEGER :: fid
    TYPE(CSvar_type) :: CSvar

    ! Setup
    err_stat = SUCCESS
    ! ...Check that the file exists
    IF ( .NOT. File_Exists( Filename ) ) THEN
      msg = 'File '//TRIM(Filename)//' not found.'
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Open the file
    err_stat = Open_Binary_File( Filename, fid )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error opening '//TRIM(Filename)
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Read the release and version
    READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%Release, &
      CSvar%Version
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading Release/Version - '//TRIM(io_msg)
      CALL Inquire_Cleanup(); RETURN
    END IF
    IF ( .NOT. CSvar_ValidRelease( CSvar ) ) THEN
      msg = 'CSvar Release check failed.'
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Read the dimensions
    READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%n_Legendre_Terms, &
      CSvar%n_Phase_Elements, &
      CSvar%n_Layers        , &
      CSvar%n_Clouds
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading dimension values from '//TRIM(Filename)//' - '//TRIM(io_msg)
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Read the global attributes
    err_stat = ReadGAtts_Binary_File( &
                 fid, &
                 Title   = Title  , &
                 History = History, &
                 Comment = Comment  )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error reading global attributes'
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Close the file
    CLOSE( fid, IOSTAT=io_stat, IOMSG=io_msg )
    IF ( io_stat /= 0 ) THEN
      msg = 'Error closing '//TRIM(Filename)//' - '//TRIM(io_msg)
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Assign the return arguments
    IF ( PRESENT(n_Legendre_Terms) ) n_Legendre_Terms = CSvar%n_Legendre_Terms
    IF ( PRESENT(n_Phase_Elements) ) n_Phase_Elements = CSvar%n_Phase_Elements
    IF ( PRESENT(n_Layers        ) ) n_Layers         = CSvar%n_Layers
    IF ( PRESENT(n_Clouds        ) ) n_Clouds         = CSvar%n_Clouds
    IF ( PRESENT(Release         ) ) Release          = CSvar%Release
    IF ( PRESENT(Version         ) ) Version          = CSvar%Version

  CONTAINS

    SUBROUTINE Inquire_CleanUp()
      ! Close file if necessary
      IF ( File_Open(fid) ) THEN
        CLOSE( fid, IOSTAT=io_stat, IOMSG=io_msg )
        IF ( io_stat /= 0 ) &
          msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg)
      END IF
      ! Set error status and print error message
      err_stat = FAILURE
      CALL Display_Message( ROUTINE_NAME, msg, err_stat )
    END SUBROUTINE Inquire_CleanUp

  END FUNCTION CSvar_InquireFile

  FUNCTION CSvar_ReadFile( &
    CSvar     , &  ! Output
    Filename  , &  ! Input
    No_Close  , &  ! Optional input
    Quiet     , &  ! Optional input
    Title     , &  ! Optional output
    History   , &  ! Optional output
    Comment   , &  ! Optional output
    Debug     ) &  ! Optional input (Debug output control)
  RESULT( err_stat )
    ! Arguments
    TYPE(CSvar_type),       INTENT(OUT) :: CSvar
    CHARACTER(*),           INTENT(IN)  :: Filename
    LOGICAL,      OPTIONAL, INTENT(IN)  :: No_Close
    LOGICAL,      OPTIONAL, INTENT(IN)  :: Quiet
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: History
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Comment
    LOGICAL,      OPTIONAL, INTENT(IN)  :: Debug
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CSvar_ReadFile'
    ! Function variables
    CHARACTER(ML) :: msg
    CHARACTER(ML) :: io_msg
    LOGICAL :: close_file
    LOGICAL :: noisy
    INTEGER :: io_stat
    INTEGER :: fid
    TYPE(CSvar_type) :: dummy

    ! Setup
    err_stat = SUCCESS
    ! ...Check No_Close argument
    close_file = .TRUE.
    IF ( PRESENT(No_Close) ) close_file = .NOT. No_Close
    ! ...Check Quiet argument
    noisy = .TRUE.
    IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet
    ! ...Override Quiet settings if debug set.
    IF ( PRESENT(Debug) ) THEN
      IF ( Debug ) noisy = .TRUE.
    END IF

    ! Check if the file is open.
    IF ( File_Open( Filename ) ) THEN
      ! ...Inquire for the logical unit number
      INQUIRE( FILE=Filename, NUMBER=fid )
      ! ...Ensure it's valid
      IF ( fid < 0 ) THEN
        msg = 'Error inquiring '//TRIM(Filename)//' for its FileID'
        CALL Read_CleanUp(); RETURN
      END IF
    ELSE
      ! ...Open the file if it exists
      IF ( File_Exists( Filename ) ) THEN
        err_stat = Open_Binary_File( Filename, fid )
        IF ( err_Stat /= SUCCESS ) THEN
          msg = 'Error opening '//TRIM(Filename)
          CALL Read_CleanUp(); RETURN
        END IF
      ELSE
        msg = 'File '//TRIM(Filename)//' not found.'
        CALL Read_CleanUp(); RETURN
      END IF
    END IF

    ! Read and check the release and version
    READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      dummy%Release, &
      dummy%Version
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading Release/Version - '//TRIM(io_msg)
      CALL Read_Cleanup(); RETURN
    END IF
    IF ( .NOT. CSvar_ValidRelease( dummy ) ) THEN
      msg = 'CSvar Release check failed.'
      CALL Read_Cleanup(); RETURN
    END IF

    ! Read the dimensions
    READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      dummy%n_Legendre_Terms, &
      dummy%n_Phase_Elements, &
      dummy%n_Layers        , &
      dummy%n_Clouds
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading data dimensions - '//TRIM(io_msg)
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Allocate the object
    CALL CSvar_Create( &
           CSvar                 , &
           dummy%n_Legendre_Terms, &
           dummy%n_Phase_Elements, &
           dummy%n_Layers        , &
           dummy%n_Clouds        )
    IF ( .NOT. CSvar_Associated( CSvar ) ) THEN
      msg = 'CSvar object allocation failed.'
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Explicitly assign the version number
    CSvar%Version = dummy%Version

    ! Read the global attributes
    err_stat = ReadGAtts_Binary_File( &
                 fid, &
                 Title   = Title  , &
                 History = History, &
                 Comment = Comment  )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error reading global attributes'
      CALL Read_Cleanup(); RETURN
    END IF

    ! Read the data
    ! ...Mass extinction coefficient
    READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%ke
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading mass extinction coefficient - '//TRIM(io_msg)
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Single scatter albedo
    READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%w
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading single scatter albedo - '//TRIM(io_msg)
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Asymmetry factor
    READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%g
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading asymmetry factor - '//TRIM(io_msg)
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Phase coefficients
    READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%pcoeff
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading phase coefficients - '//TRIM(io_msg)
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Total volume scattering coefficient
    READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%total_bs
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading total volume scattering coefficient - '//TRIM(io_msg)
      CALL Read_Cleanup(); RETURN
    END IF

    ! Close the file
    IF ( close_file ) THEN
      CLOSE( fid, IOSTAT=io_stat, IOMSG=io_msg )
      IF ( io_stat /= 0 ) THEN
        msg = 'Error closing '//TRIM(Filename)//' - '//TRIM(io_msg)
        CALL Read_Cleanup(); RETURN
      END IF
    END IF

    ! Output an info message
     IF ( noisy ) THEN
       CALL CSvar_Info( CSvar, msg )
       CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION )
     END IF

   CONTAINS

     SUBROUTINE Read_CleanUp()
       IF ( File_Open(Filename) ) THEN
         CLOSE( fid, IOSTAT=io_stat, IOMSG=io_msg )
         IF ( io_stat /= 0 ) &
           msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg)
       END IF
       CALL CSvar_Destroy( CSvar )
       err_stat = FAILURE
       CALL Display_Message( ROUTINE_NAME, msg, err_stat )
     END SUBROUTINE Read_CleanUp

  END FUNCTION CSvar_ReadFile

  FUNCTION CSvar_WriteFile( &
    CSvar     , &  ! Input
    Filename  , &  ! Input
    No_Close  , &  ! Optional input
    Quiet     , &  ! Optional input
    Title     , &  ! Optional input
    History   , &  ! Optional input
    Comment   , &  ! Optional input
    Debug     ) &  ! Optional input (Debug output control)
  RESULT( err_stat )
    ! Arguments
    TYPE(CSvar_type),  INTENT(IN) :: CSvar
    CHARACTER(*),           INTENT(IN) :: Filename
    LOGICAL,      OPTIONAL, INTENT(IN) :: No_Close
    LOGICAL,      OPTIONAL, INTENT(IN) :: Quiet
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Title
    CHARACTER(*), OPTIONAL, INTENT(IN) :: History
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Comment
    LOGICAL,      OPTIONAL, INTENT(IN) :: Debug
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CSvar_WriteFile'
    ! Function variables
    CHARACTER(ML) :: msg
    CHARACTER(ML) :: io_msg
    LOGICAL :: close_file
    LOGICAL :: noisy
    INTEGER :: io_stat
    INTEGER :: fid

    ! Setup
    err_stat = SUCCESS
    ! ...Check No_Close argument
    close_file = .TRUE.
    IF ( PRESENT(No_Close) ) close_file = .NOT. No_Close
    ! ...Check Quiet argument
    noisy = .TRUE.
    IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet
    ! ...Override Quiet settings if debug set.
    IF ( PRESENT(Debug) ) THEN
      IF ( Debug ) noisy = .TRUE.
    END IF
    ! ...Check there is data to write
    IF ( .NOT. CSvar_Associated( CSvar ) ) THEN
      msg = 'CSvar object is empty.'
      CALL Write_Cleanup(); RETURN
    END IF

    ! Check if the file is open.
    IF ( File_Open( FileName ) ) THEN
      ! ...Inquire for the logical unit number
      INQUIRE( FILE=Filename, NUMBER=fid )
      ! ...Ensure it's valid
      IF ( fid < 0 ) THEN
        msg = 'Error inquiring '//TRIM(Filename)//' for its FileID'
        CALL Write_CleanUp(); RETURN
      END IF
    ELSE
      ! ...Open the file for output
      err_stat = Open_Binary_File( Filename, fid, For_Output=.TRUE. )
      IF ( err_Stat /= SUCCESS ) THEN
        msg = 'Error opening '//TRIM(Filename)
        CALL Write_CleanUp(); RETURN
      END IF
    END IF

    ! Write the release and version
    WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%Release, &
      CSvar%Version
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing Release/Version - '//TRIM(io_msg)
      CALL Write_Cleanup(); RETURN
    END IF

    ! Write the dimensions
    WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%n_Legendre_Terms, &
      CSvar%n_Phase_Elements, &
      CSvar%n_Layers        , &
      CSvar%n_Clouds
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing data dimensions - '//TRIM(io_msg)
      CALL Write_Cleanup(); RETURN
    END IF

    ! Write the global attributes
    err_stat = WriteGAtts_Binary_File( &
                 fid, &
                 Write_Module = MODULE_VERSION_ID, &
                 Title        = Title  , &
                 History      = History, &
                 Comment      = Comment  )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error writing global attributes'
      CALL Write_Cleanup(); RETURN
    END IF

    ! Write the data
    ! ...Mass extinction coefficient
    WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%ke
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing mass extinction coefficient - '//TRIM(io_msg)
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Single scatter albedo
    WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%w
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing single scatter albedo - '//TRIM(io_msg)
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Asymmetry factor
    WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%g
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing asymmetry factor - '//TRIM(io_msg)
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Phase coefficients
    WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%pcoeff
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing phase coefficients - '//TRIM(io_msg)
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Total volume scattering coefficient
    WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
      CSvar%total_bs
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing total volume scattering coefficient - '//TRIM(io_msg)
      CALL Write_Cleanup(); RETURN
    END IF

    ! Close the file
    IF ( close_file ) THEN
      CLOSE( fid, IOSTAT=io_stat, IOMSG=io_msg )
      IF ( io_stat /= 0 ) THEN
        msg = 'Error closing '//TRIM(Filename)//' - '//TRIM(io_msg)
        CALL Write_Cleanup(); RETURN
      END IF
    END IF

    ! Output an info message
     IF ( noisy ) THEN
       CALL CSvar_Info( CSvar, msg )
       CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION )
     END IF

   CONTAINS

     SUBROUTINE Write_Cleanup()
       IF ( File_Open(Filename) ) THEN
         CLOSE( fid, IOSTAT=io_stat, IOMSG=io_msg )
         IF ( io_stat /= 0 ) &
           msg = TRIM(msg)//'; Error closing output file during error cleanup - '//TRIM(io_msg)
       END IF
       err_stat = FAILURE
       CALL Display_Message( ROUTINE_NAME, msg, err_stat )
     END SUBROUTINE Write_Cleanup

  END FUNCTION CSvar_WriteFile

!################################################################################
!################################################################################
!##                                                                            ##
!##                          ## PRIVATE PROCEDURES ##                          ##
!##                                                                            ##
!################################################################################
!################################################################################

  ELEMENTAL FUNCTION CSvar_Equal( x, y ) RESULT( is_equal )
    TYPE(CSvar_type), INTENT(IN) :: x, y
    LOGICAL :: is_equal

    ! Set up
    is_equal = .FALSE.

    ! Check the object association status
    IF ( (.NOT. CSvar_Associated(x)) .OR. &
         (.NOT. CSvar_Associated(y))      ) RETURN

   ! Check contents
    ! ...Release/version info
    IF ( (x%Release /= y%Release) .OR. &
         (x%Version /= y%Version) ) RETURN
    ! ...Dimensions
    IF ( (x%n_Legendre_Terms /= y%n_Legendre_Terms ) .OR. &
         (x%n_Phase_Elements /= y%n_Phase_Elements ) .OR. &
         (x%n_Layers         /= y%n_Layers         ) .OR. &
         (x%n_Clouds         /= y%n_Clouds         ) ) RETURN
    ! ...Arrays
    IF ( ALL(x%ke       .EqualTo. y%ke       ) .AND. &
         ALL(x%w        .EqualTo. y%w        ) .AND. &
         ALL(x%g        .EqualTo. y%g        ) .AND. &
         ALL(x%pcoeff   .EqualTo. y%pcoeff   ) .AND. &
         ALL(x%total_bs .EqualTo. y%total_bs ) ) &
      is_equal = .TRUE.
  END FUNCTION CSvar_Equal

END MODULE CSvar_Define


*DK dumpfehm
      subroutine dumpfehm(ifile,ifileini,ioption,iomode,
     *       area_coef_option,write_opt,attrib_option,area_option,
     *       hybrid_option)
C
C #####################################################################
C
C     PURPOSE -
C
C        THIS ROUTINE WRITES FEHMN and PFLOTRAN style files
C
C        Arguments are processed and passed in from writedump()
C         ifile is the file or attribute name
C         ifileini is used by dump_fehm_geom
C         ioption is fehm or stor
C            fehm will write suite of fehm files
C            stor will write fehm stor file only
C            pflotran will write pflotran stor file
C
C         iomode is writing mode such as ascii
C         area_coef_option is coef_option such as scalar
C         write_opt triggers how much to write
C             for stor it compress coef values and indices
C             for pflotran skips zeros, writes zeros, or extra
C         attrib_option is outside node option such as keepatt
C         area_option is attribute option such as keepatt_voronoi
C
C
C     INPUT ARGUMENTS -
C
C        None
C
C     OUTPUT ARGUMENTS -
C
C        None
C
C     CHANGE HISTORY -
C
C        $Log: dumpfehm.f,v $
C        Revision 2.00  2007/11/05 19:45:53  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.34   23 Feb 2005 08:29:04   tam
CPVCS    added argument imat_select to dump_material_list call that
CPVCS    enables a single zone to be selected
CPVCS
CPVCS       Rev 1.33   21 Jan 2004 11:37:18   tam
CPVCS    added ioption to arguments to allow choice between
CPVCS    fehm and stor, where stor writes stor file but
CPVCS    nothing else
CPVCS
CPVCS       Rev 1.32   10 Mar 2000 12:46:42   gable
CPVCS    Remove call to mask_icr, put inside dump_outside_list.f
CPVCS
CPVCS       Rev 1.31   Tue May 18 12:47:44 1999   murphy
CPVCS    Added 'alternate_scalar' option to produce compressed FEHM matrices on-the-fly
CPVCS
CPVCS       Rev 1.30   Tue Mar 16 09:26:16 1999   murphy
CPVCS    Removed evil print statement.
CPVCS
CPVCS       Rev 1.29   Mon Mar 15 16:46:34 1999   murphy
CPVCS    Added compression option.
CPVCS
CPVCS       Rev 1.28   Mon Jan 25 13:01:40 1999   llt
CPVCS    passing option to delete/keep boundary attributes to
CPVCS    dump_outside_list
CPVCS
CPVCS       Rev 1.27   Tue Oct 13 20:02:32 1998   gable
CPVCS    No change.
CPVCS
CPVCS       Rev 1.26   Thu Mar 12 13:35:28 1998   gable
CPVCS    Added option area_scalar, area_vector, area_both to output
CPVCS    area coefficients Aij, without division by distance xij.
CPVCS
CPVCS       Rev 1.25   Wed Feb 11 10:37:28 1998   tam
CPVCS    added option "unformatted" for iomode
CPVCS
CPVCS       Rev 1.24   Wed Oct 15 13:39:46 1997   gable
CPVCS    Modified to allow ascii or binary fehm stor file output.
CPVCS    Also added option to have scalar, vector or scalar and vector
CPVCS    area coefficients as part of output.
CPVCS
CPVCS       Rev 1.23   Fri Sep 19 15:15:44 1997   gable
CPVCS    Turn of tty log when attributes for tblrfb are added.
CPVCS
CPVCS       Rev 1.22   Wed Jul 02 09:17:42 1997   gable
CPVCS    Added call to dump_multi_mat_con.f
CPVCS
CPVCS       Rev 1.21   Mon Jun 30 16:21:28 1997   gable
CPVCS    Assign ijob to type integer.
CPVCS
CPVCS       Rev 1.20   Mon Jun 30 16:11:34 1997   gable
CPVCS    Added ijob to calling arguments of matbld3d_stor.
CPVCS
CPVCS       Rev 1.19   Mon Apr 14 16:44:04 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.18   Wed May 08 12:30:28 1996   gable
CPVCS    Major changes to dumpfehm. This code is now a driver for
CPVCS    five other codes, each of which output some of the FEHM
CPVCS    output. This will now set a bit mask in the icr array
CPVCS    to identify the top, bottom, ... nodes.
CPVCS
CPVCS       Rev 1.17   Fri Feb 16 12:51:26 1996   het
CPVCS    Correct the parent/child entries in the .stor file
CPVCS
CPVCS       Rev 1.16   Fri Feb 02 14:21:18 1996   dcg
CPVCS    remove references to explicit vector attributes (u,w,v,e,r,pic)
CPVCS
CPVCS       Rev 1.15   Tue Jan 23 09:28:00 1996   het
CPVCS    Add an epsilon to the Voronoi point calculation for 2D
CPVCS
CPVCS
CPVCS       Rev 1.14   Thu Jan 18 12:41:56 1996   gable
CPVCS    Add multi-material (parent/child) node list output.
CPVCS
CPVCS       Rev 1.13   Fri Dec 22 14:18:44 1995   het
CPVCS    Add the dump_hex option
CPVCS
CPVCS       Rev 1.12   12/05/95 08:23:10   het
CPVCS    Make changes for UNICOS
CPVCS
CPVCS       Rev 1.11   11/07/95 17:16:22   dcg
CPVCS    change flag to 2 in mmgetblk calls
CPVCS
CPVCS       Rev 1.10   10/16/95 09:05:10   het
CPVCS    Change sign(1.0 to sign(1
CPVCS
CPVCS       Rev 1.9   10/13/95 16:53:58   het
CPVCS    Latest changes
CPVCS
CPVCS       Rev 1.8   09/11/95 14:41:38   het
CPVCS    Change to the storage block based CMO stuff.
CPVCS
CPVCS       Rev 1.7   08/31/95 14:54:22   gable
CPVCS    Change constraint table to include more special cases. Constraint
CPVCS    table now goes up 0-40 cases.
CPVCS
CPVCS    Change order of zone list output. Output is now in order of materials,
CPVCS    material = 1 first.
CPVCS
CPVCS    Added a debug option. If variable, if_debug .ne. 0, then 6 new integer
CPVCS    addributes are added to the cmo. These atributes are for
CPVCS    top, bottom, left, right, front, back. The attribute is 1 if it is a side/top/...
CPVCS    and .lt. 0 if it is not.
CPVCS
CPVCS       Rev 1.6   08/15/95 18:22:42   het
CPVCS    Cleanup code and correct errors
CPVCS
CPVCS       Rev 1.5   07/25/95 15:25:02   gable
CPVCS          Change constraint table for icr array. Largest value of icr used to be
CPVCS         24. Constraint table now goes up to 32.
CPVCS
CPVCS         Correct output to fehm elem macro. Parameter ns was hardwired to 8
CPVCS         but code did not always pad connectivity to 8 integer values. Now set
CPVCS         to output ns=4 for tets, ns=3 for triangles.
CPVCS
CPVCS
CPVCS       Rev 1.4   07/14/95 10:18:54   het
CPVCS    Make output format consistent for FEHMN/AVS
CPVCS
CPVCS       Rev 1.3   06/28/95 11:30:46   het
CPVCS    Correct errors related to formatting
CPVCS
CPVCS       Rev 1.2   06/05/95 10:36:28   het
CPVCS    Make changes for hybrid_grids
CPVCS
CPVCS       Rev 1.1   05/26/95 13:13:16   het
CPVCS    Replace subroutine parameter list with subroutine calles.
CPVCS
CPVCS       Rev 1.0   01/17/95 16:36:02   pvcs
CPVCS    Original Version
C
C ######################################################################
C
      implicit none
c
      character ifile*(*), ifileini*(*)
      character ioption*(*)
      character iomode*(*), area_coef_option*(*)
      character write_opt*(*),attrib_option*(*),area_option*(*)
      character hybrid_option*(*)

      integer ntets, nen, nsdtopo, nef, ijob
      integer length, icmotype, io, num_area_coef, ierror
      integer ifcompress, ifhybrid, imat_select
      integer idebug, ilen,ityp,ierr

      integer icharlnf

      character*132 logmess
      character*32 isubname, cmo
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Begin
      isubname = 'dumpfehm'
      if (ioption(1:4) .ne.'fehm') isubname='dumpstor'
      ierror = 0
c
c     check cmo and setup
c
      call cmo_get_name(cmo,ierror)
      call cmo_get_info('nelements',cmo,
     *                  ntets,length,icmotype,ierror)
      call cmo_get_info('nodes_per_element',cmo,
     *                  nen,length,icmotype,ierror)
      call cmo_get_info('ndimensions_topo',cmo,
     *                  nsdtopo,length,icmotype,ierror)
      call cmo_get_info('faces_per_element',cmo,
     *                  nef,length,icmotype,ierror)

      call cmo_get_info('idebug',cmo,idebug,ilen,ityp,ierr)

      if(idebug.ne.0) then
        write(logmess,'(a5,a10,a,a)')"dump/",ioption,
     *   ifile(1:icharlnf(ifile)),
     *  " options set to: "
        call writloga('default',0,logmess,0,ierr)

        write(logmess,'(6x,a,2x,a,2x,a,2x,a,2x,a,2x,a)')
     *   iomode(1:icharlnf(iomode)),
     *   area_coef_option(1:icharlnf(area_coef_option)),
     *   write_opt(1:icharlnf(write_opt)),
     *   attrib_option(1:icharlnf(attrib_option)),
     *   area_option(1:icharlnf(area_option)),
     *   hybrid_option(1:icharlnf(hybrid_option))
        call writloga('default',0,logmess,0,ierr)

        call mmverify()

      endif

C     Check and set options
C     any combination of options are allowed to pass into this routine
C     check here and warn for those that do not apply, set to defaults
C         dump/fehm option ifileini is used by dump_fehm_geom
C              read ifileini.ini and skipped if ifileini is empty ??
C         dump/fehm option attrib_option default is delatt
C         dump/fehm option area_option default is -notset-
C         ifile is the file or attribute name
C         ioption is fehm or stor, where fehm will write all fehm files
C         iomode default is ascii
C         area_coef_option default is scalar
C         write_opt default is all
c
c     FEHM - Write all fehm files in addition to the stor file
c     OPTIONS for default fehm files
c       imat_select - dump_material_list of single value (set to zero here)
c                     since there is no way to get the value in here.
c       attrib_option - delatt|keepatt|keepatt_area for dump_outside_list
c       area_option - keepatt_voronoi | keepatt_median for dump_outside_list

      imat_select = 0

      if (ioption(1:4) .eq. 'fehm') then
         write(logmess,101)
  101    format('*** Write FEHMN GEOM AND ZONE FILES ***')
        call writloga('default',0,logmess,0,ierror)
        call dump_fehm_geom(ifile, ifileini)
        call dump_material_list(ifile,imat_select)
        call dump_interface_list(ifile)
        call dump_multi_mat_con(ifile)

        call dotaskx3d('log/tty/off; finish',ierror)
        call dump_outside_list(ifile, attrib_option, area_option)
        call dotaskx3d('log/tty/on; finish',ierror)
        call dump_parent_list(ifile)
      endif
C
c     STOR - write the stor file
c     As of June 3 2009
c     OPTIONS differ between the 3 routines that write stor files
c     matbld2d_stor, matbld3d_stor, anothermatbld3d_wrapper
c     the FEHM header has been modified to indicate the routine
c     and the type of compression being used.
c     matbld3d_nstor - original version, no compression (none)
c     matbld3d_cstor - original version, compress coef values (coefs)
c     matbld3d_gstor - new version, compress graph edges (graph)
c     matbld3d_astor - new version, compress indices and coef values (all)
c
c     This has become the default for 3D
c     anothermatbld3d_wrapper - update by Mike Murphy using linked lists
c        ifile : file or attribute name
c        io : 1=3=unformatted 2=ascii 5=attribute only
c        num_area_coef : only scalar available, set to 1
c        ifcompress: 0= graph - compress coef indices (edge compression)
c                       1= all - area coef and indices compression
c
c     matbld2d_stor for 2D
c        ifile : file name
c        io_type is used to toggle additional file formats
c
c     matbld3d_stor - original sparse matrix
c        ifile : file name
c        ijob  : 1=write coef to file and attribute  2= write attribute only
c        io    : 1=3=unformatted 2=ascii
c        num_area_coef : 1=scalar 2=vector 3=both 4=area_scalar
c                       -1=area_scalar -3=area_vector -4=area_both
c        ifcompress : 0= none - no ccoef compression
c                        1= coefs -  compression of area coef values
c
c

c---- 2D STOR  -----------------------------------------------c
      if(nsdtopo.eq.2.and.nen.eq.3.and.nef.eq.3) then

c        default flag for FEHM matbld is 2
         io = 2

c        check for pflotran format option
         ilen=icharlnf(write_opt)
         if (ioption(1:4).eq.'pflo') then
             if (write_opt(1:ilen) .eq.'default') io = 10
             if (write_opt(1:ilen) .eq.'filter') io = 10
             if (write_opt(1:ilen) .eq.'nofilter') io = 12
             if (write_opt(1:ilen) .eq.'all') io = 12
             if (write_opt(1:ilen) .eq.'verbose') io = 13
             ifcompress = 1
         endif

         write(logmess,100)
  100    format('***Construct Regular Sparse Matrix:2D***')
         call writloga('default',0,logmess,0,ierror)

         call matbld2d_stor(ifile,io)

c---- 3D STOR  -----------------------------------------------c
      elseif(nsdtopo.eq.3.and.nen.eq.4.and.nef.eq.4) then
         ijob = 1
         ifcompress = 0
         ifhybrid = 0
         if(iomode(1:3) .eq. 'bin')io = 1
         if(iomode(1:3) .eq. 'asc')io = 2
         if(iomode(1:3) .eq. 'unf')io = 3
         if(write_opt(1:3) .eq. 'all') ifcompress=1
         if(write_opt(1:4) .eq. 'coef') ifcompress=1
         if(write_opt(1:4) .eq. 'none') ifcompress=0
         if(write_opt(1:5) .eq. 'graph') ifcompress=0
         if(hybrid_option(1:6) .eq. 'hybrid') ifhybrid=1

         if(area_coef_option(1:6)     .eq.'scalar')then
            num_area_coef = 1
         elseif(area_coef_option(1:6) .eq.'vector')then
            num_area_coef = 3
         elseif(area_coef_option(1:4) .eq.'both')then
            num_area_coef = 4
         elseif(area_coef_option(1:11).eq.'area_scalar')then
            num_area_coef = -1
         elseif(area_coef_option(1:11).eq.'area_vector')then
            num_area_coef = -3
         elseif(area_coef_option(1:9) .eq.'area_both')then
            num_area_coef = -4
         endif

C        check for old syntax
         if(area_coef_option(1:16) .eq.'alternate_scalar') then
            num_area_coef = 1
         endif

C        vector and area options not available in anothermatbld3d
C        so default to none and use matbld3d (no compression)
C        we default to none because compression does not work for these
         if (num_area_coef .ne. 1) then
            if (write_opt(1:4).ne."coef") then
               write_opt="none"
               ifcompress = 0
            endif
         endif

c        3D Alternate STOR (default) --------------------------------c
c        this new version of matbld has become the version of choice
c        and has provided better results than the old version
c        the word "alternate" should be phased out
c        ifile = name
c        io = format and write type
c        num_area_coef = type ccoef to write
c                      = 1 = scalar Aij/distance
c        ifcompress = 1 with compression, 0 for none
c        ifhybrid triggers voronoi-median hybrid volumes
c
c        default = all

         if( ioption(1:4)  .eq.'pflo'    .or.
     *      write_opt(1:5) .eq.'graph'   .or.
     *      write_opt(1:7) .eq.'default' .or.
     *      write_opt(1:3) .eq.'all') then

c          check for pflotran format option
           ilen = icharlnf(write_opt)
           if (ioption(1:4).eq.'pflo') then
             if (write_opt(1:ilen) .eq.'default') io = 10
             if (write_opt(1:ilen) .eq.'filter') io = 10
             if (write_opt(1:ilen) .eq.'nofilter') io = 12
             if (write_opt(1:ilen) .eq.'all') io = 12
             if (write_opt(1:ilen) .eq.'verbose') io = 13
             ifcompress = 1
           endif

           write(logmess,110)
  110      format('*** Construct and Compress Sparse Matrix:3D ***')
           call writloga('default',1,logmess,0,ierror)
           if (ifcompress .gt. 0) then
             write(logmess,111)
             call writloga('default',0,logmess,0,ierror)
           endif

c          check arguments
           if (num_area_coef .ne. 1) then
             write(logmess,'(a,a12)')
     *    "Alternate Matbld3d option not available: ",area_coef_option
             call writloga('default',0,logmess,0,ierror)
             write(logmess,'(a)')
     *     "Using scalar - single component area/distance coefficients"
             call writloga('default',0,logmess,0,ierror)
             num_area_coef = 1
           endif

           call anothermatbld3d_wrapper(ifile,io,num_area_coef,
     *                ifcompress, ifhybrid)

c        3D Regular OLD STOR  ---------------------------------------c
         else

           if (ifhybrid .eq. 1) then
               write(logmess,'(a,a,a)')'Warning: ignoring hybrid ',
     *         'option because it is not supported in combination ',
     *         'with the other chosen options.'
               call writloga('default',1,logmess,0,ierror)
           endif
           write(logmess,130)
  130      format('*** Construct Sparse Matrix:3D ***')
           call writloga('default',1,logmess,0,ierror)
           if (ifcompress .gt. 0) then
             write(logmess,111)
             call writloga('default',0,logmess,0,ierror)
           endif

c          check arguments
           call matbld3d_stor(ifile,ijob,io,num_area_coef,ifcompress)

         endif
  111        format('   *** Compress Area Coefficient Values ***')

c---- topo or element not usable ---------------------------------------c
      else

        write(logmess,'(a,a)') "*** DUMP/STOR ",
     *  " Mesh object does not qualify for sparse matrix. ***"
        call writloga('default',1,logmess,1,ierr)

        if (ntets .le.0) then
          write(logmess,'(a)')
     *    "Mesh object has 0 elements.  "
          call writloga('default',0,logmess,0,ierr)
        endif
        if (nef .le.0) then
          write(logmess,'(a)')
     *    "Mesh object has 0 faces.  "
          call writloga('default',0,logmess,0,ierr)
        endif
        if (nsdtopo.ne.2 .or. nsdtopo.ne.3) then
          write(logmess,'(a,i5)')
     *    "Mesh object has unsupported dimension:  ",nsdtopo
          call writloga('default',0,logmess,0,ierr)
        endif
       logmess='cmo/status/'//cmo(1:icharlnf(cmo))//' brief ; finish'
        call dotaskx3d(logmess,ierr)

        write(logmess,'(a)')
     *  "*** DUMP/STOR Finished early, no stor file written! ***"
        call writloga('default',1,logmess,1,ierr)

      endif
C
      return
      end