TauCoeff_Define.f90

Go to the documentation of this file.

!
! TauCoeff_Define
!
! Module defining the TauCoeff data structure and containing routines to 
! manipulate it.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 18-Mar-2002
!                       paul.vandelst@noaa.gov
!
!       Updated by:     David Groff, EMC/SAIC Oct-2009
!                       david.groff@noaa.gov
!

MODULE taucoeff_define

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module use
  USE type_kinds,            ONLY: long, double
  USE message_handler,       ONLY: success, failure, display_message
  USE odas_define,           ONLY: odas_type
  USE odps_define,           ONLY: odps_type
  USE odssu_define,          ONLY: odssu_type
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Datatypes
  PUBLIC :: taucoeff_type
  ! Operators
  PUBLIC :: ASSIGNMENT(=)
  PUBLIC :: OPERATOR(.EQ.)
  ! Procedures
  PUBLIC :: taucoeff_associated
  PUBLIC :: taucoeff_destroy
  PUBLIC :: taucoeff_create
  PUBLIC :: taucoeff_info

  ! -------------------
  ! Procedure overloads
  ! -------------------
  INTERFACE ASSIGNMENT(=)
    MODULE PROCEDURE taucoeff_assign
  END INTERFACE
  
  INTERFACE OPERATOR(.EQ.)
    MODULE PROCEDURE taucoeff_equal
  END INTERFACE
  
  
  ! -----------------
  ! Module parameters
  ! -----------------
  ! RCS Id for the module
  CHARACTER(*), PARAMETER :: module_rcs_id = &
  '$Id: TauCoeff_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $'
  ! Message string length
  INTEGER , PARAMETER :: ml = 256
  ! Sensor ID string length
  INTEGER , PARAMETER :: sl = 20

  
  ! -----------------------
  ! Derived type definition  
  ! -----------------------
  TYPE :: taucoeff_type
    ! Array dimensions
    INTEGER :: n_sensors          = 0       ! n
    INTEGER :: n_odas             = 0       ! I1
    INTEGER :: n_odps             = 0       ! I2
    INTEGER :: n_odssu            = 0       ! I3
    INTEGER :: n_odzeeman         = 0       ! I4
    ! Arrays
    INTEGER, ALLOCATABLE :: algorithm_id(:)    ! n
    INTEGER, ALLOCATABLE :: sensor_index(:)    ! n
    INTEGER, ALLOCATABLE :: sensor_loindex(:)  ! n ; Local sensor index for a collection
                                               !     of sensor using the same algorithm
    INTEGER, ALLOCATABLE :: zsensor_loindex(:) ! n; Local sensor index for a collection of sensors 
                                               !    with channles requiring the Zeeman algorithm
    ! Sensor Info: Sensor types and IDs
    CHARACTER(SL), ALLOCATABLE :: sensor_id(:)  ! n
    INTEGER, ALLOCATABLE :: wmo_satellite_id(:) ! n
    INTEGER, ALLOCATABLE :: wmo_sensor_id(:)    ! n
    INTEGER, ALLOCATABLE :: sensor_type(:)      ! n
    
    ! Pointers
    TYPE(odas_type),  POINTER :: odas(:)     => null() ! I1
    TYPE(odps_type),  POINTER :: odps(:)     => null() ! I2
    TYPE(odssu_type), POINTER :: odssu(:)    => null() ! I3
    TYPE(odps_type),  POINTER :: odzeeman(:) => null() ! I4

  END TYPE taucoeff_type


CONTAINS


!--------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       TauCoeff_Associated
!
! PURPOSE:
!       Elemental Function to test the status of the allocatable and pointer 
!       components of a TauCoeff structure.
!
! CALLING SEQUENCE:
!       Is_Associated = TauCoeff_Associated( self )
!
! OBJECTS:
!       self:        TauCoeff structure which is to have its allocatable
!                    and pointer components status tested.
!                    UNITS:      N/A
!                    TYPE:       TauCoeff_type
!                    DIMENSION:  Scalar
!                    ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       Is_Associated:  The return value is a logical value indicating the
!                       status of the allocatable and pointer components.     
!                       .TRUE.  - if ANY of the TauCoeff allocatable or       
!                                 pointer members are in use.                 
!                       .FALSE. - if ALL of the TauCoeff allocatable or       
!                                 pointer members are not in use.             
!                       UNITS:      N/A                                       
!                       TYPE:       LOGICAL                                   
!                       DIMENSION:  Scalar                                    
!:sdoc-:
!--------------------------------------------------------------------------------

  ELEMENTAL FUNCTION taucoeff_associated( self ) RESULT( Is_Associated )
    ! Arguments
    TYPE(taucoeff_type), INTENT(IN) :: self
    ! Function result
    LOGICAL :: is_associated

    ! Test the structure associations
    is_associated = &
      ALLOCATED(self%Algorithm_ID  ) .OR. &
      ALLOCATED(self%Sensor_Index  ) .OR. &
      ALLOCATED(self%Sensor_LoIndex) .OR. &
      ASSOCIATED(self%ODAS         ) .OR. &  ! Should this be tested?
      ASSOCIATED(self%ODPS         ) .OR. &  ! Should this be tested?
      ASSOCIATED(self%ODSSU        ) .OR. &  ! Should this be tested?
      ASSOCIATED(self%ODZeeman     )         ! Should this be tested?

  END FUNCTION taucoeff_associated
  

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       TauCoeff_Destroy
! 
! PURPOSE:
!       Subroutine to re-initialize the TauCoeff data structures.
!
! CALLING SEQUENCE:
!       CALL TauCoeff_Destroy( self, err_stat )
!
! OBJECTS:
!       self:         Re-initialized TauCoeff structure.
!                     UNITS:      N/A
!                     TYPE:       TauCoeff_type
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
!       err_stat:     The error status. The error codes are defined in the
!                     Message_Handler module.
!                     If == SUCCESS the object destruction was successful
!                        == FAILURE an error occurred.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(OUT)
!
! COMMENTS:
!       Note the INTENT on the TauCoeff object argument is IN OUT rather than
!       just OUT. This is necessary because the argument has pointer components
!       and may be defined upon input. To prevent memory leaks, the IN OUT
!       INTENT is a must.
!:sdoc-:
!------------------------------------------------------------------------------
  SUBROUTINE taucoeff_destroy(self, err_stat)
    ! Arguments
    TYPE(taucoeff_type), INTENT(IN OUT) :: self
    INTEGER,             INTENT(OUT)    :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: routine_name = 'TauCoeff_Destroy'
    ! Local variables
    CHARACTER(ML) :: msg
    INTEGER :: alloc_stat

    ! Set up
    err_stat = success
    ! ...If structure is unused, do nothing
    IF ( .NOT. taucoeff_associated(self) ) RETURN
    
    ! Re-initialize the dimensions
    self%n_Sensors = 0

    ! Deallocate the non-scalar components
    DEALLOCATE( self%Algorithm_ID    , &
                self%Sensor_Index    , &
                self%Sensor_LoIndex  , &
                self%ZSensor_LoIndex , &
                self%Sensor_ID       , &
                self%WMO_Satellite_ID, &
                self%WMO_Sensor_ID   , &
                self%Sensor_Type     , &               
                stat = alloc_stat )
    IF ( alloc_stat /= 0 ) THEN
      err_stat = failure
      WRITE( msg, '( "Error deallocating. STAT = ", i0 )' ) alloc_stat
      CALL display_message( routine_name, trim(msg), err_stat )
    END IF
    
    ! Disassociate pointers
    NULLIFY( self%ODAS, self%ODPS, self%ODSSU, self%ODZeeman )

  END SUBROUTINE taucoeff_destroy


!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       TauCoeff_Create
! 
! PURPOSE:
!       Subroutine to create an instance of the TauCoeff data structure.
!
! CALLING SEQUENCE:
!       CALL TauCoeff_Create( self, n_Sensors, err_stat )
!
! OBJECTS:
!       self:         Instance of the TauCoeff structure.
!                     UNITS:      N/A
!                     TYPE:       TauCoeff_type
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN OUT)
!
! INPUTS:
!       n_Sensors:    Number of sensors
!                     Must be > 0.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       err_stat:     The error status. The error codes are defined in the
!                     Message_Handler module.
!                     If == SUCCESS the object creation was successful
!                        == FAILURE an error occurred.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(OUT)
!
! COMMENTS:
!       Note the INTENT on the TauCoeff object argument is IN OUT rather than
!       just OUT. This is necessary because the argument has pointer components
!       and may be defined upon input. To prevent memory leaks, the IN OUT
!       INTENT is a must.
!:sdoc-:
!------------------------------------------------------------------------------

  SUBROUTINE taucoeff_create(self, n_Sensors, err_stat)
    ! Arguments
    TYPE(taucoeff_type), INTENT(IN OUT) :: self
    INTEGER,             INTENT(IN)     :: n_sensors
    INTEGER,             INTENT(OUT)    :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: routine_name = 'TauCoeff_Create'
    ! Local variables
    CHARACTER(ML) :: msg
    INTEGER :: alloc_stat

    ! Set up
    err_stat = success
    ! ...Check input
    IF ( taucoeff_associated( self ) ) THEN
      CALL taucoeff_destroy( self, err_stat )
      IF ( err_stat /= success ) THEN
        msg = 'Error destroying TauCoeff prior to allocation.'
        CALL display_message( routine_name, trim(msg), err_stat )
        RETURN
      END IF
    END IF
    IF ( n_sensors < 1 ) THEN
      err_stat = failure
      msg = 'n_Sensors must be > 0.'
      CALL display_message( routine_name, trim(msg), err_stat )
      RETURN
    END IF


    ! Perform the array allocation
    ALLOCATE( self%Algorithm_ID( n_sensors )    , &
              self%Sensor_Index( n_sensors )    , &
              self%Sensor_LoIndex( n_sensors )  , &
              self%ZSensor_LoIndex( n_sensors ) , &
              self%Sensor_ID( n_sensors )       , &
              self%WMO_Satellite_ID( n_sensors ), &
              self%WMO_Sensor_ID( n_sensors )   , &
              self%Sensor_Type( n_sensors )     , &
              stat = alloc_stat )
    IF ( alloc_stat /= 0 ) THEN
      err_stat = failure
      WRITE( msg, '("Error allocating TauCoeff. STAT = ",i0)' ) alloc_stat
      CALL display_message( routine_name, trim(msg), err_stat )
      RETURN
    END IF


    ! Initialise
    ! ...Dimensions
    self%n_Sensors = n_sensors
    ! ...Arrays
    self%Algorithm_ID     = 0
    self%Sensor_Index     = 0
    self%Sensor_LoIndex   = 0
    self%ZSensor_LoIndex  = 0
    self%Sensor_ID        = ''
    self%WMO_Satellite_ID = 0
    self%WMO_Sensor_ID    = 0
    self%Sensor_Type      = 0
    ! ...Pointers (not required, but what the hell...)
    NULLIFY( self%ODAS, self%ODPS, self%ODSSU, self%ODZeeman )

  END SUBROUTINE taucoeff_create
  
!------------------------------------------------------------------------------
! NAME:
!       TauCoeff_Info
!
! PURPOSE:
!       Subroutine to return a string containing information about
!       a TauCoeff data structure.
!
! CALLING SEQUENCE:
!       CALL TauCoeff_Info( self, info )
!
! OBJECTS:
!       self:          TauCoeff structure about which information is required.
!                      UNITS:      N/A
!                      TYPE:       TauCoeff_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       info:          String containing information about the passed
!                      TauCoeff data structure.
!                      UNITS:      N/A
!                      TYPE:       CHARACTER(*)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT)
!------------------------------------------------------------------------------

  SUBROUTINE taucoeff_info( self, info )
    ! Arguments
    TYPE(taucoeff_type), INTENT(IN)  :: self
    CHARACTER(*),        INTENT(OUT) :: info
    ! Parameters
    INTEGER, PARAMETER :: carriage_return = 13
    INTEGER, PARAMETER :: linefeed = 10
    ! Local variables
    CHARACTER(2000) :: long_string

    ! Write the required info to the local string
    WRITE( long_string, '( a, 2x, &
                           &"N_SENSORS=",i2,2x,&
                           &"N_ODAS=",i2,2x,&
                           &"N_ODPS=",i2,2x,&
                           &"N_ODSSU=",i2,2x,&
                           &"N_ODZeeman=",i2 )' ) &
                         achar(carriage_return)//achar(linefeed), &
                         self%n_Sensors, &
                         self%n_ODAS, &
                         self%n_ODPS, &
                         self%n_ODSSU, &
                         self%n_ODZeeman
    
    ! Trim the output based on the
    ! dummy argument string length
    info = long_string(1:min( len(info), len_trim( long_string ) ))

  END SUBROUTINE taucoeff_info

!------------------------------------------------------------------------------
!
! NAME:
!       TauCoeff_Assign
!
! PURPOSE:
!       Subroutine to copy valid TauCoeff structures. Used in ASSIGNMENT(=)
!       interface block.
!
! CALLING SEQUENCE:
!       CALL TauCoeff_Assign( copy, original )
!
!         or
!
!       copy = original
!
! OBJECTS:
!       copy:          Destination structure for copy.
!                      UNITS:      N/A
!                      TYPE:       TauCoeff_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN OUT)
!
!       original:      Structure to be copied.
!                      UNITS:      N/A
!                      TYPE:       TauCoeff_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! COMMENTS:
!       Note the INTENT on the TauCoeff copy argument is IN OUT rather than
!       just OUT. This is necessary because the argument may be defined upon
!       input. To prevent memory leaks, the IN OUT INTENT is a must.
!
!------------------------------------------------------------------------------

  SUBROUTINE taucoeff_assign( copy, original )
    ! Arguments
    TYPE(TauCoeff_type), INTENT(IN OUT) :: copy
    TYPE(TauCoeff_type), INTENT(IN)     :: original
    ! Parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'TauCoeff_Assign'
    ! Variables
    INTEGER :: err_stat

    ! Destroy the output structure
    CALL taucoeff_destroy( copy, err_stat )
    IF ( err_stat /= success ) THEN
      CALL display_message( routine_name, 'Output TauCoeff re-init failed', err_stat )
      RETURN
    END IF

    ! If input structure not used, do nothing
    IF ( .NOT. taucoeff_associated( original ) ) RETURN

    ! Create the output structure
    CALL taucoeff_create( copy, original%n_Sensors, err_stat )
    IF ( err_stat /= success ) THEN
      CALL display_message( routine_name, 'Output TauCoeff allocation failed', err_stat )
      RETURN
    END IF

    ! Copy array data
    copy%Algorithm_ID     = original%Algorithm_ID
    copy%Sensor_Index     = original%Sensor_Index
    copy%Sensor_LoIndex   = original%Sensor_LoIndex
    copy%ZSensor_LoIndex  = original%ZSensor_LoIndex
    copy%Sensor_ID        = original%Sensor_ID
    copy%WMO_Satellite_ID = original%WMO_Satellite_ID
    copy%WMO_Sensor_ID    = original%WMO_Sensor_ID
    copy%Sensor_Type      = original%Sensor_Type

    ! Set pointers
    IF ( ASSOCIATED(original%ODAS) ) copy%ODAS => original%ODAS
    IF ( ASSOCIATED(original%ODPS) ) copy%ODPS => original%ODPS
    IF ( ASSOCIATED(original%ODSSU) ) copy%ODSSU => original%ODSSU
    IF ( ASSOCIATED(original%ODZeeman) ) copy%ODZeeman => original%ODZeeman
    
  END SUBROUTINE taucoeff_assign

!------------------------------------------------------------------------------
!
! NAME:
!       TauCoeff_Equal
!
! PURPOSE:
!       Elemental function to test the equality of two TauCoeff structures.
!       Used in OPERATOR(.EQ.) interface block.
!
! CALLING SEQUENCE:
!       is_equal = TauCoeff_Equal( x, y )
!
!         or
!
!       IF ( x == y ) THEN
!         ...
!       END IF
!
! OBJECTS:
!       x, y:          Two TauCoeff structures to be compared.
!                      UNITS:      N/A
!                      TYPE:       TauCoeff_type
!                      DIMENSION:  Scalar
!                      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 taucoeff_equal( x, y ) RESULT( is_equal )
    ! Arguments
    TYPE(taucoeff_type), INTENT(IN) :: x, y
    ! Function result
    LOGICAL :: is_equal
    
    ! Setup
    is_equal = .false.
    
    ! Check dimensions
    IF ( (x%n_Sensors /= y%n_Sensors) .OR. &
         (x%n_ODAS    /= y%n_ODAS   ) .OR. &
         (x%n_ODPS    /= y%n_ODPS   ) .OR. &
         (x%n_ODSSU   /= y%n_ODSSU  ) .OR. &
         (x%n_ODZeeman /= y%n_ODZeeman  ) ) RETURN

    ! Check arrays
    IF ( any(x%Algorithm_ID     /= y%Algorithm_ID  )    .OR. & 
         any(x%Sensor_Index     /= y%Sensor_Index  )    .OR. & 
         any(x%Sensor_LoIndex   /= y%Sensor_LoIndex)    .OR. & 
         any(x%ZSensor_LoIndex  /= y%ZSensor_LoIndex)   .OR. &
         any(x%Sensor_ID        /= y%Sensor_ID)         .OR. &
         any(x%WMO_Satellite_ID /= y%WMO_Satellite_ID)  .OR. &
         any(x%WMO_Sensor_ID    /= y%WMO_Sensor_ID)     .OR. &
         any(x%Sensor_Type      /= y%Sensor_Type)      ) RETURN

    ! Check pointers
    ! .... ? 
    ! Call individual ODAS_Equal, ODPS_Equal and ODSSU_Equal functions?
    ! If so, they must be elemental also!

    ! If we get here, everything is equal!
    is_equal = .true.
    
  END FUNCTION taucoeff_equal

END MODULE taucoeff_define