! ! CRTM_RTSolution_Define ! ! Module defining the CRTM RTSolution structure and containing routines ! to manipulate it. ! ! ! CREATION HISTORY: ! Written by: Paul van Delst, 13-May-2004 ! paul.vandelst@noaa.gov ! MODULE CRTM_RTSolution_Define ! ------------------ ! Environment set up ! ------------------ ! Intrinsic modules USE ISO_Fortran_Env , ONLY: OUTPUT_UNIT ! Module use statements USE Type_Kinds , ONLY: fp USE Message_Handler , ONLY: SUCCESS, FAILURE, WARNING, INFORMATION, Display_Message USE Compare_Float_Numbers, ONLY: DEFAULT_N_SIGFIG, & OPERATOR(.EqualTo.), & Compares_Within_Tolerance USE File_Utility , ONLY: File_Open, File_Exists USE Binary_File_Utility , ONLY: Open_Binary_File , & WriteGAtts_Binary_File, & ReadGAtts_Binary_File USE SensorInfo_Parameters, ONLY: INVALID_SENSOR, & INVALID_WMO_SATELLITE_ID, & INVALID_WMO_SENSOR_ID USE CRTM_Parameters , ONLY: STRLEN ! Disable all implicit typing IMPLICIT NONE ! -------------------- ! Default visibilities ! -------------------- ! Everything private by default PRIVATE ! Datatypes PUBLIC :: CRTM_RTSolution_type ! Operators PUBLIC :: OPERATOR(==) PUBLIC :: OPERATOR(+) PUBLIC :: OPERATOR(-) ! Public procedures PUBLIC :: CRTM_RTSolution_Associated PUBLIC :: CRTM_RTSolution_Destroy PUBLIC :: CRTM_RTSolution_Create PUBLIC :: CRTM_RTSolution_Zero PUBLIC :: CRTM_RTSolution_Inspect PUBLIC :: CRTM_RTSolution_DefineVersion PUBLIC :: CRTM_RTSolution_Compare PUBLIC :: CRTM_RTSolution_Statistics PUBLIC :: CRTM_RTSolution_InquireFile PUBLIC :: CRTM_RTSolution_ReadFile PUBLIC :: CRTM_RTSolution_WriteFile ! --------------------- ! Procedure overloading ! --------------------- INTERFACE OPERATOR(==) MODULE PROCEDURE CRTM_RTSolution_Equal END INTERFACE OPERATOR(==) INTERFACE OPERATOR(+) MODULE PROCEDURE CRTM_RTSolution_Add END INTERFACE OPERATOR(+) INTERFACE OPERATOR(-) MODULE PROCEDURE CRTM_RTSolution_Subtract END INTERFACE OPERATOR(-) INTERFACE OPERATOR(**) MODULE PROCEDURE CRTM_RTSolution_Exponent END INTERFACE OPERATOR(**) INTERFACE OPERATOR(/) MODULE PROCEDURE CRTM_RTSolution_Normalise END INTERFACE OPERATOR(/) INTERFACE SQRT MODULE PROCEDURE CRTM_RTSolution_Sqrt END INTERFACE SQRT INTERFACE CRTM_RTSolution_Inspect MODULE PROCEDURE Scalar_Inspect MODULE PROCEDURE Rank2_Inspect END INTERFACE CRTM_RTSolution_Inspect ! ----------------- ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & '$Id: CRTM_RTSolution_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: ONE = 1.0_fp ! Message string length INTEGER, PARAMETER :: ML = 256 ! File status on close after write error CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE' ! ------------------------------- ! RTSolution data type definition ! ------------------------------- !:tdoc+: TYPE :: CRTM_RTSolution_type ! Allocation indicator LOGICAL :: Is_Allocated = .FALSE. ! Dimensions INTEGER :: n_Layers = 0 ! K ! Sensor information CHARACTER(STRLEN) :: Sensor_ID = '' INTEGER :: WMO_Satellite_ID = INVALID_WMO_SATELLITE_ID INTEGER :: WMO_Sensor_ID = INVALID_WMO_SENSOR_ID INTEGER :: Sensor_Channel = 0 ! RT algorithm information CHARACTER(STRLEN) :: RT_Algorithm_Name = '' ! Internal variables. Users do not need to worry about these. LOGICAL :: Scattering_Flag = .TRUE. INTEGER :: n_Full_Streams = 0 INTEGER :: n_Stokes = 0 ! Forward radiative transfer intermediate results for a single channel ! These components are not defined when they are used as TL, AD ! and K variables REAL(fp) :: SSA_Max = ZERO ! Max Single Scattering Albedo in the profile REAL(fp) :: SOD = ZERO ! Scattering Optical Depth REAL(fp) :: Surface_Emissivity = ZERO REAL(fp) :: Surface_Reflectivity = ZERO REAL(fp) :: Up_Radiance = ZERO REAL(fp) :: Down_Radiance = ZERO REAL(fp) :: Down_Solar_Radiance = ZERO REAL(fp) :: Surface_Planck_Radiance = ZERO REAL(fp) :: Total_Cloud_Cover = ZERO ! Only used for fractional clear/cloudy calculation REAL(fp) :: R_clear = ZERO ! Only used for fractional clear/cloudy calculation REAL(fp) :: Tb_clear = ZERO ! Only used for fractional clear/cloudy calculation REAL(fp), ALLOCATABLE :: Upwelling_Overcast_Radiance(:) ! K REAL(fp), ALLOCATABLE :: Upwelling_Radiance(:) ! K REAL(fp), ALLOCATABLE :: Layer_Optical_Depth(:) ! K REAL(fp), ALLOCATABLE :: Single_Scatter_Albedo(:) ! K ! Radiative transfer results for a single channel REAL(fp) :: Radiance = ZERO REAL(fp) :: Brightness_Temperature = ZERO END TYPE CRTM_RTSolution_type !:tdoc-: CONTAINS !################################################################################## !################################################################################## !## ## !## ## PUBLIC MODULE ROUTINES ## ## !## ## !################################################################################## !################################################################################## !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_RTSolution_Associated ! ! PURPOSE: ! Elemental function to test the status of the allocatable components ! of a CRTM RTSolution object. ! ! CALLING SEQUENCE: ! Status = CRTM_RTSolution_Associated( RTSolution ) ! ! OBJECTS: ! RTSolution: RTSolution structure which is to have its member's ! status tested. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(IN) ! ! FUNCTION RESULT: ! Status: The return value is a logical value indicating the ! status of the RTSolution members. ! .TRUE. - if the array components are allocated. ! .FALSE. - if the array components are not allocated. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Same as input RTSolution argument ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL FUNCTION CRTM_RTSolution_Associated( RTSolution ) RESULT( Status ) TYPE(CRTM_RTSolution_type), INTENT(IN) :: RTSolution LOGICAL :: Status Status = RTSolution%Is_Allocated END FUNCTION CRTM_RTSolution_Associated !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_RTSolution_Destroy ! ! PURPOSE: ! Elemental subroutine to re-initialize CRTM RTSolution objects. ! ! CALLING SEQUENCE: ! CALL CRTM_RTSolution_Destroy( RTSolution ) ! ! OBJECTS: ! RTSolution: Re-initialized RTSolution structure. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar OR any rank ! ATTRIBUTES: INTENT(OUT) ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL SUBROUTINE CRTM_RTSolution_Destroy( RTSolution ) TYPE(CRTM_RTSolution_type), INTENT(OUT) :: RTSolution RTSolution%Is_Allocated = .FALSE. RTSolution%n_Layers = 0 END SUBROUTINE CRTM_RTSolution_Destroy !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_RTSolution_Create ! ! PURPOSE: ! Elemental subroutine to create an instance of the CRTM RTSolution object. ! ! CALLING SEQUENCE: ! CALL CRTM_RTSolution_Create( RTSolution, n_Layers ) ! ! OBJECTS: ! RTSolution: RTSolution structure. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(OUT) ! ! INPUTS: ! n_Layers: Number of layers for which there is RTSolution data. ! Must be > 0. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Same as RTSolution object ! ATTRIBUTES: INTENT(IN) ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL SUBROUTINE CRTM_RTSolution_Create( RTSolution, n_Layers ) ! Arguments TYPE(CRTM_RTSolution_type), INTENT(OUT) :: RTSolution INTEGER, INTENT(IN) :: n_Layers ! Local variables INTEGER :: alloc_stat ! Check input IF ( n_Layers < 1 ) RETURN ! Perform the allocation ALLOCATE( RTSolution%Upwelling_Radiance(n_Layers), & RTSolution%Upwelling_Overcast_Radiance(n_Layers), & RTSolution%Layer_Optical_Depth(n_Layers), & RTSolution%Single_Scatter_Albedo(n_Layers), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN ! Initialise ! ...Dimensions RTSolution%n_Layers = n_Layers ! ...Arrays RTSolution%Upwelling_Radiance = ZERO RTSolution%Upwelling_Overcast_Radiance = ZERO RTSolution%Layer_Optical_Depth = ZERO RTSolution%Single_Scatter_Albedo = ZERO ! Set allocation indicator RTSolution%Is_Allocated = .TRUE. END SUBROUTINE CRTM_RTSolution_Create !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_RTSolution_Zero ! ! PURPOSE: ! Elemental subroutine to zero out the data components ! in a CRTM RTSolution object. ! ! CALLING SEQUENCE: ! CALL CRTM_RTSolution_Zero( rts ) ! ! OUTPUTS: ! rts: CRTM RTSolution structure in which the data components ! are to be zeroed out. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(IN OUT) ! ! COMMENTS: ! - The dimension components of the structure are *NOT* set to zero. ! - The sensor infomration and RT algorithm components are ! *NOT* reset in this routine. ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL SUBROUTINE CRTM_RTSolution_Zero( RTSolution ) TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: RTSolution ! Zero out the scalar data components RTSolution%SSA_Max = ZERO RTSolution%SOD = ZERO RTSolution%Surface_Emissivity = ZERO RTSolution%Surface_Reflectivity = ZERO RTSolution%Up_Radiance = ZERO RTSolution%Down_Radiance = ZERO RTSolution%Down_Solar_Radiance = ZERO RTSolution%Surface_Planck_Radiance = ZERO RTSolution%Total_Cloud_Cover = ZERO RTSolution%R_clear = ZERO RTSolution%Tb_clear = ZERO RTSolution%Radiance = ZERO RTSolution%Brightness_Temperature = ZERO ! Zero out the array data components IF ( CRTM_RTSolution_Associated(RTSolution) ) THEN RTSolution%Upwelling_Radiance = ZERO RTSolution%Upwelling_Overcast_Radiance = ZERO RTSolution%Layer_Optical_Depth = ZERO RTSolution%Single_Scatter_Albedo = ZERO END IF END SUBROUTINE CRTM_RTSolution_Zero !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_RTSolution_Inspect ! ! PURPOSE: ! Subroutine to print the contents of a CRTM RTSolution object to stdout. ! ! CALLING SEQUENCE: ! CALL CRTM_RTSolution_Inspect( RTSolution, Unit=unit ) ! ! INPUTS: ! RTSolution: CRTM RTSolution object to display. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar or Rank-2 (n_channels x n_profiles) ! ATTRIBUTES: INTENT(IN) ! ! OPTIONAL INPUTS: ! Unit: Unit number for an already open file to which the output ! will be written. ! If the argument is specified and the file unit is not ! connected, the output goes to stdout. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN), OPTIONAL ! !:sdoc-: !-------------------------------------------------------------------------------- SUBROUTINE Scalar_Inspect( RTSolution, Unit ) ! Arguments TYPE(CRTM_RTSolution_type), INTENT(IN) :: RTSolution 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,"RTSolution OBJECT")') ! Display components WRITE(fid,'(3x,"Sensor Id : ",a )') TRIM(RTSolution%Sensor_ID) WRITE(fid,'(3x,"WMO Satellite Id : ",i0)') RTSolution%WMO_Satellite_ID WRITE(fid,'(3x,"WMO Sensor Id : ",i0)') RTSolution%WMO_Sensor_ID WRITE(fid,'(3x,"Channel : ",i0)') RTSolution%Sensor_Channel WRITE(fid,'(3x,"RT Algorithm Name : ",a )') RTSolution%RT_Algorithm_Name WRITE(fid,'(3x,"Scattering Optical Depth : ",es13.6)') RTSolution%SOD WRITE(fid,'(3x,"Surface Emissivity : ",es13.6)') RTSolution%Surface_Emissivity WRITE(fid,'(3x,"Surface Reflectivity : ",es13.6)') RTSolution%Surface_Reflectivity WRITE(fid,'(3x,"Up Radiance : ",es13.6)') RTSolution%Up_Radiance WRITE(fid,'(3x,"Down Radiance : ",es13.6)') RTSolution%Down_Radiance WRITE(fid,'(3x,"Down Solar Radiance : ",es13.6)') RTSolution%Down_Solar_Radiance WRITE(fid,'(3x,"Surface Planck Radiance : ",es13.6)') RTSolution%Surface_Planck_Radiance WRITE(fid,'(3x,"Total cloud cover : ",es13.6)') RTSolution%Total_Cloud_Cover WRITE(fid,'(3x,"Radiance (clear) : ",es13.6)') RTSolution%R_clear WRITE(fid,'(3x,"Brightness Temperature (clear): ",es13.6)') RTSolution%Tb_clear WRITE(fid,'(3x,"Radiance : ",es13.6)') RTSolution%Radiance WRITE(fid,'(3x,"Brightness Temperature : ",es13.6)') RTSolution%Brightness_Temperature IF ( .NOT. CRTM_RTSolution_Associated(RTSolution) ) RETURN WRITE(fid,'(3x,"n_Layers : ",i0)') RTSolution%n_Layers WRITE(fid,'(3x,"Upwelling Overcast Radiance :")') WRITE(fid,'(5(1x,es13.6,:))') RTSolution%Upwelling_Overcast_Radiance WRITE(fid,'(3x,"Upwelling Radiance :")') WRITE(fid,'(5(1x,es13.6,:))') RTSolution%Upwelling_Radiance WRITE(fid,'(3x,"Layer Optical Depth :")') WRITE(fid,'(5(1x,es13.6,:))') RTSolution%Layer_Optical_Depth END SUBROUTINE Scalar_Inspect SUBROUTINE Rank2_Inspect( RTSolution, Unit ) TYPE(CRTM_RTSolution_type), INTENT(IN) :: RTSolution(:,:) INTEGER, OPTIONAL, INTENT(IN) :: Unit INTEGER :: fid INTEGER :: i, n_channels INTEGER :: j, n_profiles fid = OUTPUT_UNIT IF ( PRESENT(Unit) ) THEN IF ( File_Open(Unit) ) fid = Unit END IF n_channels = SIZE(RTSolution,1) n_profiles = SIZE(RTSolution,2) DO j = 1, n_profiles DO i = 1, n_channels WRITE(fid, FMT='(1x,"PROFILE INDEX:",i0,", CHANNEL INDEX:",i0," - ")', ADVANCE='NO') j,i CALL Scalar_Inspect(RTSolution(i,j), Unit=Unit) END DO END DO END SUBROUTINE Rank2_Inspect !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_RTSolution_DefineVersion ! ! PURPOSE: ! Subroutine to return the module version information. ! ! CALLING SEQUENCE: ! CALL CRTM_RTSolution_DefineVersion( Id ) ! ! OUTPUTS: ! Id: Character string containing the version Id information ! for the module. ! UNITS: N/A ! TYPE: CHARACTER(*) ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT) ! !:sdoc-: !-------------------------------------------------------------------------------- SUBROUTINE CRTM_RTSolution_DefineVersion( Id ) CHARACTER(*), INTENT(OUT) :: Id Id = MODULE_VERSION_ID END SUBROUTINE CRTM_RTSolution_DefineVersion !------------------------------------------------------------------------------ !:sdoc+: ! NAME: ! CRTM_RTSolution_Compare ! ! PURPOSE: ! Elemental function to compare two CRTM_RTSolution objects to within ! a user specified number of significant figures. ! ! CALLING SEQUENCE: ! is_comparable = CRTM_RTSolution_Compare( x, y, n_SigFig=n_SigFig ) ! ! OBJECTS: ! x, y: Two CRTM RTSolution objects to be compared. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(IN) ! ! OPTIONAL INPUTS: ! n_SigFig: Number of significant figure to compare floating point ! components. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Conformable with inputs ! ATTRIBUTES: INTENT(IN), OPTIONAL ! ! FUNCTION RESULT: ! is_comparable: Logical value indicating whether the inputs are ! comparable. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Same as inputs. !:sdoc-: !------------------------------------------------------------------------------ ELEMENTAL FUNCTION CRTM_RTSolution_Compare( & x, & y, & n_SigFig ) & RESULT( is_comparable ) TYPE(CRTM_RTSolution_type), INTENT(IN) :: x, y INTEGER, OPTIONAL, INTENT(IN) :: n_SigFig LOGICAL :: is_comparable ! Variables INTEGER :: n ! Set up is_comparable = .FALSE. IF ( PRESENT(n_SigFig) ) THEN n = ABS(n_SigFig) ELSE n = DEFAULT_N_SIGFIG END IF ! Check the structure association status IF ( CRTM_RTSolution_Associated(x) .NEQV. CRTM_RTSolution_Associated(y) ) RETURN ! Check the sensor information IF ( (x%Sensor_ID /= y%Sensor_ID ) .OR. & (x%WMO_Satellite_ID /= y%WMO_Satellite_ID) .OR. & (x%WMO_Sensor_ID /= y%WMO_Sensor_ID ) .OR. & (x%Sensor_Channel /= y%Sensor_Channel ) ) RETURN ! Check the RT algorithm name IF ( x%RT_Algorithm_Name /= y%RT_Algorithm_Name ) RETURN ! Check the scalar components IF ( .NOT. Compares_Within_Tolerance(x%SOD , y%SOD , n) .OR. & .NOT. Compares_Within_Tolerance(x%Surface_Emissivity , y%Surface_Emissivity , n) .OR. & .NOT. Compares_Within_Tolerance(x%Surface_Reflectivity , y%Surface_Reflectivity , n) .OR. & .NOT. Compares_Within_Tolerance(x%Up_Radiance , y%Up_Radiance , n) .OR. & .NOT. Compares_Within_Tolerance(x%Down_Radiance , y%Down_Radiance , n) .OR. & .NOT. Compares_Within_Tolerance(x%Down_Solar_Radiance , y%Down_Solar_Radiance , n) .OR. & .NOT. Compares_Within_Tolerance(x%Surface_Planck_Radiance, y%Surface_Planck_Radiance, n) .OR. & .NOT. Compares_Within_Tolerance(x%Total_Cloud_Cover , y%Total_Cloud_Cover , n) .OR. & .NOT. Compares_Within_Tolerance(x%R_clear , y%R_clear , n) .OR. & .NOT. Compares_Within_Tolerance(x%Tb_clear , y%Tb_clear , n) .OR. & .NOT. Compares_Within_Tolerance(x%Radiance , y%Radiance , n) .OR. & .NOT. Compares_Within_Tolerance(x%Brightness_Temperature , y%Brightness_Temperature , n) ) RETURN ! Check the array components IF ( CRTM_RTSolution_Associated(x) .AND. CRTM_RTSolution_Associated(y) ) THEN IF ( (.NOT. ALL(Compares_Within_Tolerance(x%Upwelling_Overcast_Radiance, y%Upwelling_Overcast_Radiance, n))) .OR. & (.NOT. ALL(Compares_Within_Tolerance(x%Upwelling_Radiance , y%Upwelling_Radiance , n))) .OR. & (.NOT. ALL(Compares_Within_Tolerance(x%Layer_Optical_Depth , y%Layer_Optical_Depth , n))) ) RETURN END IF ! If we get here, the structures are comparable is_comparable = .TRUE. END FUNCTION CRTM_RTSolution_Compare !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_RTSolution_Statistics ! ! PURPOSE: ! Function to compute the statistics of an array of CRTM RTSolution objects. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_RTSolution_Statistics( rts, rts_stats ) ! ! INPUTS: ! rts: RTSolution object array for which statistics are required. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Rank-2 (n_channels x n_profiles) ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! rts_stats: Allocatable RTSolution object array containing the statistics ! for each channel. ! rts_stats(:,1) contains the profile average ! rts_stats(:,2) contains the profile standard deviation ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Rank-2 (n_channels x 2) ! ATTRIBUTES: INTENT(IN), ALLOCATABLE ! ! 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 CRTM_RTSolution_Statistics(rts, rts_stats) RESULT( err_stat ) ! Arguments TYPE(CRTM_RTSolution_type), INTENT(IN) :: rts(:,:) TYPE(CRTM_RTSolution_type), ALLOCATABLE, INTENT(OUT) :: rts_stats(:,:) ! Function result INTEGER :: err_stat ! Function parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_RTSolution_Statistics' ! Function variables CHARACTER(ML) :: err_msg CHARACTER(ML) :: alloc_msg INTEGER :: alloc_stat INTEGER :: n_channels, l INTEGER :: n_profiles, m REAL(fp) :: factor ! Setup err_stat = SUCCESS n_channels = SIZE(rts, DIM=1) n_profiles = SIZE(rts, DIM=2) factor = REAL(n_profiles,fp) ! Allocate the output stats object array ALLOCATE( rts_stats(n_channels, 2), & STAT = alloc_stat ) !STAT = alloc_stat, ERRMSG = alloc_msg ) IF ( alloc_stat /= 0 ) THEN err_msg = 'Error allocating output RTSolution structure - '//TRIM(alloc_msg) err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ); RETURN END IF rts_stats(:,1) = rts(:,1) rts_stats(:,2) = rts(:,1) CALL CRTM_RTSolution_Zero(rts_stats) ! Compute the average DO m = 1, n_profiles DO l = 1, n_channels rts_stats(l,1) = rts_stats(l,1) + rts(l,m) END DO END DO rts_stats(:,1) = rts_stats(:,1)/factor ! Compute the standard deviation DO m = 1, n_profiles DO l = 1, n_channels rts_stats(l,2) = rts_stats(l,2) + (rts(l,m) - rts_stats(l,1))**2 END DO END DO rts_stats(:,2) = SQRT(rts_stats(:,2)/factor) ! Replace the algorithm identifier rts_stats(:,1)%RT_Algorithm_Name = 'Average' rts_stats(:,2)%RT_Algorithm_Name = 'Standard deviation' END FUNCTION CRTM_RTSolution_Statistics !------------------------------------------------------------------------------ !:sdoc+: ! ! NAME: ! CRTM_RTSolution_InquireFile ! ! PURPOSE: ! Function to inquire CRTM RTSolution object files. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_RTSolution_InquireFile( Filename , & ! n_Channels = n_Channels, & ! n_Profiles = n_Profiles ) ! ! INPUTS: ! Filename: Character string specifying the name of a ! CRTM RTSolution data file to read. ! UNITS: N/A ! TYPE: CHARACTER(*) ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OPTIONAL OUTPUTS: ! n_Channels: The number of spectral channels for which there is ! data in the file. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! ATTRIBUTES: OPTIONAL, INTENT(OUT) ! ! n_Profiles: The number of profiles in the data file. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! ATTRIBUTES: OPTIONAL, 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 file inquire was successful ! == FAILURE, an unrecoverable error occurred. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! !:sdoc-: !------------------------------------------------------------------------------ FUNCTION CRTM_RTSolution_InquireFile( & Filename , & ! Input n_Channels , & ! Optional output n_Profiles ) & ! Optional output RESULT( err_stat ) ! Arguments CHARACTER(*), INTENT(IN) :: Filename INTEGER , OPTIONAL, INTENT(OUT) :: n_Channels INTEGER , OPTIONAL, INTENT(OUT) :: n_Profiles ! Function result INTEGER :: err_stat ! Function parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_RTSolution_InquireFile' ! Function variables CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg INTEGER :: io_stat INTEGER :: fid INTEGER :: l, m ! Set up err_stat = SUCCESS ! Check that the file exists IF ( .NOT. File_Exists( TRIM(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 number of channels,profiles READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) l, m IF ( io_stat /= 0 ) THEN msg = 'Error reading dimensions from '//TRIM(Filename)//' - '//TRIM(io_msg) 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 ! Set the return arguments IF ( PRESENT(n_Channels) ) n_Channels = l IF ( PRESENT(n_Profiles) ) n_Profiles = m CONTAINS SUBROUTINE Inquire_CleanUp() IF ( File_Open( Filename ) ) THEN CLOSE( fid,IOSTAT=io_stat,IOMSG=io_msg ) IF ( io_stat /= SUCCESS ) & 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 Inquire_CleanUp END FUNCTION CRTM_RTSolution_InquireFile !------------------------------------------------------------------------------ !:sdoc+: ! ! NAME: ! CRTM_RTSolution_ReadFile ! ! PURPOSE: ! Function to read CRTM RTSolution object files. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_RTSolution_ReadFile( Filename , & ! RTSolution , & ! Quiet = Quiet , & ! n_Channels = n_Channels , & ! n_Profiles = n_Profiles , & ! ! INPUTS: ! Filename: Character string specifying the name of an ! RTSolution format data file to read. ! UNITS: N/A ! TYPE: CHARACTER(*) ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! RTSolution: CRTM RTSolution object array containing the RTSolution ! data. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Rank-2 (n_Channels x n_Profiles) ! ATTRIBUTES: INTENT(OUT), ALLOCATABLE ! ! 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: ! n_Channels: The number of channels for which data was read. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! ATTRIBUTES: OPTIONAL, INTENT(OUT) ! ! n_Profiles: The number of profiles for which data was read. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! ATTRIBUTES: OPTIONAL, 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 file read was successful ! == FAILURE, an unrecoverable error occurred. ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! !:sdoc-: !------------------------------------------------------------------------------ FUNCTION CRTM_RTSolution_ReadFile( & Filename , & ! Input RTSolution , & ! Output Quiet , & ! Optional input n_Channels , & ! Optional output n_Profiles , & ! Optional output Debug ) & ! Optional input (Debug output control) RESULT( err_stat ) ! Arguments CHARACTER(*), INTENT(IN) :: Filename TYPE(CRTM_RTSolution_type), ALLOCATABLE, INTENT(OUT) :: RTSolution(:,:) ! L x M LOGICAL, OPTIONAL, INTENT(IN) :: Quiet INTEGER, OPTIONAL, INTENT(OUT) :: n_Channels INTEGER, OPTIONAL, INTENT(OUT) :: n_Profiles LOGICAL, OPTIONAL, INTENT(IN) :: Debug ! Function result INTEGER :: err_stat ! Function parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_RTSolution_ReadFile' ! Function variables CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg CHARACTER(ML) :: alloc_msg INTEGER :: io_stat INTEGER :: alloc_stat LOGICAL :: noisy INTEGER :: fid INTEGER :: l, n_input_channels INTEGER :: m, n_input_profiles ! Set up err_stat = SUCCESS ! ...Check Quiet argument noisy = .TRUE. IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet ! ...Override Quiet settings if debug set. IF ( PRESENT(Debug) ) noisy = Debug ! Open the file err_stat = Open_Binary_File( Filename, fid ) IF ( err_stat /= SUCCESS ) THEN msg = 'Error opening '//TRIM(Filename) CALL Read_Cleanup(); RETURN END IF ! Read the dimensions READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) n_input_channels, n_input_profiles IF ( io_stat /= 0 ) THEN msg = 'Error reading dimensions from '//TRIM(Filename)//' - '//TRIM(io_msg) CALL Read_Cleanup(); RETURN END IF ! ...Allocate the return structure array !ALLOCATE(RTSolution(n_input_channels, n_input_profiles), STAT=alloc_stat, ERRMSG=alloc_msg) ALLOCATE(RTSolution(n_input_channels, n_input_profiles), STAT=alloc_stat) IF ( alloc_stat /= 0 ) THEN msg = 'Error allocating RTSolution array - '//TRIM(alloc_msg) CALL Read_Cleanup(); RETURN END IF ! Loop over all the profiles and channels Profile_Loop: DO m = 1, n_input_profiles Channel_Loop: DO l = 1, n_input_channels err_stat = Read_Record( fid, RTSolution(l,m) ) IF ( err_stat /= SUCCESS ) THEN WRITE( msg,'("Error reading RTSolution element (",i0,",",i0,") from ",a)' ) & l, m, TRIM(Filename) CALL Read_Cleanup(); RETURN END IF END DO Channel_Loop END DO Profile_Loop ! 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 Read_Cleanup(); RETURN END IF ! Set the return values IF ( PRESENT(n_Channels) ) n_Channels = n_input_channels IF ( PRESENT(n_Profiles) ) n_Profiles = n_input_profiles ! Output an info message IF ( noisy ) THEN WRITE( msg,'("Number of channels and profiles read from ",a,": ",i0,1x,i0)' ) & TRIM(Filename), n_input_channels, n_input_profiles CALL Display_Message( ROUTINE_NAME, 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 IF ( ALLOCATED(RTSolution) ) THEN !DEALLOCATE(RTSolution, STAT=alloc_stat, ERRMSG=alloc_msg) DEALLOCATE(RTSolution, STAT=alloc_stat) IF ( alloc_stat /= 0 ) & msg = TRIM(msg)//'; Error deallocating RTSolution array during error cleanup - '//& TRIM(alloc_msg) END IF err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END SUBROUTINE Read_CleanUp END FUNCTION CRTM_RTSolution_ReadFile !------------------------------------------------------------------------------ !:sdoc+: ! ! NAME: ! CRTM_RTSolution_WriteFile ! ! PURPOSE: ! Function to write CRTM RTSolution object files. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_RTSolution_WriteFile( Filename , & ! RTSolution , & ! Quiet = Quiet ) ! ! INPUTS: ! Filename: Character string specifying the name of the ! RTSolution format data file to write. ! UNITS: N/A ! TYPE: CHARACTER(*) ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! RTSolution: CRTM RTSolution object array containing the RTSolution ! data. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Rank-2 (n_Channels x n_Profiles) ! 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 write 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 during *writing*, the output file is deleted before ! returning to the calling routine. ! !:sdoc-: !------------------------------------------------------------------------------ FUNCTION CRTM_RTSolution_WriteFile( & Filename , & ! Input RTSolution , & ! Input Quiet , & ! Optional input Debug ) & ! Optional input (Debug output control) RESULT( err_stat ) ! Arguments CHARACTER(*), INTENT(IN) :: Filename TYPE(CRTM_RTSolution_type), INTENT(IN) :: RTSolution(:,:) LOGICAL, OPTIONAL, INTENT(IN) :: Quiet LOGICAL, OPTIONAL, INTENT(IN) :: Debug ! Function result INTEGER :: err_stat ! Function parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_RTSolution_WriteFile' ! Function variables CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg INTEGER :: io_stat LOGICAL :: noisy INTEGER :: fid INTEGER :: l, n_output_channels INTEGER :: m, n_output_profiles ! Set up err_stat = SUCCESS ! ...Check Quiet argument noisy = .TRUE. IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet ! ...Override Quiet settings if debug set. IF ( PRESENT(Debug) ) noisy = Debug n_output_channels = SIZE(RTSolution,DIM=1) n_output_profiles = SIZE(RTSolution,DIM=2) ! Open the file 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 ! Write the dimensions WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) n_output_channels, n_output_profiles IF ( io_stat /= 0 ) THEN msg = 'Error writing dimensions to '//TRIM(Filename)//' - '//TRIM(io_msg) CALL Write_Cleanup(); RETURN END IF ! Write the data Profile_Loop: DO m = 1, n_output_profiles Channel_Loop: DO l = 1, n_output_channels err_stat = Write_Record( fid, RTSolution(l,m) ) IF ( err_stat /= SUCCESS ) THEN WRITE( msg,'("Error writing RTSolution element (",i0,",",i0,") to ",a)' ) & l, m, TRIM(Filename) CALL Write_Cleanup(); RETURN END IF END DO Channel_Loop END DO Profile_Loop ! Close the file (if error, no delete) CLOSE( fid,STATUS='KEEP',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 ! Output an info message IF ( noisy ) THEN WRITE( msg,'("Number of channels and profiles written to ",a,": ",i0,1x,i0 )' ) & TRIM(Filename), n_output_channels, n_output_profiles CALL Display_Message( ROUTINE_NAME, 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 deleting output 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 CRTM_RTSolution_WriteFile !################################################################################## !################################################################################## !## ## !## ## PRIVATE MODULE ROUTINES ## ## !## ## !################################################################################## !################################################################################## !------------------------------------------------------------------------------ ! ! NAME: ! CRTM_RTSolution_Equal ! ! PURPOSE: ! Elemental function to test the equality of two CRTM_RTSolution objects. ! Used in OPERATOR(==) interface block. ! ! CALLING SEQUENCE: ! is_equal = CRTM_RTSolution_Equal( x, y ) ! ! or ! ! IF ( x == y ) THEN ! ... ! END IF ! ! OBJECTS: ! x, y: Two CRTM RTSolution objects to be compared. ! UNITS: N/A ! TYPE: CRTM_RTSolution_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 CRTM_RTSolution_Equal( x, y ) RESULT( is_equal ) TYPE(CRTM_RTSolution_type) , INTENT(IN) :: x, y LOGICAL :: is_equal ! Setup is_equal = .FALSE. ! Check the structure association status IF ( CRTM_RTSolution_Associated(x) .NEQV. CRTM_RTSolution_Associated(y) ) RETURN ! Check scalars IF ( (x%n_Layers == y%n_Layers) .AND. & (x%Sensor_ID == y%Sensor_ID ) .AND. & (x%WMO_Satellite_ID == y%WMO_Satellite_ID ) .AND. & (x%WMO_Sensor_ID == y%WMO_Sensor_ID ) .AND. & (x%Sensor_Channel == y%Sensor_Channel ) .AND. & (x%RT_Algorithm_Name == y%RT_Algorithm_Name) .AND. & (x%SOD .EqualTo. y%SOD ) .AND. & (x%Surface_Emissivity .EqualTo. y%Surface_Emissivity ) .AND. & (x%Surface_Reflectivity .EqualTo. y%Surface_Reflectivity ) .AND. & (x%Up_Radiance .EqualTo. y%Up_Radiance ) .AND. & (x%Down_Radiance .EqualTo. y%Down_Radiance ) .AND. & (x%Down_Solar_Radiance .EqualTo. y%Down_Solar_Radiance ) .AND. & (x%Surface_Planck_Radiance .EqualTo. y%Surface_Planck_Radiance) .AND. & (x%Total_Cloud_Cover .EqualTo. y%Total_Cloud_Cover ) .AND. & (x%R_clear .EqualTo. y%R_clear ) .AND. & (x%Tb_clear .EqualTo. y%Tb_clear ) .AND. & (x%Radiance .EqualTo. y%Radiance ) .AND. & (x%Brightness_Temperature .EqualTo. y%Brightness_Temperature ) ) & is_equal = .TRUE. ! Check arrays (which may or may not be allocated) IF ( CRTM_RTSolution_Associated(x) .AND. CRTM_RTSolution_Associated(y) ) THEN is_equal = is_equal .AND. & ALL(x%Upwelling_Overcast_Radiance .EqualTo. y%Upwelling_Overcast_Radiance ) .AND. & ALL(x%Upwelling_Radiance .EqualTo. y%Upwelling_Radiance ) .AND. & ALL(x%Layer_Optical_Depth .EqualTo. y%Layer_Optical_Depth ) END IF END FUNCTION CRTM_RTSolution_Equal !-------------------------------------------------------------------------------- ! ! NAME: ! CRTM_RTSolution_Add ! ! PURPOSE: ! Pure function to add two CRTM RTSolution objects. ! Used in OPERATOR(+) interface block. ! ! CALLING SEQUENCE: ! rtssum = CRTM_RTSolution_Add( rts1, rts2 ) ! ! or ! ! rtssum = rts1 + rts2 ! ! ! INPUTS: ! rts1, rts2: The RTSolution objects to add. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN OUT) ! ! RESULT: ! rtssum: RTSolution object containing the summed components. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar ! !-------------------------------------------------------------------------------- ELEMENTAL FUNCTION CRTM_RTSolution_Add( rts1, rts2 ) RESULT( rtssum ) TYPE(CRTM_RTSolution_type), INTENT(IN) :: rts1, rts2 TYPE(CRTM_RTSolution_type) :: rtssum INTEGER :: k ! Check input ! ...If input structure association status different, do nothing IF ( CRTM_RTSolution_Associated(rts1) .NEQV. CRTM_RTSolution_Associated(rts2) ) RETURN ! ...If input structure for different sensors, do nothing IF ( (rts1%Sensor_ID /= rts2%Sensor_ID ) .AND. & (rts1%WMO_Satellite_ID /= rts2%WMO_Satellite_ID ) .AND. & (rts1%WMO_Sensor_ID /= rts2%WMO_Sensor_ID ) .AND. & (rts1%Sensor_Channel /= rts2%Sensor_Channel ) ) RETURN ! Copy the first structure rtssum = rts1 ! And add the second one's components to it ! ...Handle RT_Algorithm_Name rtssum%RT_Algorithm_Name = 'Addition' ! ...The scalar values rtssum%SOD = rtssum%SOD + rts2%SOD rtssum%Surface_Emissivity = rtssum%Surface_Emissivity + rts2%Surface_Emissivity rtssum%Surface_Reflectivity = rtssum%Surface_Reflectivity + rts2%Surface_Reflectivity rtssum%Up_Radiance = rtssum%Up_Radiance + rts2%Up_Radiance rtssum%Down_Radiance = rtssum%Down_Radiance + rts2%Down_Radiance rtssum%Down_Solar_Radiance = rtssum%Down_Solar_Radiance + rts2%Down_Solar_Radiance rtssum%Surface_Planck_Radiance = rtssum%Surface_Planck_Radiance + rts2%Surface_Planck_Radiance rtssum%Total_Cloud_Cover = rtssum%Total_Cloud_Cover + rts2%Total_Cloud_Cover rtssum%R_clear = rtssum%R_clear + rts2%R_clear rtssum%Tb_clear = rtssum%Tb_clear + rts2%Tb_clear rtssum%Radiance = rtssum%Radiance + rts2%Radiance rtssum%Brightness_Temperature = rtssum%Brightness_Temperature + rts2%Brightness_Temperature ! ...The arrays (which may or may not be allocated) IF ( CRTM_RTSolution_Associated(rts1) .AND. CRTM_RTSolution_Associated(rts2) ) THEN k = rts1%n_Layers rtssum%Upwelling_Overcast_Radiance(1:k) = rtssum%Upwelling_Overcast_Radiance(1:k) + & rts2%Upwelling_Overcast_Radiance(1:k) rtssum%Upwelling_Radiance(1:k) = rtssum%Upwelling_Radiance(1:k) + & rts2%Upwelling_Radiance(1:k) rtssum%Layer_Optical_Depth(1:k) = rtssum%Layer_Optical_Depth(1:k) + & rts2%Layer_Optical_Depth(1:k) END IF END FUNCTION CRTM_RTSolution_Add !-------------------------------------------------------------------------------- ! ! NAME: ! CRTM_RTSolution_Subtract ! ! PURPOSE: ! Pure function to subtract two CRTM RTSolution objects. ! Used in OPERATOR(-) interface block. ! ! CALLING SEQUENCE: ! rtsdiff = CRTM_RTSolution_Subtract( rts1, rts2 ) ! ! or ! ! rtsdiff = rts1 - rts2 ! ! ! INPUTS: ! rts1, rts2: The RTSolution objects to difference. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN OUT) ! ! RESULT: ! rtsdiff: RTSolution object containing the differenced components. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar ! !-------------------------------------------------------------------------------- ELEMENTAL FUNCTION CRTM_RTSolution_Subtract( rts1, rts2 ) RESULT( rtsdiff ) TYPE(CRTM_RTSolution_type), INTENT(IN) :: rts1, rts2 TYPE(CRTM_RTSolution_type) :: rtsdiff INTEGER :: k ! Check input ! ...If input structure association status different, do nothing IF ( CRTM_RTSolution_Associated(rts1) .NEQV. CRTM_RTSolution_Associated(rts2) ) RETURN ! ...If input structure for different sensors, do nothing IF ( (rts1%Sensor_ID /= rts2%Sensor_ID ) .AND. & (rts1%WMO_Satellite_ID /= rts2%WMO_Satellite_ID ) .AND. & (rts1%WMO_Sensor_ID /= rts2%WMO_Sensor_ID ) .AND. & (rts1%Sensor_Channel /= rts2%Sensor_Channel ) ) RETURN ! Copy the first structure rtsdiff = rts1 ! And subtract the second one's components from it ! ...Handle RT_Algorithm_Name rtsdiff%RT_Algorithm_Name = 'Subtraction' ! ...The scalar values rtsdiff%SOD = rtsdiff%SOD - rts2%SOD rtsdiff%Surface_Emissivity = rtsdiff%Surface_Emissivity - rts2%Surface_Emissivity rtsdiff%Surface_Reflectivity = rtsdiff%Surface_Reflectivity - rts2%Surface_Reflectivity rtsdiff%Up_Radiance = rtsdiff%Up_Radiance - rts2%Up_Radiance rtsdiff%Down_Radiance = rtsdiff%Down_Radiance - rts2%Down_Radiance rtsdiff%Down_Solar_Radiance = rtsdiff%Down_Solar_Radiance - rts2%Down_Solar_Radiance rtsdiff%Surface_Planck_Radiance = rtsdiff%Surface_Planck_Radiance - rts2%Surface_Planck_Radiance rtsdiff%Total_Cloud_Cover = rtsdiff%Total_Cloud_Cover - rts2%Total_Cloud_Cover rtsdiff%R_clear = rtsdiff%R_clear - rts2%R_clear rtsdiff%Tb_clear = rtsdiff%Tb_clear - rts2%Tb_clear rtsdiff%Radiance = rtsdiff%Radiance - rts2%Radiance rtsdiff%Brightness_Temperature = rtsdiff%Brightness_Temperature - rts2%Brightness_Temperature ! ...The arrays (which may or may not be allocated) IF ( CRTM_RTSolution_Associated(rts1) .AND. CRTM_RTSolution_Associated(rts2) ) THEN k = rts1%n_Layers rtsdiff%Upwelling_Overcast_Radiance(1:k) = rtsdiff%Upwelling_Overcast_Radiance(1:k) - & rts2%Upwelling_Overcast_Radiance(1:k) rtsdiff%Upwelling_Radiance(1:k) = rtsdiff%Upwelling_Radiance(1:k) - & rts2%Upwelling_Radiance(1:k) rtsdiff%Layer_Optical_Depth(1:k) = rtsdiff%Layer_Optical_Depth(1:k) - & rts2%Layer_Optical_Depth(1:k) END IF END FUNCTION CRTM_RTSolution_Subtract !-------------------------------------------------------------------------------- ! ! NAME: ! CRTM_RTSolution_Exponent ! ! PURPOSE: ! Elemental utility function to raise the components of a CRTM RTSolution ! object to the supplied integer power ! ! Used to compute RTSolution statistics ! ! CALLING SEQUENCE: ! rts_power = CRTM_RTSolution_Exponent( rts, power ) ! ! OBJECTS: ! rts: RTSolution structure which is to have its members values ! raised to an integer power. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(IN) ! ! INPUTS: ! power: Exponent power to be used. ! UNITS: N/A ! TYPE: INRTGER ! DIMENSION: Same as input rts object ! ATTRIBUTES: INTENT(IN) ! ! FUNCTION RESULT: ! rts_power: RTSolution structure containing the exponent result. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Same as input rts object ! !-------------------------------------------------------------------------------- ELEMENTAL FUNCTION CRTM_RTSolution_Exponent( rts, power ) RESULT( rts_power ) TYPE(CRTM_RTSolution_type), INTENT(IN) :: rts INTEGER , INTENT(IN) :: power TYPE(CRTM_RTSolution_type) :: rts_power INTEGER :: k ! Copy the structure rts_power = rts ! Raise the components to the supplied power ! ...Handle RT_Algorithm_Name rts_power%RT_Algorithm_Name = 'Exponent' ! ...The scalar values rts_power%SOD = (rts_power%SOD )**power rts_power%Surface_Emissivity = (rts_power%Surface_Emissivity )**power rts_power%Surface_Reflectivity = (rts_power%Surface_Reflectivity )**power rts_power%Up_Radiance = (rts_power%Up_Radiance )**power rts_power%Down_Radiance = (rts_power%Down_Radiance )**power rts_power%Down_Solar_Radiance = (rts_power%Down_Solar_Radiance )**power rts_power%Surface_Planck_Radiance = (rts_power%Surface_Planck_Radiance)**power rts_power%Total_Cloud_Cover = (rts_power%Total_Cloud_Cover )**power rts_power%R_clear = (rts_power%R_clear )**power rts_power%Tb_clear = (rts_power%Tb_clear )**power rts_power%Radiance = (rts_power%Radiance )**power rts_power%Brightness_Temperature = (rts_power%Brightness_Temperature )**power ! ...The arrays (which may or may not be allocated) IF ( CRTM_RTSolution_Associated(rts) ) THEN k = rts%n_Layers rts_power%Upwelling_Overcast_Radiance(1:k) = (rts_power%Upwelling_Overcast_Radiance(1:k))**power rts_power%Upwelling_Radiance(1:k) = (rts_power%Upwelling_Radiance(1:k) )**power rts_power%Layer_Optical_Depth(1:k) = (rts_power%Layer_Optical_Depth(1:k) )**power END IF END FUNCTION CRTM_RTSolution_Exponent !-------------------------------------------------------------------------------- ! ! NAME: ! CRTM_RTSolution_Normalise ! ! PURPOSE: ! Elemental utility function to normalise the components of ! a CRTM RTSolution object. ! ! Used to compute RTSolution statistics ! ! CALLING SEQUENCE: ! rts_normal = CRTM_RTSolution_Normalise( rts, factor ) ! ! OBJECTS: ! rts: RTSolution structure which is to have its members values ! normalised. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(IN) ! ! INPUTS: ! factor: Normalisation factor to be used. ! UNITS: N/A ! TYPE: REAL(fp) ! DIMENSION: Same as input rts object ! ATTRIBUTES: INTENT(IN) ! ! FUNCTION RESULT: ! rts_normal: RTSolution structure containing the normalised input ! object. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Same as input rts object ! !-------------------------------------------------------------------------------- ELEMENTAL FUNCTION CRTM_RTSolution_Normalise( rts, factor ) RESULT( rts_normal ) TYPE(CRTM_RTSolution_type), INTENT(IN) :: rts REAL(fp) , INTENT(IN) :: factor TYPE(CRTM_RTSolution_type) :: rts_normal INTEGER :: k ! Copy the structure rts_normal = rts ! Raise the components to the supplied normal ! ...Handle RT_Algorithm_Name rts_normal%RT_Algorithm_Name = 'Normalise' ! ...The scalar values rts_normal%SOD = rts_normal%SOD /factor rts_normal%Surface_Emissivity = rts_normal%Surface_Emissivity /factor rts_normal%Surface_Reflectivity = rts_normal%Surface_Reflectivity /factor rts_normal%Up_Radiance = rts_normal%Up_Radiance /factor rts_normal%Down_Radiance = rts_normal%Down_Radiance /factor rts_normal%Down_Solar_Radiance = rts_normal%Down_Solar_Radiance /factor rts_normal%Surface_Planck_Radiance = rts_normal%Surface_Planck_Radiance/factor rts_normal%Total_Cloud_Cover = rts_normal%Total_Cloud_Cover /factor rts_normal%R_clear = rts_normal%R_clear /factor rts_normal%Tb_clear = rts_normal%Tb_clear /factor rts_normal%Radiance = rts_normal%Radiance /factor rts_normal%Brightness_Temperature = rts_normal%Brightness_Temperature /factor ! ...The arrays (which may or may not be allocated) IF ( CRTM_RTSolution_Associated(rts) ) THEN k = rts%n_Layers rts_normal%Upwelling_Overcast_Radiance(1:k) = rts_normal%Upwelling_Overcast_Radiance(1:k)/factor rts_normal%Upwelling_Radiance(1:k) = rts_normal%Upwelling_Radiance(1:k) /factor rts_normal%Layer_Optical_Depth(1:k) = rts_normal%Layer_Optical_Depth(1:k) /factor END IF END FUNCTION CRTM_RTSolution_Normalise !-------------------------------------------------------------------------------- ! ! NAME: ! CRTM_RTSolution_Sqrt ! ! PURPOSE: ! Elemental utility function to compute the SQRT() of the components of ! a CRTM RTSolution object. ! ! Used to compute RTSolution statistics ! ! CALLING SEQUENCE: ! rts_sqrt = CRTM_RTSolution_Sqrt( rts ) ! ! OBJECTS: ! rts: RTSolution structure which is to have the square root ! taken of its member's vales. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(IN) ! ! FUNCTION RESULT: ! rts_sqrt: RTSolution structure containing the square root of the ! input object. ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Same as input rts object ! !-------------------------------------------------------------------------------- ELEMENTAL FUNCTION CRTM_RTSolution_Sqrt( rts ) RESULT( rts_sqrt ) TYPE(CRTM_RTSolution_type), INTENT(IN) :: rts TYPE(CRTM_RTSolution_type) :: rts_sqrt INTEGER :: k ! Copy the structure rts_sqrt = rts ! Raise the components to the supplied normal ! ...Handle RT_Algorithm_Name rts_sqrt%RT_Algorithm_Name = 'Square root' ! ...The scalar values rts_sqrt%SOD = SQRT(rts_sqrt%SOD ) rts_sqrt%Surface_Emissivity = SQRT(rts_sqrt%Surface_Emissivity ) rts_sqrt%Surface_Reflectivity = SQRT(rts_sqrt%Surface_Reflectivity ) rts_sqrt%Up_Radiance = SQRT(rts_sqrt%Up_Radiance ) rts_sqrt%Down_Radiance = SQRT(rts_sqrt%Down_Radiance ) rts_sqrt%Down_Solar_Radiance = SQRT(rts_sqrt%Down_Solar_Radiance ) rts_sqrt%Surface_Planck_Radiance = SQRT(rts_sqrt%Surface_Planck_Radiance) rts_sqrt%Total_Cloud_Cover = SQRT(rts_sqrt%Total_Cloud_Cover ) rts_sqrt%R_clear = SQRT(rts_sqrt%R_clear ) rts_sqrt%Tb_clear = SQRT(rts_sqrt%Tb_clear ) rts_sqrt%Radiance = SQRT(rts_sqrt%Radiance ) rts_sqrt%Brightness_Temperature = SQRT(rts_sqrt%Brightness_Temperature ) ! ...The arrays (which may or may not be allocated) IF ( CRTM_RTSolution_Associated(rts) ) THEN k = rts%n_Layers rts_sqrt%Upwelling_Overcast_Radiance(1:k) = SQRT(rts_sqrt%Upwelling_Overcast_Radiance(1:k)) rts_sqrt%Upwelling_Radiance(1:k) = SQRT(rts_sqrt%Upwelling_Radiance(1:k) ) rts_sqrt%Layer_Optical_Depth(1:k) = SQRT(rts_sqrt%Layer_Optical_Depth(1:k) ) END IF END FUNCTION CRTM_RTSolution_Sqrt ! ! NAME: ! Read_Record ! ! PURPOSE: ! Utility function to read a single RTSolution data record ! FUNCTION Read_Record( & fid, & ! Input rts) & ! Output RESULT( err_stat ) ! Arguments INTEGER, INTENT(IN) :: fid TYPE(CRTM_RTSolution_type), INTENT(OUT) :: rts ! Function result INTEGER :: err_stat ! Function parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_RTSolution_ReadFile(Record)' ! Function variables CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg INTEGER :: io_stat INTEGER :: n_layers ! Set up err_stat = SUCCESS ! Read the dimensions READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) n_layers IF ( io_stat /= 0 ) THEN msg = 'Error reading dimensions - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF ! Allocate the RTSolution structure if necessary IF ( n_layers > 0 ) THEN CALL CRTM_RTSolution_Create( rts, n_layers ) IF ( .NOT. CRTM_RTSolution_Associated( rts ) ) THEN msg = 'Error creating output object.' CALL Read_Record_Cleanup(); RETURN END IF END IF ! Read the sensor info READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) & rts%Sensor_Id , & rts%WMO_Satellite_Id, & rts%WMO_Sensor_Id , & rts%Sensor_Channel IF ( io_stat /= 0 ) THEN msg = 'Error reading sensor information - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF ! Read the RT algorithm name READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) & rts%RT_Algorithm_Name IF ( io_stat /= 0 ) THEN msg = 'Error reading RT Algorithm Name'//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF ! Read the forward radiative transfer intermediate results READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) & rts%SOD , & rts%Surface_Emissivity , & rts%Surface_Reflectivity , & rts%Up_Radiance , & rts%Down_Radiance , & rts%Down_Solar_Radiance , & rts%Surface_Planck_Radiance, & rts%Total_Cloud_Cover , & rts%R_clear , & rts%Tb_clear IF ( io_stat /= 0 ) THEN msg = 'Error reading scalar intermediate results - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF IF ( n_Layers > 0 ) THEN READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) & rts%Upwelling_Overcast_Radiance , & rts%Upwelling_Radiance, & rts%Layer_Optical_Depth IF ( io_stat /= 0 ) THEN msg = 'Error reading array intermediate results - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF END IF ! Read the radiative transfer results READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) & rts%Radiance , & rts%Brightness_Temperature IF ( io_stat /= 0 ) THEN msg = 'Error reading result data - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN END IF CONTAINS SUBROUTINE Read_Record_Cleanup() CALL CRTM_RTSolution_Destroy( rts ) CLOSE( fid,IOSTAT=io_stat,IOMSG=io_msg ) IF ( io_stat /= SUCCESS ) & msg = TRIM(msg)//'; Error closing file during error cleanup - '//TRIM(io_msg) err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END SUBROUTINE Read_Record_Cleanup END FUNCTION Read_Record ! ! NAME: ! Write_Record ! ! PURPOSE: ! Function to write a single RTSolution data record ! FUNCTION Write_Record( & fid, & ! Input rts) & ! Input RESULT( err_stat ) ! Arguments INTEGER, INTENT(IN) :: fid TYPE(CRTM_RTSolution_type), INTENT(IN) :: rts ! Function result INTEGER :: err_stat ! Function parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_RTSolution_WriteFile(Record)' ! Function variables CHARACTER(ML) :: msg CHARACTER(ML) :: io_msg INTEGER :: io_stat ! Set up err_stat = SUCCESS ! Write the data dimensions WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) rts%n_Layers IF ( io_stat /= 0 ) THEN msg = 'Error writing dimensions - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF ! Write the sensor info WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) & rts%Sensor_Id , & rts%WMO_Satellite_Id, & rts%WMO_Sensor_Id , & rts%Sensor_Channel IF ( io_stat /= 0 ) THEN msg = 'Error writing sensor information - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF ! Write the RT algorithm name WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) & rts%RT_Algorithm_Name IF ( io_stat /= 0 ) THEN msg = 'Error writing RT Algorithm Name'//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF ! Write the forward radiative transfer intermediate results WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) & rts%SOD , & rts%Surface_Emissivity , & rts%Surface_Reflectivity , & rts%Up_Radiance , & rts%Down_Radiance , & rts%Down_Solar_Radiance , & rts%Surface_Planck_Radiance, & rts%Total_Cloud_Cover , & rts%R_clear , & rts%Tb_clear IF ( io_stat /= 0 ) THEN msg = 'Error writing scalar intermediate results - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF IF ( rts%n_Layers > 0 ) THEN WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) & rts%Upwelling_Overcast_Radiance , & rts%Upwelling_Radiance, & rts%Layer_Optical_Depth IF ( io_stat /= 0 ) THEN msg = 'Error writing array intermediate results - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF END IF ! Write the radiative transfer results WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) & rts%Radiance , & rts%Brightness_Temperature IF ( io_stat /= 0 ) THEN msg = 'Error writing result data - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN END IF CONTAINS SUBROUTINE Write_Record_Cleanup() CLOSE( fid,STATUS=WRITE_ERROR_STATUS,IOSTAT=io_stat,IOMSG=io_msg ) IF ( io_stat /= 0 ) & msg = TRIM(msg)//'; Error closing file during error cleanup - '//TRIM(io_msg) err_stat = FAILURE CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END SUBROUTINE Write_Record_Cleanup END FUNCTION Write_Record END MODULE CRTM_RTSolution_Define