<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
!
! LSEatlas_Define
!
! Module defining the LSEatlas object.
!
!
! CREATION HISTORY:
! Written by: Paul van Delst, 17-Aug-2011
! paul.vandelst@noaa.gov
<A NAME='LSEATLAS_DEFINE'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_DEFINE' TARGET='top_target'><IMG SRC="../../gif/bar_purple.gif" border=0></A>
MODULE LSEatlas_Define,7
! -----------------
! Environment setup
! -----------------
! Module use
USE Type_Kinds
, ONLY: fp, Long, Double
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
! Disable implicit typing
IMPLICIT NONE
! ------------
! Visibilities
! ------------
! Everything private by default
PRIVATE
! Parameters
PUBLIC :: LSEATLAS_DATATYPE
! Datatypes
PUBLIC :: LSEatlas_type
! Operators
PUBLIC :: OPERATOR(==)
! Procedures
PUBLIC :: LSEatlas_Associated
PUBLIC :: LSEatlas_Destroy
PUBLIC :: LSEatlas_Create
PUBLIC :: LSEatlas_Inspect
PUBLIC :: LSEatlas_ValidRelease
PUBLIC :: LSEatlas_Info
PUBLIC :: LSEatlas_Name
PUBLIC :: LSEatlas_DefineVersion
PUBLIC :: LSEatlas_SetValue
PUBLIC :: LSEatlas_GetValue
PUBLIC :: LSEatlas_InquireFile
PUBLIC :: LSEatlas_ReadFile
PUBLIC :: LSEatlas_WriteFile
! ---------------------
! Procedure overloading
! ---------------------
<A NAME='OPERATOR'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#OPERATOR' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
INTERFACE OPERATOR(==)
MODULE PROCEDURE
END INTERFACE OPERATOR(==)
! -----------------
! Module parameters
! -----------------
CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
'$Id: LSEatlas_Define.f90 29405 2013-06-20 20:19:52Z paul.vandelst@noaa.gov $'
! Datatype information
CHARACTER(*), PARAMETER :: LSEATLAS_DATATYPE = 'LSEatlas'
! Current valid release and version
INTEGER, PARAMETER :: LSEATLAS_RELEASE = 1 ! This determines structure and file formats.
INTEGER, PARAMETER :: LSEATLAS_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
! ----------------------------------
! LSEatlas data type definitions
! ----------------------------------
!:tdoc+:
TYPE :: LSEatlas_type
PRIVATE
! Allocation indicator
LOGICAL :: Is_Allocated = .FALSE.
! Datatype information
CHARACTER(SL) :: Datatype_Name = LSEATLAS_DATATYPE
! Release and version information
INTEGER(Long) :: Release = LSEATLAS_RELEASE
INTEGER(Long) :: Version = LSEATLAS_VERSION
! Dimensions
INTEGER(Long) :: n_Frequencies = 0 ! I dim.
INTEGER(Long) :: n_Latitudes = 0 ! J dim.
INTEGER(Long) :: n_Longitudes = 0 ! K dim.
! Dimensional vectors
REAL(Double), ALLOCATABLE :: Frequency(:) ! Ix1
REAL(Double), ALLOCATABLE :: Latitude(:) ! Jx1
REAL(Double), ALLOCATABLE :: Longitude(:) ! Kx1
! Emissivity LUT data
REAL(Double), ALLOCATABLE :: Emissivity(:,:,:) ! IxJxK
END TYPE LSEatlas_type
!:tdoc-:
CONTAINS
!################################################################################
!################################################################################
!## ##
!## ## PUBLIC PROCEDURES ## ##
!## ##
!################################################################################
!################################################################################
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_Associated
!
! PURPOSE:
! Elemental function to test the status of the allocatable components
! of the LSEatlas structure.
!
! CALLING SEQUENCE:
! Status = LSEatlas_Associated( LSEatlas )
!
! OBJECTS:
! LSEatlas: Structure which is to have its member's
! status tested.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! Status: The return value is a logical value indicating the
! status of the members.
! .TRUE. - if ANY of the allocatable members
! are in use.
! .FALSE. - if ALL of the allocatable members
! are not in use.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Same as input
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='LSEATLAS_ASSOCIATED'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_ASSOCIATED' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION LSEatlas_Associated( self ) RESULT( Status )
TYPE(LSEatlas_type), INTENT(IN) :: self
LOGICAL :: Status
Status = self%Is_Allocated
END FUNCTION LSEatlas_Associated
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_Destroy
!
! PURPOSE:
! Elemental subroutine to re-initialize LSEatlas objects.
!
! CALLING SEQUENCE:
! CALL LSEatlas_Destroy( LSEatlas )
!
! OBJECTS:
! LSEatlas: Re-initialized LSEatlas structure.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='LSEATLAS_DESTROY'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_DESTROY' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
ELEMENTAL SUBROUTINE LSEatlas_Destroy( self ) 1
TYPE(LSEatlas_type), INTENT(OUT) :: self
self%Is_Allocated = .FALSE.
self%n_Frequencies = 0
self%n_Latitudes = 0
self%n_Longitudes = 0
END SUBROUTINE LSEatlas_Destroy
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_Create
!
! PURPOSE:
! Elemental subroutine to create an instance of an LSEatlas object.
!
! CALLING SEQUENCE:
! CALL LSEatlas_Create( LSEatlas , &
! n_Frequencies, &
! n_Latitudes , &
! n_Longitudes )
!
! OBJECTS:
! LSEatlas: LSEatlas object structure.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
! n_Frequencies: Number of spectral frequencies for which there are
! data.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Conformable with the LSEatlas object
! ATTRIBUTES: INTENT(IN)
!
! n_Latitudes: Number of latitude values for which there are
! data.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Conformable with the LSEatlas object
! ATTRIBUTES: INTENT(IN)
!
! n_Longitudes: Number of longitude values for which there are
! data.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Conformable with the LSEatlas object
! ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='LSEATLAS_CREATE'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_CREATE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
ELEMENTAL SUBROUTINE LSEatlas_Create( & 1
self , & ! Output
n_Frequencies, & ! Input
n_Latitudes , & ! Input
n_Longitudes ) ! Input
! Arguments
TYPE(LSEatlas_type), INTENT(OUT) :: self
INTEGER , INTENT(IN) :: n_Frequencies
INTEGER , INTENT(IN) :: n_Latitudes
INTEGER , INTENT(IN) :: n_Longitudes
! Local variables
INTEGER :: alloc_stat
! Check input
IF ( n_Frequencies < 1 .OR. &
n_Latitudes < 1 .OR. &
n_Longitudes < 1 ) RETURN
! Perform the allocation
ALLOCATE( self%Frequency( n_Frequencies ), &
self%Latitude( n_Latitudes ), &
self%Longitude( n_Longitudes ), &
self%Emissivity( n_Frequencies, n_Latitudes, n_Longitudes ), &
STAT = alloc_stat )
IF ( alloc_stat /= 0 ) RETURN
! Initialise
! ...Dimensions
self%n_Frequencies = n_Frequencies
self%n_Latitudes = n_Latitudes
self%n_Longitudes = n_Longitudes
! ...Arrays
self%Frequency = ZERO
self%Latitude = ZERO
self%Longitude = ZERO
self%Emissivity = ZERO
! Set allocation indicator
self%Is_Allocated = .TRUE.
END SUBROUTINE LSEatlas_Create
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_Inspect
!
! PURPOSE:
! Subroutine to print the contents of a LSEatlas object to stdout.
!
! CALLING SEQUENCE:
! CALL LSEatlas_Inspect( LSEatlas )
!
! OBJECTS:
! LSEatlas: LSEatlas object to display.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='LSEATLAS_INSPECT'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_INSPECT' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE LSEatlas_Inspect( self)
TYPE(LSEatlas_type), INTENT(IN) :: self
WRITE(*,'(1x,"LSEatlas OBJECT")')
! Release/version info
WRITE(*,'(3x,"Release.Version :",1x,i0,".",i0)') self%Release, self%Version
! Dimensions
WRITE(*,'(3x,"n_Frequencies :",1x,i0)') self%n_Frequencies
WRITE(*,'(3x,"n_Latitudes :",1x,i0)') self%n_Latitudes
WRITE(*,'(3x,"n_Longitudes :",1x,i0)') self%n_Longitudes
IF ( .NOT. LSEatlas_Associated(self) ) RETURN
! Dimension arrays
WRITE(*,'(3x,"Frequency :")')
WRITE(*,'(5(1x,es13.6,:))') self%Frequency
WRITE(*,'(3x,"Latitude :")')
WRITE(*,'(5(1x,es13.6,:))') self%Latitude
WRITE(*,'(3x,"Longitude :")')
WRITE(*,'(5(1x,es13.6,:))') self%Longitude
! Emissivity array
WRITE(*,'(3x,"Emissivity :")')
WRITE(*,'(5(1x,es13.6,:))') self%Emissivity
END SUBROUTINE LSEatlas_Inspect
!----------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_ValidRelease
!
! PURPOSE:
! Function to check the LSEatlas Release value.
!
! CALLING SEQUENCE:
! IsValid = LSEatlas_ValidRelease( LSEatlas )
!
! INPUTS:
! LSEatlas: LSEatlas object for which the Release component
! is to be checked.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! IsValid: Logical value defining the release validity.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Scalar
!
!:sdoc-:
!----------------------------------------------------------------------------------
<A NAME='LSEATLAS_VALIDRELEASE'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_VALIDRELEASE' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION LSEatlas_ValidRelease( self ) RESULT( IsValid ),2
! Arguments
TYPE(LSEatlas_type), INTENT(IN) :: self
! Function result
LOGICAL :: IsValid
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'LSEatlas_ValidRelease'
! Local variables
CHARACTER(ML) :: msg
! Set up
IsValid = .TRUE.
! Check release is not too old
IF ( self%Release < LSEatlas_RELEASE ) THEN
IsValid = .FALSE.
WRITE( msg,'("An LSEatlas data update is needed. ", &
&"LSEatlas release is ",i0,". Valid release is ",i0,"." )' ) &
self%Release, LSEATLAS_RELEASE
CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ); RETURN
END IF
! Check release is not too new
IF ( self%Release > LSEatlas_RELEASE ) THEN
IsValid = .FALSE.
WRITE( msg,'("An LSEatlas software update is needed. ", &
&"LSEatlas release is ",i0,". Valid release is ",i0,"." )' ) &
self%Release, LSEATLAS_RELEASE
CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ); RETURN
END IF
END FUNCTION LSEatlas_ValidRelease
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_Info
!
! PURPOSE:
! Subroutine to return a string containing version and dimension
! information about a LSEatlas object.
!
! CALLING SEQUENCE:
! CALL LSEatlas_Info( LSEatlas, Info )
!
! OBJECTS:
! LSEatlas: LSEatlas object about which info is required.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
! Info: String containing version and dimension information
! about the LSEatlas object.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='LSEATLAS_INFO'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_INFO' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE LSEatlas_Info( self, Info ) 2
! Arguments
TYPE(LSEatlas_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,"LSEatlas RELEASE.VERSION: ",i2,".",i2.2,a,3x, &
&"N_FREQUENCIES=",i0,2x,&
&"N_LATITUDES=",i0,2x,&
&"N_LONGITUDES=",i0 )' ) &
ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), &
self%Release, self%Version, &
ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), &
self%n_Frequencies, &
self%n_Latitudes , &
self%n_Longitudes
! Trim the output based on the
! dummy argument string length
Info = Long_String(1:MIN(LEN(Info), LEN_TRIM(Long_String)))
END SUBROUTINE LSEatlas_Info
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_Name
!
! PURPOSE:
! Function to return the datatype name of an LSEatlas object.
!
! CALLING SEQUENCE:
! datatype_name = LSEatlas_Name( LSEatlas )
!
! OBJECTS:
! LSEatlas: LSEatlas object structure.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! Status: The return value is a the character string containing
! the datatype name of the structure.
! UNITS: N/A
! TYPE: CHARACTER
! DIMENSION: Scalar
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='LSEATLAS_NAME'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_NAME' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION LSEatlas_Name( self ) RESULT( datatype_name )
! Arguments
TYPE(LSEatlas_type), INTENT(OUT) :: self
! Function result
CHARACTER(LEN(self%Datatype_Name)) :: datatype_name
datatype_name = self%Datatype_Name
END FUNCTION LSEatlas_Name
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_DefineVersion
!
! PURPOSE:
! Subroutine to return the module version information.
!
! CALLING SEQUENCE:
! CALL LSEatlas_DefineVersion( Id )
!
! OUTPUTS:
! Id: Character string containing the version Id information
! for the module.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='LSEATLAS_DEFINEVERSION'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_DEFINEVERSION' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE LSEatlas_DefineVersion( Id )
CHARACTER(*), INTENT(OUT) :: Id
Id = MODULE_VERSION_ID
END SUBROUTINE LSEatlas_DefineVersion
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_SetValue
!
! PURPOSE:
! Subroutine to set the contents of a valid LSEatlas object.
!
! CALLING SEQUENCE:
! CALL LSEatlas_SetValue( LSEatlas, &
! Version = Version , &
! Frequency = Frequency , &
! Latitude = Latitude , &
! Longitude = Longitude , &
! Emissivity = Emissivity )
!
! OBJECTS:
! LSEatlas: Valid, allocated LSEatlas object for which
! values are to be set.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL INPUTS:
! Version: Integer indicating the data version. If not specified
! the value of the module parameter LSEatlas_VERSION
! is used.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! Frequency: Real array to which the Frequency component of the
! LSEatlas object is to be set. The size of the
! input must match the allocated size of the component,
! otherwise all the component values are set to zero.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Rank-1 (L)
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! Latitude: Real array to which the Latitude component of the
! LSEatlas object is to be set. The size of the
! input must match the allocated size of the component,
! otherwise all the component values are set to zero.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Rank-1 (I)
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! Longitude: Real array to which the Longitude component of the
! LSEatlas object is to be set. The size of the
! input must match the allocated size of the component,
! otherwise all the component values are set to zero.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Rank-1 (J)
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! Emissivity: Real array to which the Emissivity component of the
! LSEatlas object is to be set. The size of the
! input must match the allocated size of the component,
! otherwise all the component values are set to zero.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Rank-3 (L x I x J)
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='LSEATLAS_SETVALUE'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_SETVALUE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE LSEatlas_SetValue( &
self , & ! Input
Version , & ! Optional input
Frequency , & ! Optional input
Latitude , & ! Optional input
Longitude , & ! Optional input
Emissivity ) ! Optional input
! Arguments
TYPE(LSEatlas_type), INTENT(IN OUT) :: self
INTEGER , OPTIONAL, INTENT(IN) :: Version
REAL(fp), OPTIONAL, INTENT(IN) :: Frequency(:)
REAL(fp), OPTIONAL, INTENT(IN) :: Latitude(:)
REAL(fp), OPTIONAL, INTENT(IN) :: Longitude(:)
REAL(fp), OPTIONAL, INTENT(IN) :: Emissivity(:,:,:)
IF ( .NOT. LSEatlas_Associated(self) ) RETURN
IF ( PRESENT(Version) ) self%Version = Version
IF ( PRESENT(Frequency) ) THEN
IF ( SIZE(Frequency) == self%n_Frequencies ) THEN
self%Frequency = Frequency
ELSE
self%Frequency = ZERO
END IF
END IF
IF ( PRESENT(Latitude) ) THEN
IF ( SIZE(Latitude) == self%n_Latitudes ) THEN
self%Latitude = Latitude
ELSE
self%Latitude = ZERO
END IF
END IF
IF ( PRESENT(Longitude) ) THEN
IF ( SIZE(Longitude) == self%n_Longitudes ) THEN
self%Longitude = Longitude
ELSE
self%Longitude = ZERO
END IF
END IF
IF ( PRESENT(Emissivity) ) THEN
IF ( SIZE(Emissivity,DIM=1) == self%n_Frequencies .AND. &
SIZE(Emissivity,DIM=2) == self%n_Latitudes .AND. &
SIZE(Emissivity,DIM=3) == self%n_Longitudes ) THEN
self%Emissivity = Emissivity
ELSE
self%Emissivity = ZERO
END IF
END IF
END SUBROUTINE LSEatlas_SetValue
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_GetValue
!
! PURPOSE:
! Subroutine to get the contents of a valid LSEatlas object.
!
! CALLING SEQUENCE:
! CALL LSEatlas_GetValue( LSEatlas, &
! Version = Version , &
! n_Frequencies = n_Frequencies, &
! n_Latitudes = n_Latitudes , &
! n_Longitudes = n_Longitudes , &
! Frequency = Frequency , &
! Latitude = Latitude , &
! Longitude = Longitude , &
! Emissivity = Emissivity )
!
! OBJECTS:
! LSEatlas: Valid, allocated LSEatlas object from which
! values are to be retrieved.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL OUTPUTS:
! Version: Integer indicating the data version of the object.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! n_Frequencies: Number of spectral frequencies for which there are
! data.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! n_Latitudes: Number of latitude values for which there are
! data.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! n_Longitudes: Number of longitude values for which there are
! data.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! Frequency: Real array to which the Frequency component of the
! LSEatlas object will be assigned. The actual
! argument must be declared as allocatable.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Rank-1 (L)
! ATTRIBUTES: INTENT(OUT), OPTIONAL, ALLOCATABLE
!
! Latitude: Real array to which the Latitude component of the
! LSEatlas object will be assigned. The actual
! argument must be declared as allocatable.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Rank-1 (I)
! ATTRIBUTES: INTENT(OUT), OPTIONAL, ALLOCATABLE
!
! Longitude: Real array to which the Longitude component of the
! LSEatlas object will be assigned. The actual
! argument must be declared as allocatable.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Rank-1 (J)
! ATTRIBUTES: INTENT(OUT), OPTIONAL, ALLOCATABLE
!
! Emissivity: Real array to which the Emissivity component of the
! LSEatlas object will be assigned. The actual
! argument must be declared as allocatable.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Rank-3 (L x I x J)
! ATTRIBUTES: INTENT(OUT), OPTIONAL, ALLOCATABLE
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='LSEATLAS_GETVALUE'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_GETVALUE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE LSEatlas_GetValue( &
self , & ! Input
Version , & ! Optional input
n_Frequencies, & ! Optional output
n_Latitudes , & ! Optional output
n_Longitudes , & ! Optional output
Frequency , & ! Optional output
Latitude , & ! Optional output
Longitude , & ! Optional output
Emissivity ) ! Optional output
! Arguments
TYPE(LSEatlas_type), INTENT(IN) :: self
INTEGER , OPTIONAL, INTENT(OUT) :: Version
INTEGER , OPTIONAL, INTENT(OUT) :: n_Frequencies
INTEGER , OPTIONAL, INTENT(OUT) :: n_Latitudes
INTEGER , OPTIONAL, INTENT(OUT) :: n_Longitudes
REAL(fp), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: Frequency(:)
REAL(fp), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: Latitude(:)
REAL(fp), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: Longitude(:)
REAL(fp), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: Emissivity(:,:,:)
IF ( .NOT. LSEatlas_Associated(self) ) RETURN
IF ( PRESENT(Version ) ) Version = self%Version
IF ( PRESENT(n_Frequencies) ) n_Frequencies = self%n_Frequencies
IF ( PRESENT(n_Latitudes ) ) n_Latitudes = self%n_Latitudes
IF ( PRESENT(n_Longitudes ) ) n_Longitudes = self%n_Longitudes
IF ( PRESENT(Frequency) ) THEN
ALLOCATE(Frequency(self%n_Frequencies))
Frequency = self%Frequency
END IF
IF ( PRESENT(Latitude) ) THEN
ALLOCATE(Latitude(self%n_Latitudes))
Latitude = self%Latitude
END IF
IF ( PRESENT(Longitude) ) THEN
ALLOCATE(Longitude(self%n_Longitudes))
Longitude = self%Longitude
END IF
IF ( PRESENT(Emissivity) ) THEN
ALLOCATE(Emissivity(self%n_Frequencies,self%n_Latitudes,self%n_Longitudes))
Emissivity = self%Emissivity
END IF
END SUBROUTINE LSEatlas_GetValue
!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_InquireFile
!
! PURPOSE:
! Function to inquire LSEatlas object files.
!
! CALLING SEQUENCE:
! Error_Status = LSEatlas_InquireFile( &
! Filename , &
! n_Frequencies = n_Frequencies, &
! n_Latitudes = n_Latitudes , &
! n_Longitudes = n_Longitudes , &
! Release = Release , &
! Version = Version )
!
! INPUTS:
! Filename: Character string specifying the name of the
! data file to inquire.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OPTIONAL OUTPUTS:
! n_Frequencies: Number of spectral frequencies for which there are
! data.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! n_Latitudes: Number of latitude values for which there are
! data.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! n_Longitudes: Number of longitude values for which there are
! data.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! 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-:
!------------------------------------------------------------------------------
<A NAME='LSEATLAS_INQUIREFILE'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_INQUIREFILE' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION LSEatlas_InquireFile( &,12
Filename , & ! Input
n_Frequencies, & ! Optional output
n_Latitudes , & ! Optional output
n_Longitudes , & ! 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_Frequencies
INTEGER , OPTIONAL, INTENT(OUT) :: n_Latitudes
INTEGER , OPTIONAL, INTENT(OUT) :: n_Longitudes
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 = 'LSEatlas_InquireFile'
! Function variables
CHARACTER(ML) :: msg
CHARACTER(ML) :: io_msg
INTEGER :: io_stat
INTEGER :: fid
TYPE(LSEatlas_type) :: LSEatlas
! 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 and check the datatype name
err_stat = Read_Datatype( fid, LSEatlas%Datatype_name )
IF ( err_stat /= SUCCESS ) THEN
msg = 'Error reading Datatype_Name'
CALL Inquire_Cleanup(); RETURN
END IF
IF ( TRIM(LSEatlas%Datatype_Name) /= LSEATLAS_DATATYPE ) THEN
msg = LSEATLAS_DATATYPE//' datatype name check failed.'
CALL Inquire_Cleanup(); RETURN
END IF
! Read the release and version
READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
LSEatlas%Release, &
LSEatlas%Version
IF ( io_stat /= 0 ) THEN
msg = 'Error reading Release/Version - '//TRIM(io_msg)
CALL Inquire_Cleanup(); RETURN
END IF
IF ( .NOT. LSEatlas_ValidRelease( LSEatlas ) ) THEN
msg = 'LSEatlas Release check failed.'
CALL Inquire_Cleanup(); RETURN
END IF
! Read the dimensions
READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
LSEatlas%n_Frequencies, &
LSEatlas%n_Latitudes , &
LSEatlas%n_Longitudes
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_Frequencies) ) n_Frequencies = LSEatlas%n_Frequencies
IF ( PRESENT(n_Latitudes ) ) n_Latitudes = LSEatlas%n_Latitudes
IF ( PRESENT(n_Longitudes ) ) n_Longitudes = LSEatlas%n_Longitudes
IF ( PRESENT(Release ) ) Release = LSEatlas%Release
IF ( PRESENT(Version ) ) Version = LSEatlas%Version
CONTAINS
<A NAME='INQUIRE_CLEANUP'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#INQUIRE_CLEANUP' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Inquire_CleanUp() 158,27
! 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 LSEatlas_InquireFile
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_ReadFile
!
! PURPOSE:
! Function to read LSEatlas object files.
!
! CALLING SEQUENCE:
! Error_Status = LSEatlas_ReadFile( &
! LSEatlas , &
! Filename , &
! No_Close = No_Close, &
! Quiet = Quiet )
!
! OBJECTS:
! LSEatlas: LSEatlas object containing the data read from file.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
! Filename: Character string specifying the name of a
! LSEatlas data file to read.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
! No_Close: Set this logical argument to *NOT* close the datafile
! upon exiting this routine. This option is required if
! the LSEatlas data is embedded within another file.
! If == .FALSE., File is closed upon function exit [DEFAULT].
! == .TRUE., File is NOT closed upon function exit
! If not specified, default is .FALSE.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! 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 read was successful
! == FAILURE, an unrecoverable error occurred.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------
<A NAME='LSEATLAS_READFILE'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_READFILE' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION LSEatlas_ReadFile( &,19
LSEatlas, & ! 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(LSEatlas_type) , INTENT(OUT) :: LSEatlas
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 = 'LSEatlas_ReadFile'
! Function variables
CHARACTER(ML) :: msg
CHARACTER(ML) :: io_msg
LOGICAL :: close_file
LOGICAL :: noisy
INTEGER :: io_stat
INTEGER :: fid
TYPE(LSEatlas_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 datatype name
err_stat = Read_Datatype( fid, dummy%Datatype_name )
IF ( err_stat /= SUCCESS ) THEN
msg = 'Error reading Datatype_Name'
CALL Read_Cleanup(); RETURN
END IF
IF ( TRIM(dummy%Datatype_Name) /= LSEATLAS_DATATYPE ) THEN
msg = LSEATLAS_DATATYPE//' datatype name check failed.'
CALL Read_Cleanup(); RETURN
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. LSEatlas_ValidRelease( dummy ) ) THEN
msg = 'LSEatlas Release check failed.'
CALL Read_Cleanup(); RETURN
END IF
! Read the dimensions
READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
dummy%n_Frequencies, &
dummy%n_Latitudes , &
dummy%n_Longitudes
IF ( io_stat /= 0 ) THEN
msg = 'Error reading data dimensions - '//TRIM(io_msg)
CALL Read_Cleanup(); RETURN
END IF
! ...Allocate the object
CALL LSEatlas_Create( &
LSEatlas , &
dummy%n_Frequencies, &
dummy%n_Latitudes , &
dummy%n_Longitudes )
IF ( .NOT. LSEatlas_Associated( LSEatlas ) ) THEN
msg = 'LSEatlas object allocation failed.'
CALL Read_Cleanup(); RETURN
END IF
! ...Explicitly assign the version number
LSEatlas%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 coefficient data
! ...Read the dimensional vectors
READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
LSEatlas%Frequency, &
LSEatlas%Latitude , &
LSEatlas%Longitude
IF ( io_stat /= 0 ) THEN
msg = 'Error reading dimensional vectors - '//TRIM(io_msg)
CALL Read_Cleanup(); RETURN
END IF
! ...Read the emissivity data
READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
LSEatlas%Emissivity
IF ( io_stat /= 0 ) THEN
msg = 'Error reading emissivity data - '//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 LSEatlas_Info( LSEatlas, msg )
CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION )
END IF
CONTAINS
<A NAME='READ_CLEANUP'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#READ_CLEANUP' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Read_CleanUp() 334,61
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 LSEatlas_Destroy( LSEatlas )
err_stat = FAILURE
CALL Display_Message( ROUTINE_NAME, msg, err_stat )
END SUBROUTINE Read_CleanUp
END FUNCTION LSEatlas_ReadFile
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! LSEatlas_WriteFile
!
! PURPOSE:
! Function to write LSEatlas object files.
!
! CALLING SEQUENCE:
! Error_Status = LSEatlas_WriteFile( &
! LSEatlas , &
! Filename , &
! No_Close = No_Close, &
! Quiet = Quiet )
!
! OBJECTS:
! LSEatlas: LSEatlas object containing the data to write to file.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! INPUTS:
! Filename: Character string specifying the name of a
! LSEatlas format data file to write.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
! No_Close: Set this logical argument to *NOT* close the datafile
! upon exiting this routine. This option is required if
! the LSEatlas data is to be embedded within another file.
! If == .FALSE., File is closed upon function exit [DEFAULT].
! == .TRUE., File is NOT closed upon function exit
! If not specified, default is .FALSE.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! 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-:
!------------------------------------------------------------------------------
<A NAME='LSEATLAS_WRITEFILE'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_WRITEFILE' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION LSEatlas_WriteFile( &,15
LSEatlas, & ! 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(LSEatlas_type), INTENT(IN) :: LSEatlas
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 = 'LSEatlas_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. LSEatlas_Associated( LSEatlas ) ) THEN
msg = 'LSEatlas 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 datatype name
WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
LEN(LSEatlas%Datatype_Name)
IF ( io_stat /= 0 ) THEN
msg = 'Error writing Datatype_Name length - '//TRIM(io_msg)
CALL Write_Cleanup(); RETURN
END IF
WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
LSEatlas%Datatype_Name
IF ( io_stat /= 0 ) THEN
msg = 'Error writing Datatype_Name - '//TRIM(io_msg)
CALL Write_Cleanup(); RETURN
END IF
! Write the release and version
WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
LSEatlas%Release, &
LSEatlas%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 ) &
LSEatlas%n_Frequencies, &
LSEatlas%n_Latitudes , &
LSEatlas%n_Longitudes
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 coefficient data
! ...Write the dimensional vectors
WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
LSEatlas%Frequency, &
LSEatlas%Latitude , &
LSEatlas%Longitude
IF ( io_stat /= 0 ) THEN
msg = 'Error writing dimensional vectors - '//TRIM(io_msg)
CALL Write_Cleanup(); RETURN
END IF
! ...Write the emissivity data
WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
LSEatlas%Emissivity
IF ( io_stat /= 0 ) THEN
msg = 'Error writing emissivity data - '//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 LSEatlas_Info( LSEatlas, msg )
CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION )
END IF
CONTAINS
<A NAME='WRITE_CLEANUP'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#WRITE_CLEANUP' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Write_Cleanup() 283,32
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 LSEatlas_WriteFile
!################################################################################
!################################################################################
!## ##
!## ## PRIVATE PROCEDURES ## ##
!## ##
!################################################################################
!################################################################################
!--------------------------------------------------------------------------------
!
! NAME:
! LSEatlas_Equal
!
! PURPOSE:
! Elemental function to test the equality of two LSEatlas objects.
! Used in OPERATOR(==) interface block.
!
! CALLING SEQUENCE:
! is_equal = LSEatlas_Equal( x, y )
!
! or
!
! IF ( x == y ) THEN
! ...
! END IF
!
! OBJECTS:
! x, y: Two LSEatlas objects to be compared.
! UNITS: N/A
! TYPE: LSEatlas_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! is_equal: Logical value indicating whether the inputs are equal.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Same as inputs.
!
!--------------------------------------------------------------------------------
<A NAME='LSEATLAS_EQUAL'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#LSEATLAS_EQUAL' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION LSEatlas_Equal( x, y ) RESULT( is_equal ) 1
TYPE(LSEatlas_type), INTENT(IN) :: x, y
LOGICAL :: is_equal
! Set up
is_equal = .FALSE.
! Check the object association status
IF ( (.NOT. LSEatlas_Associated(x)) .OR. &
(.NOT. LSEatlas_Associated(y)) ) RETURN
! Check contents
! ...Release/version info
IF ( (x%Release /= y%Release) .OR. &
(x%Version /= y%Version) ) RETURN
! ...Dimensions
IF ( (x%n_Frequencies /= y%n_Frequencies ) .OR. &
(x%n_Latitudes /= y%n_Latitudes ) .OR. &
(x%n_Longitudes /= y%n_Longitudes ) ) RETURN
! ...Arrays
IF ( ALL(x%Frequency .EqualTo. y%Frequency ) .AND. &
ALL(x%Latitude .EqualTo. y%Latitude ) .AND. &
ALL(x%Longitude .EqualTo. y%Longitude ) .AND. &
ALL(x%Emissivity .EqualTo. y%Emissivity ) ) &
is_equal = .TRUE.
END FUNCTION LSEatlas_Equal
<A NAME='READ_DATATYPE'><A href='../../html_code/crtm/LSEatlas_Define.f90.html#READ_DATATYPE' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION Read_Datatype( fid, datatype_name ) RESULT( err_stat ) 4
! Arguments
INTEGER , INTENT(IN) :: fid
CHARACTER(*), INTENT(OUT) :: datatype_name
! Function result
INTEGER :: err_stat
! Local variables
CHARACTER(1), ALLOCATABLE :: dummy(:)
INTEGER :: i, strlen
INTEGER :: io_stat
INTEGER :: alloc_stat
! Set up
err_stat = FAILURE
datatype_name = ''
! Get the string length
READ( fid, IOSTAT=io_stat ) strlen
IF ( io_stat /= 0 ) RETURN
! Allocate dummy string array
ALLOCATE( dummy(strlen), STAT=alloc_stat )
IF ( alloc_stat /= 0 ) RETURN
! Read the string into the dummy array
READ( fid, IOSTAT=io_stat ) dummy
IF ( io_stat /= 0 ) RETURN
! Transfer array into string
DO i = 1, MIN(strlen,LEN(datatype_name))
datatype_name(i:i) = dummy(i)
END DO
! Done
err_stat = SUCCESS
END FUNCTION Read_Datatype
END MODULE LSEatlas_Define