! ! 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 99117 2017-11-27 18:37:14Z tong.zhu@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