! ! CRTM_Options_Define ! ! Module defining the CRTM Options optional argument data structure ! and containing routines to manipulate it. ! ! ! CREATION HISTORY: ! Written by: Paul van Delst, 25-Sep-2004 ! paul.vandelst@noaa.gov ! MODULE CRTM_Options_Define ! ------------------ ! Environment set up ! ------------------ ! Module use statements USE Type_Kinds , ONLY: fp, Long, Double USE Message_Handler , ONLY: SUCCESS, FAILURE, WARNING, 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 , & WriteLogical_Binary_File, & ReadLogical_Binary_File USE CRTM_Parameters , ONLY: RT_ADA, RT_SOI, & MAX_N_STREAMS USE SSU_Input_Define , ONLY: SSU_Input_type, & OPERATOR(==), & SSU_Input_IsValid, & SSU_Input_Inspect, & SSU_Input_GetValue, & SSU_Input_SetValue, & SSU_Input_ReadFile, & SSU_Input_WriteFile USE Zeeman_Input_Define , ONLY: Zeeman_Input_type, & OPERATOR(==), & Zeeman_Input_IsValid, & Zeeman_Input_Inspect, & Zeeman_Input_GetValue, & Zeeman_Input_SetValue, & Zeeman_Input_ReadFile, & Zeeman_Input_WriteFile USE CRTM_CloudCover_Define, ONLY: DEFAULT_OVERLAP_ID, & CloudCover_Maximum_Overlap, & CloudCover_Random_Overlap , & CloudCover_MaxRan_Overlap , & CloudCover_Average_Overlap, & CloudCover_Overcast_Overlap, & CloudCover_Overlap_IsValid, & CloudCover_Overlap_Name ! Disable implicit typing IMPLICIT NONE ! ------------ ! Visibilities ! ------------ ! Everything private by default PRIVATE ! Datatypes PUBLIC :: CRTM_Options_type ! ...Inherited types PUBLIC :: SSU_Input_type PUBLIC :: Zeeman_Input_type ! Operators PUBLIC :: OPERATOR(==) ! Public procedures PUBLIC :: CRTM_Options_Associated PUBLIC :: CRTM_Options_Destroy PUBLIC :: CRTM_Options_Create PUBLIC :: CRTM_Options_IsValid PUBLIC :: CRTM_Options_Inspect PUBLIC :: CRTM_Options_DefineVersion PUBLIC :: CRTM_Options_SetValue PUBLIC :: CRTM_Options_SetEmissivity PUBLIC :: CRTM_Options_InquireFile PUBLIC :: CRTM_Options_ReadFile PUBLIC :: CRTM_Options_WriteFile ! ...Inherited procedures PUBLIC :: SSU_Input_GetValue PUBLIC :: SSU_Input_SetValue PUBLIC :: Zeeman_Input_GetValue PUBLIC :: Zeeman_Input_SetValue ! ------------------- ! Procedure overloads ! ------------------- INTERFACE CRTM_Options_SetEmissivity MODULE PROCEDURE SetEmissivity_scalar MODULE PROCEDURE SetEmissivity_rank1 END INTERFACE CRTM_Options_SetEmissivity INTERFACE OPERATOR(==) MODULE PROCEDURE CRTM_Options_Equal END INTERFACE OPERATOR(==) ! ----------------- ! Module parameters ! ----------------- CHARACTER(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = & '$Id: CRTM_Options_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(Double), PARAMETER :: ZERO = 0.0_Double REAL(Double), PARAMETER :: ONE = 1.0_Double ! Integer "logicals" for I/O INTEGER(Long), PARAMETER :: FALSE = 0_Long INTEGER(Long), PARAMETER :: TRUE = 1_Long ! Message string length INTEGER, PARAMETER :: ML = 256 ! File status on close after write error CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE' ! ---------------------------- ! Options data type definition ! ---------------------------- !:tdoc+: TYPE :: CRTM_Options_type ! Allocation indicator LOGICAL :: Is_Allocated = .FALSE. ! Input checking on by default LOGICAL :: Check_Input = .TRUE. ! User defined MW water emissivity algorithm LOGICAL :: Use_Old_MWSSEM = .FALSE. ! Antenna correction application LOGICAL :: Use_Antenna_Correction = .FALSE. ! NLTE radiance correction is ON by default LOGICAL :: Apply_NLTE_Correction = .TRUE. ! RT Algorithm is set to ADA by default INTEGER(Long) :: RT_Algorithm_Id = RT_ADA ! Aircraft flight level pressure ! Value > 0 turns "on" the aircraft option REAL(Double) :: Aircraft_Pressure = -ONE ! User defined number of RT solver streams (streams up + streams down) LOGICAL :: Use_n_Streams = .FALSE. INTEGER(Long) :: n_Streams = 0 ! Scattering switch. Default is for ! Cloud/Aerosol scattering to be included. LOGICAL :: Include_Scattering = .TRUE. ! Cloud cover overlap id is set to averaging type by default INTEGER(Long) :: Overlap_Id = DEFAULT_OVERLAP_ID ! User defined emissivity/reflectivity ! ...Dimensions INTEGER(Long) :: n_Channels = 0 ! L dimension ! ...Index into channel-specific components INTEGER(Long) :: Channel = 0 ! ...Emissivity optional arguments LOGICAL :: Use_Emissivity = .FALSE. REAL(Double), ALLOCATABLE :: Emissivity(:) ! L ! ...Direct reflectivity optional arguments LOGICAL :: Use_Direct_Reflectivity = .FALSE. REAL(Double), ALLOCATABLE :: Direct_Reflectivity(:) ! L ! SSU instrument input TYPE(SSU_Input_type) :: SSU ! Zeeman-splitting input TYPE(Zeeman_Input_type) :: Zeeman END TYPE CRTM_Options_type !:tdoc-: CONTAINS !################################################################################ !################################################################################ !## ## !## ## PUBLIC MODULE ROUTINES ## ## !## ## !################################################################################ !################################################################################ !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Options_SetValue ! ! PURPOSE: ! Elemental subroutine to set the values of the non-dimensional, ! non-contained-object CRTM_Options object components. ! ! CALLING SEQUENCE: ! CALL CRTM_Options_SetValue( & ! Options , & ! Check_Input = Check_Input , & ! Use_Old_MWSSEM = Use_Old_MWSSEM , & ! Use_Antenna_Correction = Use_Antenna_Correction , & ! Apply_NLTE_Correction = Apply_NLTE_Correction , & ! Set_ADA_RT = Set_ADA_RT , & ! Set_SOI_RT = Set_SOI_RT , & ! Include_Scattering = Include_Scattering , & ! Set_Maximum_Overlap = Set_Maximum_Overlap , & ! Set_Random_Overlap = Set_Random_Overlap , & ! Set_MaxRan_Overlap = Set_MaxRan_Overlap , & ! Set_Average_Overlap = Set_Average_Overlap , & ! Set_Overcast_Overlap = Set_Overcast_Overlap , & ! Use_Emissivity = Use_Emissivity , & ! Use_Direct_Reflectivity = Use_Direct_Reflectivity, & ! n_Streams = n_Streams , & ! Aircraft_Pressure = Aircraft_Pressure ) ! ! OBJECTS: ! Options: Options object for which the indicated component ! values are to be set. ! UNITS: N/A ! TYPE: CRTM_Options_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(IN OUT) ! ! OPTIONAL INPUTS: ! Check_Input: Set this logical argument to control checking of ! the CRTM input data. ! If == .TRUE. , the CRTM input data is checked [DEFAULT] ! == .FALSE., no input data checking is done. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Conformable with Options object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! ! Use_Old_MWSSEM: Set this logical argument to invoke the previous version ! of the microwave sea surface emissivity model. ! If == .TRUE. , the old model is used. ! == .FALSE., the current model is used [DEFAULT] ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Conformable with Options object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! ! Use_Antenna_Correction: Set this logical argument to apply an antenna correction ! to the computed brightness temperatures for certain ! microwave instruments (AMSU-A/B, MHS) ! If == .TRUE. , antenna correction is applied ! == .FALSE., no correction is applied [DEFAULT] ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Conformable with Options object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! ! Apply_NLTE_Correction: Set this logical argument to apply an non-LTE correction ! to shortwave infrared radiances. ! If == .TRUE. , non-LTE correction is applied [DEFAULT] ! == .FALSE., no correction is applied ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Conformable with Options object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! ! Set_ADA_RT: ! Set_SOI_RT: Set this logical argument to use the specified algorithm ! for scattering radiative transfer. ! If == .TRUE. , the corresponding RT algorithm is used. ! Note: - By default, the ADA algorithm is used. ! - If MORE THAN ONE argument is specified, the ! the default ADA algorithm is used. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Conformable with Options object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! ! Include_Scattering: Set this logical argument to control the inclusion of ! cloud and aerosol scattering in the radiative transfer. ! If == .TRUE. , scattering calculations are performed [DEFAULT] ! == .FALSE., only cloud/aerosol absorption is considered. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Conformable with Options object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! ! Set_Maximum_Overlap: ! Set_Random_Overlap: ! Set_MaxRan_Overlap: ! Set_Average_Overlap: Use these logical arguments to set the cloud overlap ! methodology for fractionally cloudy input profiles. ! If == .TRUE. , the corresponding overlap method is used. ! Note: - By default, the average overlap method is used. ! - If MORE THAN ONE overlap argument is specified, ! the default overlap method is used. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Conformable with Options object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! ! Use_Emissivity: Set this logical argument to control the use of the emissivity ! spectrum included in the object. ! If == .TRUE. , use the included emissivity spectrum ! == .FALSE., let the CRTM compute the emissivity spectrum ! Note: - This argument is ignored if the object does not ! contain any emissivity data ! - See the CRTM_Options_SetEmissivity() procedure for ! loading emissivity data into an Options object. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Conformable with Options object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! ! Use_Direct_Reflectivity: Set this logical argument to control the use of the direct ! reflectivity spectrum included in the object. ! If == .TRUE. , use the included direct reflectivity spectrum ! == .FALSE., let the CRTM compute the direct reflectivity spectrum ! Note: - This argument is ignored if the object does not ! contain any direct reflectivity data ! - See the CRTM_Options_SetEmissivity() procedure for ! loading direct relfectivity data into an Options object. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Conformable with Options object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! ! n_Streams: Set this integer argument to the number of streams (up + down) ! to use in the radiative transfer solver for scattering ! atmospheres. ! By default, a channel-specific value is selected based ! on the Mie parameter. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Conformable with Options object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! ! Aircraft_Pressure: Set this real argument to aircraft pressure level to use ! for an aircraft instrument simulation. ! Note: This option has not been rigorously tested. ! UNITS: hPa ! TYPE: REAL(fp) ! DIMENSION: Conformable with Options object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL SUBROUTINE CRTM_Options_SetValue( & self , & Check_Input , & Use_Old_MWSSEM , & Use_Antenna_Correction , & Apply_NLTE_Correction , & Set_ADA_RT , & Set_SOI_RT , & Include_Scattering , & Set_Maximum_Overlap , & Set_Random_Overlap , & Set_MaxRan_Overlap , & Set_Average_Overlap , & Set_Overcast_Overlap , & Use_Emissivity , & Use_Direct_Reflectivity, & n_Streams , & Aircraft_Pressure ) ! Arguments TYPE(CRTM_Options_type), INTENT(IN OUT) :: self LOGICAL , OPTIONAL, INTENT(IN) :: Check_Input LOGICAL , OPTIONAL, INTENT(IN) :: Use_Old_MWSSEM LOGICAL , OPTIONAL, INTENT(IN) :: Use_Antenna_Correction LOGICAL , OPTIONAL, INTENT(IN) :: Apply_NLTE_Correction LOGICAL , OPTIONAL, INTENT(IN) :: Set_ADA_RT LOGICAL , OPTIONAL, INTENT(IN) :: Set_SOI_RT LOGICAL , OPTIONAL, INTENT(IN) :: Include_Scattering LOGICAL , OPTIONAL, INTENT(IN) :: Set_Maximum_Overlap LOGICAL , OPTIONAL, INTENT(IN) :: Set_Random_Overlap LOGICAL , OPTIONAL, INTENT(IN) :: Set_MaxRan_Overlap LOGICAL , OPTIONAL, INTENT(IN) :: Set_Average_Overlap LOGICAL , OPTIONAL, INTENT(IN) :: Set_Overcast_Overlap LOGICAL , OPTIONAL, INTENT(IN) :: Use_Emissivity LOGICAL , OPTIONAL, INTENT(IN) :: Use_Direct_Reflectivity INTEGER , OPTIONAL, INTENT(IN) :: n_Streams REAL(fp), OPTIONAL, INTENT(IN) :: Aircraft_Pressure ! Set the "direct copy" components IF ( PRESENT(Check_Input ) ) self%Check_Input = Check_Input IF ( PRESENT(Use_Old_MWSSEM ) ) self%Use_Old_MWSSEM = Use_Old_MWSSEM IF ( PRESENT(Use_Antenna_Correction) ) self%Use_Antenna_Correction = Use_Antenna_Correction IF ( PRESENT(Apply_NLTE_Correction ) ) self%Apply_NLTE_Correction = Apply_NLTE_Correction IF ( PRESENT(Include_Scattering ) ) self%Include_Scattering = Include_Scattering IF ( PRESENT(Aircraft_Pressure ) ) self%Aircraft_Pressure = Aircraft_Pressure ! Set the "minimal processing" components IF ( PRESENT(n_Streams) ) THEN self%Use_n_Streams = .TRUE. self%n_Streams = n_Streams END IF ! Only one RT algorithm allowed! IF ( COUNT([PRESENT(Set_ADA_RT), PRESENT(Set_SOI_RT)]) > 1 ) THEN self%RT_Algorithm_Id = RT_ADA ELSE IF ( PRESENT(Set_ADA_RT) ) self%RT_Algorithm_Id = RT_ADA IF ( PRESENT(Set_SOI_RT) ) self%RT_Algorithm_Id = RT_SOI END IF ! Only one overlap option allowed! IF ( COUNT([PRESENT(Set_Maximum_Overlap), PRESENT(Set_Random_Overlap ), & PRESENT(Set_MaxRan_Overlap ), PRESENT(Set_Average_Overlap), & PRESENT(Set_Overcast_Overlap) ]) > 1 ) THEN self%Overlap_Id = DEFAULT_OVERLAP_ID ELSE IF ( PRESENT(Set_Maximum_Overlap) ) self%Overlap_Id = CloudCover_Maximum_Overlap() IF ( PRESENT(Set_Random_Overlap ) ) self%Overlap_Id = CloudCover_Random_Overlap() IF ( PRESENT(Set_MaxRan_Overlap ) ) self%Overlap_Id = CloudCover_MaxRan_Overlap() IF ( PRESENT(Set_Average_Overlap) ) self%Overlap_Id = CloudCover_Average_Overlap() IF ( PRESENT(Set_Overcast_Overlap)) self%Overlap_Id = CloudCover_Overcast_Overlap() END IF ! The emissivity and reflectivity spectra IF ( PRESENT(Use_Emissivity) ) & self%Use_Emissivity = Use_Emissivity .AND. self%Is_Allocated IF ( PRESENT(Use_Direct_Reflectivity) ) & self%Use_Direct_Reflectivity = Use_Direct_Reflectivity .AND. self%Is_Allocated END SUBROUTINE CRTM_Options_SetValue !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Options_SetEmissivity ! ! PURPOSE: ! Subroutine to set the values of the emissivity and direct reflectivity ! spectra in a CRTM_Options object. ! ! This procedure also sets the usage flags for the emissivity and direct ! reflectivity after successful assignment. See also the CRTM_Options_SetValue() ! procedure. ! ! CALLING SEQUENCE: ! CALL CRTM_Options_SetEmissivity( & ! Options , & ! Emissivity , & ! Direct_Reflectivity = Direct_Reflectivity ) ! ! OBJECTS: ! Options: Options object for which the emissivity and ! direct reflectivity are to be set. ! values are to be set. ! UNITS: N/A ! TYPE: CRTM_Options_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN OUT) ! ! INPUTS: ! Emissivity: Emissivity scalar value or spectrum array. ! If SCALAR: - The Options object MUST already be allocated. ! - The scalar value is applied to every element ! of the object emissivity array. ! RANK-1: - The object emissivity array is (re)allocated ! as necessary. ! UNITS: N/A ! TYPE: REAL(fp) ! DIMENSION: Scalar or Rank-1 ! ATTRIBUTES: INTENT(IN) ! ! OPTIONAL INPUTS: ! Direct_Reflectivity: Direct reflectivity scalar value or spectrum array. ! If SCALAR: - The Options object MUST already be allocated. ! - The scalar value is applied to every element ! of the object direct reflectivity array. ! RANK-1: - The array size must be the same as the ! input emissivity array. If not, the ! object direct reflectivity array is ! (re)allocated and set to zero. ! UNITS: N/A ! TYPE: REAL(fp) ! DIMENSION: Same as Emissivity argument ! ATTRIBUTES: INTENT(IN), OPTIONAL ! !:sdoc-: !-------------------------------------------------------------------------------- SUBROUTINE SetEmissivity_scalar( & self , & Emissivity, & Direct_Reflectivity) ! Arguments TYPE(CRTM_Options_type), INTENT(IN OUT) :: self REAL(fp), INTENT(IN) :: Emissivity REAL(fp), OPTIONAL, INTENT(IN) :: Direct_Reflectivity ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Options_SetEmissivity(Scalar)' ! Local variables CHARACTER(ML) :: msg ! Setup self%Use_Emissivity = .FALSE. ! Turn it off self%Use_Direct_Reflectivity = .FALSE. ! Turn it off IF ( .NOT. CRTM_Options_Associated(self) ) THEN msg = 'Options object not allocated. Disabling emissivity/direct reflectivity' CALL Display_Message( ROUTINE_NAME, msg, FAILURE ) RETURN END IF ! Assign the emissivity self%Emissivity = Emissivity self%Use_Emissivity = .TRUE. ! Assign the direct reflectivity if supplied IF ( PRESENT(Direct_Reflectivity) ) THEN self%Direct_Reflectivity = Direct_Reflectivity self%Use_Direct_Reflectivity = .TRUE. END IF END SUBROUTINE SetEmissivity_scalar SUBROUTINE SetEmissivity_rank1( & self , & Emissivity, & Direct_Reflectivity) ! Arguments TYPE(CRTM_Options_type), INTENT(IN OUT) :: self REAL(fp), INTENT(IN) :: Emissivity(:) REAL(fp), OPTIONAL, INTENT(IN) :: Direct_Reflectivity(:) ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Options_SetEmissivity(Rank-1)' ! Local variables CHARACTER(ML) :: msg INTEGER :: i ! Setup self%Use_Direct_Reflectivity = .FALSE. ! Turn it off ! Assign the emissivity self%Emissivity = Emissivity ! Auto (re)allocation self%Use_Emissivity = .TRUE. self%n_Channels = SIZE(Emissivity) ! Assign the direct reflectivity if supplied IF ( PRESENT(Direct_Reflectivity) ) THEN IF ( SIZE(Direct_Reflectivity) == self%n_Channels ) THEN self%Direct_Reflectivity = Direct_Reflectivity ! Auto (re)allocation self%Use_Direct_Reflectivity = .TRUE. ELSE msg = 'Size of Direct_Reflectivity argument different from Emissivity. Disabling' CALL Display_Message( ROUTINE_NAME, msg, WARNING ) self%Direct_Reflectivity = [(ZERO,i=1,self%n_Channels)] ! Auto (re)allocation self%Use_Direct_Reflectivity = .FALSE. END IF END IF ! Set the allocation flag self%Is_Allocated = ALLOCATED(self%Emissivity) .AND. ALLOCATED(self%Direct_Reflectivity) END SUBROUTINE SetEmissivity_rank1 !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Options_Associated ! ! PURPOSE: ! Elemental function to test the status of the allocatable components ! of a CRTM Options object. ! ! CALLING SEQUENCE: ! Status = CRTM_Options_Associated( Options ) ! ! OBJECTS: ! Options: Options structure which is to have its member's ! status tested. ! UNITS: N/A ! TYPE: CRTM_Options_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(IN) ! ! FUNCTION RESULT: ! Status: The return value is a logical value indicating the ! status of the Options members. ! .TRUE. - if the array components are allocated. ! .FALSE. - if the array components are not allocated. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Same as input Options argument ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL FUNCTION CRTM_Options_Associated( self ) RESULT( Status ) TYPE(CRTM_Options_type), INTENT(IN) :: self LOGICAL :: Status Status = self%Is_Allocated END FUNCTION CRTM_Options_Associated !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Options_Destroy ! ! PURPOSE: ! Elemental subroutine to re-initialize CRTM Options objects. ! ! CALLING SEQUENCE: ! CALL CRTM_Options_Destroy( Options ) ! ! OBJECTS: ! Options: Re-initialized Options structure. ! UNITS: N/A ! TYPE: CRTM_Options_type ! DIMENSION: Scalar OR any rank ! ATTRIBUTES: INTENT(OUT) ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL SUBROUTINE CRTM_Options_Destroy( self ) TYPE(CRTM_Options_type), INTENT(OUT) :: self self%Is_Allocated = .FALSE. END SUBROUTINE CRTM_Options_Destroy !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Options_Create ! ! PURPOSE: ! Elemental subroutine to create an instance of the CRTM Options object. ! ! CALLING SEQUENCE: ! CALL CRTM_Options_Create( Options, n_Channels ) ! ! OBJECTS: ! Options: Options structure. ! UNITS: N/A ! TYPE: CRTM_Options_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(OUT) ! ! INPUTS: ! n_Channels: Number of channels for which there is Options data. ! Must be > 0. ! This dimension only applies to the emissivity-related ! components. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Same as Options object ! ATTRIBUTES: INTENT(IN) ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL SUBROUTINE CRTM_Options_Create( self, n_Channels ) ! Arguments TYPE(CRTM_Options_type), INTENT(OUT) :: self INTEGER, INTENT(IN) :: n_Channels ! Local variables INTEGER :: alloc_stat ! Check input IF ( n_Channels < 1 ) RETURN ! Perform the allocation ALLOCATE( self%Emissivity(n_Channels), & self%Direct_Reflectivity(n_Channels), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN ! Initialise ! ...Dimensions self%n_Channels = n_Channels ! ...Arrays self%Emissivity = ZERO self%Direct_Reflectivity = ZERO ! Set allocation indicator self%Is_Allocated = .TRUE. END SUBROUTINE CRTM_Options_Create !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Options_IsValid ! ! PURPOSE: ! Non-pure function to perform some simple validity checks on a ! CRTM Options object. ! ! If invalid data is found, a message is printed to stdout. ! ! CALLING SEQUENCE: ! result = CRTM_Options_IsValid( opt ) ! ! or ! ! IF ( CRTM_Options_IsValid( opt ) ) THEN.... ! ! OBJECTS: ! opt: CRTM Options object which is to have its ! contents checked. ! UNITS: N/A ! TYPE: CRTM_Options_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! FUNCTION RESULT: ! result: Logical variable indicating whether or not the input ! passed the check. ! If == .FALSE., Options object is unused or contains ! invalid data. ! == .TRUE., Options object can be used in CRTM. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Scalar ! !:sdoc-: !-------------------------------------------------------------------------------- FUNCTION CRTM_Options_IsValid( self ) RESULT( IsValid ) TYPE(CRTM_Options_type), INTENT(IN) :: self LOGICAL :: IsValid CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Options_IsValid' CHARACTER(ML) :: msg ! Setup IsValid = .TRUE. ! Check n_Streams IF ( self%Use_n_Streams ) THEN IF ( self%n_Streams < 1 .OR. self%n_Streams > MAX_N_STREAMS ) THEN msg = 'Invalid n_Streams' CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ) IsValid = .FALSE. END IF END IF ! Check emissivity options IF ( self%Use_Emissivity .OR. self%Use_Direct_Reflectivity ) THEN IF ( CRTM_Options_Associated(self) ) THEN IF ( self%Use_Emissivity ) THEN IF ( ANY(self%Emissivity < ZERO) .OR. ANY(self%Emissivity > ONE) ) THEN msg = 'Invalid emissivity' CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ) IsValid = .FALSE. END IF END IF IF ( self%Use_Direct_Reflectivity ) THEN IF ( ANY(self%Direct_Reflectivity < ZERO) .OR. ANY(self%Direct_Reflectivity > ONE) ) THEN msg = 'Invalid direct reflectivity' CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ) IsValid = .FALSE. END IF END IF ELSE msg = 'Options structure not allocated for emissivity usage' CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ) IsValid = .FALSE. ENDIF END IF ! Check SSU input options IsValid = SSU_Input_IsValid( self%SSU ) .AND. IsValid ! Check Zeeman input options IsValid = Zeeman_Input_IsValid( self%Zeeman ) .AND. IsValid ! Check cloud overlap option validity IsValid = CloudCover_Overlap_IsValid( self%Overlap_Id ) .AND. IsValid END FUNCTION CRTM_Options_IsValid !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Options_Inspect ! ! PURPOSE: ! Subroutine to print the contents of a CRTM Options object to stdout. ! ! CALLING SEQUENCE: ! CALL CRTM_Options_Inspect( Options ) ! ! INPUTS: ! Options: CRTM Options object to display. ! UNITS: N/A ! TYPE: CRTM_Options_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! !:sdoc-: !-------------------------------------------------------------------------------- SUBROUTINE CRTM_Options_Inspect( self ) TYPE(CRTM_Options_type), INTENT(IN) :: self WRITE(*,'(1x,"Options OBJECT")') ! Display components WRITE(*,'(3x,"Check input flag :",1x,l1)') self%Check_Input WRITE(*,'(3x,"Use old MWSSEM flag :",1x,l1)') self%Use_Old_MWSSEM WRITE(*,'(3x,"Use antenna correction flag :",1x,l1)') self%Use_Antenna_Correction WRITE(*,'(3x,"Apply NLTE correction flag :",1x,l1)') self%Apply_NLTE_Correction WRITE(*,'(3x,"Aircraft pressure altitude :",1x,es13.6)') self%Aircraft_Pressure WRITE(*,'(3x,"RT algorithm Id :",1x,i0)') self%RT_Algorithm_Id WRITE(*,'(3x,"Include scattering flag :",1x,l1)') self%Include_Scattering WRITE(*,'(3x,"Use n_Streams flag :",1x,l1)') self%Use_n_Streams WRITE(*,'(3x,"n_Streams :",1x,i0)') self%n_Streams WRITE(*,'(3x,"Cloud cover overlap method :",1x,a )') TRIM(CloudCover_Overlap_Name(self%Overlap_Id)) ! ...Emissivity component IF ( CRTM_Options_Associated(self) ) THEN WRITE(*,'(3x,"Emissivity component")') WRITE(*,'(5x,"n_Channels :",1x,i0)') self%n_Channels WRITE(*,'(5x,"Channel index :",1x,i0)') self%Channel WRITE(*,'(5x,"Use emissivity flag :",1x,l1)') self%Use_Emissivity WRITE(*,'(5x,"Use direct reflectivity flag :",1x,l1)') self%Use_Direct_Reflectivity WRITE(*,'(5x,"Emissivity :")') WRITE(*,'(5(1x,es13.6,:))') self%Emissivity WRITE(*,'(5x,"Use direct reflectivity flag :",1x,l1)') self%Use_Direct_Reflectivity WRITE(*,'(5x,"Direct reflectivity :")') WRITE(*,'(5(1x,es13.6,:))') self%Direct_Reflectivity END IF ! ...SSU input CALL SSU_Input_Inspect( self%SSU ) ! ...Zeeman input CALL Zeeman_Input_Inspect( self%Zeeman ) END SUBROUTINE CRTM_Options_Inspect !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Options_DefineVersion ! ! PURPOSE: ! Subroutine to return the module version information. ! ! CALLING SEQUENCE: ! CALL CRTM_Options_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-: !-------------------------------------------------------------------------------- SUBROUTINE CRTM_Options_DefineVersion( Id ) CHARACTER(*), INTENT(OUT) :: Id Id = MODULE_VERSION_ID END SUBROUTINE CRTM_Options_DefineVersion !------------------------------------------------------------------------------ !:sdoc+: ! ! NAME: ! CRTM_Options_InquireFile ! ! PURPOSE: ! Function to inquire CRTM Options object files. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_Options_InquireFile( & ! Filename , & ! n_Profiles = n_Profiles ) ! ! INPUTS: ! Filename: Character string specifying the name of a ! CRTM Options data file to read. ! UNITS: N/A ! TYPE: CHARACTER(*) ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OPTIONAL OUTPUTS: ! n_Profiles: The number of profiles in the data file. ! 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 inquire was successful ! == FAILURE, an unrecoverable error occurred. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! !:sdoc-: !------------------------------------------------------------------------------ FUNCTION CRTM_Options_InquireFile( & Filename , & ! Input n_Profiles ) & ! Optional output RESULT( err_stat ) ! Arguments CHARACTER(*), INTENT(IN) :: Filename INTEGER , OPTIONAL, INTENT(OUT) :: n_Profiles ! Function result INTEGER :: err_stat ! Function parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Options_InquireFile' ! Function variables CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg INTEGER :: io_stat INTEGER :: fid INTEGER :: m ! Set up err_stat = SUCCESS ! ...Check that the file exists IF ( .NOT. File_Exists( TRIM(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 number of profiles dimension READ( fid, IOSTAT=io_stat,IOMSG=io_msg ) m IF ( io_stat /= 0 ) THEN msg = 'Error reading dimensions from '//TRIM(Filename)//' - '//TRIM(io_msg) 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 ! Set the optional return arguments IF ( PRESENT(n_Profiles) ) n_Profiles = m CONTAINS SUBROUTINE Inquire_CleanUp() IF ( File_Open(fid) ) THEN CLOSE( fid,IOSTAT=io_stat,IOMSG=io_msg ) IF ( io_stat /= SUCCESS ) & msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) END IF err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END SUBROUTINE Inquire_CleanUp END FUNCTION CRTM_Options_InquireFile !------------------------------------------------------------------------------ !:sdoc+: ! ! NAME: ! CRTM_Options_ReadFile ! ! PURPOSE: ! Function to read CRTM Options object files. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_Options_ReadFile( & ! Filename , & ! Options , & ! Quiet = Quiet , & ! n_Profiles = n_Profiles ) ! ! INPUTS: ! Filename: Character string specifying the name of an ! Options format data file to read. ! UNITS: N/A ! TYPE: CHARACTER(*) ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! Options: CRTM Options object array containing the Options ! data. ! UNITS: N/A ! TYPE: CRTM_Options_type ! DIMENSION: Rank-1 (n_Profiles) ! 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 CRTM_Options_ReadFile( & Filename , & ! Input Options , & ! Output Quiet , & ! Optional input n_Profiles, & ! Optional output Debug ) & ! Optional input (Debug output control) RESULT( err_stat ) ! Arguments CHARACTER(*), INTENT(IN) :: Filename TYPE(CRTM_Options_type), INTENT(OUT) :: Options(:) ! n_Profiles 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 = 'CRTM_Options_ReadFile' ! Function variables CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg INTEGER :: io_stat LOGICAL :: noisy INTEGER :: fid INTEGER :: m, n_file_profiles, n_input_profiles ! Set up err_stat = SUCCESS ! ...Check Quiet argument noisy = .TRUE. IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet ! ...Override Quiet settings if debug set. IF ( PRESENT(Debug) ) noisy = Debug ! ...Check that the file exists IF ( .NOT. File_Exists( TRIM(Filename) ) ) THEN msg = 'File '//TRIM(Filename)//' not found.' CALL Read_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 Read_Cleanup(); RETURN END IF ! Read the dimensions READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) n_file_profiles IF ( io_stat /= 0 ) THEN msg = 'Error reading dimensions from '//TRIM(Filename)//' - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN END IF ! ...Check if n_Profiles in file is > size of output array n_input_profiles = SIZE(Options) IF ( n_file_profiles > n_input_profiles ) THEN WRITE( msg,'("Number of profiles, ",i0,", > size of the output Options", & &" 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 err_stat = Read_Record( fid, Options(m), & Quiet = Quiet, & Debug = Debug ) IF ( err_stat /= SUCCESS ) THEN WRITE( msg,'("Error reading Options element (",i0,") from ",a)' ) m, TRIM(Filename) CALL Read_Cleanup(); RETURN END IF END DO Profile_Loop ! 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 Read_Cleanup(); RETURN END IF ! Set the optional 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, 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 CRTM_Options_Destroy( Options ) err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END SUBROUTINE Read_CleanUp END FUNCTION CRTM_Options_ReadFile !------------------------------------------------------------------------------ !:sdoc+: ! ! NAME: ! CRTM_Options_WriteFile ! ! PURPOSE: ! Function to write CRTM Options object files. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_Options_WriteFile( Filename , & ! Options , & ! Quiet = Quiet ) ! ! INPUTS: ! Filename: Character string specifying the name of the ! Options format data file to write. ! UNITS: N/A ! TYPE: CHARACTER(*) ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! Options: CRTM Options object array containing the Options ! data. ! UNITS: N/A ! TYPE: CRTM_Options_type ! DIMENSION: Rank-1 (n_Profiles) ! ATTRIBUTES: INTENT(IN) ! ! 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 ! ! SIDE EFFECTS: ! - If the output file already exists, it is overwritten. ! - If an error occurs during *writing*, the output file is deleted before ! returning to the calling routine. ! !:sdoc-: !------------------------------------------------------------------------------ FUNCTION CRTM_Options_WriteFile( & Filename, & ! Input Options , & ! Input Quiet , & ! Optional input Debug ) & ! Optional input (Debug output control) RESULT( err_stat ) ! Arguments CHARACTER(*), INTENT(IN) :: Filename TYPE(CRTM_Options_type), INTENT(IN) :: Options(:) ! n_Profiles LOGICAL, OPTIONAL, INTENT(IN) :: Quiet LOGICAL, OPTIONAL, INTENT(IN) :: Debug ! Function result INTEGER :: err_stat ! Function parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Options_WriteFile' ! Function variables CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg INTEGER :: io_stat LOGICAL :: noisy 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) ) noisy = Debug ! Any valid profiles? n_output_profiles = SIZE(Options) IF ( n_output_profiles == 0 ) THEN msg = 'Zero dimension profiles in input!' CALL Write_Cleanup(); RETURN END IF ! Open the file 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 dimensions WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) n_output_profiles IF ( io_stat /= 0 ) THEN msg = 'Error writing dimensions to '//TRIM(Filename)//'- '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF ! Write the data Profile_Loop: DO m = 1, n_output_profiles err_stat = Write_Record( fid, Options(m), & Quiet = Quiet, & Debug = Debug ) IF ( err_stat /= SUCCESS ) THEN WRITE( msg,'("Error writing Options element (",i0,") to ",a)' ) m, TRIM(Filename) CALL Write_Cleanup(); RETURN END IF END DO Profile_Loop ! Close the file (if error, no delete) CLOSE( fid,STATUS='KEEP',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 ! 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, msg, INFORMATION ) END IF CONTAINS SUBROUTINE Write_CleanUp() IF ( File_Open( Filename ) ) THEN CLOSE( fid,STATUS=WRITE_ERROR_STATUS,IOSTAT=io_stat,IOMSG=io_msg ) IF ( io_stat /= 0 ) & msg = TRIM(msg)//'; Error deleting 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 CRTM_Options_WriteFile !################################################################################## !################################################################################## !## ## !## ## PRIVATE MODULE ROUTINES ## ## !## ## !################################################################################## !################################################################################## !------------------------------------------------------------------------------ ! ! NAME: ! CRTM_Options_Equal ! ! PURPOSE: ! Elemental function to test the equality of two CRTM_Options objects. ! Used in OPERATOR(==) interface block. ! ! Note: Only the dimensionality and radiance/brightness temperatures ! are checked for equality. ! ! CALLING SEQUENCE: ! is_equal = CRTM_Options_Equal( x, y ) ! ! or ! ! IF ( x == y ) THEN ! ... ! END IF ! ! OBJECTS: ! x, y: Two CRTM Options objects to be compared. ! UNITS: N/A ! TYPE: CRTM_Options_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. ! !------------------------------------------------------------------------------ ELEMENTAL FUNCTION CRTM_Options_Equal( x, y ) RESULT( is_equal ) TYPE(CRTM_Options_type) , INTENT(IN) :: x, y LOGICAL :: is_equal is_equal = (x%Check_Input .EQV. y%Check_Input ) .AND. & (x%Use_Old_MWSSEM .EQV. y%Use_Old_MWSSEM ) .AND. & (x%Use_Antenna_Correction .EQV. y%Use_Antenna_Correction) .AND. & (x%Apply_NLTE_Correction .EQV. y%Apply_NLTE_Correction ) .AND. & (x%RT_Algorithm_Id == y%RT_Algorithm_Id ) .AND. & (x%Aircraft_Pressure .EqualTo. y%Aircraft_Pressure ) .AND. & (x%Use_n_Streams .EQV. y%Use_n_Streams ) .AND. & (x%n_Streams == y%n_Streams ) .AND. & (x%Include_Scattering .EQV. y%Include_Scattering ) .AND. & (x%Overlap_Id == y%Overlap_Id ) ! Emissivity component is_equal = is_equal .AND. & ( (x%n_Channels == y%n_Channels) .AND. & (x%Channel == y%Channel ) .AND. & (x%Use_Emissivity .EQV. y%Use_Emissivity ) .AND. & (x%Use_Direct_Reflectivity .EQV. y%Use_Direct_Reflectivity ) .AND. & (CRTM_Options_Associated(x) .EQV. CRTM_Options_Associated(y)) ) IF ( CRTM_Options_Associated(x) .AND. CRTM_Options_Associated(y) ) & is_equal = is_equal .AND. & ALL(x%Emissivity .EqualTo. y%Emissivity ) .AND. & ALL(x%Direct_Reflectivity .EqualTo. y%Direct_Reflectivity) ! SSU input is_equal = is_equal .AND. & (x%SSU == y%SSU) ! Zeeman input is_equal = is_equal .AND. & (x%Zeeman == y%Zeeman) END FUNCTION CRTM_Options_Equal ! ! NAME: ! Read_Record ! ! PURPOSE: ! Utility function to read a single options data record ! FUNCTION Read_Record( & fid , & ! Input opt , & ! Output Quiet , & ! Optional input Debug ) & ! Optional input (Debug output control) RESULT( err_stat ) ! Arguments INTEGER, INTENT(IN) :: fid TYPE(CRTM_Options_type), INTENT(OUT) :: opt LOGICAL, OPTIONAL, INTENT(IN) :: Quiet LOGICAL, OPTIONAL, INTENT(IN) :: Debug ! Function result INTEGER :: err_stat ! Function parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Options_ReadFile(Record)' ! Function variables CHARACTER(ML) :: fname CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg INTEGER :: io_stat INTEGER :: n_channels LOGICAL :: emissivity_data_present ! Set up err_stat = SUCCESS ! Read the dimensions READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) n_channels IF ( io_stat /= 0 ) THEN msg = 'Error reading dimensions - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF ! ... No emissivity data if n_channels == 0 emissivity_data_present = (n_channels > 0) ! Allocate the Options structure if necessary IF ( emissivity_data_present ) THEN CALL CRTM_Options_Create( opt, n_channels ) IF ( .NOT. CRTM_Options_Associated( opt ) ) THEN msg = 'Error creating output object.' CALL Read_Record_Cleanup(); RETURN END IF END IF ! Read the optional values ! ...Input checking logical err_stat = ReadLogical_Binary_File( fid, opt%Check_Input ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading input checking option' CALL Read_Record_Cleanup(); RETURN END IF ! ...Old MWSSEM logical err_stat = ReadLogical_Binary_File( fid, opt%Use_Old_MWSSEM ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading old MW water emissivity algorithm switch option' CALL Read_Record_Cleanup(); RETURN END IF ! ...Antenna correction logical err_stat = ReadLogical_Binary_File( fid, opt%Use_Antenna_Correction ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading antenna correction option' CALL Read_Record_Cleanup(); RETURN END IF ! ...NLTE correction logical err_stat = ReadLogical_Binary_File( fid, opt%Apply_NLTE_Correction ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading NLTE correction option' CALL Read_Record_Cleanup(); RETURN END IF ! ...RT algorithm ID READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%RT_Algorithm_Id IF ( io_stat /= 0 ) THEN msg = 'Error reading RT algorithm id option - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF ! ...Aircraft flight level pressure READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%Aircraft_Pressure IF ( io_stat /= 0 ) THEN msg = 'Error reading aircraft flight level pressure option - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF ! ...Number of RT streams options err_stat = ReadLogical_Binary_File( fid, opt%Use_n_Streams ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading n_Streams option' CALL Read_Record_Cleanup(); RETURN END IF READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%n_Streams IF ( io_stat /= 0 ) THEN msg = 'Error reading n_Streams optional value - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF ! ...Scattering options err_stat = ReadLogical_Binary_File( fid, opt%Include_Scattering ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading include scattering option' CALL Read_Record_Cleanup(); RETURN END IF ! ...Cloud cover overlap methodology identifier READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%Overlap_Id IF ( io_stat /= 0 ) THEN msg = 'Error reading Overlap_Id optional value - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF ! Read the emissivity/reflectivity data IF ( emissivity_data_present ) THEN ! Read the emissivity option ! ...The switch... err_stat = ReadLogical_Binary_File( fid, opt%Use_Emissivity ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading emissivity option' CALL Read_Record_Cleanup(); RETURN END IF ! ...and the data READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%Emissivity IF ( io_stat /= 0 ) THEN msg = 'Error reading emissivity data - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF ! Read the direct reflectivity option ! ...The switch... err_stat = ReadLogical_Binary_File( fid, opt%Use_Direct_Reflectivity ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading direct reflectivity option' CALL Read_Record_Cleanup(); RETURN END IF ! ...and the data READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%Direct_Reflectivity IF ( io_stat /= 0 ) THEN msg = 'Error reading direct reflectivity data - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF END IF ! Read the contained object data INQUIRE( UNIT=fid,NAME=fname ) ! ...The SSU input data err_stat = SSU_Input_ReadFile( & opt%SSU, & fname, & Quiet = Quiet, & No_Close = .TRUE., & Debug = Debug ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading SSU input data' CALL Read_Record_Cleanup(); RETURN END IF ! ...The Zeeman input data err_stat = Zeeman_Input_ReadFile( & opt%Zeeman, & fname, & Quiet = Quiet, & No_Close = .TRUE., & Debug = Debug ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading Zeeman input data' CALL Read_Record_Cleanup(); RETURN END IF CONTAINS SUBROUTINE Read_Record_Cleanup() CALL CRTM_Options_Destroy( opt ) CLOSE( fid,IOSTAT=io_stat,IOMSG=io_msg ) IF ( io_stat /= SUCCESS ) & msg = TRIM(msg)//'; Error closing file during error cleanup - '//TRIM(io_msg) err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END SUBROUTINE Read_Record_Cleanup END FUNCTION Read_Record ! ! NAME: ! Write_Record ! ! PURPOSE: ! Utility function to write a single options data record ! FUNCTION Write_Record( & fid , & ! Input opt , & ! Input Quiet , & ! Optional input Debug ) & ! Optional input (Debug output control) RESULT( err_stat ) ! Arguments INTEGER, INTENT(IN) :: fid TYPE(CRTM_Options_type), INTENT(IN) :: opt LOGICAL, OPTIONAL, INTENT(IN) :: Quiet LOGICAL, OPTIONAL, INTENT(IN) :: Debug ! Function result INTEGER :: err_stat ! Function parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Options_WriteFile(Record)' ! Function variables CHARACTER(ML) :: fname CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg INTEGER :: io_stat ! Set up err_stat = SUCCESS ! Write the dimensions WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%n_channels IF ( io_stat /= 0 ) THEN msg = 'Error writing dimensions - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF ! Write the optional values ! ...Input checking logical err_stat = WriteLogical_Binary_File( fid, opt%Check_Input ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error writing input checking option' CALL Write_Record_Cleanup(); RETURN END IF ! ...Old MWSSEM logical err_stat = WriteLogical_Binary_File( fid, opt%Use_Old_MWSSEM ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error writing old MW water emissivity algorithm switch option' CALL Write_Record_Cleanup(); RETURN END IF ! ...Antenna correction logical err_stat = WriteLogical_Binary_File( fid, opt%Use_Antenna_Correction ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error writing antenna correction option' CALL Write_Record_Cleanup(); RETURN END IF ! ...NLTE correction logical err_stat = WriteLogical_Binary_File( fid, opt%Apply_NLTE_Correction ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error writing NLTE correction option' CALL Write_Record_Cleanup(); RETURN END IF ! ...RT algorithm ID WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%RT_Algorithm_Id IF ( io_stat /= 0 ) THEN msg = 'Error writing RT algorithm id option - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF ! ...Aircraft flight level pressure WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%Aircraft_Pressure IF ( io_stat /= 0 ) THEN msg = 'Error writing aircraft flight level pressure option - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF ! ...Number of RT streams options err_stat = WriteLogical_Binary_File( fid, opt%Use_n_Streams ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error writing n_Streams option' CALL Write_Record_Cleanup(); RETURN END IF WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%n_Streams IF ( io_stat /= 0 ) THEN msg = 'Error writing n_Streams optional value - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF ! ...Scattering options err_stat = WriteLogical_Binary_File( fid, opt%Include_Scattering ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error writing include scattering option' CALL Write_Record_Cleanup(); RETURN END IF ! ...Cloud cover overlap methodology identifier WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%Overlap_Id IF ( io_stat /= 0 ) THEN msg = 'Error writing Overlap_Id optional value - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF ! Write the emissivity/reflectivity data IF ( CRTM_Options_Associated(opt) ) THEN ! Write the emissivity option ! ...The switch... err_stat = WriteLogical_Binary_File( fid, opt%Use_Emissivity ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error writing emissivity option' CALL Write_Record_Cleanup(); RETURN END IF ! ...and the data WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%Emissivity IF ( io_stat /= 0 ) THEN msg = 'Error writing emissivity data - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF ! Write the direct reflectivity option ! ...The switch... err_stat = WriteLogical_Binary_File( fid, opt%Use_Direct_Reflectivity ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error writing direct reflectivity option' CALL Write_Record_Cleanup(); RETURN END IF ! ...and the data WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%Direct_Reflectivity IF ( io_stat /= 0 ) THEN msg = 'Error writing direct reflectivity data - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF END IF ! Write the contained object data INQUIRE( UNIT=fid,NAME=fname ) ! ...The SSU input data err_stat = SSU_Input_WriteFile( & opt%SSU, & fname, & Quiet = Quiet, & No_Close = .TRUE., & Debug = Debug ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error writing SSU input data' CALL Write_Record_Cleanup(); RETURN END IF ! ...The Zeeman input data err_stat = Zeeman_Input_WriteFile( & opt%Zeeman, & fname, & Quiet = Quiet, & No_Close = .TRUE., & Debug = Debug ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error writing Zeeman input data' CALL Write_Record_Cleanup(); RETURN END IF CONTAINS SUBROUTINE Write_Record_Cleanup() CLOSE( fid,STATUS=WRITE_ERROR_STATUS,IOSTAT=io_stat,IOMSG=io_msg ) IF ( io_stat /= SUCCESS ) & msg = TRIM(msg)//'; Error closing file during error cleanup - '//TRIM(io_msg) err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END SUBROUTINE Write_Record_Cleanup END FUNCTION Write_Record END MODULE CRTM_Options_Define