diff --git a/Get_CRTM_Binary_Files.sh b/Get_CRTM_Binary_Files.sh index 3a559f2..56b6949 100755 --- a/Get_CRTM_Binary_Files.sh +++ b/Get_CRTM_Binary_Files.sh @@ -1,4 +1,5 @@ -foldername="fix_REL-3.0.0_20230303" +#https://bin.ssec.wisc.edu/pub/s4/CRTM/fix_REL-3.0.0_20230802.tgz +foldername="fix_REL-3.0.0_20230802" filename="${foldername}.tgz" if test -f "$filename"; then @@ -7,15 +8,22 @@ if test -f "$filename"; then else #untar the file and move directory to fix tar -zxvf $filename - mv $foldername fix + cd $foldername/ + mv fix .. + cd .. + rmdir $foldername echo "fix/ directory created from existing $filename file." fi else #download, untar, move - echo "downloading $filename, please wait about 5 minutes (3.3 GB tar file)" - wget ftp://ftp.ssec.wisc.edu/pub/s4/CRTM/$filename # CRTM binary files, add "-q" to suppress output. - tar -zxvf $filename - mv $foldername fix + echo "Downloading $filename, please wait about 5 minutes (4 GB tar file)" + wget https://bin.ssec.wisc.edu/pub/s4/CRTM/$filename # CRTM binary files, add "-q" to suppress output. + + tar -zxvf $filename + cd $foldername/ + mv fix .. + cd .. + rmdir $foldername echo "fix/ directory created from downloaded $filename." fi echo "Completed." diff --git a/src/Atmosphere/CRTM_Atmosphere_Define.f90 b/src/Atmosphere/CRTM_Atmosphere_Define.f90 index 1d68f8b..bfc508d 100644 --- a/src/Atmosphere/CRTM_Atmosphere_Define.f90 +++ b/src/Atmosphere/CRTM_Atmosphere_Define.f90 @@ -2539,7 +2539,7 @@ FUNCTION Read_Record( & atm%Level_Pressure, & atm%Pressure, & atm%Temperature, & - !atm%Relative_Humidity, & ! RH APPROACH #1 + atm%Relative_Humidity, & ! RH APPROACH #1 atm%Absorber, & atm%Cloud_Fraction IF ( io_stat /= 0 ) THEN @@ -2549,7 +2549,7 @@ FUNCTION Read_Record( & ! RH APPROACH #2 ! Compute the relative humidity - CALL Compute_Relative_Humidity( atm ) + !CALL Compute_Relative_Humidity( atm ) ! Read the cloud data IF ( n_clouds > 0 ) THEN diff --git a/src/Build/libsrc/make.dependencies b/src/Build/libsrc/make.dependencies index 15b36e9..2159a7d 100644 --- a/src/Build/libsrc/make.dependencies +++ b/src/Build/libsrc/make.dependencies @@ -18,7 +18,7 @@ CloudCoeff_Define.o : CloudCoeff_Define.f90 Compare_Float_Numbers.o Message_Hand Common_RTSolution.o : Common_RTSolution.f90 CRTM_RTSolution_Define.o CRTM_Utility.o CRTM_SfcOptics_Define.o CRTM_SfcOptics.o RTV_Define.o CRTM_AtmOptics.o CRTM_AtmOptics_Define.o CRTM_SpcCoeff.o CRTM_Planck_Functions.o CRTM_GeometryInfo_Define.o CRTM_Surface_Define.o CRTM_Atmosphere_Define.o Message_Handler.o CRTM_Parameters.o Type_Kinds.o Compare_Float_Numbers.o : Compare_Float_Numbers.f90 Type_Kinds.o CRTM_Adjoint_Module.o : CRTM_Adjoint_Module.f90 RTV_Define.o ASvar_Define.o CSvar_Define.o AOvar_Define.o CRTM_CloudCover_Define.o CRTM_Planck_Functions.o NLTECoeff_Define.o ACCoeff_Define.o CRTM_NLTECorrection.o CRTM_AerosolCoeff.o CRTM_CloudCoeff.o CRTM_AncillaryInput_Define.o CRTM_MoleculeScatter.o CRTM_AntennaCorrection.o CRTM_RTSolution.o CRTM_SfcOptics.o CRTM_SfcOptics_Define.o CRTM_AtmOptics.o CRTM_CloudScatter.o CRTM_AerosolScatter.o CRTM_AtmOptics_Define.o CRTM_AtmAbsorption.o CRTM_Predictor.o CRTM_Predictor_Define.o CRTM_GeometryInfo.o CRTM_GeometryInfo_Define.o CRTM_Atmosphere.o CRTM_Options_Define.o CRTM_RTSolution_Define.o CRTM_ChannelInfo_Define.o CRTM_Geometry_Define.o CRTM_Surface_Define.o CRTM_Atmosphere_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o -CRTM_AerosolCoeff.o : CRTM_AerosolCoeff.f90 CRTM_AerosolCoeff.o AerosolCoeff_Define.o Message_Handler.o +CRTM_AerosolCoeff.o : CRTM_AerosolCoeff.f90 AerosolCoeff_IO.o AerosolCoeff_Define.o Message_Handler.o CRTM_Aerosol_Define.o : CRTM_Aerosol_Define.f90 CRTM_AerosolCoeff.o AerosolCoeff_Define.o Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o CRTM_AerosolScatter.o : CRTM_AerosolScatter.f90 ASvar_Define.o CRTM_AtmOptics_Define.o CRTM_Interpolation.o CRTM_GeometryInfo_Define.o CRTM_Atmosphere_Define.o CRTM_AerosolCoeff.o CRTM_SpcCoeff.o CRTM_Parameters.o String_Utility.o Message_Handler.o Type_Kinds.o CRTM_AncillaryInput_Define.o : CRTM_AncillaryInput_Define.f90 Zeeman_Input_Define.o SSU_Input_Define.o @@ -30,7 +30,7 @@ CRTM_AtmOptics.o : CRTM_AtmOptics.f90 AOvar_Define.o CRTM_AtmOptics_Define.o CRT CRTM_Atmosphere_Define.o : CRTM_Atmosphere_Define.f90 CRTM_Relative_Humidity.o CRTM_Aerosol_Define.o CRTM_Cloud_Define.o CRTM_Parameters.o Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o CRTM_Atmosphere.o : CRTM_Atmosphere.f90 iAtm_Define.o CRTM_Model_Profiles.o CRTM_Atmosphere_Define.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o CRTM_Hypsometric.o CRTM_ChannelInfo_Define.o : CRTM_ChannelInfo_Define.f90 Sort_Utility.o SensorInfo_Parameters.o CRTM_Parameters.o File_Utility.o Message_Handler.o -CRTM_CloudCoeff.o : CRTM_CloudCoeff.f90 CloudCoeff_IO.o CloudCoeff_Define.o Message_Handler.o +CRTM_CloudCoeff.o : CRTM_CloudCoeff.f90 CloudCoeff_IO.o CloudCoeff_Define.o Message_Handler.o CRTM_CloudCover_Define.o : CRTM_CloudCover_Define.f90 CRTM_Cloud_Define.o CRTM_Atmosphere_Define.o CRTM_Parameters.o Compare_Float_Numbers.o Message_Handler.o File_Utility.o Type_Kinds.o CRTM_Cloud_Define.o : CRTM_Cloud_Define.f90 Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o CRTM_CloudScatter.o : CRTM_CloudScatter.f90 CSvar_Define.o CRTM_AtmOptics_Define.o CRTM_Interpolation.o CRTM_GeometryInfo_Define.o CRTM_Atmosphere_Define.o CRTM_CloudCoeff.o CRTM_SpcCoeff.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o ODPS_CoordinateMapping.o @@ -43,14 +43,15 @@ CRTM_GeometryInfo_Define.o : CRTM_GeometryInfo_Define.f90 CRTM_Geometry_Define.o CRTM_GeometryInfo.o : CRTM_GeometryInfo.f90 CRTM_GeometryInfo_Define.o CRTM_Parameters.o Date_Utility.o Message_Handler.o Type_Kinds.o CRTM_Hypsometric.o : CRTM_Hypsometric.f90 Type_Kinds.o Message_Handler.o Fundamental_Constants.o CRTM_Parameters.o CRTM_Atmosphere_Define.o CRTM_Interpolation.o : CRTM_Interpolation.f90 Type_Kinds.o -CRTM_IRiceCoeff.o : CRTM_IRiceCoeff.f90 SEcategory_Define.o Message_Handler.o +CRTM_IRiceCoeff.o : CRTM_IRiceCoeff.f90 SEcategory_Define.o SEcategory_IO.o Message_Handler.o CRTM_IR_Ice_SfcOptics.o : CRTM_IR_Ice_SfcOptics.f90 CRTM_IRiceCoeff.o CRTM_SEcategory.o CRTM_SfcOptics_Define.o CRTM_GeometryInfo_Define.o CRTM_Surface_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Spectral_Units_Conversion.o Message_Handler.o Type_Kinds.o -CRTM_IRlandCoeff.o : CRTM_IRlandCoeff.f90 SEcategory_Define.o Message_Handler.o +CRTM_IRlandCoeff.o : CRTM_IRlandCoeff.f90 SEcategory_Define.o SEcategory_IO.o Message_Handler.o CRTM_IR_Land_SfcOptics.o : CRTM_IR_Land_SfcOptics.f90 CRTM_IRlandCoeff.o CRTM_SEcategory.o CRTM_SfcOptics_Define.o CRTM_GeometryInfo_Define.o CRTM_Surface_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o -CRTM_IRsnowCoeff.o : CRTM_IRsnowCoeff.f90 SEcategory_Define.o Message_Handler.o -CRTM_IR_Snow_SfcOptics.o : CRTM_IR_Snow_SfcOptics.f90 CRTM_IRsnowCoeff.o CRTM_SEcategory.o CRTM_SfcOptics_Define.o CRTM_GeometryInfo_Define.o CRTM_Surface_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Spectral_Units_Conversion.o Message_Handler.o Type_Kinds.o +CRTM_IRSnowEM.o : CRTM_IRSnowEM.f90 IRsnowCoeff_Define.o CRTM_Interpolation.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o +CRTM_IRsnowCoeff.o : CRTM_IRsnowCoeff.f90 SEcategory_Define.o SEcategory_IO.o IRsnowCoeff_Define.o IRsnowCoeff_IO.o Message_Handler.o +CRTM_IR_Snow_SfcOptics.o : CRTM_IR_Snow_SfcOptics.f90 CRTM_IRsnowCoeff.o CRTM_SEcategory.o CRTM_IRSnowEM.o CRTM_SfcOptics_Define.o CRTM_GeometryInfo_Define.o CRTM_Surface_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Spectral_Units_Conversion.o Message_Handler.o Type_Kinds.o CRTM_IRSSEM.o : CRTM_IRSSEM.f90 IRwaterCoeff_Define.o CRTM_Interpolation.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o -CRTM_IRwaterCoeff.o : CRTM_IRwaterCoeff.f90 IRwaterCoeff_Define.o Message_Handler.o +CRTM_IRwaterCoeff.o : CRTM_IRwaterCoeff.f90 IRwaterCoeff_Define.o IRwaterCoeff_IO.o Message_Handler.o CRTM_IR_Water_SfcOptics.o : CRTM_IR_Water_SfcOptics.f90 CRTM_IRwaterCoeff.o CRTM_IRSSEM.o CRTM_SfcOptics_Define.o CRTM_GeometryInfo_Define.o CRTM_Surface_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o CRTM_K_Matrix_Module.o : CRTM_K_Matrix_Module.f90 RTV_Define.o ASvar_Define.o CSvar_Define.o AOvar_Define.o CRTM_CloudCover_Define.o CRTM_Planck_Functions.o NLTECoeff_Define.o ACCoeff_Define.o CRTM_NLTECorrection.o CRTM_AerosolCoeff.o CRTM_CloudCoeff.o CRTM_AncillaryInput_Define.o CRTM_MoleculeScatter.o CRTM_AntennaCorrection.o CRTM_RTSolution.o CRTM_Active_Sensor.o CRTM_SfcOptics.o CRTM_SfcOptics_Define.o CRTM_AtmOptics.o CRTM_CloudScatter.o CRTM_AerosolScatter.o CRTM_AtmOptics_Define.o CRTM_AtmAbsorption.o CRTM_Predictor.o CRTM_Predictor_Define.o CRTM_GeometryInfo.o CRTM_GeometryInfo_Define.o CRTM_Atmosphere.o CRTM_Options_Define.o CRTM_RTSolution_Define.o CRTM_ChannelInfo_Define.o CRTM_Geometry_Define.o CRTM_Surface_Define.o CRTM_Atmosphere_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o CRTM_LifeCycle.o : CRTM_LifeCycle.f90 CRTM_MWwaterCoeff.o CRTM_VISiceCoeff.o CRTM_VISsnowCoeff.o CRTM_VISlandCoeff.o CRTM_VISwaterCoeff.o CRTM_IRiceCoeff.o CRTM_IRsnowCoeff.o CRTM_IRlandCoeff.o CRTM_IRwaterCoeff.o CRTM_CloudCoeff.o CRTM_AerosolCoeff.o CRTM_TauCoeff.o CRTM_SpcCoeff.o CRTM_ChannelInfo_Define.o Message_Handler.o @@ -81,13 +82,13 @@ CRTM_Surface_Define.o : CRTM_Surface_Define.f90 CRTM_SensorData_Define.o Binary_ CRTM_Tangent_Linear_Module.o : CRTM_Tangent_Linear_Module.f90 RTV_Define.o ASvar_Define.o CSvar_Define.o AOvar_Define.o CRTM_CloudCover_Define.o CRTM_Planck_Functions.o NLTECoeff_Define.o ACCoeff_Define.o CRTM_NLTECorrection.o CRTM_AerosolCoeff.o CRTM_CloudCoeff.o CRTM_AncillaryInput_Define.o CRTM_MoleculeScatter.o CRTM_AntennaCorrection.o CRTM_RTSolution.o CRTM_SfcOptics.o CRTM_SfcOptics_Define.o CRTM_AtmOptics.o CRTM_CloudScatter.o CRTM_AerosolScatter.o CRTM_AtmOptics_Define.o CRTM_AtmAbsorption.o CRTM_Predictor.o CRTM_Predictor_Define.o CRTM_GeometryInfo.o CRTM_GeometryInfo_Define.o CRTM_Atmosphere.o CRTM_Options_Define.o CRTM_RTSolution_Define.o CRTM_ChannelInfo_Define.o CRTM_Geometry_Define.o CRTM_Surface_Define.o CRTM_Atmosphere_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o CRTM_TauCoeff.o : CRTM_TauCoeff.f90 CRTM_SensorInfo.o ODZeeman_TauCoeff.o TauCoeff_Define.o ODSSU_Define.o ODSSU_TauCoeff.o ODPS_Define.o ODPS_TauCoeff.o ODAS_Define.o ODAS_TauCoeff.o CRTM_Parameters.o Message_Handler.o Binary_File_Utility.o File_Utility.o Type_Kinds.o CRTM_Utility.o : CRTM_Utility.f90 CRTM_Parameters.o Message_Handler.o Type_Kinds.o -CRTM_VISiceCoeff.o : CRTM_VISiceCoeff.f90 SEcategory_Define.o Message_Handler.o +CRTM_VISiceCoeff.o : CRTM_VISiceCoeff.f90 SEcategory_Define.o SEcategory_IO.o Message_Handler.o CRTM_VIS_Ice_SfcOptics.o : CRTM_VIS_Ice_SfcOptics.f90 CRTM_VISiceCoeff.o CRTM_SEcategory.o CRTM_SfcOptics_Define.o CRTM_GeometryInfo_Define.o CRTM_Surface_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Spectral_Units_Conversion.o Message_Handler.o Type_Kinds.o -CRTM_VISlandCoeff.o : CRTM_VISlandCoeff.f90 SEcategory_Define.o Message_Handler.o +CRTM_VISlandCoeff.o : CRTM_VISlandCoeff.f90 SEcategory_Define.o SEcategory_IO.o Message_Handler.o CRTM_VIS_Land_SfcOptics.o : CRTM_VIS_Land_SfcOptics.f90 CRTM_VISlandCoeff.o CRTM_SEcategory.o CRTM_SfcOptics_Define.o CRTM_GeometryInfo_Define.o CRTM_Surface_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Spectral_Units_Conversion.o Message_Handler.o Type_Kinds.o -CRTM_VISsnowCoeff.o : CRTM_VISsnowCoeff.f90 SEcategory_Define.o Message_Handler.o +CRTM_VISsnowCoeff.o : CRTM_VISsnowCoeff.f90 SEcategory_Define.o SEcategory_IO.o Message_Handler.o CRTM_VIS_Snow_SfcOptics.o : CRTM_VIS_Snow_SfcOptics.f90 CRTM_VISsnowCoeff.o CRTM_SEcategory.o CRTM_SfcOptics_Define.o CRTM_GeometryInfo_Define.o CRTM_Surface_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Spectral_Units_Conversion.o Message_Handler.o Type_Kinds.o -CRTM_VISwaterCoeff.o : CRTM_VISwaterCoeff.f90 SEcategory_Define.o Message_Handler.o +CRTM_VISwaterCoeff.o : CRTM_VISwaterCoeff.f90 SEcategory_Define.o SEcategory_IO.o Message_Handler.o CRTM_VIS_Water_SfcOptics.o : CRTM_VIS_Water_SfcOptics.f90 CRTM_VISwaterCoeff.o CRTM_SEcategory.o CRTM_SfcOptics_Define.o CRTM_GeometryInfo_Define.o CRTM_Surface_Define.o CRTM_SpcCoeff.o CRTM_Parameters.o Spectral_Units_Conversion.o Message_Handler.o Type_Kinds.o CSvar_Define.o : CSvar_Define.f90 CRTM_Interpolation.o Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o DateTime_Utility.o : DateTime_Utility.f90 Date_Utility.o Type_Kinds.o @@ -103,7 +104,13 @@ Fundamental_Constants.o : Fundamental_Constants.f90 Type_Kinds.o Guillou.o : Guillou.f90 Fundamental_Constants.o Type_Kinds.o Hyperbolic_Step.o : Hyperbolic_Step.f90 Type_Kinds.o iAtm_Define.o : iAtm_Define.f90 CRTM_Parameters.o Message_Handler.o Type_Kinds.o -IRwaterCoeff_Define.o : IRwaterCoeff_Define.f90 Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o +IRwaterCoeff_Define.o : IRwaterCoeff_Define.f90 Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o +IRwaterCoeff_netCDF_IO.o : IRwaterCoeff_netCDF_IO.f90 IRwaterCoeff_Define.o String_Utility.o File_Utility.o Message_Handler.o Type_Kinds.o +IRwaterCoeff_IO.o : IRwaterCoeff_IO.f90 IRwaterCoeff_netCDF_IO.o IRwaterCoeff_Define.o File_Utility.o Message_Handler.o Type_Kinds.o +IRsnowCoeff_Define.o : IRsnowCoeff_Define.f90 Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o +IRsnowCoeff_Binary_IO.o : IRsnowCoeff_Binary_IO.f90 IRsnowCoeff_Define.o String_Utility.o File_Utility.o Message_Handler.o Type_Kinds.o +IRsnowCoeff_netCDF_IO.o : IRsnowCoeff_netCDF_IO.f90 IRsnowCoeff_Define.o String_Utility.o File_Utility.o Message_Handler.o Type_Kinds.o +IRsnowCoeff_IO.o : IRsnowCoeff_IO.f90 IRsnowCoeff_netCDF_IO.o IRsnowCoeff_Binary_IO.o IRsnowCoeff_Define.o File_Utility.o Message_Handler.o Type_Kinds.o Large_Scale_Correction_Module.o : Large_Scale_Correction_Module.f90 CRTM_Interpolation.o FitCoeff_Define.o Type_Kinds.o Liu.o : Liu.f90 Fundamental_Constants.o Type_Kinds.o LSEatlas_Define.o : LSEatlas_Define.f90 Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o @@ -166,6 +173,8 @@ Reflection_Correction_Module.o : Reflection_Correction_Module.f90 FitCoeff_Defin RTV_Define.o : RTV_Define.f90 CRTM_SfcOptics.o SensorInfo_Parameters.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o Search_Utility.o : Search_Utility.f90 Message_Handler.o Type_Kinds.o SEcategory_Define.o : SEcategory_Define.f90 Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o +SEcategory_netCDF_IO.o : SEcategory_netCDF_IO.f90 SEcategory_Define.o String_Utility.o File_Utility.o Message_Handler.o Type_Kinds.o +SEcategory_IO.o : SEcategory_IO.f90 SEcategory_netCDF_IO.o SEcategory_Define.o File_Utility.o Message_Handler.o Type_Kinds.o SensorInfo_Parameters.o : SensorInfo_Parameters.f90 Slope_Variance.o : Slope_Variance.f90 Hyperbolic_Step.o Type_Kinds.o Small_Scale_Correction_Module.o : Small_Scale_Correction_Module.f90 FitCoeff_Define.o Type_Kinds.o diff --git a/src/Build/libsrc/make.filelist b/src/Build/libsrc/make.filelist index 18701e6..e27a94b 100644 --- a/src/Build/libsrc/make.filelist +++ b/src/Build/libsrc/make.filelist @@ -33,8 +33,9 @@ FSRC_FILES = \ AerosolCoeff_Define.f90 AerosolCoeff_Binary_IO.f90 AerosolCoeff_netCDF_IO.f90 AerosolCoeff_IO.f90 \ CRTM_Options_Define.f90 \ CRTM_AOD_Module.f90 \ - IRwaterCoeff_Define.f90 \ - SEcategory_Define.f90 \ + IRwaterCoeff_Define.f90 IRwaterCoeff_IO.f90 IRwaterCoeff_netCDF_IO.f90 \ + IRsnowCoeff_Define.f90 IRsnowCoeff_IO.f90 IRsnowCoeff_netCDF_IO.f90 IRsnowCoeff_Binary_IO.f90 \ + SEcategory_Define.f90 SEcategory_IO.f90 SEcategory_netCDF_IO.f90\ LSEatlas_Define.f90 \ MWwaterCoeff_Define.f90 \ FitCoeff_Define.f90 \ @@ -88,7 +89,7 @@ FSRC_FILES = \ CRTM_SfcOptics.f90 \ CRTM_IR_Land_SfcOptics.f90 CRTM_IR_Water_SfcOptics.f90 CRTM_IR_Snow_SfcOptics.f90 CRTM_IR_Ice_SfcOptics.f90 \ CRTM_MW_Land_SfcOptics.f90 CRTM_MW_Water_SfcOptics.f90 CRTM_MW_Snow_SfcOptics.f90 CRTM_MW_Ice_SfcOptics.f90 \ - CRTM_VIS_Land_SfcOptics.f90 CRTM_VIS_Water_SfcOptics.f90 CRTM_VIS_Snow_SfcOptics.f90 CRTM_VIS_Ice_SfcOptics.f90 \ + CRTM_VIS_Land_SfcOptics.f90 CRTM_VIS_Water_SfcOptics.f90 CRTM_VIS_Snow_SfcOptics.f90 CRTM_VIS_Ice_SfcOptics.f90 \ CRTM_SEcategory.f90 \ CRTM_LowFrequency_MWSSEM.f90 \ CRTM_Fastem1.f90 \ @@ -100,6 +101,7 @@ FSRC_FILES = \ Guillou.f90 Ellison.f90 Liu.f90 \ Fresnel.f90 \ CRTM_IRSSEM.f90 \ + CRTM_IRSnowEM.f90 \ CRTM_AtmOptics.f90 CRTM_AtmOptics_Define.f90 AOvar_Define.f90 \ CRTM_Planck_Functions.f90 \ RTV_Define.f90 \ diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 808996b..61c637c 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -66,9 +66,17 @@ list( APPEND crtm_src_files Coefficients/CRTM_VISwaterCoeff.f90 Coefficients/EmisCoeff/IR_Land/LSEatlas/LSEatlas_Define.f90 Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_Define.f90 + Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_IO.f90 + Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_netCDF_IO.f90 + Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_Define.f90 + Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_IO.f90 + Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_Binary_IO.f90 + Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_netCDF_IO.f90 Coefficients/EmisCoeff/MW_Water/MWwaterCoeff_Define.f90 Coefficients/EmisCoeff/MW_Water/MWwaterLUT/MWwaterLUT_Define.f90 Coefficients/EmisCoeff/SEcategory/SEcategory_Define.f90 + Coefficients/EmisCoeff/SEcategory/SEcategory_IO.f90 + Coefficients/EmisCoeff/SEcategory/SEcategory_netCDF_IO.f90 Coefficients/FitCoeff/FitCoeff_Define.f90 Coefficients/FitCoeff/FitCoeff_Destroy.inc Coefficients/FitCoeff/FitCoeff_Equal.inc @@ -142,6 +150,7 @@ list( APPEND crtm_src_files SfcOptics/CRTM_VIS_Snow_SfcOptics.f90 SfcOptics/CRTM_VIS_Water_SfcOptics.f90 SfcOptics/IR_Water/IRSSEM/CRTM_IRSSEM.f90 + SfcOptics/IR_Snow/CRTM_IRSnowEM.f90 SfcOptics/MW_Water/FASTEM_MWSSEM/Azimuth_Emissivity_F6_Module.f90 SfcOptics/MW_Water/FASTEM_MWSSEM/Azimuth_Emissivity_Module.f90 SfcOptics/MW_Water/FASTEM_MWSSEM/CRTM_Fastem1.f90 diff --git a/src/CRTM_Adjoint_Module.f90 b/src/CRTM_Adjoint_Module.f90 index 765a71f..0ebbee7 100644 --- a/src/CRTM_Adjoint_Module.f90 +++ b/src/CRTM_Adjoint_Module.f90 @@ -1141,7 +1141,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) END IF ! The radiance post-processing - CALL Post_Process_RTSolution(RTSolution(ln,m), & + CALL Post_Process_RTSolution(Opt, RTSolution(ln,m), & NLTE_Predictor, & ChannelIndex, SensorIndex, & compute_antenna_correction, GeometryInfo) @@ -1160,7 +1160,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) ! Perform clear-sky post and pre-processing IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN ! Radiance post-processing - CALL Post_Process_RTSolution(RTSolution_Clear, & + CALL Post_Process_RTSolution(Opt, RTSolution_Clear, & NLTE_Predictor, & ChannelIndex, SensorIndex, & compute_antenna_correction, GeometryInfo) @@ -1476,10 +1476,11 @@ END FUNCTION profile_solution ! 3. Apply antenna correction to brightness temperature ! ---------------------------------------------------------------- - SUBROUTINE Post_Process_RTSolution(rts, & + SUBROUTINE Post_Process_RTSolution(Opt, rts, & NLTE_Predictor, & ChannelIndex, SensorIndex, & compute_antenna_correction, GeometryInfo) + TYPE(CRTM_Options_type), INTENT(IN) :: Opt TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: rts TYPE(NLTE_Predictor_type), INTENT(IN) :: NLTE_Predictor INTEGER, INTENT(IN) :: ChannelIndex, SensorIndex diff --git a/src/CRTM_K_Matrix_Module.f90 b/src/CRTM_K_Matrix_Module.f90 index fcb0ac5..73d73ea 100644 --- a/src/CRTM_K_Matrix_Module.f90 +++ b/src/CRTM_K_Matrix_Module.f90 @@ -418,11 +418,11 @@ FUNCTION CRTM_K_Matrix( & !$OMP END SINGLE !$OMP END PARALLEL - print *,' n_omp_threads = ',n_omp_threads, n_Profiles + ! print *,' n_omp_threads = ',n_omp_threads, n_Profiles ! Determine how many threads to use for profiles and channels ! After profiles get what they need, we use the left-over threads ! to parallelize channels - IF ( n_omp_threads <= n_Profiles ) THEN + IF ( n_omp_threads <= n_Profiles .OR. n_Profiles == 0) THEN n_profile_threads = n_omp_threads n_channel_threads = 1 CALL OMP_SET_MAX_ACTIVE_LEVELS(1) @@ -458,10 +458,10 @@ FUNCTION CRTM_K_Matrix( & Atmosphere(m)%Cloud(nc)%Effective_Radius(:) = ZERO END WHERE END DO - + IF(.NOT. CRTM_CloudCoeff_IsLoaded() )THEN - + Error_Status = FAILURE WRITE( Message,'("The CloudCoeff data must be loaded (with CRTM_Init routine) ", & &"for the cloudy case profile #",i0)' ) m @@ -482,7 +482,7 @@ FUNCTION CRTM_K_Matrix( & IF (Error_Status == FAILURE) THEN RETURN END IF - + !$OMP PARALLEL DO PRIVATE (Opt, AncillaryInput) NUM_THREADS(n_profile_threads) SCHEDULE (runtime) Profile_Loop2: DO m = 1, n_Profiles ! Check the optional Options structure argument @@ -504,7 +504,7 @@ FUNCTION CRTM_K_Matrix( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF - + IF (enable_timing) THEN CALL SYSTEM_CLOCK (count=count_end) elapsed = REAL (count_end - count_start) / REAL (count_rate) @@ -537,7 +537,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) INTEGER, INTENT(in) :: m ! profile index TYPE(CRTM_Options_type), INTENT(IN) :: Opt TYPE(CRTM_AncillaryInput_type), INTENT(IN) :: AncillaryInput - + ! Local variables INTEGER :: Error_Status CHARACTER(256) :: Message @@ -589,7 +589,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) ! Silence gfortran complaints about maybe-used-uninit by init to huge() r_cloudy = HUGE(r_cloudy) - + ! Reinitialise the output RTSolution CALL CRTM_RTSolution_Zero(RTSolution(:,m)) @@ -780,7 +780,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) ! Setup for fractional cloud coverage IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN - + ! Compute cloudcover Error_Status = CloudCover%Compute_CloudCover(atm, Overlap = opt%Overlap_Id) IF ( Error_Status /= SUCCESS ) THEN @@ -995,7 +995,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) RTSolution(ln,m)%WMO_Satellite_Id = ChannelInfo(n)%WMO_Satellite_Id RTSolution(ln,m)%WMO_Sensor_Id = ChannelInfo(n)%WMO_Sensor_Id RTSolution(ln,m)%Sensor_Channel = ChannelInfo(n)%Sensor_Channel(l) - + RTSolution_K(ln,m)%Sensor_Id = RTSolution(ln,m)%Sensor_Id RTSolution_K(ln,m)%WMO_Satellite_Id = RTSolution(ln,m)%WMO_Satellite_Id RTSolution_K(ln,m)%WMO_Sensor_Id = RTSolution(ln,m)%WMO_Sensor_Id @@ -1225,8 +1225,8 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) ! Clear_sky case uses Emission_Module.f90 without atmospheric scatterings right now. IF( ks == 1 ) & RTSolution_Clear_K(nt)%Radiance=(ONE-CloudCover%Total_Cloud_Cover)*RTSolution_K(ln,m)%Stokes(ks) - RTSolution_K(ln,m)%Stokes(ks) = CloudCover%Total_Cloud_Cover*RTSolution_K(ln,m)%Stokes(ks) - END DO + RTSolution_K(ln,m)%Stokes(ks) = CloudCover%Total_Cloud_Cover*RTSolution_K(ln,m)%Stokes(ks) + END DO END IF END IF END IF @@ -1282,10 +1282,10 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) CYCLE Thread_Loop END IF END IF - + IF(mth_Azi == RTV(nt)%n_Azi) THEN ! Combine cloudy and clear radiances for fractional cloud coverage - IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN IF( RTV(nt)%n_Stokes == 1 ) THEN r_cloudy(1) = RTSolution(ln,m)%Radiance ! Save the 100% cloudy radiance RTSolution(ln,m)%Radiance = & @@ -1297,16 +1297,16 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) r_cloudy(ks) = RTSolution(ln,m)%Stokes(ks) ! Save the 100% cloudy radiance RTSolution(ln,m)%Stokes(ks) = & ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_Clear(nt)%Stokes(ks)) + & - (CloudCover%Total_Cloud_Cover * RTSolution(ln,m)%Stokes(ks)) + (CloudCover%Total_Cloud_Cover * RTSolution(ln,m)%Stokes(ks)) END DO RTSolution(ln,m)%Radiance = RTSolution(ln,m)%Stokes(1) END IF ! ...Save the cloud cover in the output structure RTSolution(ln,m)%Total_Cloud_Cover = CloudCover%Total_Cloud_Cover END IF - + ! The radiance post-processing - CALL Post_Process_RTSolution(RTSolution(ln,m), & + CALL Post_Process_RTSolution(Opt, RTSolution(ln,m), & NLTE_Predictor, & ChannelIndex, SensorIndex, & compute_antenna_correction, GeometryInfo) @@ -1329,7 +1329,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) ! Perform clear-sky post and pre-processing IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN ! Radiance post-processing - CALL Post_Process_RTSolution(RTSolution_Clear(nt), & + CALL Post_Process_RTSolution(Opt, RTSolution_Clear(nt), & NLTE_Predictor, & ChannelIndex, SensorIndex, & compute_antenna_correction, GeometryInfo) @@ -1339,7 +1339,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) ! The adjoint radiance pre-processing - CALL Pre_Process_RTSolution_K(RTSolution(ln,m), RTSolution_K(ln,m), & + CALL Pre_Process_RTSolution_K(Opt, RTSolution(ln,m), RTSolution_K(ln,m), & NLTE_Predictor, NLTE_Predictor_K(nt), & ChannelIndex, SensorIndex, & compute_antenna_correction, GeometryInfo) @@ -1357,9 +1357,9 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) END IF END IF - + END IF - + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag).and.RTV(nt)%mth_Azi==0 ) THEN ! The adjoint of the clear sky radiative transfer for fractionally cloudy atmospheres RTV_Clear(nt)%mth_Azi = RTV(nt)%mth_Azi @@ -1387,8 +1387,8 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) CYCLE Thread_Loop END IF END IF - - + + ! The adjoint of the radiative transfer Error_Status = CRTM_Compute_RTSolution_AD( & Atm , & ! FWD Input @@ -1613,7 +1613,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) CYCLE Thread_Loop END IF END IF - + ! K-matrix of the atmosphere layer addition Error_Status = CRTM_Atmosphere_AddLayers_AD( Atmosphere(m), Atm_K(nt), Atmosphere_K(ln,m) ) @@ -1667,7 +1667,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) !$OMP END PARALLEL DO END FUNCTION profile_solution - + ! ---------------------------------------------------------------- ! Local subroutine to post-process the FORWARD radiance, as it is ! the same for all-sky and fractional clear-sky cases. @@ -1677,10 +1677,11 @@ END FUNCTION profile_solution ! 3. Apply antenna correction to brightness temperature ! ---------------------------------------------------------------- - SUBROUTINE Post_Process_RTSolution(rts, & + SUBROUTINE Post_Process_RTSolution(Opt, rts, & NLTE_Predictor, & ChannelIndex, SensorIndex, & compute_antenna_correction, GeometryInfo) + TYPE(CRTM_Options_type), INTENT(IN) :: Opt TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: rts TYPE(NLTE_Predictor_type), INTENT(IN) :: NLTE_Predictor INTEGER, INTENT(IN) :: ChannelIndex, SensorIndex @@ -1720,11 +1721,12 @@ END SUBROUTINE Post_Process_RTSolution ! 2. Convert adjoint radiances to brightness temperatures ! 3. Apply adjoint non-LTE correction to radiances ! ---------------------------------------------------------------- - - SUBROUTINE Pre_Process_RTSolution_K(rts, rts_K, & + + SUBROUTINE Pre_Process_RTSolution_K(Opt, rts, rts_K, & NLTE_Predictor, NLTE_Predictor_K, & ChannelIndex, SensorIndex, & compute_antenna_correction, GeometryInfo) + TYPE(CRTM_Options_type), INTENT(IN) :: Opt TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: rts, rts_K TYPE(NLTE_Predictor_type), INTENT(IN) :: NLTE_Predictor TYPE(NLTE_Predictor_type), INTENT(IN OUT) :: NLTE_Predictor_K diff --git a/src/CRTM_Tangent_Linear_Module.f90 b/src/CRTM_Tangent_Linear_Module.f90 index bd0639f..95e6bdb 100644 --- a/src/CRTM_Tangent_Linear_Module.f90 +++ b/src/CRTM_Tangent_Linear_Module.f90 @@ -286,7 +286,7 @@ FUNCTION CRTM_Tangent_Linear( & TYPE(CRTM_Atmosphere_type), INTENT(IN OUT) :: Atmosphere(:) ! M TYPE(CRTM_Surface_type), INTENT(IN) :: Surface(:) ! M TYPE(CRTM_Atmosphere_type), INTENT(IN) :: Atmosphere_TL(:) ! M - TYPE(CRTM_Surface_type), INTENT(IN) :: Surface_TL(:) ! M + TYPE(CRTM_Surface_type), INTENT(IN) :: Surface_TL(:) ! M TYPE(CRTM_Geometry_type), INTENT(IN) :: Geometry(:) ! M TYPE(CRTM_ChannelInfo_type), INTENT(IN) :: ChannelInfo(:) ! n_Sensors TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: RTSolution(:,:) ! L x M @@ -381,14 +381,14 @@ FUNCTION CRTM_Tangent_Linear( & ! Determine how many threads to use for profiles and channels ! After profiles get what they need, we use the left-over threads ! to parallelize channels - IF ( n_omp_threads <= n_Profiles ) THEN + IF ( n_omp_threads <= n_Profiles .OR. n_Profiles == 0) THEN n_profile_threads = n_omp_threads n_channel_threads = 1 CALL OMP_SET_MAX_ACTIVE_LEVELS(1) ELSE n_profile_threads = n_Profiles n_channel_threads = MIN(n_Channels, n_omp_threads / n_Profiles) -! There may have bug for MW and IR cases by using openMP over channels +! There may have bug for MW and IR cases by using openMP over channels ! IF(SpcCoeff_IsInfraredSensor(SC(1)) .OR. & ! SpcCoeff_IsMicrowaveSensor(SC(1)) ) THEN ! n_channel_threads = 1 @@ -400,7 +400,7 @@ FUNCTION CRTM_Tangent_Linear( & END IF END IF -! WRITE(6,*) +! WRITE(6,*) ! WRITE(6,'(" Using",i3," OpenMP threads =",i3," for profiles and",i3," for channels.")') & ! n_omp_threads, n_profile_threads, n_channel_threads @@ -439,7 +439,7 @@ FUNCTION CRTM_Tangent_Linear( & CYCLE Profile_Loop1 END IF END DO Profile_Loop1 -!$OMP END PARALLEL DO +!$OMP END PARALLEL DO IF (Error_Status == FAILURE) THEN RETURN @@ -480,7 +480,7 @@ FUNCTION CRTM_Tangent_Linear( & CALL CRTM_RTSolution_Inspect (RTSolution(:,:)) END IF RETURN - + CONTAINS ! Function profile_solution contains all the computational code inside of CRTM_Forward that @@ -493,7 +493,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) INTEGER, INTENT(in) :: m ! profile index TYPE(CRTM_Options_type), INTENT(IN) :: Opt TYPE(CRTM_AncillaryInput_type), INTENT(IN) :: AncillaryInput - + ! Local variables INTEGER :: Error_Status CHARACTER(256) :: Message @@ -552,7 +552,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) ! ...Assign the option specific SfcOptics input IF( Opt%n_Stokes > 0 ) RTV(nt)%n_Stokes = Opt%n_Stokes RTV(nt)%RT_Algorithm_Id = Opt%RT_Algorithm_Id - END IF + END IF CALL CRTM_SfcOptics_Create( SfcOptics(nt) , MAX_N_ANGLES, MAX_N_STOKES ) CALL CRTM_SfcOptics_Create( SfcOptics_TL(nt), MAX_N_ANGLES, MAX_N_STOKES ) @@ -691,7 +691,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) Atm%n_Layers , & MAX_N_LEGENDRE_TERMS, & CloudC%N_PHASE_ELEMENTS ) - + IF ( Options_Present ) THEN AtmOptics(nt)%depolarization = Opt%depolarization AtmOptics_TL(nt)%depolarization = Opt%depolarization @@ -700,7 +700,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) AtmOptics_TL(nt)%n_Stokes = RTV(nt)%n_Stokes AtmOptics(nt)%Include_Scattering = Opt%Include_Scattering AtmOptics_TL(nt)%Include_Scattering = Opt%Include_Scattering - END IF + END IF IF ( (.NOT. CRTM_AtmOptics_Associated( Atmoptics(nt) )) .OR. & (.NOT. CRTM_AtmOptics_Associated( Atmoptics_TL(nt) )) ) THEN @@ -731,8 +731,8 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) Atm%n_Layers , & Atm%n_Aerosols ) END IF - END DO -!$OMP END PARALLEL DO + END DO +!$OMP END PARALLEL DO IF ( Error_Status == FAILURE) RETURN @@ -784,7 +784,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) SfcOptics_Clear_TL(nt)%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM SfcOptics_Clear(nt)%n_Stokes = RTV(nt)%n_Stokes ! It may be changed for CSEM. SfcOptics_Clear_TL(nt)%n_Stokes = RTV(nt)%n_Stokes ! It may be changed for CSEM. - + ! ...CLEAR SKY average surface skin temperature for multi-surface types CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics_Clear(nt) ) CALL CRTM_Compute_SurfaceT_TL( Surface(m), Surface_TL(m), SfcOptics_Clear_TL(nt) ) @@ -881,7 +881,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) END IF END IF END DO -!$OMP END PARALLEL DO +!$OMP END PARALLEL DO IF ( Error_Status == FAILURE ) RETURN @@ -989,7 +989,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) ! ...Transfer stream count to scattering structure AtmOptics(nt)%n_Legendre_Terms = n_Full_Streams AtmOptics_TL(nt)%n_Legendre_Terms = n_Full_Streams - + ! Compute the gas absorption CALL CRTM_Compute_AtmAbsorption( SensorIndex , & ! Input ChannelIndex , & ! Input @@ -1125,7 +1125,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) CALL CRTM_AtmOptics_Combine( AtmOptics(nt), AOvar(nt) ) CALL CRTM_AtmOptics_Combine_TL( AtmOptics(nt), AtmOptics_TL(nt), AOvar(nt) ) END IF - + ! ...Save vertically integrated scattering optical depth for output RTSolution(ln,m)%SOD = AtmOptics(nt)%Scattering_Optical_Depth RTSolution_TL(ln,m)%SOD = AtmOptics_TL(nt)%Scattering_Optical_Depth @@ -1171,7 +1171,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) END IF END IF -! non scattering case, this condition may be changed for future surface reflectance +! non scattering case, this condition may be changed for future surface reflectance IF( .not.RTSolution(ln,m)%Scattering_FLAG .or. .not.AtmOptics(nt)%Include_Scattering ) RTV(nt)%n_Azi = 0 ! Fourier component loop for azimuth angles (VIS). @@ -1206,7 +1206,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) END IF - + ! ...Tangent-linear model Error_Status = CRTM_Compute_RTSolution_TL( & Atm , & ! FWD Input @@ -1230,7 +1230,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) CYCLE !RETURN END IF - + ! Repeat clear sky for fractionally cloudy atmospheres IF (CRTM_Atmosphere_IsFractional(cloud_coverage_flag).and.RTV(nt)%mth_Azi==0 ) THEN RTV_Clear(nt)%mth_Azi = mth_Azi @@ -1280,10 +1280,10 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) END DO Azimuth_Fourier_Loop - + ! Combine cloudy and clear radiances for fractional cloud coverage IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN - ! ...Save the 100% cloudy radince (or just reverse the order of calculation?) + ! ...Save the 100% cloudy radince (or just reverse the order of calculation?) DO ks = 1, RTV(nt)%n_Stokes r_cloudy = RTSolution(ln,m)%Stokes(ks) ! ...Forward radiance @@ -1300,26 +1300,26 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) RTSolution(ln,m)%Total_Cloud_Cover = CloudCover%Total_Cloud_Cover RTSolution_TL(ln,m)%Total_Cloud_Cover = CloudCover_TL%Total_Cloud_Cover END DO - + RTSolution(ln,m)%Radiance = RTSolution(ln,m)%Stokes(1) RTSolution_TL(ln,m)%Radiance = RTSolution_TL(ln,m)%Stokes(1) END IF - + ! Combine cloudy and clear radiances for fractional cloud coverage ! The radiance post-processing - CALL Post_Process_RTSolution(RTSolution(ln,m), RTSolution_TL(ln,m), & + CALL Post_Process_RTSolution(Opt, RTSolution(ln,m), RTSolution_TL(ln,m), & NLTE_Predictor, NLTE_Predictor_TL,& ChannelIndex, SensorIndex, & compute_antenna_correction, GeometryInfo) - ! Combine cloudy and clear radiances for fractional cloud coverage + ! Combine cloudy and clear radiances for fractional cloud coverage ! Perform clear-sky post-processing IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN - CALL Post_Process_RTSolution(RTSolution_Clear(nt), RTSolution_Clear_TL(nt), & + CALL Post_Process_RTSolution(Opt, RTSolution_Clear(nt), RTSolution_Clear_TL(nt), & NLTE_Predictor, NLTE_Predictor_TL, & ChannelIndex, SensorIndex, & compute_antenna_correction, GeometryInfo) - + ! ...Save the results in the output structure RTSolution(ln,m)%R_Clear = RTSolution_Clear(nt)%Radiance RTSolution(ln,m)%Tb_Clear = RTSolution_Clear(nt)%Brightness_Temperature @@ -1348,7 +1348,7 @@ FUNCTION profile_solution (m, Opt, AncillaryInput) RESULT( Error_Status ) END DO Channel_Loop END DO Thread_Loop -!$OMP END PARALLEL DO +!$OMP END PARALLEL DO IF ( Error_Status == FAILURE ) RETURN @@ -1389,13 +1389,14 @@ END FUNCTION profile_solution ! 2. Convert radiance to brightness temperature ! 3. Apply antenna correction to brightness temperature ! ---------------------------------------------------------------- - - SUBROUTINE Post_Process_RTSolution(rts, rts_TL, NLTE_Predictor, NLTE_Predictor_TL, & + + SUBROUTINE Post_Process_RTSolution(Opt, rts, rts_TL, NLTE_Predictor, NLTE_Predictor_TL, & ChannelIndex, SensorIndex, & compute_antenna_correction, GeometryInfo) + TYPE(CRTM_Options_type), INTENT(IN) :: Opt TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: rts, rts_TL TYPE(NLTE_Predictor_type), INTENT(IN) :: NLTE_Predictor - TYPE(NLTE_Predictor_type), INTENT(IN) :: NLTE_Predictor_TL + TYPE(NLTE_Predictor_type), INTENT(IN) :: NLTE_Predictor_TL INTEGER, INTENT(IN) :: ChannelIndex, SensorIndex LOGICAL, INTENT(IN) :: compute_antenna_correction TYPE(CRTM_GeometryInfo_type), INTENT(IN) :: GeometryInfo @@ -1438,7 +1439,7 @@ SUBROUTINE Post_Process_RTSolution(rts, rts_TL, NLTE_Predictor, NLTE_Predictor_T rts_TL ) ! Output END IF - END SUBROUTINE Post_Process_RTSolution + END SUBROUTINE Post_Process_RTSolution END FUNCTION CRTM_Tangent_Linear diff --git a/src/CRTM_Version.inc b/src/CRTM_Version.inc index ba79fa3..e973695 100644 --- a/src/CRTM_Version.inc +++ b/src/CRTM_Version.inc @@ -1 +1 @@ -#define CRTM_VERSION 'v2.4.1-alpha' +#define CRTM_VERSION 'v3.0.0' diff --git a/src/Coefficients/CRTM_IRiceCoeff.f90 b/src/Coefficients/CRTM_IRiceCoeff.f90 index a015f0f..e144c7d 100644 --- a/src/Coefficients/CRTM_IRiceCoeff.f90 +++ b/src/Coefficients/CRTM_IRiceCoeff.f90 @@ -2,7 +2,7 @@ ! CRTM_IRiceCoeff ! ! Module containing the shared CRTM infrared ice surface emissivity -! data and their load/destruction routines. +! data and their load/destruction routines. ! ! PUBLIC DATA: ! IRiceC: Data structure containing the infrared ice surface @@ -19,7 +19,9 @@ ! CREATION HISTORY: ! Written by: Paul van Delst, 20-Jan-2012 ! paul.vandelst@noaa.gov -! +! Modified by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu +! Add SEcategory_ReadFile_IO for netCDF I/O MODULE CRTM_IRiceCoeff @@ -30,8 +32,8 @@ MODULE CRTM_IRiceCoeff USE Message_Handler , ONLY: SUCCESS, FAILURE, Display_Message USE SEcategory_Define, ONLY: SEcategory_type, & SEcategory_Associated, & - SEcategory_Destroy, & - SEcategory_ReadFile + SEcategory_Destroy + USE SEcategory_IO, ONLY: SEcategory_ReadFile_IO ! Disable all implicit typing IMPLICIT NONE @@ -79,6 +81,7 @@ MODULE CRTM_IRiceCoeff ! Error_Status = CRTM_IRiceCoeff_Load( & ! Filename, & ! File_Path = File_Path , & +! netCDF = netCDF , & ! Quiet = Quiet , & ! Process_ID = Process_ID , & ! Output_Process_ID = Output_Process_ID ) @@ -100,6 +103,15 @@ MODULE CRTM_IRiceCoeff ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN), OPTIONAL ! +! netCDF: Set this logical argument to specify file format. +! If == .FALSE., Binary [DEFAULT]. +! == .TRUE., netCDF +! 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]. @@ -123,7 +135,7 @@ MODULE CRTM_IRiceCoeff ! Output_Process_ID: Set this argument to the MPI process ID in which ! all INFORMATION messages are to be output. If ! the passed Process_ID value agrees with this value -! the INFORMATION messages are output. +! the INFORMATION messages are output. ! This argument is ignored if the Quiet argument ! is set. ! UNITS: N/A @@ -151,6 +163,7 @@ MODULE CRTM_IRiceCoeff FUNCTION CRTM_IRiceCoeff_Load( & Filename , & ! Input File_Path , & ! Optional input + netCDF , & ! Optional input Quiet , & ! Optional input Process_ID , & ! Optional input Output_Process_ID) & ! Optional input @@ -158,7 +171,8 @@ FUNCTION CRTM_IRiceCoeff_Load( & ! Arguments CHARACTER(*), INTENT(IN) :: Filename CHARACTER(*), OPTIONAL, INTENT(IN) :: File_Path - LOGICAL , OPTIONAL, INTENT(IN) :: Quiet + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + LOGICAL , OPTIONAL, INTENT(IN) :: Quiet INTEGER , OPTIONAL, INTENT(IN) :: Process_ID INTEGER , OPTIONAL, INTENT(IN) :: Output_Process_ID ! Function result @@ -169,8 +183,10 @@ FUNCTION CRTM_IRiceCoeff_Load( & CHARACTER(ML) :: msg, pid_msg CHARACTER(ML) :: IRiceCoeff_File LOGICAL :: noisy + ! Function variables + LOGICAL :: Binary - ! Setup + ! Setup err_stat = SUCCESS ! ...Assign the filename to local variable IRiceCoeff_File = ADJUSTL(Filename) @@ -189,12 +205,16 @@ FUNCTION CRTM_IRiceCoeff_Load( & ELSE pid_msg = '' END IF - - + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + ! Read the IR ice SEcategory file - err_stat = SEcategory_ReadFile( & + err_stat = SEcategory_ReadFile_IO( & IRiceC, & IRiceCoeff_File, & + netCDF = .NOT. Binary, & Quiet = .NOT. noisy ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading IRiceCoeff SEcategory file '//TRIM(IRiceCoeff_File)//TRIM(pid_msg) @@ -203,7 +223,7 @@ FUNCTION CRTM_IRiceCoeff_Load( & CONTAINS - + SUBROUTINE Load_CleanUp() CALL SEcategory_Destroy( IRiceC ) err_stat = FAILURE @@ -283,7 +303,7 @@ FUNCTION CRTM_IRiceCoeff_Destroy( Process_ID ) RESULT( err_stat ) END FUNCTION CRTM_IRiceCoeff_Destroy - + !------------------------------------------------------------------------------ !:sdoc+: ! diff --git a/src/Coefficients/CRTM_IRlandCoeff.f90 b/src/Coefficients/CRTM_IRlandCoeff.f90 index daa5a53..36d7b49 100644 --- a/src/Coefficients/CRTM_IRlandCoeff.f90 +++ b/src/Coefficients/CRTM_IRlandCoeff.f90 @@ -19,7 +19,9 @@ ! CREATION HISTORY: ! Written by: Paul van Delst, 19-Aug-2011 ! paul.vandelst@noaa.gov -! +! Modified by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu +! Add SEcategory_ReadFile_IO for netCDF I/O MODULE CRTM_IRlandCoeff @@ -30,8 +32,8 @@ MODULE CRTM_IRlandCoeff USE Message_Handler , ONLY: SUCCESS, FAILURE, Display_Message USE SEcategory_Define, ONLY: SEcategory_type, & SEcategory_Associated, & - SEcategory_Destroy, & - SEcategory_ReadFile + SEcategory_Destroy + USE SEcategory_IO, ONLY: SEcategory_ReadFile_IO ! Disable all implicit typing IMPLICIT NONE @@ -80,6 +82,7 @@ MODULE CRTM_IRlandCoeff ! Error_Status = CRTM_IRlandCoeff_Load( & ! Filename, & ! File_Path = File_Path , & +! netCDF = netCDF , & ! Quiet = Quiet , & ! Process_ID = Process_ID , & ! Output_Process_ID = Output_Process_ID ) @@ -101,6 +104,15 @@ MODULE CRTM_IRlandCoeff ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN), OPTIONAL ! +! netCDF: Set this logical argument to specify file format. +! If == .FALSE., Binary [DEFAULT]. +! == .TRUE., netCDF +! 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]. @@ -152,6 +164,7 @@ MODULE CRTM_IRlandCoeff FUNCTION CRTM_IRlandCoeff_Load( & Filename , & ! Input File_Path , & ! Optional input + netCDF , & ! Optional input Quiet , & ! Optional input Process_ID , & ! Optional input Output_Process_ID) & ! Optional input @@ -159,6 +172,7 @@ FUNCTION CRTM_IRlandCoeff_Load( & ! Arguments CHARACTER(*), INTENT(IN) :: Filename CHARACTER(*), OPTIONAL, INTENT(IN) :: File_Path + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF LOGICAL , OPTIONAL, INTENT(IN) :: Quiet INTEGER , OPTIONAL, INTENT(IN) :: Process_ID INTEGER , OPTIONAL, INTENT(IN) :: Output_Process_ID @@ -170,6 +184,8 @@ FUNCTION CRTM_IRlandCoeff_Load( & CHARACTER(ML) :: msg, pid_msg CHARACTER(ML) :: IRlandCoeff_File LOGICAL :: noisy + ! Function variables + LOGICAL :: Binary ! Setup err_stat = SUCCESS @@ -190,12 +206,16 @@ FUNCTION CRTM_IRlandCoeff_Load( & ELSE pid_msg = '' END IF + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF ! Read the IR land SEcategory file - err_stat = SEcategory_ReadFile( & + err_stat = SEcategory_ReadFile_IO( & IRlandC, & IRlandCoeff_File, & + netCDF = .NOT. Binary, & Quiet = .NOT. noisy ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading IRlandCoeff SEcategory file '//TRIM(IRlandCoeff_File)//TRIM(pid_msg) diff --git a/src/Coefficients/CRTM_IRsnowCoeff.f90 b/src/Coefficients/CRTM_IRsnowCoeff.f90 index a32d123..38c4294 100644 --- a/src/Coefficients/CRTM_IRsnowCoeff.f90 +++ b/src/Coefficients/CRTM_IRsnowCoeff.f90 @@ -2,7 +2,7 @@ ! CRTM_IRsnowCoeff ! ! Module containing the shared CRTM infrared snow surface emissivity -! data and their load/destruction routines. +! data and their load/destruction routines. ! ! PUBLIC DATA: ! IRsnowC: Data structure containing the infrared snow surface @@ -19,7 +19,12 @@ ! CREATION HISTORY: ! Written by: Paul van Delst, 20-Jan-2012 ! paul.vandelst@noaa.gov -! +! Modified by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu +! Add SEcategory_ReadFile_IO for netCDF I/O +! Modified by: Cheng Dang, 31-May-2022 +! dangch@ucar.edu +! Add IRsnowCoeff modules MODULE CRTM_IRsnowCoeff @@ -27,11 +32,15 @@ MODULE CRTM_IRsnowCoeff ! Environment setup ! ----------------- ! Module use - USE Message_Handler , ONLY: SUCCESS, FAILURE, Display_Message - USE SEcategory_Define, ONLY: SEcategory_type, & - SEcategory_Associated, & - SEcategory_Destroy, & - SEcategory_ReadFile + USE Message_Handler , ONLY: SUCCESS, FAILURE, Display_Message + USE SEcategory_Define, ONLY: SEcategory_type, & + SEcategory_Associated, & + SEcategory_Destroy + USE SEcategory_IO, ONLY: SEcategory_ReadFile_IO + USE IRsnowCoeff_Define, ONLY: IRsnowCoeff_type, & + IRsnowCoeff_Associated, & + IRsnowCoeff_Destroy + USE IRsnowCoeff_IO, ONLY: IRsnowCoeff_ReadFile ! Disable all implicit typing IMPLICIT NONE @@ -42,11 +51,12 @@ MODULE CRTM_IRsnowCoeff ! Everything private by default PRIVATE ! The shared data - PUBLIC :: IRsnowC + PUBLIC :: IRsnowC_SE, IRsnowC ! Procedures PUBLIC :: CRTM_IRsnowCoeff_Load PUBLIC :: CRTM_IRsnowCoeff_Destroy PUBLIC :: CRTM_IRsnowCoeff_IsLoaded + PUBLIC :: CRTM_IRsnowCoeff_SE_IsLoaded ! ----------------- @@ -59,7 +69,8 @@ MODULE CRTM_IRsnowCoeff ! ------------------------------------------------ ! The shared infrared snow surface emissivity data ! ------------------------------------------------ - TYPE(SEcategory_type), SAVE :: IRsnowC + TYPE(SEcategory_type), SAVE :: IRsnowC_SE + TYPE(IRsnowCoeff_type), SAVE :: IRsnowC CONTAINS @@ -79,6 +90,8 @@ MODULE CRTM_IRsnowCoeff ! Error_Status = CRTM_IRsnowCoeff_Load( & ! Filename, & ! File_Path = File_Path , & +! netCDF = netCDF , & +! isSEcategory = isSEcategory , & ! Quiet = Quiet , & ! Process_ID = Process_ID , & ! Output_Process_ID = Output_Process_ID ) @@ -100,6 +113,25 @@ MODULE CRTM_IRsnowCoeff ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN), OPTIONAL ! +! netCDF: Set this logical argument to specify file format. +! If == .FALSE., Binary [DEFAULT]. +! == .TRUE., netCDF +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! isSEcategory: Set this logical argument to specify emissivity +! classification. +! If == .TRUE., SEcategory [DEFAULT]. +! == .False., Nalli +! If not specified, default is .TRUE. +! 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]. @@ -123,7 +155,7 @@ MODULE CRTM_IRsnowCoeff ! Output_Process_ID: Set this argument to the MPI process ID in which ! all INFORMATION messages are to be output. If ! the passed Process_ID value agrees with this value -! the INFORMATION messages are output. +! the INFORMATION messages are output. ! This argument is ignored if the Quiet argument ! is set. ! UNITS: N/A @@ -151,6 +183,8 @@ MODULE CRTM_IRsnowCoeff FUNCTION CRTM_IRsnowCoeff_Load( & Filename , & ! Input File_Path , & ! Optional input + netCDF , & ! Optional input + isSEcategory , & ! Optional input Quiet , & ! Optional input Process_ID , & ! Optional input Output_Process_ID) & ! Optional input @@ -158,7 +192,9 @@ FUNCTION CRTM_IRsnowCoeff_Load( & ! Arguments CHARACTER(*), INTENT(IN) :: Filename CHARACTER(*), OPTIONAL, INTENT(IN) :: File_Path - LOGICAL , OPTIONAL, INTENT(IN) :: Quiet + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + LOGICAL, OPTIONAL, INTENT(IN) :: isSEcategory + LOGICAL , OPTIONAL, INTENT(IN) :: Quiet INTEGER , OPTIONAL, INTENT(IN) :: Process_ID INTEGER , OPTIONAL, INTENT(IN) :: Output_Process_ID ! Function result @@ -169,8 +205,11 @@ FUNCTION CRTM_IRsnowCoeff_Load( & CHARACTER(ML) :: msg, pid_msg CHARACTER(ML) :: IRsnowCoeff_File LOGICAL :: noisy + ! Function variables + LOGICAL :: Binary + LOGICAL :: SEcategory - ! Setup + ! Setup err_stat = SUCCESS ! ...Assign the filename to local variable IRsnowCoeff_File = ADJUSTL(Filename) @@ -189,23 +228,39 @@ FUNCTION CRTM_IRsnowCoeff_Load( & ELSE pid_msg = '' END IF - - - ! Read the IR snow SEcategory file - err_stat = SEcategory_ReadFile( & - IRsnowC, & - IRsnowCoeff_File, & - Quiet = .NOT. noisy ) + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + ! ...Check SEcategory argument + SEcategory = .TRUE. + IF ( PRESENT(isSEcategory) ) SEcategory = isSEcategory + + ! Read IR snow emissivity file + IF ( SEcategory ) THEN + ! SEcategory + err_stat = SEcategory_ReadFile_IO( & + IRsnowC_SE, & + IRsnowCoeff_File, & + netCDF = .NOT. Binary, & + Quiet = .NOT. noisy ) + ELSE + ! Other classifications + err_stat = IRsnowCoeff_ReadFile( & + IRsnowC, & + IRsnowCoeff_File, & + netCDF = .NOT. Binary, & + Quiet = .NOT. noisy ) + END IF IF ( err_stat /= SUCCESS ) THEN - msg = 'Error reading IRsnowCoeff SEcategory file '//TRIM(IRsnowCoeff_File)//TRIM(pid_msg) - CALL Load_Cleanup(); RETURN + msg = 'Error reading IRsnowCoeff file '//TRIM(IRsnowCoeff_File)//TRIM(pid_msg) + CALL Load_Cleanup(); RETURN END IF - CONTAINS - + SUBROUTINE Load_CleanUp() - CALL SEcategory_Destroy( IRsnowC ) + CALL SEcategory_Destroy( IRsnowC_SE ) + CALL IRsnowCoeff_Destroy( IRsnowC ) err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END SUBROUTINE Load_CleanUp @@ -273,9 +328,17 @@ FUNCTION CRTM_IRsnowCoeff_Destroy( Process_ID ) RESULT( err_stat ) pid_msg = '' END IF - ! Destroy the structure - CALL SEcategory_Destroy( IRsnowC ) - IF ( SEcategory_Associated( IRsnowC ) ) THEN + ! Destroy the data structure + ! ...SEcategory + CALL SEcategory_Destroy( IRsnowC_SE ) + IF ( SEcategory_Associated( IRsnowC_SE ) ) THEN + err_stat = FAILURE + msg = 'Error deallocating IRsnowCoeff_SE shared data structure'//TRIM(pid_msg) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN + END IF + ! ...Other classifications + CALL IRsnowCoeff_Destroy( IRsnowC ) + IF ( IRsnowCoeff_Associated( IRsnowC ) ) THEN err_stat = FAILURE msg = 'Error deallocating IRsnowCoeff shared data structure'//TRIM(pid_msg) CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN @@ -283,7 +346,7 @@ FUNCTION CRTM_IRsnowCoeff_Destroy( Process_ID ) RESULT( err_stat ) END FUNCTION CRTM_IRsnowCoeff_Destroy - + !------------------------------------------------------------------------------ !:sdoc+: ! @@ -295,14 +358,39 @@ END FUNCTION CRTM_IRsnowCoeff_Destroy ! been loaded into the public data structure IRsnowC. ! ! CALLING SEQUENCE: -! status = CRTM_IRsnowCoeff_IsLoaded() +! status = CRTM_IRsnowCoeff_IsLoaded ! !:sdoc-: !------------------------------------------------------------------------------ FUNCTION CRTM_IRsnowCoeff_IsLoaded() RESULT( IsLoaded ) LOGICAL :: IsLoaded - IsLoaded = SEcategory_Associated( IRsnowC ) + + IsLoaded = IRsnowCoeff_Associated( IRsnowC ) + END FUNCTION CRTM_IRsnowCoeff_IsLoaded +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! CRTM_IRsnowCoeff_SE_IsLoaded +! +! PURPOSE: +! Function to test if infrared snow surface emissivity data has +! been loaded into the public data structure IRsnowC_SE. +! +! CALLING SEQUENCE: +! status = CRTM_IRsnowCoeff_SE_IsLoaded +! +!:sdoc-: +!------------------------------------------------------------------------------ + + FUNCTION CRTM_IRsnowCoeff_SE_IsLoaded() RESULT( IsLoaded ) + LOGICAL :: IsLoaded + + IsLoaded = SEcategory_Associated( IRsnowC_SE ) + + END FUNCTION CRTM_IRsnowCoeff_SE_IsLoaded + END MODULE CRTM_IRsnowCoeff diff --git a/src/Coefficients/CRTM_IRwaterCoeff.f90 b/src/Coefficients/CRTM_IRwaterCoeff.f90 index 6aa919d..c4f8871 100644 --- a/src/Coefficients/CRTM_IRwaterCoeff.f90 +++ b/src/Coefficients/CRTM_IRwaterCoeff.f90 @@ -19,7 +19,9 @@ ! CREATION HISTORY: ! Written by: Paul van Delst, 04-May-2012 ! paul.vandelst@noaa.gov -! +! Modified by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu +! Add IRwaterCoeff_ReadFile_IO for netCDF I/O MODULE CRTM_IRwaterCoeff @@ -30,8 +32,8 @@ MODULE CRTM_IRwaterCoeff USE Message_Handler , ONLY: SUCCESS, FAILURE, Display_Message USE IRwaterCoeff_Define, ONLY: IRwaterCoeff_type, & IRwaterCoeff_Associated, & - IRwaterCoeff_Destroy, & - IRwaterCoeff_ReadFile + IRwaterCoeff_Destroy + USE IRwaterCoeff_IO , ONLY: IRwaterCoeff_ReadFile_IO ! Disable all implicit typing IMPLICIT NONE @@ -47,6 +49,7 @@ MODULE CRTM_IRwaterCoeff PUBLIC :: CRTM_IRwaterCoeff_Load PUBLIC :: CRTM_IRwaterCoeff_Destroy PUBLIC :: CRTM_IRwaterCoeff_IsLoaded + PUBLIC :: CRTM_IRwaterCoeff_Classification ! ----------------- @@ -100,6 +103,15 @@ MODULE CRTM_IRwaterCoeff ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN), OPTIONAL ! +! netCDF: Set this logical argument to specify file format. +! If == .FALSE., Binary [DEFAULT]. +! == .TRUE., netCDF +! 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]. @@ -151,6 +163,7 @@ MODULE CRTM_IRwaterCoeff FUNCTION CRTM_IRwaterCoeff_Load( & Filename , & ! Input File_Path , & ! Optional input + netCDF , & ! Optional input Quiet , & ! Optional input Process_ID , & ! Optional input Output_Process_ID) & ! Optional input @@ -158,6 +171,7 @@ FUNCTION CRTM_IRwaterCoeff_Load( & ! Arguments CHARACTER(*), INTENT(IN) :: Filename CHARACTER(*), OPTIONAL, INTENT(IN) :: File_Path + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF LOGICAL , OPTIONAL, INTENT(IN) :: Quiet INTEGER , OPTIONAL, INTENT(IN) :: Process_ID INTEGER , OPTIONAL, INTENT(IN) :: Output_Process_ID @@ -169,6 +183,8 @@ FUNCTION CRTM_IRwaterCoeff_Load( & CHARACTER(ML) :: msg, pid_msg CHARACTER(ML) :: IRwaterCoeff_File LOGICAL :: noisy + ! Function variables + LOGICAL :: Binary ! Setup err_stat = SUCCESS @@ -189,13 +205,17 @@ FUNCTION CRTM_IRwaterCoeff_Load( & ELSE pid_msg = '' END IF + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF ! Read the IR water IRwaterCoeff file - err_stat = IRwaterCoeff_ReadFile( & + err_stat = IRwaterCoeff_ReadFile_IO( & IRwaterC, & IRwaterCoeff_File, & - Quiet = .NOT. noisy ) + netCDF = .NOT. Binary, & + Quiet = .NOT. noisy ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading IRwaterCoeff IRwaterCoeff file '//TRIM(IRwaterCoeff_File)//TRIM(pid_msg) CALL Load_Cleanup(); RETURN @@ -282,6 +302,32 @@ FUNCTION CRTM_IRwaterCoeff_Destroy( Process_ID ) RESULT( err_stat ) END FUNCTION CRTM_IRwaterCoeff_Destroy +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! CRTM_IRwaterCoeff_Classification +! +! PURPOSE: +! Function to return the classification name of the public +! IRwaterC structure +! +! CALLING SEQUENCE: +! Classification = CRTM_IRwaterCoeff_Classification() +! +! FUNCTION RESULT: +! Classification: The classification name field of IRwaterC +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! +!:sdoc-: +!------------------------------------------------------------------------------ + + PURE FUNCTION CRTM_IRwaterCoeff_Classification() RESULT( Classification ) + CHARACTER(LEN(IRwaterC%Classification_Name)) :: Classification + Classification = IRwaterC%Classification_Name + END FUNCTION !------------------------------------------------------------------------------ !:sdoc+: diff --git a/src/Coefficients/CRTM_VISiceCoeff.f90 b/src/Coefficients/CRTM_VISiceCoeff.f90 index 85b095d..6ee613a 100644 --- a/src/Coefficients/CRTM_VISiceCoeff.f90 +++ b/src/Coefficients/CRTM_VISiceCoeff.f90 @@ -2,7 +2,7 @@ ! CRTM_VISiceCoeff ! ! Module containing the shared CRTM visible ice surface emissivity -! data and their load/destruction routines. +! data and their load/destruction routines. ! ! PUBLIC DATA: ! VISiceC: Data structure containing the visible ice surface @@ -19,7 +19,9 @@ ! CREATION HISTORY: ! Written by: Paul van Delst, 20-Jan-2012 ! paul.vandelst@noaa.gov -! +! Modified by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu +! Add SEcategory_ReadFile_IO for netCDF I/O MODULE CRTM_VISiceCoeff @@ -30,8 +32,8 @@ MODULE CRTM_VISiceCoeff USE Message_Handler , ONLY: SUCCESS, FAILURE, Display_Message USE SEcategory_Define, ONLY: SEcategory_type, & SEcategory_Associated, & - SEcategory_Destroy, & - SEcategory_ReadFile + SEcategory_Destroy + USE SEcategory_IO, ONLY: SEcategory_ReadFile_IO ! Disable all implicit typing IMPLICIT NONE @@ -79,6 +81,7 @@ MODULE CRTM_VISiceCoeff ! Error_Status = CRTM_VISiceCoeff_Load( & ! Filename, & ! File_Path = File_Path , & +! netCDF = netCDF , & ! Quiet = Quiet , & ! Process_ID = Process_ID , & ! Output_Process_ID = Output_Process_ID ) @@ -100,6 +103,15 @@ MODULE CRTM_VISiceCoeff ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN), OPTIONAL ! +! netCDF: Set this logical argument to specify file format. +! If == .FALSE., Binary [DEFAULT]. +! == .TRUE., netCDF +! 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]. @@ -123,7 +135,7 @@ MODULE CRTM_VISiceCoeff ! Output_Process_ID: Set this argument to the MPI process ID in which ! all INFORMATION messages are to be output. If ! the passed Process_ID value agrees with this value -! the INFORMATION messages are output. +! the INFORMATION messages are output. ! This argument is ignored if the Quiet argument ! is set. ! UNITS: N/A @@ -151,6 +163,7 @@ MODULE CRTM_VISiceCoeff FUNCTION CRTM_VISiceCoeff_Load( & Filename , & ! Input File_Path , & ! Optional input + netCDF , & ! Optional input Quiet , & ! Optional input Process_ID , & ! Optional input Output_Process_ID) & ! Optional input @@ -158,7 +171,8 @@ FUNCTION CRTM_VISiceCoeff_Load( & ! Arguments CHARACTER(*), INTENT(IN) :: Filename CHARACTER(*), OPTIONAL, INTENT(IN) :: File_Path - LOGICAL , OPTIONAL, INTENT(IN) :: Quiet + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + LOGICAL , OPTIONAL, INTENT(IN) :: Quiet INTEGER , OPTIONAL, INTENT(IN) :: Process_ID INTEGER , OPTIONAL, INTENT(IN) :: Output_Process_ID ! Function result @@ -169,8 +183,10 @@ FUNCTION CRTM_VISiceCoeff_Load( & CHARACTER(ML) :: msg, pid_msg CHARACTER(ML) :: VISiceCoeff_File LOGICAL :: noisy + ! Function variables + LOGICAL :: Binary - ! Setup + ! Setup err_stat = SUCCESS ! ...Assign the filename to local variable VISiceCoeff_File = ADJUSTL(Filename) @@ -189,12 +205,16 @@ FUNCTION CRTM_VISiceCoeff_Load( & ELSE pid_msg = '' END IF - - + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + ! Read the VIS ice SEcategory file - err_stat = SEcategory_ReadFile( & + err_stat = SEcategory_ReadFile_IO( & VISiceC, & VISiceCoeff_File, & + netCDF = .NOT. Binary, & Quiet = .NOT. noisy ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading VISiceCoeff SEcategory file '//TRIM(VISiceCoeff_File)//TRIM(pid_msg) @@ -203,7 +223,7 @@ FUNCTION CRTM_VISiceCoeff_Load( & CONTAINS - + SUBROUTINE Load_CleanUp() CALL SEcategory_Destroy( VISiceC ) err_stat = FAILURE @@ -283,7 +303,7 @@ FUNCTION CRTM_VISiceCoeff_Destroy( Process_ID ) RESULT( err_stat ) END FUNCTION CRTM_VISiceCoeff_Destroy - + !------------------------------------------------------------------------------ !:sdoc+: ! diff --git a/src/Coefficients/CRTM_VISlandCoeff.f90 b/src/Coefficients/CRTM_VISlandCoeff.f90 index 577ad44..9cbbe9c 100644 --- a/src/Coefficients/CRTM_VISlandCoeff.f90 +++ b/src/Coefficients/CRTM_VISlandCoeff.f90 @@ -2,7 +2,7 @@ ! CRTM_VISlandCoeff ! ! Module containing the shared CRTM visible land surface emissivity -! data and their load/destruction routines. +! data and their load/destruction routines. ! ! PUBLIC DATA: ! VISlandC: Data structure containing the visible land surface @@ -19,7 +19,9 @@ ! CREATION HISTORY: ! Written by: Paul van Delst, 20-Jan-2012 ! paul.vandelst@noaa.gov -! +! Modified by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu +! Add SEcategory_ReadFile_IO for netCDF I/O MODULE CRTM_VISlandCoeff @@ -30,8 +32,8 @@ MODULE CRTM_VISlandCoeff USE Message_Handler , ONLY: SUCCESS, FAILURE, Display_Message USE SEcategory_Define, ONLY: SEcategory_type, & SEcategory_Associated, & - SEcategory_Destroy, & - SEcategory_ReadFile + SEcategory_Destroy + USE SEcategory_IO, ONLY: SEcategory_ReadFile_IO ! Disable all implicit typing IMPLICIT NONE @@ -79,6 +81,7 @@ MODULE CRTM_VISlandCoeff ! Error_Status = CRTM_VISlandCoeff_Load( & ! Filename, & ! File_Path = File_Path , & +! netCDF = netCDF , & ! Quiet = Quiet , & ! Process_ID = Process_ID , & ! Output_Process_ID = Output_Process_ID ) @@ -100,6 +103,15 @@ MODULE CRTM_VISlandCoeff ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN), OPTIONAL ! +! netCDF: Set this logical argument to specify file format. +! If == .FALSE., Binary [DEFAULT]. +! == .TRUE., netCDF +! 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]. @@ -123,7 +135,7 @@ MODULE CRTM_VISlandCoeff ! Output_Process_ID: Set this argument to the MPI process ID in which ! all INFORMATION messages are to be output. If ! the passed Process_ID value agrees with this value -! the INFORMATION messages are output. +! the INFORMATION messages are output. ! This argument is ignored if the Quiet argument ! is set. ! UNITS: N/A @@ -151,6 +163,7 @@ MODULE CRTM_VISlandCoeff FUNCTION CRTM_VISlandCoeff_Load( & Filename , & ! Input File_Path , & ! Optional input + netCDF , & ! Optional input Quiet , & ! Optional input Process_ID , & ! Optional input Output_Process_ID) & ! Optional input @@ -158,7 +171,8 @@ FUNCTION CRTM_VISlandCoeff_Load( & ! Arguments CHARACTER(*), INTENT(IN) :: Filename CHARACTER(*), OPTIONAL, INTENT(IN) :: File_Path - LOGICAL , OPTIONAL, INTENT(IN) :: Quiet + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + LOGICAL , OPTIONAL, INTENT(IN) :: Quiet INTEGER , OPTIONAL, INTENT(IN) :: Process_ID INTEGER , OPTIONAL, INTENT(IN) :: Output_Process_ID ! Function result @@ -169,8 +183,10 @@ FUNCTION CRTM_VISlandCoeff_Load( & CHARACTER(ML) :: msg, pid_msg CHARACTER(ML) :: VISlandCoeff_File LOGICAL :: noisy + ! Function variables + LOGICAL :: Binary - ! Setup + ! Setup err_stat = SUCCESS ! ...Assign the filename to local variable VISlandCoeff_File = ADJUSTL(Filename) @@ -189,12 +205,15 @@ FUNCTION CRTM_VISlandCoeff_Load( & ELSE pid_msg = '' END IF - - + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + ! Read the VIS land SEcategory file - err_stat = SEcategory_ReadFile( & + err_stat = SEcategory_ReadFile_IO( & VISlandC, & VISlandCoeff_File, & + netCDF = .NOT. Binary, & Quiet = .NOT. noisy ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading VISlandCoeff SEcategory file '//TRIM(VISlandCoeff_File)//TRIM(pid_msg) @@ -203,7 +222,7 @@ FUNCTION CRTM_VISlandCoeff_Load( & CONTAINS - + SUBROUTINE Load_CleanUp() CALL SEcategory_Destroy( VISlandC ) err_stat = FAILURE @@ -283,7 +302,7 @@ FUNCTION CRTM_VISlandCoeff_Destroy( Process_ID ) RESULT( err_stat ) END FUNCTION CRTM_VISlandCoeff_Destroy - + !------------------------------------------------------------------------------ !:sdoc+: ! diff --git a/src/Coefficients/CRTM_VISsnowCoeff.f90 b/src/Coefficients/CRTM_VISsnowCoeff.f90 index 1bca761..18df6cb 100644 --- a/src/Coefficients/CRTM_VISsnowCoeff.f90 +++ b/src/Coefficients/CRTM_VISsnowCoeff.f90 @@ -2,7 +2,7 @@ ! CRTM_VISsnowCoeff ! ! Module containing the shared CRTM visible snow surface emissivity -! data and their load/destruction routines. +! data and their load/destruction routines. ! ! PUBLIC DATA: ! VISsnowC: Data structure containing the visible snow surface @@ -19,7 +19,9 @@ ! CREATION HISTORY: ! Written by: Paul van Delst, 20-Jan-2012 ! paul.vandelst@noaa.gov -! +! Modified by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu +! Add SEcategory_ReadFile_IO for netCDF I/O MODULE CRTM_VISsnowCoeff @@ -30,8 +32,8 @@ MODULE CRTM_VISsnowCoeff USE Message_Handler , ONLY: SUCCESS, FAILURE, Display_Message USE SEcategory_Define, ONLY: SEcategory_type, & SEcategory_Associated, & - SEcategory_Destroy, & - SEcategory_ReadFile + SEcategory_Destroy + USE SEcategory_IO, ONLY: SEcategory_ReadFile_IO ! Disable all implicit typing IMPLICIT NONE @@ -79,6 +81,7 @@ MODULE CRTM_VISsnowCoeff ! Error_Status = CRTM_VISsnowCoeff_Load( & ! Filename, & ! File_Path = File_Path , & +! netCDF = netCDF , & ! Quiet = Quiet , & ! Process_ID = Process_ID , & ! Output_Process_ID = Output_Process_ID ) @@ -100,6 +103,15 @@ MODULE CRTM_VISsnowCoeff ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN), OPTIONAL ! +! netCDF: Set this logical argument to specify file format. +! If == .FALSE., Binary [DEFAULT]. +! == .TRUE., netCDF +! 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]. @@ -123,7 +135,7 @@ MODULE CRTM_VISsnowCoeff ! Output_Process_ID: Set this argument to the MPI process ID in which ! all INFORMATION messages are to be output. If ! the passed Process_ID value agrees with this value -! the INFORMATION messages are output. +! the INFORMATION messages are output. ! This argument is ignored if the Quiet argument ! is set. ! UNITS: N/A @@ -151,6 +163,7 @@ MODULE CRTM_VISsnowCoeff FUNCTION CRTM_VISsnowCoeff_Load( & Filename , & ! Input File_Path , & ! Optional input + netCDF , & ! Optional input Quiet , & ! Optional input Process_ID , & ! Optional input Output_Process_ID) & ! Optional input @@ -158,7 +171,8 @@ FUNCTION CRTM_VISsnowCoeff_Load( & ! Arguments CHARACTER(*), INTENT(IN) :: Filename CHARACTER(*), OPTIONAL, INTENT(IN) :: File_Path - LOGICAL , OPTIONAL, INTENT(IN) :: Quiet + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + LOGICAL , OPTIONAL, INTENT(IN) :: Quiet INTEGER , OPTIONAL, INTENT(IN) :: Process_ID INTEGER , OPTIONAL, INTENT(IN) :: Output_Process_ID ! Function result @@ -169,8 +183,10 @@ FUNCTION CRTM_VISsnowCoeff_Load( & CHARACTER(ML) :: msg, pid_msg CHARACTER(ML) :: VISsnowCoeff_File LOGICAL :: noisy + ! Function variables + LOGICAL :: Binary - ! Setup + ! Setup err_stat = SUCCESS ! ...Assign the filename to local variable VISsnowCoeff_File = ADJUSTL(Filename) @@ -189,12 +205,16 @@ FUNCTION CRTM_VISsnowCoeff_Load( & ELSE pid_msg = '' END IF - - + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + ! Read the VIS snow SEcategory file - err_stat = SEcategory_ReadFile( & + err_stat = SEcategory_ReadFile_IO( & VISsnowC, & VISsnowCoeff_File, & + netCDF = .NOT. Binary, & Quiet = .NOT. noisy ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading VISsnowCoeff SEcategory file '//TRIM(VISsnowCoeff_File)//TRIM(pid_msg) @@ -203,7 +223,7 @@ FUNCTION CRTM_VISsnowCoeff_Load( & CONTAINS - + SUBROUTINE Load_CleanUp() CALL SEcategory_Destroy( VISsnowC ) err_stat = FAILURE @@ -283,7 +303,7 @@ FUNCTION CRTM_VISsnowCoeff_Destroy( Process_ID ) RESULT( err_stat ) END FUNCTION CRTM_VISsnowCoeff_Destroy - + !------------------------------------------------------------------------------ !:sdoc+: ! diff --git a/src/Coefficients/CRTM_VISwaterCoeff.f90 b/src/Coefficients/CRTM_VISwaterCoeff.f90 index 55bcaa6..4aa28c9 100644 --- a/src/Coefficients/CRTM_VISwaterCoeff.f90 +++ b/src/Coefficients/CRTM_VISwaterCoeff.f90 @@ -2,7 +2,7 @@ ! CRTM_VISwaterCoeff ! ! Module containing the shared CRTM visible water surface emissivity -! data and their load/destruction routines. +! data and their load/destruction routines. ! ! PUBLIC DATA: ! VISwaterC: Data structure containing the visible water surface @@ -19,7 +19,9 @@ ! CREATION HISTORY: ! Written by: Paul van Delst, 20-Jan-2012 ! paul.vandelst@noaa.gov -! +! Modified by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu +! Add SEcategory_ReadFile_IO for netCDF I/O MODULE CRTM_VISwaterCoeff @@ -30,8 +32,8 @@ MODULE CRTM_VISwaterCoeff USE Message_Handler , ONLY: SUCCESS, FAILURE, Display_Message USE SEcategory_Define, ONLY: SEcategory_type, & SEcategory_Associated, & - SEcategory_Destroy, & - SEcategory_ReadFile + SEcategory_Destroy + USE SEcategory_IO, ONLY: SEcategory_ReadFile_IO ! Disable all implicit typing IMPLICIT NONE @@ -79,6 +81,7 @@ MODULE CRTM_VISwaterCoeff ! Error_Status = CRTM_VISwaterCoeff_Load( & ! Filename, & ! File_Path = File_Path , & +! netCDF = netCDF , & ! Quiet = Quiet , & ! Process_ID = Process_ID , & ! Output_Process_ID = Output_Process_ID ) @@ -100,6 +103,15 @@ MODULE CRTM_VISwaterCoeff ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN), OPTIONAL ! +! netCDF: Set this logical argument to specify file format. +! If == .FALSE., Binary [DEFAULT]. +! == .TRUE., netCDF +! 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]. @@ -123,7 +135,7 @@ MODULE CRTM_VISwaterCoeff ! Output_Process_ID: Set this argument to the MPI process ID in which ! all INFORMATION messages are to be output. If ! the passed Process_ID value agrees with this value -! the INFORMATION messages are output. +! the INFORMATION messages are output. ! This argument is ignored if the Quiet argument ! is set. ! UNITS: N/A @@ -151,6 +163,7 @@ MODULE CRTM_VISwaterCoeff FUNCTION CRTM_VISwaterCoeff_Load( & Filename , & ! Input File_Path , & ! Optional input + netCDF , & ! Optional input Quiet , & ! Optional input Process_ID , & ! Optional input Output_Process_ID) & ! Optional input @@ -158,7 +171,8 @@ FUNCTION CRTM_VISwaterCoeff_Load( & ! Arguments CHARACTER(*), INTENT(IN) :: Filename CHARACTER(*), OPTIONAL, INTENT(IN) :: File_Path - LOGICAL , OPTIONAL, INTENT(IN) :: Quiet + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + LOGICAL , OPTIONAL, INTENT(IN) :: Quiet INTEGER , OPTIONAL, INTENT(IN) :: Process_ID INTEGER , OPTIONAL, INTENT(IN) :: Output_Process_ID ! Function result @@ -169,8 +183,10 @@ FUNCTION CRTM_VISwaterCoeff_Load( & CHARACTER(ML) :: msg, pid_msg CHARACTER(ML) :: VISwaterCoeff_File LOGICAL :: noisy + ! Function variables + LOGICAL :: Binary - ! Setup + ! Setup err_stat = SUCCESS ! ...Assign the filename to local variable VISwaterCoeff_File = ADJUSTL(Filename) @@ -189,12 +205,16 @@ FUNCTION CRTM_VISwaterCoeff_Load( & ELSE pid_msg = '' END IF - - + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + ! Read the VIS water SEcategory file - err_stat = SEcategory_ReadFile( & + err_stat = SEcategory_ReadFile_IO( & VISwaterC, & VISwaterCoeff_File, & + netCDF = .NOT. Binary, & Quiet = .NOT. noisy ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error reading VISwaterCoeff SEcategory file '//TRIM(VISwaterCoeff_File)//TRIM(pid_msg) @@ -203,7 +223,7 @@ FUNCTION CRTM_VISwaterCoeff_Load( & CONTAINS - + SUBROUTINE Load_CleanUp() CALL SEcategory_Destroy( VISwaterC ) err_stat = FAILURE @@ -283,7 +303,7 @@ FUNCTION CRTM_VISwaterCoeff_Destroy( Process_ID ) RESULT( err_stat ) END FUNCTION CRTM_VISwaterCoeff_Destroy - + !------------------------------------------------------------------------------ !:sdoc+: ! diff --git a/src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_Binary_IO.f90 b/src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_Binary_IO.f90 similarity index 100% rename from src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_Binary_IO.f90 rename to src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_Binary_IO.f90 diff --git a/src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_Define.f90 b/src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_Define.f90 similarity index 100% rename from src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_Define.f90 rename to src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_Define.f90 diff --git a/src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_NC2BIN/EmisCoeff_NC2BIN.f90 b/src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_NC2BIN/EmisCoeff_NC2BIN.f90 similarity index 100% rename from src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_NC2BIN/EmisCoeff_NC2BIN.f90 rename to src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_NC2BIN/EmisCoeff_NC2BIN.f90 diff --git a/src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_NC2BIN/Makefile b/src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_NC2BIN/Makefile similarity index 100% rename from src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_NC2BIN/Makefile rename to src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_NC2BIN/Makefile diff --git a/src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_NC2BIN/make.dependencies b/src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_NC2BIN/make.dependencies similarity index 100% rename from src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_NC2BIN/make.dependencies rename to src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_NC2BIN/make.dependencies diff --git a/src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_NC2BIN/run_EmisCoeff_NC2BIN b/src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_NC2BIN/run_EmisCoeff_NC2BIN similarity index 100% rename from src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_NC2BIN/run_EmisCoeff_NC2BIN rename to src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_NC2BIN/run_EmisCoeff_NC2BIN diff --git a/src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_NC2BIN/run_EmisCoeff_NC2BIN.sh b/src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_NC2BIN/run_EmisCoeff_NC2BIN.sh similarity index 100% rename from src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_NC2BIN/run_EmisCoeff_NC2BIN.sh rename to src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_NC2BIN/run_EmisCoeff_NC2BIN.sh diff --git a/src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_netCDF_IO.f90 b/src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_netCDF_IO.f90 similarity index 100% rename from src/Coefficients/EmisCoeff/IR_Water/EmisCoeff_netCDF_IO.f90 rename to src/Coefficients/EmisCoeff/EmisCoeff_legacy/EmisCoeff_netCDF_IO.f90 diff --git a/src/Coefficients/EmisCoeff/IR_Water/Test_EmisCoeff/Makefile b/src/Coefficients/EmisCoeff/EmisCoeff_legacy/Test_EmisCoeff/Makefile similarity index 100% rename from src/Coefficients/EmisCoeff/IR_Water/Test_EmisCoeff/Makefile rename to src/Coefficients/EmisCoeff/EmisCoeff_legacy/Test_EmisCoeff/Makefile diff --git a/src/Coefficients/EmisCoeff/IR_Water/Test_EmisCoeff/Test_EmisCoeff.f90 b/src/Coefficients/EmisCoeff/EmisCoeff_legacy/Test_EmisCoeff/Test_EmisCoeff.f90 similarity index 100% rename from src/Coefficients/EmisCoeff/IR_Water/Test_EmisCoeff/Test_EmisCoeff.f90 rename to src/Coefficients/EmisCoeff/EmisCoeff_legacy/Test_EmisCoeff/Test_EmisCoeff.f90 diff --git a/src/Coefficients/EmisCoeff/IR_Water/Test_EmisCoeff/make.dependencies b/src/Coefficients/EmisCoeff/EmisCoeff_legacy/Test_EmisCoeff/make.dependencies similarity index 100% rename from src/Coefficients/EmisCoeff/IR_Water/Test_EmisCoeff/make.dependencies rename to src/Coefficients/EmisCoeff/EmisCoeff_legacy/Test_EmisCoeff/make.dependencies diff --git a/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_Binary_IO.f90 b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_Binary_IO.f90 new file mode 100644 index 0000000..c844303 --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_Binary_IO.f90 @@ -0,0 +1,807 @@ +! +! +! IRsnowCoeff_Binary_IO +! +! Module containing routines to read and write Binary format +! IRsnowCoeff files. +! +! +! CREATION HISTORY: +! Written by: Cheng Dang, 27-Jun-2022 +! dangch@ucar.edu +! + +MODULE IRsnowCoeff_Binary_IO + + ! ------------------ + ! Environment set up + ! ------------------ + ! Module use + USE File_Utility , ONLY: File_Open, File_Exists + USE Message_Handler , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message + USE Binary_File_Utility, ONLY: Open_Binary_File , & + WriteGAtts_Binary_File, & + ReadGAtts_Binary_File + USE IRsnowCoeff_Define , ONLY: IRsnowCoeff_type , & + IRsnowCoeff_Associated , & + IRsnowCoeff_Destroy , & + IRsnowCoeff_Create , & + IRsnowCoeff_ValidRelease, & + IRsnowCoeff_Info + + ! Disable implicit typing + IMPLICIT NONE + + + ! ------------ + ! Visibilities + ! ------------ + PRIVATE + PUBLIC :: IRsnowCoeff_Binary_InquireFile + PUBLIC :: IRsnowCoeff_Binary_ReadFile + PUBLIC :: IRsnowCoeff_Binary_WriteFile + + + ! ----------------- + ! Module parameters + ! ----------------- + CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE' + ! Default message length + INTEGER, PARAMETER :: ML = 256 + + +CONTAINS + + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRsnowCoeff_Binary_InquireFile +! +! PURPOSE: +! Function to inquire a IRsnowCoeff object container file. +! +! CALLING SEQUENCE: +! Error_Status = IRsnowCoeff_Binary_InquireFile( & +! Filename , & +! n_Angles = n_Angles , & +! n_Frequencies = n_Frequencies, & +! n_Grain_Sizes = n_Grain_Sizes, & +! n_Temperature = n_Temperature, & +! Release = Release , & +! Version = Version , & +! Title = Title , & +! History = History , & +! Comment = Comment ) +! +! 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_Angles: Number of angles for which there are +! emissivity data. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! n_Frequencies: Number of spectral frequencies for which there are +! emissivity data. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! n_Grain_Sizes: Number of Grain Sizes for which there are +! emissivity data. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! n_Temperature: Number of temperature for which there are +! emissivity data. +! 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 +! +! Title: Character string containing a succinct description +! of what is in the dataset. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string containing dataset creation +! history. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string containing any comments about +! the dataset. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 IRsnowCoeff_Binary_InquireFile( & + Filename , & ! Input + n_Angles , & ! Optional output + n_Frequencies, & ! Optional output + n_Grain_Sizes, & ! Optional output + n_Temperature, & ! 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_Angles + INTEGER , OPTIONAL, INTENT(OUT) :: n_Frequencies + INTEGER , OPTIONAL, INTENT(OUT) :: n_Grain_Sizes + INTEGER , OPTIONAL, INTENT(OUT) :: n_Temperature + 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 = 'IRsnowCoeff_InquireFile' + ! Function variables + CHARACTER(ML) :: msg + CHARACTER(ML) :: io_msg + INTEGER :: io_stat + INTEGER :: fid + TYPE(IRsnowCoeff_type) :: IRsnowCoeff + + + ! 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 ) & + IRsnowCoeff%Release, & + IRsnowCoeff%Version + IF ( io_stat /= 0 ) THEN + msg = 'Error reading Release/Version - '//TRIM(io_msg) + CALL Inquire_Cleanup(); RETURN + END IF + + + ! Read the dimensions + READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & + IRsnowCoeff%n_Angles , & + IRsnowCoeff%n_Frequencies, & + IRsnowCoeff%n_Grain_Sizes, & + IRsnowCoeff%n_Temperature + IF ( io_stat /= 0 ) THEN + msg = 'Error reading dimension values 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_Angles ) ) n_Angles = IRsnowCoeff%n_Angles + IF ( PRESENT(n_Frequencies) ) n_Frequencies = IRsnowCoeff%n_Frequencies + IF ( PRESENT(n_Grain_Sizes) ) n_Grain_Sizes = IRsnowCoeff%n_Grain_Sizes + IF ( PRESENT(n_Temperature) ) n_Temperature = IRsnowCoeff%n_Temperature + IF ( PRESENT(Release ) ) Release = IRsnowCoeff%Release + IF ( PRESENT(Version ) ) Version = IRsnowCoeff%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 IRsnowCoeff_Binary_InquireFile + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! IRsnowCoeff_Binary_ReadFile +! +! PURPOSE: +! Function to read IRsnowCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRsnowCoeff_Binary_ReadFile( & +! IRsnowCoeff , & +! Filename , & +! No_Close = No_Close, & +! Quiet = Quiet , & +! Title = Title , & +! History = History , & +! Comment = Comment ) +! +! OBJECTS: +! IRsnowCoeff: Object containing the data read from file. +! UNITS: N/A +! TYPE: IRsnowCoeff_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! INPUTS: +! Filename: Character string specifying the name of the +! 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 IRsnowCoeff 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 +! +! OPTIONAL OUTPUTS: +! Title: Character string containing a succinct description +! of what is in the dataset. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string containing dataset creation +! history. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string containing any comments about +! the dataset. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 read was successful +! == FAILURE, an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!------------------------------------------------------------------------------ + + FUNCTION IRsnowCoeff_Binary_ReadFile( & + IRsnowCoeff , & ! 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(IRsnowCoeff_type), INTENT(OUT) :: IRsnowCoeff + 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 = 'IRsnowCoeff_Binary_ReadFile' + ! Function variables + CHARACTER(ML) :: msg + CHARACTER(ML) :: io_msg + LOGICAL :: close_file + LOGICAL :: noisy + INTEGER :: io_stat + INTEGER :: fid + TYPE(IRsnowCoeff_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. IRsnowCoeff_ValidRelease( dummy ) ) THEN + msg = 'IRsnowCoeff Release check failed.' + CALL Read_Cleanup(); RETURN + END IF + + + ! Read the dimensions + READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & + dummy%n_Angles , & + dummy%n_Frequencies, & + dummy%n_Grain_Sizes, & + dummy%n_Temperature + IF ( io_stat /= 0 ) THEN + msg = 'Error reading dimension values from '//TRIM(Filename)//' - '//TRIM(io_msg) + CALL Read_Cleanup(); RETURN + END IF + ! ...Create the return object + CALL IRsnowCoeff_Create( & + IRsnowCoeff , & + dummy%n_Angles , & + dummy%n_Frequencies, & + dummy%n_Grain_Sizes, & + dummy%n_Temperature ) + IF ( .NOT. IRsnowCoeff_Associated( IRsnowCoeff ) ) THEN + msg = 'IRsnowCoeff object creation failed.' + CALL Read_Cleanup(); RETURN + END IF + ! ...Explicitly assign the version number + IRsnowCoeff%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 classification name + READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & + IRsnowCoeff%Classification_Name + IF ( io_stat /= 0 ) THEN + msg = 'Error reading classification name - '//TRIM(io_msg) + CALL Read_Cleanup(); RETURN + END IF + + ! Read the coefficient data + ! ...Read the dimensional vectors + READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & + IRsnowCoeff%Angle , & + IRsnowCoeff%Frequency , & + IRsnowCoeff%Grain_Size , & + IRsnowCoeff%Temperature , & + IRsnowCoeff%Emissivity + IF ( io_stat /= 0 ) THEN + msg = 'Error reading dimensional vectors - '//TRIM(io_msg) + CALL Read_Cleanup(); RETURN + END IF + ! ...Read the emissivity data + READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & + IRsnowCoeff%Emissivity + IF ( io_stat /= 0 ) THEN + msg = 'Error reading emissivity data - '//TRIM(io_msg) + CALL Read_Cleanup(); RETURN + END IF + + ! Close the file + IF ( close_file ) THEN + CLOSE( fid, IOSTAT=io_stat, IOMSG=io_msg ) + IF ( io_stat /= 0 ) THEN + msg = 'Error closing '//TRIM(Filename)//' - '//TRIM(io_msg) + CALL Read_Cleanup(); RETURN + END IF + END IF + + ! Output an info message + IF ( noisy ) THEN + CALL IRsnowCoeff_Info( IRsnowCoeff, 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 input file during error cleanup - '//TRIM(io_msg) + END IF + CALL IRsnowCoeff_Destroy( IRsnowCoeff ) + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + END SUBROUTINE Read_CleanUp + + END FUNCTION IRsnowCoeff_Binary_ReadFile + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! IRsnowCoeff_Binary_WriteFile +! +! PURPOSE: +! Function to write IRsnowCoeff object container files. +! +! CALLING SEQUENCE: +! Error_Status = IRsnowCoeff_Binary_WriteFile( & +! IRsnowCoeff , & +! Filename , & +! No_Close = No_Close, & +! Quiet = Quiet , & +! Title = Title , & +! History = History , & +! Comment = Comment ) +! +! OBJECTS: +! IRsnowCoeff: Object containing the data to write to file. +! UNITS: N/A +! TYPE: IRsnowCoeff_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! INPUTS: +! Filename: Character string specifying the name of the +! 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 IRsnowCoeff data is to be embedded within another file. +! If == .FALSE., File is closed upon function exit [DEFAULT]. +! == .TRUE., File is NOT closed upon function exit +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Quiet: Set this logical argument to suppress INFORMATION +! messages being printed to stdout +! If == .FALSE., INFORMATION messages are OUTPUT [DEFAULT]. +! == .TRUE., INFORMATION messages are SUPPRESSED. +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Title: Character string containing a succinct description +! of what is in the dataset. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! History: Character string containing dataset creation +! history. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Comment: Character string containing any comments about +! the dataset. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 IRsnowCoeff_Binary_WriteFile( & + IRsnowCoeff , & ! 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(IRsnowCoeff_type), INTENT(IN) :: IRsnowCoeff + 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 = 'IRsnowCoeff_Binary_WriteFile' + ! Function variables + CHARACTER(ML) :: msg + CHARACTER(ML) :: io_msg + LOGICAL :: close_file + LOGICAL :: noisy + INTEGER :: io_stat + INTEGER :: fid + + + ! Setup + err_stat = SUCCESS + ! ...Check No_Close argument + close_file = .TRUE. + IF ( PRESENT(No_Close) ) close_file = .NOT. No_Close + ! ...Check Quiet argument + noisy = .TRUE. + IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet + ! ...Override Quiet settings if debug set. + IF ( PRESENT(Debug) ) THEN + IF ( Debug ) noisy = .TRUE. + END IF + ! ...Check there is data to write + IF ( .NOT. IRsnowCoeff_Associated( IRsnowCoeff ) ) THEN + msg = 'IRsnowCoeff 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 ) & + IRsnowCoeff%Release, & + IRsnowCoeff%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 ) & + IRsnowCoeff%n_Angles , & + IRsnowCoeff%n_Frequencies, & + IRsnowCoeff%n_Grain_Sizes, & + IRsnowCoeff%n_Temperature + IF ( io_stat /= 0 ) THEN + msg = 'Error writing dimension values to '//TRIM(Filename)//' - '//TRIM(io_msg) + CALL Write_Cleanup(); RETURN + END IF + + + ! Write the global attributes + err_stat = WriteGAtts_Binary_File( & + fid, & + Write_Module = 'Unknown', & + Title = Title , & + History = History, & + Comment = Comment ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error writing global attributes' + CALL Write_Cleanup(); RETURN + END IF + + + ! Write the surface classification name + WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & + IRsnowCoeff%Classification_Name + IF ( io_stat /= 0 ) THEN + msg = 'Error writing classification name - '//TRIM(io_msg) + CALL Write_Cleanup(); RETURN + END IF + + + ! Write the coefficient data + ! ...Write the dimensional vectors + WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & + IRsnowCoeff%Angle , & + IRsnowCoeff%Frequency , & + IRsnowCoeff%Grain_Size , & + IRsnowCoeff%Temperature , & + IRsnowCoeff%Emissivity + IF ( io_stat /= 0 ) THEN + msg = 'Error writing dimensional vectors - '//TRIM(io_msg) + CALL Write_Cleanup(); RETURN + END IF + ! ...Write the emissivity data + WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & + IRsnowCoeff%Emissivity + IF ( io_stat /= 0 ) THEN + msg = 'Error writing emissivity data - '//TRIM(io_msg) + CALL Write_Cleanup(); RETURN + END IF + + + ! Close the file + IF ( close_file ) THEN + CLOSE( fid, IOSTAT=io_stat, IOMSG=io_msg ) + IF ( io_stat /= 0 ) THEN + msg = 'Error closing '//TRIM(Filename)//' - '//TRIM(io_msg) + CALL Write_Cleanup(); RETURN + END IF + END IF + + + ! Output an info message + IF ( noisy ) THEN + CALL IRsnowCoeff_Info( IRsnowCoeff, 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, STATUS=WRITE_ERROR_STATUS, IOSTAT=io_stat, IOMSG=io_msg ) + IF ( io_stat /= 0 ) & + msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) + END IF + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + END SUBROUTINE Write_CleanUp + + END FUNCTION IRsnowCoeff_Binary_WriteFile + +END MODULE IRsnowCoeff_Binary_IO diff --git a/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_Define.f90 b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_Define.f90 new file mode 100644 index 0000000..18e988c --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_Define.f90 @@ -0,0 +1,548 @@ +! +! IRsnowCoeff_Define +! +! Module defining the IRsnowCoeff object to hold coefficient +! data for the infrared snow surface emissivity and reflectivity models. +! +! +! CREATION HISTORY: +! Written by: Cheng Dang, 18-May-2022 +! dangch@ucar.edu + +MODULE IRsnowCoeff_Define + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module use + USE Type_Kinds , ONLY: fp, Long, Double + USE Message_Handler , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message + USE Compare_Float_Numbers, ONLY: OPERATOR(.EqualTo.) + USE File_Utility , ONLY: File_Open, File_Exists + USE Binary_File_Utility , ONLY: Open_Binary_File , & + WriteGAtts_Binary_File, & + ReadGAtts_Binary_File + ! Disable implicit typing + IMPLICIT NONE + + + ! ------------ + ! Visibilities + ! ------------ + ! Everything private by default + PRIVATE + ! Datatypes + PUBLIC :: IRsnowCoeff_type + ! Operators + PUBLIC :: OPERATOR(==) + ! Procedures + PUBLIC :: IRsnowCoeff_Associated + PUBLIC :: IRsnowCoeff_Destroy + PUBLIC :: IRsnowCoeff_Create + PUBLIC :: IRsnowCoeff_Inspect + PUBLIC :: IRsnowCoeff_ValidRelease + PUBLIC :: IRsnowCoeff_Info + + + ! --------------------- + ! Procedure overloading + ! --------------------- + INTERFACE OPERATOR(==) + MODULE PROCEDURE IRsnowCoeff_Equal + END INTERFACE OPERATOR(==) + + + ! ----------------- + ! Module parameters + ! ----------------- + ! Current valid release and version + INTEGER, PARAMETER :: IRsnowCOEFF_RELEASE = 1 ! This determines structure and file formats. + INTEGER, PARAMETER :: IRsnowCOEFF_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 + + + ! ---------------------------------- + ! IRsnowCoeff data type definitions + ! ---------------------------------- + !:tdoc+: + TYPE :: IRsnowCoeff_type + ! Allocation indicator + LOGICAL :: Is_Allocated = .FALSE. + ! Release and version information + INTEGER(Long) :: Release = IRsnowCOEFF_RELEASE + INTEGER(Long) :: Version = IRsnowCOEFF_VERSION + ! Surface classification name + CHARACTER(ML) :: Classification_Name = '' + ! Dimensions + INTEGER(Long) :: n_Angles = 0 ! I dimension + INTEGER(Long) :: n_Frequencies = 0 ! L dimension + INTEGER(Long) :: n_Grain_Sizes = 0 ! G dimension + INTEGER(Long) :: n_Temperature = 0 ! T dimension + ! Dimensional vectors + REAL(Double), ALLOCATABLE :: Angle(:) ! I + REAL(Double), ALLOCATABLE :: Frequency(:) ! L + REAL(Double), ALLOCATABLE :: Grain_Size(:) ! G + REAL(Double), ALLOCATABLE :: Temperature(:) ! T + ! Emissivity LUT data + REAL(Double), ALLOCATABLE :: Emissivity(:,:,:,:) ! I x L x G x T + END TYPE IRsnowCoeff_type + !:tdoc-: + + +CONTAINS + + +!################################################################################ +!################################################################################ +!## ## +!## ## PUBLIC MODULE ROUTINES ## ## +!## ## +!################################################################################ +!################################################################################ + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! IRsnowCoeff_Associated +! +! PURPOSE: +! Elemental function to test the status of the allocatable components +! of the IRsnowCoeff structure. +! +! CALLING SEQUENCE: +! Status = IRsnowCoeff_Associated( IRsnowCoeff ) +! +! OBJECTS: +! IRsnowCoeff: Structure which is to have its member's +! status tested. +! UNITS: N/A +! TYPE: IRsnowCoeff_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 IRsnowCoeff allocatable members +! are in use. +! .FALSE. - if ALL of the IRsnowCoeff allocatable members +! are not in use. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Same as input +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + ELEMENTAL FUNCTION IRsnowCoeff_Associated( self ) RESULT( Status ) + TYPE(IRsnowCoeff_type), INTENT(IN) :: self + LOGICAL :: Status + Status = self%Is_Allocated + END FUNCTION IRsnowCoeff_Associated + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! IRsnowCoeff_Destroy +! +! PURPOSE: +! Elemental subroutine to re-initialize IRsnowCoeff objects. +! +! CALLING SEQUENCE: +! CALL IRsnowCoeff_Destroy( IRsnowCoeff ) +! +! OBJECTS: +! IRsnowCoeff: Re-initialized IRsnowCoeff structure. +! UNITS: N/A +! TYPE: IRsnowCoeff_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(OUT) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + ELEMENTAL SUBROUTINE IRsnowCoeff_Destroy( self ) + TYPE(IRsnowCoeff_type), INTENT(OUT) :: self + self%Is_Allocated = .FALSE. + END SUBROUTINE IRsnowCoeff_Destroy + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! IRsnowCoeff_Create +! +! PURPOSE: +! Elemental subroutine to create an instance of an IRsnowCoeff object. +! +! CALLING SEQUENCE: +! CALL IRsnowCoeff_Create( IRsnowCoeff , & +! n_Angles , & +! n_Frequencies, & +! n_Grain_Sizes, & +! n_Temperature ) +! +! OBJECTS: +! IRsnowCoeff: IRsnowCoeff object structure. +! UNITS: N/A +! TYPE: IRsnowCoeff_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(OUT) +! +! INPUTS: +! n_Angles: Number of angles dimension. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Conformable with the IRsnowCoeff object +! ATTRIBUTES: INTENT(IN) +! +! n_Frequencies: Number of frequencies dimension. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Conformable with the IRsnowCoeff object +! ATTRIBUTES: INTENT(IN) +! +! n_Grain_Sizes: Number of Grain Sizes dimension. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Conformable with the IRsnowCoeff object +! ATTRIBUTES: INTENT(IN) +! +! n_Temperature: Number oftemperature dimension. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Conformable with the IRsnowCoeff object +! ATTRIBUTES: INTENT(IN) +!:sdoc-: +!-------------------------------------------------------------------------------- + + ELEMENTAL SUBROUTINE IRsnowCoeff_Create( & + self , & ! Output + n_Angles , & ! Input + n_Frequencies, & ! Input + n_Grain_Sizes, & ! Input + n_Temperature ) ! Input + ! Arguments + TYPE(IRsnowCoeff_type) , INTENT(OUT) :: self + INTEGER , INTENT(IN) :: n_Angles + INTEGER , INTENT(IN) :: n_Frequencies + INTEGER , INTENT(IN) :: n_Grain_Sizes + INTEGER , INTENT(IN) :: n_Temperature + ! Local variables + INTEGER :: alloc_stat + + ! Check input + IF ( self%Is_Allocated .OR. & + n_Angles < 1 .OR. & + n_Frequencies < 1 .OR. & + n_Grain_Sizes < 1 .OR. & + n_Temperature < 1) RETURN + + ! Perform the allocation + ALLOCATE( self%Angle( n_Angles ), & + self%Frequency( n_Frequencies ), & + self%Grain_Size( n_Grain_Sizes ), & + self%Temperature( n_Temperature ), & + self%Emissivity( n_Angles, n_Frequencies, n_Grain_Sizes, n_Temperature), & + STAT = alloc_stat ) + IF ( alloc_stat /= 0 ) RETURN + + + ! Initialise + ! ...Dimensions + self%n_Angles = n_Angles + self%n_Frequencies = n_Frequencies + self%n_Grain_Sizes = n_Grain_Sizes + self%n_Temperature = n_Temperature + ! ...Arrays + self%Angle = ZERO + self%Frequency = ZERO + self%Grain_Size = ZERO + self%Temperature = ZERO + self%Emissivity = ZERO + + ! Set allocation indicator + self%Is_Allocated = .TRUE. + + END SUBROUTINE IRsnowCoeff_Create + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! IRsnowCoeff_Inspect +! +! PURPOSE: +! Subroutine to print the contents of a IRsnowCoeff object to stdout. +! +! CALLING SEQUENCE: +! CALL IRsnowCoeff_Inspect( IRsnowCoeff ) +! +! OBJECTS: +! IRsnowCoeff: IRsnowCoeff object to display. +! UNITS: N/A +! TYPE: IRsnowCoeff_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE IRsnowCoeff_Inspect( self ) + TYPE(IRsnowCoeff_type), INTENT(IN) :: self + INTEGER :: i2, i3, i4 + WRITE(*,'(1x,"IRsnowCoeff OBJECT")') + ! Release/version info + WRITE(*,'(3x,"Release.Version :",1x,i0,".",i0)') self%Release, self%Version + ! Surface classification name + WRITE(*,'(3x,"Classification_Name :",1x,a)') TRIM(self%Classification_Name) + ! Dimensions + WRITE(*,'(3x,"n_Angles :",1x,i0)') self%n_Angles + WRITE(*,'(3x,"n_Frequencies :",1x,i0)') self%n_Frequencies + WRITE(*,'(3x,"n_Grain_Sizes :",1x,i0)') self%n_Grain_Sizes + WRITE(*,'(3x,"n_Temperature :",1x,i0)') self%n_Temperature + IF ( .NOT. IRsnowCoeff_Associated(self) ) RETURN + ! Dimension arrays + WRITE(*,'(3x,"Angle :")') + WRITE(*,'(5(1x,es22.15,:))') self%Angle + WRITE(*,'(3x,"Frequency :")') + WRITE(*,'(5(1x,es22.15,:))') self%Frequency + WRITE(*,'(3x,"Grain_Size :")') + WRITE(*,'(5(1x,es22.15,:))') self%Grain_Size + WRITE(*,'(3x,"Temperature :")') + WRITE(*,'(5(1x,es22.15,:))') self%Temperature + ! Emissivity array + WRITE(*,'(3x,"Emissivity :")') + DO i4 = 1, self%n_Temperature + WRITE(*,'(5x,"TEMPERATURE :",es22.15)') self%Temperature(i4) + DO i3 = 1, self%n_Grain_Sizes + WRITE(*,'(5x,"Grain_Size :",es22.15)') self%Grain_Size(i3) + DO i2 = 1, self%n_Frequencies + WRITE(*,'(5x,"FREQUENCY :",es22.15)') self%Frequency(i2) + WRITE(*,'(5(1x,es22.15,:))') self%Emissivity(:,i2,i3,i4) + END DO + END DO + END DO + END SUBROUTINE IRsnowCoeff_Inspect + + + +!---------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! IRsnowCoeff_ValidRelease +! +! PURPOSE: +! Function to check the IRsnowCoeff Release value. +! +! CALLING SEQUENCE: +! IsValid = IRsnowCoeff_ValidRelease( IRsnowCoeff ) +! +! INPUTS: +! IRsnowCoeff: IRsnowCoeff object for which the Release component +! is to be checked. +! UNITS: N/A +! TYPE: IRsnowCoeff_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! IsValid: Logical value defining the release validity. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! +!:sdoc-: +!---------------------------------------------------------------------------------- + + FUNCTION IRsnowCoeff_ValidRelease( self ) RESULT( IsValid ) + ! Arguments + TYPE(IRsnowCoeff_type), INTENT(IN) :: self + ! Function result + LOGICAL :: IsValid + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'IRsnowCoeff_ValidRelease' + ! Local variables + CHARACTER(ML) :: msg + + ! Set up + IsValid = .TRUE. + + + ! Check release is not too old + IF ( self%Release < IRsnowCOEFF_RELEASE ) THEN + IsValid = .FALSE. + WRITE( msg,'("An IRsnowCoeff data update is needed. ", & + &"IRsnowCoeff release is ",i0,". Valid release is ",i0,"." )' ) & + self%Release, IRsnowCOEFF_RELEASE + CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ); RETURN + END IF + + + ! Check release is not too new + IF ( self%Release > IRsnowCOEFF_RELEASE ) THEN + IsValid = .FALSE. + WRITE( msg,'("An IRsnowCoeff software update is needed. ", & + &"IRsnowCoeff release is ",i0,". Valid release is ",i0,"." )' ) & + self%Release, IRsnowCOEFF_RELEASE + CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ); RETURN + END IF + + END FUNCTION IRsnowCoeff_ValidRelease + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! IRsnowCoeff_Info +! +! PURPOSE: +! Subroutine to return a string containing version and dimension +! information about a IRsnowCoeff object. +! +! CALLING SEQUENCE: +! CALL IRsnowCoeff_Info( IRsnowCoeff, Info ) +! +! OBJECTS: +! IRsnowCoeff: IRsnowCoeff object about which info is required. +! UNITS: N/A +! TYPE: IRsnowCoeff_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! Info: String containing version and dimension information +! about the IRsnowCoeff object. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE IRsnowCoeff_Info( self, Info ) + ! Arguments + TYPE(IRsnowCoeff_type), INTENT(IN) :: self + CHARACTER(*), INTENT(OUT) :: Info + ! Parameters + INTEGER, PARAMETER :: CARRIAGE_RETURN = 13 + INTEGER, PARAMETER :: LINEFEED = 10 + ! Local variables + CHARACTER(2000) :: Long_String + + ! Write the required data to the local string + WRITE( Long_String, & + '( a,1x,"IRsnowCoeff RELEASE.VERSION: ", i2, ".", i2.2,a,3x, & + &"CLASSIFICATION: ",a,",",2x,& + &"N_ANGLES=",i3,2x,& + &"N_FREQUENCIES=",i5,2x,& + &"n_Grain_Sizes=",i3,2x,& + &"N_TEMPERATURE=",i3 )' ) & + ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), & + self%Release, self%Version, & + ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), & + TRIM(self%Classification_Name), & + self%n_Angles, & + self%n_Frequencies, & + self%n_Grain_Sizes, & + self%n_Temperature + + ! Trim the output based on the + ! dummy argument string length + Info = Long_String(1:MIN(LEN(Info), LEN_TRIM(Long_String))) + + END SUBROUTINE IRsnowCoeff_Info + + +!################################################################################## +!################################################################################## +!## ## +!## ## PRIVATE MODULE ROUTINES ## ## +!## ## +!################################################################################## +!################################################################################## + +!------------------------------------------------------------------------------ +! +! NAME: +! IRsnowCoeff_Equal +! +! PURPOSE: +! Elemental function to test the equality of two IRsnowCoeff objects. +! Used in OPERATOR(==) interface block. +! +! CALLING SEQUENCE: +! is_equal = IRsnowCoeff_Equal( x, y ) +! +! or +! +! IF ( x == y ) THEN +! ... +! END IF +! +! OBJECTS: +! x, y: Two IRsnowCoeff objects to be compared. +! UNITS: N/A +! TYPE: IRsnowCoeff_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 IRsnowCoeff_Equal( x, y ) RESULT( is_equal ) + TYPE(IRsnowCoeff_type), INTENT(IN) :: x, y + LOGICAL :: is_equal + + ! Set up + is_equal = .FALSE. + + ! Check the object association status + IF ( (.NOT. IRsnowCoeff_Associated(x)) .OR. & + (.NOT. IRsnowCoeff_Associated(y)) ) RETURN + + ! Check contents + ! ...Release/version info + IF ( (x%Release /= y%Release) .OR. & + (x%Version /= y%Version) ) RETURN + ! ...Classification name + IF ( (x%Classification_Name /= y%Classification_Name) ) RETURN + ! ...Dimensions + IF ( (x%n_Angles /= y%n_Angles ) .OR. & + (x%n_Frequencies /= y%n_Frequencies ) .OR. & + (x%n_Grain_Sizes /= y%n_Grain_Sizes ) .OR. & + (x%n_Temperature /= y%n_Temperature ) ) RETURN + ! ...Arrays + IF ( ALL(x%Angle .EqualTo. y%Angle ) .AND. & + ALL(x%Frequency .EqualTo. y%Frequency ) .AND. & + ALL(x%Grain_Size .EqualTo. y%Grain_Size ) .AND. & + ALL(x%Temperature .EqualTo. y%Temperature ) .AND. & + ALL(x%Emissivity .EqualTo. y%Emissivity ) ) & + is_equal = .TRUE. + + END FUNCTION IRsnowCoeff_Equal + +END MODULE IRsnowCoeff_Define diff --git a/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_IO.f90 b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_IO.f90 new file mode 100644 index 0000000..9e0b515 --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_IO.f90 @@ -0,0 +1,764 @@ +! +! IRsnowCoeff_IO +! +! Container module for Binary and netCDF IRsnowCoeff I/O modules. +! All Binary related modules are placeholder for now. +! +! CREATION HISTORY: +! +! Written by: Cheng Dang, 23-May-2022 +! dangch@ucar.edu + +MODULE IRsnowCoeff_IO + + ! ----------------- + ! 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_Exists + USE IRsnowCoeff_Define , ONLY: IRsnowCoeff_type, & + OPERATOR(==), & + IRsnowCoeff_Associated + USE IRsnowCoeff_Binary_IO , ONLY: IRsnowCoeff_Binary_InquireFile , & + IRsnowCoeff_Binary_ReadFile , & + IRsnowCoeff_Binary_WriteFile + USE IRsnowCoeff_netCDF_IO , ONLY: IRsnowCoeff_netCDF_InquireFile , & + IRsnowCoeff_netCDF_ReadFile , & + IRsnowCoeff_netCDF_WriteFile + ! Disable implicit typing + IMPLICIT NONE + + ! ------------ + ! Visibilities + ! ------------ + PRIVATE + PUBLIC :: IRsnowCoeff_InquireFile + PUBLIC :: IRsnowCoeff_ReadFile + PUBLIC :: IRsnowCoeff_WriteFile + PUBLIC :: IRsnowCoeff_netCDF_to_Binary + PUBLIC :: IRsnowCoeff_Binary_to_netCDF + + CONTAINS + +!################################################################################ +!################################################################################ +!## ## +!## ## PUBLIC MODULE ROUTINES ## ## +!## ## +!################################################################################ +!################################################################################ +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRsnowCoeff_InquireFile +! +! PURPOSE: +! Function to inquire IRsnowCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRsnowCoeff_InquireFile( & +! Filename, & +! netCDF = netCDF , & +! n_Angles = n_Angles , & +! n_Frequencies = n_Frequencies , & +! n_Grain_Sizes = n_Grain_Sizes , & +! n_Temperature = n_Temperature , & +! Release = Release , & +! Version = Version , & +! Title = Title , & +! History = History , & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! IRsnowCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! netCDF: Set this logical argument to access netCDF format +! IRsnowCoeff datafiles. +! If == .FALSE., file format is BINARY [DEFAULT]. +! == .TRUE., file format is NETCDF. +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! OPTIONAL OUTPUTS: +! n_Angles: The number of angles in the look-up +! table (LUT). Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Frequencies: The number of frequencies in the LUT. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Grain_Sizes: The number of grain size in +! the LUT. Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! n_Temperature: The number of temperature in +! the LUT. Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Release: The release number of the IRsnowCoeff file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Version: The version number of the IRsnowCoeff file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Title: Character string written into the TITLE global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 IRsnowCoeff_InquireFile( & + Filename , & ! Input + netCDF , & ! Optional input + n_Angles , & ! Optional output + n_Frequencies , & ! Optional output + n_Grain_Sizes , & ! Optional output + n_Temperature , & ! 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_Angles + INTEGER , OPTIONAL, INTENT(OUT) :: n_Frequencies + INTEGER , OPTIONAL, INTENT(OUT) :: n_Grain_Sizes + INTEGER , OPTIONAL, INTENT(OUT) :: n_Temperature + LOGICAL , OPTIONAL, INTENT(IN) :: netCDF + 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 variables + LOGICAL :: Binary + + ! Set up + err_stat = SUCCESS + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + + ! Call the appropriate function + IF ( Binary ) THEN + err_stat = IRsnowCoeff_Binary_InquireFile( & + Filename , & + n_Angles = n_Angles , & + n_Frequencies = n_Frequencies , & + n_Grain_Sizes = n_Grain_Sizes , & + n_Temperature = n_Temperature , & + Release = Release , & + Version = Version ) + ELSE + err_stat = IRsnowCoeff_netCDF_InquireFile( & + Filename , & + n_Angles = n_Angles , & + n_Frequencies = n_Frequencies , & + n_Grain_Sizes = n_Grain_Sizes , & + n_Temperature = n_Temperature , & + Release = Release , & + Version = Version , & + Title = Title , & + History = History , & + Comment = Comment ) + END IF + + END FUNCTION IRsnowCoeff_InquireFile + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRsnowCoeff_ReadFile +! +! PURPOSE: +! Function to read IRsnowCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRsnowCoeff_ReadFile( & +! IRsnowCoeff, & +! Filename, & +! netCDF = netCDF , & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! IRsnowCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! IRsnowCoeff: Object containing the IRsnow coefficient data. +! UNITS: N/A +! TYPE: TYPE(IRsnowCoeff_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! OPTIONAL INPUTS: +! netCDF: Set this logical argument to access netCDF format +! IRsnowCoeff datafiles. +! If == .FALSE., file format is BINARY [DEFAULT]. +! == .TRUE., file format is NETCDF. +! 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 +! +! OPTIONAL OUTPUTS: +! Title: Character string written into the TITLE global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 IRsnowCoeff_ReadFile( & + IRsnowCoeff , & ! Output + Filename , & ! Input + netCDF , & ! Optional 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(IRsnowCoeff_type), INTENT(OUT) :: IRsnowCoeff + CHARACTER(*), INTENT(IN) :: Filename + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + 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 variables + LOGICAL :: Binary + + ! Set up + err_stat = SUCCESS + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + ! Call the appropriate function + IF ( Binary ) THEN + err_stat = IRsnowCoeff_Binary_ReadFile( & + IRsnowCoeff , & + Filename , & + No_Close , & + Quiet ) + ELSE + err_stat = IRsnowCoeff_netCDF_ReadFile( & + IRsnowCoeff , & + Filename , & + Quiet , & + Title , & + History , & + Comment , & + Debug ) + END IF + + END FUNCTION IRsnowCoeff_ReadFile + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRsnowCoeff_WriteFile +! +! PURPOSE: +! Function to write IRsnowCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRsnowCoeff_WriteFile( & +! IRsnowCoeff, & +! Filename, & +! netCDF = netCDF , & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of the +! IRsnowCoeff data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! IRsnowCoeff: Object containing the IRsnow coefficient data. +! UNITS: N/A +! TYPE: TYPE(IRsnowCoeff_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! netCDF: Set this logical argument to access netCDF format +! IRsnowCoeff datafiles. +! If == .FALSE., file format is BINARY [DEFAULT]. +! == .TRUE., file format is NETCDF. +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! No_Close: Set this logical argument to *NOT* close the datafile +! upon exiting this routine. This option is required if +! the IRsnowCoeff 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 +! +! Title: Character string written into the TITLE global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 data write was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!------------------------------------------------------------------------------ + + FUNCTION IRsnowCoeff_WriteFile( & + IRsnowCoeff, & ! Input + Filename , & ! Input + netCDF , & ! Optional 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(IRsnowCoeff_type), INTENT(IN) :: IRsnowCoeff + CHARACTER(*), INTENT(IN) :: Filename + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + 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 + ! Local variables + LOGICAL :: Binary + + ! Set up + err_stat = SUCCESS + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + ! Call the appropriate function + IF ( Binary ) THEN + err_stat = IRsnowCoeff_Binary_WriteFile( & + IRsnowCoeff, & + Filename , & + No_Close , & + Quiet , & + Title , & + History , & + Comment , & + Debug ) + ELSE + err_stat = IRsnowCoeff_netCDF_WriteFile( & + IRsnowCoeff, & + Filename , & + Quiet , & + Title , & + History , & + Comment , & + Debug ) + END IF + + END FUNCTION IRsnowCoeff_WriteFile + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRsnowCoeff_netCDF_to_Binary +! +! PURPOSE: +! Function to convert a netCDF IRsnowCoeff file to Binary format. +! +! CALLING SEQUENCE: +! Error_Status = IRsnowCoeff_netCDF_to_Binary( & +! NC_Filename , & +! BIN_Filename , & +! Quiet = Quiet ) +! +! INPUTS: +! NC_Filename: Character string specifying the name of the +! netCDF format IRsnowCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! BIN_Filename: Character string specifying the name of the +! Binary format IRsnowCoeff data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! 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 conversion was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +! SIDE EFFECTS: +! - If the output file already exists, it is overwritten. +! - If an error occurs, the output file is deleted before +! returning to the calling routine. +! +!:sdoc-: +!------------------------------------------------------------------------------ + + FUNCTION IRsnowCoeff_netCDF_to_Binary( & + NC_Filename , & ! Input + BIN_Filename, & ! Input + Quiet ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: NC_Filename + CHARACTER(*), INTENT(IN) :: BIN_Filename + LOGICAL, OPTIONAL, INTENT(IN) :: Quiet + ! Function result + INTEGER :: err_stat + ! Function parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'IRsnowCoeff_netCDF_to_Binary' + ! Function variables + CHARACTER(256) :: msg + TYPE(IRsnowCoeff_type) :: cc, cc_copy + + ! Set up + err_stat = SUCCESS + + ! Read the netCDF file + err_stat = IRsnowCoeff_ReadFile(cc, NC_Filename, Quiet = Quiet, netCDF = .TRUE. ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading netCDF file '//TRIM(NC_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Write the Binary file + err_stat = IRsnowCoeff_WriteFile(cc, BIN_Filename, Quiet = Quiet ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error writing Binary file '//TRIM(BIN_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Check the write was successful + ! ...Read the Binary file + err_stat = IRsnowCoeff_ReadFile(cc_copy, BIN_Filename, Quiet = Quiet) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading Binary file '//TRIM(BIN_Filename)//' for test' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! ...Compare the IRsnowCoeff objects + IF ( .NOT. (cc == cc_copy) ) THEN + msg = 'IRsnowCoeff object comparison failed.' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + END FUNCTION IRsnowCoeff_netCDF_to_Binary + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRsnowCoeff_Binary_to_netCDF +! +! PURPOSE: +! Function to convert a binary IRsnowCoeff file to Binary format. +! +! CALLING SEQUENCE: +! Error_Status = IRsnowCoeff_Binary_to_netCDF( & +! BIN_Filename , & +! NC_Filename , & +! Quiet = Quiet ) +! +! INPUTS: +! BIN_Filename: Character string specifying the name of the +! Binary format IRsnowCoeff data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! NC_Filename: Character string specifying the name of the +! netCDF format IRsnowCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! OPTIONAL INPUTS: +! 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 conversion was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +! SIDE EFFECTS: +! - If the output file already exists, it is overwritten. +! - If an error occurs, the output file is deleted before +! returning to the calling routine. +! +!:sdoc-: +!------------------------------------------------------------------------------ + + FUNCTION IRsnowCoeff_Binary_to_netCDF( & + BIN_Filename, & ! Input + NC_Filename , & ! Input + Quiet ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: BIN_Filename + CHARACTER(*), INTENT(IN) :: NC_Filename + LOGICAL, OPTIONAL, INTENT(IN) :: Quiet + ! Function result + INTEGER :: err_stat + ! Function parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'IRsnowCoeff_Binary_to_NetCDF' + ! Function variables + CHARACTER(256) :: msg + TYPE(IRsnowCoeff_type) :: cc, cc_copy + + ! Set up + err_stat = SUCCESS + + ! Read the binary file + err_stat = IRsnowCoeff_ReadFile(cc, BIN_Filename, Quiet = Quiet) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading Binary file '//TRIM(BIN_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Write the netCDF file + err_stat = IRsnowCoeff_WriteFile(cc, NC_Filename, Quiet = Quiet, netCDF = .TRUE.) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error writing netCDF file '//TRIM(NC_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Check the write was successful + ! ...Read the netCDF file + err_stat = IRsnowCoeff_ReadFile(cc_copy, NC_Filename, Quiet = Quiet, netCDF = .TRUE.) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading netCDF file '//TRIM(NC_Filename)//' for test' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! ...Compare the IRsnowCoeff objects + IF ( .NOT. (cc == cc_copy) ) THEN + msg = 'IRsnowCoeff object comparison failed.' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + END FUNCTION IRsnowCoeff_Binary_to_netCDF + +END MODULE IRsnowCoeff_IO diff --git a/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_NC2BIN/IRsnowCoeff_NC2BIN.f90 b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_NC2BIN/IRsnowCoeff_NC2BIN.f90 new file mode 100644 index 0000000..0a5c9c7 --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_NC2BIN/IRsnowCoeff_NC2BIN.f90 @@ -0,0 +1,74 @@ +! +! ! IRsnowCoeff_NC2BIN +! +! Program to convert a CRTM IRsnowCoeff data file +! from netCDF to Binary format +! +! +! CREATION HISTORY: +! +! Written by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu + +PROGRAM IRsnowCoeff_NC2BIN + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module usage + USE Message_Handler , ONLY: SUCCESS, FAILURE, Program_Message, Display_Message + USE SignalFile_Utility , ONLY: Create_SignalFile + USE IRsnowCoeff_Define , ONLY: IRsnowCoeff_type + USE IRsnowCoeff_IO , ONLY: IRsnowCoeff_netCDF_to_Binary + ! Disable implicit typing + IMPLICIT NONE + + ! ---------- + ! Parameters + ! ---------- + CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'IRsnowCoeff_NC2BIN' + + ! --------- + ! Variables + ! --------- + INTEGER :: err_stat + CHARACTER(256) :: NC_Filename, BIN_Filename + + ! Program header + CALL Program_Message( PROGRAM_NAME, & + 'Program to convert a CRTM IRsnowCoeff data file '//& + 'from netCDF to Binary format.', & + '$Revision$') + ! Get the filenames + WRITE(*,FMT='(/5x,"Enter the INPUT netCDF IRsnowCoeff filename : ")', ADVANCE='NO') + READ(*,'(a)') NC_Filename + NC_Filename = ADJUSTL(NC_Filename) + WRITE(*,FMT='(/5x,"Enter the OUTPUT Binary IRsnowCoeff filename: ")', ADVANCE='NO') + READ(*,'(a)') BIN_Filename + BIN_Filename = ADJUSTL(BIN_Filename) + ! ...Sanity check that they're not the same + IF ( BIN_Filename == NC_Filename ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'IRsnowCoeff netCDF and Binary filenames are the same!', & + FAILURE ) + STOP + END IF + + ! Perform the conversion + err_stat = IRsnowCoeff_netCDF_to_Binary( NC_Filename, BIN_Filename ) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'IRsnowCoeff netCDF -> Binary conversion failed!', & + FAILURE ) + STOP + END IF + + ! Create a signal file indicating success + err_stat = Create_SignalFile( BIN_Filename ) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'Error creating signal file for '//TRIM(BIN_Filename), & + FAILURE ) + END IF + +END PROGRAM IRsnowCoeff_NC2BIN diff --git a/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_NC2BIN/Makefile b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_NC2BIN/Makefile new file mode 100644 index 0000000..6c2f7ad --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_NC2BIN/Makefile @@ -0,0 +1,61 @@ +#============================================================================== +# +# Makefile for IRwaterCoeff_Inspect program +# +#============================================================================== + +# Define macros +include $(CRTM_SOURCE_ROOT)/make.macros + +# This makefile +MAKE_FILE = Makefile + +# Executable files +EXE_FILE = IRsnowCoeff_NC2BIN +SCRIPT_FILE = run_$(EXE_FILE).sh + +# Source files to link +SRC_FILES = Type_Kinds.f90 \ + File_Utility.f90 \ + Message_Handler.f90 \ + Compare_Float_Numbers.f90 \ + Binary_File_Utility.f90 \ + Endian_Utility.f90 \ + String_Utility.f90 \ + Fundamental_Constants.f90 \ + SignalFile_Utility.f90 \ + IRsnowCoeff_Define.f90 \ + IRsnowCoeff_IO.f90 \ + IRsnowCoeff_Binary_IO.f90 \ + IRsnowCoeff_netCDF_IO.f90 \ + +# Obj files used in link phase +OBJ_FILES = ${SRC_FILES:.f90=.o} \ + $(EXE_FILE).o + +# Include and library definitions +INCLUDES = -I$(NC4_DIR)/include \ + -I$(HDF_DIR)/include +LIBRARIES = -L$(NC4_DIR)/lib -lnetcdf -lnetcdff \ + -L$(HDF_DIR)/lib -lhdf5 + +# Define common make targets (all, build, clean, install) +include $(CRTM_SOURCE_ROOT)/make.common_targets + +# Source link creation and removal +create_links:: + @$(LINK_SCRIPT) $(CRTM_SOURCE_ROOT) $(SRC_FILES) + +remove_links:: + @$(UNLINK_SCRIPT) $(SRC_FILES) + +# Script install target +install_script:: + @$(COPY) $(SCRIPT_FILE) ${HOME}/bin + +# Source dependency lists +include make.dependencies + +# Define default rules +include $(CRTM_SOURCE_ROOT)/make.rules + diff --git a/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_NC2BIN/make.dependencies b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_NC2BIN/make.dependencies new file mode 100644 index 0000000..b25dbe4 --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_NC2BIN/make.dependencies @@ -0,0 +1,14 @@ +RsnowCoeff_Define.o : IRsnowCoeff_Define.f90 Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o +IRsnowCoeff_Binary_IO.o : IRsnowCoeff_Binary_IO.f90 IRsnowCoeff_Define.o String_Utility.o File_Utility.o Message_Handler.o Type_Kinds.o +IRsnowCoeff_netCDF_IO.o : IRsnowCoeff_netCDF_IO.f90 IRsnowCoeff_Define.o String_Utility.o File_Utility.o Message_Handler.o Type_Kinds.o +IRsnowCoeff_IO.o : IRsnowCoeff_IO.f90 IRsnowCoeff_Binary_IO.o IRsnowCoeff_netCDF_IO.o IRsnowCoeff_Define.o String_Utility.o File_Utility.o Message_Handler.o Type_Kinds.o +IRsnowCoeff_NC2BIN.o : IRsnowCoeff_NC2BIN.f90 IRsnowCoeff_IO.o IRsnowCoeff_Define.o SignalFile_Utility.o Message_Handler.o +Binary_File_Utility.o : Binary_File_Utility.f90 Endian_Utility.o Message_Handler.o File_Utility.o Type_Kinds.o +Compare_Float_Numbers.o : Compare_Float_Numbers.f90 Type_Kinds.o +Endian_Utility.o : Endian_Utility.f90 Type_Kinds.o +File_Utility.o : File_Utility.f90 +Fundamental_Constants.o : Fundamental_Constants.f90 Type_Kinds.o +Message_Handler.o : Message_Handler.f90 File_Utility.o +SignalFile_Utility.o : SignalFile_Utility.f90 Message_Handler.o File_Utility.o +String_Utility.o : String_Utility.f90 +Type_Kinds.o : Type_Kinds.f90 diff --git a/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_netCDF_IO.f90 b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_netCDF_IO.f90 new file mode 100644 index 0000000..a2e450b --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Snow/IRsnowCoeff_netCDF_IO.f90 @@ -0,0 +1,1367 @@ +! +! IRsnowCoeff_netCDF_IO +! +! Module containing routines to read and write IRsnowCoeff netCDF +! format files. +! +! +! CREATION HISTORY: +! +! Written by: Cheng Dang, 23-May-2022 +! dangch@ucar.edu + +MODULE IRsnowCoeff_netCDF_IO + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module use + USE Type_Kinds , ONLY: fp, Double, Long + USE Message_Handler , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message + USE File_Utility , ONLY: File_Exists + USE String_Utility , ONLY: StrClean + USE IRsnowCoeff_Define , ONLY: IRsnowCoeff_type, & + IRsnowCoeff_Associated, & + IRsnowCoeff_Create, & + IRsnowCoeff_Inspect, & + IRsnowCoeff_Destroy, & + IRsnowCoeff_ValidRelease, & + IRsnowCoeff_Info + USE netcdf + ! Disable implicit typing + IMPLICIT NONE + + ! ------------ + ! Visibilities + ! ------------ + ! Everything private by default + PRIVATE + ! Procedures + PUBLIC :: IRsnowCoeff_netCDF_InquireFile + PUBLIC :: IRsnowCoeff_netCDF_ReadFile + PUBLIC :: IRsnowCoeff_netCDF_WriteFile + + ! ----------------- + ! Module parameters + ! ----------------- + ! Default msg string length + INTEGER, PARAMETER :: ML = 1024 + ! Literal constants + REAL(fp), PARAMETER :: FILL_FLOAT = -999.0_fp + REAL(fp), PARAMETER :: ONE = 1.0_fp + + ! Global attribute names. Case sensitive + CHARACTER(*), PARAMETER :: RELEASE_GATTNAME = 'Release' + CHARACTER(*), PARAMETER :: VERSION_GATTNAME = 'Version' + CHARACTER(*), PARAMETER :: DATA_SOURCE_GATTNAME = 'Data_Source' + CHARACTER(*), PARAMETER :: TITLE_GATTNAME = 'Title' + CHARACTER(*), PARAMETER :: HISTORY_GATTNAME = 'History' + CHARACTER(*), PARAMETER :: COMMENT_GATTNAME = 'Comment' + CHARACTER(*), PARAMETER :: CLASSIFICATION_NAME_GATTNAME = 'Classification_Name' + + ! Dimension names + CHARACTER(*), PARAMETER :: TNSL_DIMNAME = 'String_Length' + CHARACTER(*), PARAMETER :: FREQUENCY_DIMNAME = 'n_Frequencies' + CHARACTER(*), PARAMETER :: ANGLE_DIMNAME = 'n_Angles' + CHARACTER(*), PARAMETER :: GRAINSIZE_DIMNAME = 'n_Grain_Sizes' + CHARACTER(*), PARAMETER :: TEMPERATURE_DIMNAME = 'n_Temperature' + + ! Variable names + CHARACTER(*), PARAMETER :: ANGLE_VARNAME = 'Angle' + CHARACTER(*), PARAMETER :: FREQUENCY_VARNAME = 'Frequency' + CHARACTER(*), PARAMETER :: GRAINSIZE_VARNAME = 'Grain_Size' + CHARACTER(*), PARAMETER :: TEMPERATURE_VARNAME = 'Temperature' + CHARACTER(*), PARAMETER :: EMISSIVITY_VARNAME = 'Emissivity' + + ! Variable long name attribute. + CHARACTER(*), PARAMETER :: LONGNAME_ATTNAME = 'long_name' + CHARACTER(*), PARAMETER :: ANGLE_LONGNAME = 'Angle' + CHARACTER(*), PARAMETER :: FREQUENCY_LONGNAME = 'Frequency' + CHARACTER(*), PARAMETER :: GRAINSIZE_LONGNAME = 'Grain Size' + CHARACTER(*), PARAMETER :: TEMPERATURE_LONGNAME = 'Temperature' + CHARACTER(*), PARAMETER :: EMISSIVITY_LONGNAME = 'Emissivity' + + ! Variable description attribute. + CHARACTER(*), PARAMETER :: DESCRIPTION_ATTNAME = 'description' + CHARACTER(*), PARAMETER :: ANGLE_DESCRIPTION = 'Angle dimension values for emissivity data' + CHARACTER(*), PARAMETER :: FREQUENCY_DESCRIPTION = 'Frequency dimension values for emissivity data' + CHARACTER(*), PARAMETER :: GRAINSIZE_DESCRIPTION = 'Grain Size dimension values for emissivity data' + CHARACTER(*), PARAMETER :: TEMPERATURE_DESCRIPTION = 'Temperature dimension values for emissivity data' + CHARACTER(*), PARAMETER :: EMISSIVITY_DESCRIPTION = 'Spectral water surface emissivity data' + + ! Variable units attribute. + CHARACTER(*), PARAMETER :: UNITS_ATTNAME = 'units' + CHARACTER(*), PARAMETER :: ANGLE_UNITS = 'degrees from vertical' + CHARACTER(*), PARAMETER :: FREQUENCY_UNITS = 'inverse centimeters (cm^-1)' + CHARACTER(*), PARAMETER :: GRAINSIZE_UNITS = 'effective radius in microns (um)' + CHARACTER(*), PARAMETER :: TEMPERATURE_UNITS = 'Kelvins' + CHARACTER(*), PARAMETER :: EMISSIVITY_UNITS = 'N/A' + + ! Variable _FillValue attribute. + CHARACTER(*), PARAMETER :: FILLVALUE_ATTNAME = '_FillValue' + REAL(Double), PARAMETER :: ANGLE_FILLVALUE = FILL_FLOAT + REAL(Double), PARAMETER :: FREQUENCY_FILLVALUE = FILL_FLOAT + REAL(Double), PARAMETER :: GRAINSIZE_FILLVALUE = FILL_FLOAT + REAL(Double), PARAMETER :: TEMPERATURE_FILLVALUE = FILL_FLOAT + REAL(Double), PARAMETER :: EMISSIVITY_FILLVALUE = FILL_FLOAT + + ! Variable types + INTEGER, PARAMETER :: ANGLE_TYPE = NF90_DOUBLE + INTEGER, PARAMETER :: FREQUENCY_TYPE = NF90_DOUBLE + INTEGER, PARAMETER :: GRAINSIZE_TYPE = NF90_DOUBLE + INTEGER, PARAMETER :: TEMPERATURE_TYPE = NF90_DOUBLE + INTEGER, PARAMETER :: EMISSIVITY_TYPE = NF90_DOUBLE + + +CONTAINS + +!################################################################################ +!################################################################################ +!## ## +!## ## PUBLIC MODULE ROUTINES ## ## +!## ## +!################################################################################ +!################################################################################ +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRsnowCoeff_netCDF_InquireFile +! +! PURPOSE: +! Function to inquire IRsnowCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRsnowCoeff_netCDF_InquireFile( & +! Filename, & +! n_Angles = n_Angles , & +! n_Frequencies = n_Frequencies , & +! n_Grain_Sizes = n_Grain_Sizes , & +! n_Temperature = n_Temperature , & +! Release = Release , & +! Version = Version , & +! Title = Title , & +! History = History , & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! IRsnowCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL OUTPUTS: +! n_Angles: The number of angles in the look-up +! table (LUT). Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Frequencies: The number of frequencies in the LUT. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Grain_Sizes: The number of grain size in +! the LUT. Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Grain_Sizes: The number of temperature in +! the LUT. Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Release: The release number of the IRsnowCoeff file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Version: The version number of the IRsnowCoeff file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Title: Character string written into the TITLE global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 IRsnowCoeff_netCDF_InquireFile( & + Filename , & ! Input + n_Angles , & ! Optional output + n_Frequencies, & ! Optional output + n_Grain_Sizes, & ! Optional output + n_Temperature, & ! 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_Angles + INTEGER , OPTIONAL, INTENT(OUT) :: n_Frequencies + INTEGER , OPTIONAL, INTENT(OUT) :: n_Grain_Sizes + INTEGER , OPTIONAL, INTENT(OUT) :: n_Temperature + 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 = 'IRsnowCoeff_netCDF_InquireFile' + ! Function variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + INTEGER :: NF90_Status + INTEGER :: FileId + INTEGER :: DimId + TYPE(IRsnowCoeff_type) :: IRsnowCoeff + + ! Setup + err_stat = SUCCESS + Close_File = .FALSE. + + ! Open the file + NF90_Status = NF90_OPEN( Filename,NF90_NOWRITE,FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error opening '//TRIM(Filename)//' for read access - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Get the dimensions + ! ...n_Angles dimension + NF90_Status = NF90_INQ_DIMID( FileId,ANGLE_DIMNAME,DimId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring dimension ID for '//ANGLE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + NF90_Status = NF90_INQUIRE_DIMENSION( FileId,DimId,Len=IRsnowCoeff%n_Angles ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading dimension value for '//ANGLE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + ! ...n_Frequencies dimension + NF90_Status = NF90_INQ_DIMID( FileId,FREQUENCY_DIMNAME,DimId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring dimension ID for '//FREQUENCY_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + NF90_Status = NF90_INQUIRE_DIMENSION( FileId,DimId,Len=IRsnowCoeff%n_Frequencies ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading dimension value for '//FREQUENCY_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + ! ...n_Grain_Sizes dimension + NF90_Status = NF90_INQ_DIMID( FileId,GRAINSIZE_DIMNAME,DimId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring dimension ID for '//GRAINSIZE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + NF90_Status = NF90_INQUIRE_DIMENSION( FileId,DimId,Len=IRsnowCoeff%n_Grain_Sizes ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading dimension value for '//GRAINSIZE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + ! ...n_Temperature dimension + NF90_Status = NF90_INQ_DIMID( FileId,TEMPERATURE_DIMNAME,DimId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring dimension ID for '//TEMPERATURE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + NF90_Status = NF90_INQUIRE_DIMENSION( FileId,DimId,Len=IRsnowCoeff%n_Temperature ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading dimension value for '//TEMPERATURE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + + ! Get the global attributes + err_stat = ReadGAtts( Filename, & + FileId , & + Release = IRsnowCoeff%Release, & + Version = IRsnowCoeff%Version, & + Title = Title , & + History = History, & + Comment = Comment ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading global attributes from '//TRIM(Filename) + CALL Inquire_Cleanup(); RETURN + END IF + + ! Close the file + NF90_Status = NF90_CLOSE( FileId ) + Close_File = .FALSE. + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error closing input file - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + + ! Set the return values + IF ( PRESENT(n_Angles ) ) n_Angles = IRsnowCoeff%n_Angles + IF ( PRESENT(n_Frequencies) ) n_Frequencies = IRsnowCoeff%n_Frequencies + IF ( PRESENT(n_Grain_Sizes) ) n_Grain_Sizes = IRsnowCoeff%n_Grain_Sizes + IF ( PRESENT(n_Temperature) ) n_Temperature = IRsnowCoeff%n_Temperature + IF ( PRESENT(Release ) ) Release = IRsnowCoeff%Release + IF ( PRESENT(Version ) ) Version = IRsnowCoeff%Version + + CONTAINS + + SUBROUTINE Inquire_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing input file during error cleanup.' + END IF + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Inquire_CleanUp + + END FUNCTION IRsnowCoeff_netCDF_InquireFile + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRsnowCoeff_netCDF_WriteFile +! +! PURPOSE: +! Function to write IRsnowCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRsnowCoeff_netCDF_WriteFile( & +! IRsnowCoeff, & +! Filename, & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment, & +! Debug ) +! +! INPUTS: +! IRsnowCoeff: Object containing the IRsnow coefficient data. +! UNITS: N/A +! TYPE: TYPE(IRsnowCoeff_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Filename: Character string specifying the name of the +! IRsnowCoeff data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! OPTIONAL INPUTS: +! 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 +! +! Title: Character string written into the TITLE global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 data write was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!------------------------------------------------------------------------------ + FUNCTION IRsnowCoeff_netCDF_WriteFile( & + IRsnowCoeff , & ! Input + Filename , & ! Input + Quiet , & ! Optional input + Title , & ! Optional input + History , & ! Optional input + Comment , & ! Optional input + Debug ) & ! Optional input (Debug output control) + RESULT( err_stat ) + ! Arguments + TYPE(IRsnowCoeff_type), INTENT(IN) :: IRsnowCoeff + CHARACTER(*), INTENT(IN) :: Filename + 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 = 'IRsnowCoeff_netCDF_WriteFile' + ! Local variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + LOGICAL :: Noisy + INTEGER :: NF90_Status + INTEGER :: FileId + INTEGER :: VarId + + ! Set up + err_stat = SUCCESS + Close_File = .FALSE. + ! ...Check structure pointer association status + IF ( .NOT. IRsnowCoeff_Associated( IRsnowCoeff ) ) THEN + msg = 'IRsnowCoeff structure is empty. Nothing to do!' + CALL Write_CleanUp(); RETURN + END IF + ! ...Check if release is valid + IF ( .NOT. IRsnowCoeff_ValidRelease( IRsnowCoeff ) ) THEN + msg = 'IRsnowCoeff Release check failed.' + CALL Write_Cleanup(); RETURN + END IF + ! ...Check Quiet argument + Noisy = .TRUE. + IF ( PRESENT(Quiet) ) Noisy = .NOT. Quiet + + ! Create the output file + err_stat = CreateFile( & + Filename , & ! Input + IRsnowCoeff%n_Angles , & ! Input + IRsnowCoeff%n_Frequencies , & ! Input + IRsnowCoeff%n_Grain_Sizes , & ! Input + IRsnowCoeff%n_Temperature , & ! Input + FileId , & ! Input + Release = IRsnowCoeff%Release , & ! Optional input + Version = IRsnowCoeff%Version , & ! Optional input + Classification_Name = IRsnowCoeff%Classification_Name , & ! Optional input + Title = Title , & ! Optional input + History = History , & ! Optional input + Comment = Comment ) ! Optional input + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error creating output file '//TRIM(Filename) + CALL Write_Cleanup(); RETURN + END IF + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Write the data items + ! ...Angle variable + NF90_Status = NF90_INQ_VARID( FileId,ANGLE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//ANGLE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,IRsnowCoeff%Angle ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//ANGLE_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + ! ...Frequency variable + NF90_Status = NF90_INQ_VARID( FileId,FREQUENCY_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//FREQUENCY_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,IRsnowCoeff%Frequency ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//FREQUENCY_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + ! ...Grain Size variable + NF90_Status = NF90_INQ_VARID( FileId,GRAINSIZE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//GRAINSIZE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,IRsnowCoeff%Grain_Size ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//GRAINSIZE_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + ! ...Temperature variable + NF90_Status = NF90_INQ_VARID( FileId,TEMPERATURE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//TEMPERATURE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,IRsnowCoeff%Temperature ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//TEMPERATURE_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + ! ...Emissivity variable + NF90_Status = NF90_INQ_VARID( FileId,EMISSIVITY_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//EMISSIVITY_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,IRsnowCoeff%Emissivity ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//EMISSIVITY_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + + ! Close the file + NF90_Status = NF90_CLOSE( FileId ) + Close_File = .FALSE. + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error closing output file - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + + ! Output an info message + IF ( Noisy ) THEN + CALL IRsnowCoeff_Info( IRsnowCoeff, msg ) + CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION ) + END IF + + CONTAINS + + SUBROUTINE Write_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing output file during error cleanup - '//& + TRIM(NF90_STRERROR( NF90_Status )) + END IF + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Write_CleanUp + + END FUNCTION IRsnowCoeff_netCDF_WriteFile + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRsnowCoeff_netCDF_ReadFile +! +! PURPOSE: +! Function to read IRsnowCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRsnowCoeff_netCDF_ReadFile( & +! IRsnowCoeff, & +! Filename, & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! IRsnowCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! IRsnowCoeff: Object containing the IRsnow coefficient data. +! UNITS: N/A +! TYPE: TYPE(IRsnowCoeff_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! OPTIONAL INPUTS: +! 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 +! +! OPTIONAL OUTPUTS: +! Title: Character string written into the TITLE global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRsnowCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 IRsnowCoeff_netCDF_ReadFile( & + IRsnowCoeff , & ! Output + Filename , & ! Input + Quiet , & ! Optional input + Title , & ! Optional output + History , & ! Optional output + Comment , & ! Optional output + Debug ) & ! Optional input (Debug output control) + RESULT( err_stat ) + ! Arguments + TYPE(IRsnowCoeff_type) , INTENT(OUT) :: IRsnowCoeff + CHARACTER(*), INTENT(IN) :: Filename + 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 = 'IRsnowCoeff_netCDF_ReadFile' + ! Function variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + LOGICAL :: Noisy + INTEGER :: NF90_Status + INTEGER :: FileId + INTEGER :: n_Angles + INTEGER :: n_Frequencies + INTEGER :: n_Grain_Sizes + INTEGER :: n_Temperature + INTEGER :: VarId + + ! Set up + err_stat = SUCCESS + Close_File = .FALSE. + ! ...Check that the file exists + IF ( .NOT. File_Exists(Filename) ) THEN + msg = 'File '//TRIM(Filename)//' not found.' + CALL Read_Cleanup(); RETURN + END IF + ! ...Check Quiet argument + Noisy = .TRUE. + IF ( PRESENT(Quiet) ) Noisy = .NOT. Quiet + + ! Inquire the file to get the dimensions + err_stat = IRsnowCoeff_netCDF_InquireFile( & + Filename , & + n_Angles = n_Angles , & + n_Frequencies = n_Frequencies , & + n_Grain_Sizes = n_Grain_Sizes , & + n_Temperature = n_Temperature ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error obtaining IRsnowCoeff dimensions from '//TRIM(Filename) + CALL Read_Cleanup(); RETURN + END IF + + ! Allocate the output structure + CALL IRsnowCoeff_Create( & + IRsnowCoeff , & + n_Angles , & + n_Frequencies , & + n_Grain_Sizes , & + n_Temperature ) + IF ( .NOT. IRsnowCoeff_Associated( IRsnowCoeff ) ) THEN + msg = 'IRsnowCoeff object allocation failed.' + CALL Read_Cleanup(); RETURN + END IF + + ! Open the file for reading + NF90_Status = NF90_OPEN( Filename,NF90_NOWRITE,FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error opening '//TRIM(Filename)//' for read access - '//& + TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Read the global attributes + err_stat = ReadGAtts( Filename, & + FileID , & + Release = IRsnowCoeff%Release , & + Version = IRsnowCoeff%Version , & + Classification_Name = IRsnowCoeff%Classification_Name , & + Title = Title , & + History = History , & + Comment = Comment ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading global attribute from '//TRIM(Filename) + CALL Read_Cleanup(); RETURN + END IF + ! ...Check if release is valid + IF ( .NOT. IRsnowCoeff_ValidRelease( IRsnowCoeff ) ) THEN + msg = 'IRsnowCoeff Release check failed.' + CALL Read_Cleanup(); RETURN + END IF + + ! Read the IRsnowCoeff data + ! ...Angle variable + NF90_Status = NF90_INQ_VARID( FileId,ANGLE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//ANGLE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,IRsnowCoeff%Angle ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//ANGLE_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Frequency variable + NF90_Status = NF90_INQ_VARID( FileId,FREQUENCY_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//FREQUENCY_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,IRsnowCoeff%Frequency ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//FREQUENCY_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Grain Size variable + NF90_Status = NF90_INQ_VARID( FileId,GRAINSIZE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//GRAINSIZE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,IRsnowCoeff%Grain_Size ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//GRAINSIZE_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Temperature variable + NF90_Status = NF90_INQ_VARID( FileId,TEMPERATURE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//TEMPERATURE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,IRsnowCoeff%Temperature ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//TEMPERATURE_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Emissivity variable + NF90_Status = NF90_INQ_VARID( FileId,EMISSIVITY_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//EMISSIVITY_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,IRsnowCoeff%Emissivity ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//EMISSIVITY_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + + ! Close the file + NF90_Status = NF90_CLOSE( FileId ); Close_File = .FALSE. + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error closing output file - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + + ! Output an info message + IF ( Noisy ) THEN + CALL IRsnowCoeff_Info( IRsnowCoeff, msg ) + CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION ) + END IF + + CONTAINS + + SUBROUTINE Read_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing input file during error cleanup- '//& + TRIM(NF90_STRERROR( NF90_Status )) + END IF + CALL IRsnowCoeff_Destroy( IRsnowCoeff ) + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Read_CleanUp + + END FUNCTION IRsnowCoeff_netCDF_ReadFile + + +!################################################################################## +!################################################################################## +!## ## +!## ## PRIVATE MODULE ROUTINES ## ## +!## ## +!################################################################################## +!################################################################################## + + ! Function to write the global attributes to a IRsnowCoeff data file. + + FUNCTION WriteGAtts( & + Filename , & ! Input + FileId , & ! Input + Release , & ! Optional input + Version , & ! Optional input + Classification_Name , & ! Optional input + Title , & ! Optional input + History , & ! Optional input + Comment ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: Filename + INTEGER , INTENT(IN) :: FileId + INTEGER , OPTIONAL, INTENT(IN) :: Release + INTEGER , OPTIONAL, INTENT(IN) :: Version + CHARACTER(*), OPTIONAL, INTENT(IN) :: Classification_Name + CHARACTER(*), OPTIONAL, INTENT(IN) :: Title + CHARACTER(*), OPTIONAL, INTENT(IN) :: History + CHARACTER(*), OPTIONAL, INTENT(IN) :: Comment + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'IRsnowCoeff_WriteGAtts(netCDF)' + CHARACTER(*), PARAMETER :: WRITE_MODULE_HISTORY_GATTNAME = 'write_module_history' + CHARACTER(*), PARAMETER :: CREATION_DATE_AND_TIME_GATTNAME = 'creation_date_and_time' + ! Local variables + CHARACTER(ML) :: msg + CHARACTER(ML) :: GAttName + CHARACTER(8) :: cdate + CHARACTER(10) :: ctime + CHARACTER(5) :: czone + CHARACTER(ML) :: CLSname + INTEGER :: Ver + INTEGER :: NF90_Status + TYPE(IRsnowCoeff_type) :: IRsnowCoeff + + ! Set up + err_stat = SUCCESS + msg = ' ' + + ! Mandatory global attributes + ! ...Software ID + !GAttName = WRITE_MODULE_HISTORY_GATTNAME + !NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),MODULE_VERSION_ID ) + !IF ( NF90_Status /= NF90_NOERR ) THEN + ! CALL WriteGAtts_Cleanup(); RETURN + !END IF + ! ...Creation date + CALL DATE_AND_TIME( cdate, ctime, czone ) + GAttName = CREATION_DATE_AND_TIME_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName), & + cdate(1:4)//'/'//cdate(5:6)//'/'//cdate(7:8)//', '// & + ctime(1:2)//':'//ctime(3:4)//':'//ctime(5:6)//' '// & + czone//'UTC' ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + + ! Optional global attributes + ! ...The Release + IF ( PRESENT(Release) ) THEN + GAttName = RELEASE_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),IRsnowCoeff%Release ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + END IF + + ! ...The Version + IF ( PRESENT(Version) ) THEN + Ver = Version + ELSE + Ver = IRsnowCoeff%Version + END IF + GAttName = VERSION_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),Ver ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + ! ...The Classification_Name + IF ( PRESENT(Classification_Name) ) THEN + CLSname = Classification_Name + ELSE + CLSname = IRsnowCoeff%Classification_Name + END IF + GAttName = CLASSIFICATION_NAME_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),CLSname ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + ! ...The title + IF ( PRESENT(title) ) THEN + GAttName = TITLE_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),title ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The history + IF ( PRESENT(history) ) THEN + GAttName = HISTORY_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),history ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The comment + IF ( PRESENT(comment) ) THEN + GAttName = COMMENT_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),comment ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + END IF + + CONTAINS + + SUBROUTINE WriteGAtts_CleanUp() + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = '; Error closing input file during error cleanup - '//& + TRIM(NF90_STRERROR( NF90_Status ) ) + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME, & + 'Error writing '//TRIM(GAttName)//' attribute to '//& + TRIM(Filename)//' - '// & + TRIM(NF90_STRERROR( NF90_Status ) )//TRIM(msg), & + err_stat ) + END SUBROUTINE WriteGAtts_CleanUp + + END FUNCTION WriteGAtts + + ! Function to read the global attributes from a IRsnowCoeff data file. + + FUNCTION ReadGAtts( & + Filename , & ! Input + FileId , & ! Input + Release , & ! Optional output + Version , & ! Optional output + Classification_Name , & ! Optional output + Title , & ! Optional output + History , & ! Optional output + Comment ) & ! Optional output + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: Filename + INTEGER , INTENT(IN) :: FileId + INTEGER , OPTIONAL, INTENT(OUT) :: Release + INTEGER , OPTIONAL, INTENT(OUT) :: Version + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Classification_Name + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title + CHARACTER(*), OPTIONAL, INTENT(OUT) :: History + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Comment + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'IRsnowCoeff_ReadGAtts(netCDF)' + ! Local variables + CHARACTER(ML) :: msg + CHARACTER(256) :: GAttName + CHARACTER(5000) :: GAttString + INTEGER :: NF90_Status + + ! Set up + err_stat = SUCCESS + + ! The global attributes + ! ...The Release + IF ( PRESENT(Release) ) THEN + GAttName = RELEASE_GATTNAME + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),Release ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The Version + IF ( PRESENT(Version) ) THEN + GAttName = VERSION_GATTNAME + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),Version ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The Classification Name + IF ( PRESENT(Classification_Name) ) THEN + GAttName = CLASSIFICATION_NAME_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + Classification_Name = GAttString(1:MIN(LEN(Classification_Name), LEN_TRIM(GAttString))) + END IF + ! ...The title + IF ( PRESENT(title) ) THEN + GAttName = TITLE_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + title = GAttString(1:MIN(LEN(title), LEN_TRIM(GAttString))) + END IF + ! ...The history + IF ( PRESENT(history) ) THEN + GAttName = HISTORY_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + history = GAttString(1:MIN(LEN(history), LEN_TRIM(GAttString))) + END IF + ! ...The comment + IF ( PRESENT(comment) ) THEN + GAttName = COMMENT_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + comment = GAttString(1:MIN(LEN(comment), LEN_TRIM(GAttString))) + END IF + + CONTAINS + + SUBROUTINE ReadGAtts_CleanUp() + err_stat = FAILURE + msg = 'Error reading '//TRIM(GAttName)//' attribute from '//TRIM(Filename)//' - '// & + TRIM(NF90_STRERROR( NF90_Status ) ) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + END SUBROUTINE ReadGAtts_CleanUp + + END FUNCTION ReadGAtts + + FUNCTION CreateFile( & + Filename , & ! Input + n_Angles , & ! Input + n_Frequencies , & ! Input + n_Grain_Sizes , & ! Input + n_Temperature , & ! Input + FileId , & ! Output + Release , & ! Optional input + Version , & ! Optional input + Classification_Name , & ! Optional input + Title , & ! Optional input + History , & ! Optional input + Comment ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: Filename + INTEGER , INTENT(IN) :: n_Angles + INTEGER , INTENT(IN) :: n_Frequencies + INTEGER , INTENT(IN) :: n_Grain_Sizes + INTEGER , INTENT(IN) :: n_Temperature + INTEGER , INTENT(OUT) :: FileId + INTEGER , OPTIONAL, INTENT(IN) :: Release + INTEGER , OPTIONAL, INTENT(IN) :: Version + CHARACTER(*), OPTIONAL, INTENT(IN) :: Classification_Name + CHARACTER(*), OPTIONAL, INTENT(IN) :: Title + CHARACTER(*), OPTIONAL, INTENT(IN) :: History + CHARACTER(*), OPTIONAL, INTENT(IN) :: Comment + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'IRsnowCoeff_CreateFile(netCDF)' + ! Local variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + INTEGER :: NF90_Status + INTEGER :: n_Angles_DimID + INTEGER :: n_Frequencies_DimID + INTEGER :: n_Grain_Sizes_DimID + INTEGER :: n_Temperature_DimID + INTEGER :: varID + INTEGER :: Put_Status(4) + TYPE(IRsnowCoeff_type) :: dummy + + ! Setup + err_stat = SUCCESS + Close_File = .FALSE. + + ! Create the data file + NF90_Status = NF90_CREATE( Filename,NF90_CLOBBER,FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error creating '//TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Define the dimensions + ! ...Number of angles + NF90_Status = NF90_DEF_DIM( FileID,ANGLE_DIMNAME,n_Angles,n_Angles_DimID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//ANGLE_DIMNAME//' dimension in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + ! ...Number of frequencies + NF90_Status = NF90_DEF_DIM( FileID,FREQUENCY_DIMNAME,n_Frequencies,n_Frequencies_DimID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//FREQUENCY_DIMNAME//' dimension in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + ! ...Number of Grain Size + NF90_Status = NF90_DEF_DIM( FileID,GRAINSIZE_DIMNAME,n_Grain_Sizes,n_Grain_Sizes_DimID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//GRAINSIZE_DIMNAME//' dimension in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + ! ...Number of temperature + NF90_Status = NF90_DEF_DIM( FileID,TEMPERATURE_DIMNAME,n_Temperature,n_Temperature_DimID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//TEMPERATURE_DIMNAME//' dimension in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + CALL IRsnowCoeff_Destroy(dummy) + + ! Write the global attributes + err_stat = WriteGAtts( Filename, & + FileId , & + Release = Release , & + Version = Version , & + Classification_Name = Classification_Name , & + Title = Title , & + History = History , & + Comment = Comment ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error writing global attribute to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + + ! Define the variables + ! ...Angle variable + NF90_Status = NF90_DEF_VAR( FileID, & + ANGLE_VARNAME, & + ANGLE_TYPE, & + dimIDs=(/n_Angles_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//ANGLE_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,ANGLE_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,ANGLE_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,ANGLE_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,ANGLE_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//ANGLE_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + ! ...Frequency variable + NF90_Status = NF90_DEF_VAR( FileID, & + FREQUENCY_VARNAME, & + FREQUENCY_TYPE, & + dimIDs=(/n_Frequencies_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//FREQUENCY_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,FREQUENCY_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,FREQUENCY_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,FREQUENCY_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,FREQUENCY_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//FREQUENCY_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + ! ...Grain Size variable + NF90_Status = NF90_DEF_VAR( FileID, & + GRAINSIZE_VARNAME, & + GRAINSIZE_TYPE, & + dimIDs=(/n_Grain_Sizes_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//GRAINSIZE_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,GRAINSIZE_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,GRAINSIZE_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,GRAINSIZE_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,GRAINSIZE_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//GRAINSIZE_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + ! ...Temperature variable + NF90_Status = NF90_DEF_VAR( FileID, & + TEMPERATURE_VARNAME, & + TEMPERATURE_TYPE, & + dimIDs=(/n_Temperature_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//TEMPERATURE_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,TEMPERATURE_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,TEMPERATURE_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,TEMPERATURE_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,TEMPERATURE_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//TEMPERATURE_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + ! ...Emissivity variable + NF90_Status = NF90_DEF_VAR( FileID, & + EMISSIVITY_VARNAME, & + EMISSIVITY_TYPE, & + dimIDs=(/n_Angles_DimID, n_Frequencies_DimID, n_Grain_Sizes_DimID, n_Temperature_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//EMISSIVITY_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,EMISSIVITY_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,EMISSIVITY_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,EMISSIVITY_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,EMISSIVITY_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//EMISSIVITY_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + + ! Take netCDF file out of define mode + NF90_Status = NF90_ENDDEF( FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error taking file '//TRIM(Filename)// & + ' out of define mode - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + + CONTAINS + + SUBROUTINE Create_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileID ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing input file during error cleanup - '//& + TRIM(NF90_STRERROR( NF90_Status )) + END IF + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Create_CleanUp + + END FUNCTION CreateFile + + END MODULE IRsnowCoeff_netCDF_IO diff --git a/src/Coefficients/EmisCoeff/IR_Water/IRWaterCoeff_NC2BIN/IRWaterCoeff_NC2BIN.f90 b/src/Coefficients/EmisCoeff/IR_Water/IRWaterCoeff_NC2BIN/IRWaterCoeff_NC2BIN.f90 new file mode 100644 index 0000000..ef0aedd --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Water/IRWaterCoeff_NC2BIN/IRWaterCoeff_NC2BIN.f90 @@ -0,0 +1,74 @@ +! +! ! IRwaterCoeff_NC2BIN +! +! Program to convert a CRTM IRwaterCoeff data file +! from netCDF to Binary format +! +! +! CREATION HISTORY: +! +! Written by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu + +PROGRAM IRwaterCoeff_NC2BIN + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module usage + USE Message_Handler , ONLY: SUCCESS, FAILURE, Program_Message, Display_Message + USE SignalFile_Utility , ONLY: Create_SignalFile + USE IRwaterCoeff_Define , ONLY: IRwaterCoeff_type + USE IRwaterCoeff_IO , ONLY: IRwaterCoeff_netCDF_to_Binary + ! Disable implicit typing + IMPLICIT NONE + + ! ---------- + ! Parameters + ! ---------- + CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'IRwaterCoeff_NC2BIN' + + ! --------- + ! Variables + ! --------- + INTEGER :: err_stat + CHARACTER(256) :: NC_Filename, BIN_Filename + + ! Program header + CALL Program_Message( PROGRAM_NAME, & + 'Program to convert a CRTM IRwaterCoeff data file '//& + 'from netCDF to Binary format.', & + '$Revision$') + ! Get the filenames + WRITE(*,FMT='(/5x,"Enter the INPUT netCDF IRwaterCoeff filename : ")', ADVANCE='NO') + READ(*,'(a)') NC_Filename + NC_Filename = ADJUSTL(NC_Filename) + WRITE(*,FMT='(/5x,"Enter the OUTPUT Binary IRwaterCoeff filename: ")', ADVANCE='NO') + READ(*,'(a)') BIN_Filename + BIN_Filename = ADJUSTL(BIN_Filename) + ! ...Sanity check that they're not the same + IF ( BIN_Filename == NC_Filename ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'IRwaterCoeff netCDF and Binary filenames are the same!', & + FAILURE ) + STOP + END IF + + ! Perform the conversion + err_stat = IRwaterCoeff_netCDF_to_Binary( NC_Filename, BIN_Filename ) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'IRwaterCoeff netCDF -> Binary conversion failed!', & + FAILURE ) + STOP + END IF + + ! Create a signal file indicating success + err_stat = Create_SignalFile( BIN_Filename ) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'Error creating signal file for '//TRIM(BIN_Filename), & + FAILURE ) + END IF + +END PROGRAM IRwaterCoeff_NC2BIN diff --git a/src/Coefficients/EmisCoeff/IR_Water/IRWaterCoeff_NC2BIN/Makefile b/src/Coefficients/EmisCoeff/IR_Water/IRWaterCoeff_NC2BIN/Makefile new file mode 100644 index 0000000..5e612a8 --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Water/IRWaterCoeff_NC2BIN/Makefile @@ -0,0 +1,60 @@ +#============================================================================== +# +# Makefile for IRwaterCoeff_Inspect program +# +#============================================================================== + +# Define macros +include $(CRTM_SOURCE_ROOT)/make.macros + +# This makefile +MAKE_FILE = Makefile + +# Executable files +EXE_FILE = IRwaterCoeff_NC2BIN +SCRIPT_FILE = run_$(EXE_FILE).sh + +# Source files to link +SRC_FILES = Type_Kinds.f90 \ + File_Utility.f90 \ + Message_Handler.f90 \ + Compare_Float_Numbers.f90 \ + Binary_File_Utility.f90 \ + Endian_Utility.f90 \ + String_Utility.f90 \ + Fundamental_Constants.f90 \ + SignalFile_Utility.f90 \ + IRwaterCoeff_Define.f90 \ + IRwaterCoeff_IO.f90 \ + IRwaterCoeff_netCDF_IO.f90 + +# Obj files used in link phase +OBJ_FILES = ${SRC_FILES:.f90=.o} \ + $(EXE_FILE).o + +# Include and library definitions +INCLUDES = -I$(NC4_DIR)/include \ + -I$(HDF_DIR)/include +LIBRARIES = -L$(NC4_DIR)/lib -lnetcdf -lnetcdff \ + -L$(HDF_DIR)/lib -lhdf5 + +# Define common make targets (all, build, clean, install) +include $(CRTM_SOURCE_ROOT)/make.common_targets + +# Source link creation and removal +create_links:: + @$(LINK_SCRIPT) $(CRTM_SOURCE_ROOT) $(SRC_FILES) + +remove_links:: + @$(UNLINK_SCRIPT) $(SRC_FILES) + +# Script install target +install_script:: + @$(COPY) $(SCRIPT_FILE) ${HOME}/bin + +# Source dependency lists +include make.dependencies + +# Define default rules +include $(CRTM_SOURCE_ROOT)/make.rules + diff --git a/src/Coefficients/EmisCoeff/IR_Water/IRWaterCoeff_NC2BIN/make.dependencies b/src/Coefficients/EmisCoeff/IR_Water/IRWaterCoeff_NC2BIN/make.dependencies new file mode 100644 index 0000000..c90f74c --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Water/IRWaterCoeff_NC2BIN/make.dependencies @@ -0,0 +1,13 @@ +IRwaterCoeff_Define.o : IRwaterCoeff_Define.f90 Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o +IRwaterCoeff_netCDF_IO.o : IRwaterCoeff_netCDF_IO.f90 IRwaterCoeff_Define.o String_Utility.o File_Utility.o Message_Handler.o Type_Kinds.o +IRwaterCoeff_IO.o : IRwaterCoeff_IO.f90 IRwaterCoeff_netCDF_IO.o IRwaterCoeff_Define.o File_Utility.o Message_Handler.o Type_Kinds.o +IRwaterCoeff_NC2BIN.o : IRwaterCoeff_NC2BIN.f90 IRwaterCoeff_IO.o IRwaterCoeff_Define.o SignalFile_Utility.o Message_Handler.o +Binary_File_Utility.o : Binary_File_Utility.f90 Endian_Utility.o Message_Handler.o File_Utility.o Type_Kinds.o +Compare_Float_Numbers.o : Compare_Float_Numbers.f90 Type_Kinds.o +Endian_Utility.o : Endian_Utility.f90 Type_Kinds.o +File_Utility.o : File_Utility.f90 +Fundamental_Constants.o : Fundamental_Constants.f90 Type_Kinds.o +Message_Handler.o : Message_Handler.f90 File_Utility.o +SignalFile_Utility.o : SignalFile_Utility.f90 Message_Handler.o File_Utility.o +String_Utility.o : String_Utility.f90 +Type_Kinds.o : Type_Kinds.f90 diff --git a/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_BIN2NC/IRwaterCoeff_BIN2NC.f90 b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_BIN2NC/IRwaterCoeff_BIN2NC.f90 new file mode 100644 index 0000000..8a8ee0b --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_BIN2NC/IRwaterCoeff_BIN2NC.f90 @@ -0,0 +1,74 @@ +! +! IRwaterCoeff_BIN2NC +! +! Program to convert a CRTM IRwaterCoeff data file +! from netCDF to Binary format +! +! +! CREATION HISTORY: +! +! Written by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu + +PROGRAM IRwaterCoeff_BIN2NC + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module usage + USE Message_Handler , ONLY: SUCCESS, FAILURE, Program_Message, Display_Message + USE SignalFile_Utility , ONLY: Create_SignalFile + USE IRwaterCoeff_Define , ONLY: IRwaterCoeff_type + USE IRwaterCoeff_IO , ONLY: IRwaterCoeff_Binary_to_netCDF + ! Disable implicit typing + IMPLICIT NONE + + ! ---------- + ! Parameters + ! ---------- + CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'IRwaterCoeff_BIN2NC' + + ! --------- + ! Variables + ! --------- + INTEGER :: err_stat + CHARACTER(256) :: NC_Filename, BIN_Filename + + ! Program header + CALL Program_Message( PROGRAM_NAME, & + 'Program to convert a CRTM IRwaterCoeff data file '//& + 'from Binary to netCDF format.', & + '$Revision$') + ! Get the filenames + WRITE(*,FMT='(/5x,"Enter the INPUT Binary IRwaterCoeff filename : ")', ADVANCE='NO') + READ(*,'(a)') BIN_Filename + BIN_Filename = ADJUSTL(BIN_Filename) + WRITE(*,FMT='(/5x,"Enter the OUTPUT netCDF IRwaterCoeff filename: ")', ADVANCE='NO') + READ(*,'(a)') NC_Filename + NC_Filename = ADJUSTL(NC_Filename) + ! ...Sanity check that they're not the same + IF ( BIN_Filename == NC_Filename ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'IRwaterCoeff netCDF and Binary filenames are the same!', & + FAILURE ) + STOP + END IF + + ! Perform the conversion + err_stat = IRwaterCoeff_Binary_to_netCDF( BIN_Filename, NC_Filename ) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'IRwaterCoeff Binary -> netCDF conversion failed!', & + FAILURE ) + STOP + END IF + + ! Create a signal file indicating success + err_stat = Create_SignalFile( NC_Filename ) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'Error creating signal file for '//TRIM(NC_Filename), & + FAILURE ) + END IF + + END PROGRAM IRwaterCoeff_BIN2NC diff --git a/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_BIN2NC/Makefile b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_BIN2NC/Makefile new file mode 100644 index 0000000..4cee2de --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_BIN2NC/Makefile @@ -0,0 +1,60 @@ +#============================================================================== +# +# Makefile for IRwaterCoeff_Inspect program +# +#============================================================================== + +# Define macros +include $(CRTM_SOURCE_ROOT)/make.macros + +# This makefile +MAKE_FILE = Makefile + +# Executable files +EXE_FILE = IRwaterCoeff_BIN2NC +SCRIPT_FILE = run_$(EXE_FILE).sh + +# Source files to link +SRC_FILES = Type_Kinds.f90 \ + File_Utility.f90 \ + Message_Handler.f90 \ + Compare_Float_Numbers.f90 \ + Binary_File_Utility.f90 \ + Endian_Utility.f90 \ + String_Utility.f90 \ + Fundamental_Constants.f90 \ + SignalFile_Utility.f90 \ + IRwaterCoeff_Define.f90 \ + IRwaterCoeff_IO.f90 \ + IRwaterCoeff_netCDF_IO.f90 + +# Obj files used in link phase +OBJ_FILES = ${SRC_FILES:.f90=.o} \ + $(EXE_FILE).o + +# Include and library definitions +INCLUDES = -I$(NC4_DIR)/include \ + -I$(HDF_DIR)/include +LIBRARIES = -L$(NC4_DIR)/lib -lnetcdf -lnetcdff \ + -L$(HDF_DIR)/lib -lhdf5 + +# Define common make targets (all, build, clean, install) +include $(CRTM_SOURCE_ROOT)/make.common_targets + +# Source link creation and removal +create_links:: + @$(LINK_SCRIPT) $(CRTM_SOURCE_ROOT) $(SRC_FILES) + +remove_links:: + @$(UNLINK_SCRIPT) $(SRC_FILES) + +# Script install target +install_script:: + @$(COPY) $(SCRIPT_FILE) ${HOME}/bin + +# Source dependency lists +include make.dependencies + +# Define default rules +include $(CRTM_SOURCE_ROOT)/make.rules + diff --git a/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_BIN2NC/make.dependencies b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_BIN2NC/make.dependencies new file mode 100644 index 0000000..2a49358 --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_BIN2NC/make.dependencies @@ -0,0 +1,13 @@ +IRwaterCoeff_Define.o : IRwaterCoeff_Define.f90 Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o +IRwaterCoeff_netCDF_IO.o : IRwaterCoeff_netCDF_IO.f90 IRwaterCoeff_Define.o String_Utility.o File_Utility.o Message_Handler.o Type_Kinds.o +IRwaterCoeff_IO.o : IRwaterCoeff_IO.f90 IRwaterCoeff_netCDF_IO.o IRwaterCoeff_Define.o File_Utility.o Message_Handler.o Type_Kinds.o +IRwaterCoeff_BIN2NC.o : IRwaterCoeff_BIN2NC.f90 IRwaterCoeff_IO.o IRwaterCoeff_Define.o SignalFile_Utility.o Message_Handler.o +Binary_File_Utility.o : Binary_File_Utility.f90 Endian_Utility.o Message_Handler.o File_Utility.o Type_Kinds.o +Compare_Float_Numbers.o : Compare_Float_Numbers.f90 Type_Kinds.o +Endian_Utility.o : Endian_Utility.f90 Type_Kinds.o +File_Utility.o : File_Utility.f90 +Fundamental_Constants.o : Fundamental_Constants.f90 Type_Kinds.o +Message_Handler.o : Message_Handler.f90 File_Utility.o +SignalFile_Utility.o : SignalFile_Utility.f90 Message_Handler.o File_Utility.o +String_Utility.o : String_Utility.f90 +Type_Kinds.o : Type_Kinds.f90 diff --git a/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_Define.f90 b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_Define.f90 index 715dc46..84577e3 100644 --- a/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_Define.f90 +++ b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_Define.f90 @@ -8,7 +8,10 @@ ! CREATION HISTORY: ! Written by: Paul van Delst, 19-Aug-2011 ! paul.vandelst@noaa.gov - +! Modified by: Cheng Dang, 18-Mar-2022 +! dangch@ucar.edu +! Add temperature dimension + MODULE IRwaterCoeff_Define ! ----------------- @@ -59,7 +62,7 @@ MODULE IRwaterCoeff_Define ! Module parameters ! ----------------- ! Current valid release and version - INTEGER, PARAMETER :: IRWATERCOEFF_RELEASE = 3 ! This determines structure and file formats. + INTEGER, PARAMETER :: IRWATERCOEFF_RELEASE = 4 ! This determines structure and file formats. INTEGER, PARAMETER :: IRWATERCOEFF_VERSION = 2 ! This is just the default data version. ! Close status for write errors CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE' @@ -71,6 +74,7 @@ MODULE IRwaterCoeff_Define REAL(fp), PARAMETER :: DEGREES_TO_RADIANS = PI / 180.0_fp ! String lengths INTEGER, PARAMETER :: ML = 256 ! Message length + INTEGER, PARAMETER :: SL = 80 ! String length ! ---------------------------------- @@ -83,16 +87,20 @@ MODULE IRwaterCoeff_Define ! Release and version information INTEGER(Long) :: Release = IRWATERCOEFF_RELEASE INTEGER(Long) :: Version = IRWATERCOEFF_VERSION + ! Surface classification name + CHARACTER(SL) :: Classification_Name = '' ! Dimensions INTEGER(Long) :: n_Angles = 0 ! I dimension INTEGER(Long) :: n_Frequencies = 0 ! L dimension INTEGER(Long) :: n_Wind_Speeds = 0 ! N dimension + INTEGER(Long) :: n_Temperature = 0 ! T dimension ! Dimensional vectors - REAL(Double), ALLOCATABLE :: Angle(:) ! I - REAL(Double), ALLOCATABLE :: Frequency(:) ! L - REAL(Double), ALLOCATABLE :: Wind_Speed(:) ! N + REAL(Double), ALLOCATABLE :: Angle(:) ! I + REAL(Double), ALLOCATABLE :: Frequency(:) ! L + REAL(Double), ALLOCATABLE :: Wind_Speed(:) ! N + REAL(Double), ALLOCATABLE :: Temperature(:) ! T ! Emissivity LUT data - REAL(Double), ALLOCATABLE :: Emissivity(:,:,:) ! I x L x N + REAL(Double), ALLOCATABLE :: Emissivity(:,:,:,:) ! I x L x N x T ! Transformed dimensional vectors REAL(Double), ALLOCATABLE :: Secant_Angle(:) ! I END TYPE IRwaterCoeff_type @@ -151,7 +159,7 @@ ELEMENTAL FUNCTION IRwaterCoeff_Associated( self ) RESULT( Status ) Status = self%Is_Allocated END FUNCTION IRwaterCoeff_Associated - + !-------------------------------------------------------------------------------- !:sdoc+: ! @@ -193,7 +201,8 @@ END SUBROUTINE IRwaterCoeff_Destroy ! CALL IRwaterCoeff_Create( IRwaterCoeff , & ! n_Angles , & ! n_Frequencies, & -! n_Wind_Speeds ) +! n_Wind_Speeds, & +! n_Temperature ) ! ! OBJECTS: ! IRwaterCoeff: IRwaterCoeff object structure. @@ -224,6 +233,12 @@ END SUBROUTINE IRwaterCoeff_Destroy ! DIMENSION: Conformable with the IRwaterCoeff object ! ATTRIBUTES: INTENT(IN) ! +! n_Temperature: Number oftemperature dimension. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Conformable with the IRwaterCoeff object +! ATTRIBUTES: INTENT(IN) !:sdoc-: !-------------------------------------------------------------------------------- @@ -231,26 +246,29 @@ ELEMENTAL SUBROUTINE IRwaterCoeff_Create( & self , & ! Output n_Angles , & ! Input n_Frequencies, & ! Input - n_Wind_Speeds ) ! Input + n_Wind_Speeds, & ! Input + n_Temperature ) ! Input ! Arguments TYPE(IRwaterCoeff_type), INTENT(OUT) :: self - INTEGER , INTENT(IN) :: n_Angles - INTEGER , INTENT(IN) :: n_Frequencies - INTEGER , INTENT(IN) :: n_Wind_Speeds + INTEGER , INTENT(IN) :: n_Angles + INTEGER , INTENT(IN) :: n_Frequencies + INTEGER , INTENT(IN) :: n_Wind_Speeds + INTEGER , INTENT(IN) :: n_Temperature ! Local variables INTEGER :: alloc_stat ! Check input IF ( n_Angles < 1 .OR. & n_Frequencies < 1 .OR. & - n_Wind_Speeds < 1 ) RETURN + n_Wind_Speeds < 1 .OR. & + n_Temperature < 1) RETURN - ! Perform the allocation ALLOCATE( self%Angle( n_Angles ), & self%Frequency( n_Frequencies ), & self%Wind_Speed( n_Wind_Speeds ), & - self%Emissivity( n_Angles, n_Frequencies, n_Wind_Speeds ), & + self%Temperature( n_Temperature ), & + self%Emissivity( n_Angles, n_Frequencies, n_Wind_Speeds, n_Temperature), & self%Secant_Angle( n_Angles ), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN @@ -258,13 +276,15 @@ ELEMENTAL SUBROUTINE IRwaterCoeff_Create( & ! Initialise ! ...Dimensions - self%n_Angles = n_Angles + self%n_Angles = n_Angles self%n_Frequencies = n_Frequencies self%n_Wind_Speeds = n_Wind_Speeds + self%n_Temperature = n_Temperature ! ...Arrays self%Angle = ZERO self%Frequency = ZERO self%Wind_Speed = ZERO + self%Temperature = ZERO self%Emissivity = ZERO self%Secant_Angle = ZERO @@ -298,29 +318,37 @@ END SUBROUTINE IRwaterCoeff_Create SUBROUTINE IRwaterCoeff_Inspect( self ) TYPE(IRwaterCoeff_type), INTENT(IN) :: self - INTEGER :: i2, i3 + INTEGER :: i2, i3, i4 WRITE(*,'(1x,"IRwaterCoeff OBJECT")') ! Release/version info WRITE(*,'(3x,"Release.Version :",1x,i0,".",i0)') self%Release, self%Version + ! Surface classification name + WRITE(*,'(3x,"Classification_Name :",1x,a)') TRIM(self%Classification_Name) ! Dimensions - WRITE(*,'(3x,"n_Angles :",1x,i0)') self%n_Angles + WRITE(*,'(3x,"n_Angles :",1x,i0)') self%n_Angles WRITE(*,'(3x,"n_Frequencies :",1x,i0)') self%n_Frequencies WRITE(*,'(3x,"n_Wind_Speeds :",1x,i0)') self%n_Wind_Speeds + WRITE(*,'(3x,"n_Temperature :",1x,i0)') self%n_Temperature IF ( .NOT. IRwaterCoeff_Associated(self) ) RETURN ! Dimension arrays WRITE(*,'(3x,"Angle :")') - WRITE(*,'(5(1x,es22.15,:))') self%Angle + WRITE(*,'(5(1x,es22.15,:))') self%Angle WRITE(*,'(3x,"Frequency :")') - WRITE(*,'(5(1x,es22.15,:))') self%Frequency + WRITE(*,'(5(1x,es22.15,:))') self%Frequency WRITE(*,'(3x,"Wind_Speed :")') WRITE(*,'(5(1x,es22.15,:))') self%Wind_Speed + WRITE(*,'(3x,"Temperature :")') + WRITE(*,'(5(1x,es22.15,:))') self%Temperature ! Emissivity array WRITE(*,'(3x,"Emissivity :")') - DO i3 = 1, self%n_Wind_Speeds - WRITE(*,'(5x,"WIND_SPEED :",es22.15)') self%Wind_Speed(i3) - DO i2 = 1, self%n_Frequencies - WRITE(*,'(5x,"FREQUENCY :",es22.15)') self%Frequency(i2) - WRITE(*,'(5(1x,es22.15,:))') self%Emissivity(:,i2,i3) + DO i4 = 1, self%n_Temperature + WRITE(*,'(5x,"TEMPERATURE :",es22.15)') self%Temperature(i4) + DO i3 = 1, self%n_Wind_Speeds + WRITE(*,'(5x,"WIND_SPEED :",es22.15)') self%Wind_Speed(i3) + DO i2 = 1, self%n_Frequencies + WRITE(*,'(5x,"FREQUENCY :",es22.15)') self%Frequency(i2) + WRITE(*,'(5(1x,es22.15,:))') self%Emissivity(:,i2,i3,i4) + END DO END DO END DO END SUBROUTINE IRwaterCoeff_Inspect @@ -435,23 +463,28 @@ SUBROUTINE IRwaterCoeff_Info( self, Info ) ! Write the required data to the local string WRITE( Long_String, & - '( a,1x,"IRwaterCoeff RELEASE.VERSION: ", i2, ".", i2.2, 2x, & + '( a,1x,"IRwaterCoeff RELEASE.VERSION: ", i2, ".", i2.2,a,3x, & + &"CLASSIFICATION: ",a,",",2x,& &"N_ANGLES=",i3,2x,& &"N_FREQUENCIES=",i5,2x,& - &"N_WIND_SPEEDS=",i3 )' ) & + &"N_WIND_SPEEDS=",i3,2x,& + &"N_TEMPERATURE=",i3 )' ) & ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), & self%Release, self%Version, & + ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), & + TRIM(self%Classification_Name), & self%n_Angles, & self%n_Frequencies, & - self%n_Wind_Speeds - + self%n_Wind_Speeds, & + self%n_Temperature + ! Trim the output based on the ! dummy argument string length Info = Long_String(1:MIN(LEN(Info), LEN_TRIM(Long_String))) END SUBROUTINE IRwaterCoeff_Info - - + + !------------------------------------------------------------------------------ !:sdoc+: ! @@ -467,6 +500,7 @@ END SUBROUTINE IRwaterCoeff_Info ! n_Angles = n_Angles , & ! n_Frequencies = n_Frequencies, & ! n_Wind_Speeds = n_Wind_Speeds, & +! n_Temperature = n_Temperature, & ! Release = Release , & ! Version = Version , & ! Title = Title , & @@ -503,6 +537,13 @@ END SUBROUTINE IRwaterCoeff_Info ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT), OPTIONAL ! +! n_Temperature: Number of temperature for which there are +! emissivity data. +! 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 @@ -557,6 +598,7 @@ FUNCTION IRwaterCoeff_InquireFile( & n_Angles , & ! Optional output n_Frequencies, & ! Optional output n_Wind_Speeds, & ! Optional output + n_Temperature, & ! Optional output Release , & ! Optional output Version , & ! Optional output Title , & ! Optional output @@ -565,14 +607,15 @@ FUNCTION IRwaterCoeff_InquireFile( & RESULT( err_stat ) ! Arguments CHARACTER(*), INTENT(IN) :: Filename - INTEGER , OPTIONAL, INTENT(OUT) :: n_Angles + INTEGER , OPTIONAL, INTENT(OUT) :: n_Angles INTEGER , OPTIONAL, INTENT(OUT) :: n_Frequencies INTEGER , OPTIONAL, INTENT(OUT) :: n_Wind_Speeds + INTEGER , OPTIONAL, INTENT(OUT) :: n_Temperature 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 + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title + CHARACTER(*), OPTIONAL, INTENT(OUT) :: History + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Comment ! Function result INTEGER :: err_stat ! Function parameters @@ -584,7 +627,7 @@ FUNCTION IRwaterCoeff_InquireFile( & INTEGER :: fid TYPE(IRwaterCoeff_type) :: IRwaterCoeff - + ! Setup err_stat = SUCCESS ! ...Check that the file exists @@ -616,7 +659,8 @@ FUNCTION IRwaterCoeff_InquireFile( & READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & IRwaterCoeff%n_Angles , & IRwaterCoeff%n_Frequencies, & - IRwaterCoeff%n_Wind_Speeds + IRwaterCoeff%n_Wind_Speeds, & + IRwaterCoeff%n_Temperature IF ( io_stat /= 0 ) THEN msg = 'Error reading dimension values from '//TRIM(Filename)//' - '//TRIM(io_msg) CALL Inquire_Cleanup(); RETURN @@ -644,14 +688,15 @@ FUNCTION IRwaterCoeff_InquireFile( & ! Assign the return arguments - IF ( PRESENT(n_Angles ) ) n_Angles = IRwaterCoeff%n_Angles + IF ( PRESENT(n_Angles ) ) n_Angles = IRwaterCoeff%n_Angles IF ( PRESENT(n_Frequencies) ) n_Frequencies = IRwaterCoeff%n_Frequencies - IF ( PRESENT(n_Wind_Speeds) ) n_Wind_Speeds = IRwaterCoeff%n_Wind_Speeds + IF ( PRESENT(n_Wind_Speeds) ) n_Wind_Speeds = IRwaterCoeff%n_Wind_Speeds + IF ( PRESENT(n_Temperature) ) n_Temperature = IRwaterCoeff%n_Temperature IF ( PRESENT(Release ) ) Release = IRwaterCoeff%Release IF ( PRESENT(Version ) ) Version = IRwaterCoeff%Version - + CONTAINS - + SUBROUTINE Inquire_CleanUp() ! Close file if necessary IF ( File_Open(fid) ) THEN @@ -663,7 +708,7 @@ SUBROUTINE Inquire_CleanUp() err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END SUBROUTINE Inquire_CleanUp - + END FUNCTION IRwaterCoeff_InquireFile @@ -788,7 +833,7 @@ FUNCTION IRwaterCoeff_ReadFile( & INTEGER :: io_stat INTEGER :: fid TYPE(IRwaterCoeff_type) :: dummy - + ! Setup err_stat = SUCCESS @@ -803,7 +848,7 @@ FUNCTION IRwaterCoeff_ReadFile( & IF ( Debug ) noisy = .TRUE. END IF - + ! Check if the file is open. IF ( File_Open( Filename ) ) THEN ! ...Inquire for the logical unit number @@ -846,7 +891,8 @@ FUNCTION IRwaterCoeff_ReadFile( & READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & dummy%n_Angles , & dummy%n_Frequencies, & - dummy%n_Wind_Speeds + dummy%n_Wind_Speeds, & + dummy%n_Temperature IF ( io_stat /= 0 ) THEN msg = 'Error reading dimension values from '//TRIM(Filename)//' - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN @@ -854,17 +900,18 @@ FUNCTION IRwaterCoeff_ReadFile( & ! ...Create the return object CALL IRwaterCoeff_Create( & IRwaterCoeff , & - dummy%n_Angles , & - dummy%n_Frequencies, & - dummy%n_Wind_Speeds ) + dummy%n_Angles , & + dummy%n_Frequencies, & + dummy%n_Wind_Speeds, & + dummy%n_Temperature ) IF ( .NOT. IRwaterCoeff_Associated( IRwaterCoeff ) ) THEN msg = 'IRwaterCoeff object creation failed.' CALL Read_Cleanup(); RETURN END IF ! ...Explicitly assign the version number IRwaterCoeff%Version = dummy%Version - - + + ! Read the global attributes err_stat = ReadGAtts_Binary_File( & fid, & @@ -876,13 +923,21 @@ FUNCTION IRwaterCoeff_ReadFile( & CALL Read_Cleanup(); RETURN END IF + ! ...Read the classification name + READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & + IRwaterCoeff%Classification_Name + IF ( io_stat /= 0 ) THEN + msg = 'Error reading classification name - '//TRIM(io_msg) + CALL Read_Cleanup(); RETURN + END IF ! Read the coefficient data ! ...Read the dimensional vectors READ( fid, IOSTAT=io_stat, IOMSG=io_msg ) & - IRwaterCoeff%Angle , & - IRwaterCoeff%Frequency , & - IRwaterCoeff%Wind_Speed + IRwaterCoeff%Angle , & + IRwaterCoeff%Frequency , & + IRwaterCoeff%Wind_Speed , & + IRwaterCoeff%Temperature IF ( io_stat /= 0 ) THEN msg = 'Error reading dimensional vectors - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN @@ -914,7 +969,7 @@ FUNCTION IRwaterCoeff_ReadFile( & END IF CONTAINS - + SUBROUTINE Read_CleanUp() IF ( File_Open(Filename) ) THEN CLOSE( fid, IOSTAT=io_stat, IOMSG=io_msg ) @@ -1048,7 +1103,7 @@ FUNCTION IRwaterCoeff_WriteFile( & LOGICAL :: noisy INTEGER :: io_stat INTEGER :: fid - + ! Setup err_stat = SUCCESS @@ -1068,7 +1123,7 @@ FUNCTION IRwaterCoeff_WriteFile( & CALL Write_Cleanup(); RETURN END IF - + ! Check if the file is open. IF ( File_Open( FileName ) ) THEN ! ...Inquire for the logical unit number @@ -1102,7 +1157,8 @@ FUNCTION IRwaterCoeff_WriteFile( & WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & IRwaterCoeff%n_Angles , & IRwaterCoeff%n_Frequencies, & - IRwaterCoeff%n_Wind_Speeds + IRwaterCoeff%n_Wind_Speeds, & + IRwaterCoeff%n_Temperature IF ( io_stat /= 0 ) THEN msg = 'Error writing dimension values to '//TRIM(Filename)//' - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN @@ -1121,13 +1177,21 @@ FUNCTION IRwaterCoeff_WriteFile( & CALL Write_Cleanup(); RETURN END IF + ! Write the surface classification name + WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & + IRwaterCoeff%Classification_Name + IF ( io_stat /= 0 ) THEN + msg = 'Error writing classification name - '//TRIM(io_msg) + CALL Write_Cleanup(); RETURN + END IF ! Write the coefficient data ! ...Write the dimensional vectors WRITE( fid, IOSTAT=io_stat, IOMSG=io_msg ) & IRwaterCoeff%Angle , & IRwaterCoeff%Frequency , & - IRwaterCoeff%Wind_Speed + IRwaterCoeff%Wind_Speed , & + IRwaterCoeff%Temperature IF ( io_stat /= 0 ) THEN msg = 'Error writing dimensional vectors - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN @@ -1140,7 +1204,7 @@ FUNCTION IRwaterCoeff_WriteFile( & CALL Write_Cleanup(); RETURN END IF - + ! Close the file IF ( close_file ) THEN CLOSE( fid, IOSTAT=io_stat, IOMSG=io_msg ) @@ -1158,7 +1222,7 @@ FUNCTION IRwaterCoeff_WriteFile( & END IF CONTAINS - + SUBROUTINE Write_CleanUp() IF ( File_Open(Filename) ) THEN CLOSE( fid, STATUS=WRITE_ERROR_STATUS, IOSTAT=io_stat, IOMSG=io_msg ) @@ -1219,7 +1283,7 @@ ELEMENTAL FUNCTION IRwaterCoeff_Equal( x, y ) RESULT( is_equal ) ! Set up is_equal = .FALSE. - + ! Check the object association status IF ( (.NOT. IRwaterCoeff_Associated(x)) .OR. & (.NOT. IRwaterCoeff_Associated(y)) ) RETURN @@ -1229,17 +1293,21 @@ ELEMENTAL FUNCTION IRwaterCoeff_Equal( x, y ) RESULT( is_equal ) ! ...Release/version info IF ( (x%Release /= y%Release) .OR. & (x%Version /= y%Version) ) RETURN + ! ...Classification name + IF ( (x%Classification_Name /= y%Classification_Name) ) RETURN ! ...Dimensions IF ( (x%n_Angles /= y%n_Angles ) .OR. & (x%n_Frequencies /= y%n_Frequencies ) .OR. & - (x%n_Wind_Speeds /= y%n_Wind_Speeds ) ) RETURN + (x%n_Wind_Speeds /= y%n_Wind_Speeds ) .OR. & + (x%n_Temperature /= y%n_Temperature ) ) RETURN ! ...Arrays - IF ( ALL(x%Angle .EqualTo. y%Angle ) .AND. & - ALL(x%Frequency .EqualTo. y%Frequency ) .AND. & - ALL(x%Wind_Speed .EqualTo. y%Wind_Speed ) .AND. & - ALL(x%Emissivity .EqualTo. y%Emissivity ) ) & + IF ( ALL(x%Angle .EqualTo. y%Angle ) .AND. & + ALL(x%Frequency .EqualTo. y%Frequency ) .AND. & + ALL(x%Wind_Speed .EqualTo. y%Wind_Speed ) .AND. & + ALL(x%Temperature .EqualTo. y%Temperature ) .AND. & + ALL(x%Emissivity .EqualTo. y%Emissivity ) ) & is_equal = .TRUE. - + END FUNCTION IRwaterCoeff_Equal END MODULE IRwaterCoeff_Define diff --git a/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_IO.f90 b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_IO.f90 new file mode 100644 index 0000000..55c8dfe --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_IO.f90 @@ -0,0 +1,766 @@ +! +! IRwaterCoeff_IO +! +! Container module for Binary and netCDF IRwaterCoeff I/O modules. +! +! +! CREATION HISTORY: +! +! Written by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu +! Modified by: Cheng Dang, 18-Mar-2022 +! dangch@ucar.edu +! Add temperature dimension +! + +MODULE IRwaterCoeff_IO + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module use + USE Type_Kinds , ONLY: fp + USE Message_Handler , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message + USE File_Utility , ONLY: File_Exists + USE IRwaterCoeff_Define , ONLY: IRwaterCoeff_type, & + OPERATOR(==), & + IRwaterCoeff_InquireFile , & + IRwaterCoeff_ReadFile , & + IRwaterCoeff_WriteFile + USE IRwaterCoeff_netCDF_IO , ONLY: IRwaterCoeff_netCDF_InquireFile , & + IRwaterCoeff_netCDF_ReadFile , & + IRwaterCoeff_netCDF_WriteFile + ! Disable implicit typing + IMPLICIT NONE + + ! ------------ + ! Visibilities + ! ------------ + PRIVATE + PUBLIC :: IRwaterCoeff_InquireFile_IO + PUBLIC :: IRwaterCoeff_ReadFile_IO + PUBLIC :: IRwaterCoeff_WriteFile_IO + PUBLIC :: IRwaterCoeff_netCDF_to_Binary + PUBLIC :: IRwaterCoeff_Binary_to_netCDF + + CONTAINS + +!################################################################################ +!################################################################################ +!## ## +!## ## PUBLIC MODULE ROUTINES ## ## +!## ## +!################################################################################ +!################################################################################ +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRwaterCoeff_InquireFile_IO +! +! PURPOSE: +! Function to inquire IRwaterCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRwaterCoeff_InquireFile_IO( & +! Filename, & +! netCDF = netCDF , & +! n_Angles = n_Angles , & +! n_Frequencies = n_Frequencies , & +! n_Wind_Speeds = n_Wind_Speeds , & +! n_Temperature = n_Temperature , & +! Release = Release , & +! Version = Version , & +! Title = Title , & +! History = History , & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! IRwaterCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! netCDF: Set this logical argument to access netCDF format +! IRwaterCoeff datafiles. +! If == .FALSE., file format is BINARY [DEFAULT]. +! == .TRUE., file format is NETCDF. +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! OPTIONAL OUTPUTS: +! n_Angles: The number of angles in the look-up +! table (LUT). Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Frequencies: The number of frequencies in the LUT. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Wind_Speeds: The number of wind speeds in +! the LUT. Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! n_Temperature: The number of temperature in +! the LUT. Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Release: The release number of the IRwaterCoeff file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Version: The version number of the IRwaterCoeff file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Title: Character string written into the TITLE global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 IRwaterCoeff_InquireFile_IO( & + Filename , & ! Input + netCDF , & ! Optional input + n_Angles , & ! Optional output + n_Frequencies , & ! Optional output + n_Wind_Speeds , & ! Optional output + n_Temperature , & ! 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_Angles + INTEGER , OPTIONAL, INTENT(OUT) :: n_Frequencies + INTEGER , OPTIONAL, INTENT(OUT) :: n_Wind_Speeds + INTEGER , OPTIONAL, INTENT(OUT) :: n_Temperature + LOGICAL , OPTIONAL, INTENT(IN) :: netCDF + 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 variables + LOGICAL :: Binary + + ! Set up + err_stat = SUCCESS + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + + ! Call the appropriate function + IF ( Binary ) THEN + err_stat = IRwaterCoeff_InquireFile( & + Filename , & + n_Angles = n_Angles , & + n_Frequencies = n_Frequencies , & + n_Wind_Speeds = n_Wind_Speeds , & + n_Temperature = n_Temperature , & + Release = Release , & + Version = Version ) + ELSE + err_stat = IRwaterCoeff_netCDF_InquireFile( & + Filename , & + n_Angles = n_Angles , & + n_Frequencies = n_Frequencies , & + n_Wind_Speeds = n_Wind_Speeds , & + n_Temperature = n_Temperature , & + Release = Release , & + Version = Version , & + Title = Title , & + History = History , & + Comment = Comment ) + END IF + + END FUNCTION IRwaterCoeff_InquireFile_IO + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRwaterCoeff_ReadFile_IO +! +! PURPOSE: +! Function to read IRwaterCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRwaterCoeff_ReadFile_IO( & +! IRwaterCoeff, & +! Filename, & +! netCDF = netCDF , & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! IRwaterCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! IRwaterCoeff: Object containing the IRwater coefficient data. +! UNITS: N/A +! TYPE: TYPE(IRwaterCoeff_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! OPTIONAL INPUTS: +! netCDF: Set this logical argument to access netCDF format +! IRwaterCoeff datafiles. +! If == .FALSE., file format is BINARY [DEFAULT]. +! == .TRUE., file format is NETCDF. +! 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 +! +! OPTIONAL OUTPUTS: +! Title: Character string written into the TITLE global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 IRwaterCoeff_ReadFile_IO( & + IRwaterCoeff, & ! Output + Filename , & ! Input + netCDF , & ! Optional 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(IRwaterCoeff_type), INTENT(OUT) :: IRwaterCoeff + CHARACTER(*), INTENT(IN) :: Filename + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + 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 variables + LOGICAL :: Binary + + ! Set up + err_stat = SUCCESS + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + !Call the appropriate function + IF ( Binary ) THEN + err_stat = IRwaterCoeff_ReadFile( & + IRwaterCoeff, & + Filename , & + No_Close , & + Quiet ) + ELSE + err_stat = IRwaterCoeff_netCDF_ReadFile( & + IRwaterCoeff, & + Filename , & + Quiet , & + Title , & + History , & + Comment , & + Debug ) + END IF + + END FUNCTION IRwaterCoeff_ReadFile_IO + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRwaterCoeff_WriteFile_IO +! +! PURPOSE: +! Function to write IRwaterCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRwaterCoeff_WriteFile_IO( & +! IRwaterCoeff, & +! Filename, & +! netCDF = netCDF , & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of the +! IRwaterCoeff data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! IRwaterCoeff: Object containing the IRwater coefficient data. +! UNITS: N/A +! TYPE: TYPE(IRwaterCoeff_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! netCDF: Set this logical argument to access netCDF format +! IRwaterCoeff datafiles. +! If == .FALSE., file format is BINARY [DEFAULT]. +! == .TRUE., file format is NETCDF. +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! No_Close: Set this logical argument to *NOT* close the datafile +! upon exiting this routine. This option is required if +! the IRwaterCoeff 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 +! +! Title: Character string written into the TITLE global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 data write was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!------------------------------------------------------------------------------ + + FUNCTION IRwaterCoeff_WriteFile_IO( & + IRwaterCoeff, & ! Input + Filename , & ! Input + netCDF , & ! Optional 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(IRwaterCoeff_type), INTENT(IN) :: IRwaterCoeff + CHARACTER(*), INTENT(IN) :: Filename + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + 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 + ! Local variables + LOGICAL :: Binary + + ! Set up + err_stat = SUCCESS + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + ! Call the appropriate function + IF ( Binary ) THEN + err_stat = IRwaterCoeff_WriteFile( & + IRwaterCoeff, & + Filename , & + No_Close , & + Quiet , & + Title , & + History , & + Comment , & + Debug ) + ELSE + err_stat = IRwaterCoeff_netCDF_WriteFile( & + IRwaterCoeff, & + Filename , & + Quiet , & + Title , & + History , & + Comment , & + Debug ) + END IF + + END FUNCTION IRwaterCoeff_WriteFile_IO + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRwaterCoeff_netCDF_to_Binary +! +! PURPOSE: +! Function to convert a netCDF IRwaterCoeff file to Binary format. +! +! CALLING SEQUENCE: +! Error_Status = IRwaterCoeff_netCDF_to_Binary( & +! NC_Filename , & +! BIN_Filename , & +! Quiet = Quiet ) +! +! INPUTS: +! NC_Filename: Character string specifying the name of the +! netCDF format IRwaterCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! BIN_Filename: Character string specifying the name of the +! Binary format IRwaterCoeff data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! 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 conversion was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +! SIDE EFFECTS: +! - If the output file already exists, it is overwritten. +! - If an error occurs, the output file is deleted before +! returning to the calling routine. +! +!:sdoc-: +!------------------------------------------------------------------------------ + + FUNCTION IRwaterCoeff_netCDF_to_Binary( & + NC_Filename , & ! Input + BIN_Filename, & ! Input + Quiet ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: NC_Filename + CHARACTER(*), INTENT(IN) :: BIN_Filename + LOGICAL, OPTIONAL, INTENT(IN) :: Quiet + ! Function result + INTEGER :: err_stat + ! Function parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'IRwaterCoeff_netCDF_to_Binary' + ! Function variables + CHARACTER(256) :: msg + TYPE(IRwaterCoeff_type) :: cc, cc_copy + + ! Set up + err_stat = SUCCESS + + ! Read the netCDF file + err_stat = IRwaterCoeff_ReadFile_IO(cc, NC_Filename, Quiet = Quiet, netCDF = .TRUE. ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading netCDF file '//TRIM(NC_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Write the Binary file + err_stat = IRwaterCoeff_WriteFile_IO(cc, BIN_Filename, Quiet = Quiet ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error writing Binary file '//TRIM(BIN_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Check the write was successful + ! ...Read the Binary file + err_stat = IRwaterCoeff_ReadFile_IO(cc_copy, BIN_Filename, Quiet = Quiet) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading Binary file '//TRIM(BIN_Filename)//' for test' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! ...Compare the IRwaterCoeff objects + IF ( .NOT. (cc == cc_copy) ) THEN + msg = 'IRwaterCoeff object comparison failed.' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + END FUNCTION IRwaterCoeff_netCDF_to_Binary + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRwaterCoeff_Binary_to_netCDF +! +! PURPOSE: +! Function to convert a binary IRwaterCoeff file to Binary format. +! +! CALLING SEQUENCE: +! Error_Status = IRwaterCoeff_Binary_to_netCDF( & +! BIN_Filename , & +! NC_Filename , & +! Quiet = Quiet ) +! +! INPUTS: +! BIN_Filename: Character string specifying the name of the +! Binary format IRwaterCoeff data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! NC_Filename: Character string specifying the name of the +! netCDF format IRwaterCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! OPTIONAL INPUTS: +! 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 conversion was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +! SIDE EFFECTS: +! - If the output file already exists, it is overwritten. +! - If an error occurs, the output file is deleted before +! returning to the calling routine. +! +!:sdoc-: +!------------------------------------------------------------------------------ + + FUNCTION IRwaterCoeff_Binary_to_netCDF( & + BIN_Filename, & ! Input + NC_Filename , & ! Input + Quiet ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: BIN_Filename + CHARACTER(*), INTENT(IN) :: NC_Filename + LOGICAL, OPTIONAL, INTENT(IN) :: Quiet + ! Function result + INTEGER :: err_stat + ! Function parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'IRwaterCoeff_Binary_to_NetCDF' + ! Function variables + CHARACTER(256) :: msg + TYPE(IRwaterCoeff_type) :: cc, cc_copy + + ! Set up + err_stat = SUCCESS + + ! Read the netCDF file + err_stat = IRwaterCoeff_ReadFile_IO(cc, BIN_Filename, Quiet = Quiet) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading Binary file '//TRIM(BIN_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Write the Binary file + err_stat = IRwaterCoeff_WriteFile_IO(cc, NC_Filename, Quiet = Quiet, netCDF = .TRUE.) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error writing netCDF file '//TRIM(NC_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Check the write was successful + ! ...Read the Binary file + err_stat = IRwaterCoeff_ReadFile_IO(cc_copy, NC_Filename, Quiet = Quiet, netCDF = .TRUE.) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading netCDF file '//TRIM(NC_Filename)//' for test' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! ...Compare the IRwaterCoeff objects + IF ( .NOT. (cc == cc_copy) ) THEN + msg = 'IRwaterCoeff object comparison failed.' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + END FUNCTION IRwaterCoeff_Binary_to_netCDF + +END MODULE IRwaterCoeff_IO diff --git a/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_Inspect/IRwaterCoeff_Inspect.f90 b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_Inspect/IRwaterCoeff_Inspect.f90 index 94a9f6f..6645afa 100644 --- a/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_Inspect/IRwaterCoeff_Inspect.f90 +++ b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_Inspect/IRwaterCoeff_Inspect.f90 @@ -28,7 +28,7 @@ PROGRAM IRwaterCoeff_Inspect ! Parameters ! ---------- CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'IRwaterCoeff_Inspect' - CHARACTER(*), PARAMETER :: PROGRAM_VERSION_ID = & + !CHARACTER(*), PARAMETER :: PROGRAM_VERSION_ID = & ! --------- ! Variables diff --git a/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_netCDF_IO.f90 b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_netCDF_IO.f90 new file mode 100644 index 0000000..76a982d --- /dev/null +++ b/src/Coefficients/EmisCoeff/IR_Water/IRwaterCoeff_netCDF_IO.f90 @@ -0,0 +1,1377 @@ +! +! +! IRwaterCoeff_netCDF_IO +! +! Module containing routines to read and write IRwaterCoeff netCDF +! format files. +! +! +! CREATION HISTORY: +! +! Written by: Cheng Dang, 05-Mar-2022 +! dangch@ucar.edu +! Modified by: Cheng Dang, 18-Mar-2022 +! dangch@ucar.edu +! Add temperature dimension +! + +MODULE IRwaterCoeff_netCDF_IO + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module use + USE Type_Kinds , ONLY: fp, Double, Long + USE Message_Handler , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message + USE File_Utility , ONLY: File_Exists + USE String_Utility , ONLY: StrClean + USE IRwaterCoeff_Define, ONLY: IRwaterCoeff_type, & + IRwaterCoeff_Associated, & + IRwaterCoeff_Create, & + IRwaterCoeff_Inspect, & + IRwaterCoeff_Destroy, & + IRwaterCoeff_ValidRelease, & + IRwaterCoeff_Info + USE netcdf + ! Disable implicit typing + IMPLICIT NONE + + ! ------------ + ! Visibilities + ! ------------ + ! Everything private by default + PRIVATE + ! Procedures + PUBLIC :: IRwaterCoeff_netCDF_InquireFile + PUBLIC :: IRwaterCoeff_netCDF_ReadFile + PUBLIC :: IRwaterCoeff_netCDF_WriteFile + + ! ----------------- + ! Module parameters + ! ----------------- + ! Default msg string length + INTEGER, PARAMETER :: ML = 1024 + ! Literal constants + REAL(fp), PARAMETER :: FILL_FLOAT = -999.0_fp + REAL(fp), PARAMETER :: ONE = 1.0_fp + ! Conversion constants + REAL(fp), PARAMETER :: PI = 3.141592653589793238462643383279_fp + REAL(fp), PARAMETER :: DEGREES_TO_RADIANS = PI / 180.0_fp + + ! Global attribute names. Case sensitive + CHARACTER(*), PARAMETER :: RELEASE_GATTNAME = 'Release' + CHARACTER(*), PARAMETER :: VERSION_GATTNAME = 'Version' + CHARACTER(*), PARAMETER :: DATA_SOURCE_GATTNAME = 'Data_Source' + CHARACTER(*), PARAMETER :: TITLE_GATTNAME = 'Title' + CHARACTER(*), PARAMETER :: HISTORY_GATTNAME = 'History' + CHARACTER(*), PARAMETER :: COMMENT_GATTNAME = 'Comment' + CHARACTER(*), PARAMETER :: CLASSIFICATION_NAME_GATTNAME = 'Classification_Name' + + ! Dimension names + CHARACTER(*), PARAMETER :: TNSL_DIMNAME = 'String_Length' + CHARACTER(*), PARAMETER :: FREQUENCY_DIMNAME = 'n_Frequencies' + CHARACTER(*), PARAMETER :: ANGLE_DIMNAME = 'n_Angles' + CHARACTER(*), PARAMETER :: WINDSPEED_DIMNAME = 'n_Wind_Speeds' + CHARACTER(*), PARAMETER :: TEMPERATURE_DIMNAME = 'n_Temperature' + + ! Variable names + CHARACTER(*), PARAMETER :: ANGLE_VARNAME = 'Angle' + CHARACTER(*), PARAMETER :: FREQUENCY_VARNAME = 'Frequency' + CHARACTER(*), PARAMETER :: WINDSPEED_VARNAME = 'Wind_Speed' + CHARACTER(*), PARAMETER :: TEMPERATURE_VARNAME = 'Temperature' + CHARACTER(*), PARAMETER :: EMISSIVITY_VARNAME = 'Emissivity' + + ! Variable long name attribute. + CHARACTER(*), PARAMETER :: LONGNAME_ATTNAME = 'long_name' + CHARACTER(*), PARAMETER :: ANGLE_LONGNAME = 'Angle' + CHARACTER(*), PARAMETER :: FREQUENCY_LONGNAME = 'Frequency' + CHARACTER(*), PARAMETER :: WINDSPEED_LONGNAME = 'Wind Speed' + CHARACTER(*), PARAMETER :: TEMPERATURE_LONGNAME = 'Temperature' + CHARACTER(*), PARAMETER :: EMISSIVITY_LONGNAME = 'Emissivity' + + ! Variable description attribute. + CHARACTER(*), PARAMETER :: DESCRIPTION_ATTNAME = 'description' + CHARACTER(*), PARAMETER :: ANGLE_DESCRIPTION = 'Angle dimension values for emissivity data' + CHARACTER(*), PARAMETER :: FREQUENCY_DESCRIPTION = 'Frequency dimension values for emissivity data' + CHARACTER(*), PARAMETER :: WINDSPEED_DESCRIPTION = 'Wind speed dimension values for emissivity data' + CHARACTER(*), PARAMETER :: TEMPERATURE_DESCRIPTION = 'Temperature dimension values for emissivity data' + CHARACTER(*), PARAMETER :: EMISSIVITY_DESCRIPTION = 'Spectral water surface emissivity data' + + ! Variable units attribute. + CHARACTER(*), PARAMETER :: UNITS_ATTNAME = 'units' + CHARACTER(*), PARAMETER :: ANGLE_UNITS = 'degrees from vertical' + CHARACTER(*), PARAMETER :: FREQUENCY_UNITS = 'inverse centimeters (cm^-1)' + CHARACTER(*), PARAMETER :: WINDSPEED_UNITS = 'meters per second (m.s^-1)' + CHARACTER(*), PARAMETER :: TEMPERATURE_UNITS = 'Kelvins' + CHARACTER(*), PARAMETER :: EMISSIVITY_UNITS = 'N/A' + + ! Variable _FillValue attribute. + CHARACTER(*), PARAMETER :: FILLVALUE_ATTNAME = '_FillValue' + REAL(Double), PARAMETER :: ANGLE_FILLVALUE = FILL_FLOAT + REAL(Double), PARAMETER :: FREQUENCY_FILLVALUE = FILL_FLOAT + REAL(Double), PARAMETER :: WINDSPEED_FILLVALUE = FILL_FLOAT + REAL(Double), PARAMETER :: TEMPERATURE_FILLVALUE = FILL_FLOAT + REAL(Double), PARAMETER :: EMISSIVITY_FILLVALUE = FILL_FLOAT + + ! Variable types + INTEGER, PARAMETER :: ANGLE_TYPE = NF90_DOUBLE + INTEGER, PARAMETER :: FREQUENCY_TYPE = NF90_DOUBLE + INTEGER, PARAMETER :: WINDSPEED_TYPE = NF90_DOUBLE + INTEGER, PARAMETER :: TEMPERATURE_TYPE = NF90_DOUBLE + INTEGER, PARAMETER :: EMISSIVITY_TYPE = NF90_DOUBLE + + +CONTAINS + +!################################################################################ +!################################################################################ +!## ## +!## ## PUBLIC MODULE ROUTINES ## ## +!## ## +!################################################################################ +!################################################################################ +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRwaterCoeff_netCDF_InquireFile +! +! PURPOSE: +! Function to inquire IRwaterCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRwaterCoeff_netCDF_InquireFile( & +! Filename, & +! n_Angles = n_Angles , & +! n_Frequencies = n_Frequencies , & +! n_Wind_Speeds = n_Wind_Speeds , & +! n_Temperature = n_Temperature , & +! Release = Release , & +! Version = Version , & +! Title = Title , & +! History = History , & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! IRwaterCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL OUTPUTS: +! n_Angles: The number of angles in the look-up +! table (LUT). Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Frequencies: The number of frequencies in the LUT. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Wind_Speeds: The number of wind speeds in +! the LUT. Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Wind_Speeds: The number of temperature in +! the LUT. Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Release: The release number of the IRwaterCoeff file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Version: The version number of the IRwaterCoeff file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Title: Character string written into the TITLE global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 IRwaterCoeff_netCDF_InquireFile( & + Filename , & ! Input + n_Angles , & ! Optional output + n_Frequencies, & ! Optional output + n_Wind_Speeds, & ! Optional output + n_Temperature, & ! 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_Angles + INTEGER , OPTIONAL, INTENT(OUT) :: n_Frequencies + INTEGER , OPTIONAL, INTENT(OUT) :: n_Wind_Speeds + INTEGER , OPTIONAL, INTENT(OUT) :: n_Temperature + 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 = 'IRwaterCoeff_netCDF_InquireFile' + ! Function variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + INTEGER :: NF90_Status + INTEGER :: FileId + INTEGER :: DimId + TYPE(IRwaterCoeff_type) :: IRwaterCoeff + + ! Setup + err_stat = SUCCESS + Close_File = .FALSE. + + ! Open the file + NF90_Status = NF90_OPEN( Filename,NF90_NOWRITE,FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error opening '//TRIM(Filename)//' for read access - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Get the dimensions + ! ...n_Angles dimension + NF90_Status = NF90_INQ_DIMID( FileId,ANGLE_DIMNAME,DimId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring dimension ID for '//ANGLE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + NF90_Status = NF90_INQUIRE_DIMENSION( FileId,DimId,Len=IRwaterCoeff%n_Angles ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading dimension value for '//ANGLE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + ! ...n_Frequencies dimension + NF90_Status = NF90_INQ_DIMID( FileId,FREQUENCY_DIMNAME,DimId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring dimension ID for '//FREQUENCY_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + NF90_Status = NF90_INQUIRE_DIMENSION( FileId,DimId,Len=IRwaterCoeff%n_Frequencies ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading dimension value for '//FREQUENCY_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + ! ...n_Wind_Speeds dimension + NF90_Status = NF90_INQ_DIMID( FileId,WINDSPEED_DIMNAME,DimId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring dimension ID for '//WINDSPEED_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + NF90_Status = NF90_INQUIRE_DIMENSION( FileId,DimId,Len=IRwaterCoeff%n_Wind_Speeds ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading dimension value for '//WINDSPEED_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + ! ...n_Temperature dimension + NF90_Status = NF90_INQ_DIMID( FileId,TEMPERATURE_DIMNAME,DimId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring dimension ID for '//TEMPERATURE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + NF90_Status = NF90_INQUIRE_DIMENSION( FileId,DimId,Len=IRwaterCoeff%n_Temperature ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading dimension value for '//TEMPERATURE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + + ! Get the global attributes + err_stat = ReadGAtts( Filename, & + FileId , & + Release = IRwaterCoeff%Release, & + Version = IRwaterCoeff%Version, & + Title = Title , & + History = History, & + Comment = Comment ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading global attributes from '//TRIM(Filename) + CALL Inquire_Cleanup(); RETURN + END IF + + ! Close the file + NF90_Status = NF90_CLOSE( FileId ) + Close_File = .FALSE. + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error closing input file - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + + ! Set the return values + IF ( PRESENT(n_Angles ) ) n_Angles = IRwaterCoeff%n_Angles + IF ( PRESENT(n_Frequencies) ) n_Frequencies = IRwaterCoeff%n_Frequencies + IF ( PRESENT(n_Wind_Speeds) ) n_Wind_Speeds = IRwaterCoeff%n_Wind_Speeds + IF ( PRESENT(n_Temperature) ) n_Temperature = IRwaterCoeff%n_Temperature + IF ( PRESENT(Release ) ) Release = IRwaterCoeff%Release + IF ( PRESENT(Version ) ) Version = IRwaterCoeff%Version + + CONTAINS + + SUBROUTINE Inquire_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing input file during error cleanup.' + END IF + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Inquire_CleanUp + + END FUNCTION IRwaterCoeff_netCDF_InquireFile + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRwaterCoeff_netCDF_WriteFile +! +! PURPOSE: +! Function to write IRwaterCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRwaterCoeff_netCDF_WriteFile( & +! IRwaterCoeff, & +! Filename, & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment, & +! Debug ) +! +! INPUTS: +! IRwaterCoeff: Object containing the IRwater coefficient data. +! UNITS: N/A +! TYPE: TYPE(IRwaterCoeff_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Filename: Character string specifying the name of the +! IRwaterCoeff data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! OPTIONAL INPUTS: +! 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 +! +! Title: Character string written into the TITLE global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 data write was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!------------------------------------------------------------------------------ + FUNCTION IRwaterCoeff_netCDF_WriteFile( & + IRwaterCoeff, & ! Input + Filename , & ! Input + Quiet , & ! Optional input + Title , & ! Optional input + History , & ! Optional input + Comment , & ! Optional input + Debug ) & ! Optional input (Debug output control) + RESULT( err_stat ) + ! Arguments + TYPE(IRwaterCoeff_type), INTENT(IN) :: IRwaterCoeff + CHARACTER(*), INTENT(IN) :: Filename + 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 = 'IRwaterCoeff_netCDF_WriteFile' + ! Local variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + LOGICAL :: Noisy + INTEGER :: NF90_Status + INTEGER :: FileId + INTEGER :: VarId + + ! Set up + err_stat = SUCCESS + Close_File = .FALSE. + ! ...Check structure pointer association status + IF ( .NOT. IRwaterCoeff_Associated( IRwaterCoeff ) ) THEN + msg = 'IRwaterCoeff structure is empty. Nothing to do!' + CALL Write_CleanUp(); RETURN + END IF + ! ...Check if release is valid + IF ( .NOT. IRwaterCoeff_ValidRelease( IRwaterCoeff ) ) THEN + msg = 'IRwaterCoeff Release check failed.' + CALL Write_Cleanup(); RETURN + END IF + ! ...Check Quiet argument + Noisy = .TRUE. + IF ( PRESENT(Quiet) ) Noisy = .NOT. Quiet + + ! Create the output file + err_stat = CreateFile( & + Filename , & ! Input + IRwaterCoeff%n_Angles , & ! Input + IRwaterCoeff%n_Frequencies , & ! Input + IRwaterCoeff%n_Wind_Speeds , & ! Input + IRwaterCoeff%n_Temperature , & ! Input + FileId , & ! Output + Release = IRwaterCoeff%Release , & ! Optional input + Version = IRwaterCoeff%Version , & ! Optional input + Classification_Name = IRwaterCoeff%Classification_Name , & ! Optional input + Title = Title , & ! Optional input + History = History , & ! Optional input + Comment = Comment ) ! Optional input + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error creating output file '//TRIM(Filename) + CALL Write_Cleanup(); RETURN + END IF + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Write the data items + ! ...Angle variable + NF90_Status = NF90_INQ_VARID( FileId,ANGLE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//ANGLE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,IRwaterCoeff%Angle ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//ANGLE_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + ! ...Frequency variable + NF90_Status = NF90_INQ_VARID( FileId,FREQUENCY_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//FREQUENCY_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,IRwaterCoeff%Frequency ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//FREQUENCY_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + ! ...Wind speed variable + NF90_Status = NF90_INQ_VARID( FileId,WINDSPEED_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//WINDSPEED_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,IRwaterCoeff%Wind_Speed ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//WINDSPEED_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + ! ...Temperature variable + NF90_Status = NF90_INQ_VARID( FileId,TEMPERATURE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//TEMPERATURE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,IRwaterCoeff%Temperature ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//TEMPERATURE_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + ! ...Emissivity variable + NF90_Status = NF90_INQ_VARID( FileId,EMISSIVITY_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//EMISSIVITY_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,IRwaterCoeff%Emissivity ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//EMISSIVITY_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + + ! Close the file + NF90_Status = NF90_CLOSE( FileId ) + Close_File = .FALSE. + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error closing output file - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + + ! Output an info message + IF ( Noisy ) THEN + CALL IRwaterCoeff_Info( IRwaterCoeff, msg ) + CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION ) + END IF + + CONTAINS + + SUBROUTINE Write_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing output file during error cleanup - '//& + TRIM(NF90_STRERROR( NF90_Status )) + END IF + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Write_CleanUp + + END FUNCTION IRwaterCoeff_netCDF_WriteFile + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! IRwaterCoeff_netCDF_ReadFile +! +! PURPOSE: +! Function to read IRwaterCoeff object files. +! +! CALLING SEQUENCE: +! Error_Status = IRwaterCoeff_netCDF_ReadFile( & +! IRwaterCoeff, & +! Filename, & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! IRwaterCoeff data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! IRwaterCoeff: Object containing the IRwater coefficient data. +! UNITS: N/A +! TYPE: TYPE(IRwaterCoeff_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! OPTIONAL INPUTS: +! 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 +! +! OPTIONAL OUTPUTS: +! Title: Character string written into the TITLE global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the IRwaterCoeff file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 IRwaterCoeff_netCDF_ReadFile( & + IRwaterCoeff, & ! Output + Filename , & ! Input + Quiet , & ! Optional input + Title , & ! Optional output + History , & ! Optional output + Comment , & ! Optional output + Debug ) & ! Optional input (Debug output control) + RESULT( err_stat ) + ! Arguments + TYPE(IRwaterCoeff_type), INTENT(OUT) :: IRwaterCoeff + CHARACTER(*), INTENT(IN) :: Filename + 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 = 'IRwaterCoeff_netCDF_ReadFile' + ! Function variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + LOGICAL :: Noisy + INTEGER :: NF90_Status + INTEGER :: FileId + INTEGER :: n_Angles + INTEGER :: n_Frequencies + INTEGER :: n_Wind_Speeds + INTEGER :: n_Temperature + INTEGER :: VarId + + ! Set up + err_stat = SUCCESS + Close_File = .FALSE. + ! ...Check that the file exists + IF ( .NOT. File_Exists(Filename) ) THEN + msg = 'File '//TRIM(Filename)//' not found.' + CALL Read_Cleanup(); RETURN + END IF + ! ...Check Quiet argument + Noisy = .TRUE. + IF ( PRESENT(Quiet) ) Noisy = .NOT. Quiet + + ! Inquire the file to get the dimensions + err_stat = IRwaterCoeff_netCDF_InquireFile( & + Filename , & + n_Angles = n_Angles , & + n_Frequencies = n_Frequencies , & + n_Wind_Speeds = n_Wind_Speeds , & + n_Temperature = n_Temperature ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error obtaining IRwaterCoeff dimensions from '//TRIM(Filename) + CALL Read_Cleanup(); RETURN + END IF + + ! Allocate the output structure + CALL IRwaterCoeff_Create( & + IRwaterCoeff , & + n_Angles , & + n_Frequencies , & + n_Wind_Speeds , & + n_Temperature ) + IF ( .NOT. IRwaterCoeff_Associated( IRwaterCoeff ) ) THEN + msg = 'IRwaterCoeff object allocation failed.' + CALL Read_Cleanup(); RETURN + END IF + + ! Open the file for reading + NF90_Status = NF90_OPEN( Filename,NF90_NOWRITE,FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error opening '//TRIM(Filename)//' for read access - '//& + TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Read the global attributes + err_stat = ReadGAtts( Filename, & + FileID , & + Release = IRwaterCoeff%Release , & + Version = IRwaterCoeff%Version , & + Classification_Name = IRwaterCoeff%Classification_Name , & + Title = Title , & + History = History , & + Comment = Comment ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading global attribute from '//TRIM(Filename) + CALL Read_Cleanup(); RETURN + END IF + ! ...Check if release is valid + IF ( .NOT. IRwaterCoeff_ValidRelease( IRwaterCoeff ) ) THEN + msg = 'IRwaterCoeff Release check failed.' + CALL Read_Cleanup(); RETURN + END IF + + ! Read the IRwaterCoeff data + ! ...Angle variable + NF90_Status = NF90_INQ_VARID( FileId,ANGLE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//ANGLE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,IRwaterCoeff%Angle ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//ANGLE_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Compute the transformed dimensional vectors + IRwaterCoeff%Secant_Angle = ONE/COS(DEGREES_TO_RADIANS*IRwaterCoeff%Angle) + + ! ...Frequency variable + NF90_Status = NF90_INQ_VARID( FileId,FREQUENCY_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//FREQUENCY_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,IRwaterCoeff%Frequency ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//FREQUENCY_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Wind speed variable + NF90_Status = NF90_INQ_VARID( FileId,WINDSPEED_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//WINDSPEED_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,IRwaterCoeff%Wind_Speed ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//WINDSPEED_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Temperature variable + NF90_Status = NF90_INQ_VARID( FileId,TEMPERATURE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//TEMPERATURE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,IRwaterCoeff%Temperature ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//TEMPERATURE_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Emissivity variable + NF90_Status = NF90_INQ_VARID( FileId,EMISSIVITY_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//EMISSIVITY_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,IRwaterCoeff%Emissivity ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//EMISSIVITY_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + + ! Close the file + NF90_Status = NF90_CLOSE( FileId ); Close_File = .FALSE. + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error closing output file - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + + ! Output an info message + IF ( Noisy ) THEN + CALL IRwaterCoeff_Info( IRwaterCoeff, msg ) + CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION ) + END IF + + CONTAINS + + SUBROUTINE Read_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing input file during error cleanup- '//& + TRIM(NF90_STRERROR( NF90_Status )) + END IF + CALL IRwaterCoeff_Destroy( IRwaterCoeff ) + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Read_CleanUp + + END FUNCTION IRwaterCoeff_netCDF_ReadFile + + +!################################################################################## +!################################################################################## +!## ## +!## ## PRIVATE MODULE ROUTINES ## ## +!## ## +!################################################################################## +!################################################################################## + + ! Function to write the global attributes to a IRwaterCoeff data file. + + FUNCTION WriteGAtts( & + Filename , & ! Input + FileId , & ! Input + Release , & ! Optional input + Version , & ! Optional input + Classification_Name , & ! Optional input + Title , & ! Optional input + History , & ! Optional input + Comment ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: Filename + INTEGER , INTENT(IN) :: FileId + INTEGER , OPTIONAL, INTENT(IN) :: Release + INTEGER , OPTIONAL, INTENT(IN) :: Version + CHARACTER(*), OPTIONAL, INTENT(IN) :: Classification_Name + CHARACTER(*), OPTIONAL, INTENT(IN) :: Title + CHARACTER(*), OPTIONAL, INTENT(IN) :: History + CHARACTER(*), OPTIONAL, INTENT(IN) :: Comment + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'IRwaterCoeff_WriteGAtts(netCDF)' + CHARACTER(*), PARAMETER :: WRITE_MODULE_HISTORY_GATTNAME = 'write_module_history' + CHARACTER(*), PARAMETER :: CREATION_DATE_AND_TIME_GATTNAME = 'creation_date_and_time' + ! Local variables + CHARACTER(ML) :: msg + CHARACTER(ML) :: GAttName + CHARACTER(8) :: cdate + CHARACTER(10) :: ctime + CHARACTER(5) :: czone + CHARACTER(ML) :: CLSname + INTEGER :: Ver + INTEGER :: NF90_Status + TYPE(IRwaterCoeff_type) :: IRwaterCoeff + + ! Set up + err_stat = SUCCESS + msg = ' ' + + ! Mandatory global attributes + ! ...Software ID + !GAttName = WRITE_MODULE_HISTORY_GATTNAME + !NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),MODULE_VERSION_ID ) + !IF ( NF90_Status /= NF90_NOERR ) THEN + ! CALL WriteGAtts_Cleanup(); RETURN + !END IF + ! ...Creation date + CALL DATE_AND_TIME( cdate, ctime, czone ) + GAttName = CREATION_DATE_AND_TIME_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName), & + cdate(1:4)//'/'//cdate(5:6)//'/'//cdate(7:8)//', '// & + ctime(1:2)//':'//ctime(3:4)//':'//ctime(5:6)//' '// & + czone//'UTC' ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + + ! Optional global attributes + ! ...The Release + IF ( PRESENT(Release) ) THEN + GAttName = RELEASE_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),IRwaterCoeff%Release ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The Version + IF ( PRESENT(Version) ) THEN + Ver = Version + ELSE + Ver = IRwaterCoeff%Version + END IF + GAttName = VERSION_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),Ver ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + ! ...The Classification_Name + IF ( PRESENT(Classification_Name) ) THEN + CLSname = Classification_Name + ELSE + CLSname = IRwaterCoeff%Classification_Name + END IF + GAttName = CLASSIFICATION_NAME_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),CLSname ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + ! ...The title + IF ( PRESENT(title) ) THEN + GAttName = TITLE_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),title ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The history + IF ( PRESENT(history) ) THEN + GAttName = HISTORY_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),history ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The comment + IF ( PRESENT(comment) ) THEN + GAttName = COMMENT_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),comment ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + END IF + + CONTAINS + + SUBROUTINE WriteGAtts_CleanUp() + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = '; Error closing input file during error cleanup - '//& + TRIM(NF90_STRERROR( NF90_Status ) ) + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME, & + 'Error writing '//TRIM(GAttName)//' attribute to '//& + TRIM(Filename)//' - '// & + TRIM(NF90_STRERROR( NF90_Status ) )//TRIM(msg), & + err_stat ) + END SUBROUTINE WriteGAtts_CleanUp + + END FUNCTION WriteGAtts + + ! Function to read the global attributes from a IRwaterCoeff data file. + + FUNCTION ReadGAtts( & + Filename , & ! Input + FileId , & ! Input + Release , & ! Optional output + Version , & ! Optional output + Classification_Name , & ! Optional output + Title , & ! Optional output + History , & ! Optional output + Comment ) & ! Optional output + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: Filename + INTEGER , INTENT(IN) :: FileId + INTEGER , OPTIONAL, INTENT(OUT) :: Release + INTEGER , OPTIONAL, INTENT(OUT) :: Version + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Classification_Name + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title + CHARACTER(*), OPTIONAL, INTENT(OUT) :: History + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Comment + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'IRwaterCoeff_ReadGAtts(netCDF)' + ! Local variables + CHARACTER(ML) :: msg + CHARACTER(256) :: GAttName + CHARACTER(5000) :: GAttString + INTEGER :: NF90_Status + + ! Set up + err_stat = SUCCESS + + ! The global attributes + ! ...The Release + IF ( PRESENT(Release) ) THEN + GAttName = RELEASE_GATTNAME + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),Release ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The Version + IF ( PRESENT(Version) ) THEN + GAttName = VERSION_GATTNAME + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),Version ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The Classification Name + IF ( PRESENT(Classification_Name) ) THEN + GAttName = CLASSIFICATION_NAME_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + Classification_Name = GAttString(1:MIN(LEN(Classification_Name), LEN_TRIM(GAttString))) + END IF + ! ...The title + IF ( PRESENT(title) ) THEN + GAttName = TITLE_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + title = GAttString(1:MIN(LEN(title), LEN_TRIM(GAttString))) + END IF + ! ...The history + IF ( PRESENT(history) ) THEN + GAttName = HISTORY_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + history = GAttString(1:MIN(LEN(history), LEN_TRIM(GAttString))) + END IF + ! ...The comment + IF ( PRESENT(comment) ) THEN + GAttName = COMMENT_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + comment = GAttString(1:MIN(LEN(comment), LEN_TRIM(GAttString))) + END IF + + CONTAINS + + SUBROUTINE ReadGAtts_CleanUp() + err_stat = FAILURE + msg = 'Error reading '//TRIM(GAttName)//' attribute from '//TRIM(Filename)//' - '// & + TRIM(NF90_STRERROR( NF90_Status ) ) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + END SUBROUTINE ReadGAtts_CleanUp + + END FUNCTION ReadGAtts + + FUNCTION CreateFile( & + Filename , & ! Input + n_Angles , & ! Input + n_Frequencies , & ! Input + n_Wind_Speeds , & ! Input + n_Temperature , & ! Input + FileId , & ! Output + Release , & ! Optional input + Version , & ! Optional input + Classification_Name , & ! Optional input + Title , & ! Optional input + History , & ! Optional input + Comment ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: Filename + INTEGER , INTENT(IN) :: n_Angles + INTEGER , INTENT(IN) :: n_Frequencies + INTEGER , INTENT(IN) :: n_Wind_Speeds + INTEGER , INTENT(IN) :: n_Temperature + INTEGER , INTENT(OUT) :: FileId + INTEGER , OPTIONAL, INTENT(IN) :: Release + INTEGER , OPTIONAL, INTENT(IN) :: Version + CHARACTER(*), OPTIONAL, INTENT(IN) :: Classification_Name + CHARACTER(*), OPTIONAL, INTENT(IN) :: Title + CHARACTER(*), OPTIONAL, INTENT(IN) :: History + CHARACTER(*), OPTIONAL, INTENT(IN) :: Comment + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'IRwaterCoeff_CreateFile(netCDF)' + ! Local variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + INTEGER :: NF90_Status + INTEGER :: n_Angles_DimID + INTEGER :: n_Frequencies_DimID + INTEGER :: n_Wind_Speeds_DimID + INTEGER :: n_Temperature_DimID + INTEGER :: varID + INTEGER :: Put_Status(4) + TYPE(IRwaterCoeff_type) :: dummy + + ! Setup + err_stat = SUCCESS + Close_File = .FALSE. + + ! Create the data file + NF90_Status = NF90_CREATE( Filename,NF90_CLOBBER,FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error creating '//TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Define the dimensions + ! ...Number of angles + NF90_Status = NF90_DEF_DIM( FileID,ANGLE_DIMNAME,n_Angles,n_Angles_DimID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//ANGLE_DIMNAME//' dimension in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + ! ...Number of frequencies + NF90_Status = NF90_DEF_DIM( FileID,FREQUENCY_DIMNAME,n_Frequencies,n_Frequencies_DimID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//FREQUENCY_DIMNAME//' dimension in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + ! ...Number of wind speed + NF90_Status = NF90_DEF_DIM( FileID,WINDSPEED_DIMNAME,n_Wind_Speeds,n_Wind_Speeds_DimID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//WINDSPEED_DIMNAME//' dimension in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + ! ...Number of temperature + NF90_Status = NF90_DEF_DIM( FileID,TEMPERATURE_DIMNAME,n_Temperature,n_Temperature_DimID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//TEMPERATURE_DIMNAME//' dimension in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + CALL IRwaterCoeff_Destroy(dummy) + + ! Write the global attributes + err_stat = WriteGAtts( Filename, & + FileId , & + Release = Release , & + Version = Version , & + Classification_Name = Classification_Name , & + Title = Title , & + History = History , & + Comment = Comment ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error writing global attribute to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + + ! Define the variables + ! ...Angle variable + NF90_Status = NF90_DEF_VAR( FileID, & + ANGLE_VARNAME, & + ANGLE_TYPE, & + dimIDs=(/n_Angles_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//ANGLE_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,ANGLE_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,ANGLE_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,ANGLE_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,ANGLE_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//ANGLE_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + ! ...Frequency variable + NF90_Status = NF90_DEF_VAR( FileID, & + FREQUENCY_VARNAME, & + FREQUENCY_TYPE, & + dimIDs=(/n_Frequencies_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//FREQUENCY_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,FREQUENCY_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,FREQUENCY_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,FREQUENCY_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,FREQUENCY_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//FREQUENCY_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + ! ...Wind speed variable + NF90_Status = NF90_DEF_VAR( FileID, & + WINDSPEED_VARNAME, & + WINDSPEED_TYPE, & + dimIDs=(/n_Wind_Speeds_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//WINDSPEED_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,WINDSPEED_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,WINDSPEED_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,WINDSPEED_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,WINDSPEED_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//WINDSPEED_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + ! ...Temperature variable + NF90_Status = NF90_DEF_VAR( FileID, & + TEMPERATURE_VARNAME, & + TEMPERATURE_TYPE, & + dimIDs=(/n_Temperature_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//TEMPERATURE_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,TEMPERATURE_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,TEMPERATURE_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,TEMPERATURE_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,TEMPERATURE_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//TEMPERATURE_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + ! ...Emissivity variable + NF90_Status = NF90_DEF_VAR( FileID, & + EMISSIVITY_VARNAME, & + EMISSIVITY_TYPE, & + dimIDs=(/n_Angles_DimID, n_Frequencies_DimID, n_Wind_Speeds_DimID, n_Temperature_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//EMISSIVITY_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,EMISSIVITY_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,EMISSIVITY_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,EMISSIVITY_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,EMISSIVITY_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//EMISSIVITY_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + + ! Take netCDF file out of define mode + NF90_Status = NF90_ENDDEF( FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error taking file '//TRIM(Filename)// & + ' out of define mode - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + + CONTAINS + + SUBROUTINE Create_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileID ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing input file during error cleanup - '//& + TRIM(NF90_STRERROR( NF90_Status )) + END IF + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Create_CleanUp + + END FUNCTION CreateFile + + END MODULE IRwaterCoeff_netCDF_IO diff --git a/src/Coefficients/EmisCoeff/MW_Water/MWwaterCoeff_Inspect/MWwaterCoeff_Inspect.f90 b/src/Coefficients/EmisCoeff/MW_Water/MWwaterCoeff_Inspect/MWwaterCoeff_Inspect.f90 index 8af4919..366e584 100644 --- a/src/Coefficients/EmisCoeff/MW_Water/MWwaterCoeff_Inspect/MWwaterCoeff_Inspect.f90 +++ b/src/Coefficients/EmisCoeff/MW_Water/MWwaterCoeff_Inspect/MWwaterCoeff_Inspect.f90 @@ -28,7 +28,7 @@ PROGRAM MWwaterCoeff_Inspect ! Parameters ! ---------- CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'MWwaterCoeff_Inspect' - CHARACTER(*), PARAMETER :: PROGRAM_VERSION_ID = & + !CHARACTER(*), PARAMETER :: PROGRAM_VERSION_ID = & ! --------- ! Variables diff --git a/src/Coefficients/EmisCoeff/MW_Water/MWwaterLUT/MWwaterLUT_Inspect/MWwaterLUT_Inspect.f90 b/src/Coefficients/EmisCoeff/MW_Water/MWwaterLUT/MWwaterLUT_Inspect/MWwaterLUT_Inspect.f90 index 8f3fd0e..0cc7eec 100644 --- a/src/Coefficients/EmisCoeff/MW_Water/MWwaterLUT/MWwaterLUT_Inspect/MWwaterLUT_Inspect.f90 +++ b/src/Coefficients/EmisCoeff/MW_Water/MWwaterLUT/MWwaterLUT_Inspect/MWwaterLUT_Inspect.f90 @@ -28,7 +28,7 @@ PROGRAM MWwaterLUT_Inspect ! Parameters ! ---------- CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'MWwaterLUT_Inspect' - CHARACTER(*), PARAMETER :: PROGRAM_VERSION_ID = & + !CHARACTER(*), PARAMETER :: PROGRAM_VERSION_ID = & ! --------- ! Variables diff --git a/src/Coefficients/EmisCoeff/SEcategory/SEcategory_BIN2NC/Makefile b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_BIN2NC/Makefile new file mode 100644 index 0000000..c148f0f --- /dev/null +++ b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_BIN2NC/Makefile @@ -0,0 +1,61 @@ +#============================================================================== +# +# Makefile for SEcategory_BIN2NC program +# +#============================================================================== + +# Define macros +include $(CRTM_SOURCE_ROOT)/make.macros + +# This makefile +MAKE_FILE = Makefile + +# Executable file +EXE_FILE = SEcategory_BIN2NC +SCRIPT_FILE = run_$(EXE_FILE).sh + +# Source files to link +SRC_FILES = Type_Kinds.f90 \ + File_Utility.f90 \ + Message_Handler.f90 \ + Compare_Float_Numbers.f90 \ + Endian_Utility.f90 \ + Binary_File_Utility.f90 \ + String_Utility.f90 \ + Fundamental_Constants.f90 \ + SignalFile_Utility.f90 \ + SEcategory_Define.f90 \ + SEcategory_IO.f90 \ + SEcategory_netCDF_IO.f90 + +# Obj files used in link phase +OBJ_FILES = ${SRC_FILES:.f90=.o} \ + $(EXE_FILE).o + +# Include and library definitions +INCLUDES = -I$(NC4_DIR)/include \ + -I$(HDF_DIR)/include +LIBRARIES = -L$(NC4_DIR)/lib -lnetcdf -lnetcdff \ + -L$(HDF_DIR)/lib -lhdf5 + + +# Define common make targets (all, build, clean, install) +include $(CRTM_SOURCE_ROOT)/make.common_targets + +# Source link creation and removal +create_links:: + @$(LINK_SCRIPT) $(CRTM_SOURCE_ROOT) $(SRC_FILES) + +remove_links:: + @$(UNLINK_SCRIPT) $(SRC_FILES) + +# Script install target +install_script: + @$(COPY) $(SCRIPT_FILE) ${HOME}/bin + +# Source dependency lists +include make.dependencies + +# Define default rules +include $(CRTM_SOURCE_ROOT)/make.rules + diff --git a/src/Coefficients/EmisCoeff/SEcategory/SEcategory_BIN2NC/SEcategory_BIN2NC.f90 b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_BIN2NC/SEcategory_BIN2NC.f90 new file mode 100644 index 0000000..129a60f --- /dev/null +++ b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_BIN2NC/SEcategory_BIN2NC.f90 @@ -0,0 +1,73 @@ +! +! SEcategory_BIN2NC +! +! Program to convert a CRTM SEcategory data file +! from Binary to netCDF format +! +! +! CREATION HISTORY: +! Written by: Cheng Dang, 02-12-2022 +! dangch@ucar.edu + +PROGRAM SEcategory_BIN2NC + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module usage + USE Message_Handler , ONLY: SUCCESS, FAILURE, Program_Message, Display_Message + USE SignalFile_Utility , ONLY: Create_SignalFile + USE SEcategory_Define , ONLY: SEcategory_type + USE SEcategory_IO , ONLY: SEcategory_Binary_to_netCDF + ! Disable implicit typing + IMPLICIT NONE + + ! ---------- + ! Parameters + ! ---------- + CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'SEcategory_BIN2NC' + + ! --------- + ! Variables + ! --------- + INTEGER :: err_stat + CHARACTER(256) :: NC_Filename, BIN_Filename + + ! Program header + CALL Program_Message( PROGRAM_NAME, & + 'Program to convert a CRTM SEcategory data file '//& + 'from Binary to netCDF format.', & + '$Revision$') + ! Get the filenames + WRITE(*,FMT='(/5x,"Enter the INPUT Binary SEcategory filename : ")', ADVANCE='NO') + READ(*,'(a)') BIN_Filename + BIN_Filename = ADJUSTL(BIN_Filename) + WRITE(*,FMT='(/5x,"Enter the OUTPUT netCDF SEcategory filename: ")', ADVANCE='NO') + READ(*,'(a)') NC_Filename + NC_Filename = ADJUSTL(NC_Filename) + ! ...Sanity check that they're not the same + IF ( BIN_Filename == NC_Filename ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'SEcategory netCDF and Binary filenames are the same!', & + FAILURE ) + STOP + END IF + + ! Perform the conversion + err_stat = SEcategory_Binary_to_netCDF( BIN_Filename, NC_Filename ) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'SEcategory Binary -> netCDF conversion failed!', & + FAILURE ) + STOP + END IF + + ! Create a signal file indicating success + err_stat = Create_SignalFile( NC_Filename ) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'Error creating signal file for '//TRIM(NC_Filename), & + FAILURE ) + END IF + +END PROGRAM SEcategory_BIN2NC diff --git a/src/Coefficients/EmisCoeff/SEcategory/SEcategory_BIN2NC/make.dependencies b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_BIN2NC/make.dependencies new file mode 100644 index 0000000..c23209f --- /dev/null +++ b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_BIN2NC/make.dependencies @@ -0,0 +1,13 @@ +SEcategory_Define.o : SEcategory_Define.f90 File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o Binary_File_Utility.o +SEcategory_netCDF_IO.o : SEcategory_netCDF_IO.f90 SEcategory_Define.o String_Utility.o File_Utility.o Message_Handler.o Type_Kinds.o +SEcategory_IO.o : SEcategory_IO.f90 SEcategory_netCDF_IO.o SEcategory_Define.o File_Utility.o Message_Handler.o Type_Kinds.o +SEcategory_BIN2NC.o : SEcategory_BIN2NC.f90 SEcategory_IO.o SEcategory_Define.o SignalFile_Utility.o Message_Handler.o +Binary_File_Utility.o : Binary_File_Utility.f90 Endian_Utility.o Message_Handler.o File_Utility.o Type_Kinds.o +Compare_Float_Numbers.o : Compare_Float_Numbers.f90 Type_Kinds.o +Endian_Utility.o : Endian_Utility.f90 Type_Kinds.o +File_Utility.o : File_Utility.f90 +Fundamental_Constants.o : Fundamental_Constants.f90 Type_Kinds.o +Message_Handler.o : Message_Handler.f90 File_Utility.o +SignalFile_Utility.o : SignalFile_Utility.f90 Message_Handler.o File_Utility.o +String_Utility.o : String_Utility.f90 +Type_Kinds.o : Type_Kinds.f90 diff --git a/src/Coefficients/EmisCoeff/SEcategory/SEcategory_Define.f90 b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_Define.f90 index c4f748c..e1a669e 100644 --- a/src/Coefficients/EmisCoeff/SEcategory/SEcategory_Define.f90 +++ b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_Define.f90 @@ -1634,20 +1634,20 @@ ELEMENTAL FUNCTION SEcategory_Equal( x, y ) RESULT( is_equal ) ! Check the object association status IF ( (.NOT. SEcategory_Associated(x)) .OR. & (.NOT. SEcategory_Associated(y)) ) RETURN - - ! Check contents + ! Check contents ! ...Release/version info IF ( (x%Release /= y%Release) .OR. & (x%Version /= y%Version) ) RETURN - ! ...Classification name + !...Classification name IF ( (x%Classification_Name /= y%Classification_Name) ) RETURN ! ...Dimensions IF ( (x%n_Frequencies /= y%n_Frequencies ) .OR. & (x%n_Surface_Types /= y%n_Surface_Types ) ) RETURN ! ...Arrays - IF ( ALL(x%Frequency .EqualTo. y%Frequency ) .AND. & - ALL(x%Surface_Type == y%Surface_Type ) .AND. & - ALL(x%Reflectance .EqualTo. y%Reflectance ) ) & + IF ( ALL(x%Frequency .EqualTo. y%Frequency ) .AND. & + ALL(x%Surface_Type == y%Surface_Type ) .AND. & + ALL(x%Surface_Type_IsValid .EQV. y%Surface_Type_IsValid ) .AND. & + ALL(x%Reflectance .EqualTo. y%Reflectance ) ) & is_equal = .TRUE. END FUNCTION SEcategory_Equal diff --git a/src/Coefficients/EmisCoeff/SEcategory/SEcategory_IO.f90 b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_IO.f90 new file mode 100644 index 0000000..6cdd28c --- /dev/null +++ b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_IO.f90 @@ -0,0 +1,739 @@ +! +! SEcategory_IO +! +! Container module for Binary and netCDF SEcategory I/O modules. +! +! +! CREATION HISTORY: +! +! Written by: Cheng Dang, 12-Feb-2022 +! dangch@ucar.edu + +MODULE SEcategory_IO + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module use + USE Type_Kinds , ONLY: fp + USE Message_Handler , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message + USE File_Utility , ONLY: File_Exists + USE SEcategory_Define , ONLY: SEcategory_type, & + OPERATOR(==), & + SEcategory_InquireFile , & + SEcategory_ReadFile , & + SEcategory_WriteFile + USE SEcategory_netCDF_IO , ONLY: SEcategory_netCDF_InquireFile , & + SEcategory_netCDF_ReadFile , & + SEcategory_netCDF_WriteFile + ! Disable implicit typing + IMPLICIT NONE + + ! ------------ + ! Visibilities + ! ------------ + PRIVATE + PUBLIC :: SEcategory_InquireFile_IO + PUBLIC :: SEcategory_ReadFile_IO + PUBLIC :: SEcategory_WriteFile_IO + PUBLIC :: SEcategory_netCDF_to_Binary + PUBLIC :: SEcategory_Binary_to_netCDF + +CONTAINS + + +!################################################################################ +!################################################################################ +!## ## +!## ## PUBLIC MODULE ROUTINES ## ## +!## ## +!################################################################################ +!################################################################################ +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! SEcategory_InquireFile_IO +! +! PURPOSE: +! Function to inquire SEcategory object files. +! +! CALLING SEQUENCE: +! Error_Status = SEcategory_InquireFile_IO( & +! Filename, & +! netCDF = netCDF , & +! n_Frequencies = n_Frequencies , & +! n_Surface_Types = n_Surface_Types , & +! Release = Release , & +! Version = Version , & +! Title = Title , & +! History = History , & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! SEcategory data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! netCDF: Set this logical argument to access netCDF format +! SEcategory datafiles. +! If == .FALSE., file format is BINARY [DEFAULT]. +! == .TRUE., file format is NETCDF. +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! OPTIONAL OUTPUTS: +! n_Frequencies: The number of frequencies in the LUT. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Surface_Types: The number of surface types in +! the LUT. Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Release: The release number of the SEcategory file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Version: The version number of the SEcategory file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Title: Character string written into the TITLE global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 SEcategory_InquireFile_IO( & + Filename , & ! Input + netCDF , & ! Optional input + n_Frequencies , & ! Optional output + n_Surface_Types, & ! 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_Frequencies + INTEGER , OPTIONAL, INTENT(OUT) :: n_Surface_Types + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + 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 variables + LOGICAL :: Binary + + ! Set up + err_stat = SUCCESS + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + + ! Call the appropriate function + IF ( Binary ) THEN + err_stat = SEcategory_InquireFile( & + Filename , & + n_Frequencies = n_Frequencies , & + n_Surface_Types = n_Surface_Types, & + Release = Release , & + Version = Version ) + ELSE + err_stat = SEcategory_netCDF_InquireFile( & + Filename , & + n_Frequencies = n_Frequencies , & + n_Surface_Types = n_Surface_Types, & + Release = Release , & + Version = Version , & + Title = Title , & + History = History , & + Comment = Comment ) + END IF + + END FUNCTION SEcategory_InquireFile_IO + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! SEcategory_ReadFile_IO +! +! PURPOSE: +! Function to read SEcategory object files. +! +! CALLING SEQUENCE: +! Error_Status = SEcategory_ReadFile_IO( & +! SEcategory, & +! Filename, & +! netCDF = netCDF , & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! SEcategory data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! SEcategory: Object containing the IRwater coefficient data. +! UNITS: N/A +! TYPE: TYPE(SEcategory_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! OPTIONAL INPUTS: +! netCDF: Set this logical argument to access netCDF format +! SEcategory datafiles. +! If == .FALSE., file format is BINARY [DEFAULT]. +! == .TRUE., file format is NETCDF. +! 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 +! +! OPTIONAL OUTPUTS: +! Title: Character string written into the TITLE global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 SEcategory_ReadFile_IO( & + SEcategory, & ! Output + Filename , & ! Input + netCDF , & ! Optional 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(SEcategory_type), INTENT(OUT) :: SEcategory + CHARACTER(*), INTENT(IN) :: Filename + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + 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 variables + LOGICAL :: Binary + + ! Set up + err_stat = SUCCESS + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + !Call the appropriate function + IF ( Binary ) THEN + err_stat = SEcategory_ReadFile( & + SEcategory, & + Filename , & + No_Close , & + Quiet ) + ELSE + err_stat = SEcategory_netCDF_ReadFile( & + SEcategory, & + Filename , & + Quiet , & + Title , & + History , & + Comment , & + Debug ) + END IF + + END FUNCTION SEcategory_ReadFile_IO + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! SEcategory_WriteFile_IO +! +! PURPOSE: +! Function to write SEcategory object files. +! +! CALLING SEQUENCE: +! Error_Status = SEcategory_WriteFile_IO( & +! SEcategory, & +! Filename, & +! netCDF = netCDF , & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of the +! SEcategory data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! SEcategory: Object containing the IRwater coefficient data. +! UNITS: N/A +! TYPE: TYPE(SEcategory_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! netCDF: Set this logical argument to access netCDF format +! SEcategory datafiles. +! If == .FALSE., file format is BINARY [DEFAULT]. +! == .TRUE., file format is NETCDF. +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! No_Close: Set this logical argument to *NOT* close the datafile +! upon exiting this routine. This option is required if +! the SEcategory 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 +! +! Title: Character string written into the TITLE global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 data write was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!------------------------------------------------------------------------------ + FUNCTION SEcategory_WriteFile_IO( & + SEcategory, & ! Input + Filename , & ! Input + netCDF , & ! Optional 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(SEcategory_type), INTENT(IN) :: SEcategory + CHARACTER(*), INTENT(IN) :: Filename + LOGICAL, OPTIONAL, INTENT(IN) :: netCDF + 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 + ! Local variables + LOGICAL :: Binary + + ! Set up + err_stat = SUCCESS + ! ...Check netCDF argument + Binary = .TRUE. + IF ( PRESENT(netCDF) ) Binary = .NOT. netCDF + + ! Call the appropriate function + IF ( Binary ) THEN + err_stat = SEcategory_WriteFile( & + SEcategory, & + Filename , & + No_Close , & + Quiet , & + Title , & + History , & + Comment , & + Debug ) + ELSE + err_stat = SEcategory_netCDF_WriteFile( & + SEcategory, & + Filename , & + Quiet , & + Title , & + History , & + Comment , & + Debug ) + END IF + + END FUNCTION SEcategory_WriteFile_IO + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! SEcategory_netCDF_to_Binary +! +! PURPOSE: +! Function to convert a netCDF SEcategory file to Binary format. +! +! CALLING SEQUENCE: +! Error_Status = SEcategory_netCDF_to_Binary( & +! NC_Filename , & +! BIN_Filename , & +! Quiet = Quiet ) +! +! INPUTS: +! NC_Filename: Character string specifying the name of the +! netCDF format SEcategory data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! BIN_Filename: Character string specifying the name of the +! Binary format SEcategory data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! 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 conversion was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +! SIDE EFFECTS: +! - If the output file already exists, it is overwritten. +! - If an error occurs, the output file is deleted before +! returning to the calling routine. +! +!:sdoc-: +!------------------------------------------------------------------------------ + + FUNCTION SEcategory_netCDF_to_Binary( & + NC_Filename , & ! Input + BIN_Filename, & ! Input + Quiet ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: NC_Filename + CHARACTER(*), INTENT(IN) :: BIN_Filename + LOGICAL, OPTIONAL, INTENT(IN) :: Quiet + ! Function result + INTEGER :: err_stat + ! Function parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'SEcategory_netCDF_to_Binary' + ! Function variables + CHARACTER(256) :: msg + TYPE(SEcategory_type) :: cc, cc_copy + + ! Set up + err_stat = SUCCESS + + ! Read the netCDF file + err_stat = SEcategory_ReadFile_IO(cc, NC_Filename, Quiet = Quiet, netCDF = .TRUE. ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading netCDF file '//TRIM(NC_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Write the Binary file + err_stat = SEcategory_WriteFile_IO(cc, BIN_Filename, Quiet = Quiet ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error writing Binary file '//TRIM(BIN_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Check the write was successful + ! ...Read the Binary file + err_stat = SEcategory_ReadFile_IO(cc_copy, BIN_Filename, Quiet = Quiet) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading Binary file '//TRIM(BIN_Filename)//' for test' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! ...Compare the SEcategory objects + IF ( .NOT. (cc == cc_copy) ) THEN + msg = 'SEcategory object comparison failed.' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + END FUNCTION SEcategory_netCDF_to_Binary + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! SEcategory_Binary_to_netCDF +! +! PURPOSE: +! Function to convert a binary SEcategory file to Binary format. +! +! CALLING SEQUENCE: +! Error_Status = SEcategory_Binary_to_netCDF( & +! BIN_Filename , & +! NC_Filename , & +! Quiet = Quiet ) +! +! INPUTS: +! BIN_Filename: Character string specifying the name of the +! Binary format SEcategory data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! NC_Filename: Character string specifying the name of the +! netCDF format SEcategory data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! 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 conversion was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +! SIDE EFFECTS: +! - If the output file already exists, it is overwritten. +! - If an error occurs, the output file is deleted before +! returning to the calling routine. +! +!:sdoc-: +!------------------------------------------------------------------------------ + FUNCTION SEcategory_Binary_to_netCDF( & + BIN_Filename, & ! Input + NC_Filename , & ! Input + Quiet ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: BIN_Filename + CHARACTER(*), INTENT(IN) :: NC_Filename + LOGICAL, OPTIONAL, INTENT(IN) :: Quiet + ! Function result + INTEGER :: err_stat + ! Function parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'SEcategory_Binary_to_NetCDF' + ! Function variables + CHARACTER(256) :: msg + TYPE(SEcategory_type) :: cc, cc_copy + + ! Set up + err_stat = SUCCESS + + ! Read the Binary file + err_stat = SEcategory_ReadFile_IO(cc, BIN_Filename, Quiet = Quiet) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading Binary file '//TRIM(BIN_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Write the netCDF file + err_stat = SEcategory_WriteFile_IO(cc, NC_Filename, Quiet = Quiet, netCDF = .TRUE.) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error writing netCDF file '//TRIM(NC_Filename) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Check the write was successful + ! ...Read the netCDF file + err_stat = SEcategory_ReadFile_IO(cc_copy, NC_Filename, Quiet = Quiet, netCDF = .TRUE.) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading netCDF file '//TRIM(NC_Filename)//' for test' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! ...Compare the SEcategory objects + IF ( .NOT. (cc == cc_copy) ) THEN + msg = 'SEcategory object comparison failed.' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + END FUNCTION SEcategory_Binary_to_netCDF + +END MODULE SEcategory_IO diff --git a/src/Coefficients/EmisCoeff/SEcategory/SEcategory_Inspect/SEcategory_Inspect.f90 b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_Inspect/SEcategory_Inspect.f90 index 43ab00d..e19d70e 100644 --- a/src/Coefficients/EmisCoeff/SEcategory/SEcategory_Inspect/SEcategory_Inspect.f90 +++ b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_Inspect/SEcategory_Inspect.f90 @@ -28,7 +28,7 @@ PROGRAM SEcategory_Inspect ! Parameters ! ---------- CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'SEcategory_Inspect' - CHARACTER(*), PARAMETER :: PROGRAM_RCS_ID = & + !CHARACTER(*), PARAMETER :: PROGRAM_RCS_ID = & ! --------- ! Variables diff --git a/src/Coefficients/EmisCoeff/SEcategory/SEcategory_NC2BIN/SEcategory_NC2BIN.f90 b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_NC2BIN/SEcategory_NC2BIN.f90 new file mode 100644 index 0000000..e0889fe --- /dev/null +++ b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_NC2BIN/SEcategory_NC2BIN.f90 @@ -0,0 +1,73 @@ +! +! SEcategory_NC2BIN +! +! Program to convert a CRTM SEcategory data file +! from netCDF to Binary format +! +! +! CREATION HISTORY: +! Written by: Cheng Dang, 12-Feb-2022 +! dangch@ucar.edu + +PROGRAM SEcategory_NC2BIN + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module usage + USE Message_Handler , ONLY: SUCCESS, FAILURE, Program_Message, Display_Message + USE SignalFile_Utility , ONLY: Create_SignalFile + USE SEcategory_Define , ONLY: SEcategory_type + USE SEcategory_IO , ONLY: SEcategory_netCDF_to_Binary + ! Disable implicit typing + IMPLICIT NONE + + ! ---------- + ! Parameters + ! ---------- + CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'SEcategory_NC2BIN' + + ! --------- + ! Variables + ! --------- + INTEGER :: err_stat + CHARACTER(256) :: NC_Filename, BIN_Filename + + ! Program header + CALL Program_Message( PROGRAM_NAME, & + 'Program to convert a CRTM SEcategory data file '//& + 'from netCDF to Binary format.', & + '$Revision$') + ! Get the filenames + WRITE(*,FMT='(/5x,"Enter the INPUT netCDF SEcategory filename : ")', ADVANCE='NO') + READ(*,'(a)') NC_Filename + NC_Filename = ADJUSTL(NC_Filename) + WRITE(*,FMT='(/5x,"Enter the OUTPUT Binary SEcategory filename: ")', ADVANCE='NO') + READ(*,'(a)') BIN_Filename + BIN_Filename = ADJUSTL(BIN_Filename) + ! ...Sanity check that they're not the same + IF ( BIN_Filename == NC_Filename ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'SEcategory netCDF and Binary filenames are the same!', & + FAILURE ) + STOP + END IF + + ! Perform the conversion + err_stat = SEcategory_netCDF_to_Binary( NC_Filename, BIN_Filename ) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'SEcategory netCDF -> Binary conversion failed!', & + FAILURE ) + STOP + END IF + + ! Create a signal file indicating success + err_stat = Create_SignalFile( BIN_Filename ) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( PROGRAM_NAME, & + 'Error creating signal file for '//TRIM(BIN_Filename), & + FAILURE ) + END IF + +END PROGRAM SEcategory_NC2BIN diff --git a/src/Coefficients/EmisCoeff/SEcategory/SEcategory_NC2BIN/make.dependencies b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_NC2BIN/make.dependencies new file mode 100644 index 0000000..8a084a9 --- /dev/null +++ b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_NC2BIN/make.dependencies @@ -0,0 +1,15 @@ +SEcategory_Define.o : SEcategory_Define.f90 File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o Binary_File_Utility.o +SEcategory_netCDF_IO.o : SEcategory_netCDF_IO.f90 SEcategory_Define.o String_Utility.o File_Utility.o Message_Handler.o Type_Kinds.o +SEcategory_IO.o : SEcategory_IO.f90 SEcategory_netCDF_IO.o SEcategory_Define.o File_Utility.o Message_Handler.o Type_Kinds.o +SEcategory_NC2BIN.o : SEcategory_NC2BIN.f90 SEcategory_IO.o SEcategory_Define.o SignalFile_Utility.o Message_Handler.o +SEcategory_BIN2NC.o : SEcategory_BIN2NC.f90 SEcategory_IO.o SEcategory_Define.o SignalFile_Utility.o Message_Handler.o +Binary_File_Utility.o : Binary_File_Utility.f90 Endian_Utility.o Message_Handler.o File_Utility.o Type_Kinds.o +Compare_Float_Numbers.o : Compare_Float_Numbers.f90 Type_Kinds.o +Endian_Utility.o : Endian_Utility.f90 Type_Kinds.o +File_Utility.o : File_Utility.f90 +Fundamental_Constants.o : Fundamental_Constants.f90 Type_Kinds.o +Message_Handler.o : Message_Handler.f90 File_Utility.o +SignalFile_Utility.o : SignalFile_Utility.f90 Message_Handler.o File_Utility.o +Fundamental_Constants.o Type_Kinds.o +String_Utility.o : String_Utility.f90 +Type_Kinds.o : Type_Kinds.f90 diff --git a/src/Coefficients/EmisCoeff/SEcategory/SEcategory_netCDF_IO.f90 b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_netCDF_IO.f90 new file mode 100644 index 0000000..76971f2 --- /dev/null +++ b/src/Coefficients/EmisCoeff/SEcategory/SEcategory_netCDF_IO.f90 @@ -0,0 +1,1306 @@ +! +! SEcategory_netCDF_IO +! +! Module containing routines to read and write SEcategory netCDF +! format files. +! +! +! CREATION HISTORY: +! +! Written by: Cheng Dang, 12-Feb-2022 +! dangch@ucar.edu + +MODULE SEcategory_netCDF_IO + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module use + USE Type_Kinds , ONLY: fp, Double, Long + USE Message_Handler , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message + USE File_Utility , ONLY: File_Exists + USE String_Utility , ONLY: StrClean + USE SEcategory_Define , ONLY: SEcategory_type , & + SEcategory_Associated , & + SEcategory_Destroy , & + SEcategory_Create , & + SEcategory_Inspect , & + SEcategory_ValidRelease , & + SEcategory_Info , & + SEcategory_Name , & + SEcategory_Index + USE netcdf + ! Disable implicit typing + IMPLICIT NONE + + + ! ------------ + ! Visibilities + ! ------------ + ! Everything private by default + PRIVATE + ! Procedures + PUBLIC :: SEcategory_netCDF_InquireFile + PUBLIC :: SEcategory_netCDF_ReadFile + PUBLIC :: SEcategory_netCDF_WriteFile + + ! ----------------- + ! Module parameters + ! ----------------- + ! Default msg string length + INTEGER, PARAMETER :: ML = 1024 + ! Literal constants + REAL(fp), PARAMETER :: FILL_FLOAT = -999.0_fp + INTEGER , PARAMETER :: INT_ZERO = 0 + INTEGER , PARAMETER :: INT_ONE = 1 + + ! Global attribute names. Case sensitive + CHARACTER(*), PARAMETER :: RELEASE_GATTNAME = 'Release' + CHARACTER(*), PARAMETER :: VERSION_GATTNAME = 'Version' + CHARACTER(*), PARAMETER :: DATA_SOURCE_GATTNAME = 'Data_Source' + CHARACTER(*), PARAMETER :: TITLE_GATTNAME = 'Title' + CHARACTER(*), PARAMETER :: HISTORY_GATTNAME = 'History' + CHARACTER(*), PARAMETER :: COMMENT_GATTNAME = 'Comment' + CHARACTER(*), PARAMETER :: DATATYPE_NAME_GATTNAME = 'Datatype_Name' + CHARACTER(*), PARAMETER :: CLASSIFICATION_NAME_GATTNAME = 'Classification_Name' + + + ! Dimension names + CHARACTER(*), PARAMETER :: TNSL_DIMNAME = 'String_Length' + CHARACTER(*), PARAMETER :: FREQUENCY_DIMNAME = 'n_Frequencies' + CHARACTER(*), PARAMETER :: TYPE_DIMNAME = 'n_Surface_Types' + + ! Variable names + CHARACTER(*), PARAMETER :: REFLECTANCE_VARNAME = 'Reflectance' + CHARACTER(*), PARAMETER :: FREQUENCY_VARNAME = 'Frequency' + CHARACTER(*), PARAMETER :: TYPE_VARNAME = 'Surface_Type' + CHARACTER(*), PARAMETER :: TYPE_ISVALID_VARNAME = 'Surface_Type_IsValid' + + ! Variable long name attribute. + CHARACTER(*), PARAMETER :: LONGNAME_ATTNAME = 'long_name' + CHARACTER(*), PARAMETER :: REFLECTANCE_LONGNAME = 'Reflectance' + CHARACTER(*), PARAMETER :: FREQUENCY_LONGNAME = 'Frequency' + CHARACTER(*), PARAMETER :: TYPE_LONGNAME = 'Surface Type' + CHARACTER(*), PARAMETER :: TYPE_ISVALID_LONGNAME = 'Surface Type IsValid' + + ! Variable description attribute. + CHARACTER(*), PARAMETER :: DESCRIPTION_ATTNAME = 'description' + CHARACTER(*), PARAMETER :: REFLECTANCE_DESCRIPTION = 'Reflectance' + CHARACTER(*), PARAMETER :: FREQUENCY_DESCRIPTION = 'Frequency' + CHARACTER(*), PARAMETER :: TYPE_DESCRIPTION = 'Surface Type' + CHARACTER(*), PARAMETER :: TYPE_ISVALID_DESCRIPTION = 'Surface Type IsValid' + + ! Variable units attribute. + CHARACTER(*), PARAMETER :: UNITS_ATTNAME = 'units' + CHARACTER(*), PARAMETER :: REFLECTANCE_UNITS = 'N/A' + CHARACTER(*), PARAMETER :: FREQUENCY_UNITS = 'cm^-1' + CHARACTER(*), PARAMETER :: TYPE_UNITS = 'N/A' + CHARACTER(*), PARAMETER :: TYPE_ISVALID_UNITS = 'N/A' + + ! Variable _FillValue attribute. + CHARACTER(*), PARAMETER :: FILLVALUE_ATTNAME = '_FillValue' + REAL(Double), PARAMETER :: REFLECTANCE_FILLVALUE = FILL_FLOAT + REAL(Double), PARAMETER :: FREQUENCY_FILLVALUE = FILL_FLOAT + CHARACTER(*), PARAMETER :: TYPE_FILLVALUE = NF90_FILL_CHAR + INTEGER , PARAMETER :: TYPE_ISVALID_FILLVALUE = INT_ZERO + + ! Variable types + INTEGER, PARAMETER :: REFLECTANCE_TYPE = NF90_DOUBLE + INTEGER, PARAMETER :: FREQUENCY_TYPE = NF90_DOUBLE + INTEGER, PARAMETER :: TYPE_TYPE = NF90_CHAR + INTEGER, PARAMETER :: TYPE_ISVALID_TYPE = NF90_INT + +CONTAINS + + +!################################################################################ +!################################################################################ +!## ## +!## ## PUBLIC MODULE ROUTINES ## ## +!## ## +!################################################################################ +!################################################################################ +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! SEcategory_netCDF_InquireFile +! +! PURPOSE: +! Function to inquire SEcategory object files. +! +! CALLING SEQUENCE: +! Error_Status = SEcategory_netCDF_InquireFile( & +! Filename, & +! netCDF = netCDF , & +! n_Frequencies = n_Frequencies , & +! n_Surface_Types = n_Surface_Types , & +! Release = Release , & +! Version = Version , & +! Title = Title , & +! History = History , & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! SEcategory data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! netCDF: Set this logical argument to access netCDF format +! SEcategory datafiles. +! If == .FALSE., file format is BINARY [DEFAULT]. +! == .TRUE., file format is NETCDF. +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! OPTIONAL OUTPUTS: +! n_Frequencies: The number of frequencies in the LUT. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! n_Surface_Types: The number of surface types in +! the LUT. Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Release: The release number of the SEcategory file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Version: The version number of the SEcategory file. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Title: Character string written into the TITLE global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 SEcategory_netCDF_InquireFile( & + Filename , & ! Input + n_Frequencies , & ! Optional output + n_Surface_Types , & ! 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_Frequencies + INTEGER , OPTIONAL, INTENT(OUT) :: n_Surface_Types + 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 = 'SEcategory_netCDF_InquireFile' + ! Function variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + INTEGER :: NF90_Status + INTEGER :: FileId + INTEGER :: DimId + TYPE(SEcategory_type) :: SEcategory + + ! Set up + err_stat = SUCCESS + Close_File = .FALSE. + + ! Open the file + NF90_Status = NF90_OPEN( Filename,NF90_NOWRITE,FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error opening '//TRIM(Filename)//' for read access - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Get the dimensions + ! ...n_Frequencies dimension + NF90_Status = NF90_INQ_DIMID( FileId,FREQUENCY_DIMNAME,DimId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring dimension ID for '//FREQUENCY_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + NF90_Status = NF90_INQUIRE_DIMENSION( FileId,DimId,Len=SEcategory%n_Frequencies ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading dimension value for '//FREQUENCY_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + ! ...n_Surface_Types dimension + NF90_Status = NF90_INQ_DIMID( FileId,TYPE_DIMNAME,DimId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring dimension ID for '//TYPE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + NF90_Status = NF90_INQUIRE_DIMENSION( FileId,DimId,Len=SEcategory%n_Surface_Types ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading dimension value for '//TYPE_DIMNAME//' - '// & + TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + + ! Get the global attributes + err_stat = ReadGAtts( Filename, & + FileId , & + Release = SEcategory%Release, & + Version = SEcategory%Version, & + Title = Title , & + History = History, & + Comment = Comment ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading global attributes from '//TRIM(Filename) + CALL Inquire_Cleanup(); RETURN + END IF + + ! Close the file + NF90_Status = NF90_CLOSE( FileId ) + Close_File = .FALSE. + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error closing input file - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Inquire_Cleanup(); RETURN + END IF + + ! Set the return values + IF ( PRESENT(n_Frequencies ) ) n_Frequencies = SEcategory%n_Frequencies + IF ( PRESENT(n_Surface_Types ) ) n_Surface_Types = SEcategory%n_Surface_Types + IF ( PRESENT(Release ) ) Release = SEcategory%Release + IF ( PRESENT(Version ) ) Version = SEcategory%Version + + CONTAINS + + SUBROUTINE Inquire_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing input file during error cleanup.' + END IF + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Inquire_CleanUp + + END FUNCTION SEcategory_netCDF_InquireFile + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! SEcategory_netCDF_WriteFile +! +! PURPOSE: +! Function to write SEcategory object files. +! +! CALLING SEQUENCE: +! Error_Status = SEcategory_netCDF_WriteFile( & +! SEcategory, & +! Filename, & +! netCDF = netCDF , & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment ) +! +! INPUTS: +! SEcategory: Object containing the IRwater coefficient data. +! UNITS: N/A +! TYPE: TYPE(SEcategory_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Filename: Character string specifying the name of the +! SEcategory data file to write. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! netCDF: Set this logical argument to access netCDF format +! SEcategory datafiles. +! If == .FALSE., file format is BINARY [DEFAULT]. +! == .TRUE., file format is NETCDF. +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! No_Close: Set this logical argument to *NOT* close the datafile +! upon exiting this routine. This option is required if +! the SEcategory 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 +! +! Title: Character string written into the TITLE global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 data write was successful +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!------------------------------------------------------------------------------ + FUNCTION SEcategory_netCDF_WriteFile( & + SEcategory, & + Filename , & + Quiet , & + Title , & + History , & + Comment , & + Debug ) & + RESULT( err_stat ) + ! Arguments + TYPE(SEcategory_type), INTENT(IN) :: SEcategory + CHARACTER(*), INTENT(IN) :: Filename + 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 + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'SEcategory_netCDF_WriteFile' + ! Local variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + LOGICAL :: Noisy + INTEGER :: NF90_Status + INTEGER :: FileId + INTEGER :: VarId + INTEGER :: i + INTEGER :: AllocateStatus + INTEGER, ALLOCATABLE :: INT_Surface_Type_IsValid(:) + + + ! Set up + err_stat = SUCCESS + Close_File = .FALSE. + ! ...Check structure pointer association status + IF ( .NOT. SEcategory_Associated( SEcategory ) ) THEN + msg = 'SEcategory structure is empty. Nothing to do!' + CALL Write_CleanUp(); RETURN + END IF + ! ...Check if release is valid + IF ( .NOT. SEcategory_ValidRelease( SEcategory ) ) THEN + msg = 'SEcategory Release check failed.' + CALL Write_Cleanup(); RETURN + END IF + ! ...Check Quiet argument + Noisy = .TRUE. + IF ( PRESENT(Quiet) ) Noisy = .NOT. Quiet + + ! Create the output file + err_stat = CreateFile( & + Filename , & ! Input + SEcategory%n_Frequencies , & ! Input + SEcategory%n_Surface_Types , & ! Input + FileId , & ! Output + Version = SEcategory%Version , & ! Optional input + Classification_Name = SEcategory%Classification_Name , & ! Optional input, required for IR land + Title = Title , & ! Optional input + History = History , & ! Optional input + Comment = Comment ) ! Optional input + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error creating output file '//TRIM(Filename) + CALL Write_Cleanup(); RETURN + END IF + + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Write the data items + ! ...Surface Type variable + NF90_Status = NF90_INQ_VARID( FileId,TYPE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//TYPE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,SEcategory%Surface_Type ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//TYPE_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + ! ...Frequency variable + NF90_Status = NF90_INQ_VARID( FileId,FREQUENCY_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//FREQUENCY_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,SEcategory%Frequency ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//FREQUENCY_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + ! ...Reflectance variable + NF90_Status = NF90_INQ_VARID( FileId,REFLECTANCE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//REFLECTANCE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,SEcategory%Reflectance ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//REFLECTANCE_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + !...Surface Type IsValid variable + !...Convert LOGICAL variable to INTEGER for netCDF I/O + ALLOCATE(INT_Surface_Type_IsValid(SEcategory%n_Surface_Types)) + DO i = 1, SEcategory%n_Surface_Types + IF (SEcategory%Surface_Type_IsValid(i)) THEN + INT_Surface_Type_IsValid(i) = INT_ONE + ELSE + INT_Surface_Type_IsValid(i) = INT_ZERO + END IF + END DO + NF90_Status = NF90_INQ_VARID( FileId,TYPE_ISVALID_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//TYPE_ISVALID_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + NF90_Status = NF90_PUT_VAR( FileId,VarId,INT_Surface_Type_IsValid ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error writing '//TYPE_ISVALID_VARNAME//' to '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + DEALLOCATE(INT_Surface_Type_IsValid) + + ! Close the file + NF90_Status = NF90_CLOSE( FileId ) + Close_File = .FALSE. + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error closing output file - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Write_Cleanup(); RETURN + END IF + + ! Output an info message + IF ( Noisy ) THEN + CALL SEcategory_Info( SEcategory, msg ) + CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION ) + END IF + + CONTAINS + + SUBROUTINE Write_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing output file during error cleanup - '//& + TRIM(NF90_STRERROR( NF90_Status )) + END IF + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Write_CleanUp + + END FUNCTION SEcategory_netCDF_WriteFile + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! SEcategory_netCDF_ReadFile +! +! PURPOSE: +! Function to read SEcategory object files. +! +! CALLING SEQUENCE: +! Error_Status = SEcategory_netCDF_ReadFile( & +! SEcategory, & +! Filename, & +! Quiet = Quiet , & +! Title = Title , & +! History = History, & +! Comment = Comment ) +! +! INPUTS: +! Filename: Character string specifying the name of a +! SEcategory data file to read. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! SEcategory: Object containing the IRwater coefficient data. +! UNITS: N/A +! TYPE: TYPE(SEcategory_type) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! OPTIONAL INPUTS: +! 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 +! +! OPTIONAL OUTPUTS: +! Title: Character string written into the TITLE global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! History: Character string written into the HISTORY global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Comment: Character string written into the COMMENT global +! attribute field of the SEcategory file. +! This argument is ignored if the netCDF argument +! is not supplied or set. +! UNITS: N/A +! TYPE: CHARACTER(*) +! 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 SEcategory_netCDF_ReadFile( & + SEcategory , & ! Output + Filename , & ! Input + Quiet , & ! Optional input + Title , & ! Optional output + History , & ! Optional output + Comment , & ! Optional output + Debug ) & ! Optional input (Debug output control) + RESULT( err_stat ) + ! Arguments + TYPE(SEcategory_type), INTENT(OUT) :: SEcategory + CHARACTER(*), INTENT(IN) :: Filename + 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 = 'SEcategory_netCDF_ReadFile' + ! Function variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + LOGICAL :: Noisy + INTEGER :: NF90_Status + INTEGER :: FileId + INTEGER :: n_Frequencies + INTEGER :: n_Surface_Types + INTEGER :: VarId + INTEGER :: AllocateStatus + INTEGER :: i + INTEGER, ALLOCATABLE :: INT_Surface_Type_IsValid(:) + + ! Set up + err_stat = SUCCESS + Close_File = .FALSE. + ! ...Check that the file exists + IF ( .NOT. File_Exists(Filename) ) THEN + msg = 'File '//TRIM(Filename)//' not found.' + CALL Read_Cleanup(); RETURN + END IF + ! ...Check Quiet argument + Noisy = .TRUE. + IF ( PRESENT(Quiet) ) Noisy = .NOT. Quiet + + ! Inquire the file to get the dimensions + err_stat = SEcategory_netCDF_InquireFile( & + Filename , & + n_Frequencies = n_Frequencies , & + n_Surface_Types = n_Surface_Types ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error obtaining SEcategory dimensions from '//TRIM(Filename) + CALL Read_Cleanup(); RETURN + END IF + + ! Allocate the output structure + CALL SEcategory_Create( & + SEcategory , & + n_Frequencies , & + n_Surface_Types ) + IF ( .NOT. SEcategory_Associated( SEcategory ) ) THEN + msg = 'SEcategory object allocation failed.' + CALL Read_Cleanup(); RETURN + END IF + + + ! Open the file for reading + NF90_Status = NF90_OPEN( Filename,NF90_NOWRITE,FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error opening '//TRIM(Filename)//' for read access - '//& + TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Read the global attributes + err_stat = ReadGAtts( Filename, & + FileID , & + Release = SEcategory%Release , & + Version = SEcategory%Version , & + Classification_Name = SEcategory%Classification_Name, & + Title = Title , & + History = History , & + Comment = Comment ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error reading global attribute from '//TRIM(Filename) + CALL Read_Cleanup(); RETURN + END IF + ! ...Check if release is valid + IF ( .NOT. SEcategory_ValidRelease( SEcategory ) ) THEN + msg = 'SEcategory Release check failed.' + CALL Read_Cleanup(); RETURN + END IF + + ! Read the SEcategory data + ! ...Surface Type variable + NF90_Status = NF90_INQ_VARID( FileId,TYPE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//TYPE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,SEcategory%Surface_Type ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//TYPE_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Frequency variable + NF90_Status = NF90_INQ_VARID( FileId,FREQUENCY_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//FREQUENCY_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,SEcategory%Frequency ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//FREQUENCY_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + ! ...Reflectance variable + NF90_Status = NF90_INQ_VARID( FileId,REFLECTANCE_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//REFLECTANCE_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,SEcategory%Reflectance ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//REFLECTANCE_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + !...Surface Type IsValid variable + ALLOCATE(INT_Surface_Type_IsValid(SEcategory%n_Surface_Types)) + NF90_Status = NF90_INQ_VARID( FileId,TYPE_ISVALID_VARNAME,VarId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error inquiring '//TRIM(Filename)//' for '//TYPE_ISVALID_VARNAME//& + ' variable ID - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + NF90_Status = NF90_GET_VAR( FileId,VarId,INT_Surface_Type_IsValid ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error reading '//TYPE_ISVALID_VARNAME//' from '//TRIM(Filename)//& + ' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + !...Convert INTEGER to LOGICAL variable to INTEGER for SEcategory + DO i = 1, SEcategory%n_Surface_Types + IF (INT_Surface_Type_IsValid(i) == INT_ONE ) THEN + SEcategory%Surface_Type_IsValid(i) = .TRUE. + ELSE + SEcategory%Surface_Type_IsValid(i) = .FALSE. + END IF + END DO + DEALLOCATE(INT_Surface_Type_IsValid) + + ! Close the file + NF90_Status = NF90_CLOSE( FileId ); Close_File = .FALSE. + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error closing output file - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Read_Cleanup(); RETURN + END IF + + ! Output an info message + IF ( Noisy ) THEN + CALL SEcategory_Info( SEcategory, msg ) + CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION ) + END IF + + CONTAINS + + SUBROUTINE Read_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing input file during error cleanup- '//& + TRIM(NF90_STRERROR( NF90_Status )) + END IF + CALL SEcategory_Destroy( SEcategory ) + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Read_CleanUp + + END FUNCTION SEcategory_netCDF_ReadFile + + +!################################################################################## +!################################################################################## +!## ## +!## ## PRIVATE MODULE ROUTINES ## ## +!## ## +!################################################################################## +!################################################################################## + + ! Function to write the global attributes to a SEcategory data file. + + FUNCTION WriteGAtts( & + Filename , & ! Input + FileId , & ! Input + Version , & ! Optional input + Classification_Name , & ! Optional input + Title , & ! Optional input + History , & ! Optional input + Comment ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: Filename + INTEGER , INTENT(IN) :: FileId + INTEGER , OPTIONAL, INTENT(IN) :: Version + CHARACTER(*), OPTIONAL, INTENT(IN) :: Classification_Name + CHARACTER(*), OPTIONAL, INTENT(IN) :: Title + CHARACTER(*), OPTIONAL, INTENT(IN) :: History + CHARACTER(*), OPTIONAL, INTENT(IN) :: Comment + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'SEcategory_WriteGAtts(netCDF)' + CHARACTER(*), PARAMETER :: WRITE_MODULE_HISTORY_GATTNAME = 'write_module_history' + CHARACTER(*), PARAMETER :: CREATION_DATE_AND_TIME_GATTNAME = 'creation_date_and_time' + ! Local variables + CHARACTER(ML) :: msg + CHARACTER(ML) :: GAttName + CHARACTER(8) :: cdate + CHARACTER(10) :: ctime + CHARACTER(5) :: czone + CHARACTER(ML) :: CLSname + INTEGER :: Ver + INTEGER :: NF90_Status + TYPE(SEcategory_type) :: SEcategory + + ! Set up + err_stat = SUCCESS + msg = ' ' + + ! Mandatory global attributes + ! ...Software ID + !GAttName = WRITE_MODULE_HISTORY_GATTNAME + !NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),MODULE_VERSION_ID ) + !IF ( NF90_Status /= NF90_NOERR ) THEN + ! CALL WriteGAtts_Cleanup(); RETURN + !END IF + ! ...Creation date + CALL DATE_AND_TIME( cdate, ctime, czone ) + GAttName = CREATION_DATE_AND_TIME_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName), & + cdate(1:4)//'/'//cdate(5:6)//'/'//cdate(7:8)//', '// & + ctime(1:2)//':'//ctime(3:4)//':'//ctime(5:6)//' '// & + czone//'UTC' ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + ! ...The Release + GAttName = RELEASE_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),SEcategory%Release ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + + ! Optional global attributes + ! ...The Version + IF ( PRESENT(Version) ) THEN + Ver = Version + ELSE + Ver = SEcategory%Version + END IF + GAttName = VERSION_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),Ver ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + ! ...The Classification_Name, required for IR land + IF ( PRESENT(Classification_Name) ) THEN + CLSname = Classification_Name + ELSE + CLSname = SEcategory%Classification_Name + END IF + GAttName = CLASSIFICATION_NAME_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),CLSname ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + ! ...The title + IF ( PRESENT(title) ) THEN + GAttName = TITLE_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),title ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The history + IF ( PRESENT(history) ) THEN + GAttName = HISTORY_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),history ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The comment + IF ( PRESENT(comment) ) THEN + GAttName = COMMENT_GATTNAME + NF90_Status = NF90_PUT_ATT( FileId,NF90_GLOBAL,TRIM(GAttName),comment ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL WriteGAtts_Cleanup(); RETURN + END IF + END IF + + CONTAINS + + SUBROUTINE WriteGAtts_CleanUp() + NF90_Status = NF90_CLOSE( FileId ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = '; Error closing input file during error cleanup - '//& + TRIM(NF90_STRERROR( NF90_Status ) ) + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME, & + 'Error writing '//TRIM(GAttName)//' attribute to '//& + TRIM(Filename)//' - '// & + TRIM(NF90_STRERROR( NF90_Status ) )//TRIM(msg), & + err_stat ) + END SUBROUTINE WriteGAtts_CleanUp + + END FUNCTION WriteGAtts + + ! Function to read the global attributes from a SEcategory data file. + + FUNCTION ReadGAtts(& + Filename , & ! Input + FileId , & ! Input + Release , & ! Optional output + Version , & ! Optional output + Classification_Name , & ! Optional output + Title , & ! Optional output + History , & ! Optional output + Comment ) & ! Optional output + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: Filename + INTEGER , INTENT(IN) :: FileId + INTEGER , OPTIONAL, INTENT(OUT) :: Release + INTEGER , OPTIONAL, INTENT(OUT) :: Version + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Classification_Name + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title + CHARACTER(*), OPTIONAL, INTENT(OUT) :: History + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Comment + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'SEcategory_ReadGAtts(netCDF)' + ! Local variables + CHARACTER(ML) :: msg + CHARACTER(256) :: GAttName + CHARACTER(5000) :: GAttString + INTEGER :: NF90_Status + + ! Set up + err_stat = SUCCESS + + ! The global attributes + ! ...The Release + IF ( PRESENT(Release) ) THEN + GAttName = RELEASE_GATTNAME + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),Release ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The Version + IF ( PRESENT(Version) ) THEN + GAttName = VERSION_GATTNAME + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),Version ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + END IF + ! ...The Classification Name + IF ( PRESENT(Classification_Name) ) THEN + GAttName = CLASSIFICATION_NAME_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + Classification_Name = GAttString(1:MIN(LEN(Classification_Name), LEN_TRIM(GAttString))) + END IF + ! ...The title + IF ( PRESENT(title) ) THEN + GAttName = TITLE_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + title = GAttString(1:MIN(LEN(title), LEN_TRIM(GAttString))) + END IF + ! ...The history + IF ( PRESENT(history) ) THEN + GAttName = HISTORY_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + history = GAttString(1:MIN(LEN(history), LEN_TRIM(GAttString))) + END IF + ! ...The comment + IF ( PRESENT(comment) ) THEN + GAttName = COMMENT_GATTNAME; GAttString = '' + NF90_Status = NF90_GET_ATT( FileID,NF90_GLOBAL,TRIM(GAttName),GAttString ) + IF ( NF90_Status /= NF90_NOERR ) THEN + CALL ReadGAtts_Cleanup(); RETURN + END IF + CALL StrClean( GAttString ) + comment = GAttString(1:MIN(LEN(comment), LEN_TRIM(GAttString))) + END IF + + CONTAINS + + SUBROUTINE ReadGAtts_CleanUp() + err_stat = FAILURE + msg = 'Error reading '//TRIM(GAttName)//' attribute from '//TRIM(Filename)//' - '// & + TRIM(NF90_STRERROR( NF90_Status ) ) + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + END SUBROUTINE ReadGAtts_CleanUp + + END FUNCTION ReadGAtts + + FUNCTION CreateFile( & + Filename , & ! Input + n_Frequencies , & ! Input + n_Surface_Types , & ! Input + FileId , & ! Output + Version , & ! Optional input + Classification_Name , & ! Optional input + Title , & ! Optional input + History , & ! Optional input + Comment ) & ! Optional input + RESULT( err_stat ) + ! Arguments + CHARACTER(*), INTENT(IN) :: Filename + INTEGER , INTENT(IN) :: n_Frequencies + INTEGER , INTENT(IN) :: n_Surface_Types + INTEGER , INTENT(OUT) :: FileId + INTEGER , OPTIONAL, INTENT(IN) :: Version + CHARACTER(*), OPTIONAL, INTENT(IN) :: Classification_Name + CHARACTER(*), OPTIONAL, INTENT(IN) :: Title + CHARACTER(*), OPTIONAL, INTENT(IN) :: History + CHARACTER(*), OPTIONAL, INTENT(IN) :: Comment + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'SEcategory_CreateFile(netCDF)' + ! Local variables + CHARACTER(ML) :: msg + LOGICAL :: Close_File + INTEGER :: NF90_Status + INTEGER :: n_Frequencies_DimID + INTEGER :: n_Surface_Types_DimID + INTEGER :: tnsl_DimID + INTEGER :: varID + INTEGER :: Put_Status(4) + TYPE(SEcategory_type) :: dummy + + ! Setup + err_stat = SUCCESS + Close_File = .FALSE. + + ! Create the data file + NF90_Status = NF90_CREATE( Filename,NF90_CLOBBER,FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error creating '//TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + ! ...Close the file if any error from here on + Close_File = .TRUE. + + ! Define the dimensions + ! ...Number of frequencies + NF90_Status = NF90_DEF_DIM( FileID,FREQUENCY_DIMNAME,n_Frequencies,n_Frequencies_DimID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//FREQUENCY_DIMNAME//' dimension in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + ! ...Number of surface types + NF90_Status = NF90_DEF_DIM( FileID,TYPE_DIMNAME,n_Surface_Types,n_Surface_Types_DimID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//TYPE_DIMNAME//' dimension in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + ! ...Type_Name string length + CALL SEcategory_Create(dummy,0,1) ! Only n_Types dimension non-zero + NF90_Status = NF90_DEF_DIM( FileID,TNSL_DIMNAME,LEN(dummy%Surface_Type(1)),tnsl_DimID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//TNSL_DIMNAME//' dimension in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + CALL SEcategory_Destroy(dummy) + + ! Write the global attributes + err_stat = WriteGAtts( Filename , & + FileId , & + Version = Version , & + Classification_Name = Classification_Name , & + Title = Title , & + History = History , & + Comment = Comment ) + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error writing global attribute to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + + ! Define the variables + ! ...Surface Type variable + NF90_Status = NF90_DEF_VAR( FileID, & + TYPE_VARNAME, & + TYPE_TYPE, & + dimIDs=(/tnsl_DimID, n_Surface_Types_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//TYPE_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,TYPE_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,TYPE_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,TYPE_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,TYPE_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//TYPE_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + !...Surface Type IsValid variable + NF90_Status = NF90_DEF_VAR( FileID, & + TYPE_ISVALID_VARNAME, & + TYPE_ISVALID_TYPE, & + dimIDs=(/n_Surface_Types_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//TYPE_ISVALID_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,TYPE_ISVALID_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,TYPE_ISVALID_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,TYPE_ISVALID_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,TYPE_ISVALID_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//TYPE_ISVALID_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + ! ...Frequency variable + NF90_Status = NF90_DEF_VAR( FileID, & + FREQUENCY_VARNAME, & + FREQUENCY_TYPE, & + dimIDs=(/n_Frequencies_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//FREQUENCY_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,FREQUENCY_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,FREQUENCY_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,FREQUENCY_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,FREQUENCY_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//FREQUENCY_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + ! ...Reflectance variable + NF90_Status = NF90_DEF_VAR( FileID, & + REFLECTANCE_VARNAME, & + REFLECTANCE_TYPE, & + dimIDs=(/n_Frequencies_DimID, n_Surface_Types_DimID/), & + varID=VarID ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error defining '//REFLECTANCE_VARNAME//' variable in '//& + TRIM(Filename)//' - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + Put_Status(1) = NF90_PUT_ATT( FileID,VarID,LONGNAME_ATTNAME ,REFLECTANCE_LONGNAME ) + Put_Status(2) = NF90_PUT_ATT( FileID,VarID,DESCRIPTION_ATTNAME,REFLECTANCE_DESCRIPTION ) + Put_Status(3) = NF90_PUT_ATT( FileID,VarID,UNITS_ATTNAME ,REFLECTANCE_UNITS ) + Put_Status(4) = NF90_PUT_ATT( FileID,VarID,FILLVALUE_ATTNAME ,REFLECTANCE_FILLVALUE ) + IF ( ANY(Put_Status /= NF90_NOERR) ) THEN + msg = 'Error writing '//REFLECTANCE_VARNAME//' variable attributes to '//TRIM(Filename) + CALL Create_Cleanup(); RETURN + END IF + + ! Take netCDF file out of define mode + NF90_Status = NF90_ENDDEF( FileId ) + IF ( NF90_Status /= NF90_NOERR ) THEN + msg = 'Error taking file '//TRIM(Filename)// & + ' out of define mode - '//TRIM(NF90_STRERROR( NF90_Status )) + CALL Create_Cleanup(); RETURN + END IF + + CONTAINS + + SUBROUTINE Create_CleanUp() + IF ( Close_File ) THEN + NF90_Status = NF90_CLOSE( FileID ) + IF ( NF90_Status /= NF90_NOERR ) & + msg = TRIM(msg)//'; Error closing input file during error cleanup - '//& + TRIM(NF90_STRERROR( NF90_Status )) + END IF + err_stat = FAILURE + CALL Display_Message( ROUTINE_NAME,msg,err_stat ) + END SUBROUTINE Create_CleanUp + + END FUNCTION CreateFile + +END MODULE SEcategory_netCDF_IO diff --git a/src/RTSolution/RTV_Define.f90 b/src/RTSolution/RTV_Define.f90 index 3cfb2be..9efe2a2 100644 --- a/src/RTSolution/RTV_Define.f90 +++ b/src/RTSolution/RTV_Define.f90 @@ -452,6 +452,18 @@ SUBROUTINE RTV_Create( & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN + ! zero items after allocation to prevent underflow / overflow issues + RTV%Pff = ZERO + RTV%Pbb = ZERO + RTV%Pplus = ZERO + RTV%Pminus = ZERO + RTV%Pleg = ZERO + RTV%Off = ZERO + RTV%Obb = ZERO + RTV%n_Factor = ZERO + RTV%sum_fac = ZERO + + ! Perform the allocation for adding-doubling variables ALLOCATE( RTV%Inv_Gamma( nZ, nZ, n_Layers) , & RTV%Inv_GammaT(nZ, nZ, n_Layers) , & @@ -465,6 +477,18 @@ SUBROUTINE RTV_Create( & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN + ! zero items after allocation + RTV%Inv_Gamma = ZERO + RTV%Inv_GammaT = ZERO + RTV%Refl_Trans = ZERO + RTV%s_Layer_Trans = ZERO + RTV%s_Layer_Refl = ZERO + RTV%s_Level_Refl_UP = ZERO + RTV%s_Level_Rad_UP = ZERO + RTV%s_Layer_Source_UP = ZERO + RTV%s_Layer_Source_DOWN = ZERO + + ! Perform the allocation for AMOM variables ALLOCATE( RTV%Thermal_C(nZ, n_Layers) , & RTV%EigVa(nZ, n_Layers) , & @@ -493,6 +517,33 @@ SUBROUTINE RTV_Create( & RTV%i_Gm_A5(nZ, nZ, n_Layers), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN + + ! zero items after allocation + RTV%Thermal_C = ZERO + RTV%EigVa = ZERO + RTV%Exp_x = ZERO + RTV%EigValue = ZERO + RTV%HH = ZERO + RTV%PM = ZERO + RTV%PP = ZERO + RTV%PPM = ZERO + RTV%PPP = ZERO + RTV%i_PPM = ZERO + RTV%i_PPP = ZERO + RTV%EigVe = ZERO + RTV%Gm = ZERO + RTV%i_Gm = ZERO + RTV%Gp = ZERO + RTV%EigVeF = ZERO + RTV%EigVeVa = ZERO + RTV%A1 = ZERO + RTV%A2 = ZERO + RTV%A3 = ZERO + RTV%A4 = ZERO + RTV%A5 = ZERO + RTV%A6 = ZERO + RTV%Gm_A5 = ZERO + RTV%i_Gm_A5 = ZERO ! Perform the allocation for SOI variables ALLOCATE( RTV%e_Layer_Trans( nZ, n_Layers), & @@ -510,6 +561,21 @@ SUBROUTINE RTV_Create( & RTV%Source_down(nZ, 0:MAX_N_DOUBLING, n_Layers), & STAT = alloc_stat ) + RTV%e_Layer_Trans = ZERO + RTV%s_Level_IterRad_DOWN = ZERO + RTV%s_Level_IterRad_UP = ZERO + RTV%EXPFACT = ZERO + RTV%Number_Doubling = ZERO + RTV%Delta_Tau = ZERO + RTV%Refl = ZERO + RTV%Trans = ZERO + RTV%Inv_BeT = ZERO + RTV%C1 = ZERO + RTV%C2 = ZERO + RTV%Source_up = ZERO + RTV%Source_down = ZERO + + IF ( alloc_stat /= 0 ) RETURN IF(RTV%RT_Algorithm_Id == RT_VMOM) THEN ALLOCATE( RTV%ADS1(nZ, nZ, MAX_N_AMOM, n_Layers), & @@ -521,6 +587,16 @@ SUBROUTINE RTV_Create( & RTV%AmBS4(nZ, nZ, n_Layers), & RTV%ApBS3(nZ, nZ, n_Layers), & STAT = alloc_stat ) + + RTV%ADS1 = ZERO + RTV%ADS2 = ZERO + RTV%ADS3 = ZERO + RTV%ADS4 = ZERO + RTV%ADS = ZERO + RTV%ADSr = ZERO + RTV%AmBS4 = ZERO + RTV%ApBS3 = ZERO + IF ( alloc_stat /= 0 ) RETURN END IF diff --git a/src/SfcOptics/CRTM_IR_Snow_SfcOptics.f90 b/src/SfcOptics/CRTM_IR_Snow_SfcOptics.f90 index a93d9bb..8665d5c 100644 --- a/src/SfcOptics/CRTM_IR_Snow_SfcOptics.f90 +++ b/src/SfcOptics/CRTM_IR_Snow_SfcOptics.f90 @@ -1,8 +1,8 @@ ! ! CRTM_IR_Snow_SfcOptics ! -! Module to compute the surface optical properties for ICE surfaces at -! infrared frequencies required for determining the ICE surface +! Module to compute the surface optical properties for snow surfaces at +! infrared frequencies required for determining the snow surface ! contribution to the radiative transfer. ! ! This module is provided to allow developers to "wrap" their existing @@ -14,6 +14,9 @@ ! Written by: Paul van Delst, 23-Jun-2005 ! paul.vandelst@noaa.gov ! +! Modified by: Cheng Dang, 31-May-2022 +! dangch@ucar.edu +! MODULE CRTM_IR_Snow_SfcOptics @@ -31,7 +34,14 @@ MODULE CRTM_IR_Snow_SfcOptics USE CRTM_SfcOptics_Define , ONLY: CRTM_SfcOptics_type USE CRTM_SEcategory , ONLY: SEVar_type => iVar_type, & SEcategory_Emissivity - USE CRTM_IRsnowCoeff , ONLY: IRsnowC + USE CRTM_IRsnowCoeff , ONLY: CRTM_IRsnowCoeff_IsLoaded, & + CRTM_IRsnowCoeff_SE_IsLoaded, & + IRsnowC, & + IRsnowC_SE + USE CRTM_IRSnowEM , ONLY: IRsnowVar_type => iVar_type, & + CRTM_Compute_IRSnowEM, & + CRTM_Compute_IRSnowEM_TL, & + CRTM_Compute_IRSnowEM_AD ! Disable implicit typing IMPLICIT NONE @@ -42,7 +52,7 @@ MODULE CRTM_IR_Snow_SfcOptics ! Everything private by default PRIVATE ! Data types - PUBLIC :: iVar_type + PUBLIC :: iVar_SE_type, iVar_type ! Science routines PUBLIC :: Compute_IR_Snow_SfcOptics PUBLIC :: Compute_IR_Snow_SfcOptics_TL @@ -60,12 +70,18 @@ MODULE CRTM_IR_Snow_SfcOptics ! Structure definition to hold forward ! variables across FWD, TL, and AD calls ! -------------------------------------- - TYPE :: iVar_type + TYPE :: iVar_SE_type PRIVATE TYPE(SEVar_type) :: sevar + END TYPE iVar_SE_type + + TYPE :: iVar_type + PRIVATE + TYPE(IRsnowVar_type) :: irsnowvar END TYPE iVar_type + CONTAINS @@ -155,6 +171,7 @@ FUNCTION Compute_IR_Snow_SfcOptics( & SensorIndex , & ! Input ChannelIndex, & ! Input SfcOptics , & ! Output + iVar_SE , & ! Internal variable output iVar ) & ! Internal variable output RESULT( err_stat ) ! Arguments @@ -162,6 +179,7 @@ FUNCTION Compute_IR_Snow_SfcOptics( & INTEGER, INTENT(IN) :: SensorIndex INTEGER, INTENT(IN) :: ChannelIndex TYPE(CRTM_SfcOptics_type), INTENT(IN OUT) :: SfcOptics + TYPE(iVar_SE_type), INTENT(IN OUT) :: iVar_SE TYPE(iVar_type), INTENT(IN OUT) :: iVar ! Function result INTEGER :: err_stat @@ -169,36 +187,65 @@ FUNCTION Compute_IR_Snow_SfcOptics( & CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Compute_IR_Snow_SfcOptics' ! Local variables CHARACTER(ML) :: msg - INTEGER :: j + INTEGER :: j, nZ REAL(fp) :: frequency, emissivity + LOGICAL :: isSEcategory, isIRsnowC ! Set up - err_stat = SUCCESS - frequency = SC(SensorIndex)%Wavenumber(ChannelIndex) + err_stat = SUCCESS + ! ...Retrieve frequency data from structures + frequency = SC(SensorIndex)%Wavenumber(ChannelIndex) + ! ...Short name for angle dimensions + nZ = SfcOptics%n_Angles + isSEcategory = CRTM_IRsnowCoeff_SE_IsLoaded() + isIRsnowC = CRTM_IRsnowCoeff_IsLoaded() ! Compute Lambertian surface emissivity - err_stat = SEcategory_Emissivity( & - IRsnowC , & ! Input - frequency , & ! Input - Surface%Snow_Type, & ! Input - emissivity , & ! Output - iVar%sevar ) ! Internal variable output - IF ( err_stat /= SUCCESS ) THEN - msg = 'Error occurred in SEcategory_Emissivity()' - CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN - END IF + IF ( isSEcategory ) THEN + err_stat = SEcategory_Emissivity( & + IRsnowC_SE , & ! Input + frequency , & ! Input + Surface%Snow_Type, & ! Input + emissivity , & ! Output + iVar_SE%sevar ) ! Internal variable output + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error occurred in SEcategory_Emissivity()' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN + END IF + + ! Solar direct component + IF ( SpcCoeff_IsSolar(SC(SensorIndex), ChannelIndex=ChannelIndex) ) THEN + SfcOptics%Direct_Reflectivity(:,1) = ONE - emissivity + END IF + + ! Fill the return emissivity arrays + SfcOptics%Emissivity(1:SfcOptics%n_Angles,1) = emissivity + + ELSE IF ( isIRsnowC ) THEN + err_stat = CRTM_Compute_IRSnowEM(& + IRsnowC , & ! Input + Surface%Snow_Temperature , & ! Input + Surface%Snow_Grain_Size , & ! Input + frequency , & ! Input + SfcOptics%Angle(1:nZ) , & ! Input + iVar%irsnowvar , & ! Internal variable output + SfcOptics%Emissivity(1:nZ,1) ) ! Output + IF ( err_stat /= SUCCESS ) THEN + msg = 'Error occurred in CRTM_Compute_IRSnowEM()' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN + END IF + + ! Compute the solar direct BRDF + IF ( SpcCoeff_IsSolar(SC(SensorIndex), ChannelIndex=ChannelIndex) ) THEN + ! Cheng: placeholder for BRDF + SfcOptics%Direct_Reflectivity(1:nZ,1) = ZERO + END IF - - ! Solar direct component - IF ( SpcCoeff_IsSolar(SC(SensorIndex), ChannelIndex=ChannelIndex) ) THEN - SfcOptics%Direct_Reflectivity(:,1) = ONE - emissivity END IF - - ! Fill the return emissivity and reflectivity arrays - SfcOptics%Emissivity(1:SfcOptics%n_Angles,1) = emissivity - DO j = 1, SfcOptics%n_Angles + ! Fill the return reflectivity arrays + DO j = 1, nZ SfcOptics%Reflectivity(j,1,j,1) = ONE - SfcOptics%Emissivity(j,1) END DO @@ -217,11 +264,84 @@ END FUNCTION Compute_IR_Snow_SfcOptics ! ! This function is a wrapper for third party code. ! -! NB: CURRENTLY THIS IS A STUB FUNCTION AS THERE ARE NO TL -! COMPONENTS IN THE IR SNOW SFCOPTICS COMPUTATIONS. ! ! CALLING SEQUENCE: -! Error_Status = Compute_IR_Snow_SfcOptics_TL( SfcOptics_TL ) +! err_stat = Compute_IR_Snow_SfcOptics_TL( & +! Surface , & ! Input +! SfcOptics , & ! Input +! Surface_TL , & ! Input +! GeometryInfo, & ! Input +! SensorIndex , & ! Input +! ChannelIndex, & ! Input +! SfcOptics_TL, & ! Output +! iVar ) & ! Internal variable input +! +! OUTPUTS: +! SfcOptics_TL: CRTM_SfcOptics structure containing the tangent-linear +! surface optical properties required for the tangent- +! linear radiative transfer calculation. +! UNITS: N/A +! TYPE: CRTM_SfcOptics_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! Surface: CRTM_Surface structure containing the surface state +! data. +! UNITS: N/A +! TYPE: CRTM_Surface_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Surface_TL: CRTM_Surface structure containing the tangent-linear +! surface state data. +! UNITS: N/A +! TYPE: CRTM_Surface_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! SfcOptics: CRTM_SfcOptics structure containing the surface +! optical properties required for the radiative +! transfer calculation. +! UNITS: N/A +! TYPE: CRTM_SfcOptics_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! GeometryInfo: CRTM_GeometryInfo structure containing the +! view geometry information. +! UNITS: N/A +! TYPE: CRTM_GeometryInfo_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! SensorIndex: Sensor index id. This is a unique index associated +! with a (supported) sensor used to access the +! shared coefficient data for a particular sensor. +! See the ChannelIndex argument. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! ChannelIndex: Channel index id. This is a unique index associated +! with a (supported) sensor channel used to access the +! shared coefficient data for a particular sensor's +! channel. +! See the SensorIndex argument. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! iVar: Structure containing internal variables required for +! subsequent tangent-linear or adjoint model calls. +! The contents of this structure are NOT accessible +! outside of the CRTM_IR_Water_SfcOptics module. +! UNITS: N/A +! TYPE: iVar_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! SfcOptics_TL: CRTM_SfcOptics structure containing the tangent-linear @@ -233,7 +353,7 @@ END FUNCTION Compute_IR_Snow_SfcOptics ! ATTRIBUTES: INTENT(IN OUT) ! ! FUNCTION RESULT: -! Error_Status: The return value is an integer defining the error status. +! err_stat: The return value is an integer defining the error status. ! The error codes are defined in the Message_Handler module. ! If == SUCCESS the computation was sucessful ! == FAILURE an unrecoverable error occurred @@ -249,26 +369,74 @@ END FUNCTION Compute_IR_Snow_SfcOptics !---------------------------------------------------------------------------------- FUNCTION Compute_IR_Snow_SfcOptics_TL( & - SfcOptics_TL ) & ! Output + Surface , & ! Input + SfcOptics , & ! Input + Surface_TL , & ! Input + GeometryInfo, & ! Input + SensorIndex , & ! Input + ChannelIndex, & ! Input + SfcOptics_TL, & ! Output + iVar ) & ! Internal variable input RESULT( err_stat ) ! Arguments - TYPE(CRTM_SfcOptics_type), INTENT(IN OUT) :: SfcOptics_TL + TYPE(CRTM_Surface_type), INTENT(IN) :: Surface + TYPE(CRTM_Surface_type), INTENT(IN) :: Surface_TL + TYPE(CRTM_SfcOptics_type), INTENT(IN) :: SfcOptics + TYPE(CRTM_GeometryInfo_type), INTENT(IN) :: GeometryInfo + INTEGER, INTENT(IN) :: SensorIndex + INTEGER, INTENT(IN) :: ChannelIndex + TYPE(CRTM_SfcOptics_type), INTENT(IN OUT) :: SfcOptics_TL + TYPE(iVar_type), INTENT(IN) :: iVar ! Function result - INTEGER :: err_stat + INTEGER :: err_stat, j, nZ ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Compute_IR_Snow_SfcOptics_TL' ! Local variables - + LOGICAL :: isIRsnowC ! Set up - err_stat = SUCCESS - + err_stat = SUCCESS + ! ...Short name for angle dimensions + nZ = SfcOptics%n_Angles + ! ...Snow coefficient model + isIRsnowC = CRTM_IRsnowCoeff_IsLoaded() ! Compute the tangent-linear surface optical parameters - ! ***No TL models yet, so default TL output is zero*** - SfcOptics_TL%Reflectivity = ZERO - SfcOptics_TL%Direct_Reflectivity = ZERO - SfcOptics_TL%Emissivity = ZERO + IF ( isIRsnowC ) THEN + + ! Compute tangent-linear IR snow surface emissivity + err_stat = CRTM_Compute_IRSnowEM_TL( & + IRsnowC , & ! Input model coefficients + Surface_TL%Snow_Temperature , & ! Input + Surface_TL%Snow_Grain_Size , & ! Input + iVar%irsnowvar , & ! Internal variable input + SfcOptics_TL%Emissivity(1:nZ,1) ) ! Output + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( ROUTINE_NAME, & + 'Error computing Tangent_linear IR snow surface emissivity', & + err_stat ) + RETURN + END IF + + ! Compute the tangent-linear solar direct BRDF + IF ( SpcCoeff_IsSolar(SC(SensorIndex), ChannelIndex=ChannelIndex) ) THEN + ! Cheng: placeholder for BRDF + SfcOptics_TL%Direct_Reflectivity(1:nZ,1) = ZERO + END IF + + ! Surface reflectance (currently assumed to be specular ALWAYS) + DO j = 1, nZ + SfcOptics_TL%Reflectivity(j,1,j,1) = -SfcOptics_TL%Emissivity(j,1) + END DO + + ELSE + + ! No TL component for SEcategory files + SfcOptics_TL%Reflectivity = ZERO + SfcOptics_TL%Direct_Reflectivity = ZERO + SfcOptics_TL%Emissivity = ZERO + + END IF END FUNCTION Compute_IR_Snow_SfcOptics_TL @@ -285,20 +453,82 @@ END FUNCTION Compute_IR_Snow_SfcOptics_TL ! ! This function is a wrapper for third party code. ! -! NB: CURRENTLY THIS IS A STUB FUNCTION AS THERE ARE NO AD -! COMPONENTS IN THE IR SNOW SFCOPTICS COMPUTATIONS. -! ! CALLING SEQUENCE: -! Error_Status = Compute_IR_Snow_SfcOptics_AD( SfcOptics_AD ) +! Error_Status = Compute_IR_Snow_SfcOptics_AD( & +! Surface , & +! SfcOptics , & +! SfcOptics_AD, & +! GeometryInfo, & +! SensorIndex , & +! ChannelIndex, & +! Surface_AD , & +! iVar ) ! ! INPUTS: -! SfcOptics_AD: Structure containing the adjoint surface optical -! properties required for the adjoint radiative +! Surface: CRTM_Surface structure containing the surface state +! data. +! UNITS: N/A +! TYPE: CRTM_Surface_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! SfcOptics: CRTM_SfcOptics structure containing the surface +! optical properties required for the radiative ! transfer calculation. -! *** COMPONENTS MODIFIED UPON OUTPUT *** ! UNITS: N/A ! TYPE: CRTM_SfcOptics_type ! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! SfcOptics_AD: CRTM_SfcOptics structure containing the adjoint +! surface optical properties required for the adjoint +! radiative transfer calculation. +! UNITS: N/A +! TYPE: CRTM_SfcOptics_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! GeometryInfo: CRTM_GeometryInfo structure containing the +! view geometry information. +! UNITS: N/A +! TYPE: CRTM_GeometryInfo_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! SensorIndex: Sensor index id. This is a unique index associated +! with a (supported) sensor used to access the +! shared coefficient data for a particular sensor. +! See the ChannelIndex argument. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! ChannelIndex: Channel index id. This is a unique index associated +! with a (supported) sensor channel used to access the +! shared coefficient data for a particular sensor's +! channel. +! See the SensorIndex argument. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! iVar: Structure containing internal variables required for +! subsequent tangent-linear or adjoint model calls. +! The contents of this structure are NOT accessible +! outside of the CRTM_IR_Water_SfcOptics module. +! UNITS: N/A +! TYPE: iVar_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! Surface_AD: CRTM_Surface structure containing the adjoint +! surface state data. +! UNITS: N/A +! TYPE: CRTM_Surface_type +! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN OUT) ! ! FUNCTION RESULT: @@ -310,6 +540,7 @@ END FUNCTION Compute_IR_Snow_SfcOptics_TL ! TYPE: INTEGER ! DIMENSION: Scalar ! +! ! COMMENTS: ! Note the INTENT on the input adjoint arguments are IN OUT regardless ! of their specification as "input" or "output". This is because these @@ -320,26 +551,75 @@ END FUNCTION Compute_IR_Snow_SfcOptics_TL !---------------------------------------------------------------------------------- FUNCTION Compute_IR_Snow_SfcOptics_AD( & - SfcOptics_AD ) & ! Input + Surface , & ! Input + SfcOptics , & ! Input + SfcOptics_AD, & ! Input + GeometryInfo, & ! Input + SensorIndex , & ! Input + ChannelIndex, & ! Input + Surface_AD , & ! Output + iVar ) & ! Internal variable input RESULT( err_stat ) ! Arguments - TYPE(CRTM_SfcOptics_type), INTENT(IN OUT) :: SfcOptics_AD + TYPE(CRTM_Surface_type), INTENT(IN) :: Surface + TYPE(CRTM_SfcOptics_type), INTENT(IN) :: SfcOptics + TYPE(CRTM_SfcOptics_type), INTENT(IN OUT) :: SfcOptics_AD + TYPE(CRTM_GeometryInfo_type), INTENT(IN) :: GeometryInfo + INTEGER, INTENT(IN) :: SensorIndex + INTEGER, INTENT(IN) :: ChannelIndex + TYPE(CRTM_Surface_type), INTENT(IN OUT) :: Surface_AD + TYPE(iVar_type), INTENT(IN) :: iVar ! Function result - INTEGER :: err_stat + INTEGER :: err_stat, j, nZ ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Compute_IR_Snow_SfcOptics_AD' ! Local variables - + LOGICAL :: isIRsnowC ! Set up err_stat = SUCCESS - + ! ...Short name for angle dimensions + nZ = SfcOptics%n_Angles + ! ...Snow coefficient model + isIRsnowC = CRTM_IRsnowCoeff_IsLoaded() ! Compute the adjoint surface optical parameters - ! ***No AD models yet, so there is no impact on AD result*** - SfcOptics_AD%Reflectivity = ZERO - SfcOptics_AD%Direct_Reflectivity = ZERO - SfcOptics_AD%Emissivity = ZERO + IF ( isIRsnowC ) THEN + ! Surface reflectance (currently assumed to be specular ALWAYS) + DO j = nZ, 1, -1 + SfcOptics_AD%Emissivity(j,1) = SfcOptics_AD%Emissivity(j,1) - & + SfcOptics_AD%Reflectivity(j,1,j,1) + SfcOptics_AD%Reflectivity(j,1,j,1) = ZERO + END DO + + ! Compute the adjoint solar direct BRDF + IF ( SpcCoeff_IsSolar(SC(SensorIndex), ChannelIndex=ChannelIndex) ) THEN + ! Cheng: placeholder for BRDF + SfcOptics_AD%Direct_Reflectivity(1:nZ,1) = ZERO + END IF + + ! Compute sdjoint IRSSEM sea surface emissivity + err_stat = CRTM_Compute_IRSnowEM_AD( & + IRsnowC , & ! Input model coefficients + SfcOptics_AD%Emissivity(1:nZ,1), & ! Input + iVar%irsnowvar , & ! Internal Variable Input + Surface_AD%Snow_Grain_Size , & ! Output + Surface_AD%Snow_Temperature ) ! Output + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( ROUTINE_NAME, & + 'Error computing Adjoint IR sea surface emissivity', & + err_stat ) + RETURN + END IF + + ELSE + + ! No AD component for SEcategory files + SfcOptics_AD%Reflectivity = ZERO + SfcOptics_AD%Direct_Reflectivity = ZERO + SfcOptics_AD%Emissivity = ZERO + + END IF END FUNCTION Compute_IR_Snow_SfcOptics_AD diff --git a/src/SfcOptics/CRTM_IR_Water_SfcOptics.f90 b/src/SfcOptics/CRTM_IR_Water_SfcOptics.f90 index fc1b3a1..e0e84b5 100644 --- a/src/SfcOptics/CRTM_IR_Water_SfcOptics.f90 +++ b/src/SfcOptics/CRTM_IR_Water_SfcOptics.f90 @@ -13,6 +13,9 @@ ! CREATION HISTORY: ! Written by: Paul van Delst, 25-Jun-2005 ! paul.vandelst@noaa.gov +! Modified by: Cheng Dang, 18-Mar-2022 +! dangch@ucar.edu +! Add water temperature ! MODULE CRTM_IR_Water_SfcOptics @@ -209,6 +212,7 @@ FUNCTION Compute_IR_Water_SfcOptics( & ! Compute IR sea surface emissivity Error_Status = CRTM_Compute_IRSSEM( & IRwaterC , & ! Input model coefficients + Surface%Water_Temperature , & ! Input Surface%Wind_Speed , & ! Input Frequency , & ! Input SfcOptics%Angle(1:nZ) , & ! Input @@ -221,6 +225,7 @@ FUNCTION Compute_IR_Water_SfcOptics( & RETURN END IF + ! Compute the solar direct BRDF IF ( SpcCoeff_IsSolar(SC(SensorIndex), ChannelIndex=ChannelIndex) ) THEN @@ -392,6 +397,7 @@ FUNCTION Compute_IR_Water_SfcOptics_TL( & ! Compute tangent-linear IR sea surface emissivity Error_Status = CRTM_Compute_IRSSEM_TL( & IRwaterC , & ! Input model coefficients + Surface_TL%Water_Temperature , & ! Input Surface_TL%Wind_Speed , & ! Input iVar%IRSSEM , & ! Internal variable input SfcOptics_TL%Emissivity(1:nZ,1) ) ! Output @@ -589,7 +595,6 @@ FUNCTION Compute_IR_Water_SfcOptics_AD( & brdf_AD = SUM(SfcOptics_AD%Direct_Reflectivity(1:nZ,1)) SfcOptics_AD%Direct_Reflectivity(1:nZ,1) = ZERO - CALL BRDF_Rough_Sea_AD(Surface%Wind_Speed, & brdf_AD, & Surface_AD%Wind_Speed, & @@ -597,13 +602,15 @@ FUNCTION Compute_IR_Water_SfcOptics_AD( & END IF SfcOptics_AD%Direct_Reflectivity(1:nZ,1) = ZERO - END IF + END IF + ! Compute sdjoint IRSSEM sea surface emissivity Error_Status = CRTM_Compute_IRSSEM_AD( & IRwaterC , & ! Input model coefficients SfcOptics_AD%Emissivity(1:nZ,1), & ! Input iVar%IRSSEM , & ! Internal Variable Input - Surface_AD%Wind_Speed ) ! Output + Surface_AD%Wind_Speed , & ! Output + Surface_AD%Water_Temperature ) ! Output IF ( Error_Status /= SUCCESS ) THEN CALL Display_Message( ROUTINE_NAME, & 'Error computing Adjoint IR sea surface emissivity', & diff --git a/src/SfcOptics/CRTM_SfcOptics.f90 b/src/SfcOptics/CRTM_SfcOptics.f90 index 2440044..ea3565c 100644 --- a/src/SfcOptics/CRTM_SfcOptics.f90 +++ b/src/SfcOptics/CRTM_SfcOptics.f90 @@ -17,10 +17,10 @@ ! Author: Date: Description: ! ======= ===== ============ ! Patrick Stegmann 2021-01-22 Added CONST_MIXED_POLARIZATION scheme. -! -! Patrick Stegmann 2021-08-31 Added PRA_POLARIZATION scheme for GEMS-1. ! +! Patrick Stegmann 2021-08-31 Added PRA_POLARIZATION scheme for GEMS-1. ! +! Cheng Dang 2022-05-31 Added IRsnowCoeff TL and AD modules MODULE CRTM_SfcOptics @@ -84,6 +84,7 @@ MODULE CRTM_SfcOptics Compute_IR_Water_SfcOptics_TL, & Compute_IR_Water_SfcOptics_AD USE CRTM_IR_Snow_SfcOptics, ONLY: IRSSOVar_type => iVar_type, & + IRSSOVar_SE_type => iVar_SE_type, & Compute_IR_Snow_SfcOptics, & Compute_IR_Snow_SfcOptics_TL, & Compute_IR_Snow_SfcOptics_AD @@ -146,10 +147,11 @@ MODULE CRTM_SfcOptics TYPE(MWSSOVar_type) :: MWSSOV ! Snow TYPE(MWISOVar_type) :: MWISOV ! Ice ! Infrared - TYPE(IRLSOVar_type) :: IRLSOV ! Land - TYPE(IRWSOVar_type) :: IRWSOV ! Water - TYPE(IRSSOVar_type) :: IRSSOV ! Snow - TYPE(IRISOVar_type) :: IRISOV ! Ice + TYPE(IRLSOVar_type) :: IRLSOV ! Land + TYPE(IRWSOVar_type) :: IRWSOV ! Water + TYPE(IRSSOVar_type) :: IRSSOV ! Snow + TYPE(IRSSOVar_SE_type) :: IRSSOV_SE ! Snow, SE category + TYPE(IRISOVar_type) :: IRISOV ! Ice ! Visible TYPE(VISLSOVar_type) :: VISLSOV ! Land TYPE(VISWSOVar_type) :: VISWSOV ! Water @@ -463,7 +465,7 @@ FUNCTION CRTM_Compute_SfcOptics( & INTEGER , INTENT(IN) :: SensorIndex INTEGER , INTENT(IN) :: ChannelIndex TYPE(CRTM_SfcOptics_type) , INTENT(IN OUT) :: SfcOptics - TYPE(iVar_type) , INTENT(IN OUT) :: iVar + TYPE(iVar_type) , INTENT(OUT) :: iVar ! Function result INTEGER :: Error_Status ! Local parameters @@ -635,6 +637,7 @@ FUNCTION CRTM_Compute_SfcOptics( & !# If the SfcOptics n_Stokes dimension == 1, the polarisations are # !# decoupled. # !#----------------------------------------------------------------------# + Decoupled_Polarization: IF( SfcOptics%n_Stokes == 1 ) THEN @@ -739,7 +742,7 @@ FUNCTION CRTM_Compute_SfcOptics( & ! ========== ! Leslie, V. (2020): TROPICS Polarization Description, 20 November 2020. ! (Personal Communication) - ! + ! CASE ( CONST_MIXED_POLARIZATION ) SIN2_Angle = (GeometryInfo%Distance_Ratio * & SIN(DEGREES_TO_RADIANS*SC(SensorIndex)%PolAngle(ChannelIndex)))**2 @@ -749,18 +752,18 @@ FUNCTION CRTM_Compute_SfcOptics( & SfcOptics%Reflectivity(i,1,i,1) = (Reflectivity(i,1,i,1)*SIN2_Angle) + & (Reflectivity(i,2,i,2)*(ONE-SIN2_Angle)) END DO - + ! ! Description: ! ============ - ! Polarization changing with a defined polarization rotation angle + ! Polarization changing with a defined polarization rotation angle ! as instrument zenith angle changes. Implemented for GEMS-1 SmallSat. ! CASE ( PRA_POLARIZATION ) DO i = 1, nZ ! Alias for the sensor scan angle: phi = GeometryInfo%Sensor_Scan_Radian - ! Instrument offset angle: + ! Instrument offset angle: theta_f = DEGREES_TO_RADIANS*SC(SensorIndex)%PolAngle(ChannelIndex) ph = SIN(phi) * ( COS(phi) + SIN(theta_f)*(1.0_fp - COS(phi)) ) & ! -------------------------------------------------------------- @@ -775,7 +778,7 @@ FUNCTION CRTM_Compute_SfcOptics( & SfcOptics%Reflectivity(i,1,i,1) = (Reflectivity(i,1,i,1)*SIN2_Angle) + & (Reflectivity(i,2,i,2)*(ONE-SIN2_Angle)) END DO - + ! Serious problem if we got to this points CASE DEFAULT Error_Status = FAILURE @@ -876,11 +879,12 @@ FUNCTION CRTM_Compute_SfcOptics( & ! Compute the surface optics Error_Status = Compute_IR_Snow_SfcOptics( & - Surface , & ! Input - SensorIndex , & ! Input - ChannelIndex, & ! Input - SfcOptics , & ! In/Output - iVar%IRSSOV ) ! Internal variable output + Surface , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + SfcOptics , & ! In/Output + iVar%IRSSOV_SE, & ! Internal variable output + iVar%IRSSOV ) ! Internal variable output IF ( Error_Status /= SUCCESS ) THEN WRITE( Message,'("Error computing IR snow SfcOptics at ",& &"channel index ",i0)' ) ChannelIndex @@ -1512,14 +1516,14 @@ FUNCTION CRTM_Compute_SfcOptics_TL( & ! ! Description: ! ============ - ! Polarization changing with a defined polarization rotation angle + ! Polarization changing with a defined polarization rotation angle ! as instrument zenith angle changes. Implemented for GEMS-1 SmallSat. ! CASE ( PRA_POLARIZATION ) DO i = 1, nZ ! Alias for the sensor scan angle: phi = GeometryInfo%Sensor_Scan_Radian - ! Instrument offset angle: + ! Instrument offset angle: theta_f = DEGREES_TO_RADIANS*SC(SensorIndex)%PolAngle(ChannelIndex) ph = SIN(phi) * ( COS(phi) + SIN(theta_f)*(1.0_fp - COS(phi)) ) & ! -------------------------------------------------------------- @@ -1636,7 +1640,15 @@ FUNCTION CRTM_Compute_SfcOptics_TL( & Infrared_Snow: IF( Surface%Snow_Coverage > ZERO ) THEN ! Compute the surface optics - Error_Status = Compute_IR_Snow_SfcOptics_TL( SfcOptics_TL ) + Error_Status = Compute_IR_Snow_SfcOptics_TL( & + Surface , & ! Input + SfcOptics , & ! Input + Surface_TL , & ! Input + GeometryInfo, & ! Input + SensorIndex , & ! Input + ChannelIndex, & ! Input + SfcOptics_TL, & ! In/Output + iVar%IRSSOV ) ! Internal variable input IF ( Error_Status /= SUCCESS ) THEN WRITE( Message,'("Error computing IR snow SfcOptics_TL at ",& &"channel index ",i0)' ) ChannelIndex @@ -2052,14 +2064,14 @@ FUNCTION CRTM_Compute_SfcOptics_AD( & ! ! Description: ! ============ - ! Polarization changing with a defined polarization rotation angle + ! Polarization changing with a defined polarization rotation angle ! as instrument zenith angle changes. Implemented for GEMS-1 SmallSat. ! CASE ( PRA_POLARIZATION ) DO i = 1, nZ ! Alias for the sensor scan angle: phi = GeometryInfo%Sensor_Scan_Radian - ! Instrument offset angle: + ! Instrument offset angle: theta_f = DEGREES_TO_RADIANS*SC(SensorIndex)%PolAngle(ChannelIndex) ph = SIN(phi) * ( COS(phi) + SIN(theta_f)*(1.0_fp - COS(phi)) ) & ! -------------------------------------------------------------- @@ -2089,7 +2101,8 @@ FUNCTION CRTM_Compute_SfcOptics_AD( & RETURN END SELECT Polarization_Type - + + ELSE @@ -2232,12 +2245,12 @@ FUNCTION CRTM_Compute_SfcOptics_AD( & ELSE IF ( SpcCoeff_IsInfraredSensor( SC(SensorIndex) ) ) THEN Reflectivity_AD(1:nZ,1,1:nZ,1:nL) = SfcOptics_AD%Reflectivity(1:nZ,1,1:nZ,1:nL) - SfcOptics_AD%Reflectivity = ZERO + SfcOptics_AD%Reflectivity = ZERO Emissivity_AD(1:nZ,1:nL) = SfcOptics_AD%Emissivity(1:nZ,1:nL) SfcOptics_AD%Emissivity = ZERO Direct_Reflectivity_AD(1:nZ,1) = SfcOptics_AD%Direct_Reflectivity(1:nZ,1) SfcOptics_AD%Direct_Reflectivity(1:nZ,1) = ZERO - + ! ------------------------------------ ! Infrared ICE emissivity/reflectivity ! ------------------------------------ @@ -2254,7 +2267,7 @@ FUNCTION CRTM_Compute_SfcOptics_AD( & (Reflectivity_AD(1:nZ,1:nL,1:nZ,1:nL)*Surface%Ice_Coverage) SfcOptics_AD%Direct_Reflectivity(1:nZ,1:nL) = & SfcOptics_AD%Direct_Reflectivity(1:nZ,1:nL) + & - (Direct_Reflectivity_AD(1:nZ,1:nL)*Surface%Ice_Coverage) + (Direct_Reflectivity_AD(1:nZ,1:nL)*Surface%Ice_Coverage) ! Compute the surface optics adjoints Error_Status = Compute_IR_Ice_SfcOptics_AD( SfcOptics_AD ) IF ( Error_Status /= SUCCESS ) THEN @@ -2283,9 +2296,17 @@ FUNCTION CRTM_Compute_SfcOptics_AD( & (Reflectivity_AD(1:nZ,1:nL,1:nZ,1:nL)*Surface%Snow_Coverage) SfcOptics_AD%Direct_Reflectivity(1:nZ,1:nL) = & SfcOptics_AD%Direct_Reflectivity(1:nZ,1:nL) + & - (Direct_Reflectivity_AD(1:nZ,1:nL)*Surface%Snow_Coverage) + (Direct_Reflectivity_AD(1:nZ,1:nL)*Surface%Snow_Coverage) ! Compute the surface optics adjoints - Error_Status = Compute_IR_Snow_SfcOptics_AD( SfcOptics_AD ) + Error_Status = Compute_IR_Snow_SfcOptics_AD( & + Surface , & ! Input + SfcOptics , & ! Input + SfcOptics_AD, & ! Input + GeometryInfo, & ! Input + SensorIndex , & ! Input + ChannelIndex, & ! Input + Surface_AD , & ! Output + iVar%IRSSOV ) ! Internal variable input IF ( Error_Status /= SUCCESS ) THEN WRITE( Message,'("Error computing IR snow SfcOptics_AD at ",& &"channel index ",i0)' ) ChannelIndex @@ -2312,7 +2333,7 @@ FUNCTION CRTM_Compute_SfcOptics_AD( & (Reflectivity_AD(1:nZ,1:nL,1:nZ,1:nL)*Surface%Water_Coverage) SfcOptics_AD%Direct_Reflectivity(1:nZ,1:nL) = & SfcOptics_AD%Direct_Reflectivity(1:nZ,1:nL) + & - (Direct_Reflectivity_AD(1:nZ,1:nL)*Surface%Water_Coverage) + (Direct_Reflectivity_AD(1:nZ,1:nL)*Surface%Water_Coverage) ! Compute the surface optics adjoints Error_Status = Compute_IR_Water_SfcOptics_AD( & Surface , & ! Input @@ -2349,7 +2370,7 @@ FUNCTION CRTM_Compute_SfcOptics_AD( & (Reflectivity_AD(1:nZ,1:nL,1:nZ,1:nL)*Surface%Land_Coverage) SfcOptics_AD%Direct_Reflectivity(1:nZ,1:nL) = & SfcOptics_AD%Direct_Reflectivity(1:nZ,1:nL) + & - (Direct_Reflectivity_AD(1:nZ,1:nL)*Surface%Land_Coverage) + (Direct_Reflectivity_AD(1:nZ,1:nL)*Surface%Land_Coverage) ! Compute the surface optics adjoints ! **STUB PROCEDURE** Error_Status = Compute_IR_Land_SfcOptics_AD( SfcOptics_AD ) diff --git a/src/SfcOptics/IR_Snow/CRTM_IRSnowEM.f90 b/src/SfcOptics/IR_Snow/CRTM_IRSnowEM.f90 new file mode 100644 index 0000000..4d96f5f --- /dev/null +++ b/src/SfcOptics/IR_Snow/CRTM_IRSnowEM.f90 @@ -0,0 +1,675 @@ +! +! CRTM_IRSnowEM +! +! Module containing function to invoke the CRTM Infrared +! Snow Emissivity Model. +! +! +! CREATION HISTORY: +! Written by: Cheng Dang, 31-May-2022 +! dangch@ucar.edu +! + +MODULE CRTM_IRSnowEM + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module use + USE Type_Kinds, ONLY: fp + USE Message_Handler, ONLY: SUCCESS, FAILURE, Display_Message + USE CRTM_Parameters, ONLY: ZERO, ONE, DEGREES_TO_RADIANS + USE CRTM_Interpolation, ONLY: NPTS, & + LPoly, & + LPoly_type, & + Clear_LPoly, & + Find_Index, & + Interp_3D, & + Interp_4D, & + LPoly_TL, & + Interp_3D_TL, & + Interp_4D_TL, & + LPoly_AD, & + Interp_3D_AD, & + Interp_4D_AD + USE IRsnowCoeff_Define, ONLY: IRsnowCoeff_type + ! Disable implicit typing + IMPLICIT NONE + + ! ------------ + ! Visibilities + ! ------------ + ! Everything private by default + PRIVATE + ! Derived type + PUBLIC :: iVar_type + ! Procedures + PUBLIC :: CRTM_Compute_IRSnowEM + PUBLIC :: CRTM_Compute_IRSnowEM_TL + PUBLIC :: CRTM_Compute_IRSnowEM_AD + + + ! ----------------- + ! Module parameters + ! ----------------- + ! Version Id for the module + ! Message string length + INTEGER, PARAMETER :: ML = 256 + + + ! ------------------------------- + ! Structure definition to hold + ! forward interpolating variables + ! across fwd, tl and adjoint + ! ------------------------------- + ! The interpolation routine structure + TYPE :: Einterp_type + ! The dimensions + INTEGER :: n_Angles = 0 + INTEGER :: n_Pts = 0 + ! Allocation indicator + LOGICAL :: Is_Allocated = .FALSE. + ! The interpolating polynomials + TYPE(LPoly_type), ALLOCATABLE :: wlp(:) ! Angle + TYPE(LPoly_type) :: xlp ! Frequency + TYPE(LPoly_type) :: ylp ! Snow Grain Size + TYPE(LPoly_type) :: zlp ! Snow Temperature + ! The LUT interpolation indices + INTEGER, ALLOCATABLE :: i1(:) , i2(:) ! Angle + INTEGER :: j1 , j2 ! Frequency + INTEGER :: k1 , k2 ! Snow Grain Size + INTEGER :: l1 , l2 ! Snow Temperature + ! The LUT interpolation boundary check + LOGICAL, ALLOCATABLE :: a_outbound(:) ! Angle + LOGICAL :: f_outbound ! Frequency + LOGICAL :: r_outbound ! Snow Grain Size + LOGICAL :: t_outbound ! Snow Temperature + ! The interpolation input + REAL(fp), ALLOCATABLE :: a_int(:) ! Angle + REAL(fp) :: f_int ! Frequency + REAL(fp) :: r_int ! Snow Grain Size + REAL(fp) :: t_int ! Snow Temperature + ! The data to be interpolated + REAL(fp), ALLOCATABLE :: a(:,:) ! Angle + REAL(fp), ALLOCATABLE :: f(:) ! Frequency + REAL(fp), ALLOCATABLE :: r(:) ! Snow Grain Size + REAL(fp), ALLOCATABLE :: t(:) ! Snow Temperature + END TYPE Einterp_type + + ! The main internal variable structure + TYPE :: iVar_type + PRIVATE + ! The interpolation data + TYPE(Einterp_type) :: ei + END TYPE iVar_type + + +CONTAINS + + +!################################################################################ +!################################################################################ +!## ## +!## ## PUBLIC MODULE ROUTINES ## ## +!## ## +!################################################################################ +!################################################################################ + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_Compute_IRSnowEM +! +! PURPOSE: +! Function to compute the CRTM infrared snow surface emissivity +! for input temperature, grain size, frequency, and angles. +! +! CALLING SEQUENCE: +! Error_Status = CRTM_Compute_IRSnowEM(IRsnowCoeff , & +! Snow_Temperature , & +! Snow_Grain_Size , & +! Frequency , & +! Angle , & +! iVar , & +! Emissivity ) +! +! INPUTS: +! IRsnowCoeff: Infrared snow emissivity model coefficient object. +! Load the object with the coefficients for the emissivity +! model to use. +! UNITS: N/A +! TYPE: IRsnowCoeff_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Snow_Temperature: Snow temperature. +! UNITS: Kelvin (K) +! TYPE: REAL(fp) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Snow_Grain_Size: Snow grain size. +! UNITS: microns (um) +! TYPE: REAL(fp) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Frequency: Infrared frequency. +! UNITS: inverse centimetres (cm^-1) +! TYPE: REAL(fp) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Angle: Surface zenith angle. +! UNITS: Degrees +! TYPE: REAL(fp) +! DIMENSION: Rank-1 (n_Angles) +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! iVar: Structure containing internal variables required for +! subsequent tangent-linear or adjoint model calls. +! The contents of this structure are NOT accessible +! outside of this module. +! UNITS: N/A +! TYPE: iVar_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! Emissivity: Snow surface emissivities for the +! requested Grain Size, frequency, and angles. +! UNITS: N/A +! TYPE: REAL(fp) +! DIMENSION: Same as input ANGLE argument. +! ATTRIBUTES: INTENT(OUT) +! +! 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 computation was successful. +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION CRTM_Compute_IRSnowEM( & + IRsnowCoeff , & ! Input model coefficients + Snow_Temperature , & ! Input + Snow_Grain_Size , & ! Input + Frequency , & ! Input + Angle , & ! Input + iVar , & ! Internal variable output + Emissivity ) & ! Output + RESULT( err_stat ) + ! Arguments + TYPE(IRsnowCoeff_type) , INTENT(IN) :: IRsnowCoeff + REAL(fp) , INTENT(IN) :: Snow_Temperature ! t + REAL(fp) , INTENT(IN) :: Snow_Grain_Size ! r + REAL(fp) , INTENT(IN) :: Frequency ! f + REAL(fp) , INTENT(IN) :: Angle(:) ! a + TYPE(iVar_type) , INTENT(OUT) :: iVar + REAL(fp) , INTENT(OUT) :: Emissivity(:) + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Compute_IRsnowEM' + ! Local variables + CHARACTER(ML) :: msg + INTEGER :: n_Angles, i + + ! Set up + err_stat = SUCCESS + ! ...Check dimensions + n_Angles = SIZE(Angle) + IF ( SIZE(Emissivity) /= n_Angles ) THEN + err_stat = FAILURE + msg = 'Input Angle and output Emissivity array dimensions inconsistent.' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + ! ...Allocate interpolation variable structure + CALL Einterp_Create( iVar%ei, NPTS, n_Angles ) + IF ( .NOT. Einterp_Associated( iVar%ei ) ) THEN + err_stat = FAILURE + msg = 'Error allocating interpolation variable structure.' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + + ! Compute the snow temperature interpolating polynomial + ! ...Find the LUT indices and check if input is out of bounds + iVar%ei%t_int = Snow_Temperature + CALL find_index(IRsnowCoeff%Temperature, & + iVar%ei%t_int, iVar%ei%l1, iVar%ei%l2, iVar%ei%t_outbound) + iVar%ei%t = IRsnowCoeff%Temperature(iVar%ei%l1:iVar%ei%l2) + ! ...Compute the polynomial + CALL LPoly( iVar%ei%t , & ! Input + iVar%ei%t_int, & ! Input + iVar%ei%zlp ) ! Output + + + ! Compute the grain size interpolating polynomial + ! ...Find the LUT indices and check if input is out of bounds + iVar%ei%r_int = Snow_Grain_Size + CALL find_index(IRsnowCoeff%Grain_Size, & + iVar%ei%r_int, iVar%ei%k1, iVar%ei%k2, iVar%ei%r_outbound) + iVar%ei%r = IRsnowCoeff%Grain_Size(iVar%ei%k1:iVar%ei%k2) + ! ...Compute the polynomial + CALL LPoly( iVar%ei%r , & ! Input + iVar%ei%r_int, & ! Input + iVar%ei%ylp ) ! Output + + + ! Compute the frequency interpolating polynomial + ! ...Find the LUT indices and check if input is out of bounds + iVar%ei%f_int = Frequency + CALL find_index(IRsnowCoeff%Frequency, & + iVar%ei%f_int, iVar%ei%j1, iVar%ei%j2, iVar%ei%f_outbound) + iVar%ei%f = IRsnowCoeff%Frequency(iVar%ei%j1:iVar%ei%j2) + ! ...Compute the polynomial + CALL LPoly( iVar%ei%f , & ! Input + iVar%ei%f_int, & ! Input + iVar%ei%xlp ) ! Output + + + ! Compute the angle interpolating polynomials + DO i = 1, n_Angles + + ! ...Find the LUT indices and check if input is out of bounds + iVar%ei%a_int(i) = ABS(Angle(i)) + CALL find_index(IRsnowCoeff%Angle, & + iVar%ei%a_int(i), iVar%ei%i1(i), iVar%ei%i2(i), iVar%ei%a_outbound(i)) + iVar%ei%a(:,i) = IRsnowCoeff%Angle(iVar%ei%i1(i):iVar%ei%i2(i)) + + ! ...Compute the polynomial + CALL LPoly( iVar%ei%a(:,i) , & ! Input + iVar%ei%a_int(i), & ! Input + iVar%ei%wlp(i) ) ! Output + + ! Compute the interpolated emissivity + CALL Interp_4D( IRsnowCoeff%Emissivity( iVar%ei%i1(i):iVar%ei%i2(i) , & + iVar%ei%j1 :iVar%ei%j2 , & + iVar%ei%k1 :iVar%ei%k2 , & + iVar%ei%l1 :iVar%ei%l2 ), & ! Input + iVar%ei%wlp(i), & ! Input + iVar%ei%xlp , & ! Input + iVar%ei%ylp , & ! Input + iVar%ei%zlp , & ! Input + Emissivity(i) ) ! Output + + END DO + + END FUNCTION CRTM_Compute_IRSnowEM + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_Compute_IRSnowEM_TL +! +! PURPOSE: +! Function to compute the tangent-linear CRTM infrared snow +! emissivity for input temperature, grain size, frequency, +! and angles. +! +! This function must be called *after* the forward model function, +! CRTM_Compute_IRSnowEM, has been called. The forward model function +! populates the internal variable structure argument, iVar. +! +! CALLING SEQUENCE: +! Error_Status = CRTM_Compute_IRSnowEM_TL( IRsnowCoeff , & +! Snow_Temperature_TL , & +! Snow_Grain_Size_TL , & +! iVar , & +! Emissivity_TL ) +! INPUTS: +! IRsnowCoeff: Infrared snow emissivity model coefficient object. +! Load the object with the coefficients for the emissivity +! model to use. +! UNITS: N/A +! TYPE: IRsnowCoeff_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Snow_Temperature_TL: The tangent-linear snow temperature. +! UNITS: Kelvin (K) +! TYPE: REAL(fp) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Snow_Grain_Size_TL: The tangent-linear Grain Size. +! UNITS: metres per second (m.s^-1) +! TYPE: REAL(fp) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! iVar: Structure containing internal variables required for +! subsequent tangent-linear or adjoint model calls. +! The contents of this structure are NOT accessible +! outside of this module. +! UNITS: N/A +! TYPE: iVar_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! Emissivity_TL: Tangent-linear snow surface emissivity. +! UNITS: N/A +! TYPE: REAL(fp) +! DIMENSION: Rank-1 (n_Angles) +! ATTRIBUTES: INTENT(OUT) +! +! 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 computation was successful. +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION CRTM_Compute_IRSnowEM_TL( & + IRsnowCoeff , & ! Input model coefficients + Snow_Temperature_TL , & ! Input + Snow_Grain_Size_TL , & ! Input + iVar , & ! Internal variable input + Emissivity_TL ) & ! Output + RESULT( err_stat ) + ! Arguments + TYPE(IRsnowCoeff_type) , INTENT(IN) :: IRsnowCoeff + REAL(fp) , INTENT(IN) :: Snow_Temperature_TL + REAL(fp) , INTENT(IN) :: Snow_Grain_Size_TL + TYPE(iVar_type) , INTENT(IN) :: iVar + REAL(fp) , INTENT(OUT) :: Emissivity_TL(:) + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Compute_IRsnowEM_TL' + ! Local variables + CHARACTER(ML) :: msg + INTEGER :: i + REAL(fp) :: r_TL(NPTS), t_TL(NPTS) + REAL(fp) :: e_TL_3D(NPTS,NPTS,NPTS), e_TL_4D(NPTS,NPTS,NPTS,NPTS) + TYPE(LPoly_Type) :: ylp_TL, xlp_TL, wlp_TL, zlp_TL + + ! Set up + err_stat = SUCCESS + ! ...Check internal variable allocation + IF ( .NOT. Einterp_Associated( iVar%ei ) ) THEN + err_stat = FAILURE + msg = 'Internal structure ei is not allocated' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + ! ...Check dimensions + IF ( SIZE( Emissivity_TL ) /= iVar%ei%n_Angles ) THEN + err_stat = FAILURE + msg = 'Input Emissivity_TL array dimensions inconsistent with number of angles.' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + ! ...No TL if snow temperature is out of bounds + IF (iVar%ei%t_outbound) THEN + Emissivity_TL = ZERO + RETURN + END IF + ! ...No TL if snow grain size is out of bounds + IF ( iVar%ei%r_outbound ) THEN + Emissivity_TL = ZERO + RETURN + END IF + ! ...Initialise local TL variables + t_TL = ZERO + r_TL = ZERO + e_TL_3D = ZERO + e_TL_4D = ZERO + CALL Clear_LPoly(wlp_TL) + CALL Clear_LPoly(xlp_TL) + + + ! Calculate the TL interpolating + ! polynomials for snow temperature + CALL LPoly_TL( iVar%ei%t, iVar%ei%t_int, & ! FWD Input + iVar%ei%zlp, & ! FWD Input + t_TL, Snow_Temperature_TL, & ! TL Input + zlp_TL ) ! TL Output + ! polynomials for snow grain size + CALL LPoly_TL( iVar%ei%r, iVar%ei%r_int, & ! FWD Input + iVar%ei%ylp, & ! FWD Input + r_TL, Snow_Grain_Size_TL, & ! TL Input + ylp_TL ) ! TL Output + + + ! Begin loop over angles + DO i = 1, iVar%ei%n_Angles + + ! Perform interpolation + CALL interp_4D_TL(IRsnowCoeff%Emissivity(iVar%ei%i1(i) :iVar%ei%i2(i), & + iVar%ei%j1 :iVar%ei%j2 , & + iVar%ei%k1 :iVar%ei%k2 , & + iVar%ei%l1 :iVar%ei%l2 ), & ! FWD Emissivity input + iVar%ei%wlp(i), & ! FWD polynomial input + iVar%ei%xlp , & ! FWD polynomial input + iVar%ei%ylp , & ! FWD polynomial input + iVar%ei%zlp , & ! FWD polynomial input + e_TL_4D, wlp_TL, xlp_TL, ylp_TL, zlp_TL, & ! TL input + Emissivity_TL(i) ) ! Output + + END DO + + END FUNCTION CRTM_Compute_IRSnowEM_TL + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_Compute_IRSnowEM_AD +! +! PURPOSE: +! Function to compute the adjoint of the CRTM infrared snow +! emissivity for input grain size, frequency, and angles. +! +! This function must be called *after* the forward model function, +! CRTM_Compute_IRSnowEM, has been called. The forward model function +! populates the internal variable structure argument, iVar. +! +! CALLING SEQUENCE: +! Error_Status = CRTM_Compute_IRSnowEM_AD(IRsnowCoeff , & +! Emissivity_AD , & +! iVar , & +! Snow_Grain_Size_AD , & +! Snow_Temperature_AD ) +! +! INPUTS: +! IRsnowCoeff: Infrared snow emissivity model coefficient object. +! Load the object with the coefficients for the emissivity +! model to use. +! UNITS: N/A +! TYPE: IRsnowCoeff_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Emissivity_AD: Adjoint snow surface emissivity. +! *** SET TO ZERO ON EXIT *** +! UNITS: N/A +! TYPE: REAL(fp) +! DIMENSION: Rank-1 (n_Angles) +! ATTRIBUTES: INTENT(IN OUT) +! +! iVar: Structure containing internal variables required for +! subsequent tangent-linear or adjoint model calls. +! The contents of this structure are NOT accessible +! outside of this module. +! UNITS: N/A +! TYPE: iVar_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! Snow_Grain_Size_AD: Adjoint snow grain size. +! *** MUST HAVE VALUE ON ENTRY *** +! UNITS: per microns (um)^-1 +! TYPE: REAL(fp) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! Snow_Temperature_AD: Adjoint snow temperature. +! *** MUST HAVE VALUE ON ENTRY *** +! UNITS: per Kelvin, (K)^-1 +! TYPE: REAL(fp) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! 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 computation was successful. +! == FAILURE an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION CRTM_Compute_IRSnowEM_AD( & + IRsnowCoeff , & ! Input model coefficients + Emissivity_AD , & ! Input + iVar , & ! Internal Variable Input + Snow_Grain_Size_AD , & ! Output + Snow_Temperature_AD ) & ! Output + RESULT( err_stat ) + ! Arguments + TYPE(IRsnowCoeff_type) , INTENT(IN) :: IRsnowCoeff + REAL(fp) , INTENT(IN OUT) :: Emissivity_AD(:) + TYPE(iVar_type) , INTENT(IN) :: iVar + REAL(fp) , INTENT(IN OUT) :: Snow_Grain_Size_AD + REAL(fp) , INTENT(IN OUT) :: Snow_Temperature_AD + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Compute_IRsnowEM_AD' + ! Local variables + CHARACTER(ML) :: msg + INTEGER :: i + REAL(fp) :: e_AD_3D(NPTS,NPTS,NPTS), e_AD_4D(NPTS,NPTS,NPTS,NPTS) + REAL(fp) :: r_AD(NPTS), t_AD(NPTS) + TYPE(LPoly_Type) :: wlp_AD, xlp_AD, ylp_AD, zlp_AD + + ! Set Up + err_stat = SUCCESS + e_AD_3D = ZERO + e_AD_4D = ZERO + r_AD = ZERO + t_AD = ZERO + ! ...Check internal variable allocation + IF ( .NOT. Einterp_Associated( iVar%ei ) ) THEN + err_stat = FAILURE + msg = 'Internal structure ei is not allocated' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + ! ...Check dimensions + IF ( SIZE(Emissivity_AD) /= iVar%ei%n_Angles ) THEN + err_stat = FAILURE + msg = 'Input Emissivity_AD array dimensions inconsistent with number of angles.' + CALL Display_Message( ROUTINE_NAME, msg, err_stat ) + RETURN + END IF + ! ...No AD if snow temperature is out of bounds + IF (iVar%ei%t_outbound) RETURN + ! ...No AD if snow grain size is out of bounds + IF ( iVar%ei%r_outbound ) RETURN + ! ...Initialize local variables + CALL Clear_LPoly(wlp_AD) + CALL Clear_LPoly(xlp_AD) + CALL Clear_LPoly(ylp_AD) + CALL Clear_LPoly(zlp_AD) + + ! Loop over emissivity calculation angles + DO i = 1, iVar%ei%n_Angles + + ! Get the adjoint interpoalting polynomial for snow grain size and snow temperature + CALL Interp_4D_AD(IRsnowCoeff%Emissivity( iVar%ei%i1(i) :iVar%ei%i2(i), & + iVar%ei%j1 :iVar%ei%j2 , & + iVar%ei%k1 :iVar%ei%k2 , & + iVar%ei%l1 :iVar%ei%l2 ), & ! FWD Input + iVar%ei%wlp(i) , & ! FWD Input + iVar%ei%xlp , & ! FWD Input + iVar%ei%ylp , & ! FWD Input + iVar%ei%zlp , & ! FWD Input + Emissivity_AD(i), & ! AD Input + e_AD_4D, wlp_AD, xlp_AD, ylp_AD, zlp_AD ) ! AD Output + ! Set adjoint emissivity to zero + Emissivity_AD(i) = ZERO + + END DO + + ! Compute the snow grain size adjoint + CALL Lpoly_AD(iVar%ei%r , & ! FWD Input + iVar%ei%r_int , & ! FWD Input + iVar%ei%ylp , & ! FWD Input + ylp_AD , & ! AD Input + r_AD , & ! AD Output + Snow_Grain_Size_AD ) ! AD Output + + ! Compute the snow temperature adjoint + CALL Lpoly_AD(iVar%ei%t , & ! FWD Input + iVar%ei%t_int , & ! FWD Input + iVar%ei%zlp , & ! FWD Input + zlp_AD , & ! AD Input + t_AD , & ! AD Output + Snow_Temperature_AD ) ! AD Output + + END FUNCTION CRTM_Compute_IRSnowEM_AD + + +!################################################################################ +!################################################################################ +!## ## +!## ## PRIVATE MODULE ROUTINES ## ## +!## ## +!################################################################################ +!################################################################################ + + ! ---------------------------------------------- + ! Procedures to manipulate the Einterp structure + ! ---------------------------------------------- + ELEMENTAL FUNCTION Einterp_Associated( ei ) RESULT( Status ) + TYPE(Einterp_type), INTENT(IN) :: ei + LOGICAL :: Status + Status = ei%Is_Allocated + END FUNCTION Einterp_Associated + + ELEMENTAL SUBROUTINE Einterp_Create( ei, n_Pts, n_Angles ) + TYPE(Einterp_type), INTENT(OUT) :: ei + INTEGER, INTENT(IN) :: n_Pts + INTEGER, INTENT(IN) :: n_Angles + INTEGER :: alloc_stat + IF ( n_Pts < 1 .OR. n_Angles < 1 ) RETURN + ALLOCATE( ei%wlp(n_Angles) , & + ei%i1(n_Angles) , & + ei%i2(n_Angles) , & + ei%a_outbound(n_Angles), & + ei%a_int(n_Angles) , & + ei%a(n_Pts,n_Angles) , & + ei%f(n_Pts) , & + ei%r(n_Pts) , & + STAT = alloc_stat ) + IF ( alloc_stat /= 0 ) RETURN + ei%n_Angles = n_Angles + ei%n_Pts = n_Pts + ei%Is_Allocated = .TRUE. + END SUBROUTINE Einterp_Create + +END MODULE CRTM_IRSnowEM diff --git a/src/SfcOptics/IR_Water/IRSSEM/CRTM_IRSSEM.f90 b/src/SfcOptics/IR_Water/IRSSEM/CRTM_IRSSEM.f90 index d283f21..36e4cd6 100644 --- a/src/SfcOptics/IR_Water/IRSSEM/CRTM_IRSSEM.f90 +++ b/src/SfcOptics/IR_Water/IRSSEM/CRTM_IRSSEM.f90 @@ -9,6 +9,10 @@ ! Written by: Paul van Delst, 22-Jun-2005 ! paul.vandelst@noaa.gov ! +! Modified by: Cheng Dang, 18-Mar-2022 +! dangch@ucar.edu +! Add water temperature dimension +! MODULE CRTM_IRSSEM @@ -25,10 +29,13 @@ MODULE CRTM_IRSSEM Clear_LPoly, & Find_Index, & Interp_3D, & + Interp_4D, & LPoly_TL, & Interp_3D_TL, & + Interp_4D_TL, & LPoly_AD, & - Interp_3D_AD + Interp_3D_AD, & + Interp_4D_AD USE IRwaterCoeff_Define, ONLY: IRwaterCoeff_type ! Disable implicit typing IMPLICIT NONE @@ -70,22 +77,27 @@ MODULE CRTM_IRSSEM TYPE(LPoly_type), ALLOCATABLE :: wlp(:) ! Angle TYPE(LPoly_type) :: xlp ! Frequency TYPE(LPoly_type) :: ylp ! Wind Speed + TYPE(LPoly_type) :: zlp ! Water Temperature ! The LUT interpolation indices - INTEGER, ALLOCATABLE :: i1(:), i2(:) ! Angle + INTEGER, ALLOCATABLE :: i1(:) , i2(:) ! Angle INTEGER :: j1 , j2 ! Frequency INTEGER :: k1 , k2 ! Wind Speed + INTEGER :: l1 , l2 ! Water Temperature ! The LUT interpolation boundary check LOGICAL, ALLOCATABLE :: a_outbound(:) ! Angle LOGICAL :: f_outbound ! Frequency LOGICAL :: v_outbound ! Wind Speed + LOGICAL :: t_outbound ! Water Temperature ! The interpolation input REAL(fp), ALLOCATABLE :: a_int(:) ! Angle REAL(fp) :: f_int ! Frequency REAL(fp) :: v_int ! Wind Speed + REAL(fp) :: t_int ! Water Temperature ! The data to be interpolated REAL(fp), ALLOCATABLE :: a(:,:) ! Angle REAL(fp), ALLOCATABLE :: f(:) ! Frequency REAL(fp), ALLOCATABLE :: v(:) ! Wind Speed + REAL(fp), ALLOCATABLE :: t(:) ! Water Temperature END TYPE Einterp_type ! The main internal variable structure @@ -120,6 +132,7 @@ MODULE CRTM_IRSSEM ! ! CALLING SEQUENCE: ! Error_Status = CRTM_Compute_IRSSEM( IRwaterCoeff, & +! Water_Temperature , & ! Wind_Speed , & ! Frequency , & ! Angle , & @@ -135,6 +148,12 @@ MODULE CRTM_IRSSEM ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! +! Water_Temperature: Water_Temperature +! UNITS: Kelvin (K) +! TYPE: REAL(fp) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! ! Wind_Speed: Wind speed. ! UNITS: metres per second (m.s^-1) ! TYPE: REAL(fp) @@ -183,18 +202,20 @@ MODULE CRTM_IRSSEM !-------------------------------------------------------------------------------- FUNCTION CRTM_Compute_IRSSEM( & - IRwaterCoeff, & ! Input model coefficients - Wind_Speed , & ! Input - Frequency , & ! Input - Angle , & ! Input - iVar , & ! Internal variable output - Emissivity ) & ! Output + IRwaterCoeff , & ! Input model coefficients + Water_Temperature , & ! Input + Wind_Speed , & ! Input + Frequency , & ! Input + Angle , & ! Input + iVar , & ! Internal variable output + Emissivity ) & ! Output RESULT( err_stat ) ! Arguments TYPE(IRwaterCoeff_type), INTENT(IN) :: IRwaterCoeff - REAL(fp) , INTENT(IN) :: Wind_Speed ! v - REAL(fp) , INTENT(IN) :: Frequency ! f - REAL(fp) , INTENT(IN) :: Angle(:) ! a + REAL(fp) , INTENT(IN) :: Water_Temperature ! t + REAL(fp) , INTENT(IN) :: Wind_Speed ! v + REAL(fp) , INTENT(IN) :: Frequency ! f + REAL(fp) , INTENT(IN) :: Angle(:) ! a TYPE(iVar_type) , INTENT(OUT) :: iVar REAL(fp) , INTENT(OUT) :: Emissivity(:) ! Function result @@ -227,6 +248,20 @@ FUNCTION CRTM_Compute_IRSSEM( & ! ...Convert angles to secants sec_angle = ONE/COS(DEGREES_TO_RADIANS*Angle) + ! Compute the water temperature interpolating polynomial + ! ...Required only for LUT "Nalli2" + ! ...Find the LUT indices and check if input is out of bounds + IF ( IRwaterCoeff%Classification_Name == "Nalli2" ) THEN + iVar%ei%t_int = Water_Temperature + CALL find_index(IRwaterCoeff%Temperature, & + iVar%ei%t_int, iVar%ei%l1, iVar%ei%l2, iVar%ei%t_outbound) + iVar%ei%t = IRwaterCoeff%Temperature(iVar%ei%l1:iVar%ei%l2) + ! ...Compute the polynomial + CALL LPoly( iVar%ei%t , & ! Input + iVar%ei%t_int, & ! Input + iVar%ei%zlp ) ! Output + END IF + ! Compute the wind speed interpolating polynomial ! ...Find the LUT indices and check if input is out of bounds @@ -272,16 +307,28 @@ FUNCTION CRTM_Compute_IRSSEM( & iVar%ei%a_int(i), & ! Input iVar%ei%wlp(i) ) ! Output - ! Compute the interpolated emissivity - CALL Interp_3D( IRwaterCoeff%Emissivity( iVar%ei%i1(i):iVar%ei%i2(i), & - iVar%ei%j1 :iVar%ei%j2 , & - iVar%ei%k1 :iVar%ei%k2 ), & ! Input - iVar%ei%wlp(i), & ! Input - iVar%ei%xlp , & ! Input - iVar%ei%ylp , & ! Input - Emissivity(i) ) ! Output - + IF ( IRwaterCoeff%Classification_Name == "Nalli2" ) THEN + ! WRITE(*,*) 'Interp_4D', Interp_4D + CALL Interp_4D( IRwaterCoeff%Emissivity( iVar%ei%i1(i):iVar%ei%i2(i), & + iVar%ei%j1 :iVar%ei%j2 , & + iVar%ei%k1 :iVar%ei%k2 , & + iVar%ei%l1 :iVar%ei%l2 ), & ! Input + iVar%ei%wlp(i), & ! Input + iVar%ei%xlp , & ! Input + iVar%ei%ylp , & ! Input + iVar%ei%zlp , & ! Input + Emissivity(i) ) ! Output + ELSE + CALL Interp_3D( IRwaterCoeff%Emissivity( iVar%ei%i1(i):iVar%ei%i2(i), & + iVar%ei%j1 :iVar%ei%j2 , & + iVar%ei%k1 :iVar%ei%k2 , & + 1 ), & ! Input + iVar%ei%wlp(i), & ! Input + iVar%ei%xlp , & ! Input + iVar%ei%ylp , & ! Input + Emissivity(i) ) ! Output + END IF END DO END FUNCTION CRTM_Compute_IRSSEM @@ -295,7 +342,8 @@ END FUNCTION CRTM_Compute_IRSSEM ! ! PURPOSE: ! Function to compute the tangent-linear CRTM infrared sea surface -! emissivity (IRSSE) for input wind speed, frequency, and angles. +! emissivity (IRSSE) for input water temperature, wind speed, frequency, +! and angles. ! ! This function must be called *after* the forward model function, ! CRTM_Compute_IRSSEM, has been called. The forward model function @@ -303,6 +351,7 @@ END FUNCTION CRTM_Compute_IRSSEM ! ! CALLING SEQUENCE: ! Error_Status = CRTM_Compute_IRSSEM_TL( IRwaterCoeff , & +! Water_Temperature_TL, & ! Wind_Speed_TL, & ! iVar , & ! Emissivity_TL ) @@ -315,6 +364,12 @@ END FUNCTION CRTM_Compute_IRSSEM ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! +! Water_Temperature_TL: The tangent-linear water temperature. +! UNITS: Kelvin (K) +! TYPE: REAL(fp) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! ! Wind_Speed_TL: The tangent-linear wind speed. ! UNITS: metres per second (m.s^-1) ! TYPE: REAL(fp) @@ -350,13 +405,15 @@ END FUNCTION CRTM_Compute_IRSSEM !-------------------------------------------------------------------------------- FUNCTION CRTM_Compute_IRSSEM_TL( & - IRwaterCoeff , & ! Input model coefficients - Wind_Speed_TL, & ! Input - iVar , & ! Internal variable input - Emissivity_TL) & ! Output + IRwaterCoeff , & ! Input model coefficients + Water_Temperature_TL, & ! Input + Wind_Speed_TL , & ! Input + iVar , & ! Internal variable input + Emissivity_TL ) & ! Output RESULT( err_stat ) ! Arguments TYPE(IRwaterCoeff_type), INTENT(IN) :: IRwaterCoeff + REAL(fp) , INTENT(IN) :: Water_Temperature_TL REAL(fp) , INTENT(IN) :: Wind_Speed_TL TYPE(iVar_type) , INTENT(IN) :: iVar REAL(fp) , INTENT(OUT) :: Emissivity_TL(:) @@ -367,9 +424,9 @@ FUNCTION CRTM_Compute_IRSSEM_TL( & ! Local variables CHARACTER(ML) :: msg INTEGER :: i - REAL(fp) :: v_TL(NPTS) - REAL(fp) :: e_TL(NPTS,NPTS,NPTS) - TYPE(LPoly_Type) :: ylp_TL, xlp_TL, wlp_TL + REAL(fp) :: v_TL(NPTS), t_TL(NPTS) + REAL(fp) :: e_TL_3D(NPTS,NPTS,NPTS), e_TL_4D(NPTS,NPTS,NPTS,NPTS) + TYPE(LPoly_Type) :: ylp_TL, xlp_TL, wlp_TL, zlp_TL ! Set up err_stat = SUCCESS @@ -387,19 +444,33 @@ FUNCTION CRTM_Compute_IRSSEM_TL( & CALL Display_Message( ROUTINE_NAME, msg, err_stat ) RETURN END IF + ! ...No TL if water temperature is out of bounds + IF (IRwaterCoeff%n_Temperature > 1 .AND. iVar%ei%t_outbound) THEN + Emissivity_TL = ZERO + RETURN + END IF ! ...No TL if wind speed is out of bounds IF ( iVar%ei%v_outbound ) THEN Emissivity_TL = ZERO RETURN END IF ! ...Initialise local TL variables + t_TL = ZERO v_TL = ZERO - e_TL = ZERO + e_TL_3D = ZERO + e_TL_4D = ZERO CALL Clear_LPoly(wlp_TL) CALL Clear_LPoly(xlp_TL) ! Calculate the TL interpolating + ! polynomials for water temperature + IF ( IRwaterCoeff%Classification_Name == "Nalli2" ) THEN + CALL LPoly_TL( iVar%ei%t, iVar%ei%t_int, & ! FWD Input + iVar%ei%zlp, & ! FWD Input + t_TL, Water_Temperature_TL, & ! TL Input + zlp_TL ) ! TL Output + END IF ! polynomials for wind speed CALL LPoly_TL( iVar%ei%v, iVar%ei%v_int, & ! FWD Input iVar%ei%ylp, & ! FWD Input @@ -411,14 +482,28 @@ FUNCTION CRTM_Compute_IRSSEM_TL( & DO i = 1, iVar%ei%n_Angles ! Perform interpolation - CALL interp_3D_TL(IRwaterCoeff%Emissivity(iVar%ei%i1(i):iVar%ei%i2(i), & - iVar%ei%j1 :iVar%ei%j2 , & - iVar%ei%k1 :iVar%ei%k2 ), & ! FWD Emissivity input - iVar%ei%wlp(i), & ! FWD polynomial input - iVar%ei%xlp , & ! FWD polynomial input - iVar%ei%ylp , & ! FWD polynomial input - e_TL, wlp_TL, xlp_TL, ylp_TL, & ! TL input - Emissivity_TL(i) ) ! Output + IF ( IRwaterCoeff%Classification_Name == "Nalli2" ) THEN + CALL interp_4D_TL(IRwaterCoeff%Emissivity(iVar%ei%i1(i):iVar%ei%i2(i), & + iVar%ei%j1 :iVar%ei%j2 , & + iVar%ei%k1 :iVar%ei%k2 , & + iVar%ei%l1 :iVar%ei%l2 ), & ! FWD Emissivity input + iVar%ei%wlp(i), & ! FWD polynomial input + iVar%ei%xlp , & ! FWD polynomial input + iVar%ei%ylp , & ! FWD polynomial input + iVar%ei%zlp , & ! FWD polynomial input + e_TL_4D, wlp_TL, xlp_TL, ylp_TL, zlp_TL, & ! TL input + Emissivity_TL(i) ) ! Output + ELSE + CALL interp_3D_TL(IRwaterCoeff%Emissivity(iVar%ei%i1(i):iVar%ei%i2(i), & + iVar%ei%j1 :iVar%ei%j2 , & + iVar%ei%k1 :iVar%ei%k2 , & + 1 ), & ! FWD Emissivity input + iVar%ei%wlp(i), & ! FWD polynomial input + iVar%ei%xlp , & ! FWD polynomial input + iVar%ei%ylp , & ! FWD polynomial input + e_TL_3D, wlp_TL, xlp_TL, ylp_TL, & ! TL input + Emissivity_TL(i) ) ! Output + END IF END DO @@ -440,10 +525,11 @@ END FUNCTION CRTM_Compute_IRSSEM_TL ! populates the internal variable structure argument, iVar. ! ! CALLING SEQUENCE: -! Error_Status = CRTM_Compute_IRSSEM_AD( IRwaterCoeff , & -! Emissivity_AD, & -! iVar , & -! Wind_Speed_AD ) +! Error_Status = CRTM_Compute_IRSSEM_AD( IRwaterCoeff , & +! Emissivity_AD , & +! iVar , & +! Wind_Speed_AD , & +! Water_Temperature_AD ) ! ! INPUTS: ! IRwaterCoeff: Infrared water emissivity model coefficient object. @@ -478,6 +564,13 @@ END FUNCTION CRTM_Compute_IRSSEM_TL ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN OUT) ! +! Water_Temperature_AD: Adjoint water temperature. +! *** MUST HAVE VALUE ON ENTRY *** +! UNITS: per Kelvin, (K)^-1 +! TYPE: REAL(fp) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! ! FUNCTION RESULT: ! Error_Status: The return value is an integer defining the error status. ! The error codes are defined in the Message_Handler module. @@ -491,16 +584,18 @@ END FUNCTION CRTM_Compute_IRSSEM_TL !-------------------------------------------------------------------------------- FUNCTION CRTM_Compute_IRSSEM_AD( & - IRwaterCoeff , & ! Input model coefficients - Emissivity_AD, & ! Input - iVar , & ! Internal Variable Input - Wind_Speed_AD) & ! Output + IRwaterCoeff , & ! Input model coefficients + Emissivity_AD , & ! Input + iVar , & ! Internal Variable Input + Wind_Speed_AD , & ! Output + Water_Temperature_AD ) & ! Output RESULT( err_stat ) ! Arguments TYPE(IRwaterCoeff_type), INTENT(IN) :: IRwaterCoeff REAL(fp) , INTENT(IN OUT) :: Emissivity_AD(:) TYPE(iVar_type) , INTENT(IN) :: iVar REAL(fp) , INTENT(IN OUT) :: Wind_Speed_AD + REAL(fp) , INTENT(IN OUT) :: Water_Temperature_AD ! Function result INTEGER :: err_stat ! Local parameters @@ -508,14 +603,16 @@ FUNCTION CRTM_Compute_IRSSEM_AD( & ! Local variables CHARACTER(ML) :: msg INTEGER :: i - REAL(fp) :: e_AD(NPTS,NPTS,NPTS) - REAL(fp) :: v_AD(NPTS) - TYPE(LPoly_Type) :: wlp_AD, xlp_AD, ylp_AD + REAL(fp) :: e_AD_3D(NPTS,NPTS,NPTS), e_AD_4D(NPTS,NPTS,NPTS,NPTS) + REAL(fp) :: v_AD(NPTS), t_AD(NPTS) + TYPE(LPoly_Type) :: wlp_AD, xlp_AD, ylp_AD, zlp_AD ! Set Up err_stat = SUCCESS - e_AD = ZERO + e_AD_3D = ZERO + e_AD_4D = ZERO v_AD = ZERO + t_AD = ZERO ! ...Check internal variable allocation IF ( .NOT. Einterp_Associated( iVar%ei ) ) THEN err_stat = FAILURE @@ -530,26 +627,42 @@ FUNCTION CRTM_Compute_IRSSEM_AD( & CALL Display_Message( ROUTINE_NAME, msg, err_stat ) RETURN END IF + ! ...No AD if water temperature is out of bounds + IF (IRwaterCoeff%n_Temperature > 1 .AND. iVar%ei%t_outbound) RETURN ! ...No AD if wind speed is out of bounds IF ( iVar%ei%v_outbound ) RETURN ! ...Initialize local variables CALL Clear_LPoly(wlp_AD) CALL Clear_LPoly(xlp_AD) CALL Clear_LPoly(ylp_AD) + CALL Clear_LPoly(zlp_AD) ! Loop over emissivity calculation angles DO i = 1, iVar%ei%n_Angles - - ! Get the adjoint interpoalting polynomial for wind speed - CALL Interp_3D_AD(IRwaterCoeff%Emissivity( iVar%ei%i1(i):iVar%ei%i2(i), & - iVar%ei%j1 :iVar%ei%j2 , & - iVar%ei%k1 :iVar%ei%k2 ), & ! FWD Input - iVar%ei%wlp(i) , & ! FWD Input - iVar%ei%xlp , & ! FWD Input - iVar%ei%ylp , & ! FWD Input - Emissivity_AD(i), & ! AD Input - e_AD, wlp_AD, xlp_AD, ylp_AD ) ! AD Output - + IF ( IRwaterCoeff%Classification_Name == "Nalli2" ) THEN + ! Get the adjoint interpoalting polynomial for wind speed and water temperature + CALL Interp_4D_AD(IRwaterCoeff%Emissivity( iVar%ei%i1(i):iVar%ei%i2(i), & + iVar%ei%j1 :iVar%ei%j2 , & + iVar%ei%k1 :iVar%ei%k2 , & + iVar%ei%l1 :iVar%ei%l2 ), & ! FWD Input + iVar%ei%wlp(i) , & ! FWD Input + iVar%ei%xlp , & ! FWD Input + iVar%ei%ylp , & ! FWD Input + iVar%ei%zlp , & ! FWD Input + Emissivity_AD(i), & ! AD Input + e_AD_4D, wlp_AD, xlp_AD, ylp_AD, zlp_AD ) ! AD Output + ELSE + ! Get the adjoint interpoalting polynomial for wind speed + CALL Interp_3D_AD(IRwaterCoeff%Emissivity( iVar%ei%i1(i):iVar%ei%i2(i), & + iVar%ei%j1 :iVar%ei%j2 , & + iVar%ei%k1 :iVar%ei%k2 , & + 1 ), & ! FWD Input + iVar%ei%wlp(i) , & ! FWD Input + iVar%ei%xlp , & ! FWD Input + iVar%ei%ylp , & ! FWD Input + Emissivity_AD(i), & ! AD Input + e_AD_3D, wlp_AD, xlp_AD, ylp_AD ) ! AD Output + END IF ! Set adjoint emissivity to zero Emissivity_AD(i) = ZERO @@ -563,6 +676,16 @@ FUNCTION CRTM_Compute_IRSSEM_AD( & v_AD , & ! AD Output Wind_Speed_AD ) ! AD Output + ! Compute the water temperature adjoint + IF ( IRwaterCoeff%n_Temperature > 1 ) THEN + CALL Lpoly_AD(iVar%ei%t , & ! FWD Input + iVar%ei%t_int , & ! FWD Input + iVar%ei%zlp , & ! FWD Input + zlp_AD , & ! AD Input + t_AD , & ! AD Output + Water_Temperature_AD ) ! AD Output + END IF + END FUNCTION CRTM_Compute_IRSSEM_AD diff --git a/src/Surface/CRTM_Surface_Define.f90 b/src/Surface/CRTM_Surface_Define.f90 index 8292574..999eb2f 100644 --- a/src/Surface/CRTM_Surface_Define.f90 +++ b/src/Surface/CRTM_Surface_Define.f90 @@ -188,7 +188,7 @@ MODULE CRTM_Surface_Define REAL(fp), PARAMETER :: DEFAULT_SNOW_TEMPERATURE = 263.0_fp ! K REAL(fp), PARAMETER :: DEFAULT_SNOW_DEPTH = 50.0_fp ! mm REAL(fp), PARAMETER :: DEFAULT_SNOW_DENSITY = 0.2_fp ! g/cm^3 - REAL(fp), PARAMETER :: DEFAULT_SNOW_GRAIN_SIZE = 2.0_fp ! mm + REAL(fp), PARAMETER :: DEFAULT_SNOW_GRAIN_SIZE = 2.0e3_fp ! um (microns) ! ...Ice surface type data INTEGER, PARAMETER :: DEFAULT_ICE_TYPE = 1 ! First item in list REAL(fp), PARAMETER :: DEFAULT_ICE_TEMPERATURE = 263.0_fp ! K @@ -421,12 +421,12 @@ ELEMENTAL SUBROUTINE CRTM_Surface_NonVariableCopy( sfc, modified_sfc ) modified_sfc%Water_Coverage = sfc%Water_Coverage modified_sfc%Snow_Coverage = sfc%Snow_Coverage modified_sfc%Ice_Coverage = sfc%Ice_Coverage - + modified_sfc%Land_Type = sfc%Land_Type modified_sfc%Water_Type = sfc%Water_Type modified_sfc%Snow_Type = sfc%Snow_Type modified_sfc%Ice_Type = sfc%Ice_Type - + END SUBROUTINE CRTM_Surface_NonVariableCopy @@ -584,14 +584,14 @@ SUBROUTINE Scalar_Inspect( Sfc, Unit ) INTEGER, OPTIONAL, INTENT(IN) :: Unit ! Local variables INTEGER :: fid - + ! Setup fid = OUTPUT_UNIT IF ( PRESENT(Unit) ) THEN IF ( File_Open(Unit) ) fid = Unit END IF - + WRITE(fid,'(1x,"Surface OBJECT")') ! Surface coverage WRITE(fid,'(3x,"Land Coverage :",1x,f6.3)') Sfc%Land_Coverage @@ -1166,7 +1166,7 @@ SUBROUTINE Read_CleanUp() IF ( io_stat /= 0 ) & msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) END IF - IF ( ALLOCATED(Surface) ) THEN + IF ( ALLOCATED(Surface) ) THEN !DEALLOCATE(Surface, STAT=alloc_stat, ERRMSG=alloc_msg) DEALLOCATE(Surface, STAT=alloc_stat) IF ( alloc_stat /= 0 ) & @@ -1286,7 +1286,7 @@ SUBROUTINE Read_CleanUp() IF ( io_stat /= 0 ) & msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) END IF - IF ( ALLOCATED(Surface) ) THEN + IF ( ALLOCATED(Surface) ) THEN !DEALLOCATE(Surface, STAT=alloc_stat, ERRMSG=alloc_msg) DEALLOCATE(Surface, STAT=alloc_stat) IF ( alloc_stat /= 0 ) & @@ -2396,7 +2396,7 @@ FUNCTION Write_Record( & IF ( PRESENT(Debug) ) THEN IF ( Debug ) noisy = .TRUE. END IF - + ! Write the gross surface type coverage WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) & diff --git a/src/Surface/Create_Test_Surface/Create_Test_Surface.f90 b/src/Surface/Create_Test_Surface/Create_Test_Surface.f90 index 0cdf63d..3bc0a89 100644 --- a/src/Surface/Create_Test_Surface/Create_Test_Surface.f90 +++ b/src/Surface/Create_Test_Surface/Create_Test_Surface.f90 @@ -46,7 +46,7 @@ PROGRAM Create_Test_Surface INTEGER :: Error_Status TYPE(CRTM_Surface_type) :: Surface(N_PROFILES) - + ! Output header ! ------------- CALL Program_Message( PROGRAM_NAME, & @@ -80,7 +80,7 @@ PROGRAM Create_Test_Surface Surface(1)%Snow_Temperature = 270.0_fp Surface(1)%Snow_Depth = 20.0_fp Surface(1)%Snow_Density = 0.25_fp - Surface(1)%Snow_Grain_Size = 1.5_fp + Surface(1)%Snow_Grain_Size = 1.5e3_fp ! Profile 2: Mid-latitude summer @@ -109,7 +109,7 @@ PROGRAM Create_Test_Surface Surface(2)%Snow_Temperature = 270.0_fp Surface(2)%Snow_Depth = 20.0_fp Surface(2)%Snow_Density = 0.25_fp - Surface(2)%Snow_Grain_Size = 1.5_fp + Surface(2)%Snow_Grain_Size = 1.5e3_fp ! Profile 3: Mid-latitude winter @@ -138,7 +138,7 @@ PROGRAM Create_Test_Surface Surface(3)%Snow_Temperature = 265.0_fp Surface(3)%Snow_Depth = 100.0_fp Surface(3)%Snow_Density = 0.1_fp - Surface(3)%Snow_Grain_Size = 0.5_fp + Surface(3)%Snow_Grain_Size = 0.5e3_fp ! Ice surface type data Surface(3)%Ice_Type = FRESH_ICE Surface(3)%Ice_Temperature = 265.0_fp @@ -173,7 +173,7 @@ PROGRAM Create_Test_Surface Surface(4)%Snow_Temperature = 270.0_fp Surface(4)%Snow_Depth = 200.0_fp Surface(4)%Snow_Density = 0.18_fp - Surface(4)%Snow_Grain_Size = 1.0_fp + Surface(4)%Snow_Grain_Size = 1.0e3_fp ! Ice surface type data Surface(4)%Ice_Type = FRESH_ICE Surface(4)%Ice_Temperature = 260.0_fp @@ -208,7 +208,7 @@ PROGRAM Create_Test_Surface Surface(5)%Snow_Temperature = 265.0_fp Surface(5)%Snow_Depth = 400.0_fp Surface(5)%Snow_Density = 0.1_fp - Surface(5)%Snow_Grain_Size = 0.5_fp + Surface(5)%Snow_Grain_Size = 0.5e3_fp ! Ice surface type data Surface(5)%Ice_Type = FRESH_ICE Surface(5)%Ice_Temperature = 255.0_fp @@ -243,7 +243,7 @@ PROGRAM Create_Test_Surface Surface(6)%Snow_Temperature = 268.0_fp Surface(6)%Snow_Depth = 60.0_fp Surface(6)%Snow_Density = 0.2_fp - Surface(6)%Snow_Grain_Size = 1.0_fp + Surface(6)%Snow_Grain_Size = 1.0e3_fp ! Ice surface type data Surface(6)%Ice_Type = FRESH_ICE Surface(6)%Ice_Temperature = 265.0_fp diff --git a/src/Surface/Surface_ConvertFormat/CRTM_Surface_Define_old.f90 b/src/Surface/Surface_ConvertFormat/CRTM_Surface_Define_old.f90 index 4846d91..da06eea 100644 --- a/src/Surface/Surface_ConvertFormat/CRTM_Surface_Define_old.f90 +++ b/src/Surface/Surface_ConvertFormat/CRTM_Surface_Define_old.f90 @@ -328,7 +328,7 @@ MODULE CRTM_Surface_Define_old REAL(fp), PARAMETER :: DEFAULT_SNOW_TEMPERATURE = 263.0_fp ! K REAL(fp), PARAMETER :: DEFAULT_SNOW_DEPTH = 50.0_fp ! mm REAL(fp), PARAMETER :: DEFAULT_SNOW_DENSITY = 0.2_fp ! g/cm^3 - REAL(fp), PARAMETER :: DEFAULT_SNOW_GRAIN_SIZE = 2.0_fp ! mm + REAL(fp), PARAMETER :: DEFAULT_SNOW_GRAIN_SIZE = 2.0e3_fp ! um (microns) ! Ice surface type data INTEGER, PARAMETER :: DEFAULT_ICE_TYPE = FRESH_ICE REAL(fp), PARAMETER :: DEFAULT_ICE_TEMPERATURE = 263.0_fp ! K diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index bc0c7d4..b6f4297 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -446,6 +446,30 @@ foreach(regtype IN LISTS TLAD_types) endforeach() +#================================================================================= +#OpenMP regression tests +foreach(regtype IN LISTS regression_types) + string(COMPARE EQUAL ${regtype} "k_matrix" isregtype) + if (isregtype) + continue() #skip all k_matrix tests + endif() + foreach(testtype IN LISTS omp_tests) + ecbuild_add_executable( TARGET "test_${regtype}_test_${testtype}" + SOURCES "mains/regression/${regtype}/test_${testtype}/test_${testtype}.F90" + LIBS crtm + NOINSTALL) + + foreach(sensor_id IN LISTS ${testtype}_Sensor_Ids) + + ecbuild_add_test( TARGET "test_${regtype}_${testtype}_${sensor_id}" + OMP $ENV{OMP_NUM_THREADS} + COMMAND "test_${regtype}_test_${testtype}" + ARGS "${sensor_id}" + TEST_DEPENDS get_crtm_coeffs) + endforeach() + endforeach() +endforeach() + #--------------------------------------------------------------------------------- # Active sensor module AD/TL test diff --git a/test/crtm_data_downloader.py b/test/crtm_data_downloader.py index fdc5396..81e7fc0 100755 --- a/test/crtm_data_downloader.py +++ b/test/crtm_data_downloader.py @@ -15,9 +15,19 @@ def DownloadUntar(download_base_url, testfiles_path, testfiles_name, md5check): if (md5check == "1"): - urllib.request.urlretrieve( download_base_url+"/"+testfiles_name+".md5", testfiles_path+"/"+testfiles_name+".md5") - - urllib.request.urlretrieve( download_base_url+"/"+testfiles_name, testfiles_path+"/"+testfiles_name) + try: + urllib.request.urlretrieve( download_base_url+"/"+testfiles_name+".md5", testfiles_path+"/"+testfiles_name+".md5") + except: + raise RuntimeError("Downloading md5 checksum file failed!") + try: + urllib.request.urlretrieve( download_base_url+"/"+testfiles_name, testfiles_path+"/"+testfiles_name) + except: + raise RuntimeError("Downloading CRTM test data file failed!") + else: + try: + urllib.request.urlretrieve( download_base_url+"/"+testfiles_name, testfiles_path+"/"+testfiles_name) + except: + raise RuntimeError("Downloading CRTM test data file failed!") tar_file = tarfile.open(testfiles_path+"/"+testfiles_name) tar_file.extractall(testfiles_path) tar_file.close() @@ -30,7 +40,10 @@ def DownloadUntar(download_base_url, testfiles_path, testfiles_name, md5check): print("local files found") # dl md5 save it as *.md5.dl - urllib.request.urlretrieve( download_base_url+"/"+testfiles_name+".md5", testfiles_path+"/"+testfiles_name+".md5.dl") + try: + urllib.request.urlretrieve( download_base_url+"/"+testfiles_name+".md5", testfiles_path+"/"+testfiles_name+".md5.dl") + except: + raise RuntimeError("Downloading md5.dl checksum file from S3 failed!") # compare *md5.dl with md5 local with open(testfiles_path+"/"+testfiles_name+".md5", 'r') as f: diff --git a/test/mains/application/check_crtm.F90 b/test/mains/application/check_crtm.F90 index e70346c..023cb53 100644 --- a/test/mains/application/check_crtm.F90 +++ b/test/mains/application/check_crtm.F90 @@ -182,7 +182,6 @@ PROGRAM check_crtm CloudCoeff_File = 'CloudCoeff.'//TRIM(Cloud_Scheme)//'nc4' END IF - WRITE( *,'(/5x,"Initializing the CRTM...")' ) err_stat = CRTM_Init( SENSOR_ID, & chinfo, & diff --git a/test/mains/application/check_crtm.fpp b/test/mains/application/check_crtm.fpp index e70346c..023cb53 100644 --- a/test/mains/application/check_crtm.fpp +++ b/test/mains/application/check_crtm.fpp @@ -182,7 +182,6 @@ PROGRAM check_crtm CloudCoeff_File = 'CloudCoeff.'//TRIM(Cloud_Scheme)//'nc4' END IF - WRITE( *,'(/5x,"Initializing the CRTM...")' ) err_stat = CRTM_Init( SENSOR_ID, & chinfo, & diff --git a/test/mains/regression/forward/test_OMPoverChannels/Load_Atm_Data.inc b/test/mains/regression/forward/test_OMPoverChannels/Load_Atm_Data.inc new file mode 100644 index 0000000..d8357b8 --- /dev/null +++ b/test/mains/regression/forward/test_OMPoverChannels/Load_Atm_Data.inc @@ -0,0 +1,489 @@ + ! + ! Include file containing an internal subprogam to load some test profile data + ! + SUBROUTINE Load_Atm_Data() + ! Local variables + INTEGER :: nc + INTEGER :: k1, k2 + + + ! 4a.1 Profile #1 + ! --------------- + ! ...Profile and absorber definitions + atm(1)%Climatology = US_STANDARD_ATMOSPHERE + atm(1)%Absorber_Id(1:2) = (/ H2O_ID , O3_ID /) + atm(1)%Absorber_Units(1:2) = (/ MASS_MIXING_RATIO_UNITS, VOLUME_MIXING_RATIO_UNITS /) + ! ...Profile data + atm(1)%Level_Pressure = & + (/0.714_fp, 0.975_fp, 1.297_fp, 1.687_fp, 2.153_fp, 2.701_fp, 3.340_fp, 4.077_fp, & + 4.920_fp, 5.878_fp, 6.957_fp, 8.165_fp, 9.512_fp, 11.004_fp, 12.649_fp, 14.456_fp, & + 16.432_fp, 18.585_fp, 20.922_fp, 23.453_fp, 26.183_fp, 29.121_fp, 32.274_fp, 35.650_fp, & + 39.257_fp, 43.100_fp, 47.188_fp, 51.528_fp, 56.126_fp, 60.990_fp, 66.125_fp, 71.540_fp, & + 77.240_fp, 83.231_fp, 89.520_fp, 96.114_fp, 103.017_fp, 110.237_fp, 117.777_fp, 125.646_fp, & + 133.846_fp, 142.385_fp, 151.266_fp, 160.496_fp, 170.078_fp, 180.018_fp, 190.320_fp, 200.989_fp, & + 212.028_fp, 223.441_fp, 235.234_fp, 247.409_fp, 259.969_fp, 272.919_fp, 286.262_fp, 300.000_fp, & + 314.137_fp, 328.675_fp, 343.618_fp, 358.967_fp, 374.724_fp, 390.893_fp, 407.474_fp, 424.470_fp, & + 441.882_fp, 459.712_fp, 477.961_fp, 496.630_fp, 515.720_fp, 535.232_fp, 555.167_fp, 575.525_fp, & + 596.306_fp, 617.511_fp, 639.140_fp, 661.192_fp, 683.667_fp, 706.565_fp, 729.886_fp, 753.627_fp, & + 777.790_fp, 802.371_fp, 827.371_fp, 852.788_fp, 878.620_fp, 904.866_fp, 931.524_fp, 958.591_fp, & + 986.067_fp,1013.948_fp,1042.232_fp,1070.917_fp,1100.000_fp/) + + atm(1)%Pressure = & + (/0.838_fp, 1.129_fp, 1.484_fp, 1.910_fp, 2.416_fp, 3.009_fp, 3.696_fp, 4.485_fp, & + 5.385_fp, 6.402_fp, 7.545_fp, 8.822_fp, 10.240_fp, 11.807_fp, 13.532_fp, 15.423_fp, & + 17.486_fp, 19.730_fp, 22.163_fp, 24.793_fp, 27.626_fp, 30.671_fp, 33.934_fp, 37.425_fp, & + 41.148_fp, 45.113_fp, 49.326_fp, 53.794_fp, 58.524_fp, 63.523_fp, 68.797_fp, 74.353_fp, & + 80.198_fp, 86.338_fp, 92.778_fp, 99.526_fp, 106.586_fp, 113.965_fp, 121.669_fp, 129.703_fp, & + 138.072_fp, 146.781_fp, 155.836_fp, 165.241_fp, 175.001_fp, 185.121_fp, 195.606_fp, 206.459_fp, & + 217.685_fp, 229.287_fp, 241.270_fp, 253.637_fp, 266.392_fp, 279.537_fp, 293.077_fp, 307.014_fp, & + 321.351_fp, 336.091_fp, 351.236_fp, 366.789_fp, 382.751_fp, 399.126_fp, 415.914_fp, 433.118_fp, & + 450.738_fp, 468.777_fp, 487.236_fp, 506.115_fp, 525.416_fp, 545.139_fp, 565.285_fp, 585.854_fp, & + 606.847_fp, 628.263_fp, 650.104_fp, 672.367_fp, 695.054_fp, 718.163_fp, 741.693_fp, 765.645_fp, & + 790.017_fp, 814.807_fp, 840.016_fp, 865.640_fp, 891.679_fp, 918.130_fp, 944.993_fp, 972.264_fp, & + 999.942_fp,1028.025_fp,1056.510_fp,1085.394_fp/) + + atm(1)%Temperature = & + (/256.186_fp, 252.608_fp, 247.762_fp, 243.314_fp, 239.018_fp, 235.282_fp, 233.777_fp, 234.909_fp, & + 237.889_fp, 241.238_fp, 243.194_fp, 243.304_fp, 242.977_fp, 243.133_fp, 242.920_fp, 242.026_fp, & + 240.695_fp, 239.379_fp, 238.252_fp, 236.928_fp, 235.452_fp, 234.561_fp, 234.192_fp, 233.774_fp, & + 233.305_fp, 233.053_fp, 233.103_fp, 233.307_fp, 233.702_fp, 234.219_fp, 234.959_fp, 235.940_fp, & + 236.744_fp, 237.155_fp, 237.374_fp, 238.244_fp, 239.736_fp, 240.672_fp, 240.688_fp, 240.318_fp, & + 239.888_fp, 239.411_fp, 238.512_fp, 237.048_fp, 235.388_fp, 233.551_fp, 231.620_fp, 230.418_fp, & + 229.927_fp, 229.511_fp, 229.197_fp, 228.947_fp, 228.772_fp, 228.649_fp, 228.567_fp, 228.517_fp, & + 228.614_fp, 228.861_fp, 229.376_fp, 230.223_fp, 231.291_fp, 232.591_fp, 234.013_fp, 235.508_fp, & + 237.041_fp, 238.589_fp, 240.165_fp, 241.781_fp, 243.399_fp, 244.985_fp, 246.495_fp, 247.918_fp, & + 249.073_fp, 250.026_fp, 251.113_fp, 252.321_fp, 253.550_fp, 254.741_fp, 256.089_fp, 257.692_fp, & + 259.358_fp, 261.010_fp, 262.779_fp, 264.702_fp, 266.711_fp, 268.863_fp, 271.103_fp, 272.793_fp, & + 273.356_fp, 273.356_fp, 273.356_fp, 273.356_fp/) + + atm(1)%Absorber(:,1) = & + (/4.187E-03_fp,4.401E-03_fp,4.250E-03_fp,3.688E-03_fp,3.516E-03_fp,3.739E-03_fp,3.694E-03_fp,3.449E-03_fp, & + 3.228E-03_fp,3.212E-03_fp,3.245E-03_fp,3.067E-03_fp,2.886E-03_fp,2.796E-03_fp,2.704E-03_fp,2.617E-03_fp, & + 2.568E-03_fp,2.536E-03_fp,2.506E-03_fp,2.468E-03_fp,2.427E-03_fp,2.438E-03_fp,2.493E-03_fp,2.543E-03_fp, & + 2.586E-03_fp,2.632E-03_fp,2.681E-03_fp,2.703E-03_fp,2.636E-03_fp,2.512E-03_fp,2.453E-03_fp,2.463E-03_fp, & + 2.480E-03_fp,2.499E-03_fp,2.526E-03_fp,2.881E-03_fp,3.547E-03_fp,4.023E-03_fp,4.188E-03_fp,4.223E-03_fp, & + 4.252E-03_fp,4.275E-03_fp,4.105E-03_fp,3.675E-03_fp,3.196E-03_fp,2.753E-03_fp,2.338E-03_fp,2.347E-03_fp, & + 2.768E-03_fp,3.299E-03_fp,3.988E-03_fp,4.531E-03_fp,4.625E-03_fp,4.488E-03_fp,4.493E-03_fp,4.614E-03_fp, & + 7.523E-03_fp,1.329E-02_fp,2.468E-02_fp,4.302E-02_fp,6.688E-02_fp,9.692E-02_fp,1.318E-01_fp,1.714E-01_fp, & + 2.149E-01_fp,2.622E-01_fp,3.145E-01_fp,3.726E-01_fp,4.351E-01_fp,5.002E-01_fp,5.719E-01_fp,6.507E-01_fp, & + 7.110E-01_fp,7.552E-01_fp,8.127E-01_fp,8.854E-01_fp,9.663E-01_fp,1.050E+00_fp,1.162E+00_fp,1.316E+00_fp, & + 1.494E+00_fp,1.690E+00_fp,1.931E+00_fp,2.226E+00_fp,2.574E+00_fp,2.939E+00_fp,3.187E+00_fp,3.331E+00_fp, & + 3.352E+00_fp,3.260E+00_fp,3.172E+00_fp,3.087E+00_fp/) + + atm(1)%Absorber(:,2) = & + (/3.035E+00_fp,3.943E+00_fp,4.889E+00_fp,5.812E+00_fp,6.654E+00_fp,7.308E+00_fp,7.660E+00_fp,7.745E+00_fp, & + 7.696E+00_fp,7.573E+00_fp,7.413E+00_fp,7.246E+00_fp,7.097E+00_fp,6.959E+00_fp,6.797E+00_fp,6.593E+00_fp, & + 6.359E+00_fp,6.110E+00_fp,5.860E+00_fp,5.573E+00_fp,5.253E+00_fp,4.937E+00_fp,4.625E+00_fp,4.308E+00_fp, & + 3.986E+00_fp,3.642E+00_fp,3.261E+00_fp,2.874E+00_fp,2.486E+00_fp,2.102E+00_fp,1.755E+00_fp,1.450E+00_fp, & + 1.208E+00_fp,1.087E+00_fp,1.030E+00_fp,1.005E+00_fp,1.010E+00_fp,1.028E+00_fp,1.068E+00_fp,1.109E+00_fp, & + 1.108E+00_fp,1.071E+00_fp,9.928E-01_fp,8.595E-01_fp,7.155E-01_fp,5.778E-01_fp,4.452E-01_fp,3.372E-01_fp, & + 2.532E-01_fp,1.833E-01_fp,1.328E-01_fp,9.394E-02_fp,6.803E-02_fp,5.152E-02_fp,4.569E-02_fp,4.855E-02_fp, & + 5.461E-02_fp,6.398E-02_fp,7.205E-02_fp,7.839E-02_fp,8.256E-02_fp,8.401E-02_fp,8.412E-02_fp,8.353E-02_fp, & + 8.269E-02_fp,8.196E-02_fp,8.103E-02_fp,7.963E-02_fp,7.741E-02_fp,7.425E-02_fp,7.067E-02_fp,6.702E-02_fp, & + 6.368E-02_fp,6.070E-02_fp,5.778E-02_fp,5.481E-02_fp,5.181E-02_fp,4.920E-02_fp,4.700E-02_fp,4.478E-02_fp, & + 4.207E-02_fp,3.771E-02_fp,3.012E-02_fp,1.941E-02_fp,9.076E-03_fp,2.980E-03_fp,5.117E-03_fp,1.160E-02_fp, & + 1.428E-02_fp,1.428E-02_fp,1.428E-02_fp,1.428E-02_fp/) + + + ! Load CO2 absorber data if there are three absorrbers + IF ( atm(1)%n_Absorbers > 2 ) THEN + atm(1)%Absorber_Id(3) = CO2_ID + atm(1)%Absorber_Units(3) = VOLUME_MIXING_RATIO_UNITS + atm(1)%Absorber(:,3) = 380.0_fp + END IF + + + ! Cloud data + IF ( atm(1)%n_Clouds > 0 ) THEN + k1 = 75 + k2 = 79 + DO nc = 1, atm(1)%n_Clouds + atm(1)%Cloud(nc)%Type = WATER_CLOUD + atm(1)%Cloud(nc)%Effective_Radius(k1:k2) = 20.0_fp ! microns + atm(1)%Cloud(nc)%Water_Content(k1:k2) = 5.0_fp ! kg/m^2 + END DO + END IF + + + ! Aerosol data. Three aerosol types can be loaded: + ! Dust, Sulphate, and Sea Salt SSCM3 + Load_Aerosol_Data_1: IF ( atm(1)%n_Aerosols > 0 ) THEN + atm(1)%Aerosol(1)%Type = DUST_AEROSOL + atm(1)%Aerosol(1)%Effective_Radius = & ! microns + (/0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 5.305110E-16_fp, & + 7.340409E-16_fp, 1.037097E-15_fp, 1.496791E-15_fp, 2.207471E-15_fp, 3.327732E-15_fp, & + 5.128933E-15_fp, 8.083748E-15_fp, 1.303055E-14_fp, 2.148368E-14_fp, 3.622890E-14_fp, & + 6.248544E-14_fp, 1.102117E-13_fp, 1.987557E-13_fp, 3.663884E-13_fp, 6.901587E-13_fp, & + 1.327896E-12_fp, 2.608405E-12_fp, 5.228012E-12_fp, 1.068482E-11_fp, 2.225098E-11_fp, & + 4.717675E-11_fp, 1.017447E-10_fp, 2.229819E-10_fp, 4.960579E-10_fp, 1.118899E-09_fp, & + 2.555617E-09_fp, 5.902789E-09_fp, 1.376717E-08_fp, 3.237321E-08_fp, 7.662427E-08_fp, & + 1.822344E-07_fp, 4.346896E-07_fp, 1.037940E-06_fp, 2.475858E-06_fp, 5.887266E-06_fp, & + 1.392410E-05_fp, 3.267943E-05_fp, 7.592447E-05_fp, 1.741777E-04_fp, 3.935216E-04_fp, & + 8.732308E-04_fp, 1.897808E-03_fp, 4.027868E-03_fp, 8.323272E-03_fp, 1.669418E-02_fp, & + 3.239702E-02_fp, 6.063055E-02_fp, 1.090596E-01_fp, 1.878990E-01_fp, 3.089856E-01_fp, & + 4.832092E-01_fp, 7.159947E-01_fp, 1.001436E+00_fp, 1.317052E+00_fp, 1.622354E+00_fp, & + 1.864304E+00_fp, 1.990457E+00_fp, 1.966354E+00_fp, 1.789883E+00_fp, 1.494849E+00_fp, & + 1.140542E+00_fp, 7.915451E-01_fp, 4.974823E-01_fp, 2.818937E-01_fp, 1.433668E-01_fp, & + 6.514795E-02_fp, 2.633057E-02_fp, 9.421763E-03_fp, 2.971053E-03_fp, 8.218245E-04_fp/) + atm(1)%Aerosol(1)%Concentration = & ! kg/m^2 + (/0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 2.458105E-18_fp, 1.983430E-16_fp, & + 1.191432E-14_fp, 5.276880E-13_fp, 1.710270E-11_fp, 4.035105E-10_fp, 6.911389E-09_fp, & + 8.594215E-08_fp, 7.781797E-07_fp, 5.162773E-06_fp, 2.534018E-05_fp, 9.325154E-05_fp, & + 2.617738E-04_fp, 5.727150E-04_fp, 1.002153E-03_fp, 1.446048E-03_fp, 1.782757E-03_fp, & + 1.955759E-03_fp, 1.999206E-03_fp, 1.994698E-03_fp, 1.913109E-03_fp, 1.656122E-03_fp, & + 1.206328E-03_fp, 6.847261E-04_fp, 2.785695E-04_fp, 7.418821E-05_fp, 1.172680E-05_fp, & + 9.900895E-07_fp, 3.987399E-08_fp, 6.786932E-10_fp, 4.291151E-12_fp, 8.785440E-15_fp/) + + IF ( atm(1)%n_Aerosols > 1 ) THEN + atm(1)%Aerosol(2)%Type = SULFATE_AEROSOL + atm(1)%Aerosol(2)%Effective_Radius = & ! microns + (/0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.060238E-01_fp, 3.652677E-01_fp, 4.139419E-01_fp, 4.438249E-01_fp, & + 4.486394E-01_fp, 4.261471E-01_fp, 3.795067E-01_fp, 3.174571E-01_fp, 3.000000E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.243099E-01_fp, 4.662931E-01_fp, & + 6.103025E-01_fp, 6.958640E-01_fp, 6.776480E-01_fp, 5.570077E-01_fp, 3.828734E-01_fp, & + 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp, 3.000000E-01_fp/) + atm(1)%Aerosol(2)%Concentration = & ! kg/m^2 + (/0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 7.299549E-21_fp, 2.154532E-20_fp, 6.848207E-20_fp, & + 2.339296E-19_fp, 8.562906E-19_fp, 3.346100E-18_fp, 1.389284E-17_fp, 6.094260E-17_fp, & + 2.805828E-16_fp, 1.345656E-15_fp, 6.665967E-15_fp, 3.378989E-14_fp, 1.734933E-13_fp, & + 8.924837E-13_fp, 4.546743E-12_fp, 2.266249E-11_fp, 1.091369E-10_fp, 5.013496E-10_fp, & + 2.168936E-09_fp, 8.725800E-09_fp, 3.224980E-08_fp, 1.082545E-07_fp, 3.266343E-07_fp, & + 8.780083E-07_fp, 2.087760E-06_fp, 4.370441E-06_fp, 8.038113E-06_fp, 1.300537E-05_fp, & + 1.860671E-05_fp, 2.376757E-05_fp, 2.751048E-05_fp, 2.945706E-05_fp, 2.998589E-05_fp, & + 2.995521E-05_fp, 2.909387E-05_fp, 2.609907E-05_fp, 2.031620E-05_fp, 1.274989E-05_fp, & + 5.920554E-06_fp, 1.842346E-06_fp, 3.429331E-07_fp, 3.355556E-08_fp, 1.506455E-09_fp, & + 1.720306E-10_fp, 1.161071E-09_fp, 7.599420E-09_fp, 4.096076E-08_fp, 1.815570E-07_fp, & + 6.623233E-07_fp, 1.994766E-06_fp, 4.987904E-06_fp, 1.044158E-05_fp, 1.850659E-05_fp, & + 2.817442E-05_fp, 3.750360E-05_fp, 4.459276E-05_fp, 4.857087E-05_fp, 4.990199E-05_fp, & + 4.998888E-05_fp, 4.922362E-05_fp, 4.582548E-05_fp, 3.844906E-05_fp, 2.757877E-05_fp, & + 1.615474E-05_fp, 9.509965E-06_fp, 1.672265E-05_fp, 4.602962E-05_fp, 8.740809E-05_fp, & + 1.165118E-04_fp, 1.248318E-04_fp, 1.240508E-04_fp, 1.095622E-04_fp, 7.116027E-05_fp, & + 2.756351E-05_fp, 5.072010E-06_fp, 3.467497E-07_fp, 6.759169E-09_fp, 2.828000E-11_fp/) + END IF + + IF ( atm(1)%n_Aerosols > 2 ) THEN + atm(1)%Aerosol(3)%Type = SEASALT_SSCM3_AEROSOL + atm(1)%Aerosol(3)%Effective_Radius = & ! microns + (/7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, & + 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp, 7.600000E+00_fp/) + atm(1)%Aerosol(3)%Concentration = & ! kg/m^2 + (/1.834405E-15_fp, 2.004881E-15_fp, & + 2.234084E-15_fp, 2.543453E-15_fp, 2.964461E-15_fp, 3.544295E-15_fp, 4.355235E-15_fp, & + 5.510452E-15_fp, 7.191267E-15_fp, 9.695182E-15_fp, 1.352261E-14_fp, 1.953716E-14_fp, & + 2.926925E-14_fp, 4.550553E-14_fp, 7.346181E-14_fp, 1.231759E-13_fp, 2.145104E-13_fp, & + 3.878653E-13_fp, 7.276576E-13_fp, 1.414927E-12_fp, 2.847645E-12_fp, 5.921044E-12_fp, & + 1.269153E-11_fp, 2.797048E-11_fp, 6.318984E-11_fp, 1.458383E-10_fp, 3.425444E-10_fp, & + 8.153831E-10_fp, 1.958067E-09_fp, 4.720525E-09_fp, 1.136570E-08_fp, 2.718180E-08_fp, & + 6.420674E-08_fp, 1.489302E-07_fp, 3.372331E-07_fp, 7.410874E-07_fp, 1.571399E-06_fp, & + 3.197064E-06_fp, 6.208220E-06_fp, 1.145048E-05_fp, 1.997373E-05_fp, 3.283395E-05_fp, & + 5.072822E-05_fp, 7.354173E-05_fp, 1.000035E-04_fp, 1.276931E-04_fp, 1.535301E-04_fp, & + 1.746342E-04_fp, 1.892127E-04_fp, 1.971011E-04_fp, 1.997815E-04_fp, 1.999842E-04_fp, & + 1.985580E-04_fp, 1.917087E-04_fp, 1.753846E-04_fp, 1.474980E-04_fp, 1.101113E-04_fp, & + 7.010137E-05_fp, 3.636523E-05_fp, 1.460058E-05_fp, 4.282477E-06_fp, 8.603007E-07_fp, & + 1.101800E-07_fp, 8.310010E-09_fp, 3.382006E-10_fp, 6.751810E-12_fp, 3.060195E-13_fp, & + 9.145434E-12_fp, 2.343817E-10_fp, 4.156377E-09_fp, 5.122906E-08_fp, 4.424084E-07_fp, & + 2.708849E-06_fp, 1.194846E-05_fp, 3.874236E-05_fp, 9.466062E-05_fp, 1.795200E-04_fp, & + 2.735688E-04_fp, 3.486493E-04_fp, 3.889143E-04_fp, 3.997242E-04_fp, 3.991008E-04_fp, & + 3.826235E-04_fp, 3.287943E-04_fp, 2.344766E-04_fp, 1.275907E-04_fp, 4.835821E-05_fp, & + 1.156687E-05_fp, 1.570009E-06_fp, 1.078885E-07_fp, 3.321985E-09_fp, 4.023206E-11_fp/) + END IF + END IF Load_Aerosol_Data_1 + + + + ! 4a.2 Profile #2 + ! --------------- + ! ...Profile and absorber definitions + atm(2)%Climatology = TROPICAL + atm(2)%Absorber_Id(1:2) = (/ H2O_ID , O3_ID /) + atm(2)%Absorber_Units(1:2) = (/ MASS_MIXING_RATIO_UNITS, VOLUME_MIXING_RATIO_UNITS /) + ! ...Profile data + atm(2)%Level_Pressure = & + (/0.714_fp, 0.975_fp, 1.297_fp, 1.687_fp, 2.153_fp, 2.701_fp, 3.340_fp, 4.077_fp, & + 4.920_fp, 5.878_fp, 6.957_fp, 8.165_fp, 9.512_fp, 11.004_fp, 12.649_fp, 14.456_fp, & + 16.432_fp, 18.585_fp, 20.922_fp, 23.453_fp, 26.183_fp, 29.121_fp, 32.274_fp, 35.650_fp, & + 39.257_fp, 43.100_fp, 47.188_fp, 51.528_fp, 56.126_fp, 60.990_fp, 66.125_fp, 71.540_fp, & + 77.240_fp, 83.231_fp, 89.520_fp, 96.114_fp, 103.017_fp, 110.237_fp, 117.777_fp, 125.646_fp, & + 133.846_fp, 142.385_fp, 151.266_fp, 160.496_fp, 170.078_fp, 180.018_fp, 190.320_fp, 200.989_fp, & + 212.028_fp, 223.441_fp, 235.234_fp, 247.409_fp, 259.969_fp, 272.919_fp, 286.262_fp, 300.000_fp, & + 314.137_fp, 328.675_fp, 343.618_fp, 358.967_fp, 374.724_fp, 390.893_fp, 407.474_fp, 424.470_fp, & + 441.882_fp, 459.712_fp, 477.961_fp, 496.630_fp, 515.720_fp, 535.232_fp, 555.167_fp, 575.525_fp, & + 596.306_fp, 617.511_fp, 639.140_fp, 661.192_fp, 683.667_fp, 706.565_fp, 729.886_fp, 753.627_fp, & + 777.790_fp, 802.371_fp, 827.371_fp, 852.788_fp, 878.620_fp, 904.866_fp, 931.524_fp, 958.591_fp, & + 986.067_fp,1013.948_fp,1042.232_fp,1070.917_fp,1100.000_fp/) + + atm(2)%Pressure = & + (/0.838_fp, 1.129_fp, 1.484_fp, 1.910_fp, 2.416_fp, 3.009_fp, 3.696_fp, 4.485_fp, & + 5.385_fp, 6.402_fp, 7.545_fp, 8.822_fp, 10.240_fp, 11.807_fp, 13.532_fp, 15.423_fp, & + 17.486_fp, 19.730_fp, 22.163_fp, 24.793_fp, 27.626_fp, 30.671_fp, 33.934_fp, 37.425_fp, & + 41.148_fp, 45.113_fp, 49.326_fp, 53.794_fp, 58.524_fp, 63.523_fp, 68.797_fp, 74.353_fp, & + 80.198_fp, 86.338_fp, 92.778_fp, 99.526_fp, 106.586_fp, 113.965_fp, 121.669_fp, 129.703_fp, & + 138.072_fp, 146.781_fp, 155.836_fp, 165.241_fp, 175.001_fp, 185.121_fp, 195.606_fp, 206.459_fp, & + 217.685_fp, 229.287_fp, 241.270_fp, 253.637_fp, 266.392_fp, 279.537_fp, 293.077_fp, 307.014_fp, & + 321.351_fp, 336.091_fp, 351.236_fp, 366.789_fp, 382.751_fp, 399.126_fp, 415.914_fp, 433.118_fp, & + 450.738_fp, 468.777_fp, 487.236_fp, 506.115_fp, 525.416_fp, 545.139_fp, 565.285_fp, 585.854_fp, & + 606.847_fp, 628.263_fp, 650.104_fp, 672.367_fp, 695.054_fp, 718.163_fp, 741.693_fp, 765.645_fp, & + 790.017_fp, 814.807_fp, 840.016_fp, 865.640_fp, 891.679_fp, 918.130_fp, 944.993_fp, 972.264_fp, & + 999.942_fp,1028.025_fp,1056.510_fp,1085.394_fp/) + + atm(2)%Temperature = & + (/266.536_fp, 269.608_fp, 270.203_fp, 264.526_fp, 251.578_fp, 240.264_fp, 235.095_fp, 232.959_fp, & + 233.017_fp, 233.897_fp, 234.385_fp, 233.681_fp, 232.436_fp, 231.607_fp, 231.192_fp, 230.808_fp, & + 230.088_fp, 228.603_fp, 226.407_fp, 223.654_fp, 220.525_fp, 218.226_fp, 216.668_fp, 215.107_fp, & + 213.538_fp, 212.006_fp, 210.507_fp, 208.883_fp, 206.793_fp, 204.415_fp, 202.058_fp, 199.718_fp, & + 197.668_fp, 196.169_fp, 194.993_fp, 194.835_fp, 195.648_fp, 196.879_fp, 198.830_fp, 201.091_fp, & + 203.558_fp, 206.190_fp, 208.900_fp, 211.736_fp, 214.601_fp, 217.522_fp, 220.457_fp, 223.334_fp, & + 226.156_fp, 228.901_fp, 231.557_fp, 234.173_fp, 236.788_fp, 239.410_fp, 242.140_fp, 244.953_fp, & + 247.793_fp, 250.665_fp, 253.216_fp, 255.367_fp, 257.018_fp, 258.034_fp, 258.778_fp, 259.454_fp, & + 260.225_fp, 261.251_fp, 262.672_fp, 264.614_fp, 266.854_fp, 269.159_fp, 271.448_fp, 273.673_fp, & + 275.955_fp, 278.341_fp, 280.822_fp, 283.349_fp, 285.826_fp, 288.288_fp, 290.721_fp, 293.135_fp, & + 295.609_fp, 298.173_fp, 300.787_fp, 303.379_fp, 305.960_fp, 308.521_fp, 310.916_fp, 313.647_fp, & + 315.244_fp, 315.244_fp, 315.244_fp, 315.244_fp/) + + atm(2)%Absorber(:,1) = & + (/3.887E-03_fp,3.593E-03_fp,3.055E-03_fp,2.856E-03_fp,2.921E-03_fp,2.555E-03_fp,2.392E-03_fp,2.605E-03_fp, & + 2.573E-03_fp,2.368E-03_fp,2.354E-03_fp,2.333E-03_fp,2.312E-03_fp,2.297E-03_fp,2.287E-03_fp,2.283E-03_fp, & + 2.282E-03_fp,2.286E-03_fp,2.296E-03_fp,2.309E-03_fp,2.324E-03_fp,2.333E-03_fp,2.335E-03_fp,2.335E-03_fp, & + 2.333E-03_fp,2.340E-03_fp,2.361E-03_fp,2.388E-03_fp,2.421E-03_fp,2.458E-03_fp,2.492E-03_fp,2.523E-03_fp, & + 2.574E-03_fp,2.670E-03_fp,2.789E-03_fp,2.944E-03_fp,3.135E-03_fp,3.329E-03_fp,3.530E-03_fp,3.759E-03_fp, & + 4.165E-03_fp,4.718E-03_fp,5.352E-03_fp,6.099E-03_fp,6.845E-03_fp,7.524E-03_fp,8.154E-03_fp,8.381E-03_fp, & + 8.214E-03_fp,8.570E-03_fp,9.672E-03_fp,1.246E-02_fp,1.880E-02_fp,2.720E-02_fp,3.583E-02_fp,4.462E-02_fp, & + 4.548E-02_fp,3.811E-02_fp,3.697E-02_fp,4.440E-02_fp,2.130E-01_fp,6.332E-01_fp,9.945E-01_fp,1.073E+00_fp, & + 1.196E+00_fp,1.674E+00_fp,2.323E+00_fp,2.950E+00_fp,3.557E+00_fp,4.148E+00_fp,4.666E+00_fp,5.092E+00_fp, & + 5.487E+00_fp,5.852E+00_fp,6.137E+00_fp,6.297E+00_fp,6.338E+00_fp,6.234E+00_fp,5.906E+00_fp,5.476E+00_fp, & + 5.176E+00_fp,4.994E+00_fp,4.884E+00_fp,4.832E+00_fp,4.791E+00_fp,4.760E+00_fp,4.736E+00_fp,6.368E+00_fp, & + 7.897E+00_fp,7.673E+00_fp,7.458E+00_fp,7.252E+00_fp/) + + atm(2)%Absorber(:,2) = & + (/2.742E+00_fp,3.386E+00_fp,4.164E+00_fp,5.159E+00_fp,6.357E+00_fp,7.430E+00_fp,8.174E+00_fp,8.657E+00_fp, & + 8.930E+00_fp,9.056E+00_fp,9.077E+00_fp,8.988E+00_fp,8.778E+00_fp,8.480E+00_fp,8.123E+00_fp,7.694E+00_fp, & + 7.207E+00_fp,6.654E+00_fp,6.060E+00_fp,5.464E+00_fp,4.874E+00_fp,4.299E+00_fp,3.739E+00_fp,3.202E+00_fp, & + 2.688E+00_fp,2.191E+00_fp,1.710E+00_fp,1.261E+00_fp,8.835E-01_fp,5.551E-01_fp,3.243E-01_fp,1.975E-01_fp, & + 1.071E-01_fp,7.026E-02_fp,6.153E-02_fp,5.869E-02_fp,6.146E-02_fp,6.426E-02_fp,6.714E-02_fp,6.989E-02_fp, & + 7.170E-02_fp,7.272E-02_fp,7.346E-02_fp,7.383E-02_fp,7.406E-02_fp,7.418E-02_fp,7.424E-02_fp,7.411E-02_fp, & + 7.379E-02_fp,7.346E-02_fp,7.312E-02_fp,7.284E-02_fp,7.274E-02_fp,7.273E-02_fp,7.272E-02_fp,7.270E-02_fp, & + 7.257E-02_fp,7.233E-02_fp,7.167E-02_fp,7.047E-02_fp,6.920E-02_fp,6.803E-02_fp,6.729E-02_fp,6.729E-02_fp, & + 6.753E-02_fp,6.756E-02_fp,6.717E-02_fp,6.615E-02_fp,6.510E-02_fp,6.452E-02_fp,6.440E-02_fp,6.463E-02_fp, & + 6.484E-02_fp,6.487E-02_fp,6.461E-02_fp,6.417E-02_fp,6.382E-02_fp,6.378E-02_fp,6.417E-02_fp,6.482E-02_fp, & + 6.559E-02_fp,6.638E-02_fp,6.722E-02_fp,6.841E-02_fp,6.944E-02_fp,6.720E-02_fp,6.046E-02_fp,4.124E-02_fp, & + 2.624E-02_fp,2.623E-02_fp,2.622E-02_fp,2.622E-02_fp/) + + + ! Load CO2 absorrber data if there are three absorrbers + IF ( atm(2)%n_Absorbers > 2 ) THEN + atm(2)%Absorber_Id(3) = CO2_ID + atm(2)%Absorber_Units(3) = VOLUME_MIXING_RATIO_UNITS + atm(2)%Absorber(:,3) = & + (/1.100e+02_fp,2.700e+02_fp,3.200e+02_fp,3.300e+02_fp,3.200e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp, & + 3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp, & + 3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp, & + 3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp, & + 3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp, & + 3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp, & + 3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp, & + 3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp, & + 3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp, & + 3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp, & + 3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp, & + 3.300e+02_fp,3.300e+02_fp,3.300e+02_fp,3.300e+02_fp /) + END IF + + + ! Cloud data + IF ( atm(2)%n_Clouds > 0 ) THEN + k1 = 73 + k2 = 90 + DO nc = 1, atm(2)%n_Clouds + atm(2)%Cloud(nc)%Type = RAIN_CLOUD + atm(2)%Cloud(nc)%Effective_Radius(k1:k2) = 1000.0_fp ! microns + atm(2)%Cloud(nc)%Water_Content(k1:k2) = 5.0_fp ! kg/m^2 + END DO + END IF + + + ! Aerosol data. Three aerosol types can be loaded: + ! Sea Sat SSAM, Sea Salt SSCM1, and Sea Salt SSCM2 + Load_Aerosol_Data_2: IF ( atm(2)%n_Aerosols > 0 ) THEN + + atm(2)%Aerosol(1)%Type = SEASALT_SSAM_AEROSOL + atm(2)%Aerosol(1)%Effective_Radius = & ! microns + (/0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, & + 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, & + 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, & + 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, & + 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, & + 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, 3.500000E-01_fp, & + 3.500000E-01_fp, 4.172383E-01_fp, 5.083015E-01_fp, 6.111266E-01_fp, 7.244139E-01_fp, & + 8.457720E-01_fp, 9.716019E-01_fp, 1.097090E+00_fp, 1.216347E+00_fp, 1.322729E+00_fp, & + 1.400000E+00_fp, 1.400000E+00_fp, 1.400000E+00_fp, 1.400000E+00_fp, 1.400000E+00_fp, & + 1.370222E+00_fp, 1.261597E+00_fp, 1.129123E+00_fp, 9.811745E-01_fp, 8.268477E-01_fp/) + atm(2)%Aerosol(1)%Concentration = & ! kg/m^2 + (/0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 3.112058E-19_fp, 1.184702E-18_fp, 4.577011E-18_fp, 1.789488E-17_fp, 7.059239E-17_fp, & + 2.801093E-16_fp, 1.114424E-15_fp, 4.430982E-15_fp, 1.754743E-14_fp, 6.897637E-14_fp, & + 2.681926E-13_fp, 1.027837E-12_fp, 3.868968E-12_fp, 1.425352E-11_fp, 5.121245E-11_fp, & + 1.788308E-10_fp, 6.048330E-10_fp, 1.974708E-09_fp, 6.203527E-09_fp, 1.869357E-08_fp, & + 5.387408E-08_fp, 1.480799E-07_fp, 3.871910E-07_fp, 9.608434E-07_fp, 2.258279E-06_fp, & + 5.017946E-06_fp, 1.052599E-05_fp, 2.082121E-05_fp, 3.880948E-05_fp, 6.814300E-05_fp, & + 1.127227E-04_fp, 1.757803E-04_fp, 2.586908E-04_fp, 3.598829E-04_fp, 4.743266E-04_fp, & + 5.939634E-04_fp, 7.091114E-04_fp, 8.104756E-04_fp, 8.911259E-04_fp, 9.478373E-04_fp, & + 9.814733E-04_fp, 9.964914E-04_fp, 9.999501E-04_fp, 9.994838E-04_fp, 9.921395E-04_fp, & + 9.678320E-04_fp, 9.171414E-04_fp, 8.337592E-04_fp, 7.173667E-04_fp, 5.757384E-04_fp/) + + IF ( atm(2)%n_Aerosols > 1 ) THEN + atm(2)%Aerosol(2)%Type = SEASALT_SSCM1_AEROSOL + atm(2)%Aerosol(2)%Effective_Radius = & ! microns + (/0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 1.200000E+00_fp, 1.200000E+00_fp, 1.200000E+00_fp, 1.200000E+00_fp, & + 1.200000E+00_fp, 1.200000E+00_fp, 1.200000E+00_fp, 1.200000E+00_fp, 1.200000E+00_fp, & + 2.035608E+00_fp, 3.433539E+00_fp, 4.500000E+00_fp, 4.500000E+00_fp, 4.500000E+00_fp, & + 4.500000E+00_fp, 4.500000E+00_fp, 4.500000E+00_fp, 4.500000E+00_fp, 4.500000E+00_fp/) + atm(2)%Aerosol(2)%Concentration = & ! kg/m^2 + (/0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 1.718665E-20_fp, 6.364432E-18_fp, 1.294130E-15_fp, 1.453633E-13_fp, & + 9.116027E-12_fp, 3.241673E-10_fp, 6.673036E-09_fp, 8.162075E-08_fp, 6.123529E-07_fp, & + 2.926244E-06_fp, 9.306878E-06_fp, 2.071874E-05_fp, 3.418072E-05_fp, 4.455191E-05_fp, & + 4.926597E-05_fp, 5.000000E-05_fp, 4.924296E-05_fp, 4.412128E-05_fp, 3.247284E-05_fp/) + END IF + + IF ( atm(2)%n_Aerosols > 2 ) THEN + atm(2)%Aerosol(3)%Type = SEASALT_SSCM2_AEROSOL + atm(2)%Aerosol(3)%Effective_Radius = & ! microns + (/0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, & + 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp, 3.500000E+00_fp/) + atm(2)%Aerosol(3)%Concentration = & ! kg/m^2 + (/0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, 0.000000E+00_fp, & + 0.000000E+00_fp, 0.000000E+00_fp, 7.258759E-21_fp, 1.408580E-19_fp, 2.671985E-18_fp, & + 4.861044E-17_fp, 8.316902E-16_fp, 1.311926E-14_fp, 1.870485E-13_fp, 2.363806E-12_fp, & + 2.598250E-11_fp, 2.440107E-10_fp, 1.926085E-09_fp, 1.259490E-08_fp, 6.741174E-08_fp, & + 2.926595E-07_fp, 1.024936E-06_fp, 2.891988E-06_fp, 6.598725E-06_fp, 1.228990E-05_fp, & + 1.898153E-05_fp, 2.488012E-05_fp, 2.855754E-05_fp, 2.988952E-05_fp, 2.999200E-05_fp, & + 2.927621E-05_fp, 2.600524E-05_fp, 1.925823E-05_fp, 1.073490E-05_fp, 4.002469E-06_fp, & + 8.719108E-07_fp, 9.516156E-08_fp, 4.374152E-09_fp, 6.968124E-11_fp, 3.094494E-13_fp, & + 3.007755E-16_fp, 1.306643E-19_fp, 8.973748E-18_fp, 6.907477E-16_fp, 3.699227E-14_fp, & + 1.371784E-12_fp, 3.515726E-11_fp, 6.234566E-10_fp, 7.684359E-09_fp, 6.636126E-08_fp, & + 4.063274E-07_fp, 1.792269E-06_fp, 5.811355E-06_fp, 1.419909E-05_fp, 2.692800E-05_fp, & + 4.103532E-05_fp, 5.229739E-05_fp, 5.833714E-05_fp, 5.995863E-05_fp, 5.986513E-05_fp, & + 5.739352E-05_fp, 4.931915E-05_fp, 3.517150E-05_fp, 1.913860E-05_fp, 7.253731E-06_fp, & + 1.735030E-06_fp, 2.355013E-07_fp, 1.618327E-08_fp, 4.982977E-10_fp, 6.034809E-12_fp/) + END IF + END IF Load_Aerosol_Data_2 + + END SUBROUTINE Load_Atm_Data diff --git a/test/mains/regression/forward/test_OMPoverChannels/Load_Sfc_Data.inc b/test/mains/regression/forward/test_OMPoverChannels/Load_Sfc_Data.inc new file mode 100644 index 0000000..3b2aec4 --- /dev/null +++ b/test/mains/regression/forward/test_OMPoverChannels/Load_Sfc_Data.inc @@ -0,0 +1,55 @@ + ! + ! Include file containing an internal subprogam to load some test surface data + ! + SUBROUTINE Load_Sfc_Data() + + + ! 4a.0 Surface type definitions for default SfcOptics definitions + ! For IR and VIS, this is the NPOESS reflectivities. + ! --------------------------------------------------------------- + INTEGER, PARAMETER :: TUNDRA_SURFACE_TYPE = 10 ! NPOESS Land surface type for IR/VIS Land SfcOptics + INTEGER, PARAMETER :: SCRUB_SURFACE_TYPE = 7 ! NPOESS Land surface type for IR/VIS Land SfcOptics + INTEGER, PARAMETER :: COARSE_SOIL_TYPE = 1 ! Soil type for MW land SfcOptics + INTEGER, PARAMETER :: GROUNDCOVER_VEGETATION_TYPE = 7 ! Vegetation type for MW Land SfcOptics + INTEGER, PARAMETER :: BARE_SOIL_VEGETATION_TYPE = 11 ! Vegetation type for MW Land SfcOptics + INTEGER, PARAMETER :: SEA_WATER_TYPE = 1 ! Water type for all SfcOptics + INTEGER, PARAMETER :: FRESH_SNOW_TYPE = 2 ! NPOESS Snow type for IR/VIS SfcOptics + INTEGER, PARAMETER :: FRESH_ICE_TYPE = 1 ! NPOESS Ice type for IR/VIS SfcOptics + + + + ! 4a.1 Profile #1 + ! --------------- + ! ...Land surface characteristics + sfc(1)%Land_Coverage = 0.1_fp + sfc(1)%Land_Type = TUNDRA_SURFACE_TYPE + sfc(1)%Land_Temperature = 272.0_fp + sfc(1)%Lai = 0.17_fp + sfc(1)%Soil_Type = COARSE_SOIL_TYPE + sfc(1)%Vegetation_Type = GROUNDCOVER_VEGETATION_TYPE + ! ...Water surface characteristics + sfc(1)%Water_Coverage = 0.5_fp + sfc(1)%Water_Type = SEA_WATER_TYPE + sfc(1)%Water_Temperature = 275.0_fp + ! ...Snow coverage characteristics + sfc(1)%Snow_Coverage = 0.25_fp + sfc(1)%Snow_Type = FRESH_SNOW_TYPE + sfc(1)%Snow_Temperature = 265.0_fp + ! ...Ice surface characteristics + sfc(1)%Ice_Coverage = 0.15_fp + sfc(1)%Ice_Type = FRESH_ICE_TYPE + sfc(1)%Ice_Temperature = 269.0_fp + + + + ! 4a.2 Profile #2 + ! --------------- + ! Surface data + sfc(2)%Land_Coverage = 1.0_fp + sfc(2)%Land_Type = SCRUB_SURFACE_TYPE + sfc(2)%Land_Temperature = 318.0_fp + sfc(2)%Lai = 0.65_fp + sfc(2)%Soil_Type = COARSE_SOIL_TYPE + sfc(2)%Vegetation_Type = BARE_SOIL_VEGETATION_TYPE + + END SUBROUTINE Load_Sfc_Data diff --git a/test/mains/regression/forward/test_OMPoverChannels/Makefile.in b/test/mains/regression/forward/test_OMPoverChannels/Makefile.in new file mode 100644 index 0000000..9cbb321 --- /dev/null +++ b/test/mains/regression/forward/test_OMPoverChannels/Makefile.in @@ -0,0 +1,65 @@ +# @configure_input@ + +# individual test makefile template + +# The file definitions. This include must occur before targets. +EXE_FILE=$(shell echo ${PWD} | sed 's,.*/,,') +SRC_FILE=$(EXE_FILE).f90 +OBJ_FILE=${SRC_FILE:.f90=.o} + +# The test type (e.g. forward, k_matrix, etc) +TEST_TYPE=`dirname ${PWD} | sed 's,.*/,,'` + +# Tool-specific substitution variables +FC = @FC@ +FCFLAGS = @FCFLAGS@ -I../../incsrc +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ + +# The targets +all: $(EXE_FILE) + +$(OBJ_FILE): $(SRC_FILE) + +$(EXE_FILE): $(OBJ_FILE) + @echo; echo; \ + echo "=============================================="; \ + echo "Building $(TEST_TYPE) $(EXE_FILE) using:"; \ + echo " FC : $(FC)"; \ + echo " FCFLAGS : $(FCFLAGS)"; \ + echo " LDFLAGS : $(LDFLAGS)"; \ + echo "==============================================" + $(FC) $(LDFLAGS) $(OBJ_FILE) -o $(EXE_FILE) $(LIBS) + +clean: + @echo; echo; \ + echo "=============================================="; \ + echo "Cleaning up $(TEST_TYPE) $(EXE_FILE)"; \ + echo "==============================================" + rm -fr $(OBJ_FILE) $(EXE_FILE) gmon.out *.output *.bin results/*.signal + +update: + @update() \ + { files=`find . -maxdepth 1 -name "$$1" -print`; \ + if [ -n "$$files" ]; then \ + mv $$files results; \ + else \ + echo "No $$1 files to update."; \ + fi \ + }; \ + echo; echo; \ + echo "=============================================="; \ + echo "Updating results for $(TEST_TYPE) $(EXE_FILE)"; \ + echo "=============================================="; \ + update "*.output"; update "*.bin" + +realclean: clean + -rm Makefile + +# Specify targets that do not generate filesystem objects +.PHONY: all clean update realclean + +# Specify suffix rules +.SUFFIXES: .f90 .o +.f90.o: + @$(FC) $(FCFLAGS) -c $< diff --git a/test/mains/regression/forward/test_OMPoverChannels/Map_To_NCEP_Model_Coordinates.inc b/test/mains/regression/forward/test_OMPoverChannels/Map_To_NCEP_Model_Coordinates.inc new file mode 100644 index 0000000..0d7a86a --- /dev/null +++ b/test/mains/regression/forward/test_OMPoverChannels/Map_To_NCEP_Model_Coordinates.inc @@ -0,0 +1,161 @@ + ! + ! Include file containing an internal subprogram to map + ! atmospheres to representative NCEP model coordinates + ! + SUBROUTINE Map_To_NCEP_Model_Coordinates() + ! Local parameter + REAL(fp), PARAMETER :: PRESSURE_DIFFERENCE_FILL_VALUE = 1500.0_fp + ! Local variables + INTEGER :: n_Profiles + INTEGER :: Best_Match_Index + REAL(fp) :: Pressure_Difference + ! Layer counters + INTEGER :: k, kr, kg + ! Profile counter + INTEGER :: m + + n_Profiles = SIZE(Atm) + + ! Assign profile 1 vertical coordinates + Atm_NAM(1)%Pressure = & + (/7.557_fp, 18.680_fp, 29.832_fp, 41.024_fp, 52.266_fp, 63.614_fp, & + 75.140_fp, 86.867_fp, 98.898_fp, 111.283_fp, 124.021_fp, 137.265_fp, & + 151.065_fp, 165.624_fp, 181.345_fp, 198.683_fp, 217.994_fp, 239.376_fp, & + 263.135_fp, 289.310_fp, 317.552_fp, 347.341_fp, 378.054_fp, 409.310_fp, & + 441.043_fp, 473.178_fp, 505.540_fp, 537.933_fp, 570.153_fp, 602.116_fp, & + 633.675_fp, 664.585_fp, 694.747_fp, 723.816_fp, 751.247_fp, 776.696_fp, & + 799.965_fp, 821.053_fp, 839.864_fp, 856.496_fp, 871.196_fp, 884.014_fp, & + 895.245_fp, 904.942_fp, 913.304_fp, 920.824_fp, 927.750_fp, 934.330_fp, & + 940.613_fp, 946.599_fp, 952.337_fp, 957.878_fp, 963.221_fp, 968.415_fp, & + 973.510_fp, 978.506_fp, 983.403_fp, 988.202_fp, 992.940_fp, 997.651_fp/) + Atm_NAM(1)%Level_Pressure = & + (/2.000_fp, 13.114_fp, 24.246_fp, 35.417_fp, 46.629_fp, 57.902_fp, & + 69.326_fp, 80.953_fp, 92.781_fp, 105.014_fp, 117.551_fp, 130.492_fp, & + 144.039_fp, 158.092_fp, 173.156_fp, 189.534_fp, 207.833_fp, 228.154_fp, & + 250.598_fp, 275.671_fp, 302.949_fp, 332.154_fp, 362.528_fp, 393.579_fp, & + 425.042_fp, 457.045_fp, 489.310_fp, 521.770_fp, 554.095_fp, 586.211_fp, & + 618.021_fp, 649.329_fp, 679.840_fp, 709.653_fp, 737.978_fp, 764.517_fp, & + 788.875_fp, 811.054_fp, 831.053_fp, 848.675_fp, 864.316_fp, 878.076_fp, & + 889.952_fp, 900.539_fp, 909.346_fp, 917.262_fp, 924.386_fp, 931.114_fp, & + 937.546_fp, 943.680_fp, 949.518_fp, 955.157_fp, 960.598_fp, 965.843_fp, & + 970.987_fp, 976.032_fp, 980.980_fp, 985.827_fp, 990.577_fp, 995.302_fp, & + 1000.000_fp/) + Atm_GFS(1)%Pressure = & + (/0.321_fp, 1.010_fp, 1.798_fp, 2.701_fp, 3.733_fp, 4.914_fp, & + 6.264_fp, 7.807_fp, 9.570_fp, 11.584_fp, 13.882_fp, 16.503_fp, & + 19.492_fp, 22.895_fp, 26.769_fp, 31.172_fp, 36.172_fp, 41.842_fp, & + 48.263_fp, 55.520_fp, 63.709_fp, 72.928_fp, 83.282_fp, 94.879_fp, & + 107.828_fp, 122.239_fp, 138.215_fp, 155.853_fp, 175.235_fp, 196.427_fp, & + 219.467_fp, 244.369_fp, 271.106_fp, 299.614_fp, 329.784_fp, 361.464_fp, & + 394.453_fp, 428.513_fp, 463.366_fp, 498.709_fp, 534.218_fp, 569.567_fp, & + 604.432_fp, 638.510_fp, 671.523_fp, 703.229_fp, 733.431_fp, 761.972_fp, & + 788.744_fp, 813.681_fp, 836.757_fp, 857.984_fp, 877.401_fp, 895.071_fp, & + 911.079_fp, 925.518_fp, 938.495_fp, 950.117_fp, 960.493_fp, 969.733_fp, & + 977.941_fp, 985.216_fp, 991.651_fp, 997.335_fp/) + Atm_GFS(1)%Level_Pressure = & + (/0.001_fp, 0.642_fp, 1.377_fp, 2.219_fp, 3.182_fp, 4.284_fp, & + 5.544_fp, 6.984_fp, 8.630_fp, 10.510_fp, 12.657_fp, 15.107_fp, & + 17.900_fp, 21.083_fp, 24.707_fp, 28.830_fp, 33.514_fp, 38.830_fp, & + 44.854_fp, 51.671_fp, 59.370_fp, 68.048_fp, 77.808_fp, 88.756_fp, & + 101.002_fp, 114.655_fp, 129.823_fp, 146.607_fp, 165.099_fp, 185.372_fp, & + 207.481_fp, 231.454_fp, 257.284_fp, 284.928_fp, 314.300_fp, 345.269_fp, & + 377.659_fp, 411.248_fp, 445.778_fp, 480.955_fp, 516.463_fp, 551.974_fp, & + 587.160_fp, 621.705_fp, 655.315_fp, 687.730_fp, 718.729_fp, 748.133_fp, & + 775.811_fp, 801.676_fp, 825.685_fp, 847.830_fp, 868.138_fp, 886.663_fp, & + 903.479_fp, 918.678_fp, 932.359_fp, 944.631_fp, 955.603_fp, 965.384_fp, & + 974.082_fp, 981.799_fp, 988.632_fp, 994.671_fp, 1000.000_fp/) + + ! Assign profile 2 vertical coordinates + Atm_NAM(2)%Pressure = & + (/7.557_fp, 18.680_fp, 29.832_fp, 41.024_fp, 52.266_fp, 63.614_fp, & + 75.140_fp, 86.867_fp, 98.898_fp, 111.283_fp, 124.021_fp, 137.265_fp, & + 151.065_fp, 165.624_fp, 181.345_fp, 198.683_fp, 217.994_fp, 239.376_fp, & + 263.135_fp, 289.310_fp, 317.552_fp, 347.341_fp, 378.054_fp, 409.310_fp, & + 441.043_fp, 473.178_fp, 505.540_fp, 537.933_fp, 570.153_fp, 602.116_fp, & + 633.675_fp, 664.585_fp, 694.747_fp, 723.816_fp, 751.247_fp, 776.696_fp, & + 799.965_fp, 821.053_fp, 839.864_fp, 856.496_fp, 871.196_fp, 884.014_fp, & + 895.245_fp, 904.942_fp, 913.304_fp, 920.824_fp, 927.750_fp, 934.330_fp, & + 940.613_fp, 946.599_fp, 952.337_fp, 957.878_fp, 963.221_fp, 968.415_fp, & + 973.510_fp, 978.506_fp, 983.403_fp, 988.202_fp, 992.940_fp, 997.651_fp/) + Atm_NAM(2)%Level_Pressure = & + (/2.000_fp, 13.114_fp, 24.246_fp, 35.417_fp, 46.629_fp, 57.902_fp, & + 69.326_fp, 80.953_fp, 92.781_fp, 105.014_fp, 117.551_fp, 130.492_fp, & + 144.039_fp, 158.092_fp, 173.156_fp, 189.534_fp, 207.833_fp, 228.154_fp, & + 250.598_fp, 275.671_fp, 302.949_fp, 332.154_fp, 362.528_fp, 393.579_fp, & + 425.042_fp, 457.045_fp, 489.310_fp, 521.770_fp, 554.095_fp, 586.211_fp, & + 618.021_fp, 649.329_fp, 679.840_fp, 709.653_fp, 737.978_fp, 764.517_fp, & + 788.875_fp, 811.054_fp, 831.053_fp, 848.675_fp, 864.316_fp, 878.076_fp, & + 889.952_fp, 900.539_fp, 909.346_fp, 917.262_fp, 924.386_fp, 931.114_fp, & + 937.546_fp, 943.680_fp, 949.518_fp, 955.157_fp, 960.598_fp, 965.843_fp, & + 970.987_fp, 976.032_fp, 980.980_fp, 985.827_fp, 990.577_fp, 995.302_fp, & + 1000.000_fp/) + Atm_GFS(2)%Pressure = & + (/0.321_fp, 1.010_fp, 1.798_fp, 2.701_fp, 3.733_fp, 4.914_fp, & + 6.264_fp, 7.807_fp, 9.570_fp, 11.584_fp, 13.882_fp, 16.503_fp, & + 19.492_fp, 22.895_fp, 26.769_fp, 31.172_fp, 36.172_fp, 41.842_fp, & + 48.263_fp, 55.520_fp, 63.709_fp, 72.928_fp, 83.282_fp, 94.879_fp, & + 107.828_fp, 122.239_fp, 138.215_fp, 155.853_fp, 175.235_fp, 196.427_fp, & + 219.467_fp, 244.369_fp, 271.106_fp, 299.614_fp, 329.784_fp, 361.464_fp, & + 394.453_fp, 428.513_fp, 463.366_fp, 498.709_fp, 534.218_fp, 569.567_fp, & + 604.432_fp, 638.510_fp, 671.523_fp, 703.229_fp, 733.431_fp, 761.972_fp, & + 788.744_fp, 813.681_fp, 836.757_fp, 857.984_fp, 877.401_fp, 895.071_fp, & + 911.079_fp, 925.518_fp, 938.495_fp, 950.117_fp, 960.493_fp, 969.733_fp, & + 977.941_fp, 985.216_fp, 991.651_fp, 997.335_fp/) + Atm_GFS(2)%Level_Pressure = & + (/0.001_fp, 0.642_fp, 1.377_fp, 2.219_fp, 3.182_fp, 4.284_fp, & + 5.544_fp, 6.984_fp, 8.630_fp, 10.510_fp, 12.657_fp, 15.107_fp, & + 17.900_fp, 21.083_fp, 24.707_fp, 28.830_fp, 33.514_fp, 38.830_fp, & + 44.854_fp, 51.671_fp, 59.370_fp, 68.048_fp, 77.808_fp, 88.756_fp, & + 101.002_fp, 114.655_fp, 129.823_fp, 146.607_fp, 165.099_fp, 185.372_fp, & + 207.481_fp, 231.454_fp, 257.284_fp, 284.928_fp, 314.300_fp, 345.269_fp, & + 377.659_fp, 411.248_fp, 445.778_fp, 480.955_fp, 516.463_fp, 551.974_fp, & + 587.160_fp, 621.705_fp, 655.315_fp, 687.730_fp, 718.729_fp, 748.133_fp, & + 775.811_fp, 801.676_fp, 825.685_fp, 847.830_fp, 868.138_fp, 886.663_fp, & + 903.479_fp, 918.678_fp, 932.359_fp, 944.631_fp, 955.603_fp, 965.384_fp, & + 974.082_fp, 981.799_fp, 988.632_fp, 994.671_fp, 1000.000_fp/) + + !------------------------------ + ! Assign layer temperatures, + ! absorber amounts and metadata + !------------------------------ + DO m = 1, n_Profiles + ! Assign metadata + ! Regional + Atm_NAM(m)%Climatology = Atm(m)%Climatology + Atm_NAM(m)%Absorber_Id(:) = Atm(m)%Absorber_Id(:) + Atm_NAM(m)%Absorber_Units(:) = Atm(m)%Absorber_Units(:) + ! Global + Atm_GFS(m)%Climatology = Atm(m)%Climatology + Atm_GFS(m)%Absorber_Id(:) = Atm(m)%Absorber_Id(:) + Atm_GFS(m)%Absorber_Units(:) = Atm(m)%Absorber_Units(:) + ! Regional assignments of temperature and absorber amounts + DO kr = 1, Atm_NAM(m)%n_Layers + Pressure_Difference = PRESSURE_DIFFERENCE_FILL_VALUE + DO k = 1, Atm(m)%n_Layers + IF(ABS(Atm_NAM(m)%Pressure(kr)-Atm(m)%Pressure(k)) < & + Pressure_Difference) THEN + Pressure_Difference = ABS(Atm_NAM(m)%Pressure(kr)-Atm(m)%Pressure(k)) + Best_Match_Index = k + END IF + ENDDO + Atm_NAM(m)%Temperature(kr) = Atm(m)%Temperature(Best_Match_Index) + Atm_NAM(m)%Absorber(kr,1) = Atm(m)%Absorber(Best_Match_Index,1) + Atm_NAM(m)%Absorber(kr,2) = Atm(m)%Absorber(Best_Match_Index,2) + ENDDO + ! Global assignments of temperature and absorber amounts + DO kg = 1, Atm_GFS(m)%n_Layers + Pressure_Difference = PRESSURE_DIFFERENCE_FILL_VALUE + DO k = 1, Atm(m)%n_Layers + IF(ABS(Atm_GFS(m)%Pressure(kg)-Atm(m)%Pressure(k)) < & + Pressure_Difference) THEN + Pressure_Difference = ABS(Atm_GFS(m)%Pressure(kg)-Atm(m)%Pressure(k)) + Best_Match_Index = k + END IF + ENDDO + Atm_GFS(m)%Temperature(kg) = Atm(m)%Temperature(Best_Match_Index) + Atm_GFS(m)%Absorber(kg,1) = Atm(m)%Absorber(Best_Match_Index,1) + Atm_GFS(m)%Absorber(kg,2) = Atm(m)%Absorber(Best_Match_Index,2) + ENDDO + ENDDO + + END SUBROUTINE Map_To_NCEP_Model_Coordinates diff --git a/test/mains/regression/forward/test_OMPoverChannels/SignalFile_Create.inc b/test/mains/regression/forward/test_OMPoverChannels/SignalFile_Create.inc new file mode 100644 index 0000000..7fd142a --- /dev/null +++ b/test/mains/regression/forward/test_OMPoverChannels/SignalFile_Create.inc @@ -0,0 +1,9 @@ + SUBROUTINE SignalFile_Create() + CHARACTER(256) :: Filename + INTEGER :: fid + Filename = RESULTS_PATH//TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.signal' + fid = Get_Lun() + OPEN( fid, FILE = Filename ) + WRITE( fid,* ) TRIM(Filename) + CLOSE( fid ) + END SUBROUTINE SignalFile_Create diff --git a/test/mains/regression/forward/test_OMPoverChannels/coefficients/make.link_data b/test/mains/regression/forward/test_OMPoverChannels/coefficients/make.link_data new file mode 100644 index 0000000..b5673fa --- /dev/null +++ b/test/mains/regression/forward/test_OMPoverChannels/coefficients/make.link_data @@ -0,0 +1,28 @@ +#============================================================================== +# +# Makefile to create *local, working copy* coefficient data links +# for the current example scenario +# +#============================================================================== + +# Define macros via include file +include $(CRTM_SOURCE_ROOT)/make.macros + +# Define the endian type for ALL datafiles +ENDIAN_TYPE = Big_Endian + +# Define common coefficient file link targets via include file +include $(CRTM_SOURCE_ROOT)/make.common_coefficient_targets + +# Define sensor coefficient file link targets via include file +TAUCOEFF_TYPE = ODPS +SENSOR_IDS = amsua_metop-a mhs_n18 hirs4_n18 ssmis_f16 amsre_aqua +include $(CRTM_SOURCE_ROOT)/make.sensor_coefficient_targets + +# Main targets +# ...Subtargets used by main makefiles +create_coeff_links:: create_common_coeff_links create_sensor_coeff_links +remove_coeff_links:: remove_common_coeff_links remove_sensor_coeff_links +# ..."Global" targets +all:: create_coeff_links +clean:: remove_coeff_links diff --git a/test/mains/regression/forward/test_OMPoverChannels/sensor_id.list b/test/mains/regression/forward/test_OMPoverChannels/sensor_id.list new file mode 100644 index 0000000..644b66e --- /dev/null +++ b/test/mains/regression/forward/test_OMPoverChannels/sensor_id.list @@ -0,0 +1,3 @@ +amsr2_gcom-w1 +atms_npp +cris399_npp diff --git a/test/mains/regression/forward/test_OMPoverChannels/test_OMPoverChannels.F90 b/test/mains/regression/forward/test_OMPoverChannels/test_OMPoverChannels.F90 new file mode 100644 index 0000000..2f451de --- /dev/null +++ b/test/mains/regression/forward/test_OMPoverChannels/test_OMPoverChannels.F90 @@ -0,0 +1,328 @@ +! +! test_OMPoverChannels +! +! Test program for the CRTM Forward function including clouds and aerosols. +! +! + +PROGRAM test_OMPoverChannels + + ! ============================================================================ + ! **** ENVIRONMENT SETUP FOR RTM USAGE **** + ! + ! Module usage + USE CRTM_Module +#ifdef _OPENMP + USE OMP_LIB +#endif + ! Disable all implicit typing + IMPLICIT NONE + ! ============================================================================ + + + ! ---------- + ! Parameters + ! ---------- + CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'test_OMPoverChannels' + CHARACTER(*), PARAMETER :: COEFFICIENTS_PATH = './testinput/' + CHARACTER(*), PARAMETER :: RESULTS_PATH = './results/forward/' + + ! ============================================================================ + ! 0. **** SOME SET UP PARAMETERS FOR THIS TEST **** + ! + ! Profile dimensions... + INTEGER, PARAMETER :: N_PROFILES = 2 + INTEGER, PARAMETER :: N_LAYERS = 92 + INTEGER, PARAMETER :: N_ABSORBERS = 2 + INTEGER, PARAMETER :: N_CLOUDS = 1 + INTEGER, PARAMETER :: N_AEROSOLS = 1 + ! ...but only ONE Sensor at a time + INTEGER, PARAMETER :: N_SENSORS = 1 + + ! Test GeometryInfo angles. The test scan angle is based + ! on the default Re (earth radius) and h (satellite height) + REAL(fp), PARAMETER :: ZENITH_ANGLE = 30.0_fp + REAL(fp), PARAMETER :: SCAN_ANGLE = 26.37293341421_fp + ! ============================================================================ + + + ! --------- + ! Variables + ! --------- + CHARACTER(256) :: Message + CHARACTER(256) :: Version + CHARACTER(256) :: Sensor_Id + INTEGER :: Error_Status + INTEGER :: Allocate_Status + INTEGER :: n_Channels + INTEGER :: l, m + ! Declarations for RTSolution comparison + INTEGER :: n_l, n_m + CHARACTER(256) :: rts_File + TYPE(CRTM_RTSolution_type), ALLOCATABLE :: rts(:,:) + + + ! ============================================================================ + ! 1. **** DEFINE THE CRTM INTERFACE STRUCTURES **** + ! + TYPE(CRTM_ChannelInfo_type) :: ChannelInfo(N_SENSORS) + TYPE(CRTM_Geometry_type) :: Geometry(N_PROFILES) + TYPE(CRTM_Atmosphere_type) :: Atm(N_PROFILES) + TYPE(CRTM_Surface_type) :: Sfc(N_PROFILES) + TYPE(CRTM_RTSolution_type), ALLOCATABLE :: RTSolution(:,:) + ! ============================================================================ + + !First, make sure the right number of inputs have been provided + IF(COMMAND_ARGUMENT_COUNT().NE.1)THEN + WRITE(*,*)'test_OMPoverChannels.F90: ERROR, only one command-line argument required, returning' + STOP 1 + ENDIF + + CALL GET_COMMAND_ARGUMENT(1,Sensor_Id) !read in the value + + ! Program header + ! -------------- + CALL CRTM_Version( Version ) + CALL Program_Message( PROGRAM_NAME, & + 'Test program for the CRTM Forward function including clouds and aerosols.', & + 'CRTM Version: '//TRIM(Version) ) + + + ! Get sensor id from user + ! ----------------------- + Sensor_Id = ADJUSTL(Sensor_Id) + WRITE( *,'(//5x,"Running CRTM for ",a," sensor...")' ) TRIM(Sensor_Id) + + ! Set number of OpenMP threads, if present: + ! ----------------------------------------- +#ifdef _OPENMP + CALL OMP_SET_NUM_THREADS(8) +!$OMP PARALLEL +!$OMP SINGLE + WRITE(*,*) "Running the test for ", OMP_GET_NUM_THREADS(), " threads." +!$OMP END SINGLE +!$OMP END PARALLEL +#endif + + + + ! ============================================================================ + ! 2. **** INITIALIZE THE CRTM **** + ! + + ! 2a. Initialise the requested sensor + ! ----------------------------------- + WRITE( *,'(/5x,"Initializing the CRTM...")' ) + Error_Status = CRTM_Init( (/Sensor_Id/), & + ChannelInfo, & + File_Path=COEFFICIENTS_PATH) + IF ( Error_Status /= SUCCESS ) THEN + Message = 'Error initializing CRTM' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + STOP 1 + END IF + + ! 2b. Specify an instrument channel subset for processing + ! ------------------------------------------------------- + Error_Status = CRTM_ChannelInfo_Subset( ChannelInfo(1), & + Channel_Subset = (/3,4,5,6,7,8,10/) ) + IF ( Error_Status /= SUCCESS ) THEN + Message = 'Selecting channel subset unsuccessful!' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + STOP 1 + END IF + + ! 2c. Determine the total number of channels + ! for which the CRTM was initialized + ! ------------------------------------------ + n_Channels = SUM(CRTM_ChannelInfo_n_Channels(ChannelInfo)) + ! ============================================================================ + + + + + ! ============================================================================ + ! 3. **** ALLOCATE STRUCTURE ARRAYS **** + ! + ! 3a. Allocate the ARRAYS + ! ----------------------- + ALLOCATE( RTSolution( n_Channels, N_PROFILES ), STAT=Allocate_Status ) + IF ( Allocate_Status /= 0 ) THEN + Message = 'Error allocating structure arrays' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + STOP 1 + END IF + + ! 3b. Allocate the STRUCTURES + ! --------------------------- + CALL CRTM_Atmosphere_Create( Atm, N_LAYERS, N_ABSORBERS, N_CLOUDS, N_AEROSOLS ) + IF ( ANY(.NOT. CRTM_Atmosphere_Associated(Atm)) ) THEN + Message = 'Error allocating CRTM Atmosphere structures' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + STOP 1 + END IF + ! ============================================================================ + + + + + ! ============================================================================ + ! 4. **** ASSIGN INPUT DATA **** + ! + ! 4a. Atmosphere and Surface input + ! -------------------------------- + CALL Load_Atm_Data() + CALL Load_Sfc_Data() + + + ! 4b. GeometryInfo input + ! ---------------------- + ! All profiles are given the same value + ! The Sensor_Scan_Angle is optional. + CALL CRTM_Geometry_SetValue( Geometry, & + Sensor_Zenith_Angle = ZENITH_ANGLE, & + Sensor_Scan_Angle = SCAN_ANGLE ) + ! ============================================================================ + + + + + ! ============================================================================ + ! 5. **** CALL THE CRTM FORWARD MODEL **** + ! + Error_Status = CRTM_Forward( Atm , & + Sfc , & + Geometry , & + ChannelInfo, & + RTSolution ) + IF ( Error_Status /= SUCCESS ) THEN + Message = 'Error in CRTM Forward Model' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + STOP 1 + END IF + ! ============================================================================ + + + + + ! ============================================================================ + ! 6. **** OUTPUT THE RESULTS TO SCREEN **** + ! + DO m = 1, N_PROFILES + WRITE( *,'(//7x,"Profile ",i0," output for ",a )') m, TRIM(Sensor_Id) + DO l = 1, n_Channels + WRITE( *, '(/5x,"Channel ",i0," results")') RTSolution(l,m)%Sensor_Channel + CALL CRTM_RTSolution_Inspect(RTSolution(l,m)) + END DO + END DO + ! ============================================================================ + + ! ============================================================================ + ! 8. **** COMPARE RTSolution RESULTS TO SAVED VALUES **** + ! + WRITE( *, '( /5x, "Comparing calculated results with saved ones..." )' ) + + ! 8a. Create the output file if it does not exist + ! ----------------------------------------------- + ! ...Generate a filename + rts_File = RESULTS_PATH//TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.RTSolution.bin' + ! ...Check if the file exists + IF ( .NOT. File_Exists(rts_File) ) THEN + Message = 'RTSolution save file does not exist. Creating...' + CALL Display_Message( PROGRAM_NAME, Message, INFORMATION ) + ! ...File not found, so write RTSolution structure to file + Error_Status = CRTM_RTSolution_WriteFile( rts_File, RTSolution, Quiet=.TRUE. ) + IF ( Error_Status /= SUCCESS ) THEN + Message = 'Error creating RTSolution save file' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + STOP 1 + END IF + END IF + + ! 8b. Inquire the saved file + ! -------------------------- + Error_Status = CRTM_RTSolution_InquireFile( rts_File, & + n_Channels = n_l, & + n_Profiles = n_m ) + IF ( Error_Status /= SUCCESS ) THEN + Message = 'Error inquiring RTSolution save file' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + STOP 1 + END IF + + ! 8c. Compare the dimensions + ! -------------------------- + IF ( n_l /= n_Channels .OR. n_m /= 2 ) THEN + Message = 'Dimensions of saved data different from that calculated!' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + STOP 1 + END IF + + ! 8d. Allocate the structure to read in saved data + ! ------------------------------------------------ + ALLOCATE( rts( n_l, n_m ), STAT=Allocate_Status ) + IF ( Allocate_Status /= 0 ) THEN + Message = 'Error allocating RTSolution saved data array' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + STOP 1 + END IF + + ! 8e. Read the saved data + ! ----------------------- + Error_Status = CRTM_RTSolution_ReadFile( rts_File, rts, Quiet=.TRUE. ) + IF ( Error_Status /= SUCCESS ) THEN + Message = 'Error reading RTSolution save file' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + STOP 1 + END IF + + ! 8f. Compare the structures + ! -------------------------- + IF ( ALL(CRTM_RTSolution_Compare(RTSolution, rts)) ) THEN + Message = 'RTSolution results are the same!' + CALL Display_Message( PROGRAM_NAME, Message, INFORMATION ) + ELSE + Message = 'RTSolution results are different!' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + ! Write the current RTSolution results to file + rts_File = TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.RTSolution.bin' + Error_Status = CRTM_RTSolution_WriteFile( rts_File, RTSolution, Quiet=.TRUE. ) + IF ( Error_Status /= SUCCESS ) THEN + Message = 'Error creating temporary RTSolution save file for failed comparison' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + END IF + STOP 1 + END IF + ! ============================================================================ + + ! ============================================================================ + ! 7. **** DESTROY THE CRTM **** + ! + WRITE( *, '( /5x, "Destroying the CRTM..." )' ) + Error_Status = CRTM_Destroy( ChannelInfo ) + IF ( Error_Status /= SUCCESS ) THEN + Message = 'Error destroying CRTM' + CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + STOP 1 + END IF + ! ============================================================================ + + ! ============================================================================ + ! 9. **** CLEAN UP **** + ! + ! 9a. Deallocate the structures + ! ----------------------------- + CALL CRTM_Atmosphere_Destroy(Atm) + + ! 9b. Deallocate the arrays + ! ------------------------- + DEALLOCATE(RTSolution, rts, STAT=Allocate_Status) + ! ============================================================================ + + +CONTAINS + + INCLUDE 'Load_Atm_Data.inc' + INCLUDE 'Load_Sfc_Data.inc' + +END PROGRAM test_OMPoverChannels diff --git a/test/mains/regression/k_matrix/test_AOD/tx.sh b/test/mains/regression/k_matrix/test_AOD/tx.sh new file mode 100644 index 0000000..36a0158 --- /dev/null +++ b/test/mains/regression/k_matrix/test_AOD/tx.sh @@ -0,0 +1,2 @@ +find ./ -name "*.f90" -exec sed -i "s/ WRITE( *,'\(/5x,\"Enter sensor id: \"\)',ADVANCE='NO' \)//'" {} \; +echo READ( *,'(a)' ) Sensor_Id diff --git a/test/mains/regression/k_matrix/test_Simple/test_Simple.f90 b/test/mains/regression/k_matrix/test_Simple/test_Simple.f90 index 1f2d277..e79beb1 100644 --- a/test/mains/regression/k_matrix/test_Simple/test_Simple.f90 +++ b/test/mains/regression/k_matrix/test_Simple/test_Simple.f90 @@ -58,8 +58,8 @@ PROGRAM test_Simple INTEGER :: n_la, n_ma INTEGER :: n_ls, n_ms CHARACTER(256) :: atmk_File, sfck_File - TYPE(CRTM_Atmosphere_type), ALLOCATABLE :: atm_k(:,:) - TYPE(CRTM_Surface_type) , ALLOCATABLE :: sfc_k(:,:) + TYPE(CRTM_Atmosphere_type), ALLOCATABLE :: atm_K(:,:) + TYPE(CRTM_Surface_type) , ALLOCATABLE :: sfc_K(:,:) @@ -133,6 +133,7 @@ PROGRAM test_Simple ! 3a. Allocate the ARRAYS ! ----------------------- ALLOCATE( RTSolution( n_Channels, N_PROFILES ), & + atm_K( n_Channels, N_PROFILES ), & Atmosphere_K( n_Channels, N_PROFILES ), & Surface_K( n_Channels, N_PROFILES ), & RTSolution_K( n_Channels, N_PROFILES ), & @@ -159,15 +160,15 @@ PROGRAM test_Simple Message = 'Error allocating CRTM Atmosphere_K structure' CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) STOP 1 - END IF - + END IF + ! Deleted in V2.4.1 ! The comparative K-MATRIX structure inside the results file - CALL CRTM_Atmosphere_Create( atm_K, N_LAYERS, N_ABSORBERS, N_CLOUDS, N_AEROSOLS ) - IF ( ANY(.NOT. CRTM_Atmosphere_Associated(atm_K)) ) THEN - Message = 'Error allocating CRTM atm_K structure' - CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) - STOP 1 - END IF + !CALL CRTM_Atmosphere_Create( atm_K, N_LAYERS, N_ABSORBERS, N_CLOUDS, N_AEROSOLS ) + !IF ( ANY(.NOT. CRTM_Atmosphere_Associated(atm_K)) ) THEN + ! Message = 'Error allocating CRTM atm_K structure' + ! CALL Display_Message( PROGRAM_NAME, Message, FAILURE ) + ! STOP 1 + !END IF ! ============================================================================ @@ -201,7 +202,7 @@ PROGRAM test_Simple ! 5a. Zero the K-matrix OUTPUT structures ! --------------------------------------- CALL CRTM_Atmosphere_Zero( Atmosphere_K ) - CALL CRTM_Atmosphere_Zero( atm_K ) + !CALL CRTM_Atmosphere_Zero( atm_K ) ! deleted in V2.4.1 CALL CRTM_Surface_Zero( Surface_K ) ! 5b. Inintialize the K-matrix INPUT so diff --git a/test/mains/unit/input_output/test_AerosolCoeff/test_aerosol_coeff_io.f90 b/test/mains/unit/input_output/test_AerosolCoeff/test_aerosol_coeff_io.f90 index 710c332..b782662 100644 --- a/test/mains/unit/input_output/test_AerosolCoeff/test_aerosol_coeff_io.f90 +++ b/test/mains/unit/input_output/test_AerosolCoeff/test_aerosol_coeff_io.f90 @@ -42,8 +42,8 @@ PROGRAM test_aerosol_coeff_io CHARACTER(*), PARAMETER :: Aerosol_Model = 'CRTM' CHARACTER(*), PARAMETER :: AerosolCoeff_File = 'AerosolCoeff.bin' CHARACTER(*), PARAMETER :: File_Path = './testinput/' - LOGICAL, PARAMETER :: Quiet = .TRUE. LOGICAL, PARAMETER :: netCDF = .FALSE. + LOGICAL, PARAMETER :: Quiet = .TRUE. INTEGER :: err_stat TYPE(UnitTest_type) :: ioTest LOGICAL :: testPassed diff --git a/test/mains/unit/input_output/test_AerosolCoeff_NC/test_aerosol_coeff_io_nc.f90 b/test/mains/unit/input_output/test_AerosolCoeff_NC/test_aerosol_coeff_io_nc.f90 index 97250df..5674c01 100644 --- a/test/mains/unit/input_output/test_AerosolCoeff_NC/test_aerosol_coeff_io_nc.f90 +++ b/test/mains/unit/input_output/test_AerosolCoeff_NC/test_aerosol_coeff_io_nc.f90 @@ -42,8 +42,8 @@ PROGRAM test_aerosol_coeff_io_nc CHARACTER(*), PARAMETER :: Aerosol_Model = 'CRTM' CHARACTER(*), PARAMETER :: AerosolCoeff_File = 'AerosolCoeff.nc4' CHARACTER(*), PARAMETER :: File_Path = './testinput/' - LOGICAL, PARAMETER :: Quiet = .TRUE. LOGICAL, PARAMETER :: netCDF = .TRUE. + LOGICAL, PARAMETER :: Quiet = .TRUE. INTEGER :: err_stat TYPE(UnitTest_type) :: ioTest LOGICAL :: testPassed diff --git a/test/mains/unit/input_output/test_EmisCoeff/test_emis_coeff_io.f90 b/test/mains/unit/input_output/test_EmisCoeff/test_emis_coeff_io.f90 new file mode 100644 index 0000000..da60c22 --- /dev/null +++ b/test/mains/unit/input_output/test_EmisCoeff/test_emis_coeff_io.f90 @@ -0,0 +1,225 @@ +!------------------------------------------------------- +! +! Description: +! Simple test program to inspect the CRTM Coeff files. +! +! Date: 2018-08-14 Author: P. Stegmann + +! MODIFICATION HISTORY: +! ===================== +! +! Author: Date: Description: +! ======= ===== ============ +! Patrick Stegmann 2021-02-05 Refactored as a CRTM +! unit test. +! Cheng Dang 2021-07-28 Modified for Aerosol +! Coeff look-up table +! Cheng Dang 2022-03-14 Modified for EmisCoeff +! look-up table (VIS,IR) +!------------------------------------------------------- + +PROGRAM test_emis_coeff_io + + ! ==================================================== + ! **** ENVIRONMENT SETUP FOR RTM USAGE **** + ! + + ! Module usage + USE UnitTest_Define, ONLY: UnitTest_type, & + UnitTest_Init, & + UnitTest_Setup, & + UnitTest_Assert, & + UnitTest_Passed + ! ...Infrared surface emissivities + USE CRTM_IRwaterCoeff , ONLY: CRTM_IRwaterCoeff_Load + USE CRTM_IRlandCoeff , ONLY: CRTM_IRlandCoeff_Load + USE CRTM_IRsnowCoeff , ONLY: CRTM_IRsnowCoeff_Load + USE CRTM_IRiceCoeff , ONLY: CRTM_IRiceCoeff_Load + ! ...Visible surface emissivities + USE CRTM_VISwaterCoeff , ONLY: CRTM_VISwaterCoeff_Load + USE CRTM_VISlandCoeff , ONLY: CRTM_VISlandCoeff_Load + USE CRTM_VISsnowCoeff , ONLY: CRTM_VISsnowCoeff_Load + USE CRTM_VISiceCoeff , ONLY: CRTM_VISiceCoeff_Load + USE Message_Handler , ONLY: SUCCESS, Display_Message + + ! Disable all implicit typing + IMPLICIT NONE + + ! Data dictionary: + CHARACTER(2000) :: info + CHARACTER(*), PARAMETER :: Default_IRwaterCoeff_File = 'Nalli.IRwater.EmisCoeff.bin' + CHARACTER(*), PARAMETER :: Default_IRlandCoeff_File = 'NPOESS.IRland.EmisCoeff.bin' + CHARACTER(*), PARAMETER :: Default_IRsnowCoeff_File = 'NPOESS.IRsnow.EmisCoeff.bin' + CHARACTER(*), PARAMETER :: Default_IRiceCoeff_File = 'NPOESS.IRice.EmisCoeff.bin' + CHARACTER(*), PARAMETER :: Default_VISwaterCoeff_File = 'NPOESS.VISwater.EmisCoeff.bin' + CHARACTER(*), PARAMETER :: Default_VISlandCoeff_File = 'NPOESS.VISland.EmisCoeff.bin' + CHARACTER(*), PARAMETER :: Default_VISsnowCoeff_File = 'NPOESS.VISsnow.EmisCoeff.bin' + CHARACTER(*), PARAMETER :: Default_VISiceCoeff_File = 'NPOESS.VISice.EmisCoeff.bin' + CHARACTER(*), PARAMETER :: Optional_IRwaterCoeff_File = 'Nalli2.IRwater.EmisCoeff.bin' + CHARACTER(*), PARAMETER :: Optional_IRsnowCoeff_File = 'Nalli.IRsnow.EmisCoeff.bin' + LOGICAL, PARAMETER :: netCDF = .FALSE. + CHARACTER(*), PARAMETER :: File_Path = './testinput/' + LOGICAL, PARAMETER :: Quiet = .TRUE. + INTEGER :: err_stat + TYPE(UnitTest_type) :: ioTest + LOGICAL :: testPassed + CHARACTER(*), PARAMETER :: Program_Name = 'Test_Emi_Coeff_io' + + ! Initialize Unit test: + CALL UnitTest_Init(ioTest, .TRUE.) + CALL UnitTest_Setup(ioTest, 'Emi_Coeff_IO_Test', Program_Name, .TRUE.) + + ! Greeting: + WRITE(*,*) 'HELLO, THIS IS A TEST CODE TO INSPECT EmisCoeff files in binary format.' + WRITE(*,*) 'test_emi_coeff_io' + WRITE(*,*) 'The following default EmisCoeff files are investigated: ' + + ! Load the default emissivity coefficient look-up table: + WRITE(*,*) '...loading: ', Default_IRlandCoeff_File + err_stat = 3 + err_stat = CRTM_IRlandCoeff_Load( & + Default_IRlandCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRlandCoeff_Load' ,'Error loading IRlandCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_IRwaterCoeff_File + err_stat = 3 + err_stat = CRTM_IRwaterCoeff_Load( & + Default_IRwaterCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRwaterCoeff_Load' ,'Error loading IRwaterCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_IRsnowCoeff_File + err_stat = 3 + err_stat = CRTM_IRsnowCoeff_Load( & + Default_IRsnowCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRsnowCoeff_Load' ,'Error loading IRsnowCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_IRiceCoeff_File + err_stat = 3 + err_stat = CRTM_IRiceCoeff_Load( & + Default_IRiceCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRiceCoeff_Load' ,'Error loading IRiceCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_VISlandCoeff_File + err_stat = 3 + err_stat = CRTM_VISlandCoeff_Load( & + Default_IRiceCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_VISlandCoeff_Load' ,'Error loading VISlandCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_VISwaterCoeff_File + err_stat = 3 + err_stat = CRTM_VISwaterCoeff_Load( & + Default_VISwaterCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_VISwaterCoeff_Load' ,'Error loading VISwaterCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_VISsnowCoeff_File + err_stat = 3 + err_stat = CRTM_VISsnowCoeff_Load( & + Default_VISsnowCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_VISsnowCoeff_Load' ,'Error loading VISsnowCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_VISiceCoeff_File + err_stat = 3 + err_stat = CRTM_VISiceCoeff_Load( & + Default_VISiceCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_VISiceCoeff_Load' ,'Error loading VISiceCoeff data', err_stat ) + STOP 1 + END IF + + ! Greeting: + WRITE(*,*) 'The following optional EmisCoeff files are investigated: ' + + ! Load the optional emissivity coefficient look-up table: + WRITE(*,*) '...loading: ', Optional_IRwaterCoeff_File + err_stat = 3 + err_stat = CRTM_IRwaterCoeff_Load( & + Optional_IRwaterCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRwaterCoeff_Load' ,'Error loading IRwaterCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Optional_IRsnowCoeff_File + err_stat = 3 + err_stat = CRTM_IRsnowCoeff_Load( & + Optional_IRsnowCoeff_File, & + netCDF = netCDF, & + isSEcategory = .FALSE., & + Quiet = Quiet, & + File_Path = File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRsnowCoeff_Load' ,'Error loading IRsnowCoeff data', err_stat ) + STOP 1 + END IF + STOP 0 + + +END PROGRAM test_emis_coeff_io diff --git a/test/mains/unit/input_output/test_EmisCoeff_NC/test_emis_coeff_io_nc.f90 b/test/mains/unit/input_output/test_EmisCoeff_NC/test_emis_coeff_io_nc.f90 new file mode 100644 index 0000000..7db2c96 --- /dev/null +++ b/test/mains/unit/input_output/test_EmisCoeff_NC/test_emis_coeff_io_nc.f90 @@ -0,0 +1,240 @@ +!------------------------------------------------------- +! +! Description: +! Simple test program to inspect the CRTM Coeff files. +! +! Date: 2018-08-14 Author: P. Stegmann + +! MODIFICATION HISTORY: +! ===================== +! +! Author: Date: Description: +! ======= ===== ============ +! Patrick Stegmann 2021-02-05 Refactored as a CRTM +! unit test. +! Cheng Dang 2021-07-28 Modified for Aerosol +! Coeff look-up table +! Cheng Dang 2022-03-14 Modified for EmisCoeff +! look-up table (VIS,IR) +!------------------------------------------------------- + +PROGRAM test_emis_coeff_io_nc + + ! ==================================================== + ! **** ENVIRONMENT SETUP FOR RTM USAGE **** + ! + + ! Module usage + USE UnitTest_Define, ONLY: UnitTest_type, & + UnitTest_Init, & + UnitTest_Setup, & + UnitTest_Assert, & + UnitTest_Passed + ! ...Infrared surface emissivities + USE CRTM_IRwaterCoeff , ONLY: CRTM_IRwaterCoeff_Load + USE CRTM_IRlandCoeff , ONLY: CRTM_IRlandCoeff_Load + USE CRTM_IRsnowCoeff , ONLY: CRTM_IRsnowCoeff_Load + USE CRTM_IRiceCoeff , ONLY: CRTM_IRiceCoeff_Load + ! ...Visible surface emissivities + USE CRTM_VISwaterCoeff , ONLY: CRTM_VISwaterCoeff_Load + USE CRTM_VISlandCoeff , ONLY: CRTM_VISlandCoeff_Load + USE CRTM_VISsnowCoeff , ONLY: CRTM_VISsnowCoeff_Load + USE CRTM_VISiceCoeff , ONLY: CRTM_VISiceCoeff_Load + USE Message_Handler , ONLY: SUCCESS, Display_Message + + ! Disable all implicit typing + IMPLICIT NONE + + ! Data dictionary: + CHARACTER(2000) :: info + CHARACTER(*), PARAMETER :: Default_IRwaterCoeff_File = 'Nalli.IRwater.EmisCoeff.nc4' + CHARACTER(*), PARAMETER :: Default_IRlandCoeff_File = 'NPOESS.IRland.EmisCoeff.nc4' + CHARACTER(*), PARAMETER :: Default_IRsnowCoeff_File = 'NPOESS.IRsnow.EmisCoeff.nc4' + CHARACTER(*), PARAMETER :: Default_IRiceCoeff_File = 'NPOESS.IRice.EmisCoeff.nc4' + CHARACTER(*), PARAMETER :: Default_VISwaterCoeff_File = 'NPOESS.VISwater.EmisCoeff.nc4' + CHARACTER(*), PARAMETER :: Default_VISlandCoeff_File = 'NPOESS.VISland.EmisCoeff.nc4' + CHARACTER(*), PARAMETER :: Default_VISsnowCoeff_File = 'NPOESS.VISsnow.EmisCoeff.nc4' + CHARACTER(*), PARAMETER :: Default_VISiceCoeff_File = 'NPOESS.VISice.EmisCoeff.nc4' + CHARACTER(*), PARAMETER :: Optional_IRwaterCoeff_File = 'Nalli2.IRwater.EmisCoeff.nc4' + CHARACTER(*), PARAMETER :: Optional_IRsnowCoeff_File = 'Nalli.IRsnow.EmisCoeff.nc4' + CHARACTER(*), PARAMETER :: Optional_IRsnowCoeff_File_Nalli2 = 'Nalli2.IRsnow.EmisCoeff.nc4' + LOGICAL, PARAMETER :: netCDF = .TRUE. + CHARACTER(*), PARAMETER :: NC_File_Path = './testinput/' + LOGICAL, PARAMETER :: Quiet = .TRUE. + INTEGER :: err_stat + TYPE(UnitTest_type) :: ioTest + LOGICAL :: testPassed + CHARACTER(*), PARAMETER :: Program_Name = 'Test_Emi_Coeff_io_nc' + + ! Initialize Unit test: + CALL UnitTest_Init(ioTest, .TRUE.) + CALL UnitTest_Setup(ioTest, 'Emi_Coeff_IO_Test', Program_Name, .TRUE.) + + ! Greeting: + WRITE(*,*) 'HELLO, THIS IS A TEST CODE TO INSPECT EmisCoeff files in netCDF format.' + WRITE(*,*) 'test_emi_coeff_io_nc' + WRITE(*,*) 'The following optional EmisCoeff files are investigated: ' + + ! Load the default emissivity coefficient look-up table: + WRITE(*,*) '...loading: ', Default_IRlandCoeff_File + err_stat = 3 + err_stat = CRTM_IRlandCoeff_Load( & + Default_IRlandCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = NC_File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRlandCoeff_Load' ,'Error loading IRlandCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_IRwaterCoeff_File + err_stat = 3 + err_stat = CRTM_IRwaterCoeff_Load( & + Default_IRwaterCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = NC_File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRwaterCoeff_Load' ,'Error loading IRwaterCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_IRsnowCoeff_File + err_stat = 3 + err_stat = CRTM_IRsnowCoeff_Load( & + Default_IRsnowCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = NC_File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRsnowCoeff_Load' ,'Error loading IRsnowCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_IRiceCoeff_File + err_stat = 3 + err_stat = CRTM_IRiceCoeff_Load( & + Default_IRiceCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = NC_File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRiceCoeff_Load' ,'Error loading IRiceCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_VISlandCoeff_File + err_stat = 3 + err_stat = CRTM_VISlandCoeff_Load( & + Default_IRiceCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = NC_File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_VISlandCoeff_Load' ,'Error loading VISlandCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_VISwaterCoeff_File + err_stat = 3 + err_stat = CRTM_VISwaterCoeff_Load( & + Default_VISwaterCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = NC_File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_VISwaterCoeff_Load' ,'Error loading VISwaterCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_VISsnowCoeff_File + err_stat = 3 + err_stat = CRTM_VISsnowCoeff_Load( & + Default_VISsnowCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = NC_File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_VISsnowCoeff_Load' ,'Error loading VISsnowCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Default_VISiceCoeff_File + err_stat = 3 + err_stat = CRTM_VISiceCoeff_Load( & + Default_VISiceCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = NC_File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_VISiceCoeff_Load' ,'Error loading VISiceCoeff data', err_stat ) + STOP 1 + END IF + + ! Greeting: + WRITE(*,*) 'The following optional EmisCoeff files are investigated: ' + + ! Load the optional emissivity coefficient look-up table: + WRITE(*,*) '...loading: ', Optional_IRwaterCoeff_File + err_stat = 3 + err_stat = CRTM_IRwaterCoeff_Load( & + Optional_IRwaterCoeff_File, & + netCDF = netCDF, & + Quiet = Quiet, & + File_Path = NC_File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRwaterCoeff_Load' ,'Error loading IRwaterCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Optional_IRsnowCoeff_File + err_stat = 3 + err_stat = CRTM_IRsnowCoeff_Load( & + Optional_IRsnowCoeff_File, & + netCDF = netCDF, & + isSEcategory = .FALSE., & + Quiet = Quiet, & + File_Path = NC_File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRsnowCoeff_Load' ,'Error loading IRsnowCoeff data', err_stat ) + STOP 1 + END IF + + WRITE(*,*) '...loading: ', Optional_IRsnowCoeff_File_Nalli2 + err_stat = 3 + err_stat = CRTM_IRsnowCoeff_Load( & + Optional_IRsnowCoeff_File_Nalli2, & + netCDF = netCDF, & + isSEcategory = .FALSE., & + Quiet = Quiet, & + File_Path = NC_File_Path) + CALL UnitTest_Assert(ioTest, (err_stat==SUCCESS) ) + testPassed = UnitTest_Passed(ioTest) + IF ( err_stat /= SUCCESS ) THEN + CALL Display_Message( 'CRTM_IRsnowCoeff_Load' ,'Error loading IRsnowCoeff data', err_stat ) + STOP 1 + END IF + STOP 0 + +END PROGRAM test_emis_coeff_io_nc diff --git a/test/mains/unit/input_output/test_SpcCoeff_NC/data/amsua_aqua.SpcCoeff.nc b/test/mains/unit/input_output/test_SpcCoeff_NC/data/amsua_aqua.SpcCoeff.nc deleted file mode 100755 index dc67c7c..0000000 --- a/test/mains/unit/input_output/test_SpcCoeff_NC/data/amsua_aqua.SpcCoeff.nc +++ /dev/null @@ -1,3 +0,0 @@ -version https://git-lfs.github.com/spec/v1 -oid sha256:b2af0368a0e49b43f3f3316e99c2d8a81f1948eda376b1205d9844c8bd719c7e -size 4572 diff --git a/test/mains/unit/input_output/test_TauCoeff_NC/data/amsua_aqua.TauCoeff.nc b/test/mains/unit/input_output/test_TauCoeff_NC/data/amsua_aqua.TauCoeff.nc deleted file mode 100755 index 7eb8422..0000000 --- a/test/mains/unit/input_output/test_TauCoeff_NC/data/amsua_aqua.TauCoeff.nc +++ /dev/null @@ -1,3 +0,0 @@ -version https://git-lfs.github.com/spec/v1 -oid sha256:cbd0db606d7f9ffede0ee7bf3aff635e791e12b3f3de3d56662da3deee58d6ac -size 102900 diff --git a/test/readme_crtm_tests.txt b/test/readme_crtm_tests.txt index a18d007..30ed49f 100644 --- a/test/readme_crtm_tests.txt +++ b/test/readme_crtm_tests.txt @@ -1,10 +1,9 @@ B. Johnson JCSDA 10/2020 Synopsis: -Application, Unit, and Regression tests, largely culled from Paul van Delst's and Dave Groff's CRTM tests, modified to work with CRTM v2.4.0 in a CMake environment. +Application, Unit, and Regression tests, largely culled from Paul van Delst's and Dave Groff's CRTM tests, modified to work with CRTM v3.0.0 in a CMake environment. Not a complete or comprehensive suite of tests, please add a test each time you add a new code element or substantially change code. -In theory, these tests should work with CRTM v2.3.0, and possibly CRTM v2.2.3 (untested) Layout: @@ -38,11 +37,11 @@ Prerequisites: Currently, it is looking for the CRTM in the following folder: - ${CRTM_SOURCE_ROOT}/Build/crtm_v2.4.0-alpha/ + ${CRTM_SOURCE_ROOT}/Build/crtm_v3.0.0/ In CMakeLists.txt it's looking for it in this line: - HINTS "$ENV{CRTM_SOURCE_ROOT}/Build/crtm_v2.4.0-alpha/lib" + HINTS "$ENV{CRTM_SOURCE_ROOT}/Build/crtm_v3.0.0/lib" Running Tests: