<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
!
! Zeeman_Input_Define
!
! Module containing the structure definition and associated routines
! for CRTM inputs specific to Zeeman
!
!
! CREATION HISTORY:
! Written by: Paul van Delst, 26-Oct-2009
! paul.vandelst@noaa.gov
!
<A NAME='ZEEMAN_INPUT_DEFINE'><A href='../../html_code/crtm/Zeeman_Input_Define.f90.html#ZEEMAN_INPUT_DEFINE' TARGET='top_target'><IMG SRC="../../gif/bar_purple.gif" border=0></A>
MODULE Zeeman_Input_Define 3,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
! ------------
! Visibilities
! ------------
PRIVATE
! Datatypes
PUBLIC :: Zeeman_Input_type
! Operators
PUBLIC :: OPERATOR(==)
! Procedures
PUBLIC :: Zeeman_Input_GetValue
PUBLIC :: Zeeman_Input_SetValue
PUBLIC :: Zeeman_Input_IsValid
PUBLIC :: Zeeman_Input_Inspect
PUBLIC :: Zeeman_Input_DefineVersion
PUBLIC :: Zeeman_Input_ValidRelease
PUBLIC :: Zeeman_Input_ReadFile
PUBLIC :: Zeeman_Input_WriteFile
! -------------------
! Procedure overloads
! -------------------
<A NAME='OPERATOR'><A href='../../html_code/crtm/Zeeman_Input_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(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = &
'$Id: Zeeman_Input_Define.f90 29405 2013-06-20 20:19:52Z paul.vandelst@noaa.gov $'
! Release and version
INTEGER, PARAMETER :: ZEEMAN_INPUT_RELEASE = 1 ! This determines structure and file formats.
INTEGER, PARAMETER :: ZEEMAN_INPUT_VERSION = 1 ! This is just the default data version.
! Close status for write errors
CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE'
! Message string length
INTEGER, PARAMETER :: ML = 256
! Literal constants
REAL(Double), PARAMETER :: ZERO = 0.0_Double
! Zeeman specific data
REAL(Double), PARAMETER :: DEFAULT_MAGENTIC_FIELD = 0.3_Double
!--------------------
! Structure defintion
!--------------------
!:tdoc+:
TYPE :: Zeeman_Input_type
PRIVATE
! Release and version information
INTEGER(Long) :: Release = ZEEMAN_INPUT_RELEASE
INTEGER(Long) :: Version = ZEEMAN_INPUT_VERSION
! Earth magnetic field strength in Gauss
REAL(Double) :: Be = DEFAULT_MAGENTIC_FIELD
! Cosine of the angle between the Earth
! magnetic field and wave propagation direction
REAL(Double) :: Cos_ThetaB = ZERO
! Cosine of the azimuth angle of the Be vector.
REAL(Double) :: Cos_PhiB = ZERO
! Doppler frequency shift caused by Earth-rotation.
REAL(Double) :: Doppler_Shift = ZERO
END TYPE Zeeman_Input_type
!:tdoc-:
CONTAINS
!################################################################################
!################################################################################
!## ##
!## ## PUBLIC MODULE ROUTINES ## ##
!## ##
!################################################################################
!################################################################################
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Zeeman_Input_SetValue
!
! PURPOSE:
! Elemental subroutine to set the values of Zeeman_Input
! object components.
!
! CALLING SEQUENCE:
! CALL Zeeman_Input_SetValue( Zeeman_Input , &
! Field_Strength = Field_Strength, &
! Cos_ThetaB = Cos_ThetaB , &
! Cos_PhiB = Cos_PhiB , &
! Doppler_Shift = Doppler_Shift )
!
! OBJECTS:
! Zeeman_Input: Zeeman_Input object for which component values
! are to be set.
! UNITS: N/A
! TYPE: Zeeman_Input_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL INPUTS:
! Field_Strength: Earth's magnetic filed strength
! UNITS: Gauss
! TYPE: REAL(fp)
! DIMENSION: Scalar or same as Zeeman_Input
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! Cos_ThetaB: Cosine of the angle between the Earth magnetic
! field and wave propagation vectors.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Scalar or same as Zeeman_Input
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! Cos_PhiB: Cosine of the azimuth angle of the Earth magnetic
! field vector.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Scalar or same as Zeeman_Input
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! Doppler_Shift: Doppler frequency shift caused by Earth-rotation.
! Positive towards sensor.
! UNITS: KHz
! TYPE: REAL(fp)
! DIMENSION: Scalar or same as Zeeman_Input
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='ZEEMAN_INPUT_SETVALUE'><A href='../../html_code/crtm/Zeeman_Input_Define.f90.html#ZEEMAN_INPUT_SETVALUE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
ELEMENTAL SUBROUTINE Zeeman_Input_SetValue( &
Zeeman_Input , &
Field_Strength, &
Cos_ThetaB , &
Cos_PhiB , &
Doppler_Shift )
! Arguments
TYPE(Zeeman_Input_type), INTENT(IN OUT) :: Zeeman_Input
REAL(fp), OPTIONAL, INTENT(IN) :: Field_Strength
REAL(fp), OPTIONAL, INTENT(IN) :: Cos_ThetaB
REAL(fp), OPTIONAL, INTENT(IN) :: Cos_PhiB
REAL(fp), OPTIONAL, INTENT(IN) :: Doppler_Shift
! Set components
IF ( PRESENT(Field_Strength) ) Zeeman_Input%Be = Field_Strength
IF ( PRESENT(Cos_ThetaB ) ) Zeeman_Input%Cos_ThetaB = Cos_ThetaB
IF ( PRESENT(Cos_PhiB ) ) Zeeman_Input%Cos_PhiB = Cos_PhiB
IF ( PRESENT(Doppler_Shift ) ) Zeeman_Input%Doppler_Shift = Doppler_Shift
END SUBROUTINE Zeeman_Input_SetValue
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Zeeman_Input_GetValue
!
! PURPOSE:
! Elemental subroutine to get the values of Zeeman_Input
! object components.
!
! CALLING SEQUENCE:
! CALL Zeeman_Input_GetValue( Zeeman_Input , &
! Field_Strength = Field_Strength, &
! Cos_ThetaB = Cos_ThetaB , &
! Cos_PhiB = Cos_PhiB , &
! Doppler_Shift = Doppler_Shift )
!
! OBJECTS:
! Zeeman_Input: Zeeman_Input object for which component values
! are to be set.
! UNITS: N/A
! TYPE: Zeeman_Input_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL OUTPUTS:
! Field_Strength: Earth's magnetic filed strength
! UNITS: Gauss
! TYPE: REAL(fp)
! DIMENSION: Scalar or same as Zeeman_Input
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! Cos_ThetaB: Cosine of the angle between the Earth magnetic
! field and wave propagation vectors.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Scalar or same as Zeeman_Input
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! Cos_PhiB: Cosine of the azimuth angle of the Earth magnetic
! field vector.
! UNITS: N/A
! TYPE: REAL(fp)
! DIMENSION: Scalar or same as Zeeman_Input
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! Doppler_Shift: Doppler frequency shift caused by Earth-rotation.
! Positive towards sensor.
! UNITS: KHz
! TYPE: REAL(fp)
! DIMENSION: Scalar or same as Zeeman_Input
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='ZEEMAN_INPUT_GETVALUE'><A href='../../html_code/crtm/Zeeman_Input_Define.f90.html#ZEEMAN_INPUT_GETVALUE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
ELEMENTAL SUBROUTINE Zeeman_Input_GetValue( & 6
Zeeman_Input , &
Field_Strength, &
Cos_ThetaB , &
Cos_PhiB , &
Doppler_Shift )
! Arguments
TYPE(Zeeman_Input_type),INTENT(IN) :: Zeeman_Input
REAL(fp), OPTIONAL, INTENT(OUT) :: Field_Strength
REAL(fp), OPTIONAL, INTENT(OUT) :: Cos_ThetaB
REAL(fp), OPTIONAL, INTENT(OUT) :: Cos_PhiB
REAL(fp), OPTIONAL, INTENT(OUT) :: Doppler_Shift
! Get components
IF ( PRESENT(Field_Strength) ) Field_Strength = Zeeman_Input%Be
IF ( PRESENT(Cos_ThetaB ) ) Cos_ThetaB = Zeeman_Input%Cos_ThetaB
IF ( PRESENT(Cos_PhiB ) ) Cos_PhiB = Zeeman_Input%Cos_PhiB
IF ( PRESENT(Doppler_Shift ) ) Doppler_Shift = Zeeman_Input%Doppler_Shift
END SUBROUTINE Zeeman_Input_GetValue
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Zeeman_Input_IsValid
!
! PURPOSE:
! Non-pure function to perform some simple validity checks on a
! Zeeman_Input object.
!
! If invalid data is found, a message is printed to stdout.
!
! CALLING SEQUENCE:
! result = Zeeman_Input_IsValid( z )
!
! or
!
! IF ( Zeeman_Input_IsValid( z ) ) THEN....
!
! OBJECTS:
! z: Zeeman_Input object which is to have its
! contents checked.
! UNITS: N/A
! TYPE: Zeeman_Input_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! result: Logical variable indicating whether or not the input
! passed the check.
! If == .FALSE., object is unused or contains
! invalid data.
! == .TRUE., object can be used.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Scalar
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='ZEEMAN_INPUT_ISVALID'><A href='../../html_code/crtm/Zeeman_Input_Define.f90.html#ZEEMAN_INPUT_ISVALID' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION Zeeman_Input_IsValid( z ) RESULT( IsValid ) 1,4
TYPE(Zeeman_Input_type), INTENT(IN) :: z
LOGICAL :: IsValid
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Zeeman_Input_IsValid'
!!!
real(fp), parameter :: big_number = 1.0e+09_fp
!!!
CHARACTER(ML) :: msg
! Setup
IsValid = .TRUE.
! Check components
IF ( z%Be < ZERO ) THEN
msg = 'Invalid field strength'
CALL Display_Message( ROUTINE_NAME, TRIM(msg), INFORMATION )
IsValid = .FALSE.
END IF
IF ( z%Cos_ThetaB > big_number ) THEN
msg = 'Invalid COS(ThetaB)'
CALL Display_Message( ROUTINE_NAME, TRIM(msg), INFORMATION )
IsValid = .FALSE.
END IF
IF ( z%Cos_PhiB > big_number ) THEN
msg = 'Invalid COS(PhiB)'
CALL Display_Message( ROUTINE_NAME, TRIM(msg), INFORMATION )
IsValid = .FALSE.
END IF
IF ( ABS(z%Doppler_Shift) > big_number ) THEN
msg = 'Invalid Doppler shift'
CALL Display_Message( ROUTINE_NAME, TRIM(msg), INFORMATION )
IsValid = .FALSE.
END IF
END FUNCTION Zeeman_Input_IsValid
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Zeeman_Input_Inspect
!
! PURPOSE:
! Subroutine to print the contents of an Zeeman_Input object to stdout.
!
! CALLING SEQUENCE:
! CALL Zeeman_Input_Inspect( z )
!
! INPUTS:
! z: Zeeman_Input object to display.
! UNITS: N/A
! TYPE: Zeeman_Input_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='ZEEMAN_INPUT_INSPECT'><A href='../../html_code/crtm/Zeeman_Input_Define.f90.html#ZEEMAN_INPUT_INSPECT' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Zeeman_Input_Inspect(z) 1
TYPE(Zeeman_Input_type), INTENT(IN) :: z
WRITE(*,'(3x,"Zeeman_Input OBJECT")')
WRITE(*,'(5x,"Field strength (gauss):",1x,es22.15)') z%Be
WRITE(*,'(5x,"COS(ThetaB) :",1x,es22.15)') z%Cos_ThetaB
WRITE(*,'(5x,"COS(PhiB) :",1x,es22.15)') z%Cos_PhiB
WRITE(*,'(5x,"Doppler shift (KHz) :",1x,es22.15)') z%Doppler_Shift
END SUBROUTINE Zeeman_Input_Inspect
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Zeeman_Input_DefineVersion
!
! PURPOSE:
! Subroutine to return the module version information.
!
! CALLING SEQUENCE:
! CALL Zeeman_Input_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='ZEEMAN_INPUT_DEFINEVERSION'><A href='../../html_code/crtm/Zeeman_Input_Define.f90.html#ZEEMAN_INPUT_DEFINEVERSION' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Zeeman_Input_DefineVersion( Id )
CHARACTER(*), INTENT(OUT) :: Id
Id = MODULE_VERSION_ID
END SUBROUTINE Zeeman_Input_DefineVersion
!----------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Zeeman_Input_ValidRelease
!
! PURPOSE:
! Function to check the Zeeman_Input Release value.
!
! CALLING SEQUENCE:
! IsValid = Zeeman_Input_ValidRelease( Zeeman_Input )
!
! INPUTS:
! Zeeman_Input: Zeeman_Input object for which the Release component
! is to be checked.
! UNITS: N/A
! TYPE: Zeeman_Input_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='ZEEMAN_INPUT_VALIDRELEASE'><A href='../../html_code/crtm/Zeeman_Input_Define.f90.html#ZEEMAN_INPUT_VALIDRELEASE' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION Zeeman_Input_ValidRelease( self ) RESULT( IsValid ),2
! Arguments
TYPE(Zeeman_Input_type), INTENT(IN) :: self
! Function result
LOGICAL :: IsValid
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Zeeman_Input_ValidRelease'
! Local variables
CHARACTER(ML) :: msg
! Set up
IsValid = .TRUE.
! Check release is not too old
IF ( self%Release < ZEEMAN_INPUT_RELEASE ) THEN
IsValid = .FALSE.
WRITE( msg,'("An Zeeman_Input data update is needed. ", &
&"Zeeman_Input release is ",i0,". Valid release is ",i0,"." )' ) &
self%Release, ZEEMAN_INPUT_RELEASE
CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ); RETURN
END IF
! Check release is not too new
IF ( self%Release > ZEEMAN_INPUT_RELEASE ) THEN
IsValid = .FALSE.
WRITE( msg,'("An Zeeman_Input software update is needed. ", &
&"Zeeman_Input release is ",i0,". Valid release is ",i0,"." )' ) &
self%Release, ZEEMAN_INPUT_RELEASE
CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ); RETURN
END IF
END FUNCTION Zeeman_Input_ValidRelease
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Zeeman_Input_ReadFile
!
! PURPOSE:
! Function to read Zeeman_Input object files.
!
! CALLING SEQUENCE:
! Error_Status = Zeeman_Input_ReadFile( &
! Zeeman_Input , &
! Filename , &
! No_Close = No_Close, &
! Quiet = Quiet )
!
! OBJECTS:
! Zeeman_Input: Zeeman_Input object containing the data read from file.
! UNITS: N/A
! TYPE: Zeeman_Input_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
! Filename: Character string specifying the name of a
! Zeeman_Input 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 Zeeman_Input 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='ZEEMAN_INPUT_READFILE'><A href='../../html_code/crtm/Zeeman_Input_Define.f90.html#ZEEMAN_INPUT_READFILE' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION Zeeman_Input_ReadFile( & 1,10
Zeeman_Input, & ! 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(Zeeman_Input_type), INTENT(OUT) :: Zeeman_Input
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 = 'Zeeman_Input_ReadFile'
! Function variables
CHARACTER(ML) :: msg
CHARACTER(ML) :: io_msg
LOGICAL :: close_file
LOGICAL :: noisy
INTEGER :: io_stat
INTEGER :: fid
TYPE(Zeeman_Input_type) :: dummy
! Setup
err_stat = SUCCESS
! ...Check No_Close argument
close_file = .TRUE.
IF ( PRESENT(No_Close) ) close_file = .NOT. No_Close
! ...Check Quiet argument
noisy = .TRUE.
IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet
! ...Override Quiet settings if debug set.
IF ( PRESENT(Debug) ) THEN
IF ( Debug ) noisy = .TRUE.
END IF
! Check if the file is open.
IF ( File_Open( Filename ) ) THEN
! ...Inquire for the logical unit number
INQUIRE( FILE=Filename, NUMBER=fid )
! ...Ensure it's valid
IF ( fid < 0 ) THEN
msg = 'Error inquiring '//TRIM(Filename)//' for its FileID'
CALL Read_CleanUp(); RETURN
END IF
ELSE
! ...Open the file if it exists
IF ( File_Exists( Filename ) ) THEN
err_stat = Open_Binary_File( Filename, fid )
IF ( err_Stat /= SUCCESS ) THEN
msg = 'Error opening '//TRIM(Filename)
CALL Read_CleanUp(); RETURN
END IF
ELSE
msg = 'File '//TRIM(Filename)//' not found.'
CALL Read_CleanUp(); RETURN
END IF
END IF
! Read and check the release and version
READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
dummy%Release, &
dummy%Version
IF ( io_stat /= 0 ) THEN
msg = 'Error reading Release/Version - '//TRIM(io_msg)
CALL Read_Cleanup(); RETURN
END IF
IF ( .NOT. Zeeman_Input_ValidRelease( dummy ) ) THEN
msg = 'Zeeman_Input Release check failed.'
CALL Read_Cleanup(); RETURN
END IF
! ...Explicitly assign the version number
Zeeman_Input%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 scalars
READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
Zeeman_Input%Be , &
Zeeman_Input%Cos_ThetaB , &
Zeeman_Input%Cos_PhiB , &
Zeeman_Input%Doppler_Shift
IF ( io_stat /= 0 ) THEN
msg = 'Error reading 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
CONTAINS
<A NAME='READ_CLEANUP'><A href='../../html_code/crtm/Zeeman_Input_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
err_stat = FAILURE
CALL Display_Message( ROUTINE_NAME, msg, err_stat )
END SUBROUTINE Read_CleanUp
END FUNCTION Zeeman_Input_ReadFile
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Zeeman_Input_WriteFile
!
! PURPOSE:
! Function to write Zeeman_Input object files.
!
! CALLING SEQUENCE:
! Error_Status = Zeeman_Input_WriteFile( &
! Zeeman_Input , &
! Filename , &
! No_Close = No_Close, &
! Quiet = Quiet )
!
! OBJECTS:
! Zeeman_Input: Zeeman_Input object containing the data to write to file.
! UNITS: N/A
! TYPE: Zeeman_Input_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! INPUTS:
! Filename: Character string specifying the name of a
! Zeeman_Input 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 Zeeman_Input 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='ZEEMAN_INPUT_WRITEFILE'><A href='../../html_code/crtm/Zeeman_Input_Define.f90.html#ZEEMAN_INPUT_WRITEFILE' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION Zeeman_Input_WriteFile( & 1,8
Zeeman_Input, & ! 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(Zeeman_Input_type), INTENT(IN) :: Zeeman_Input
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 = 'Zeeman_Input_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 if the file is open.
IF ( File_Open( FileName ) ) THEN
! ...Inquire for the logical unit number
INQUIRE( FILE=Filename, NUMBER=fid )
! ...Ensure it's valid
IF ( fid < 0 ) THEN
msg = 'Error inquiring '//TRIM(Filename)//' for its FileID'
CALL Write_CleanUp(); RETURN
END IF
ELSE
! ...Open the file for output
err_stat = Open_Binary_File( Filename, fid, For_Output=.TRUE. )
IF ( err_Stat /= SUCCESS ) THEN
msg = 'Error opening '//TRIM(Filename)
CALL Write_CleanUp(); RETURN
END IF
END IF
! Write the release and version
WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
Zeeman_Input%Release, &
Zeeman_Input%Version
IF ( io_stat /= 0 ) THEN
msg = 'Error writing Release/Version - '//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 scalars
WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) &
Zeeman_Input%Be , &
Zeeman_Input%Cos_ThetaB , &
Zeeman_Input%Cos_PhiB , &
Zeeman_Input%Doppler_Shift
IF ( io_stat /= 0 ) THEN
msg = 'Error writing 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
CONTAINS
<A NAME='WRITE_CLEANUP'><A href='../../html_code/crtm/Zeeman_Input_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 Zeeman_Input_WriteFile
!################################################################################
!################################################################################
!## ##
!## ## PRIVATE MODULE ROUTINES ## ##
!## ##
!################################################################################
!################################################################################
<A NAME='ZEEMAN_INPUT_EQUAL'><A href='../../html_code/crtm/Zeeman_Input_Define.f90.html#ZEEMAN_INPUT_EQUAL' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION Zeeman_Input_Equal(x, y) RESULT(is_equal) 1
TYPE(Zeeman_Input_type), INTENT(IN) :: x, y
LOGICAL :: is_equal
is_equal = (x%Be .EqualTo. y%Be ) .AND. &
(x%Cos_ThetaB .EqualTo. y%Cos_ThetaB ) .AND. &
(x%Cos_PhiB .EqualTo. y%Cos_PhiB ) .AND. &
(x%Doppler_Shift .EqualTo. y%Doppler_Shift)
END FUNCTION Zeeman_Input_Equal
END MODULE Zeeman_Input_Define