NLTE_Predictor_IO.f90

Go to the documentation of this file.

!
! NLTE_Predictor_IO
!
! Module containing routines to read and write Binary format
! NLTE_Predictor data files.
!
!
! CREATION HISTORY:
!       Written by:  Paul van Delst, 15-Mar-2011
!                    paul.vandelst@noaa.gov
!

MODULE nlte_predictor_io

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module use
  USE type_kinds           , ONLY: long, double
  USE file_utility         , ONLY: file_open, file_exists
  USE message_handler      , ONLY: success, failure, warning, information, display_message
  USE binary_file_utility  , ONLY: open_binary_file
  USE nlte_predictor_define, ONLY: nlte_predictor_type        , &
                                   nlte_predictor_destroy     , &
                                   nlte_predictor_validrelease, &
                                   nlte_predictor_info
  ! Disable implicit typing
  IMPLICIT NONE


  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: nlte_predictor_inquirefile
  PUBLIC :: nlte_predictor_readfile
  PUBLIC :: nlte_predictor_writefile
  PUBLIC :: nlte_predictor_ioversion


  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PRIVATE, PARAMETER :: module_version_id = &
    '$Id: NLTE_Predictor_IO.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $'
  CHARACTER(*), PARAMETER :: write_error_status = 'DELETE'
  ! Default message length
  INTEGER, PARAMETER :: ml = 256


CONTAINS


!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTE_Predictor_InquireFile
!
! PURPOSE:
!       Function to inquire a Binary format NLTE_Predictor file.
!
! CALLING SEQUENCE:
!       Error_Status = NLTE_Predictor_InquireFile( &
!                        Filename               , &
!                        n_Profiles = n_Profiles, &
!                        Release    = Release   , &
!                        Version    = Version     )
!
! INPUTS:
!       Filename:      Character string specifying the name of the NLTE
!                      predictor data file to inquire.
!                      UNITS:      N/A
!                      TYPE:       CHARACTER(*)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! OPTIONAL OUTPUTS:
!       n_Profiles:    The number of profiles for which there is NLTE
!                      predictor information in the data file.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       Release:       The data/file release number. Used to check
!                      for data/software mismatch.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Version:       The data/file version number. Used for
!                      purposes only in identifying the dataset for
!                      a particular release.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:  The return value is an integer defining the error
!                      status. The error codes are defined in the
!                      Message_Handler module.
!                      If == SUCCESS the file inquire was successful
!                         == FAILURE an unrecoverable error occurred.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION nlte_predictor_inquirefile( &
    Filename  , &  ! Input
    n_Profiles, &  ! Optional output  
    Release   , &  ! Optional Output
    Version   ) &  ! Optional Output
  result( err_stat )
    ! Arguments
    CHARACTER(*),           INTENT(IN)  :: filename
    INTEGER     , OPTIONAL, INTENT(OUT) :: n_profiles
    INTEGER     , OPTIONAL, INTENT(OUT) :: release
    INTEGER     , OPTIONAL, INTENT(OUT) :: version
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: routine_name = 'NLTE_Predictor_InquireFile'
    ! Function variables
    CHARACTER(ML) :: msg
    INTEGER :: io_stat
    INTEGER :: fid
    INTEGER :: rel, ver, m

 
    ! 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 ) rel, ver
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error reading Release/Version. IOSTAT = ",i0)' ) io_stat
      CALL inquire_cleanup(); RETURN
    END IF


    ! Read the number of profiles
    READ( fid, iostat=io_stat ) m
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error reading dimensions from ",a,". IOSTAT = ",i0)' ) trim(filename), io_stat
      CALL inquire_cleanup(); RETURN
    END IF


    ! Close the file
    CLOSE( fid, iostat=io_stat )
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error closing ",a,". IOSTAT = ",i0)' ) trim(filename), io_stat
      CALL inquire_cleanup(); RETURN
    END IF


    ! Assign the return arguments
    IF ( PRESENT(n_profiles) ) n_profiles = m
    IF ( PRESENT(release   ) ) release    = rel
    IF ( PRESENT(version   ) ) version    = ver
    
  CONTAINS
  
    SUBROUTINE inquire_cleanup()
      ! Close file if necessary
      IF ( file_open(fid) ) THEN
        CLOSE( fid, iostat=io_stat )
        IF ( io_stat /= 0 ) &
          msg = trim(msg)//'; Error closing input file during error cleanup'
      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 nlte_predictor_inquirefile


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTE_Predictor_ReadFile
!
! PURPOSE:
!       Function to read NLTE_Predictor object files in Binary format.
!
! CALLING SEQUENCE:
!       Error_Status = NLTE_Predictor_ReadFile( &
!                        Filename      , &
!                        NLTE_Predictor, &
!                        Quiet      = Quiet     , &
!                        n_Profiles = n_Profiles  )
!
! INPUTS:
!       Filename:       Character string specifying the name of a
!                       NLTE_Predictor format data file to read.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       NLTE_Predictor: NLTE_Predictor object containing the NLTE correction
!                       algorithm predictor data.
!                       UNITS:      N/A
!                       TYPE:       NLTE_Predictor_type
!                       DIMENSION:  Rank-1
!                       ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Quiet:          Set this logical argument to suppress INFORMATION
!                       messages being printed to stdout
!                       If == .FALSE., INFORMATION messages are OUTPUT [DEFAULT].
!                          == .TRUE.,  INFORMATION messages are SUPPRESSED.
!                       If not specified, default is .FALSE.
!                       UNITS:      N/A
!                       TYPE:       LOGICAL
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
! OPTIONAL OUTPUTS:
!       n_Profiles:     The number of profiles for which data was read.
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
!       Error_Status:   The return value is an integer defining the error status.
!                       The error codes are defined in the Message_Handler module.
!                       If == SUCCESS, the file read was successful
!                          == FAILURE, an unrecoverable error occurred.
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION nlte_predictor_readfile( &
    Filename      , &  ! Input
    NLTE_Predictor, &  ! Output
    Quiet         , &  ! Optional input
    n_Profiles    , &  ! Optional output
    Debug         ) &  ! Optional input (Debug output control)
  result( err_stat )
    ! Arguments
    CHARACTER(*),              INTENT(IN)  :: filename
    TYPE(nlte_predictor_type), INTENT(OUT) :: nlte_predictor(:)
    LOGICAL,         OPTIONAL, INTENT(IN)  :: quiet          
    INTEGER,         OPTIONAL, INTENT(OUT) :: n_profiles
    LOGICAL,         OPTIONAL, INTENT(IN)  :: debug          
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: routine_name = 'NLTE_Predictor_ReadFile'
    ! Function variables
    CHARACTER(ML) :: msg
    LOGICAL :: noisy
    INTEGER :: io_stat
    INTEGER :: fid
    INTEGER :: n_file_profiles
    INTEGER :: m, n_input_profiles
    TYPE(nlte_predictor_type) :: dummy
    

    ! Setup
    err_stat = success
    ! ...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

   
    ! 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


    ! Read and check the release and version
    READ( fid, iostat=io_stat ) dummy%Release, dummy%Version
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error reading Release/Version. IOSTAT = ",i0)' ) io_stat
      CALL read_cleanup(); RETURN
    END IF
    IF ( .NOT. nlte_predictor_validrelease( dummy ) ) THEN
      msg = 'NLTE_Predictor Release check failed.'
      CALL read_cleanup(); RETURN
    END IF


    ! Read the dimensions     
    READ( fid, iostat=io_stat ) n_file_profiles
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error reading profile dimension from ",a,". IOSTAT = ",i0)' ) &
             trim(filename), io_stat
      CALL read_cleanup(); RETURN
    END IF
    ! ...Check if n_Profiles in file is > size of output array
    n_input_profiles = SIZE(nlte_predictor)
    IF ( n_file_profiles > n_input_profiles ) THEN
      WRITE( msg,'("Number of profiles, ",i0," > size of the output NLTE_Predictor ", &
                  &" array, ",i0,". Only the first ",i0, &
                  &" profiles will be read.")' ) &
                  n_file_profiles, n_input_profiles, n_input_profiles
      CALL display_message( routine_name, msg, warning )
    END IF
    n_input_profiles = min(n_input_profiles, n_file_profiles)
    
    
    ! Loop over all the profiles
    profile_loop: DO m = 1, n_input_profiles

      ! Read the NLTE predictor data
      ! ...Read the dimensions
      READ( fid, iostat=io_stat ) &
        nlte_predictor(m)%n_Layers    , &
        nlte_predictor(m)%n_Predictors
      IF ( io_stat /= 0 ) THEN
        WRITE( msg,'("Error reading data dimensions for profile ",i0, &
                    &". IOSTAT = ",i0)' ) m, io_stat
        CALL read_cleanup(); RETURN
      END IF
      ! ...Read the logical indicators
      READ( fid, iostat=io_stat ) &
        nlte_predictor(m)%Is_Active , &
        nlte_predictor(m)%Compute_Tm
      IF ( io_stat /= 0 ) THEN
        WRITE( msg,'("Error reading logical indicators for profile ",i0, &
                    &". IOSTAT = ",i0)' ) m, io_stat
        CALL read_cleanup(); RETURN
      END IF
      ! ...Read the array indices
      READ( fid, iostat=io_stat ) &
        nlte_predictor(m)%k1, &
        nlte_predictor(m)%k2, &
        nlte_predictor(m)%isen, &
        nlte_predictor(m)%isol
      IF ( io_stat /= 0 ) THEN
        WRITE( msg,'("Error reading array indices for profile ",i0, &
                    &". IOSTAT = ",i0)' ) m, io_stat
        CALL read_cleanup(); RETURN
      END IF
      ! ...Read the predictors and interpolation weights
      READ( fid, iostat=io_stat ) &
        nlte_predictor(m)%Tm       , &
        nlte_predictor(m)%Predictor, &
        nlte_predictor(m)%w        
      IF ( io_stat /= 0 ) THEN
        WRITE( msg,'("Error reading predictors and interpolation weights for profile ",i0, &
                    &". IOSTAT = ",i0)' ) m, io_stat
        CALL read_cleanup(); RETURN
      END IF

      ! Explicitly assign the version number
      nlte_predictor(m)%Version = dummy%Version

    END DO profile_loop
        
    
    ! Close the file
    CLOSE( fid, iostat=io_stat )
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error closing ",a,". IOSTAT = ",i0)' ) trim(filename), io_stat
      CALL read_cleanup(); RETURN
    END IF


    ! Set the return values
    IF ( PRESENT(n_profiles) ) n_profiles = n_input_profiles


    ! Output an info message
    IF ( noisy ) THEN
      WRITE( msg,'("Number of profiles read from ",a,": ",i0)' ) trim(filename), n_input_profiles
      CALL display_message( routine_name, trim(msg), information )
    END IF

   CONTAINS
   
     SUBROUTINE read_cleanup()
       IF ( file_open(filename) ) THEN
         CLOSE( fid, iostat=io_stat )
         IF ( io_stat /= 0 ) &
           msg = trim(msg)//'; Error closing input file during error cleanup.'
       END IF
       CALL nlte_predictor_destroy( nlte_predictor )
       err_stat = failure
       CALL display_message( routine_name, msg, err_stat )
     END SUBROUTINE read_cleanup

  END FUNCTION nlte_predictor_readfile


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTE_Predictor_WriteFile
!
! PURPOSE:
!       Function to write NLTE_Predictor object files in Binary format.
!
! CALLING SEQUENCE:
!       Error_Status = NLTE_Predictor_WriteFile( &
!                        Filename           , &
!                        NLTE_Predictor     , &
!                        Quiet    = Quiet     )
!
! INPUTS:
!       Filename:       Character string specifying the name of a
!                       NLTE_Predictor format data file to read.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       NLTE_Predictor: NLTE_Predictor object containing the NLTE correction
!                       algorithm predictor data.
!                       UNITS:      N/A
!                       TYPE:       NLTE_Predictor_type
!                       DIMENSION:  Rank-1
!                       ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Quiet:          Set this logical argument to suppress INFORMATION
!                       messages being printed to stdout
!                       If == .FALSE., INFORMATION messages are OUTPUT [DEFAULT].
!                          == .TRUE.,  INFORMATION messages are SUPPRESSED.
!                       If not specified, default is .FALSE.
!                       UNITS:      N/A
!                       TYPE:       LOGICAL
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:   The return value is an integer defining the error status.
!                       The error codes are defined in the Message_Handler module.
!                       If == SUCCESS, the file write was successful
!                          == FAILURE, an unrecoverable error occurred.
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION nlte_predictor_writefile( &
    Filename      , &  ! Input
    NLTE_Predictor, &  ! Input
    Quiet         , &  ! Optional input
    Debug         ) &  ! Optional input (Debug output control)
  result( err_stat )
    ! Arguments
    CHARACTER(*),              INTENT(IN) :: filename
    TYPE(nlte_predictor_type), INTENT(IN) :: nlte_predictor(:)
    LOGICAL,         OPTIONAL, INTENT(IN) :: quiet
    LOGICAL,         OPTIONAL, INTENT(IN) :: debug
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: routine_name = 'NLTE_Predictor_WriteFile'
    ! Function variables
    CHARACTER(ML) :: msg
    LOGICAL :: noisy
    INTEGER :: io_stat
    INTEGER :: fid
    INTEGER :: m, n_output_profiles
    

    ! Setup
    err_stat = success
    ! ...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

   
    ! 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


    ! Write the release and version
    WRITE( fid,iostat=io_stat ) nlte_predictor(1)%Release, nlte_predictor(1)%Version
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error writing Release/Version. IOSTAT = ",i0)' ) io_stat
      CALL write_cleanup(); RETURN
    END IF


    ! Write the dimensions
    n_output_profiles = SIZE(nlte_predictor)
    WRITE( fid, iostat=io_stat ) n_output_profiles
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error writing profile dimension to ",a,". IOSTAT = ",i0)' ) &
             trim(filename), io_stat
      CALL write_cleanup(); RETURN
    END IF
    
    
    ! Loop over all the profiles
    profile_loop: DO m = 1, n_output_profiles

      ! Write the NLTE predictor data
      ! ...Write the dimensions
      WRITE( fid, iostat=io_stat ) &
        nlte_predictor(m)%n_Layers    , &
        nlte_predictor(m)%n_Predictors
      IF ( io_stat /= 0 ) THEN
        WRITE( msg,'("Error writing data dimensions for profile ",i0, &
                    &". IOSTAT = ",i0)' ) m, io_stat
        CALL write_cleanup(); RETURN
      END IF
      ! ...Write the logical indicators
      WRITE( fid, iostat=io_stat ) &
        nlte_predictor(m)%Is_Active , &
        nlte_predictor(m)%Compute_Tm
      IF ( io_stat /= 0 ) THEN
        WRITE( msg,'("Error writing logical indicators for profile ",i0, &
                    &". IOSTAT = ",i0)' ) m, io_stat
        CALL write_cleanup(); RETURN
      END IF
      ! ...Write the array indices
      WRITE( fid, iostat=io_stat ) &
        nlte_predictor(m)%k1, &
        nlte_predictor(m)%k2, &
        nlte_predictor(m)%isen, &
        nlte_predictor(m)%isol
      IF ( io_stat /= 0 ) THEN
        WRITE( msg,'("Error writing array indices for profile ",i0, &
                    &". IOSTAT = ",i0)' ) m, io_stat
        CALL write_cleanup(); RETURN
      END IF
      ! ...Write the predictors and interpolation weights
      WRITE( fid, iostat=io_stat ) &
        nlte_predictor(m)%Tm       , &
        nlte_predictor(m)%Predictor, &
        nlte_predictor(m)%w        
      IF ( io_stat /= 0 ) THEN
        WRITE( msg,'("Error writing predictors and interpolation weights for profile ",i0, &
                    &". IOSTAT = ",i0)' ) m, io_stat
        CALL write_cleanup(); RETURN
      END IF

    END DO profile_loop
    

    ! Close the file
    CLOSE( fid, iostat=io_stat )
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error closing ",a,". IOSTAT = ",i0)' ) trim(filename), io_stat
      CALL write_cleanup(); RETURN
    END IF


    ! Output an info message
    IF ( noisy ) THEN
      WRITE( msg,'("Number of profiles written to ",a,": ",i0)' ) trim(filename), n_output_profiles
      CALL display_message( routine_name, trim(msg), information )
    END IF

   CONTAINS
   
     SUBROUTINE write_cleanup()
       IF ( file_open(filename) ) THEN
         CLOSE( fid, iostat=io_stat, status=write_error_status )
         IF ( io_stat /= 0 ) &
           msg = trim(msg)//'; Error closing output file during error cleanup.'
       END IF
       err_stat = failure
       CALL display_message( routine_name, msg, err_stat )
     END SUBROUTINE write_cleanup

  END FUNCTION nlte_predictor_writefile


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTE_Predictor_IOVersion
!
! PURPOSE:
!       Subroutine to return the module version information.
!
! CALLING SEQUENCE:
!       CALL NLTE_Predictor_IOVersion( Id )
!
! OUTPUT ARGUMENTS:
!       Id:   Character string containing the version Id information
!             for the module.
!             UNITS:      N/A
!             TYPE:       CHARACTER(*)
!             DIMENSION:  Scalar
!             ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE nlte_predictor_ioversion( Id )
    CHARACTER(*), INTENT(OUT) :: id
    id = module_version_id
  END SUBROUTINE nlte_predictor_ioversion
  
END MODULE nlte_predictor_io