! ! PAFV_Define ! ! Module defining the PAFV object. ! ! ! CREATION HISTORY: ! Written by: Paul van Delst, 21-Mar-2012 ! paul.vandelst@noaa.gov MODULE PAFV_Define ! ----------------- ! Environment setup ! ----------------- ! Module use USE Type_Kinds , ONLY: fp 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 ! Disable implicit typing IMPLICIT NONE ! ------------ ! Visibilities ! ------------ ! Everything private by default PRIVATE ! Datatypes PUBLIC :: PAFV_type ! Operators PUBLIC :: OPERATOR(==) ! Procedures PUBLIC :: PAFV_Associated PUBLIC :: PAFV_Destroy PUBLIC :: PAFV_Create PUBLIC :: PAFV_Inspect PUBLIC :: PAFV_ValidRelease PUBLIC :: PAFV_Info PUBLIC :: PAFV_DefineVersion PUBLIC :: PAFV_InquireFile PUBLIC :: PAFV_ReadFile PUBLIC :: PAFV_WriteFile ! --------------------- ! Procedure overloading ! --------------------- INTERFACE OPERATOR(==) MODULE PROCEDURE PAFV_Equal END INTERFACE OPERATOR(==) ! ----------------- ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & '$Id: PAFV_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: PAFV_RELEASE = 2 ! This determines structure and file formats. INTEGER, PARAMETER :: PAFV_VERSION = 1 ! This is just the default data version. ! Close status for write errors CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE' ! Literal constants REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: ONE = 1.0_fp ! String lengths INTEGER, PARAMETER :: ML = 256 ! Message length ! Compact-OPTRAN data indicator INTEGER, PARAMETER :: DATA_MISSING = 0 INTEGER, PARAMETER :: DATA_PRESENT = 1 ! Compact-OPTRAN max. order and number of predictors INTEGER, PUBLIC, PARAMETER :: MAX_OPTRAN_ORDER = 10 INTEGER, PUBLIC, PARAMETER :: MAX_OPTRAN_PREDICTORS = 14 INTEGER, PUBLIC, PARAMETER :: MAX_OPTRAN_USED_PREDICTORS = 6 ! ------------------------- ! PAFV data type definition ! ------------------------- !:tdoc+: TYPE :: PAFV_type ! Allocation indicator LOGICAL :: Is_Allocated = .FALSE. ! Release and version information INTEGER :: Release = PAFV_RELEASE INTEGER :: Version = PAFV_VERSION ! Dimensions variables INTEGER :: n_ODPS_Layers = 0 ! K INTEGER :: n_Absorbers = 0 ! J INTEGER :: n_User_Layers = 0 ! uK ! ODPS Forward variables ! ...Index array for ODPS to user profile interpolations INTEGER, ALLOCATABLE :: ODPS2User_Idx(:,:) ! 2 x 0:uK ! ...Index array for user to ODPS profile interpolations INTEGER, ALLOCATABLE :: interp_index(:,:) ! 2 x K ! ...Accumulated weighting factors array for user to ODPS profile interpolations REAL(fp), ALLOCATABLE :: Acc_Weighting(:,:) ! uK x K ! ...Profile data REAL(fp), ALLOCATABLE :: Temperature(:) ! K REAL(fp), ALLOCATABLE :: Absorber(:,:) ! K x J INTEGER, ALLOCATABLE :: idx_map(:) ! K INTEGER :: H2O_idx = 0 ! Pressure profiles for interpolations REAL(fp), ALLOCATABLE :: Ref_LnPressure(:) ! K REAL(fp), ALLOCATABLE :: User_LnPressure(:) ! uK ! Predictor Forward variables REAL(fp), ALLOCATABLE :: PDP(:) ! K REAL(fp), ALLOCATABLE :: Tz_ref(:) ! K REAL(fp), ALLOCATABLE :: Tz(:) ! K REAL(fp), ALLOCATABLE :: Tzp_ref(:) ! K REAL(fp), ALLOCATABLE :: Tzp(:) ! K ! ... REAL(fp), ALLOCATABLE :: GAz_ref(:,:) ! K x J REAL(fp), ALLOCATABLE :: GAz_sum(:,:) ! K x J REAL(fp), ALLOCATABLE :: GAz(:,:) ! K x J REAL(fp), ALLOCATABLE :: GAzp_ref(:,:) ! K x J REAL(fp), ALLOCATABLE :: GAzp_sum(:,:) ! K x J REAL(fp), ALLOCATABLE :: GAzp(:,:) ! K x J REAL(fp), ALLOCATABLE :: GATzp_ref(:,:) ! K x J REAL(fp), ALLOCATABLE :: GATzp_sum(:,:) ! K x J REAL(fp), ALLOCATABLE :: GATzp(:,:) ! K x J ! ... REAL(fp), ALLOCATABLE :: DT(:) ! K REAL(fp), ALLOCATABLE :: T(:) ! K REAL(fp), ALLOCATABLE :: T2(:) ! K REAL(fp), ALLOCATABLE :: DT2(:) ! K REAL(fp), ALLOCATABLE :: H2O(:) ! K REAL(fp), ALLOCATABLE :: H2O_A(:) ! K REAL(fp), ALLOCATABLE :: H2O_R(:) ! K REAL(fp), ALLOCATABLE :: H2O_S(:) ! K REAL(fp), ALLOCATABLE :: H2O_R4(:) ! K REAL(fp), ALLOCATABLE :: H2OdH2OTzp(:) ! K REAL(fp), ALLOCATABLE :: CO2(:) ! K REAL(fp), ALLOCATABLE :: O3(:) ! K REAL(fp), ALLOCATABLE :: O3_A(:) ! K REAL(fp), ALLOCATABLE :: O3_R(:) ! K REAL(fp), ALLOCATABLE :: CO(:) ! K REAL(fp), ALLOCATABLE :: CO_A(:) ! K REAL(fp), ALLOCATABLE :: CO_R(:) ! K REAL(fp), ALLOCATABLE :: CO_S(:) ! K REAL(fp), ALLOCATABLE :: CO_ACOdCOzp(:) ! K REAL(fp), ALLOCATABLE :: N2O(:) ! K REAL(fp), ALLOCATABLE :: N2O_A(:) ! K REAL(fp), ALLOCATABLE :: N2O_R(:) ! K REAL(fp), ALLOCATABLE :: N2O_S(:) ! K REAL(fp), ALLOCATABLE :: CH4(:) ! K REAL(fp), ALLOCATABLE :: CH4_A(:) ! K REAL(fp), ALLOCATABLE :: CH4_R(:) ! K REAL(fp), ALLOCATABLE :: CH4_ACH4zp(:) ! K ! Optical depth Forward variables REAL(fp), ALLOCATABLE :: OD(:) ! K REAL(fp), ALLOCATABLE :: OD_Path(:) ! K ! Zeeman specific Forward variables REAL(fp) :: w1, w2 ! weights for two-points linear interpolation INTEGER :: inode ! node position ! Compact-OPTRAN Forward variables LOGICAL :: OPTRAN = .FALSE. ! ...Dimensions INTEGER :: n_OUsed_Pred = MAX_OPTRAN_USED_PREDICTORS ! oI; No. of OPTRAN used predictors ! ...Predictor variables REAL(fp), ALLOCATABLE :: dPonG(:) ! K REAL(fp), ALLOCATABLE :: d_Absorber(:) ! K REAL(fp), ALLOCATABLE :: Int_vapor(:) ! K REAL(fp), ALLOCATABLE :: AveA(:) ! K REAL(fp), ALLOCATABLE :: Inverse(:) ! K REAL(fp), ALLOCATABLE :: s_t(:) ! K REAL(fp), ALLOCATABLE :: s_p(:) ! K REAL(fp), ALLOCATABLE :: Ap1(:) ! K ! ...Optical depth variables REAL(fp), ALLOCATABLE :: b(:,:) ! K x 0:oI REAL(fp), ALLOCATABLE :: LN_Chi(:) ! K REAL(fp), ALLOCATABLE :: Chi(:) ! K END TYPE PAFV_type !:tdoc-: CONTAINS !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! PAFV_Associated ! ! PURPOSE: ! Elemental function to test the status of the allocatable components ! of the PAFV structure. ! ! CALLING SEQUENCE: ! Status = PAFV_Associated( PAFV ) ! ! OBJECTS: ! PAFV: ! Structure which is to have its member's ! status tested. ! UNITS: N/A ! TYPE: PAFV_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(IN) ! ! FUNCTION RESULT: ! Status: ! The return value is a logical value indicating the ! status of the allocated members. ! .TRUE. - if ANY of the PAFV allocatable members ! are in use. ! .FALSE. - if ALL of the PAFV allocatable members ! are not in use. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Same as input ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL FUNCTION PAFV_Associated( self ) RESULT( Status ) TYPE(PAFV_type), INTENT(IN) :: self LOGICAL :: Status Status = self%Is_Allocated END FUNCTION PAFV_Associated !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! PAFV_Destroy ! ! PURPOSE: ! Elemental subroutine to re-initialize PAFV objects. ! ! CALLING SEQUENCE: ! CALL PAFV_Destroy( PAFV ) ! ! OBJECTS: ! PAFV: ! Re-initialized PAFV structure. ! UNITS: N/A ! TYPE: PAFV_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(OUT) ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL SUBROUTINE PAFV_Destroy( self ) TYPE(PAFV_type), INTENT(OUT) :: self self%Is_Allocated = .FALSE. END SUBROUTINE PAFV_Destroy !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! PAFV_Create ! ! PURPOSE: ! Elemental subroutine to create an instance of an PAFV object. ! ! CALLING SEQUENCE: ! CALL PAFV_Create( & ! PAFV , & ! n_ODPS_Layers, & ! n_User_Layers, & ! n_Absorbers , & ! No_OPTRAN = No_OPTRAN ) ! ! OBJECTS: ! PAFV: ! PAFV object structure. ! UNITS: N/A ! TYPE: PAFV_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(OUT) ! ! INPUTS: ! n_ODPS_Layers: ! Number of internal ODPS layers that are defined ! in the ODPS TauCoeff data file. ! Must be > 0. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Conformable with the PAFV object ! ATTRIBUTES: INTENT(IN) ! ! n_User_Layers: ! Number of atmospheric layers defined by user. ! Must be > 0. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Conformable with the PAFV object ! ATTRIBUTES: INTENT(IN) ! ! n_Absorbers: ! Number of gaseous absorbers. ! Must be > 0. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Conformable with the PAFV object ! ATTRIBUTES: INTENT(IN) ! ! OPTIONAL INPUTS: ! No_OPTRAN: ! Logical switch to disable allocation of Compact-OPTRAN ! arrays for use with water vapour absorption. ! If == .FALSE., arrays are allocated [DEFAULT] ! == .TRUE., arrays are NOT allocated ! If not specified, arrays are allocated. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Conformable with the PAFV object ! ATTRIBUTES: INTENT(IN), OPTIONAL ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL SUBROUTINE PAFV_Create( & self , & ! Output n_ODPS_Layers, & ! Input n_User_Layers, & ! Input n_Absorbers , & ! Input No_OPTRAN ) ! Optional Input ! Arguments TYPE(PAFV_type), INTENT(OUT) :: self INTEGER, INTENT(IN) :: n_ODPS_Layers INTEGER, INTENT(IN) :: n_User_Layers INTEGER, INTENT(IN) :: n_Absorbers LOGICAL, OPTIONAL, INTENT(IN) :: No_OPTRAN ! Local variables LOGICAL :: use_optran INTEGER :: alloc_stat ! Check input IF ( n_ODPS_Layers < 1 .OR. & n_Absorbers < 1 .OR. & n_User_Layers < 1 ) RETURN ! ...Process options use_optran = .TRUE. IF ( PRESENT(No_OPTRAN) ) use_optran = .NOT. No_OPTRAN ! Perform the ODPS allocations ! ...ODPS Forward variables ALLOCATE( self%ODPS2User_Idx(2, 0:n_User_Layers), & self%interp_index(2, n_ODPS_Layers), & self%Acc_Weighting(n_User_Layers,n_ODPS_Layers), & self%Temperature(n_ODPS_Layers), & self%Absorber(n_ODPS_Layers, n_Absorbers), & self%idx_map(n_Absorbers), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN ! ...Pressure profiles for interpolations ALLOCATE( self%Ref_LnPressure(n_ODPS_Layers), & self%User_LnPressure(n_User_Layers), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN ! Predictor forward variables ! ... ALLOCATE( self%PDP(n_ODPS_Layers), & self%Tz_ref(n_ODPS_Layers), & self%Tz(n_ODPS_Layers), & self%Tzp_ref(n_ODPS_Layers), & self%Tzp(n_ODPS_Layers), & self%GAz_ref(n_ODPS_Layers, n_Absorbers), & self%GAz_sum(n_ODPS_Layers, n_Absorbers), & self%GAz(n_ODPS_Layers, n_Absorbers), & self%GAzp_ref(n_ODPS_Layers, n_Absorbers), & self%GAzp_sum(n_ODPS_Layers, n_Absorbers), & self%GAzp(n_ODPS_Layers, n_Absorbers), & self%GATzp_ref(n_ODPS_Layers, n_Absorbers), & self%GATzp_sum(n_ODPS_Layers, n_Absorbers), & self%GATzp(n_ODPS_Layers, n_Absorbers), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN ! ... ALLOCATE( self%DT(n_ODPS_Layers), & self%T(n_ODPS_Layers), & self%T2(n_ODPS_Layers), & self%DT2(n_ODPS_Layers), & self%H2O(n_ODPS_Layers), & self%H2O_A(n_ODPS_Layers), & self%H2O_R(n_ODPS_Layers), & self%H2O_S(n_ODPS_Layers), & self%H2O_R4(n_ODPS_Layers), & self%H2OdH2OTzp(n_ODPS_Layers), & self%CO2(n_ODPS_Layers), & self%O3(n_ODPS_Layers), & self%O3_A(n_ODPS_Layers), & self%O3_R(n_ODPS_Layers), & self%CO(n_ODPS_Layers), & self%CO_A(n_ODPS_Layers), & self%CO_R(n_ODPS_Layers), & self%CO_S(n_ODPS_Layers), & self%CO_ACOdCOzp(n_ODPS_Layers), & self%N2O(n_ODPS_Layers), & self%N2O_A(n_ODPS_Layers), & self%N2O_R(n_ODPS_Layers), & self%N2O_S(n_ODPS_Layers), & self%CH4(n_ODPS_Layers), & self%CH4_A(n_ODPS_Layers), & self%CH4_R(n_ODPS_Layers), & self%CH4_ACH4zp(n_ODPS_Layers), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN ! ...Optical depth variables ALLOCATE( self%OD(n_ODPS_Layers), & self%OD_path(0:n_ODPS_Layers), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN ! Initialise dimensions (not arrays) self%n_ODPS_Layers = n_ODPS_Layers self%n_Absorbers = n_Absorbers self%n_User_Layers = n_User_Layers ! Allocate OPTRAN if required IF ( use_optran ) THEN ALLOCATE( self%dPonG(n_ODPS_Layers), & self%d_Absorber(n_ODPS_Layers), & self%Int_vapor(n_ODPS_Layers), & self%AveA(n_ODPS_Layers), & self%Inverse(n_ODPS_Layers), & self%s_t(n_ODPS_Layers), & self%s_p(n_ODPS_Layers), & self%Ap1(n_ODPS_Layers), & self%b(n_ODPS_Layers, 0:MAX_OPTRAN_USED_PREDICTORS), & self%LN_Chi(n_ODPS_Layers), & self%Chi(n_ODPS_Layers), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN ! ...Initialise dimensions self%n_OUsed_Pred = MAX_OPTRAN_USED_PREDICTORS ! ...Flag OPTRAN section as usuable self%OPTRAN = .TRUE. END IF ! Set allocation indicator self%Is_Allocated = .TRUE. END SUBROUTINE PAFV_Create !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! PAFV_Inspect ! ! PURPOSE: ! Subroutine to print the contents of a PAFV object to stdout. ! ! CALLING SEQUENCE: ! CALL PAFV_Inspect( PAFV ) ! ! OBJECTS: ! PAFV: ! PAFV object to display. ! UNITS: N/A ! TYPE: PAFV_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! !:sdoc-: !-------------------------------------------------------------------------------- SUBROUTINE PAFV_Inspect(self) TYPE(PAFV_type), INTENT(IN) :: self WRITE(*,'(1x,"PAFV OBJECT")') ! Release/version info WRITE(*,'(3x,"Release.Version :",1x,i0,".",i0)') self%Release, self%Version ! Dimensions WRITE(*,'(3x,"n_ODPS_Layers :",1x,i0)') self%n_ODPS_Layers WRITE(*,'(3x,"n_User_Layers :",1x,i0)') self%n_User_Layers WRITE(*,'(3x,"n_Absorbers :",1x,i0)') self%n_Absorbers IF ( .NOT. PAFV_Associated(self) ) RETURN ! ODPS data arrays WRITE(*,'(3x,"ODPS data arrays :")') ! ...ODPS Forward variables WRITE(*,'(5x,"ODPS2User_Idx :")'); WRITE(*,'(10(1x,i3,:))') self%ODPS2User_Idx WRITE(*,'(5x,"interp_index :")'); WRITE(*,'(10(1x,i3,:))') self%interp_index WRITE(*,'(5x,"Acc_Weighting :")'); WRITE(*,'(5(1x,es13.6,:))') self%Acc_Weighting WRITE(*,'(5x,"Temperature :")'); WRITE(*,'(5(1x,es13.6,:))') self%Temperature WRITE(*,'(5x,"Absorber :")'); WRITE(*,'(5(1x,es13.6,:))') self%Absorber WRITE(*,'(5x,"idx_map :")'); WRITE(*,'(10(1x,i3,:))') self%idx_map WRITE(*,'(5x,"H2O_idx :",1x,i0)') self%H2O_idx ! ...Pressure profiles for interpolations WRITE(*,'(5x,"Ref_LnPressure :")'); WRITE(*,'(5(1x,es13.6,:))') self%Ref_LnPressure WRITE(*,'(5x,"User_LnPressure :")'); WRITE(*,'(5(1x,es13.6,:))') self%User_LnPressure ! ...Predictor forward variables WRITE(*,'(5x,"PDP :")'); WRITE(*,'(5(1x,es13.6,:))') self%PDP WRITE(*,'(5x,"Tz_ref :")'); WRITE(*,'(5(1x,es13.6,:))') self%Tz_ref WRITE(*,'(5x,"Tz :")'); WRITE(*,'(5(1x,es13.6,:))') self%Tz WRITE(*,'(5x,"Tzp_ref :")'); WRITE(*,'(5(1x,es13.6,:))') self%Tzp_ref WRITE(*,'(5x,"Tzp :")'); WRITE(*,'(5(1x,es13.6,:))') self%Tzp WRITE(*,'(5x,"GAz_ref :")'); WRITE(*,'(5(1x,es13.6,:))') self%GAz_ref WRITE(*,'(5x,"GAz_sum :")'); WRITE(*,'(5(1x,es13.6,:))') self%GAz_sum WRITE(*,'(5x,"GAz :")'); WRITE(*,'(5(1x,es13.6,:))') self%GAz WRITE(*,'(5x,"GAzp_ref :")'); WRITE(*,'(5(1x,es13.6,:))') self%GAzp_ref WRITE(*,'(5x,"GAzp_sum :")'); WRITE(*,'(5(1x,es13.6,:))') self%GAzp_sum WRITE(*,'(5x,"GAzp :")'); WRITE(*,'(5(1x,es13.6,:))') self%GAzp WRITE(*,'(5x,"GATzp_ref :")'); WRITE(*,'(5(1x,es13.6,:))') self%GATzp_ref WRITE(*,'(5x,"GATzp_sum :")'); WRITE(*,'(5(1x,es13.6,:))') self%GATzp_sum WRITE(*,'(5x,"GATzp :")'); WRITE(*,'(5(1x,es13.6,:))') self%GATzp WRITE(*,'(5x,"DT :")'); WRITE(*,'(5(1x,es13.6,:))') self%DT WRITE(*,'(5x,"T :")'); WRITE(*,'(5(1x,es13.6,:))') self%T WRITE(*,'(5x,"T2 :")'); WRITE(*,'(5(1x,es13.6,:))') self%T2 WRITE(*,'(5x,"DT2 :")'); WRITE(*,'(5(1x,es13.6,:))') self%DT2 WRITE(*,'(5x,"H2O :")'); WRITE(*,'(5(1x,es13.6,:))') self%H2O WRITE(*,'(5x,"H2O_A :")'); WRITE(*,'(5(1x,es13.6,:))') self%H2O_A WRITE(*,'(5x,"H2O_R :")'); WRITE(*,'(5(1x,es13.6,:))') self%H2O_R WRITE(*,'(5x,"H2O_S :")'); WRITE(*,'(5(1x,es13.6,:))') self%H2O_S WRITE(*,'(5x,"H2O_R4 :")'); WRITE(*,'(5(1x,es13.6,:))') self%H2O_R4 WRITE(*,'(5x,"H2OdH2OTzp :")'); WRITE(*,'(5(1x,es13.6,:))') self%H2OdH2OTzp WRITE(*,'(5x,"CO2 :")'); WRITE(*,'(5(1x,es13.6,:))') self%CO2 WRITE(*,'(5x,"O3 :")'); WRITE(*,'(5(1x,es13.6,:))') self%O3 WRITE(*,'(5x,"O3_A :")'); WRITE(*,'(5(1x,es13.6,:))') self%O3_A WRITE(*,'(5x,"O3_R :")'); WRITE(*,'(5(1x,es13.6,:))') self%O3_R WRITE(*,'(5x,"CO :")'); WRITE(*,'(5(1x,es13.6,:))') self%CO WRITE(*,'(5x,"CO_A :")'); WRITE(*,'(5(1x,es13.6,:))') self%CO_A WRITE(*,'(5x,"CO_R :")'); WRITE(*,'(5(1x,es13.6,:))') self%CO_R WRITE(*,'(5x,"CO_S :")'); WRITE(*,'(5(1x,es13.6,:))') self%CO_S WRITE(*,'(5x,"CO_ACOdCOzp :")'); WRITE(*,'(5(1x,es13.6,:))') self%CO_ACOdCOzp WRITE(*,'(5x,"N2O :")'); WRITE(*,'(5(1x,es13.6,:))') self%N2O WRITE(*,'(5x,"N2O_A :")'); WRITE(*,'(5(1x,es13.6,:))') self%N2O_A WRITE(*,'(5x,"N2O_R :")'); WRITE(*,'(5(1x,es13.6,:))') self%N2O_R WRITE(*,'(5x,"N2O_S :")'); WRITE(*,'(5(1x,es13.6,:))') self%N2O_S WRITE(*,'(5x,"CH4 :")'); WRITE(*,'(5(1x,es13.6,:))') self%CH4 WRITE(*,'(5x,"CH4_A :")'); WRITE(*,'(5(1x,es13.6,:))') self%CH4_A WRITE(*,'(5x,"CH4_R :")'); WRITE(*,'(5(1x,es13.6,:))') self%CH4_R WRITE(*,'(5x,"CH4_ACH4zp :")'); WRITE(*,'(5(1x,es13.6,:))') self%CH4_ACH4zp ! Optical depth variables WRITE(*,'(3x,"ODPS optical depth arrays :")') WRITE(*,'(5x,"OD :")'); WRITE(*,'(5(1x,es13.6,:))') self%OD WRITE(*,'(5x,"OD_path :")'); WRITE(*,'(5(1x,es13.6,:))') self%OD_path ! Zeeman specific Forward variables WRITE(*,'(3x,"Zeeman-specific data :")') WRITE(*,'(5x,"w1, w2 :")'); WRITE(*,'(2(1x,es13.6))') self%w1, self%w2 WRITE(*,'(5x,"inode :")'); WRITE(*,'(1x,i0)') self%inode ! Compact-OPTRAN Forward variables IF ( self%OPTRAN ) THEN WRITE(*,'(3x,"Compact-OPTRAN option :")') WRITE(*,'(3x,"n_OUsed_Pred :",1x,i0)') self%n_OUsed_Pred WRITE(*,'(5x,"dPonG :")'); WRITE(*,'(5(1x,es13.6,:))') self%dPonG WRITE(*,'(5x,"d_Absorber :")'); WRITE(*,'(5(1x,es13.6,:))') self%d_Absorber WRITE(*,'(5x,"Int_vapor :")'); WRITE(*,'(5(1x,es13.6,:))') self%Int_vapor WRITE(*,'(5x,"AveA :")'); WRITE(*,'(5(1x,es13.6,:))') self%AveA WRITE(*,'(5x,"Inverse :")'); WRITE(*,'(5(1x,es13.6,:))') self%Inverse WRITE(*,'(5x,"s_t :")'); WRITE(*,'(5(1x,es13.6,:))') self%s_t WRITE(*,'(5x,"s_p :")'); WRITE(*,'(5(1x,es13.6,:))') self%s_p WRITE(*,'(5x,"Ap1 :")'); WRITE(*,'(5(1x,es13.6,:))') self%Ap1 WRITE(*,'(5x,"b :")'); WRITE(*,'(5(1x,es13.6,:))') self%b WRITE(*,'(5x,"LN_Chi :")'); WRITE(*,'(5(1x,es13.6,:))') self%LN_Chi WRITE(*,'(5x,"Chi :")'); WRITE(*,'(5(1x,es13.6,:))') self%Chi END IF END SUBROUTINE PAFV_Inspect !---------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! PAFV_ValidRelease ! ! PURPOSE: ! Function to check the PAFV Release value. ! ! CALLING SEQUENCE: ! IsValid = PAFV_ValidRelease( PAFV ) ! ! INPUTS: ! PAFV: ! PAFV object for which the Release component ! is to be checked. ! UNITS: N/A ! TYPE: PAFV_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! FUNCTION RESULT: ! IsValid: ! Logical value defining the release validity. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Scalar ! !:sdoc-: !---------------------------------------------------------------------------------- FUNCTION PAFV_ValidRelease( self ) RESULT( IsValid ) ! Arguments TYPE(PAFV_type), INTENT(IN) :: self ! Function result LOGICAL :: IsValid ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'PAFV_ValidRelease' ! Local variables CHARACTER(ML) :: msg ! Set up IsValid = .TRUE. ! Check release is not too old IF ( self%Release < PAFV_RELEASE ) THEN IsValid = .FALSE. WRITE( msg,'("An PAFV data update is needed. ", & &"PAFV release is ",i0,". Valid release is ",i0,"." )' ) & self%Release, PAFV_RELEASE CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ); RETURN END IF ! Check release is not too new IF ( self%Release > PAFV_RELEASE ) THEN IsValid = .FALSE. WRITE( msg,'("An PAFV software update is needed. ", & &"PAFV release is ",i0,". Valid release is ",i0,"." )' ) & self%Release, PAFV_RELEASE CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ); RETURN END IF END FUNCTION PAFV_ValidRelease !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! PAFV_Info ! ! PURPOSE: ! Subroutine to return a string containing version and dimension ! information about a PAFV object. ! ! CALLING SEQUENCE: ! CALL PAFV_Info( PAFV, Info ) ! ! OBJECTS: ! PAFV: ! PAFV object about which info is required. ! UNITS: N/A ! TYPE: PAFV_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! Info: ! String containing version and dimension information ! about the PAFV object. ! UNITS: N/A ! TYPE: CHARACTER(*) ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT) ! !:sdoc-: !-------------------------------------------------------------------------------- SUBROUTINE PAFV_Info( self, Info ) ! Arguments TYPE(PAFV_type), INTENT(IN) :: self CHARACTER(*), INTENT(OUT) :: Info ! Parameters INTEGER, PARAMETER :: CARRIAGE_RETURN = 13 INTEGER, PARAMETER :: LINEFEED = 10 ! Local variables CHARACTER(1000) :: s1, s2 CHARACTER(2000) :: Long_String ! Write the required data to the local string WRITE( s1, & '(a,1x,"PAFV RELEASE.VERSION: ",i2,".",i2.2,a,3x, & &"N_ODPS_LAYERS=",i0,2x,& &"N_ABSORBERS =",i0,2x,& &"N_USER_LAYERS=",i0,2x)' ) & ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), & self%Release, self%Version, & ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), & self%n_ODPS_Layers, & self%n_Absorbers, & self%n_User_Layers ! Compact-OPTRAN Forward variables IF ( self%OPTRAN ) THEN WRITE( s2, & '(a,1x,"PAFV ODAS Option",a,3x, & &"N_OUSED_PRED=",i0,2x)' ) & ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), & ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), & self%n_OUsed_Pred END IF ! Trim the output based on the ! dummy argument string length Long_String = TRIM(s1)//TRIM(s2) Info = Long_String(1:MIN(LEN(Info), LEN_TRIM(Long_String))) END SUBROUTINE PAFV_Info !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! PAFV_DefineVersion ! ! PURPOSE: ! Subroutine to return the module version information. ! ! CALLING SEQUENCE: ! CALL PAFV_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 PAFV_DefineVersion( Id ) CHARACTER(*), INTENT(OUT) :: Id Id = MODULE_VERSION_ID END SUBROUTINE PAFV_DefineVersion !------------------------------------------------------------------------------ !:sdoc+: ! ! NAME: ! PAFV_InquireFile ! ! PURPOSE: ! Function to inquire PAFV object files. ! ! CALLING SEQUENCE: ! Error_Status = PAFV_InquireFile( & ! Filename, & ! n_ODPS_Layers = n_ODPS_Layers, & ! n_Absorbers = n_Absorbers , & ! n_User_Layers = n_User_Layers, & ! Release = Release , & ! Version = Version ) ! ! INPUTS: ! Filename: ! Character string specifying the name of the ! data file to inquire. ! UNITS: N/A ! TYPE: CHARACTER(*) ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OPTIONAL OUTPUTS: ! n_ODPS_Layers: ! Number of internal ODPS layers that are defined ! in the ODPS TauCoeff data file. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT), OPTIONAL ! ! n_Absorbers: ! Number of gaseous absorbers. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT), OPTIONAL ! ! n_Layers: ! Number of atmospheric layers defined by user. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT), OPTIONAL ! ! Release: ! The data/file release number. Used to check ! for data/software mismatch. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT), OPTIONAL ! ! Version: ! The data/file version number. Used for ! purposes only in identifying the dataset for ! a particular release. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT), 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 inquire was successful ! == FAILURE an unrecoverable error occurred. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! !:sdoc-: !------------------------------------------------------------------------------ FUNCTION PAFV_InquireFile( & Filename , & ! Input n_ODPS_Layers, & ! Optional output n_Absorbers , & ! Optional output n_User_Layers, & ! Optional output Release , & ! Optional output Version , & ! Optional output Title , & ! Optional output History , & ! Optional output Comment ) & ! Optional output RESULT( err_stat ) ! Arguments CHARACTER(*), INTENT(IN) :: Filename INTEGER , OPTIONAL, INTENT(OUT) :: n_ODPS_Layers INTEGER , OPTIONAL, INTENT(OUT) :: n_Absorbers INTEGER , OPTIONAL, INTENT(OUT) :: n_User_Layers INTEGER , OPTIONAL, INTENT(OUT) :: Release INTEGER , OPTIONAL, INTENT(OUT) :: Version CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title CHARACTER(*), OPTIONAL, INTENT(OUT) :: History CHARACTER(*), OPTIONAL, INTENT(OUT) :: Comment ! Function result INTEGER :: err_stat ! Function parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'PAFV_InquireFile' ! Function variables CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg INTEGER :: io_stat INTEGER :: fid INTEGER :: optran_present TYPE(PAFV_type) :: pafv ! Setup err_stat = SUCCESS ! ...Check that the file exists IF ( .NOT. File_Exists( Filename ) ) THEN msg = 'File '//TRIM(Filename)//' not found.' CALL Inquire_Cleanup(); RETURN END IF ! Open the file err_stat = Open_Binary_File( Filename, fid ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error opening '//TRIM(Filename) CALL Inquire_Cleanup(); RETURN END IF ! Read the release and version READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & pafv%Release, & pafv%Version IF ( io_stat /= 0 ) THEN msg = 'Error reading Release/Version - '//TRIM(io_msg) CALL Inquire_Cleanup(); RETURN END IF IF ( .NOT. PAFV_ValidRelease( pafv ) ) THEN msg = 'PAFV Release check failed.' CALL Inquire_Cleanup(); RETURN END IF ! Read the dimensions READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & pafv%n_ODPS_Layers, & pafv%n_Absorbers , & pafv%n_User_Layers IF ( io_stat /= 0 ) THEN msg = 'Error reading dimension values from '//TRIM(Filename)//' - '//TRIM(io_msg) CALL Inquire_Cleanup(); RETURN END IF ! Read Compact-OPTRAN data indicator READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) optran_present IF ( io_stat /= 0 ) THEN msg = 'Error reading Compact-OPTRAN data indicator from '//TRIM(Filename)//' - '//TRIM(io_msg) CALL Inquire_Cleanup(); RETURN END IF ! 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 Inquire_Cleanup(); RETURN END IF ! Close the file CLOSE( fid, IOSTAT=io_stat, IOMSG=io_msg ) IF ( io_stat /= 0 ) THEN msg = 'Error closing '//TRIM(Filename)//' - '//TRIM(io_msg) CALL Inquire_Cleanup(); RETURN END IF ! Assign the return arguments IF ( PRESENT(n_ODPS_Layers) ) n_ODPS_Layers = pafv%n_ODPS_Layers IF ( PRESENT(n_Absorbers ) ) n_Absorbers = pafv%n_Absorbers IF ( PRESENT(n_User_Layers) ) n_User_Layers = pafv%n_User_Layers IF ( PRESENT(Release ) ) Release = pafv%Release IF ( PRESENT(Version ) ) Version = pafv%Version CONTAINS SUBROUTINE Inquire_CleanUp() ! Close file if necessary IF ( File_Open(fid) ) 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 ! Set error status and print error message err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END SUBROUTINE Inquire_CleanUp END FUNCTION PAFV_InquireFile !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! PAFV_ReadFile ! ! PURPOSE: ! Function to read PAFV object files. ! ! CALLING SEQUENCE: ! Error_Status = PAFV_ReadFile( & ! PAFV , & ! Filename, & ! No_Close = No_Close, & ! Quiet = Quiet ) ! ! OBJECTS: ! PAFV: ! PAFV object containing the data read from file. ! UNITS: N/A ! TYPE: PAFV_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT) ! ! INPUTS: ! Filename: ! Character string specifying the name of a ! PAFV 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 PAFV 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 PAFV_ReadFile( & PAFV, & ! 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(PAFV_type), INTENT(OUT) :: PAFV 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 = 'PAFV_ReadFile' ! Function variables CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg LOGICAL :: close_file LOGICAL :: noisy INTEGER :: io_stat INTEGER :: fid INTEGER :: optran_present TYPE(PAFV_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. PAFV_ValidRelease( dummy ) ) THEN msg = 'PAFV Release check failed.' CALL Read_Cleanup(); RETURN END IF ! Read the dimensions READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & dummy%n_ODPS_Layers, & dummy%n_Absorbers , & dummy%n_User_Layers IF ( io_stat /= 0 ) THEN msg = 'Error reading dimension values - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN END IF ! Read Compact-OPTRAN data indicator READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) optran_present IF ( io_stat /= 0 ) THEN msg = 'Error reading Compact-OPTRAN data indicator - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN END IF ! Allocate the object CALL PAFV_Create( & PAFV, & dummy%n_ODPS_Layers, & dummy%n_Absorbers , & dummy%n_User_Layers , & No_OPTRAN = (optran_present == DATA_MISSING) ) IF ( .NOT. PAFV_Associated( PAFV ) ) THEN msg = 'PAFV object allocation failed.' CALL Read_Cleanup(); RETURN END IF ! ...Explicitly assign the version number PAFV%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 ODPS forward variables READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%ODPS2User_Idx, & PAFV%interp_index , & PAFV%Acc_Weighting, & PAFV%Temperature , & PAFV%Absorber , & PAFV%idx_map , & PAFV%H2O_idx IF ( io_stat /= 0 ) THEN msg = 'Error reading ODPS forward variables - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN END IF ! Read the pressure profiles for interpolation READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%Ref_LnPressure, & PAFV%User_LnPressure IF ( io_stat /= 0 ) THEN msg = 'Error reading pressure profiles - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN END IF ! Read the predictor forward variables READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%PDP , & PAFV%Tz_ref , & PAFV%Tz , & PAFV%Tzp_ref , & PAFV%Tzp , & PAFV%GAz_ref , & PAFV%GAz_sum , & PAFV%GAz , & PAFV%GAzp_ref , & PAFV%GAzp_sum , & PAFV%GAzp , & PAFV%GATzp_ref, & PAFV%GATzp_sum, & PAFV%GATzp IF ( io_stat /= 0 ) THEN msg = 'Error reading predictor forward variables (set1) - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN END IF READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%DT , & PAFV%T , & PAFV%T2 , & PAFV%DT2 , & PAFV%H2O , & PAFV%H2O_A , & PAFV%H2O_R , & PAFV%H2O_S , & PAFV%H2O_R4 , & PAFV%H2OdH2OTzp , & PAFV%CO2 , & PAFV%O3 , & PAFV%O3_A , & PAFV%O3_R , & PAFV%CO , & PAFV%CO_A , & PAFV%CO_R , & PAFV%CO_S , & PAFV%CO_ACOdCOzp, & PAFV%N2O , & PAFV%N2O_A , & PAFV%N2O_R , & PAFV%N2O_S , & PAFV%CH4 , & PAFV%CH4_A , & PAFV%CH4_R , & PAFV%CH4_ACH4zp IF ( io_stat /= 0 ) THEN msg = 'Error reading predictor forward variables (set2) - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN END IF ! Read the optical depth variables READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%OD, & PAFV%OD_path IF ( io_stat /= 0 ) THEN msg = 'Error reading optical depth variables - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN END IF ! Read the Zeeman specific Forward variables READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%w1, & PAFV%w2, & PAFV%inode IF ( io_stat /= 0 ) THEN msg = 'Error reading Zeeman specific forward variables - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN END IF ! Read the compact-OPTRAN Forward variables if necessary IF ( PAFV%OPTRAN ) THEN READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%dPonG , & PAFV%d_Absorber, & PAFV%Int_vapor , & PAFV%AveA , & PAFV%Inverse , & PAFV%s_t , & PAFV%s_p , & PAFV%Ap1 , & PAFV%b , & PAFV%LN_Chi , & PAFV%Chi IF ( io_stat /= 0 ) THEN msg = 'Error reading compact-OPTRAN variables - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN END IF 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 ! Output an info message IF ( noisy ) THEN CALL PAFV_Info( PAFV, msg ) CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION ) 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 output file '//TRIM(Filename)//& ' during error cleanup - '//TRIM(io_msg) END IF CALL PAFV_Destroy( PAFV ) err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END SUBROUTINE Read_CleanUp END FUNCTION PAFV_ReadFile !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! PAFV_WriteFile ! ! PURPOSE: ! Function to write PAFV object files. ! ! CALLING SEQUENCE: ! Error_Status = PAFV_WriteFile( & ! PAFV , & ! Filename, & ! No_Close = No_Close, & ! Quiet = Quiet ) ! ! OBJECTS: ! PAFV: ! PAFV object containing the data to write to file. ! UNITS: N/A ! TYPE: PAFV_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! INPUTS: ! Filename: ! Character string specifying the name of a ! PAFV 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 PAFV 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 write was successful ! == FAILURE, an unrecoverable error occurred. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! !:sdoc-: !------------------------------------------------------------------------------ FUNCTION PAFV_WriteFile( & PAFV , & ! 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(PAFV_type), INTENT(IN) :: PAFV 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 = 'PAFV_WriteFile' ! Function variables CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg LOGICAL :: close_file LOGICAL :: noisy INTEGER :: io_stat INTEGER :: fid INTEGER :: optran_present ! 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 there is data to write IF ( .NOT. PAFV_Associated( PAFV ) ) THEN msg = 'PAFV object is empty.' CALL Write_Cleanup(); RETURN 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 ) & PAFV%Release, & PAFV%Version IF ( io_stat /= 0 ) THEN msg = 'Error writing Release/Version - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF ! Write the dimensions WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%n_ODPS_Layers, & PAFV%n_Absorbers , & PAFV%n_User_Layers IF ( io_stat /= 0 ) THEN msg = 'Error writing dimension values - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF ! Write Compact-OPTRAN data indicator IF ( PAFV%OPTRAN) THEN optran_present = DATA_PRESENT ELSE optran_present = DATA_MISSING END IF WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) optran_present IF ( io_stat /= 0 ) THEN msg = 'Error writing Compact-OPTRAN data indicator - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF ! Write the global attributes err_stat = WriteGAtts_Binary_File( & fid, & Title = Title , & History = History, & Comment = Comment ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error writing global attributes' CALL Write_Cleanup(); RETURN END IF ! Write the ODPS forward variables WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%ODPS2User_Idx, & PAFV%interp_index , & PAFV%Acc_Weighting, & PAFV%Temperature , & PAFV%Absorber , & PAFV%idx_map , & PAFV%H2O_idx IF ( io_stat /= 0 ) THEN msg = 'Error writing ODPS forward variables - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF ! Write the pressure profiles for interpolation WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%Ref_LnPressure , & PAFV%User_LnPressure IF ( io_stat /= 0 ) THEN msg = 'Error writing pressure profiles - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF ! Write the predictor forward variables WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%PDP , & PAFV%Tz_ref , & PAFV%Tz , & PAFV%Tzp_ref , & PAFV%Tzp , & PAFV%GAz_ref , & PAFV%GAz_sum , & PAFV%GAz , & PAFV%GAzp_ref , & PAFV%GAzp_sum , & PAFV%GAzp , & PAFV%GATzp_ref, & PAFV%GATzp_sum, & PAFV%GATzp IF ( io_stat /= 0 ) THEN msg = 'Error writing predictor forward variables (set1) - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%DT , & PAFV%T , & PAFV%T2 , & PAFV%DT2 , & PAFV%H2O , & PAFV%H2O_A , & PAFV%H2O_R , & PAFV%H2O_S , & PAFV%H2O_R4 , & PAFV%H2OdH2OTzp , & PAFV%CO2 , & PAFV%O3 , & PAFV%O3_A , & PAFV%O3_R , & PAFV%CO , & PAFV%CO_A , & PAFV%CO_R , & PAFV%CO_S , & PAFV%CO_ACOdCOzp, & PAFV%N2O , & PAFV%N2O_A , & PAFV%N2O_R , & PAFV%N2O_S , & PAFV%CH4 , & PAFV%CH4_A , & PAFV%CH4_R , & PAFV%CH4_ACH4zp IF ( io_stat /= 0 ) THEN msg = 'Error writing predictor forward variables (set2) - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF ! Write the optical depth variables WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%OD, & PAFV%OD_path IF ( io_stat /= 0 ) THEN msg = 'Error writing optical depth variables - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF ! Write the Zeeman specific Forward variables WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%w1, & PAFV%w2, & PAFV%inode IF ( io_stat /= 0 ) THEN msg = 'Error writing Zeeman specific forward variables - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF ! Write the compact-OPTRAN Forward variables if necessary IF ( PAFV%OPTRAN ) THEN WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & PAFV%dPonG , & PAFV%d_Absorber, & PAFV%Int_vapor , & PAFV%AveA , & PAFV%Inverse , & PAFV%s_t , & PAFV%s_p , & PAFV%Ap1 , & PAFV%b , & PAFV%LN_Chi , & PAFV%Chi IF ( io_stat /= 0 ) THEN msg = 'Error writing compac-OPTRAN variables - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF 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 ! Output an info message IF ( noisy ) THEN CALL PAFV_Info( PAFV, msg ) CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION ) 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 '//TRIM(Filename)//& ' 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 PAFV_WriteFile !################################################################################ !################################################################################ !## ## !## ## PRIVATE PROCEDURES ## ## !## ## !################################################################################ !################################################################################ !-------------------------------------------------------------------------------- ! ! NAME: ! PAFV_Equal ! ! PURPOSE: ! Elemental function to test the equality of two PAFV objects. ! Used in OPERATOR(==) interface block. ! ! CALLING SEQUENCE: ! is_equal = PAFV_Equal( x, y ) ! ! or ! ! IF ( x == y ) THEN ! ... ! END IF ! ! OBJECTS: ! x, y: ! Two PAFV objects to be compared. ! UNITS: N/A ! TYPE: PAFV_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 PAFV_Equal( x, y ) RESULT( is_equal ) TYPE(PAFV_type), INTENT(IN) :: x, y LOGICAL :: is_equal ! Set up is_equal = .FALSE. ! Check the object association status IF ( (.NOT. PAFV_Associated(x)) .OR. & (.NOT. PAFV_Associated(y)) ) RETURN ! Check contents ! ...Release/version info IF ( (x%Release /= y%Release) .OR. & (x%Version /= y%Version) ) RETURN ! ...Dimensions IF ( (x%n_ODPS_Layers /= y%n_ODPS_Layers ) .OR. & (x%n_Absorbers /= y%n_Absorbers ) .OR. & (x%n_User_Layers /= y%n_User_Layers ) ) RETURN ! ...Compact-OPTRAN data indicator IF ( x%OPTRAN .NEQV. y%OPTRAN ) RETURN ! ...Arrays IF ( ALL(x%ODPS2User_Idx == y%ODPS2User_Idx ) .AND. & ALL(x%interp_index == y%interp_index ) .AND. & ALL(x%Acc_Weighting .EqualTo. y%Acc_Weighting ) .AND. & ALL(x%Temperature .EqualTo. y%Temperature ) .AND. & ALL(x%Absorber .EqualTo. y%Absorber ) .AND. & ALL(x%idx_map == y%idx_map ) ) & is_equal = .TRUE. IF ( ALL(x%Ref_LnPressure .EqualTo. y%Ref_LnPressure ) .AND. & ALL(x%User_LnPressure .EqualTo. y%User_LnPressure ) ) & is_equal = is_equal .EQV. .TRUE. IF ( ALL(x%PDP .EqualTo. y%PDP ) .AND. & ALL(x%Tz_ref .EqualTo. y%Tz_ref ) .AND. & ALL(x%Tz .EqualTo. y%Tz ) .AND. & ALL(x%Tzp_ref .EqualTo. y%Tzp_ref ) .AND. & ALL(x%Tzp .EqualTo. y%Tzp ) .AND. & ALL(x%GAz_ref .EqualTo. y%GAz_ref ) .AND. & ALL(x%GAz_sum .EqualTo. y%GAz_sum ) .AND. & ALL(x%GAz .EqualTo. y%GAz ) .AND. & ALL(x%GAzp_ref .EqualTo. y%GAzp_ref ) .AND. & ALL(x%GAzp_sum .EqualTo. y%GAzp_sum ) .AND. & ALL(x%GAzp .EqualTo. y%GAzp ) .AND. & ALL(x%GATzp_ref .EqualTo. y%GATzp_ref ) .AND. & ALL(x%GATzp_sum .EqualTo. y%GATzp_sum ) .AND. & ALL(x%GATzp .EqualTo. y%GATzp ) ) & is_equal = is_equal .EQV. .TRUE. IF ( ALL(x%DT .EqualTo. y%DT ) .AND. & ALL(x%T .EqualTo. y%T ) .AND. & ALL(x%T2 .EqualTo. y%T2 ) .AND. & ALL(x%DT2 .EqualTo. y%DT2 ) .AND. & ALL(x%H2O .EqualTo. y%H2O ) .AND. & ALL(x%H2O_A .EqualTo. y%H2O_A ) .AND. & ALL(x%H2O_R .EqualTo. y%H2O_R ) .AND. & ALL(x%H2O_S .EqualTo. y%H2O_S ) .AND. & ALL(x%H2O_R4 .EqualTo. y%H2O_R4 ) .AND. & ALL(x%H2OdH2OTzp .EqualTo. y%H2OdH2OTzp ) .AND. & ALL(x%CO2 .EqualTo. y%CO2 ) .AND. & ALL(x%O3 .EqualTo. y%O3 ) .AND. & ALL(x%O3_A .EqualTo. y%O3_A ) .AND. & ALL(x%O3_R .EqualTo. y%O3_R ) .AND. & ALL(x%CO .EqualTo. y%CO ) .AND. & ALL(x%CO_A .EqualTo. y%CO_A ) .AND. & ALL(x%CO_R .EqualTo. y%CO_R ) .AND. & ALL(x%CO_S .EqualTo. y%CO_S ) .AND. & ALL(x%CO_ACOdCOzp .EqualTo. y%CO_ACOdCOzp ) .AND. & ALL(x%N2O .EqualTo. y%N2O ) .AND. & ALL(x%N2O_A .EqualTo. y%N2O_A ) .AND. & ALL(x%N2O_R .EqualTo. y%N2O_R ) .AND. & ALL(x%N2O_S .EqualTo. y%N2O_S ) .AND. & ALL(x%CH4 .EqualTo. y%CH4 ) .AND. & ALL(x%CH4_A .EqualTo. y%CH4_A ) .AND. & ALL(x%CH4_R .EqualTo. y%CH4_R ) .AND. & ALL(x%CH4_ACH4zp .EqualTo. y%CH4_ACH4zp ) ) & is_equal = is_equal .EQV. .TRUE. ! ...Optical depth variables IF ( ALL(x%OD .EqualTo. y%OD ) .AND. & ALL(x%OD_path .EqualTo. y%OD_path ) ) & is_equal = is_equal .EQV. .TRUE. ! ...Zeeman variables IF ( (x%w1 .EqualTo. y%w1 ) .AND. & (x%w2 .EqualTo. y%w2 ) .AND. & (x%inode == y%inode ) ) & is_equal = is_equal .EQV. .TRUE. ! ...Compact-OPTRAN data IF ( x%OPTRAN .AND. y%OPTRAN ) THEN IF ( ALL(x%dPonG .EqualTo. y%dPonG ) .AND. & ALL(x%d_Absorber .EqualTo. y%d_Absorber ) .AND. & ALL(x%Int_vapor .EqualTo. y%Int_vapor ) .AND. & ALL(x%AveA .EqualTo. y%AveA ) .AND. & ALL(x%Inverse .EqualTo. y%Inverse ) .AND. & ALL(x%s_t .EqualTo. y%s_t ) .AND. & ALL(x%s_p .EqualTo. y%s_p ) .AND. & ALL(x%Ap1 .EqualTo. y%Ap1 ) .AND. & ALL(x%b .EqualTo. y%b ) .AND. & ALL(x%LN_Chi .EqualTo. y%LN_Chi ) .AND. & ALL(x%Chi .EqualTo. y%Chi ) ) & is_equal = is_equal .EQV. .TRUE. END IF END FUNCTION PAFV_Equal END MODULE PAFV_Define