Zeeman_Input_Define.f90

Go to the documentation of this file.

!
! 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 60152 2015-08-13 19:19:13Z 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-:
!--------------------------------------------------------------------------------

  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