NLTE_Predictor_Define.f90

Go to the documentation of this file.

!
! NLTE_Predictor_Define
!
! Module defining the NLTE_Predictor data structure and containing routines to 
! manipulate it.
!
! CREATION HISTORY:
!       Written by:  Paul van Delst, 16-Mar-2011
!                    paul.vandelst@noaa.gov
!

MODULE nlte_predictor_define

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module use
  USE type_kinds,            ONLY: fp
  USE message_handler      , ONLY: success, failure, information, display_message
  USE compare_float_numbers, ONLY: default_n_sigfig, &
                                   OPERATOR(.equalto.), &
                                   compares_within_tolerance
  USE nlte_parameters      , ONLY: n_nlte_layers, n_nlte_predictors
  ! Disable implicit typing
  IMPLICIT NONE


  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Datatypes
  PUBLIC :: nlte_predictor_type
  ! Operators
  PUBLIC :: OPERATOR(==)
  ! Procedures
  PUBLIC :: nlte_predictor_destroy
  PUBLIC :: nlte_predictor_inspect
  PUBLIC :: nlte_predictor_validrelease
  PUBLIC :: nlte_predictor_info
  PUBLIC :: nlte_predictor_defineversion
  PUBLIC :: nlte_predictor_compare
  PUBLIC :: nlte_predictor_isactive


  ! ---------------------
  ! Procedure overloading
  ! ---------------------
  INTERFACE OPERATOR(==)
    MODULE PROCEDURE nlte_predictor_equal
  END INTERFACE OPERATOR(==)


  ! -----------------
  ! Module parameters
  ! -----------------
  ! Version Id for the module
  CHARACTER(*), PARAMETER :: module_version_id = &
  '$Id: NLTE_Predictor_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $'
  ! Literal constants
  REAL(fp), PARAMETER :: zero = 0.0_fp
  REAL(fp), PARAMETER :: one  = 1.0_fp
  ! Default message string length
  INTEGER, PARAMETER :: ml = 512
  ! Sensor id string length
  INTEGER, PARAMETER :: sl = 20
  ! Current valid release and version numbers
  INTEGER, PARAMETER :: nlte_predictor_release = 1
  INTEGER, PARAMETER :: nlte_predictor_version = 1


  ! -----------------------
  ! Derived type definition
  ! -----------------------
  TYPE :: nlte_predictor_type
    ! Allocation indicator
    LOGICAL :: is_allocated = .true.
    ! Release and version information
    INTEGER :: release = nlte_predictor_release
    INTEGER :: version = nlte_predictor_version
    ! Dimensions
    INTEGER :: n_layers     = n_nlte_layers
    INTEGER :: n_predictors = n_nlte_layers + 1
    ! Logical indicators
    ! ...In-use indicator
    LOGICAL :: is_active = .false.
    ! ...Computation indicator
    LOGICAL :: compute_tm = .true.
    ! Data
    INTEGER :: k1(n_nlte_layers) = 0  ! Indices of atmosphere for upper layer
    INTEGER :: k2(n_nlte_layers) = 0  ! Indices of atmosphere for lower layer
    INTEGER :: isen = 0               ! Indices of coefficients for user sensor zenith angle
    INTEGER :: isol = 0               ! Indices of coefficients for user solar  zenith angle
    REAL(fp) :: tm(n_nlte_layers)            = zero  ! Mean layer temperature
    REAL(fp) :: predictor(n_nlte_layers + 1) = zero  ! Predictors
    REAL(fp) :: w(2, 2)                      = zero  ! Coefficient bilinear interpolation weights
  END TYPE nlte_predictor_type


CONTAINS


!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTE_Predictor_Destroy
! 
! PURPOSE:
!       Elemental subroutine to re-initialize NLTE_Predictor objects.
!
! CALLING SEQUENCE:
!       CALL NLTE_Predictor_Destroy( NLTE_Predictor )
!
! OBJECTS:
!       NLTE_Predictor:  Re-initialized NLTE_Predictor structure.
!                        UNITS:      N/A
!                        TYPE:       NLTE_Predictor_type
!                        DIMENSION:  Scalar or any rank
!                        ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE nlte_predictor_destroy( NLTE_Predictor )
    TYPE(nlte_predictor_type), INTENT(OUT) :: nlte_predictor
    ! Set logicals to avoid "unused argument" warnings
    nlte_predictor%Is_Active  = .false.
    nlte_predictor%Compute_Tm = .true.
  END SUBROUTINE nlte_predictor_destroy


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTE_Predictor_Inspect
!
! PURPOSE:
!       Subroutine to print the contents of a NLTE_Predictor object to stdout.
!
! CALLING SEQUENCE:
!       CALL NLTE_Predictor_Inspect( NLTE_Predictor )
!
! OBJECTS:
!       NLTE_Predictor:  NLTE_Predictor object to display.
!                        UNITS:      N/A
!                        TYPE:       NLTE_Predictor_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE nlte_predictor_inspect( NLTE_Predictor )
    TYPE(nlte_predictor_type), INTENT(IN) :: nlte_predictor
    WRITE(*,'(1x,"NLTE_Predictor OBJECT")')
    ! Release/version info
    WRITE(*,'(3x,"Release.Version  :",1x,i0,".",i0)') nlte_predictor%Release, nlte_predictor%Version
    ! Dimensions
    WRITE(*,'(3x,"n_Layers         :",1x,i0)') nlte_predictor%n_Layers    
    WRITE(*,'(3x,"n_Predictors     :",1x,i0)') nlte_predictor%n_Predictors
    ! Logical indicators
    WRITE(*,'(3x,"Is_Active        :",1x,l1)') nlte_predictor%Is_Active 
    WRITE(*,'(3x,"Compute_Tm       :",1x,l1)') nlte_predictor%Compute_Tm
    ! Data
    WRITE(*,'(3x,"k1        :",4(1x,i0,:,","))') nlte_predictor%k1
    WRITE(*,'(3x,"k2        :",4(1x,i0,:,","))') nlte_predictor%k2
    WRITE(*,'(3x,"isen      :",1x,i0)') nlte_predictor%isen
    WRITE(*,'(3x,"isol      :",1x,i0)') nlte_predictor%isol
    WRITE(*,'(3x,"Tm        :")')
    WRITE(*,'(5(1x,es13.6,:))') nlte_predictor%Tm
    WRITE(*,'(3x,"Predictor :")')
    WRITE(*,'(5(1x,es13.6,:))') nlte_predictor%Predictor
    WRITE(*,'(3x,"w         :")')
    WRITE(*,'(5(1x,es13.6,:))') nlte_predictor%w
    
  END SUBROUTINE nlte_predictor_inspect
  
  
!----------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTE_Predictor_ValidRelease
!
! PURPOSE:
!       Function to check the NLTE_Predictor Release value.
!
! CALLING SEQUENCE:
!       IsValid = NLTE_Predictor_ValidRelease( NLTE_Predictor )
!
! INPUTS:
!       NLTE_Predictor:  NLTE_Predictor object for which the Release component
!                        is to be checked.
!                        UNITS:      N/A
!                        TYPE:       NLTE_Predictor_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       IsValid:         Logical value defining the release validity.
!                        UNITS:      N/A
!                        TYPE:       LOGICAL
!                        DIMENSION:  Scalar
!
!:sdoc-:
!----------------------------------------------------------------------------------

  FUNCTION nlte_predictor_validrelease( NLTE_Predictor ) RESULT( IsValid )
    ! Arguments
    TYPE(nlte_predictor_type), INTENT(IN) :: nlte_predictor
    ! Function result
    LOGICAL :: isvalid
    ! Local parameters
    CHARACTER(*), PARAMETER :: routine_name = 'NLTE_Predictor_ValidRelease'
    ! Local variables
    CHARACTER(ML) :: msg

    ! Set up
    isvalid = .true.


    ! Check release is not too old
    IF ( nlte_predictor%Release < nlte_predictor_release ) THEN
      isvalid = .false.
      WRITE( msg,'("An NLTE_Predictor data update is needed. ", &
                  &"NLTE_Predictor release is ",i0,". Valid release is ",i0,"." )' ) &
                  nlte_predictor%Release, nlte_predictor_release
      CALL display_message( routine_name, msg, information )
      RETURN
    END IF


    ! Check release is not too new
    IF ( nlte_predictor%Release > nlte_predictor_release ) THEN
      isvalid = .false.
      WRITE( msg,'("An NLTE_Predictor software update is needed. ", &
                  &"NLTE_Predictor release is ",i0,". Valid release is ",i0,"." )' ) &
                  nlte_predictor%Release, nlte_predictor_release
      CALL display_message( routine_name, msg, information )
      RETURN
    END IF

  END FUNCTION nlte_predictor_validrelease


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTE_Predictor_Info
!
! PURPOSE:
!       Subroutine to return a string containing version and dimension
!       information about a NLTE_Predictor object.
!
! CALLING SEQUENCE:
!       CALL NLTE_Predictor_Info( NLTE_Predictor, Info )
!
! OBJECTS:
!       NLTE_Predictor:  NLTE_Predictor object about which info is required.
!                        UNITS:      N/A
!                        TYPE:       NLTE_Predictor_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Info:            String containing version and dimension information
!                        about the NLTE_Predictor object.
!                        UNITS:      N/A
!                        TYPE:       CHARACTER(*)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE nlte_predictor_info( NLTE_Predictor, Info )
    ! Arguments
    TYPE(nlte_predictor_type), INTENT(IN)  :: nlte_predictor
    CHARACTER(*),              INTENT(OUT) :: info
    ! Parameters
    INTEGER, PARAMETER :: carriage_return = 13
    INTEGER, PARAMETER :: linefeed = 10
    ! Local variables
    CHARACTER(2000) :: long_string

    ! Write the required data to the local string
    WRITE( long_string, &
           '(a,1x,"NLTE_Predictor RELEASE.VERSION: ",i2,".",i2.2,a,3x, &
           &"N_LAYERS=",i0,2x,&
           &"N_PREDICTORS=",i0 )' ) &
           achar(carriage_return)//achar(linefeed), &
           nlte_predictor%Release, nlte_predictor%Version, &
           achar(carriage_return)//achar(linefeed), &
           nlte_predictor%n_Layers    , &
           nlte_predictor%n_Predictors
                       
    ! Trim the output based on the
    ! dummy argument string length
    info = long_string(1:min(len(info), len_trim(long_string)))

  END SUBROUTINE nlte_predictor_info
 
 
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTE_Predictor_DefineVersion
!
! PURPOSE:
!       Subroutine to return the module version information.
!
! CALLING SEQUENCE:
!       CALL NLTE_Predictor_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 nlte_predictor_defineversion( Id )
    CHARACTER(*), INTENT(OUT) :: id
    id = module_version_id
  END SUBROUTINE nlte_predictor_defineversion


!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       NLTE_Predictor_Compare
!
! PURPOSE:
!       Elemental function to compare two NLTE_Predictor objects to within
!       a user specified number of significant figures.
!
! CALLING SEQUENCE:
!       is_comparable = NLTE_Predictor_Compare( x, y, n_SigFig=n_SigFig )
!
! OBJECTS:
!       x, y:          Two NLTE_Predictor objects to be compared.
!                      UNITS:      N/A
!                      TYPE:       NLTE_Predictor_type
!                      DIMENSION:  Scalar or any rank
!                      ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
!       n_SigFig:      Number of significant figure to compare floating point
!                      components.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar or same as input
!                      ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       is_equal:      Logical value indicating whether the inputs are equal.
!                      UNITS:      N/A
!                      TYPE:       LOGICAL
!                      DIMENSION:  Same as inputs.
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL FUNCTION nlte_predictor_compare( &
    x, &
    y, &
    n_SigFig ) &
  result( is_comparable )
    TYPE(nlte_predictor_type), INTENT(IN) :: x, y
    INTEGER,         OPTIONAL, INTENT(IN) :: n_sigfig
    LOGICAL :: is_comparable
    ! Variables
    INTEGER :: n

    ! Set up
    is_comparable = .false.
    IF ( PRESENT(n_sigfig) ) THEN
      n = abs(n_sigfig)
    ELSE
      n = default_n_sigfig
    END IF
    
    ! Check contents
    ! ...Release/version info
    IF ( (x%Release /= y%Release) .OR. &
         (x%Version /= y%Version) ) RETURN
    ! ...Dimensions
    IF ( (x%n_Layers     /= y%n_Layers     ) .OR. &
         (x%n_Predictors /= y%n_Predictors ) ) RETURN
    ! ...Scalars
    IF ( (x%Is_Active  .NEQV. y%Is_Active ) .OR. &
         (x%Compute_Tm .NEQV. y%Compute_Tm) .OR. &
         (x%isen         /=   y%isen      ) .OR. &
         (x%isol         /=   y%isol      ) ) RETURN
    ! ...Integer arrays
    IF ( any(x%k1 /= y%k1) .AND. any(x%k2 /= y%k2) ) RETURN
    ! ...Floating point arrays
    IF ( (.NOT. all(compares_within_tolerance(x%Tm       , y%Tm       , n))) .OR. &
         (.NOT. all(compares_within_tolerance(x%Predictor, y%Predictor, n))) .OR. &
         (.NOT. all(compares_within_tolerance(x%w        , y%w        , n))) ) RETURN

    ! If we get here, the structures are comparable
    is_comparable = .true.
    
  END FUNCTION nlte_predictor_compare


!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       NLTE_Predictor_IsActive
!
! PURPOSE:
!       Elemental function to determine if an NLTE_Predictor object is
!       active and valid for use in NLTE correction.
!
! CALLING SEQUENCE:
!       is_active = NLTE_Predictor_IsActive( NLTE_Predictor )
!
! OBJECTS:
!       NLTE_Predictor:  NLTE_Predictor object to be tested.
!                        UNITS:      N/A
!                        TYPE:       NLTE_Predictor_type
!                        DIMENSION:  Scalar or any rank
!                        ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       is_active:     Logical value indicating whether the input predictor
!                      is active and valid for use.
!                      UNITS:      N/A
!                      TYPE:       LOGICAL
!                      DIMENSION:  Same as inputs.
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL FUNCTION nlte_predictor_isactive( NLTE_Predictor ) RESULT( Is_Active )
    TYPE(nlte_predictor_type), INTENT(IN) :: nlte_predictor
    LOGICAL :: is_active
    is_active = nlte_predictor%Is_Active
  END FUNCTION nlte_predictor_isactive


!##################################################################################
!##################################################################################
!##                                                                              ##
!##                          ## PRIVATE MODULE ROUTINES ##                       ##
!##                                                                              ##
!##################################################################################
!##################################################################################

!------------------------------------------------------------------------------
!
! NAME:
!       NLTE_Predictor_Equal
!
! PURPOSE:
!       Elemental function to test the equality of two NLTE_Predictor objects.
!       Used in OPERATOR(==) interface block.
!
! CALLING SEQUENCE:
!       is_equal = NLTE_Predictor_Equal( x, y )
!
!         or
!
!       IF ( x == y ) THEN
!         ...
!       END IF
!
! OBJECTS:
!       x, y:          Two NLTE_Predictor objects to be compared.
!                      UNITS:      N/A
!                      TYPE:       NLTE_Predictor_type
!                      DIMENSION:  Scalar or any rank
!                      ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       is_equal:      Logical value indicating whether the inputs are equal.
!                      UNITS:      N/A
!                      TYPE:       LOGICAL
!                      DIMENSION:  Same as inputs.
!
!------------------------------------------------------------------------------

  ELEMENTAL FUNCTION nlte_predictor_equal( x, y ) RESULT( is_equal )
    TYPE(nlte_predictor_type), INTENT(IN) :: x, y
    LOGICAL :: is_equal

    ! Set up
    is_equal = .false.
   
    ! Check contents
    ! ...Release/version info
    IF ( (x%Release /= y%Release) .OR. &
         (x%Version /= y%Version) ) RETURN
    ! ...Dimensions
    IF ( (x%n_Layers     /= y%n_Layers     ) .OR. &
         (x%n_Predictors /= y%n_Predictors ) ) RETURN
    ! ...Scalars
    IF ( (x%Is_Active  .NEQV. y%Is_Active ) .OR. &
         (x%Compute_Tm .NEQV. y%Compute_Tm) .OR. &
         (x%isen         /=   y%isen      ) .OR. &
         (x%isol         /=   y%isol      ) ) RETURN
    ! ...Arrays
    IF ( all(x%k1           ==     y%k1       ) .AND. &
         all(x%k2           ==     y%k2       ) .AND. &
         all(x%Tm        .equalto. y%Tm       ) .AND. &
         all(x%Predictor .equalto. y%Predictor) .AND. &
         all(x%w         .equalto. y%w        ) ) &
      is_equal = .true.

  END FUNCTION nlte_predictor_equal

END MODULE nlte_predictor_define