<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
!
! NLTECoeff_Define
!
! Module defining the NLTECoeff structure and containing routines to
! manipulate it.
!
!
! CREATION HISTORY:
! Written by: Yong Han, 08-05-2010
! yong.han@noaa.gov
!
! Refactored by: Paul van Delst, 19-Jan-2011
! paul.vandelst@noaa.gov
!
<A NAME='NLTECOEFF_DEFINE'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_DEFINE' TARGET='top_target'><IMG SRC="../../gif/bar_purple.gif" border=0></A>
MODULE NLTECoeff_Define 8,7
! -----------------
! Environment setup
! -----------------
! Module use
USE Type_Kinds
, ONLY: Long, Double
USE Message_Handler , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message
USE Compare_Float_Numbers, ONLY: OPERATOR(.EqualTo.)
USE Subset_Define , ONLY: Subset_type , &
Subset_Associated, &
Subset_GetValue , &
Subset_Generate
USE SensorInfo_Parameters, ONLY: INVALID_WMO_SATELLITE_ID, &
INVALID_WMO_SENSOR_ID
! Disable implicit typing
IMPLICIT NONE
! ------------
! Visibilities
! ------------
! Everything private by default
PRIVATE
! Datatypes
PUBLIC :: NLTECoeff_type
! Operators
PUBLIC :: OPERATOR(==)
! Procedures
PUBLIC :: NLTECoeff_Associated
PUBLIC :: NLTECoeff_Destroy
PUBLIC :: NLTECoeff_Create
PUBLIC :: NLTECoeff_Inspect
PUBLIC :: NLTECoeff_ValidRelease
PUBLIC :: NLTECoeff_Info
PUBLIC :: NLTECoeff_DefineVersion
PUBLIC :: NLTECoeff_Subset
PUBLIC :: NLTECoeff_Concat
PUBLIC :: NLTECoeff_ChannelReindex
! ---------------------
! Procedure overloading
! ---------------------
<A NAME='OPERATOR'><A href='../../html_code/crtm/NLTECoeff_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
! -----------------
! Version Id for the module
CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
'$Id: NLTECoeff_Define.f90 29405 2013-06-20 20:19:52Z paul.vandelst@noaa.gov $'
! Literal constants
REAL(Double), PARAMETER :: ZERO = 0.0_Double
REAL(Double), PARAMETER :: ONE = 1.0_Double
! Default message string length
INTEGER, PARAMETER :: ML = 512
! Sensor id string length
INTEGER, PARAMETER :: SL = 20
! Current valid release and version numbers
INTEGER, PARAMETER :: NLTECOEFF_RELEASE = 2 ! This determines structure and file formats.
INTEGER, PARAMETER :: NLTECOEFF_VERSION = 1 ! This is just the data version.
! Number of layers for which mean temperatures are computed
INTEGER, PARAMETER :: N_LAYERS = 2
! Integer flags corresponding to logical false/true
INTEGER, PARAMETER :: FALSE = 0
INTEGER, PARAMETER :: TRUE = 1
! -----------------------
! Derived type definition
! -----------------------
TYPE :: NLTECoeff_type
! Allocation indicator
LOGICAL :: Is_Allocated = .FALSE.
! Release and version information
INTEGER(Long) :: Release = NLTECOEFF_RELEASE
INTEGER(Long) :: Version = NLTECOEFF_VERSION
! Dimensions
INTEGER(Long) :: n_Predictors = 0 ! n1 dimension
INTEGER(Long) :: n_Sensor_Angles = 0 ! n2 dimension
INTEGER(Long) :: n_Solar_Angles = 0 ! n3 dimension
INTEGER(Long) :: n_NLTE_Channels = 0 ! n4 dimension
INTEGER(Long) :: n_Channels = 0 ! n5 dimension
! ..."Internal" dimension
!What is this line for??? INTEGER(Long) :: n_Layers = N_LAYERS
! Sensor info
CHARACTER(SL) :: Sensor_Id = ''
INTEGER(Long) :: WMO_Satellite_ID = INVALID_WMO_SATELLITE_ID
INTEGER(Long) :: WMO_Sensor_ID = INVALID_WMO_SENSOR_ID
INTEGER(Long), ALLOCATABLE :: Sensor_Channel(:) ! n5
! Pressure levels used for computing mean temperatures in the two layers
REAL(Double) :: Upper_Plevel(N_LAYERS) = ZERO
REAL(Double) :: Lower_Plevel(N_LAYERS) = ZERO
! Min., max. and mean layer temperatures used as the temperature predictor limits
REAL(Double) :: Min_Tm(N_LAYERS) = ZERO
REAL(Double) :: Max_Tm(N_LAYERS) = ZERO
REAL(Double) :: Mean_Tm(N_LAYERS) = ZERO
! Coefficient table dimension vectors
REAL(Double) , ALLOCATABLE :: Secant_Sensor_Zenith(:) ! n2
REAL(Double) , ALLOCATABLE :: Secant_Solar_Zenith(:) ! n3
INTEGER(Long), ALLOCATABLE :: NLTE_Channel(:) ! n4
LOGICAL , ALLOCATABLE :: Is_NLTE_Channel(:) ! n5
! Coefficients for NLTE corrections
INTEGER(Long), ALLOCATABLE :: C_Index(:) ! n5
REAL(Double) , ALLOCATABLE :: C(:,:,:,:) ! n1 x n2 x n3 x n4
END TYPE NLTECoeff_type
CONTAINS
!################################################################################
!################################################################################
!## ##
!## ## PUBLIC MODULE ROUTINES ## ##
!## ##
!################################################################################
!################################################################################
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! NLTECoeff_Associated
!
! PURPOSE:
! Elemental function to test the status of the allocatable components
! of the NLTECoeff structure.
!
! CALLING SEQUENCE:
! Status = NLTECoeff_Associated( NLTECoeff )
!
! OBJECTS:
! NLTECoeff: Structure which is to have its member's
! status tested.
! UNITS: N/A
! TYPE: NLTECoeff_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! Status: The return value is a logical value indicating the
! status of the NLTE members.
! .TRUE. - if ANY of the NLTECoeff allocatable members
! are in use.
! .FALSE. - if ALL of the NLTECoeff allocatable members
! are not in use.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Same as input
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='NLTECOEFF_ASSOCIATED'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_ASSOCIATED' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION NLTECoeff_Associated( NLTECoeff ) RESULT( Status ) 1
TYPE(NLTECoeff_type), INTENT(IN) :: NLTECoeff
LOGICAL :: Status
Status = NLTECoeff%Is_Allocated
END FUNCTION NLTECoeff_Associated
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! NLTECoeff_Destroy
!
! PURPOSE:
! Elemental subroutine to re-initialize NLTECoeff objects.
!
! CALLING SEQUENCE:
! CALL NLTECoeff_Destroy( NLTECoeff )
!
! OBJECTS:
! NLTECoeff: Re-initialized NLTECoeff structure.
! UNITS: N/A
! TYPE: NLTECoeff_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='NLTECOEFF_DESTROY'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_DESTROY' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
ELEMENTAL SUBROUTINE NLTECoeff_Destroy( NLTECoeff ) 2
TYPE(NLTECoeff_type), INTENT(OUT) :: NLTECoeff
NLTECoeff%Is_Allocated = .FALSE.
NLTECoeff%n_Predictors = 0
NLTECoeff%n_Sensor_Angles = 0
NLTECoeff%n_Solar_Angles = 0
NLTECoeff%n_NLTE_Channels = 0
NLTECoeff%n_Channels = 0
NLTECoeff%Sensor_Id = ''
NLTECoeff%WMO_Satellite_ID = INVALID_WMO_SATELLITE_ID
NLTECoeff%WMO_Sensor_ID = INVALID_WMO_SENSOR_ID
END SUBROUTINE NLTECoeff_Destroy
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! NLTECoeff_Create
!
! PURPOSE:
! Elemental subroutine to create an instance of an NLTECoeff object.
!
! CALLING SEQUENCE:
! CALL NLTECoeff_Create( NLTECoeff , &
! n_Predictors , &
! n_Sensor_Angles , &
! n_Solar_Angles , &
! n_NLTE_Channels , &
! n_Channels )
!
! OBJECTS:
! NLTECoeff: NLTECoeff object structure.
! UNITS: N/A
! TYPE: NLTECoeff_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
! n_Predictors: Number of predictors used in NLTE correction algorithm.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Same as the NLTECoeff object
! ATTRIBUTES: INTENT(IN)
!
! n_Sensor_Angles: Number of sensor zenith angles.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Same as the NLTECoeff object
! ATTRIBUTES: INTENT(IN)
!
! n_Solar_Angles: Number of solar zenith angles.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Same as the NLTECoeff object
! ATTRIBUTES: INTENT(IN)
!
! n_NLTE_Channels: Number of NLTE channels for the sensor.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Same as the NLTECoeff object
! ATTRIBUTES: INTENT(IN)
!
! n_Channels: Total number of channels for the sensor.
! Must be >= n_NLTE_Channels.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Same as NLTECoeff object
! ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='NLTECOEFF_CREATE'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_CREATE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
ELEMENTAL SUBROUTINE NLTECoeff_Create( & 4
NLTECoeff , & ! Output
n_Predictors , & ! Input
n_Sensor_Angles , & ! Input
n_Solar_Angles , & ! Input
n_NLTE_Channels , & ! Input
n_Channels ) ! Input
! Arguments
TYPE(NLTECoeff_type), INTENT(OUT) :: NLTECoeff
INTEGER , INTENT(IN) :: n_Predictors
INTEGER , INTENT(IN) :: n_Sensor_Angles
INTEGER , INTENT(IN) :: n_Solar_Angles
INTEGER , INTENT(IN) :: n_NLTE_Channels
INTEGER , INTENT(IN) :: n_Channels
! Local variables
INTEGER :: alloc_stat
! Check input
IF ( n_Predictors < 1 .OR. &
n_Sensor_Angles < 1 .OR. &
n_Solar_Angles < 1 .OR. &
n_NLTE_Channels < 1 .OR. &
n_Channels < n_NLTE_Channels ) RETURN
! Perform the allocation
ALLOCATE( NLTECoeff%Sensor_Channel( n_Channels ), &
NLTECoeff%Secant_Sensor_Zenith( n_Sensor_Angles ), &
NLTECoeff%Secant_Solar_Zenith( n_Solar_Angles ), &
NLTECoeff%NLTE_Channel( n_NLTE_Channels ), &
NLTECoeff%Is_NLTE_Channel( n_Channels ), &
NLTECoeff%C_Index( n_Channels ), &
NLTECoeff%C( n_Predictors, n_Sensor_Angles, n_Solar_Angles, n_NLTE_Channels ), &
STAT = alloc_stat )
IF ( alloc_stat /= 0 ) RETURN
! Initialise
! ...Dimensions
NLTECoeff%n_Predictors = n_Predictors
NLTECoeff%n_Sensor_Angles = n_Sensor_Angles
NLTECoeff%n_Solar_Angles = n_Solar_Angles
NLTECoeff%n_NLTE_Channels = n_NLTE_Channels
NLTECoeff%n_Channels = n_Channels
! ...Arrays
NLTECoeff%Sensor_Channel = 0
NLTECoeff%Secant_Sensor_Zenith = ZERO
NLTECoeff%Secant_Solar_Zenith = ZERO
NLTECoeff%NLTE_Channel = 0
NLTECoeff%Is_NLTE_Channel = .FALSE.
NLTECoeff%C_Index = 0
NLTECoeff%C = ZERO
! Set allocation indicator
NLTECoeff%Is_Allocated = .TRUE.
END SUBROUTINE NLTECoeff_Create
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! NLTECoeff_Inspect
!
! PURPOSE:
! Subroutine to print the contents of a NLTECoeff object to stdout.
!
! CALLING SEQUENCE:
! CALL NLTECoeff_Inspect( NLTECoeff )
!
! OBJECTS:
! NLTECoeff: NLTECoeff object to display.
! UNITS: N/A
! TYPE: NLTECoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='NLTECOEFF_INSPECT'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_INSPECT' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE NLTECoeff_Inspect( NLTECoeff ) 1
TYPE(NLTECoeff_type), INTENT(IN) :: NLTECoeff
INTEGER :: i
CHARACTER(3) :: maybe
WRITE(*,'(1x,"NLTECoeff OBJECT")')
! Release/version info
WRITE(*,'(3x,"Release.Version :",1x,i0,".",i0)') NLTECoeff%Release, NLTECoeff%Version
! Dimensions
WRITE(*,'(3x,"n_Predictors :",1x,i0)') NLTECoeff%n_Predictors
WRITE(*,'(3x,"n_Sensor_Angles :",1x,i0)') NLTECoeff%n_Sensor_Angles
WRITE(*,'(3x,"n_Solar_Angles :",1x,i0)') NLTECoeff%n_Solar_Angles
WRITE(*,'(3x,"n_NLTE_Channels :",1x,i0)') NLTECoeff%n_NLTE_Channels
WRITE(*,'(3x,"n_Channels :",1x,i0)') NLTECoeff%n_Channels
IF ( .NOT. NLTECoeff_Associated(NLTECoeff) ) RETURN
! Sensor info
WRITE(*,'(3x,"Sensor_Id :",1x,a )') TRIM(NLTECoeff%Sensor_Id)
WRITE(*,'(3x,"WMO_Satellite_ID :",1x,i0)') NLTECoeff%WMO_Satellite_ID
WRITE(*,'(3x,"WMO_Sensor_ID :",1x,i0)') NLTECoeff%WMO_Sensor_ID
WRITE(*,'(3x,"Sensor_Channel :")')
WRITE(*,'(10(1x,i5,:))') NLTECoeff%Sensor_Channel
! Pressure arrays
WRITE(*,'(3x,"Upper_Plevel :")')
WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Upper_Plevel
WRITE(*,'(3x,"Lower_Plevel :")')
WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Lower_Plevel
! Temperature arrays
WRITE(*,'(3x,"Min_Tm :")')
WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Min_Tm
WRITE(*,'(3x,"Max_Tm :")')
WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Max_Tm
WRITE(*,'(3x,"Mean_Tm :")')
WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Mean_Tm
! Coefficient table dimension vectors
WRITE(*,'(3x,"Secant_Sensor_Zenith :")')
WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Secant_Sensor_Zenith
WRITE(*,'(3x,"Secant_Solar_Zenith :")')
WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Secant_Solar_Zenith
WRITE(*,'(3x,"NLTE_Channel :")')
WRITE(*,'(10(1x,i5,:))') NLTECoeff%NLTE_Channel
! NLTE channel flag
WRITE(*,'(3x,"NLTE_Channel_Flag :")')
DO i = 1, NLTECoeff%n_Channels
IF ( MOD(i,5) == 0 .OR. i == NLTECoeff%n_Channels ) THEN
maybe = 'yes'
ELSE
maybe = 'no'
END IF
WRITE(*,FMT='(1x,i5,":",l1,", c-index: ",i0)',ADVANCE=maybe) NLTECoeff%Sensor_Channel(i), &
NLTECoeff%Is_NLTE_Channel(i), &
NLTECoeff%C_Index(i)
END DO
! Coefficient data
WRITE(*,'(3x,"NLTE correction coefficients :")')
WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%C
END SUBROUTINE NLTECoeff_Inspect
!----------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! NLTECoeff_ValidRelease
!
! PURPOSE:
! Function to check the NLTECoeff Release value.
!
! CALLING SEQUENCE:
! IsValid = NLTECoeff_ValidRelease( NLTECoeff )
!
! INPUTS:
! NLTECoeff: NLTECoeff object for which the Release component
! is to be checked.
! UNITS: N/A
! TYPE: NLTECoeff_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='NLTECOEFF_VALIDRELEASE'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_VALIDRELEASE' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION NLTECoeff_ValidRelease( NLTECoeff ) RESULT( IsValid ),2
! Arguments
TYPE(NLTECoeff_type), INTENT(IN) :: NLTECoeff
! Function result
LOGICAL :: IsValid
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'NLTECoeff_ValidRelease'
! Local variables
CHARACTER(ML) :: msg
! Set up
IsValid = .TRUE.
! Check release is not too old
IF ( NLTECoeff%Release < NLTECOEFF_RELEASE ) THEN
IsValid = .FALSE.
WRITE( msg,'("A NLTECoeff data update is needed. ", &
&"NLTECoeff release is ",i0,". Valid release is ",i0,"." )' ) &
NLTECoeff%Release, NLTECOEFF_RELEASE
CALL Display_Message( ROUTINE_NAME, msg, INFORMATION )
RETURN
END IF
! Check release is not too new
IF ( NLTECoeff%Release > NLTECOEFF_RELEASE ) THEN
IsValid = .FALSE.
WRITE( msg,'("A NLTECoeff software update is needed. ", &
&"NLTECoeff release is ",i0,". Valid release is ",i0,"." )' ) &
NLTECoeff%Release, NLTECOEFF_RELEASE
CALL Display_Message( ROUTINE_NAME, msg, INFORMATION )
RETURN
END IF
END FUNCTION NLTECoeff_ValidRelease
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! NLTECoeff_Info
!
! PURPOSE:
! Subroutine to return a string containing version and dimension
! information about a NLTECoeff object.
!
! CALLING SEQUENCE:
! CALL NLTECoeff_Info( NLTECoeff, Info )
!
! OBJECTS:
! NLTECoeff: NLTECoeff object about which info is required.
! UNITS: N/A
! TYPE: NLTECoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
! Info: String containing version and dimension information
! about the NLTECoeff object.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='NLTECOEFF_INFO'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_INFO' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE NLTECoeff_Info( NLTECoeff, Info ) 3
! Arguments
TYPE(NLTECoeff_type), INTENT(IN) :: NLTECoeff
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,"NLTECoeff RELEASE.VERSION: ",i2,".",i2.2,a,3x, &
&"N_PREDICTORS=",i0,2x,&
&"N_SENSOR_ANGLES=",i0,2x,&
&"N_SOLAR_ANGLES=",i0,2x,&
&"N_NLTE_CHANNELS=",i0,2x,&
&"N_CHANNELS=",i0 )' ) &
ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), &
NLTECoeff%Release, NLTECoeff%Version, &
ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), &
NLTECoeff%n_Predictors , &
NLTECoeff%n_Sensor_Angles , &
NLTECoeff%n_Solar_Angles , &
NLTECoeff%n_NLTE_Channels , &
NLTECoeff%n_Channels
! Trim the output based on the
! dummy argument string length
Info = Long_String(1:MIN(LEN(Info), LEN_TRIM(Long_String)))
END SUBROUTINE NLTECoeff_Info
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! NLTECoeff_DefineVersion
!
! PURPOSE:
! Subroutine to return the module version information.
!
! CALLING SEQUENCE:
! CALL NLTECoeff_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='NLTECOEFF_DEFINEVERSION'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_DEFINEVERSION' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE NLTECoeff_DefineVersion( Id ) 1
CHARACTER(*), INTENT(OUT) :: Id
Id = MODULE_VERSION_ID
END SUBROUTINE NLTECoeff_DefineVersion
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! NLTECoeff_Subset
!
! PURPOSE:
! Subroutine to return a channel subset of the input NLTECoeff object.
!
! CALLING SEQUENCE:
! CALL NLTECoeff_Subset( NLTECoeff, Subset, NC_Subset )
!
! OBJECTS:
! NLTECoeff: NLTECoeff object which is to be subsetted.
! UNITS: N/A
! TYPE: NLTECoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! INPUTS:
! Subset: Subset object containing the list of indices
! corresponding the channels to be extracted.
! UNITS: N/A
! TYPE: Subset_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
! NC_Subset: NLTECoeff object containing the requested channel subset
! of the input NLTECoeff data.
! UNITS: N/A
! TYPE: NLTECoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='NLTECOEFF_SUBSET'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_SUBSET' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE NLTECoeff_Subset( & 1,6
NLTECoeff , & ! Input
Sensor_Channel, & ! Input
NC_Subset ) ! Output
! Arguments
TYPE(NLTECoeff_type), INTENT(IN) :: NLTECoeff
INTEGER , INTENT(IN) :: Sensor_Channel(:)
TYPE(NLTECoeff_type), INTENT(OUT) :: NC_Subset
! Local variables
TYPE(Subset_type) :: subset, nlte_subset
INTEGER :: n_subset_channels, n_nlte_subset_channels
INTEGER, ALLOCATABLE :: idx(:), nlte_idx(:)
! Check input is valid
IF ( .NOT. NLTECoeff_Associated(NLTECoeff) ) RETURN
! Generate the channel subset list
CALL Subset_Generate( &
subset, &
NLTECoeff%Sensor_Channel, &
Sensor_Channel )
IF ( .NOT. Subset_Associated( subset ) ) RETURN
! ...Generate the NLTE channel subset list
! ...(which is itself a subset of the sensor channel list)
CALL Subset_Generate( &
nlte_subset, &
NLTECoeff%NLTE_Channel, &
Sensor_Channel )
IF ( .NOT. Subset_Associated( nlte_subset ) ) RETURN
! Allocate the output subset NLTECoeff object
CALL Subset_GetValue( subset , n_Values = n_subset_channels , Index = idx )
CALL Subset_GetValue( nlte_subset, n_Values = n_nlte_subset_channels, Index = nlte_idx )
CALL NLTECoeff_Create( &
NC_Subset , &
NLTECoeff%n_Predictors , &
NLTECoeff%n_Sensor_Angles, &
NLTECoeff%n_Solar_Angles , &
n_nlte_subset_channels , &
n_subset_channels )
IF ( .NOT. NLTECoeff_Associated(NC_Subset) ) RETURN
! Extract out the subset channels
! ...First assign the non-channel dependent data
NC_Subset%Version = NLTECoeff%Version
NC_Subset%Sensor_Id = NLTECoeff%Sensor_Id
NC_Subset%WMO_Satellite_ID = NLTECoeff%WMO_Satellite_ID
NC_Subset%WMO_Sensor_ID = NLTECoeff%WMO_Sensor_ID
NC_Subset%Upper_Plevel = NLTECoeff%Upper_Plevel
NC_Subset%Lower_Plevel = NLTECoeff%Lower_Plevel
NC_Subset%Min_Tm = NLTECoeff%Min_Tm
NC_Subset%Max_Tm = NLTECoeff%Max_Tm
NC_Subset%Mean_Tm = NLTECoeff%Mean_Tm
NC_Subset%Secant_Sensor_Zenith = NLTECoeff%Secant_Sensor_Zenith
NC_Subset%Secant_Solar_Zenith = NLTECoeff%Secant_Solar_Zenith
! ...and now extract the subset
NC_Subset%Sensor_Channel = NLTECoeff%Sensor_Channel(idx)
NC_Subset%NLTE_Channel = NLTECoeff%NLTE_Channel(nlte_idx)
NC_Subset%Is_NLTE_Channel = NLTECoeff%Is_NLTE_Channel(idx)
NC_Subset%C_Index = NLTECoeff%C_Index(idx)
NC_Subset%C = NLTECoeff%C(:,:,:,nlte_idx)
! ...Reindex the correction coefficient index array
CALL NLTECoeff_Reindex( NC_Subset )
END SUBROUTINE NLTECoeff_Subset
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! NLTECoeff_Concat
!
! PURPOSE:
! Subroutine to concatenate multiple NLTECoeff objects along the channel
! dimension into a single NLTECoeff object.
!
! CALLING SEQUENCE:
! CALL NLTECoeff_Concat( NLTECoeff, NC_Array, Sensor_Id=Sensor_Id )
!
! OBJECTS:
! NLTECoeff: NLTECoeff object containing the concatenated result.
! UNITS: N/A
! TYPE: NLTECoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
! NC_Array: Array of NLTECoeff objects to be concatenated.
! UNITS: N/A
! TYPE: NLTECoeff_type
! DIMENSION: Rank-1
! ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
! Sensor_Id: Sensor id character to string to use for the concatenated
! result. If not specified, the sensor id of the first valid
! element of NC_Array is used.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='NLTECOEFF_CONCAT'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_CONCAT' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE NLTECoeff_Concat( & 1,3
NLTECoeff, & ! Output
NC_Array , & ! Input
Sensor_Id ) ! Optional input
! Arguments
TYPE(NLTECoeff_type) , INTENT(OUT) :: NLTECoeff
TYPE(NLTECoeff_type) , INTENT(IN) :: NC_Array(:)
CHARACTER(*), OPTIONAL, INTENT(IN) :: Sensor_Id
! Local variables
INTEGER, ALLOCATABLE :: valid_index(:)
INTEGER :: i, j, n_nc, n_valid, n_channels, n_nlte_channels
INTEGER :: ch1, ch2, nlte_ch1, nlte_ch2
! Set up
! ...Check input is valid
n_nc = SIZE(NC_Array)
IF ( n_nc < 1 ) RETURN
! ...Count valid input
n_valid = COUNT(NLTECoeff_Associated(NC_Array))
IF ( n_valid == 0 ) RETURN
! ...Index the valid input
ALLOCATE( valid_index(n_valid) )
valid_index = PACK( (/(i,i=1,n_nc)/), MASK=NLTECoeff_Associated(NC_Array) )
! ...Check non-channel dimensions and ids
DO j = 1, n_valid
i = valid_index(j)
IF ( NC_Array(i)%n_Predictors /= NC_Array(valid_index(1))%n_Predictors .OR. &
NC_Array(i)%n_Sensor_Angles /= NC_Array(valid_index(1))%n_Sensor_Angles .OR. &
NC_Array(i)%n_Solar_Angles /= NC_Array(valid_index(1))%n_Solar_Angles .OR. &
NC_Array(i)%WMO_Satellite_ID /= NC_Array(valid_index(1))%WMO_Satellite_ID .OR. &
NC_Array(i)%WMO_Sensor_ID /= NC_Array(valid_index(1))%WMO_Sensor_ID ) THEN
RETURN
END IF
END DO
! Sum channel dimensions
n_nlte_channels = SUM(NC_Array(valid_index)%n_NLTE_Channels)
n_channels = SUM(NC_Array(valid_index)%n_Channels)
! Allocate the output concatenated NLTECoeff object
CALL NLTECoeff_Create( &
NLTECoeff , &
NC_Array(valid_index(1))%n_Predictors , &
NC_Array(valid_index(1))%n_Sensor_Angles, &
NC_Array(valid_index(1))%n_Solar_Angles , &
n_nlte_channels , &
n_channels )
IF ( .NOT. NLTECoeff_Associated(NLTECoeff) ) RETURN
! Concatenate the channel data
! ...First assign the non-channel dependent data
NLTECoeff%Version = NC_Array(valid_index(1))%Version
IF ( PRESENT(Sensor_Id) ) THEN
NLTECoeff%Sensor_Id = ADJUSTL(Sensor_Id)
ELSE
NLTECoeff%Sensor_Id = NC_Array(valid_index(1))%Sensor_Id
END IF
NLTECoeff%WMO_Satellite_ID = NC_Array(valid_index(1))%WMO_Satellite_ID
NLTECoeff%WMO_Sensor_ID = NC_Array(valid_index(1))%WMO_Sensor_ID
NLTECoeff%Upper_Plevel = NC_Array(valid_index(1))%Upper_Plevel
NLTECoeff%Lower_Plevel = NC_Array(valid_index(1))%Lower_Plevel
NLTECoeff%Min_Tm = NC_Array(valid_index(1))%Min_Tm
NLTECoeff%Max_Tm = NC_Array(valid_index(1))%Max_Tm
NLTECoeff%Mean_Tm = NC_Array(valid_index(1))%Mean_Tm
NLTECoeff%Secant_Sensor_Zenith = NC_Array(valid_index(1))%Secant_Sensor_Zenith
NLTECoeff%Secant_Solar_Zenith = NC_Array(valid_index(1))%Secant_Solar_Zenith
! ...and now concatenate the channel data
ch1 = 1
nlte_ch1 = 1
DO j = 1, n_valid
i = valid_index(j)
nlte_ch2 = nlte_ch1 + NC_Array(i)%n_NLTE_Channels - 1
ch2 = ch1 + NC_Array(i)%n_Channels - 1
NLTECoeff%Sensor_Channel(ch1:ch2) = NC_Array(i)%Sensor_Channel
NLTECoeff%NLTE_Channel(nlte_ch1:nlte_ch2) = NC_Array(i)%NLTE_Channel
NLTECoeff%Is_NLTE_Channel(ch1:ch2) = NC_Array(i)%Is_NLTE_Channel
NLTECoeff%C_Index(ch1:ch2) = NC_Array(i)%C_Index
NLTECoeff%C(:,:,:,nlte_ch1:nlte_ch2) = NC_Array(i)%C
nlte_ch1 = nlte_ch2 + 1
ch1 = ch2 + 1
END DO
! ...Reindex the correction coefficient index array
CALL NLTECoeff_Reindex( NLTECoeff )
! Cleanup
DEALLOCATE( valid_index )
END SUBROUTINE NLTECoeff_Concat
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! NLTECoeff_ChannelReindex
!
! PURPOSE:
! Subroutine to re-index an NLTECoeff object for a different complete
! channel set.
!
! CALLING SEQUENCE:
! CALL NLTECoeff_ChannelReindex( NLTECoeff, Sensor_Channels )
!
! OBJECTS:
! NLTECoeff: NLTECoeff object to have its channel information reindexed.
! UNITS: N/A
! TYPE: NLTECoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
! INPUTS:
! Sensor_Channel: Array of channel numbers for which the NLTECoeff object
! is to be re-indexed against.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Rank-1
! ATTRIBUTES: INTENT(IN)
!
! COMMENTS:
! If there is a mismatch between the channel sets, e.g. total number of
! sensor channels is less than the number of NLTE channels, or if ANY of
! the NLTE channels are NOT in the sensor channel list, no reindexing is
! performed and the input structure is returned with no changes.
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='NLTECOEFF_CHANNELREINDEX'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_CHANNELREINDEX' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE NLTECoeff_ChannelReindex( NLTECoeff, Sensor_Channel ) 1,2
! Arguments
TYPE(NLTECoeff_type), INTENT(IN OUT) :: NLTECoeff
INTEGER , INTENT(IN) :: Sensor_Channel(:)
! Local variables
TYPE(NLTECoeff_type) :: nc_copy
INTEGER :: i, i_nlte
INTEGER :: n_channels, n_nlte_channels
! Setup
IF ( .NOT. NLTECoeff_Associated(NLTECoeff) ) RETURN
n_channels = SIZE(Sensor_Channel)
IF ( n_channels < 1 ) RETURN
IF ( n_channels < NLTECoeff%n_NLTE_Channels ) RETURN
! Copy the input structure
nc_copy = NLTECoeff
! Allocate the reindexed NLTECoeff object
CALL NLTECoeff_Create( &
NLTECoeff , &
nc_copy%n_Predictors , &
nc_copy%n_Sensor_Angles, &
nc_copy%n_Solar_Angles , &
nc_copy%n_NLTE_Channels, &
n_channels )
IF ( .NOT. NLTECoeff_Associated(NLTECoeff) ) RETURN
! Fill the new structure
! ...Copy over the non-channel related information
NLTECoeff%Version = nc_copy%Version
NLTECoeff%Sensor_Id = nc_copy%Sensor_Id
NLTECoeff%WMO_Satellite_ID = nc_copy%WMO_Satellite_ID
NLTECoeff%WMO_Sensor_ID = nc_copy%WMO_Sensor_ID
NLTECoeff%Upper_Plevel = nc_copy%Upper_Plevel
NLTECoeff%Lower_Plevel = nc_copy%Lower_Plevel
NLTECoeff%Min_Tm = nc_copy%Min_Tm
NLTECoeff%Max_Tm = nc_copy%Max_Tm
NLTECoeff%Mean_Tm = nc_copy%Mean_Tm
NLTECoeff%Secant_Sensor_Zenith = nc_copy%Secant_Sensor_Zenith
NLTECoeff%Secant_Solar_Zenith = nc_copy%Secant_Solar_Zenith
! ...Copy over the NLTE channel related information
NLTECoeff%NLTE_Channel = nc_copy%NLTE_Channel
NLTECoeff%C = nc_copy%C
! ...Copy over the all-channel related information
NLTECoeff%Sensor_Channel = Sensor_Channel
! Perform the channel reindexing
i_nlte = 1
Reindex_Loop: DO i = 1, n_channels
IF ( NLTECoeff%Sensor_Channel(i) == NLTECoeff%NLTE_Channel(i_nlte) ) THEN
NLTECoeff%Is_NLTE_Channel(i) = .TRUE.
NLTECoeff%C_Index(i) = i_nlte
i_nlte = i_nlte + 1
IF (i_nlte > NLTECoeff%n_NLTE_Channels) EXIT Reindex_Loop
END IF
END DO Reindex_Loop
! ...Unless ALL the NLTE channel were reindexed, restore the original structure
n_nlte_channels = i_nlte - 1
IF ( n_nlte_channels /= NLTECoeff%n_NLTE_Channels ) NLTECoeff = nc_copy
! Clean up
CALL NLTECoeff_Destroy(nc_copy)
END SUBROUTINE NLTECoeff_ChannelReindex
!##################################################################################
!##################################################################################
!## ##
!## ## PRIVATE MODULE ROUTINES ## ##
!## ##
!##################################################################################
!##################################################################################
!------------------------------------------------------------------------------
!
! NAME:
! NLTECoeff_Equal
!
! PURPOSE:
! Elemental function to test the equality of two NLTECoeff objects.
! Used in OPERATOR(==) interface block.
!
! CALLING SEQUENCE:
! is_equal = NLTECoeff_Equal( x, y )
!
! or
!
! IF ( x == y ) THEN
! ...
! END IF
!
! OBJECTS:
! x, y: Two NLTECoeff objects to be compared.
! UNITS: N/A
! TYPE: NLTECoeff_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.
!
!------------------------------------------------------------------------------
<A NAME='NLTECOEFF_EQUAL'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_EQUAL' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION NLTECoeff_Equal( x, y ) RESULT( is_equal ) 1
TYPE(NLTECoeff_type), INTENT(IN) :: x, y
LOGICAL :: is_equal
! Set up
is_equal = .FALSE.
! Check the object association status
IF ( (.NOT. NLTECoeff_Associated(x)) .OR. &
(.NOT. NLTECoeff_Associated(y)) ) RETURN
! Check contents
! ...Release/version info
IF ( (x%Release /= y%Release) .OR. &
(x%Version /= y%Version) ) RETURN
! ...Dimensions
IF ( (x%n_Predictors /= y%n_Predictors ) .OR. &
(x%n_Sensor_Angles /= y%n_Sensor_Angles ) .OR. &
(x%n_Solar_Angles /= y%n_Solar_Angles ) .OR. &
(x%n_NLTE_Channels /= y%n_NLTE_Channels ) .OR. &
(x%n_Channels /= y%n_Channels ) ) RETURN
! ...Scalars
IF ( (x%Sensor_Id /= y%Sensor_Id ) .OR. &
(x%WMO_Satellite_ID /= y%WMO_Satellite_ID) .OR. &
(x%WMO_Sensor_ID /= y%WMO_Sensor_ID ) ) RETURN
! ...Arrays
IF ( ALL(x%Sensor_Channel == y%Sensor_Channel ) .AND. &
ALL(x%Upper_Plevel .EqualTo. y%Upper_Plevel ) .AND. &
ALL(x%Lower_Plevel .EqualTo. y%Lower_Plevel ) .AND. &
ALL(x%Min_Tm .EqualTo. y%Min_Tm ) .AND. &
ALL(x%Max_Tm .EqualTo. y%Max_Tm ) .AND. &
ALL(x%Mean_Tm .EqualTo. y%Mean_Tm ) .AND. &
ALL(x%Secant_Sensor_Zenith .EqualTo. y%Secant_Sensor_Zenith) .AND. &
ALL(x%Secant_Solar_Zenith .EqualTo. y%Secant_Solar_Zenith ) .AND. &
ALL(x%NLTE_Channel == y%NLTE_Channel ) .AND. &
ALL(x%Is_NLTE_Channel .EQV. y%Is_NLTE_Channel ) .AND. &
ALL(x%C_Index == y%C_Index ) .AND. &
ALL(x%C .EqualTo. y%C ) ) &
is_equal = .TRUE.
END FUNCTION NLTECoeff_Equal
!--------------------------------------------------------------------------------
!
! NAME:
! NLTECoeff_Reindex
!
! PURPOSE:
! Subroutine to reindex the C_Index component of an NLTECoeff object after,
! for example, subsetting or concatenation.
!
! CALLING SEQUENCE:
! CALL NLTECoeff_Reindex( NLTECoeff )
!
! OBJECTS:
! NLTECoeff: NLTECoeff object which is to have its C_Index
! component reindexed.
! UNITS: N/A
! TYPE: NLTECoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
!--------------------------------------------------------------------------------
<A NAME='NLTECOEFF_REINDEX'><A href='../../html_code/crtm/NLTECoeff_Define.f90.html#NLTECOEFF_REINDEX' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE NLTECoeff_Reindex( NLTECoeff ) 2
TYPE(NLTECoeff_type), INTENT(IN OUT) :: NLTECoeff
INTEGER :: i, j
j = 1
DO i = 1, NLTECoeff%n_Channels
IF ( NLTECoeff%C_Index(i) > 0 ) THEN
NLTECoeff%C_Index(i) = j
j = j + 1
END IF
END DO
END SUBROUTINE NLTECoeff_Reindex
END MODULE NLTECoeff_Define