! ! 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 ! MODULE Zeeman_Input_Define ! ----------------- ! 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 ! ------------------- INTERFACE OPERATOR(==) MODULE PROCEDURE Zeeman_Input_Equal END INTERFACE OPERATOR(==) ! ----------------- ! Module parameters ! ----------------- CHARACTER(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = & '$Id: Zeeman_Input_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@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-: !-------------------------------------------------------------------------------- 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-: !-------------------------------------------------------------------------------- ELEMENTAL SUBROUTINE Zeeman_Input_GetValue( & 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-: !-------------------------------------------------------------------------------- FUNCTION Zeeman_Input_IsValid( z ) RESULT( IsValid ) 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-: !-------------------------------------------------------------------------------- SUBROUTINE Zeeman_Input_Inspect(z) 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-: !-------------------------------------------------------------------------------- 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-: !---------------------------------------------------------------------------------- FUNCTION Zeeman_Input_ValidRelease( self ) RESULT( IsValid ) ! 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-: !------------------------------------------------------------------------------ FUNCTION Zeeman_Input_ReadFile( & 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 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 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-: !------------------------------------------------------------------------------ FUNCTION Zeeman_Input_WriteFile( & 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 SUBROUTINE Write_Cleanup() 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 ## ## !## ## !################################################################################ !################################################################################ ELEMENTAL FUNCTION Zeeman_Input_Equal(x, y) RESULT(is_equal) 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