diff --git a/Makefile b/Makefile index 78299f80e2..73d3d228c4 100644 --- a/Makefile +++ b/Makefile @@ -137,7 +137,7 @@ all_wrfvar : $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" ext $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" toolsdir if [ $(CRTM) -ne 0 ] ; then \ - (cd var/external/crtm_2.2.3; $(MAKE) $(J)) ; \ + (cd var/external/crtm_2.3.0; $(MAKE) $(J)) ; \ fi if [ $(BUFR) ] ; then \ (cd var/external/bufr; \ diff --git a/compile b/compile index 0d0f171093..1568a7e9e0 100755 --- a/compile +++ b/compile @@ -335,8 +335,8 @@ else setenv BUFR 1 endif setenv CRTM_CPP "-DCRTM" - setenv CRTM_LIB "-L../external/crtm_2.2.3/libsrc -lCRTM" - setenv CRTM_SRC "-I../external/crtm_2.2.3/libsrc" + setenv CRTM_LIB "-L../external/crtm_2.3.0/libsrc -lCRTM" + setenv CRTM_SRC "-I../external/crtm_2.3.0/libsrc" #setenv SFC_CRTM `grep '^SFC' configure.wrf | awk '{print $3}' | sed -e 's/\// /g' | awk '{print $NF}'` #setenv ABI_CRTM `grep '^SFC' configure.wrf | sed -n 's/.*\(\-m[0-9]\{2\}\).*/\1/p'` setenv CRTM 1 @@ -349,37 +349,6 @@ else setenv CRTM_SRC " " setenv CRTM 0 endif - set RTTOV = ( `grep "^RTTOVPATH" configure.wrf | cut -d"=" -f2-` ) - if ( $RTTOV == "" ) then - setenv RTTOV_LIB " " - setenv RTTOV_SRC " " - unsetenv RTTOV - else - echo " " - echo "Compiling with RTTOV libraries in:" - echo $RTTOV - echo " " - if ( ! $?BUFR ) then - echo " " - echo "BUFR library is needed for radiance data ingest." - echo "setting BUFR=1" - echo " " - setenv BUFR 1 - endif - if ( -e ${RTTOV}/lib/librttov11.1.0_main.a ) then - setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov11.1.0_coef_io -lrttov11.1.0_emis_atlas -lrttov11.1.0_main" - else if ( -e ${RTTOV}/lib/librttov11.2.0_main.a ) then - setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov11.2.0_coef_io -lrttov11.2.0_emis_atlas -lrttov11.2.0_main" - else if ( -e ${RTTOV}/lib/librttov11_main.a ) then - setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov11_coef_io -lrttov11_emis_atlas -lrttov11_main" - else - echo "Can not find a compatible RTTOV library! Please ensure that your RTTOV build was successful," - echo "your 'RTTOV' environment variable is set correctly, and you are using a supported version of RTTOV." - echo "Currently supported versions are 11.1, 11.2, and 11.3" - exit 1 - endif - setenv RTTOV_SRC "-I${RTTOV}/include -I${RTTOV}/mod" - endif set hdf5path = ( `grep "^HDF5PATH" configure.wrf | cut -d"=" -f2-` ) if ( $hdf5path == "" ) then setenv HDF5_INC "" @@ -392,6 +361,42 @@ else setenv HDF5_INC "-I${hdf5path}/include" setenv HDF5 1 endif + set RTTOV = ( `grep "^RTTOVPATH" configure.wrf | cut -d"=" -f2-` ) + if ( $RTTOV == "" ) then + setenv RTTOV_LIB " " + setenv RTTOV_SRC " " + unsetenv RTTOV + else + if ( $hdf5path == "" ) then + echo "As of version 12.1 of RTTOV, WRFDA requires HDF5 in order utilize the RTTOV library." + echo "RTTOV emissivity atlas files are now provided only in HDF5 format." + echo "Please supply an HDF5 path prior to configure or unset RTTOV." + exit 1 + else + echo " " + echo "Compiling with RTTOV libraries in:" + echo $RTTOV + echo " " + if ( ! $?BUFR ) then + echo " " + echo "BUFR library is needed for radiance data ingest." + echo "setting BUFR=1" + echo " " + setenv BUFR 1 + endif + if ( -e ${RTTOV}/lib/librttov12_main.a ) then + setenv RTTOV_LIB "-L${hdf5path}/lib -lhdf5hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -L${RTTOV}/lib -lrttov12_coef_io -lrttov12_emis_atlas -lrttov12_main -lrttov12_hdf" + else + echo "Can not find a compatible RTTOV library! Please ensure that your RTTOV build was successful," + echo "your 'RTTOV' environment variable is set correctly, and you are using a supported version of RTTOV." + echo "Current supported version(s): 12.1" + + exit 1 + endif + setenv RTTOV_SRC "-I${RTTOV}/include -I${RTTOV}/mod" + endif + endif + if ( $?CLOUD_CV ) then setenv CLOUD_CV_CPP "-DCLOUD_CV" else diff --git a/phys/module_sf_noahmpdrv.F b/phys/module_sf_noahmpdrv.F index 53226c103d..9c986d9ad2 100644 --- a/phys/module_sf_noahmpdrv.F +++ b/phys/module_sf_noahmpdrv.F @@ -979,7 +979,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN,XLAT,XLONG, & ! IN RB = MAX(RB, 0.0) ! New Calculation of total Canopy/Stomatal Conductance Based on Bonan et al. (2011) ! -- Inverse of Canopy Resistance (below) - IF(RSSUN .le. 0.0 .and. RSSHA .le. 0.0) THEN + IF(RSSUN .le. 0.0 .or. RSSHA .le. 0.0 .or. LAISUN .eq. 0.0 .or. LAISHA .eq. 0.0) THEN RS (I,J) = 0.0 ELSE RS (I,J) = ((1.0/(RSSUN+RB)*LAISUN) + ((1.0/(RSSHA+RB))*LAISHA)) diff --git a/var/da/da_radiance/da_get_innov_vector_rttov.inc b/var/da/da_radiance/da_get_innov_vector_rttov.inc index 17d6b309c7..ac78014a08 100644 --- a/var/da/da_radiance/da_get_innov_vector_rttov.inc +++ b/var/da/da_radiance/da_get_innov_vector_rttov.inc @@ -22,7 +22,6 @@ subroutine da_get_innov_vector_rttov (it, grid, ob, iv) integer :: i, j, k ! Index dimension. integer :: nlevels ! Number of obs levels. integer :: nchanprof, errorstatus - integer :: ir_atlas_version, mw_atlas_version character(len=256) :: atlas_path real*8 :: seap, icep, lndp, snop @@ -42,7 +41,7 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) type(aux_vars_type), allocatable :: aux_vars(:) type(rttov_chanprof), allocatable :: chanprof(:) - type(profile_type), allocatable :: profiles(:) + type(rttov_profile), allocatable :: profiles(:) ! variables for computing clwp real, allocatable :: dpf(:,:), clw(:,:), pf(:,:) @@ -203,9 +202,6 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) if ( rttov_emis_atlas_ir > 0 .or. rttov_emis_atlas_mw > 0 ) then ! set up emissivity atlas atlas_path = 'emis_data/' - ir_atlas_version = 100 - mw_atlas_version = 100 ! TELSEM - if ( rttov_emis_atlas_mw == 2 ) mw_atlas_version = 200 ! CNRW write(unit=message(1),fmt='(A,A)') & 'Setting up emissivity atlas for instrument ', trim(iv%instid(inst)%rttovid_string) call da_message(message(1:1)) @@ -213,10 +209,12 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) errorstatus, & ! out opts(inst), & ! in grid%start_month, & ! in - coefs(inst), & ! in + atlas_type(inst), & ! in + atlas, & ! inout + atlas_id(inst), & ! in, optional path = trim(atlas_path), & ! in, optional - ir_atlas_ver = ir_atlas_version, & ! in, optional - mw_atlas_ver = mw_atlas_version) ! in, optional + coefs = coefs(inst)) ! in + if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"failure in setting up emissivity atlas"/)) @@ -234,11 +232,11 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) ! latitude, longitude, surftype are used for retreiving emis from atlas ! zenangle is used by MW emmisivity atlas ! snow_frac is used only by IR emmisivity atlas - profiles(n-n1+1)%latitude = iv%instid(inst)%info%lat(1,n) - profiles(n-n1+1)%longitude = iv%instid(inst)%info%lon(1,n) - profiles(n-n1+1)%zenangle = iv%instid(inst)%satzen(n) - profiles(n-n1+1)%skin%surftype = iv%instid(inst)%surftype(n) - profiles(n-n1+1)%snow_frac = iv%instid(inst)%snow_frac(n) + profiles(n-n1+1)%latitude = iv%instid(inst)%info%lat(1,n) + profiles(n-n1+1)%longitude = iv%instid(inst)%info%lon(1,n) + profiles(n-n1+1)%zenangle = iv%instid(inst)%satzen(n) + profiles(n-n1+1)%skin%surftype = iv%instid(inst)%surftype(n) + profiles(n-n1+1)%skin%snow_fraction = iv%instid(inst)%snow_frac(n) end do ! Retrieve values from atlas @@ -248,6 +246,7 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) chanprof, & ! in profiles, & ! in coefs(inst), & ! in + atlas, &! in emissivity=emissivity(:)%emis_in ) ! out if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & @@ -377,7 +376,7 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) deallocate (emissivity) if ( rttov_emis_atlas_ir > 0 .or. rttov_emis_atlas_mw > 0 ) then - call rttov_deallocate_emis_atlas(coefs(inst)) + call rttov_deallocate_emis_atlas(atlas) end if end do ! end loop for sensor diff --git a/var/da/da_radiance/da_radiance.f90 b/var/da/da_radiance/da_radiance.f90 index cb98c45e05..0bbc532488 100644 --- a/var/da/da_radiance/da_radiance.f90 +++ b/var/da/da_radiance/da_radiance.f90 @@ -18,8 +18,8 @@ module da_radiance init_constants_derived, & rttov_platform_name, rttov_inst_name, crtm_sensor_name ! names used by both RTTOV and CRTM #ifdef RTTOV - use module_radiance, only : coefs, rttov_coefs, profile_type, radiance_type, & - transmission_type,errorstatus_success,gas_id_watervapour,rttov_emissivity + use module_radiance, only : coefs, rttov_coefs, rttov_profile, rttov_radiance, & + rttov_transmission,errorstatus_success,gas_id_watervapour,rttov_emissivity #endif #ifdef CRTM use module_radiance, only : crtm_channelinfo_type, crtm_platform_name, crtm_init, & diff --git a/var/da/da_radiance/da_rttov.f90 b/var/da/da_radiance/da_rttov.f90 index 9b85c271ad..9150a87a4e 100644 --- a/var/da/da_radiance/da_rttov.f90 +++ b/var/da/da_radiance/da_rttov.f90 @@ -12,10 +12,11 @@ module da_rttov i_kind,r_kind, r_double, & one, zero, three,deg2rad, q2ppmv, & coefs, opts,opts_rt_ir, rttov_inst_name - use module_radiance, only : rttov_options, rttov_opts_rt_ir, rttov_coefs, profile_type, & - transmission_type, radiance_type, rttov_chanprof, & + use module_radiance, only : rttov_options, rttov_opts_rt_ir, rttov_coefs, rttov_profile, & + rttov_transmission, rttov_radiance, rttov_chanprof, & jpim, jprb, errorstatus_success, errorstatus_fatal, gas_id_watervapour, & - sensor_id_ir, sensor_id_mw, sensor_id_hi,rttov_emissivity + atlas, atlas_type, atlas_id, atlas_type_ir, atlas_type_mw, & + sensor_id_ir, sensor_id_mw, sensor_id_hi, sensor_id_po, rttov_emissivity use da_control, only : max_ob_levels,missing_r, & v_interp_p, v_interp_h, tovs_batch, gravity, & diff --git a/var/da/da_radiance/da_rttov_ad.inc b/var/da/da_radiance/da_rttov_ad.inc index ba790fbcdd..e9a31cd457 100644 --- a/var/da/da_radiance/da_rttov_ad.inc +++ b/var/da/da_radiance/da_rttov_ad.inc @@ -20,7 +20,7 @@ subroutine da_rttov_ad( inst, nchanl, nprofiles, con_vars, & ! RTTOV input parameters type (rttov_chanprof), allocatable :: chanprof(:) - type (profile_type), allocatable :: profiles(:), profiles_ad(:) + type (rttov_profile), allocatable :: profiles(:), profiles_ad(:) type (rttov_emissivity), allocatable :: emissivity(:), emissivity_ad(:) logical, allocatable :: calcemis(:) @@ -28,8 +28,8 @@ subroutine da_rttov_ad( inst, nchanl, nprofiles, con_vars, & integer :: errorstatus ! RTTOV inout parameters - type (radiance_type) :: radiance, radiance_ad - type (transmission_type) :: transmission, transmission_ad + type (rttov_radiance) :: radiance, radiance_ad + type (rttov_transmission) :: transmission, transmission_ad call da_trace_entry("da_rttov_ad") @@ -94,7 +94,7 @@ subroutine da_rttov_ad( inst, nchanl, nprofiles, con_vars, & profiles(n) % cloud(:,:) = 0.0 profiles(n) % cfrac(:) = 0.0 profiles(n) % idg = 1 - profiles(n) % ish = 1 + profiles(n) % ice_scheme = 1 end if profiles(n) % skin % surftype = aux_vars (n) % surftype @@ -106,7 +106,8 @@ subroutine da_rttov_ad( inst, nchanl, nprofiles, con_vars, & end if end if - if ( coefs(inst)%coef%id_sensor == sensor_id_mw ) then + if ( coefs(inst)%coef%id_sensor == sensor_id_mw .or. & + coefs(inst)%coef%id_sensor == sensor_id_po ) then if ( profiles(n) % skin % surftype == 2 ) then profiles(n) % skin % fastem (1) = 2.2 profiles(n) % skin % fastem (2) = 3.7 @@ -164,7 +165,7 @@ subroutine da_rttov_ad( inst, nchanl, nprofiles, con_vars, & call rttov_alloc_transmission( & & errorstatus, & & transmission, & - & nlevels-1, & + & nlevels, & & nchanprof, & & asw, & & init = .true. ) @@ -177,7 +178,7 @@ subroutine da_rttov_ad( inst, nchanl, nprofiles, con_vars, & call rttov_alloc_transmission( & & errorstatus, & & transmission_ad, & - & nlevels-1, & + & nlevels, & & nchanprof, & & asw, & & init = .true. ) @@ -192,7 +193,7 @@ subroutine da_rttov_ad( inst, nchanl, nprofiles, con_vars, & & errorstatus, & & nchanprof, & & radiance, & - & nlevels-1, & + & nlevels, & & asw, & & init=.true. ) if ( errorstatus /= errorstatus_success ) then @@ -205,7 +206,7 @@ subroutine da_rttov_ad( inst, nchanl, nprofiles, con_vars, & & errorstatus, & & nchanprof, & & radiance_ad, & - & nlevels-1, & + & nlevels, & & asw, & & init=.true. ) if ( errorstatus /= errorstatus_success ) then @@ -218,11 +219,13 @@ subroutine da_rttov_ad( inst, nchanl, nprofiles, con_vars, & radiance_ad % clear ((n-1)*nchanl+1:n*nchanl) = 0.0 end do - if (coefs(inst)%coef%id_sensor == 1 .or. coefs(inst)%coef%id_sensor == 3) then ! infrared sensor + if ( coefs(inst)%coef%id_sensor == sensor_id_ir .or. & + coefs(inst)%coef%id_sensor == sensor_id_hi ) then ! infrared sensor calcemis(1:nchanprof) = .true. emissivity(1:nchanprof)%emis_in = 0.0 emissivity_ad(1:nchanprof)%emis_in = 0.0 - else if (coefs(inst)%coef%id_sensor == 2) then ! microwave sensor + else if ( coefs(inst)%coef%id_sensor == sensor_id_mw .or. & + coefs(inst)%coef%id_sensor == sensor_id_po ) then ! microwave sensor do n = 1, nprofiles if ( profiles(n) % skin % surftype == 1) then ! sea calcemis((n-1)*nchanl+1:n*nchanl) = .true. @@ -291,24 +294,24 @@ subroutine da_rttov_ad( inst, nchanl, nprofiles, con_vars, & asw = 0 ! deallocation ! deallocate radiance arrays - call rttov_alloc_rad (errorstatus,nchanprof,radiance,nlevels-1,asw) + call rttov_alloc_rad (errorstatus,nchanprof,radiance,nlevels,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"radiance deallocation error"/)) end if - call rttov_alloc_rad (errorstatus,nchanprof,radiance_ad,nlevels-1,asw) + call rttov_alloc_rad (errorstatus,nchanprof,radiance_ad,nlevels,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"radiance AD deallocation error"/)) end if ! deallocate transmission arrays - call rttov_alloc_transmission (errorstatus,transmission,nlevels-1,nchanprof,asw) + call rttov_alloc_transmission (errorstatus,transmission,nlevels,nchanprof,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"transmission deallocation error"/)) end if - call rttov_alloc_transmission (errorstatus,transmission_ad,nlevels-1,nchanprof,asw) + call rttov_alloc_transmission (errorstatus,transmission_ad,nlevels,nchanprof,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"transmission AD deallocation error"/)) diff --git a/var/da/da_radiance/da_rttov_direct.inc b/var/da/da_radiance/da_rttov_direct.inc index bc94a7b4b4..0af155f5e4 100644 --- a/var/da/da_radiance/da_rttov_direct.inc +++ b/var/da/da_radiance/da_rttov_direct.inc @@ -24,15 +24,15 @@ subroutine da_rttov_direct(inst, nchanl, nprofiles, nlevels, & ! RTTOV input parameters type (rttov_chanprof), allocatable :: chanprof(:) - type (profile_type), allocatable :: profiles(:) + type (rttov_profile), allocatable :: profiles(:) logical, allocatable :: calcemis(:) ! RTTOV out parameters integer :: errorstatus ! RTTOV inout parameters - type (radiance_type) :: radiance - type (transmission_type) :: transmission + type (rttov_radiance) :: radiance + type (rttov_transmission) :: transmission call da_trace_entry("da_rttov_direct") @@ -79,7 +79,7 @@ subroutine da_rttov_direct(inst, nchanl, nprofiles, nlevels, & profiles(n) % cloud(:,:) = 0.0 profiles(n) % cfrac(:) = 0.0 profiles(n) % idg = 1 - profiles(n) % ish = 1 + profiles(n) % ice_scheme = 1 end if profiles(n)% skin % surftype = aux_vars(n) % surftype @@ -93,7 +93,8 @@ subroutine da_rttov_direct(inst, nchanl, nprofiles, nlevels, & ! for microwave channels, land/sea-ce emissivity is computed ! from coefs in prof%skin%fastem, if calcemis = True - if ( coefs(inst)%coef%id_sensor == sensor_id_mw ) then + if ( coefs(inst)%coef%id_sensor == sensor_id_mw .or. & + coefs(inst)%coef%id_sensor == sensor_id_po ) then if ( profiles(n) % skin % surftype == 2 ) then ! sea-ice profiles(n) % skin % fastem (1) = 2.2 profiles(n) % skin % fastem (2) = 3.7 @@ -143,7 +144,7 @@ subroutine da_rttov_direct(inst, nchanl, nprofiles, nlevels, & & errorstatus, & & nchanprof, & & radiance, & - & nlevels-1, & + & nlevels, & & asw, & & init = .true. ) if ( errorstatus /= errorstatus_success ) then @@ -162,7 +163,7 @@ subroutine da_rttov_direct(inst, nchanl, nprofiles, nlevels, & call rttov_alloc_transmission( & & errorstatus, & & transmission, & - & nlevels-1, & + & nlevels, & & nchanprof, & & asw, & & init = .true. ) @@ -226,14 +227,14 @@ subroutine da_rttov_direct(inst, nchanl, nprofiles, nlevels, & deallocate (chanprof) asw = 0 ! deallocate radiance arrays - call rttov_alloc_rad (errorstatus,nchanprof,radiance,nlevels-1,asw) + call rttov_alloc_rad (errorstatus,nchanprof,radiance,nlevels,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"radiance deallocation error"/)) end if asw = 0 ! deallocate transmission arrays - call rttov_alloc_transmission (errorstatus,transmission,nlevels-1,nchanprof,asw) + call rttov_alloc_transmission (errorstatus,transmission,nlevels,nchanprof,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"transmission deallocation error"/)) diff --git a/var/da/da_radiance/da_rttov_init.inc b/var/da/da_radiance/da_rttov_init.inc index 7c783ebfe0..6728b7adf3 100644 --- a/var/da/da_radiance/da_rttov_init.inc +++ b/var/da/da_radiance/da_rttov_init.inc @@ -39,6 +39,7 @@ subroutine da_rttov_init(iv,ob,nsensor,nchan) ! local variables !---------------- integer :: mxchn + integer(jpim) :: id_sensor if (trace_use) call da_trace_entry("da_rttov_init") @@ -55,6 +56,10 @@ subroutine da_rttov_init(iv,ob,nsensor,nchan) allocate (opts_rt_ir(nsensor)) allocate (sensor(3,nsensor)) allocate (coefs_channels(mxchn,nsensor)) + if ( rttov_emis_atlas_ir > 0 .or. rttov_emis_atlas_mw > 0 ) then + allocate (atlas_type(nsensor)) + allocate (atlas_id(nsensor)) + end if sensor (1,1:nsensor) = rtminit_platform (1:nsensor) sensor (2,1:nsensor) = rtminit_satid (1:nsensor) @@ -129,6 +134,19 @@ subroutine da_rttov_init(iv,ob,nsensor,nchan) iv%instid(n)%nlevels = coefs(n)%coef%nlevels + if ( rttov_emis_atlas_ir > 0 .or. rttov_emis_atlas_mw > 0 ) then + id_sensor = coefs(n)%coef%id_sensor + atlas_type(n) = 0 + if( id_sensor == sensor_id_ir .OR. id_sensor == sensor_id_hi ) then + atlas_type(n) = atlas_type_ir +! atlas_id(n) = uwiremis_atlas_id !(Previous WRFDA default) + atlas_id(n) = rttov_emis_atlas_ir !(namelist variable, can either be 1=uwiremis or 2=camel) + end if + if( id_sensor == sensor_id_mw .OR. id_sensor == sensor_id_po ) then + atlas_type(n) = atlas_type_mw + atlas_id(n) = rttov_emis_atlas_mw !(namelist variable, can either be 1=TELSEM2 or 2=CNRW) + end if + end if end do deallocate (sensor) diff --git a/var/da/da_radiance/da_rttov_k.inc b/var/da/da_radiance/da_rttov_k.inc index 432ce6f7b0..975853109f 100644 --- a/var/da/da_radiance/da_rttov_k.inc +++ b/var/da/da_radiance/da_rttov_k.inc @@ -24,7 +24,7 @@ subroutine da_rttov_k(inst, nchanl, nprofiles, nlevels, & ! RTTOV input parameters type (rttov_chanprof), allocatable :: chanprof(:) - type (profile_type), allocatable :: profiles(:), profiles_k(:) + type (rttov_profile), allocatable :: profiles(:), profiles_k(:) logical, allocatable :: calcemis(:) ! RTTOV out parameters @@ -32,8 +32,8 @@ subroutine da_rttov_k(inst, nchanl, nprofiles, nlevels, & ! RTTOV inout parameters type (rttov_emissivity), allocatable :: emissivity_k(:) - type (radiance_type) :: radiance, radiance_k - type (transmission_type) :: transmission, transmission_k + type (rttov_radiance) :: radiance, radiance_k + type (rttov_transmission) :: transmission, transmission_k call da_trace_entry("da_rttov_k") @@ -96,7 +96,7 @@ subroutine da_rttov_k(inst, nchanl, nprofiles, nlevels, & profiles(n) % cloud(:,:) = 0.0 profiles(n) % cfrac(:) = 0.0 profiles(n) % idg = 1 - profiles(n) % ish = 1 + profiles(n) % ice_scheme = 1 end if profiles(n)% skin % surftype = aux_vars(n) % surftype @@ -110,7 +110,8 @@ subroutine da_rttov_k(inst, nchanl, nprofiles, nlevels, & ! for microwave channels, land/sea-ce emissivity is computed ! from coefs in prof%skin%fastem, if calcemis = True - if ( coefs(inst)%coef%id_sensor == sensor_id_mw ) then + if ( coefs(inst)%coef%id_sensor == sensor_id_mw .or. & + coefs(inst)%coef%id_sensor == sensor_id_po ) then if ( profiles(n) % skin % surftype == 2 ) then profiles(n) % skin % fastem (1) = 2.2 profiles(n) % skin % fastem (2) = 3.7 @@ -167,7 +168,7 @@ subroutine da_rttov_k(inst, nchanl, nprofiles, nlevels, & & errorstatus, & & nchanprof, & & radiance, & - & nlevels-1, & + & nlevels, & & asw, & & init = .true. ) if ( errorstatus /= errorstatus_success ) then @@ -180,7 +181,7 @@ subroutine da_rttov_k(inst, nchanl, nprofiles, nlevels, & & errorstatus, & & nchanprof, & & radiance_k, & - & nlevels-1, & + & nlevels, & & asw, & & init = .true. ) if ( errorstatus /= errorstatus_success ) then @@ -193,7 +194,7 @@ subroutine da_rttov_k(inst, nchanl, nprofiles, nlevels, & call rttov_alloc_transmission( & & errorstatus, & & transmission, & - & nlevels-1, & + & nlevels, & & nchanprof, & & asw, & & init = .true. ) @@ -206,7 +207,7 @@ subroutine da_rttov_k(inst, nchanl, nprofiles, nlevels, & call rttov_alloc_transmission( & & errorstatus, & & transmission_k, & - & nlevels-1, & + & nlevels, & & nchanprof, & & asw, & & init = .true. ) @@ -290,24 +291,24 @@ subroutine da_rttov_k(inst, nchanl, nprofiles, nlevels, & asw = 0 ! deallocation ! deallocate radiance arrays - call rttov_alloc_rad (errorstatus,nchanprof,radiance,nlevels-1,asw) + call rttov_alloc_rad (errorstatus,nchanprof,radiance,nlevels,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"radiance deallocation error"/)) end if - call rttov_alloc_rad (errorstatus,nchanprof,radiance_k,nlevels-1,asw) + call rttov_alloc_rad (errorstatus,nchanprof,radiance_k,nlevels,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"radiance K deallocation error"/)) end if ! deallocate transmission arrays - call rttov_alloc_transmission (errorstatus,transmission,nlevels-1,nchanprof,asw) + call rttov_alloc_transmission (errorstatus,transmission,nlevels,nchanprof,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"transmission deallocation error"/)) end if - call rttov_alloc_transmission (errorstatus,transmission_k,nlevels-1,nchanprof,asw) + call rttov_alloc_transmission (errorstatus,transmission_k,nlevels,nchanprof,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"transmission K deallocation error"/)) diff --git a/var/da/da_radiance/da_rttov_tl.inc b/var/da/da_radiance/da_rttov_tl.inc index e8a7bfe63b..9dc4de9fcf 100644 --- a/var/da/da_radiance/da_rttov_tl.inc +++ b/var/da/da_radiance/da_rttov_tl.inc @@ -21,7 +21,7 @@ subroutine da_rttov_tl(inst, nchanl, nprofiles, con_vars, aux_vars, & ! RTTOV input parameters type (rttov_chanprof), allocatable :: chanprof(:) - type (profile_type), allocatable :: profiles(:), profiles_tl(:) + type (rttov_profile), allocatable :: profiles(:), profiles_tl(:) logical, allocatable :: calcemis(:) type (rttov_emissivity), allocatable :: emissivity(:), emissivity_tl(:) @@ -29,8 +29,8 @@ subroutine da_rttov_tl(inst, nchanl, nprofiles, con_vars, aux_vars, & integer :: errorstatus ! RTTOV inout parameters - type (radiance_type) :: radiance, radiance_tl - type (transmission_type) :: transmission, transmission_tl + type (rttov_radiance) :: radiance, radiance_tl + type (rttov_transmission) :: transmission, transmission_tl call da_trace_entry("da_rttov_tl") @@ -95,7 +95,7 @@ subroutine da_rttov_tl(inst, nchanl, nprofiles, con_vars, aux_vars, & profiles(n) % cloud(:,:) = 0.0 profiles(n) % cfrac(:) = 0.0 profiles(n) % idg = 1 - profiles(n) % ish = 1 + profiles(n) % ice_scheme = 1 end if profiles(n)% skin % surftype = aux_vars(n) % surftype @@ -107,7 +107,8 @@ subroutine da_rttov_tl(inst, nchanl, nprofiles, con_vars, aux_vars, & end if end if - if ( coefs(inst)%coef%id_sensor == sensor_id_mw ) then + if ( coefs(inst)%coef%id_sensor == sensor_id_mw .or. & + coefs(inst)%coef%id_sensor == sensor_id_po ) then if ( profiles(n) % skin % surftype == 2 ) then profiles(n) % skin % fastem (1) = 2.2 profiles(n) % skin % fastem (2) = 3.7 @@ -169,7 +170,7 @@ subroutine da_rttov_tl(inst, nchanl, nprofiles, con_vars, aux_vars, & call rttov_alloc_transmission( & & errorstatus, & & transmission, & - & nlevels-1, & + & nlevels, & & nchanprof, & & asw, & & init = .true. ) @@ -182,7 +183,7 @@ subroutine da_rttov_tl(inst, nchanl, nprofiles, con_vars, aux_vars, & call rttov_alloc_transmission( & & errorstatus, & & transmission_tl, & - & nlevels-1, & + & nlevels, & & nchanprof, & & asw, & & init = .true. ) @@ -197,7 +198,7 @@ subroutine da_rttov_tl(inst, nchanl, nprofiles, con_vars, aux_vars, & & errorstatus, & & nchanprof, & & radiance, & - & nlevels-1, & + & nlevels, & & asw, & & init = .true. ) if ( errorstatus /= errorstatus_success ) then @@ -210,7 +211,7 @@ subroutine da_rttov_tl(inst, nchanl, nprofiles, con_vars, aux_vars, & & errorstatus, & & nchanprof, & & radiance_tl, & - & nlevels-1, & + & nlevels, & & asw, & & init = .true. ) if ( errorstatus /= errorstatus_success ) then @@ -218,11 +219,13 @@ subroutine da_rttov_tl(inst, nchanl, nprofiles, con_vars, aux_vars, & (/"memory allocation error for radiance TL arrays"/)) end if - if ( coefs(inst)%coef%id_sensor == 1 .or. coefs(inst)%coef%id_sensor == 3 ) then ! infrared sensor + if ( coefs(inst)%coef%id_sensor == sensor_id_ir .or. & + coefs(inst)%coef%id_sensor == sensor_id_hi ) then ! infrared sensor calcemis(1:nchanprof) = .true. emissivity(1:nchanprof)%emis_in = 0.0 emissivity_tl(1:nchanprof)%emis_in = 0.0 - else if ( coefs(inst)%coef%id_sensor == 2 ) then ! microwave sensor + else if ( coefs(inst)%coef%id_sensor == sensor_id_mw .or. & + coefs(inst)%coef%id_sensor == sensor_id_po ) then ! microwave sensor do n = 1, nprofiles if ( profiles(n) % skin % surftype == 1 ) then ! sea calcemis((n-1)*nchanl+1:n*nchanl) = .true. @@ -288,24 +291,24 @@ subroutine da_rttov_tl(inst, nchanl, nprofiles, con_vars, aux_vars, & asw = 0 ! deallocation ! deallocate radiance arrays - call rttov_alloc_rad (errorstatus,nchanprof,radiance,nlevels-1,asw) + call rttov_alloc_rad (errorstatus,nchanprof,radiance,nlevels,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"radiance deallocation error"/)) end if - call rttov_alloc_rad (errorstatus,nchanprof,radiance_tl,nlevels-1,asw) + call rttov_alloc_rad (errorstatus,nchanprof,radiance_tl,nlevels,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"radiance TL deallocation error"/)) end if ! deallocate transmission arrays - call rttov_alloc_transmission (errorstatus,transmission,nlevels-1,nchanprof,asw) + call rttov_alloc_transmission (errorstatus,transmission,nlevels,nchanprof,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"transmission deallocation error"/)) end if - call rttov_alloc_transmission (errorstatus,transmission_tl,nlevels-1,nchanprof,asw) + call rttov_alloc_transmission (errorstatus,transmission_tl,nlevels,nchanprof,asw) if ( errorstatus /= errorstatus_success ) then call da_error(__FILE__,__LINE__, & (/"transmission TL deallocation error"/)) diff --git a/var/da/da_radiance/module_radiance.f90 b/var/da/da_radiance/module_radiance.f90 index 9a83cd8969..93f895afad 100644 --- a/var/da/da_radiance/module_radiance.f90 +++ b/var/da/da_radiance/module_radiance.f90 @@ -14,17 +14,22 @@ module module_radiance gas_id_watervapour, & sensor_id_ir, & sensor_id_mw, & - sensor_id_hi + sensor_id_hi, & + sensor_id_po use rttov_types, only : & rttov_options, & rttov_opts_rt_ir, & rttov_coefs, & - profile_type, & - transmission_type, & - radiance_type, & + rttov_profile, & + rttov_transmission, & + rttov_radiance, & rttov_chanprof, & rttov_emissivity use parkind1, only : jpim, jprb + use mod_rttov_emis_atlas, only : & + rttov_emis_atlas_data, & + atlas_type_mw, & + atlas_type_ir #endif #ifdef CRTM @@ -139,6 +144,8 @@ module module_radiance type (rttov_coefs), allocatable :: coefs(:) ! coefficients structure type (rttov_options), allocatable :: opts(:) ! options structure type (rttov_opts_rt_ir), allocatable :: opts_rt_ir(:) ! options structure + type (rttov_emis_atlas_data) :: atlas + integer(jpim), allocatable :: atlas_type(:), atlas_id(:) #endif type satinfo_type diff --git a/var/external/crtm_2.2.3/config-setup/g95.setup b/var/external/crtm_2.2.3/config-setup/g95.setup deleted file mode 100644 index 1287892e6f..0000000000 --- a/var/external/crtm_2.2.3/config-setup/g95.setup +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/sh -#-------------------------------------------------------------------------------# -# PRODUCTION build settings for Linux g95 compiler -#-------------------------------------------------------------------------------# - -export FC="g95" - -export FCFLAGS="\ --O2 \ --ffast-math \ --ffree-form \ --fno-second-underscore \ --funroll-loops \ --malign-double" - -export LDFLAGS="" - -export LIBS="" diff --git a/var/external/crtm_2.2.3/crtm_release_notes.txt b/var/external/crtm_2.2.3/crtm_release_notes.txt deleted file mode 100644 index 8abcdb48a7..0000000000 --- a/var/external/crtm_2.2.3/crtm_release_notes.txt +++ /dev/null @@ -1,52 +0,0 @@ -Release Notes: CRTM library v2.2.3 - -$Revision: 60152 $ - ------------------------------------------------------------ -v2.2.3 - released August 13, 2015 - - * Made minor fixfile changes to include - 1. Corrected the WMO satellite id for DMSP-19 SSMIS in the CRTM fixfiles. - - * Compute resource information - N/A. This is a library used in the GSI. - - ------------------------------------------------------------ -v2.2.2 - released August 12, 2015 - - * Made minor code changes to include - 1. Report invalid WMO Sensor and Satellite identifiers as a WARNING rather than ERROR. - - * Made minor build changes to include - 1. Modification of Intel ifort compiler flags as requested by GSI developers. - - * Compute resource information - N/A. This is a library used in the GSI. - - ------------------------------------------------------------ -v2.2.1 - released April 20, 2015 - - * Made scientific changes to include - 1. Revert ATMS spectral and transmittance coefficients to those derived - from a boxcar response. - - * Compute resource information - N/A. This is a library used in the GSI. - - ------------------------------------------------------------ -v2.2.0 - released April 13, 2015 - - * Made scientific changes to include - 1. Overcast radiances - 2. Reflection correction in microwave sea surface emissivity model for - non-precipitating clouds - 3. ATMS snow emissivity model - 4. Cloud optical property coefficient update for infrared ice clouds. - 5. Software updates to address zeus meta-data server issues (file inquiries) - 6. Implementation of the FASTEM-6 microwave sea surface emissivity model. - - * Compute resource information - N/A. This is a library used in the GSI. diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Version.inc b/var/external/crtm_2.2.3/libsrc/CRTM_Version.inc deleted file mode 100644 index 38f441d555..0000000000 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Version.inc +++ /dev/null @@ -1 +0,0 @@ -'v2.2.3' diff --git a/var/external/crtm_2.2.3/libsrc/UnitTest_Define.f90 b/var/external/crtm_2.2.3/libsrc/UnitTest_Define.f90 deleted file mode 100644 index b8f88d360d..0000000000 --- a/var/external/crtm_2.2.3/libsrc/UnitTest_Define.f90 +++ /dev/null @@ -1,3021 +0,0 @@ -! -! UnitTest_Define -! -! Module defining the UnitTest object -! -! -! CREATION HISTORY: -! Written by: Paul van Delst, 05-Feb-2007 -! paul.vandelst@noaa.gov -! - -MODULE UnitTest_Define - - ! ------------------ - ! Environment setup - ! ----------------- - ! Module usage - USE Type_Kinds , ONLY: Byte, Short, Long, Single, Double - USE Compare_Float_Numbers, ONLY: OPERATOR(.EqualTo.) - ! Disable implicit typing - IMPLICIT NONE - - ! ------------ - ! Visibilities - ! ------------ - ! Everything private by default - PRIVATE - ! Datatypes - PUBLIC :: UnitTest_type - ! Procedures - PUBLIC :: UnitTest_Init - PUBLIC :: UnitTest_Setup - PUBLIC :: UnitTest_Report - PUBLIC :: UnitTest_Summary - PUBLIC :: UnitTest_n_Passed - PUBLIC :: UnitTest_n_Failed - PUBLIC :: UnitTest_Passed - PUBLIC :: UnitTest_Failed - PUBLIC :: UnitTest_Assert - PUBLIC :: UnitTest_IsEqual - PUBLIC :: UnitTest_IsEqualWithin - PUBLIC :: UnitTest_DefineVersion - - - ! --------------------- - ! Procedure overloading - ! --------------------- - ! PUBLIC procedures - INTERFACE UnitTest_IsEqual - ! INTEGER(Byte) procedures - MODULE PROCEDURE intbyte_isequal_scalar - MODULE PROCEDURE intbyte_isequal_rank1 - MODULE PROCEDURE intbyte_isequal_rank2 - ! INTEGER(Short) procedures - MODULE PROCEDURE intshort_isequal_scalar - MODULE PROCEDURE intshort_isequal_rank1 - MODULE PROCEDURE intshort_isequal_rank2 - ! INTEGER(Long) procedures - MODULE PROCEDURE intlong_isequal_scalar - MODULE PROCEDURE intlong_isequal_rank1 - MODULE PROCEDURE intlong_isequal_rank2 - ! REAL(Single) procedures - MODULE PROCEDURE realsp_isequal_scalar - MODULE PROCEDURE realsp_isequal_rank1 - MODULE PROCEDURE realsp_isequal_rank2 - ! REAL(Double) procedures - MODULE PROCEDURE realdp_isequal_scalar - MODULE PROCEDURE realdp_isequal_rank1 - MODULE PROCEDURE realdp_isequal_rank2 - ! COMPLEX(Single) procedures - MODULE PROCEDURE complexsp_isequal_scalar - MODULE PROCEDURE complexsp_isequal_rank1 - MODULE PROCEDURE complexsp_isequal_rank2 - ! COMPLEX(Double) procedures - MODULE PROCEDURE complexdp_isequal_scalar - MODULE PROCEDURE complexdp_isequal_rank1 - MODULE PROCEDURE complexdp_isequal_rank2 - ! CHARACTER(*) procedures - MODULE PROCEDURE char_isequal_scalar - MODULE PROCEDURE char_isequal_rank1 - MODULE PROCEDURE char_isequal_rank2 - END INTERFACE UnitTest_IsEqual - - INTERFACE UnitTest_IsEqualWithin - ! REAL(Single) procedures - MODULE PROCEDURE realsp_isequalwithin_scalar - MODULE PROCEDURE realsp_isequalwithin_rank1 - MODULE PROCEDURE realsp_isequalwithin_rank2 - ! REAL(Double) procedures - MODULE PROCEDURE realdp_isequalwithin_scalar - MODULE PROCEDURE realdp_isequalwithin_rank1 - MODULE PROCEDURE realdp_isequalwithin_rank2 - ! COMPLEX(Single) procedures - MODULE PROCEDURE complexsp_isequalwithin_scalar - MODULE PROCEDURE complexsp_isequalwithin_rank1 - MODULE PROCEDURE complexsp_isequalwithin_rank2 - ! COMPLEX(Double) procedures - MODULE PROCEDURE complexdp_isequalwithin_scalar - MODULE PROCEDURE complexdp_isequalwithin_rank1 - MODULE PROCEDURE complexdp_isequalwithin_rank2 - END INTERFACE UnitTest_IsEqualWithin - - - ! PRIVATE procedures - INTERFACE Get_Multiplier - MODULE PROCEDURE realsp_get_multiplier - MODULE PROCEDURE realdp_get_multiplier - END INTERFACE Get_Multiplier - - - ! ----------------- - ! Module parameters - ! ----------------- - CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: UnitTest_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' - INTEGER, PARAMETER :: SL = 512 - INTEGER, PARAMETER :: CR = 13 - INTEGER, PARAMETER :: LF = 10 - CHARACTER(2), PARAMETER :: CRLF = ACHAR(CR)//ACHAR(LF) - CHARACTER(*), PARAMETER :: RFMT = 'es25.18' - CHARACTER(*), PARAMETER :: ZFMT = '"(",'//RFMT//',",",'//RFMT//',")"' - LOGICAL, PARAMETER :: DEFAULT_VERBOSE = .FALSE. - - ! Message colours - CHARACTER(*), PARAMETER :: GREEN_COLOUR = ACHAR(27)//'[1;32m' - CHARACTER(*), PARAMETER :: RED_COLOUR = ACHAR(27)//'[1;31m' - CHARACTER(*), PARAMETER :: NO_COLOUR = ACHAR(27)//'[0m' - - ! Message levels - INTEGER, PARAMETER :: N_MESSAGE_LEVELS = 6 - INTEGER, PARAMETER :: INIT_LEVEL = 1 - INTEGER, PARAMETER :: SETUP_LEVEL = 2 - INTEGER, PARAMETER :: TEST_LEVEL = 3 - INTEGER, PARAMETER :: REPORT_LEVEL = 4 - INTEGER, PARAMETER :: SUMMARY_LEVEL = 5 - INTEGER, PARAMETER :: INTERNAL_FAIL_LEVEL = 6 - CHARACTER(*), PARAMETER :: MESSAGE_LEVEL(N_MESSAGE_LEVELS) = & - [ 'INIT ', & - 'SETUP ', & - 'TEST ', & - 'REPORT ', & - 'SUMMARY ', & - 'INTERNAL FAILURE' ] - - ! ------------------------ - ! Derived type definitions - ! ------------------------ - !:tdoc+: - TYPE :: UnitTest_type - PRIVATE - ! User accessible test settings - LOGICAL :: Verbose = DEFAULT_VERBOSE - CHARACTER(SL) :: Title = '' - CHARACTER(SL) :: Caller = '' - ! Internal test settings - ! ...Test result messaging - INTEGER :: Level = INIT_LEVEL - CHARACTER(SL) :: Procedure = '' - CHARACTER(SL) :: Message = '' - ! ...Test result (used for array argument procedures) - LOGICAL :: Test_Result = .TRUE. - ! ...Individual test counters - INTEGER :: n_Tests = 0 - INTEGER :: n_Passed_Tests = 0 - INTEGER :: n_Failed_Tests = 0 - ! ...All test counters - INTEGER :: n_AllTests = 0 - INTEGER :: n_Passed_AllTests = 0 - INTEGER :: n_Failed_AllTests = 0 - END TYPE UnitTest_type - !:tdoc-: - -CONTAINS - - -!################################################################################ -!################################################################################ -!## ## -!## ## PUBLIC MODULE ROUTINES ## ## -!## ## -!################################################################################ -!################################################################################ - -!------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! UnitTest_Init -! -! PURPOSE: -! UnitTest initialisation subroutine. -! -! This subroutine should be called ONCE, BEFORE ANY tests are performed. -! -! CALLING SEQUENCE: -! CALL UnitTest_Init( UnitTest, Verbose=Verbose ) -! -! OBJECTS: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT) -! -! OPTIONAL INPUTS: -! Verbose: Logical argument to control length of reporting output. -! If == .FALSE., Only failed tests are reported [DEFAULT]. -! == .TRUE., Both failed and passed tests are reported. -! If not specified, default is .TRUE. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -!:sdoc-: -!------------------------------------------------------------------------------ - - SUBROUTINE UnitTest_Init( UnitTest, Verbose ) - ! Arguments - TYPE(UnitTest_type), INTENT(OUT) :: UnitTest - LOGICAL, OPTIONAL, INTENT(IN) :: Verbose - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_Init' - ! Variables - LOGICAL :: local_Verbose - - ! Check optional arguments - local_Verbose = DEFAULT_VERBOSE - IF ( PRESENT(Verbose) ) local_Verbose = Verbose - - ! Perform initialisation - CALL Set_Property( & - UnitTest, & - Verbose = local_Verbose, & - Level = INIT_LEVEL, & - Procedure = PROCEDURE_NAME, & - n_Tests = 0, & - n_Passed_Tests = 0, & - n_Failed_Tests = 0, & - n_AllTests = 0, & - n_Passed_AllTests = 0, & - n_Failed_AllTests = 0 ) - CALL Display_Message( UnitTest ) - END SUBROUTINE UnitTest_Init - - -!------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! UnitTest_Setup -! -! PURPOSE: -! UnitTest individual test setup subroutine. -! -! This subroutine should be called BEFORE each set of tests performed. -! -! CALLING SEQUENCE: -! CALL UnitTest_Setup( UnitTest , & -! Title , & -! Caller = Caller , & -! Verbose = Verbose ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN OUT) -! -! INPUTS: -! Title: Character string containing the title of the test -! to be performed. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! OPTIONAL INPUTS: -! Caller: Character string containing the name of the calling -! subprogram. If not specified, default is an empty string. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! Verbose: Logical argument to control length of reporting output. -! If == .FALSE., Only failed tests are reported [DEFAULT]. -! == .TRUE., Both failed and passed tests are reported. -! If not specified, default is .TRUE. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -!:sdoc-: -!------------------------------------------------------------------------------ - - SUBROUTINE UnitTest_Setup( UnitTest, Title, Caller, Verbose ) - ! Arguments - TYPE(UnitTest_type) , INTENT(IN OUT) :: UnitTest - CHARACTER(*) , INTENT(IN) :: Title - CHARACTER(*), OPTIONAL, INTENT(IN) :: Caller - LOGICAL, OPTIONAL, INTENT(IN) :: Verbose - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_Setup' - ! Variables - CHARACTER(SL) :: local_Caller - LOGICAL :: local_Verbose - CHARACTER(SL) :: Message - - ! Check arguments - local_Caller = '' - IF ( PRESENT(Caller) ) local_Caller = '; CALLER: '//TRIM(ADJUSTL(Caller)) - local_Verbose = DEFAULT_VERBOSE - IF ( PRESENT(Verbose) ) local_Verbose = Verbose - - ! Create init message - Message = TRIM(Title)//TRIM(local_Caller) - - ! Perform initialistion - CALL Set_Property( & - UnitTest, & - Title = ADJUSTL(Title), & - Caller = local_Caller , & - Verbose = local_Verbose , & - Level = SETUP_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message, & - n_Tests = 0, & - n_Passed_Tests = 0, & - n_Failed_Tests = 0 ) - CALL Display_Message( UnitTest ) - - END SUBROUTINE UnitTest_Setup - - -!------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! UnitTest_Report -! -! PURPOSE: -! UnitTest individual test report subroutine -! -! This subroutine should be called AFTER each set of tests performed. -! -! CALLING SEQUENCE: -! CALL UnitTest_Report( UnitTest ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -!:sdoc-: -!------------------------------------------------------------------------------ - - SUBROUTINE UnitTest_Report( UnitTest ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_Report' - ! Variables - INTEGER :: n_Tests - INTEGER :: n_Passed_Tests - INTEGER :: n_Failed_Tests - CHARACTER(SL) :: Message - CHARACTER(SL) :: Attention - CHARACTER(SL) :: colour - ! Retrieve required properties - CALL Get_Property( & - UnitTest, & - n_Tests = n_Tests , & - n_Passed_Tests = n_Passed_Tests, & - n_Failed_Tests = n_Failed_Tests ) - - ! Test fail attention-grabber - colour = GREEN_COLOUR - Attention = '' - IF ( n_Failed_Tests /= 0 ) THEN - colour = RED_COLOUR - Attention = ' <----<<< **WARNING**' - END IF - - ! Output results - WRITE( Message, & - '(a,a,3x,"Passed ",i0," of ",i0," tests", & - &a,3x,"Failed ",i0," of ",i0," tests",a,a)') & - TRIM(colour), CRLF, & - n_Passed_Tests, n_Tests, & - CRLF, & - n_Failed_Tests, n_Tests, & - TRIM(Attention), NO_COLOUR - CALL Set_Property( & - UnitTest, & - Level = REPORT_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - - END SUBROUTINE UnitTest_Report - - -!------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! UnitTest_Summary -! -! PURPOSE: -! UnitTest test suite report summary subroutine -! -! This subroutine should be called ONCE, AFTER ALL tests are performed. -! -! CALLING SEQUENCE: -! CALL UnitTest_Summary( UnitTest ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -!:sdoc-: -!------------------------------------------------------------------------------ - - SUBROUTINE UnitTest_Summary( UnitTest ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_Summary' - ! Variables - INTEGER :: n_AllTests - INTEGER :: n_Passed_AllTests - INTEGER :: n_Failed_AllTests - CHARACTER(SL) :: Message - CHARACTER(SL) :: Attention - CHARACTER(SL) :: colour - - ! Retrieve required properties - CALL Get_Property( & - UnitTest, & - n_AllTests = n_AllTests , & - n_Passed_AllTests = n_Passed_AllTests, & - n_Failed_AllTests = n_Failed_AllTests ) - - ! Test fail attention-grabber - colour = GREEN_COLOUR - Attention = '' - IF ( n_Failed_AllTests /= 0 ) THEN - colour = RED_COLOUR - Attention = ' <----<<< **WARNING**' - END IF - - ! Output results - WRITE( Message, & - '(a,a,1x,"Passed ",i0," of ",i0," total tests",& - &a,1x,"Failed ",i0," of ",i0," total tests",a,a)') & - TRIM(colour), CRLF, & - n_Passed_AllTests, n_AllTests, & - CRLF, & - n_Failed_AllTests, n_AllTests, & - TRIM(Attention), NO_COLOUR - CALL Set_Property( & - UnitTest, & - Level = SUMMARY_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - END SUBROUTINE UnitTest_Summary - - -!------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! UnitTest_n_Passed -! -! PURPOSE: -! Utility function to return the number of tests passed. -! -! CALLING SEQUENCE: -! n = UnitTest_n_Passed( UnitTest ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! FUNCTION RESULT: -! n: The number of unit tests that have currently passed. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! -!:sdoc-: -!------------------------------------------------------------------------------ - - PURE FUNCTION UnitTest_n_Passed( UnitTest ) RESULT( n ) - TYPE(UnitTest_type), INTENT(IN) :: UnitTest - INTEGER :: n - CALL Get_Property( UnitTest, n_Passed_Tests = n ) - END FUNCTION UnitTest_n_Passed - - -!------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! UnitTest_n_Failed -! -! PURPOSE: -! Utility function to return the number of tests failed. -! -! CALLING SEQUENCE: -! n = UnitTest_n_Failed( UnitTest ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! FUNCTION RESULT: -! n: The number of unit tests that have currently failed. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! -!:sdoc-: -!------------------------------------------------------------------------------ - - PURE FUNCTION UnitTest_n_Failed( UnitTest ) RESULT( n ) - TYPE(UnitTest_type), INTENT(IN) :: UnitTest - INTEGER :: n - CALL Get_Property( UnitTest, n_Failed_Tests = n ) - END FUNCTION UnitTest_n_Failed - - -!------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! UnitTest_Passed -! -! PURPOSE: -! Function to inform if the last test performed passed. -! -! CALLING SEQUENCE: -! result = UnitTest_Passed( UnitTest ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! FUNCTION RESULT: -! result: Logical to indicate if the last test performed passed. -! If == .TRUE., the last test passed, -! == .FALSE., the last test failed. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Scalar -! -!:sdoc-: -!------------------------------------------------------------------------------ - - PURE FUNCTION UnitTest_Passed( UnitTest ) RESULT( Passed ) - TYPE(UnitTest_type), INTENT(IN) :: UnitTest - LOGICAL :: Passed - CALL Get_Property( UnitTest, Test_Result = Passed ) - END FUNCTION UnitTest_Passed - - -!------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! UnitTest_Failed -! -! PURPOSE: -! Function to inform if the last test performed failed. -! -! Syntactic sugar procedure. -! -! CALLING SEQUENCE: -! result = UnitTest_Failed( UnitTest ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! FUNCTION RESULT: -! result: Logical to indicate if the last test performed failed. -! If == .TRUE., the last test failed, -! == .FALSE., the last test passed. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Scalar -! -!:sdoc-: -!------------------------------------------------------------------------------ - - PURE FUNCTION UnitTest_Failed( UnitTest ) RESULT( Failed ) - TYPE(UnitTest_type), INTENT(IN) :: UnitTest - LOGICAL :: Failed - Failed = .NOT. UnitTest_Passed( UnitTest ) - END FUNCTION UnitTest_Failed - - -!------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! UnitTest_Assert -! -! PURPOSE: -! Subroutine to assert its test argument -! -! CALLING SEQUENCE: -! CALL UnitTest_Assert(UnitTest, Test) -! -! OBJECTS: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN OUT) -! -! INPUTS: -! Test: The logical expression to assert. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -!:sdoc-: -!------------------------------------------------------------------------------ - - SUBROUTINE UnitTest_Assert(UnitTest, Test) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - LOGICAL, INTENT(IN) :: Test - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_Assert' - ! Variables - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - Message = '' - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - CALL Test_Info_String( UnitTest, Message ) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - - END SUBROUTINE UnitTest_Assert - - -!------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! UnitTest_IsEqual -! -! PURPOSE: -! Subroutine to assert that two arguments are equal. -! -! CALLING SEQUENCE: -! CALL UnitTest_IsEqual( UnitTest, Expected, Actual ) -! -! OBJECTS: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN OUT) -! -! INPUTS: -! Expected: The expected value of the variable being tested. -! UNITS: N/A -! TYPE: INTEGER(Byte) , or -! INTEGER(Short) , or -! INTEGER(Long) , or -! REAL(Single) , or -! REAL(Double) , or -! COMPLEX(Single), or -! COMPLEX(Double), or -! CHARACTER(*) -! DIMENSION: Scalar, or -! Rank-1, or -! Rank-2 -! ATTRIBUTES: INTENT(IN) -! -! Actual: The actual value of the variable being tested. -! UNITS: N/A -! TYPE: Same as Expected input -! DIMENSION: Same as Expected input -! ATTRIBUTES: INTENT(IN) -! -!:sdoc-: -!------------------------------------------------------------------------------ - - SUBROUTINE intbyte_isequal_scalar( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - INTEGER(Byte), INTENT(IN) :: Expected, Actual - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[INTEGER(Byte)]' - ! Variables - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Assign the test - Test = (Expected == Actual) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message,'("Expected ",i0," and got ",i0)') Expected, Actual - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE intbyte_isequal_scalar - - - SUBROUTINE intbyte_isequal_rank1( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - INTEGER(Byte), INTENT(IN) :: Expected(:), Actual(:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[INTEGER(Byte)]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & - isize, SIZE(Actual) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL intbyte_isequal_scalar( UnitTest, Expected(i), Actual(i) ) - END DO - END SUBROUTINE intbyte_isequal_rank1 - - - SUBROUTINE intbyte_isequal_rank2( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - INTEGER(Byte), INTENT(IN) :: Expected(:,:), Actual(:,:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[INTEGER(Byte)]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL intbyte_isequal_scalar( UnitTest, Expected(i,j), Actual(i,j) ) - END DO - END DO - END SUBROUTINE intbyte_isequal_rank2 - - - SUBROUTINE intshort_isequal_scalar( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - INTEGER(Short), INTENT(IN) :: Expected, Actual - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[INTEGER(Short)]' - ! Variables - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Assign the test - Test = (Expected == Actual) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message,'("Expected ",i0," and got ",i0)') Expected, Actual - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE intshort_isequal_scalar - - - SUBROUTINE intshort_isequal_rank1( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - INTEGER(Short), INTENT(IN) :: Expected(:), Actual(:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[INTEGER(Short)]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & - isize, SIZE(Actual) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL intshort_isequal_scalar( UnitTest, Expected(i), Actual(i) ) - END DO - END SUBROUTINE intshort_isequal_rank1 - - - SUBROUTINE intshort_isequal_rank2( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - INTEGER(Short), INTENT(IN) :: Expected(:,:), Actual(:,:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[INTEGER(Short)]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL intshort_isequal_scalar( UnitTest, Expected(i,j), Actual(i,j) ) - END DO - END DO - END SUBROUTINE intshort_isequal_rank2 - - - SUBROUTINE intlong_isequal_scalar( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - INTEGER(Long), INTENT(IN) :: Expected, Actual - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[INTEGER(Long)]' - ! Variables - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Assign the test - Test = (Expected == Actual) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message,'("Expected ",i0," and got ",i0)') Expected, Actual - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE intlong_isequal_scalar - - - SUBROUTINE intlong_isequal_rank1( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - INTEGER(Long), INTENT(IN) :: Expected(:), Actual(:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[INTEGER(Long)]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & - isize, SIZE(Actual) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL intlong_isequal_scalar( UnitTest, Expected(i), Actual(i) ) - END DO - END SUBROUTINE intlong_isequal_rank1 - - - SUBROUTINE intlong_isequal_rank2( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - INTEGER(Long), INTENT(IN) :: Expected(:,:), Actual(:,:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[INTEGER(Long)]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL intlong_isequal_scalar( UnitTest, Expected(i,j), Actual(i,j) ) - END DO - END DO - END SUBROUTINE intlong_isequal_rank2 - - - SUBROUTINE realsp_isequal_scalar( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Single), INTENT(IN) :: Expected, Actual - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[REAL(Single)]' - ! Variables - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Assign the test - Test = (Expected .EqualTo. Actual) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message, & - '(a,7x,"Expected: ",'//RFMT//',a,& - &7x,"And got: ",'//RFMT//')') & - CRLF, Expected, CRLF, Actual - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE realsp_isequal_scalar - - - SUBROUTINE realsp_isequal_rank1( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Single), INTENT(IN) :: Expected(:), Actual(:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[REAL(Single)]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & - isize, SIZE(Actual) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL realsp_isequal_scalar( UnitTest, Expected(i), Actual(i) ) - END DO - END SUBROUTINE realsp_isequal_rank1 - - - SUBROUTINE realsp_isequal_rank2( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Single), INTENT(IN) :: Expected(:,:), Actual(:,:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[REAL(Single)]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL realsp_isequal_scalar( UnitTest, Expected(i,j), Actual(i,j) ) - END DO - END DO - END SUBROUTINE realsp_isequal_rank2 - - - SUBROUTINE realdp_isequal_scalar( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Double), INTENT(IN) :: Expected, Actual - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[REAL(Double)]' - ! Variables - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Assign the test - Test = (Expected .EqualTo. Actual) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message, & - '(a,7x,"Expected: ",'//RFMT//',a,& - &7x,"And got: ",'//RFMT//')') & - CRLF, Expected, CRLF, Actual - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE realdp_isequal_scalar - - - SUBROUTINE realdp_isequal_rank1( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Double), INTENT(IN) :: Expected(:), Actual(:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[REAL(Double)]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & - isize, SIZE(Actual) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL realdp_isequal_scalar( UnitTest, Expected(i), Actual(i) ) - END DO - END SUBROUTINE realdp_isequal_rank1 - - - SUBROUTINE realdp_isequal_rank2( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Double), INTENT(IN) :: Expected(:,:), Actual(:,:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[REAL(Double)]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL realdp_isequal_scalar( UnitTest, Expected(i,j), Actual(i,j) ) - END DO - END DO - END SUBROUTINE realdp_isequal_rank2 - - - SUBROUTINE complexsp_isequal_scalar( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Single), INTENT(IN) :: Expected, Actual - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[COMPLEX(Single)]' - ! Variables - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Assign the test - Test = (Expected .EqualTo. Actual) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message, & - '(a,7x,"Expected: ",'//ZFMT//',a,& - &7x,"And got: ",'//ZFMT//')') & - CRLF, Expected, CRLF, Actual - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE complexsp_isequal_scalar - - - SUBROUTINE complexsp_isequal_rank1( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Single), INTENT(IN) :: Expected(:), Actual(:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[COMPLEX(Single)]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & - isize, SIZE(Actual) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL complexsp_isequal_scalar( UnitTest, Expected(i), Actual(i) ) - END DO - END SUBROUTINE complexsp_isequal_rank1 - - - SUBROUTINE complexsp_isequal_rank2( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Single), INTENT(IN) :: Expected(:,:), Actual(:,:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[COMPLEX(Single)]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL complexsp_isequal_scalar( UnitTest, Expected(i,j), Actual(i,j) ) - END DO - END DO - END SUBROUTINE complexsp_isequal_rank2 - - - SUBROUTINE complexdp_isequal_scalar( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Double), INTENT(IN) :: Expected, Actual - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[COMPLEX(Double)]' - ! Variables - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Assign the test - Test = (Expected .EqualTo. Actual) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message, & - '(a,7x,"Expected: ",'//ZFMT//',a,& - &7x,"And got: ",'//ZFMT//')') & - CRLF, Expected, CRLF, Actual - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE complexdp_isequal_scalar - - - SUBROUTINE complexdp_isequal_rank1( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Double), INTENT(IN) :: Expected(:), Actual(:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[COMPLEX(Double)]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & - isize, SIZE(Actual) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL complexdp_isequal_scalar( UnitTest, Expected(i), Actual(i) ) - END DO - END SUBROUTINE complexdp_isequal_rank1 - - - SUBROUTINE complexdp_isequal_rank2( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Double), INTENT(IN) :: Expected(:,:), Actual(:,:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[COMPLEX(Double)]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL complexdp_isequal_scalar( UnitTest, Expected(i,j), Actual(i,j) ) - END DO - END DO - END SUBROUTINE complexdp_isequal_rank2 - - - SUBROUTINE char_isequal_scalar( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - CHARACTER(*), INTENT(IN) :: Expected, Actual - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[CHARACTER]' - ! Variables - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Assign the test - Test = (Expected == Actual) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message,'("Expected >",a,"< and got >",a,"<")') Expected, Actual - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE char_isequal_scalar - - - SUBROUTINE char_isequal_rank1( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - CHARACTER(*), INTENT(IN) :: Expected(:), Actual(:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[CHARACTER]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & - isize, SIZE(Actual) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL char_isequal_scalar( UnitTest, Expected(i), Actual(i) ) - END DO - END SUBROUTINE char_isequal_rank1 - - - SUBROUTINE char_isequal_rank2( UnitTest, Expected, Actual ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - CHARACTER(*), INTENT(IN) :: Expected(:,:), Actual(:,:) - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqual[CHARACTER]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL char_isequal_scalar( UnitTest, Expected(i,j), Actual(i,j) ) - END DO - END DO - END SUBROUTINE char_isequal_rank2 - - -!------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! UnitTest_IsEqualWithin -! -! PURPOSE: -! Subroutine to assert that two floating point arguments are equal to -! within the specified tolerance. -! -! CALLING SEQUENCE: -! CALL UnitTest_IsEqualWithin( UnitTest , & -! Expected , & -! Actual , & -! Tolerance, & -! Epsilon_Scale = Epsilon_Scale ) -! -! OBJECTS: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN OUT) -! -! INPUTS: -! Expected: The expected value of the variable being tested. -! UNITS: N/A -! TYPE: REAL(Single) , or -! REAL(Double) , or -! COMPLEX(Single), or -! COMPLEX(Double) -! DIMENSION: Scalar, or -! Rank-1, or -! Rank-2 -! ATTRIBUTES: INTENT(IN) -! -! Actual: The actual value of the variable being tested. -! UNITS: N/A -! TYPE: Same as Expected input -! DIMENSION: Same as Expected input -! ATTRIBUTES: INTENT(IN) -! -! Tolerance: The tolerance to within which the Expected and Actual -! values must agree. If negative, the value of -! EPSILON(Expected) -! is used. -! This argument is ignored if the EPSILON_SCALE optional -! argument is specified -! UNITS: N/A -! TYPE: Same as Expected input -! DIMENSION: Same as Expected input -! ATTRIBUTES: INTENT(IN) -! -! OPTIONAL INPUTS: -! Epsilon_Scale: Set this logical flag to compute and use the tolerance -! value: -! EPSILON(Expected) * Scale_Factor -! where the scaling factor is the exponent value of the -! input argument Expected. -! UNITS: N/A -! TYPE: LOGICAL. -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -!:sdoc-: -!------------------------------------------------------------------------------ - - SUBROUTINE realsp_isequalwithin_scalar( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Single), INTENT(IN) :: Expected, Actual, Tolerance - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[REAL(Single)]' - ! Variables - REAL(Single) :: tol - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Default tolerance - tol = Tolerance - ! ...Check optional arguments - IF ( PRESENT(Epsilon_Scale) ) THEN - IF ( Epsilon_Scale ) tol = EPSILON(Expected) * Get_Multiplier( Expected ) - END IF - ! ...Assign the test - Test = (ABS(Expected-Actual) < tol) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message, & - '(a,7x,"Expected: ",'//RFMT//',a,& - &7x,"To within: ",'//RFMT//',a,& - &7x,"And got: ",'//RFMT//',a,& - &7x,"|Difference|: ",'//RFMT//')') & - CRLF, Expected, CRLF, tol, CRLF, Actual, CRLF, ABS(Expected-Actual) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE realsp_isequalwithin_scalar - - - SUBROUTINE realsp_isequalwithin_rank1( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Single), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[REAL(Single)]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize .OR. & - SIZE(Tolerance) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0,"; Tolerance:",i0)') & - isize, SIZE(Actual), SIZE(Tolerance) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL realsp_isequalwithin_scalar( & - UnitTest , & - Expected(i) , & - Actual(i) , & - Tolerance(i), & - Epsilon_Scale = Epsilon_Scale ) - END DO - END SUBROUTINE realsp_isequalwithin_rank1 - - - SUBROUTINE realsp_isequalwithin_rank2( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Single), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[REAL(Single)]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize .OR. & - SIZE(Tolerance,DIM=1) /= isize .OR. & - SIZE(Tolerance,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- ",& - &"Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,"); Tolerance:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2), & - SIZE(Tolerance,DIM=1), SIZE(Tolerance,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL realsp_isequalwithin_scalar( & - UnitTest , & - Expected(i,j) , & - Actual(i,j) , & - Tolerance(i,j), & - Epsilon_Scale = Epsilon_Scale ) - END DO - END DO - END SUBROUTINE realsp_isequalwithin_rank2 - - - SUBROUTINE realdp_isequalwithin_scalar( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Double), INTENT(IN) :: Expected, Actual, Tolerance - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[REAL(Double)]' - ! Variables - REAL(Double) :: tol - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Default tolerance - tol = Tolerance - ! ...Check optional arguments - IF ( PRESENT(Epsilon_Scale) ) THEN - IF ( Epsilon_Scale ) tol = EPSILON(Expected) * Get_Multiplier( Expected ) - END IF - ! ...Assign the test - Test = (ABS(Expected-Actual) < tol) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message, & - '(a,7x,"Expected: ",'//RFMT//',a,& - &7x,"To within: ",'//RFMT//',a,& - &7x,"And got: ",'//RFMT//',a,& - &7x,"|Difference|: ",'//RFMT//')') & - CRLF, Expected, CRLF, tol, CRLF, Actual, CRLF, ABS(Expected-Actual) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE realdp_isequalwithin_scalar - - - SUBROUTINE realdp_isequalwithin_rank1( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Double), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[REAL(Double)]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize .OR. & - SIZE(Tolerance) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0,"; Tolerance:",i0)') & - isize, SIZE(Actual), SIZE(Tolerance) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL realdp_isequalwithin_scalar( & - UnitTest , & - Expected(i) , & - Actual(i) , & - Tolerance(i), & - Epsilon_Scale = Epsilon_Scale ) - END DO - END SUBROUTINE realdp_isequalwithin_rank1 - - - SUBROUTINE realdp_isequalwithin_rank2( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - REAL(Double), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[REAL(Double)]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize .OR. & - SIZE(Tolerance,DIM=1) /= isize .OR. & - SIZE(Tolerance,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- ",& - &"Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,"); Tolerance:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2), & - SIZE(Tolerance,DIM=1), SIZE(Tolerance,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL realdp_isequalwithin_scalar( & - UnitTest , & - Expected(i,j) , & - Actual(i,j) , & - Tolerance(i,j), & - Epsilon_Scale = Epsilon_Scale ) - END DO - END DO - END SUBROUTINE realdp_isequalwithin_rank2 - - - SUBROUTINE complexsp_isequalwithin_scalar( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Single), INTENT(IN) :: Expected, Actual, Tolerance - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[COMPLEX(Single)]' - ! Variables - REAL(Single) :: tolr, toli - REAL(Single) :: zr, zi - REAL(Single) :: dzr, dzi - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Split expected into real and imag - zr = REAL(Expected,Single) - zi = AIMAG(Expected) - ! ...Default tolerance - tolr = REAL(Tolerance,Single) - toli = AIMAG(Tolerance) - ! ...Check optional arguments - IF ( PRESENT(Epsilon_Scale) ) THEN - IF ( Epsilon_Scale ) THEN - tolr = EPSILON(zr) * Get_Multiplier(zr) - toli = EPSILON(zi) * Get_Multiplier(zi) - END IF - END IF - ! ...Assign the test - dzr = ABS(zr - REAL(Actual,Single)) - dzi = ABS(zi - AIMAG(Actual)) - Test = (dzr < tolr) .AND. (dzi < toli) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message, & - '(a,7x,"Expected: ",'//ZFMT//',a,& - &7x,"To within: ",'//ZFMT//',a,& - &7x,"And got: ",'//ZFMT//',a,& - &7x,"|Difference|: ",'//ZFMT//')') & - CRLF, Expected, CRLF, CMPLX(tolr,toli,Single), CRLF, Actual, CRLF, dzr, dzi - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE complexsp_isequalwithin_scalar - - - SUBROUTINE complexsp_isequalwithin_rank1( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Single), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[COMPLEX(Single)]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize .OR. & - SIZE(Tolerance) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0,"; Tolerance:",i0)') & - isize, SIZE(Actual), SIZE(Tolerance) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL complexsp_isequalwithin_scalar( & - UnitTest , & - Expected(i) , & - Actual(i) , & - Tolerance(i), & - Epsilon_Scale = Epsilon_Scale ) - END DO - END SUBROUTINE complexsp_isequalwithin_rank1 - - - SUBROUTINE complexsp_isequalwithin_rank2( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Single), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[COMPLEX(Single)]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize .OR. & - SIZE(Tolerance,DIM=1) /= isize .OR. & - SIZE(Tolerance,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- ",& - &"Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,"); Tolerance:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2), & - SIZE(Tolerance,DIM=1), SIZE(Tolerance,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL complexsp_isequalwithin_scalar( & - UnitTest , & - Expected(i,j) , & - Actual(i,j) , & - Tolerance(i,j), & - Epsilon_Scale = Epsilon_Scale ) - END DO - END DO - END SUBROUTINE complexsp_isequalwithin_rank2 - - - SUBROUTINE complexdp_isequalwithin_scalar( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Double), INTENT(IN) :: Expected, Actual, Tolerance - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[COMPLEX(Double)]' - ! Variables - REAL(Double) :: tolr, toli - REAL(Double) :: zr, zi - REAL(Double) :: dzr, dzi - LOGICAL :: Test - LOGICAL :: Verbose - CHARACTER(SL) :: Message - - ! Setup - ! ...Split expected into real and imag - zr = REAL(Expected,Double) - zi = AIMAG(Expected) - ! ...Default tolerance - tolr = REAL(Tolerance,Double) - toli = AIMAG(Tolerance) - ! ...Check optional arguments - IF ( PRESENT(Epsilon_Scale) ) THEN - IF ( Epsilon_Scale ) THEN - tolr = EPSILON(zr) * Get_Multiplier(zr) - toli = EPSILON(zi) * Get_Multiplier(zi) - END IF - END IF - ! ...Assign the test - dzr = ABS(zr - REAL(Actual,Double)) - dzi = ABS(zi - AIMAG(Actual)) - Test = (dzr < tolr) .AND. (dzi < toli) - ! ...Locally modify properties for this test - CALL Get_Property( & - UnitTest, & - Verbose = Verbose ) - Verbose = Verbose .OR. (.NOT. Test) ! Always output test failure - - - ! Assert the test - IF ( Test ) THEN - CALL Test_Passed( UnitTest ) - ELSE - CALL Test_Failed( UnitTest ) - END IF - - ! Output message - WRITE( Message, & - '(a,7x,"Expected: ",'//ZFMT//',a,& - &7x,"To within: ",'//ZFMT//',a,& - &7x,"And got: ",'//ZFMT//',a,& - &7x,"|Difference|: ",'//ZFMT//')') & - CRLF, Expected, CRLF, CMPLX(tolr,toli,Double), CRLF, Actual, CRLF, dzr, dzi - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - IF ( Verbose ) CALL Display_Message( UnitTest ) - END SUBROUTINE complexdp_isequalwithin_scalar - - - SUBROUTINE complexdp_isequalwithin_rank1( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Double), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[COMPLEX(Double)]' - ! Variables - INTEGER :: i, isize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected) - IF ( SIZE(Actual) /= isize .OR. & - SIZE(Tolerance) /= isize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0,"; Tolerance:",i0)') & - isize, SIZE(Actual), SIZE(Tolerance) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO i = 1, isize - CALL complexdp_isequalwithin_scalar( & - UnitTest , & - Expected(i) , & - Actual(i) , & - Tolerance(i), & - Epsilon_Scale = Epsilon_Scale ) - END DO - END SUBROUTINE complexdp_isequalwithin_rank1 - - - SUBROUTINE complexdp_isequalwithin_rank2( & - UnitTest , & - Expected , & - Actual , & - Tolerance , & - Epsilon_Scale ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - COMPLEX(Double), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) - LOGICAL, OPTIONAL, INTENT(IN) :: Epsilon_Scale - ! Parameters - CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest_IsEqualWithin[COMPLEX(Double)]' - ! Variables - INTEGER :: i, j, isize, jsize - CHARACTER(SL) :: Message - - ! Check array sizes - isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) - IF ( SIZE(Actual,DIM=1) /= isize .OR. & - SIZE(Actual,DIM=2) /= jsize .OR. & - SIZE(Tolerance,DIM=1) /= isize .OR. & - SIZE(Tolerance,DIM=2) /= jsize ) THEN - CALL Test_Failed( UnitTest ) - WRITE( Message, & - '("Array sizes are diffferent -- ",& - &"Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,"); Tolerance:(",i0,",",i0,")")') & - isize, jsize, & - SIZE(Actual,DIM=1), SIZE(Actual,DIM=2), & - SIZE(Tolerance,DIM=1), SIZE(Tolerance,DIM=2) - CALL Set_Property( & - UnitTest, & - Level = TEST_LEVEL, & - Procedure = PROCEDURE_NAME, & - Message = Message ) - CALL Display_Message( UnitTest ) - RETURN - ENDIF - - ! Loop over elements - DO j = 1, jsize - DO i = 1, isize - CALL complexdp_isequalwithin_scalar( & - UnitTest , & - Expected(i,j) , & - Actual(i,j) , & - Tolerance(i,j), & - Epsilon_Scale = Epsilon_Scale ) - END DO - END DO - END SUBROUTINE complexdp_isequalwithin_rank2 - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! -! NAME: -! UnitTest_DefineVersion -! -! PURPOSE: -! Subroutine to return the module version information. -! -! CALLING SEQUENCE: -! CALL UnitTest_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 UnitTest_DefineVersion( Id ) - CHARACTER(*), INTENT(OUT) :: Id - Id = MODULE_VERSION_ID - END SUBROUTINE UnitTest_DefineVersion - - -!################################################################################ -!################################################################################ -!## ## -!## ## PRIVATE MODULE ROUTINES ## ## -!## ## -!################################################################################ -!################################################################################ - -!=================== -! METHOD PROCEDURES -!=================== - -!------------------------------------------------------------------------------ -! -! NAME: -! Set_Property -! -! PURPOSE: -! Private subroutine to set the properties of a UnitTest object. -! -! All WRITE access to the UnitTest object properties should be -! done using this subroutine. -! -! CALLING SEQUENCE: -! CALL Set_Property( & -! UnitTest, & -! Verbose = Verbose , & -! Title = Title , & -! Caller = Caller , & -! Level = Level , & -! Procedure = Procedure , & -! Message = Message , & -! Test_Result = Test_Result , & -! n_Tests = n_Tests , & -! n_Passed_Tests = n_Passed_Tests , & -! n_Failed_Tests = n_Failed_Tests , & -! n_AllTests = n_AllTests , & -! n_Passed_AllTests = n_Passed_AllTests, & -! n_Failed_AllTests = n_Failed_AllTests ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN OUT) -! -! OPTIONAL INPUTS: -! Verbose: Logical to control length of reporting output. -! If == .FALSE., Only failed tests are reported. -! == .TRUE., Both failed and passed tests are reported. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! Title: Character string containing the title of the -! test to be performed. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! Caller: Character string containing the name of the -! calling subprogram. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! Level: Integer flag specifying the output message level. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! Procedure: The name of the UnitTest procedure. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! Message: Character string containing an informational -! message about the unit test performed. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! Test_Result: Logical to contain the result of unit tests -! performed -! If == .TRUE., Test passed. -! == .FALSE., Test failed. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! n_Tests: The number of tests performed for the current -! unit test type, i.e. since the last call to -! UnitTest_Setup(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! n_Passed_Tests: The number of tests passed for the current -! unit test type, i.e. since the last call to -! UnitTest_Setup(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! n_Failed_Tests: The number of tests failed for the current -! unit test type, i.e. since the last call to -! UnitTest_Setup(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! n_AllTests: The total number of tests performed, i.e. since -! the last call to UnitTest_Init(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! n_Passed_AllTests: The total number of tests passed, i.e. since -! the last call to UnitTest_Init(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! n_Failed_AllTests: The total number of tests failed, i.e. since -! the last call to UnitTest_Init(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -!------------------------------------------------------------------------------ - - PURE SUBROUTINE Set_Property( & - UnitTest , & ! Object - Verbose , & ! Optional input - Title , & ! Optional input - Caller , & ! Optional input - Level , & ! Optional input - Procedure , & ! Optional input - Message , & ! Optional input - Test_Result , & ! Optional input - n_Tests , & ! Optional input - n_Passed_Tests , & ! Optional input - n_Failed_Tests , & ! Optional input - n_AllTests , & ! Optional input - n_Passed_AllTests, & ! Optional input - n_Failed_AllTests ) ! Optional input - ! Arguments - TYPE(UnitTest_type) , INTENT(IN OUT) :: UnitTest - LOGICAL , OPTIONAL, INTENT(IN) :: Verbose - CHARACTER(*), OPTIONAL, INTENT(IN) :: Title - CHARACTER(*), OPTIONAL, INTENT(IN) :: Caller - INTEGER , OPTIONAL, INTENT(IN) :: Level - CHARACTER(*), OPTIONAL, INTENT(IN) :: Procedure - CHARACTER(*), OPTIONAL, INTENT(IN) :: Message - LOGICAL , OPTIONAL, INTENT(IN) :: Test_Result - INTEGER , OPTIONAL, INTENT(IN) :: n_Tests - INTEGER , OPTIONAL, INTENT(IN) :: n_Passed_Tests - INTEGER , OPTIONAL, INTENT(IN) :: n_Failed_Tests - INTEGER , OPTIONAL, INTENT(IN) :: n_AllTests - INTEGER , OPTIONAL, INTENT(IN) :: n_Passed_AllTests - INTEGER , OPTIONAL, INTENT(IN) :: n_Failed_AllTests - ! Set the object properties - IF ( PRESENT(Verbose ) ) UnitTest%Verbose = Verbose - IF ( PRESENT(Title ) ) UnitTest%Title = Title - IF ( PRESENT(Caller ) ) UnitTest%Caller = Caller - IF ( PRESENT(Level ) ) UnitTest%Level = Level - IF ( PRESENT(Procedure ) ) UnitTest%Procedure = Procedure - IF ( PRESENT(Message ) ) UnitTest%Message = Message - IF ( PRESENT(Test_Result ) ) UnitTest%Test_Result = Test_Result - IF ( PRESENT(n_Tests ) ) UnitTest%n_Tests = n_Tests - IF ( PRESENT(n_Passed_Tests ) ) UnitTest%n_Passed_Tests = n_Passed_Tests - IF ( PRESENT(n_Failed_Tests ) ) UnitTest%n_Failed_Tests = n_Failed_Tests - IF ( PRESENT(n_AllTests ) ) UnitTest%n_AllTests = n_AllTests - IF ( PRESENT(n_Passed_AllTests) ) UnitTest%n_Passed_AllTests = n_Passed_AllTests - IF ( PRESENT(n_Failed_AllTests) ) UnitTest%n_Failed_AllTests = n_Failed_AllTests - END SUBROUTINE Set_Property - - -!------------------------------------------------------------------------------ -! -! NAME: -! Get_Property -! -! PURPOSE: -! Private subroutine to get the properties of a UnitTest object. -! -! All READ access to the UnitTest object properties should be -! done using this subroutine. -! -! CALLING SEQUENCE: -! CALL Get_Property( & -! UnitTest, & -! Verbose = Verbose , & -! Title = Title , & -! Caller = Caller , & -! Level = Level , & -! Procedure = Procedure , & -! Message = Message , & -! Test_Result = Test_Result , & -! n_Tests = n_Tests , & -! n_Passed_Tests = n_Passed_Tests , & -! n_Failed_Tests = n_Failed_Tests , & -! n_AllTests = n_AllTests , & -! n_Passed_AllTests = n_Passed_AllTests, & -! n_Failed_AllTests = n_Failed_AllTests ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! OPTIONAL OUTPUTS: -! Verbose: Logical to control length of reporting output. -! If == .FALSE., Only failed tests are reported. -! == .TRUE., Both failed and passed tests are reported. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -! Title: Character string containing the title of the -! test to be performed. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -! Caller: Character string containing the name of the -! calling subprogram. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -! Level: Integer flag specifying the output message level. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -! Procedure: The name of the last UnitTest Procedure called. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! Message: Character string containing an informational -! message about the last unit test performed. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -! Test_Result: Logical containing the result of the last -! unit test performed -! If == .TRUE., Test passed. -! == .FALSE., Test failed. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -! n_Tests: The number of tests performed for the current -! unit test type, i.e. since the last call to -! UnitTest_Setup(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -! n_Passed_Tests: The number of tests passed for the current -! unit test type, i.e. since the last call to -! UnitTest_Setup(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -! n_Failed_Tests: The number of tests failed for the current -! unit test type, i.e. since the last call to -! UnitTest_Setup(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -! n_AllTests: The total number of tests performed, i.e. since -! the last call to UnitTest_Init(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -! n_Passed_AllTests: The total number of tests passed, i.e. since -! the last call to UnitTest_Init(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -! n_Failed_AllTests: The total number of tests failed, i.e. since -! the last call to UnitTest_Init(). -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT), OPTIONAL -! -!------------------------------------------------------------------------------ - - PURE SUBROUTINE Get_Property( & - UnitTest , & ! Object - Verbose , & ! Optional output - Title , & ! Optional output - Caller , & ! Optional output - Level , & ! Optional output - Procedure , & ! Optional output - Message , & ! Optional output - Test_Result , & ! Optional output - n_Tests , & ! Optional output - n_Passed_Tests , & ! Optional output - n_Failed_Tests , & ! Optional output - n_AllTests , & ! Optional output - n_Passed_AllTests, & ! Optional output - n_Failed_AllTests ) ! Optional output - ! Arguments - TYPE(UnitTest_type) , INTENT(IN) :: UnitTest - LOGICAL , OPTIONAL, INTENT(OUT) :: Verbose - CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title - CHARACTER(*), OPTIONAL, INTENT(OUT) :: Caller - INTEGER , OPTIONAL, INTENT(OUT) :: Level - CHARACTER(*), OPTIONAL, INTENT(OUT) :: Procedure - CHARACTER(*), OPTIONAL, INTENT(OUT) :: Message - LOGICAL , OPTIONAL, INTENT(OUT) :: Test_Result - INTEGER , OPTIONAL, INTENT(OUT) :: n_Tests - INTEGER , OPTIONAL, INTENT(OUT) :: n_Passed_Tests - INTEGER , OPTIONAL, INTENT(OUT) :: n_Failed_Tests - INTEGER , OPTIONAL, INTENT(OUT) :: n_AllTests - INTEGER , OPTIONAL, INTENT(OUT) :: n_Passed_AllTests - INTEGER , OPTIONAL, INTENT(OUT) :: n_Failed_AllTests - ! Get the object properties - IF ( PRESENT(Verbose ) ) Verbose = UnitTest%Verbose - IF ( PRESENT(Title ) ) Title = UnitTest%Title - IF ( PRESENT(Caller ) ) Caller = UnitTest%Caller - IF ( PRESENT(Level ) ) Level = UnitTest%Level - IF ( PRESENT(Procedure ) ) Procedure = UnitTest%Procedure - IF ( PRESENT(Message ) ) Message = UnitTest%Message - IF ( PRESENT(Test_Result ) ) Test_Result = UnitTest%Test_Result - IF ( PRESENT(n_Tests ) ) n_Tests = UnitTest%n_Tests - IF ( PRESENT(n_Passed_Tests ) ) n_Passed_Tests = UnitTest%n_Passed_Tests - IF ( PRESENT(n_Failed_Tests ) ) n_Failed_Tests = UnitTest%n_Failed_Tests - IF ( PRESENT(n_AllTests ) ) n_AllTests = UnitTest%n_AllTests - IF ( PRESENT(n_Passed_AllTests) ) n_Passed_AllTests = UnitTest%n_Passed_AllTests - IF ( PRESENT(n_Failed_AllTests) ) n_Failed_AllTests = UnitTest%n_Failed_AllTests - END SUBROUTINE Get_Property - - -!------------------------------------------------------------------------------ -! -! NAME: -! Test_Passed -! -! PURPOSE: -! Subroutine to increment passed test counters. -! -! CALLING SEQUENCE: -! CALL Test_Passed( UnitTest ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN OUT) -! -!------------------------------------------------------------------------------ - - SUBROUTINE Test_Passed( UnitTest ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - ! Variables - INTEGER :: n_Passed_Tests, n_Passed_AllTests - - ! Increment total test counters - CALL Test_Increment( UnitTest ) - - ! Increment the passed test counters - ! ...Get 'em - CALL Get_Property( & - UnitTest, & - n_Passed_Tests = n_Passed_Tests, & - n_Passed_AllTests = n_Passed_AllTests ) - ! ...Increment - n_Passed_Tests = n_Passed_Tests + 1 - n_Passed_AllTests = n_Passed_AllTests + 1 - ! ...Save 'em and set successful test result - CALL Set_Property( & - UnitTest, & - Test_Result = .TRUE., & - n_Passed_Tests = n_Passed_Tests, & - n_Passed_AllTests = n_Passed_AllTests ) - END SUBROUTINE Test_Passed - - -!------------------------------------------------------------------------------ -! -! NAME: -! Test_Failed -! -! PURPOSE: -! Subroutine to increment failed test counters. -! -! CALLING SEQUENCE: -! CALL Test_Failed( UnitTest ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN OUT) -! -!------------------------------------------------------------------------------ - - SUBROUTINE Test_Failed( UnitTest ) - ! Arguments - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - ! Variables - INTEGER :: n_Failed_Tests, n_Failed_AllTests - - ! Increment total test counters - CALL Test_Increment( UnitTest ) - - ! Increment the failed test counters - ! ...Get 'em - CALL Get_Property( & - UnitTest, & - n_Failed_Tests = n_Failed_Tests, & - n_Failed_AllTests = n_Failed_AllTests ) - ! ...Increment - n_Failed_Tests = n_Failed_Tests + 1 - n_Failed_AllTests = n_Failed_AllTests + 1 - ! ...Save 'em and set unsuccessful test result - CALL Set_Property( & - UnitTest, & - Test_Result = .FALSE., & - n_Failed_Tests = n_Failed_Tests, & - n_Failed_AllTests = n_Failed_AllTests ) - END SUBROUTINE Test_Failed - - -!------------------------------------------------------------------------------ -! -! NAME: -! Test_Increment -! -! PURPOSE: -! Subroutine to increment the test total counters. -! -! CALLING SEQUENCE: -! CALL Test_Increment( UnitTest ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN OUT) -! -!------------------------------------------------------------------------------ - - SUBROUTINE Test_Increment( UnitTest ) - TYPE(UnitTest_type), INTENT(IN OUT) :: UnitTest - INTEGER :: n_Tests, n_AllTests - - CALL Get_Property( & - UnitTest, & - n_Tests = n_Tests, & - n_AllTests = n_AllTests ) - - n_Tests = n_Tests + 1 - n_AllTests = n_AllTests + 1 - - CALL Set_Property( & - UnitTest, & - n_Tests = n_Tests, & - n_AllTests = n_AllTests ) - END SUBROUTINE Test_Increment - - -!------------------------------------------------------------------------------ -! -! NAME: -! Display_Message -! -! PURPOSE: -! Subroutine to display the unit test messages to stdout. -! -! CALLING SEQUENCE: -! CALL Display_Message( UnitTest ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN OUT) -! -!------------------------------------------------------------------------------ - - SUBROUTINE Display_Message( UnitTest ) - TYPE(UnitTest_type), INTENT(IN) :: UnitTest - ! Variables - INTEGER :: Level - CHARACTER(SL) :: Procedure - CHARACTER(SL) :: Message - CHARACTER(SL) :: Fmt - CHARACTER(SL) :: Prefix - CHARACTER(SL) :: Test_Info - INTEGER :: n_Spaces - - CALL Get_Property( & - UnitTest, & - Level = Level, & - Procedure = Procedure, & - Message = Message ) - - ! Set output bits manually - Test_Info = '' - SELECT CASE(Level) - CASE(INIT_LEVEL) - Prefix = '/' - n_Spaces = 1 - CASE(SETUP_LEVEL) - Prefix = '/,3x,14("-"),/' - n_Spaces = 3 - CASE(TEST_LEVEL) - Prefix = '' - n_Spaces = 5 - CALL Test_Info_String( UnitTest, Test_Info ) - CASE(REPORT_LEVEL) - Prefix = '' - n_Spaces = 3 - CASE(SUMMARY_LEVEL) - Prefix = '/,1x,16("="),/' - n_Spaces = 1 - CASE DEFAULT - Level = INTERNAL_FAIL_LEVEL - Prefix = '/,"INVALID MESSAGE LEVEL!!",/' - n_Spaces = 15 - END SELECT - - ! Write the message to stdout - WRITE(Fmt, '("(",a,i0,"x,""("",a,"") "",a,"": "",a,1x,a)")') TRIM(Prefix), n_Spaces - WRITE( *,FMT=Fmt ) TRIM(MESSAGE_LEVEL(Level)), TRIM(Procedure), TRIM(Test_Info), TRIM(Message) - - END SUBROUTINE Display_Message - - -!------------------------------------------------------------------------------ -! -! NAME: -! Test_Info_String -! -! PURPOSE: -! Subroutine to construct an info string for message output. -! -! CALLING SEQUENCE: -! CALL Test_Info_String( UnitTest, info ) -! -! OBJECT: -! UnitTest: UnitTest object. -! UNITS: N/A -! TYPE: TYPE(UnitTest_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! OUTPUTS: -! info: Character string containing the test number and -! whether the test passed or failed. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT) -! -!------------------------------------------------------------------------------ - - SUBROUTINE Test_Info_String( UnitTest, info ) - TYPE(UnitTest_Type), INTENT(IN) :: UnitTest - CHARACTER(*), INTENT(OUT) :: info - INTEGER :: n_Tests - CHARACTER(6) :: PassFail - CALL Get_Property( UnitTest, n_Tests = n_Tests ) - IF ( UnitTest_Passed( UnitTest ) ) THEN - PassFail = 'PASSED' - ELSE - PassFail = 'FAILED' - END IF - WRITE( info,'("Test#",i0,1x,a,".")') n_Tests, PassFail - END SUBROUTINE Test_Info_String - - -!==================== -! UTILITY PROCEDURES -!==================== - -!------------------------------------------------------------------------------ -! -! NAME: -! Get_Multiplier -! -! PURPOSE: -! Elemental function to compute the exponent multiplier of an input -! for use in scaling tolerance values for floating point comparisons. -! -! CALLING SEQUENCE: -! e = Get_Multiplier(x) -! -! INPUTS: -! x: Number for which the exponent multiplier is required. -! UNITS: N/A -! TYPE: REAL(Single) , or -! REAL(Double) -! DIMENSION: Scalar or any rank -! ATTRIBUTES: INTENT(IN) -! -! FUNCTION RESULT: -! e: Exponent multiplier to use in scaling tolerance values. -! UNITS: N/A -! TYPE: Same as input x. -! DIMENSION: Same as input x. -! -!------------------------------------------------------------------------------ - - ELEMENTAL FUNCTION realsp_get_multiplier(x) RESULT(e) - REAL(Single), INTENT(IN) :: x - REAL(Single) :: e - IF (x > 0.0_Single) THEN - e = 10.0_Single**FLOOR(LOG10(x)) - ELSE - e = 1.0_Single - END IF - END FUNCTION realsp_get_multiplier - - ELEMENTAL FUNCTION realdp_get_multiplier(x) RESULT(e) - REAL(Double), INTENT(IN) :: x - REAL(Double) :: e - IF (x > 0.0_Double) THEN - e = 10.0_Double**FLOOR(LOG10(x)) - ELSE - e = 1.0_Double - END IF - END FUNCTION realdp_get_multiplier - -END MODULE UnitTest_Define diff --git a/var/external/crtm_2.2.3/README b/var/external/crtm_2.3.0/README similarity index 91% rename from var/external/crtm_2.2.3/README rename to var/external/crtm_2.3.0/README index 1260f759c1..acfa09054c 100644 --- a/var/external/crtm_2.2.3/README +++ b/var/external/crtm_2.3.0/README @@ -1,7 +1,7 @@ -JCSDA CRTM v2.2.3 Build Instructions +JCSDA CRTM v2.3.x Build Instructions ==================================== -$Revision: 60152 $ +$Revision: 99117 $ CRTM SUPPORT EMAIL: ncep.list.emc.jcsda_crtm.support@noaa.gov @@ -64,6 +64,7 @@ The current list of test compiler environments in the config-setup/ directory are: $ ls config-setup/ + ftn.setup ftn.setup.csh g95-debug.setup gfortran.setup.csh pgf95.setup g95-debug.setup.csh ifort-debug.setup pgf95.setup.csh g95.setup ifort-debug.setup.csh xlf2003-debug.setup @@ -161,7 +162,7 @@ test runs looks like: Check/example program for the CRTM Forward and K-Matrix functions using big_endian coefficient datafiles - CRTM Version: REL-2.2.3 + CRTM Version: REL-2.3.x ********************************************************** @@ -192,10 +193,10 @@ directory follows the convention: _ -So, if a library version (say, v2.2.3) build was configured with --prefix=$PWD +So, if a library version (say, v2.3.0) build was configured with --prefix=$PWD then the installation directory will be - ${PWD}/crtm_v2.2.3 + ${PWD}/crtm_v2.3.0 @@ -206,10 +207,10 @@ To perform a GNU-type install, type: $ make install -For a library version, say, v2.2.3, this will create a directory called -"crtm_v2.2.3". That directory structure is shown below: +For a library version, say, v2.3.0, this will create a directory called +"crtm_v2.3.0". That directory structure is shown below: - crtm_v2.2.3/ + crtm_v2.3.0/ | |--include/ | | @@ -234,7 +235,7 @@ Let's assume the above install was moved into "/usrx/local/nceplibs", to use the library in this structure in your own application, the usual environment variables would be modified something like: - libroot="/usrx/local/nceplibs/crtm_v2.2.3" + libroot="/usrx/local/nceplibs/crtm_v2.3.0" FCFLAGS="-I${libroot}/include ${FCFLAGS}" LDFLAGS="-L${libroot}/lib ${LDFLAGS}" LIBS="-lcrtm" @@ -251,17 +252,17 @@ conventions, type: $ make nco_install -For a library version, say, v2.2.3, this will create a directory called -"crtm_v2.2.3". That directory is organised according to the current NCO structure +For a library version, say, v2.3.0, this will create a directory called +"crtm_v2.3.0". That directory is organised according to the current NCO structure on WCOSS in /nwprod/lib, as shown below: - crtm_v2.2.3/ + crtm_v2.3.0/ | - |--libcrtm_v2.2.3.a + |--libcrtm_v2.3.0.a | `--incmod/ | - `--crtm_v2.2.3/ + `--crtm_v2.3.0/ | |--accoeff_binary_io.mod |--accoeff_define.mod @@ -269,7 +270,7 @@ on WCOSS in /nwprod/lib, as shown below: |--zeeman_input_define.mod `--zeeman_utility.mod -The contents of the "crtm_v2.2.3" directory can then be moved into the official +The contents of the "crtm_v2.3.0" directory can then be moved into the official /nwprod/lib location as needed. NOTE: ********** IMPORTANT - READ THIS ********** @@ -288,9 +289,9 @@ library in this structure in your own application, the usual environment variabl would be modified something like: libroot="/usrx/local/nceplibs" - FCFLAGS="-I${libroot}/incmod/crtm_v2.2.3 ${FCFLAGS}" + FCFLAGS="-I${libroot}/incmod/crtm_v2.3.0 ${FCFLAGS}" LDFLAGS="-L${libroot} ${LDFLAGS}" - LIBS="-lcrtm_v2.2.3" + LIBS="-lcrtm_v2.3.0" (with appropriate syntax changes for csh) @@ -305,11 +306,11 @@ contents somewhere else) you can type: $ make uninstall This will DELETE the created installation directory. So, for a library version, -say, v2.2.3, if your configure script invocation was something like +say, v2.3.0, if your configure script invocation was something like $ ./configure --prefix=${PWD} ...other command line arguments... -then the "uninstall" target will delete the "${PWD}/crtm_v2.2.3" directory. +then the "uninstall" target will delete the "${PWD}/crtm_v2.3.0" directory. diff --git a/var/external/crtm_2.2.3/config-setup/g95-debug.setup b/var/external/crtm_2.3.0/config-setup/ftn.setup similarity index 56% rename from var/external/crtm_2.2.3/config-setup/g95-debug.setup rename to var/external/crtm_2.3.0/config-setup/ftn.setup index 39b1418eb7..fe5f3aa89c 100644 --- a/var/external/crtm_2.2.3/config-setup/g95-debug.setup +++ b/var/external/crtm_2.3.0/config-setup/ftn.setup @@ -1,19 +1,18 @@ #!/bin/sh #-------------------------------------------------------------------------------# -# DEBUG build settings for Linux g95 compiler +# PRODUCTION build settings for ftn compiler on EMC Linux Cray machine #-------------------------------------------------------------------------------# -export FC="g95" +export FC="ftn" export FCFLAGS="\ --fbounds-check \ --ffree-form \ --fno-second-underscore \ --ftrace=frame \ --malign-double \ --Wall" +-O3 \ +-axCore-AVX2 \ +-fp-model source \ +-convert big_endian \ +-free \ +-assume byterecl" export LDFLAGS="" export LIBS="" - diff --git a/var/external/crtm_2.3.0/config-setup/ftn.setup.csh b/var/external/crtm_2.3.0/config-setup/ftn.setup.csh new file mode 100644 index 0000000000..b516544a11 --- /dev/null +++ b/var/external/crtm_2.3.0/config-setup/ftn.setup.csh @@ -0,0 +1,9 @@ +#!/bin/csh +#-------------------------------------------------------------------------------# +# PRODUCTION build settings for ftn compiler on EMC Linux Cray machine +#-------------------------------------------------------------------------------# + +setenv FC "ftn" +setenv FCFLAGS "-O3 -axCore-AVX2 -fp-model source -convert big_endian -free -assume byterecl" +setenv LDFLAGS "" +setenv LIBS "" diff --git a/var/external/crtm_2.2.3/config-setup/g95-debug.setup.csh b/var/external/crtm_2.3.0/config-setup/g95-debug.setup.csh similarity index 100% rename from var/external/crtm_2.2.3/config-setup/g95-debug.setup.csh rename to var/external/crtm_2.3.0/config-setup/g95-debug.setup.csh diff --git a/var/external/crtm_2.2.3/config-setup/g95.setup.csh b/var/external/crtm_2.3.0/config-setup/g95.setup.csh similarity index 100% rename from var/external/crtm_2.2.3/config-setup/g95.setup.csh rename to var/external/crtm_2.3.0/config-setup/g95.setup.csh diff --git a/var/external/crtm_2.2.3/config-setup/gfortran-debug.setup b/var/external/crtm_2.3.0/config-setup/gfortran-debug.setup similarity index 97% rename from var/external/crtm_2.2.3/config-setup/gfortran-debug.setup rename to var/external/crtm_2.3.0/config-setup/gfortran-debug.setup index 7b180d172e..15a2ca1c43 100644 --- a/var/external/crtm_2.2.3/config-setup/gfortran-debug.setup +++ b/var/external/crtm_2.3.0/config-setup/gfortran-debug.setup @@ -15,7 +15,7 @@ export FCFLAGS="\ -ggdb \ -Wall \ -Wconversion \ --std=f2003" +-std=f2008" export LDFLAGS="" diff --git a/var/external/crtm_2.2.3/config-setup/gfortran-debug.setup.csh b/var/external/crtm_2.3.0/config-setup/gfortran-debug.setup.csh similarity index 90% rename from var/external/crtm_2.2.3/config-setup/gfortran-debug.setup.csh rename to var/external/crtm_2.3.0/config-setup/gfortran-debug.setup.csh index 0c6bb94674..b34c005828 100644 --- a/var/external/crtm_2.2.3/config-setup/gfortran-debug.setup.csh +++ b/var/external/crtm_2.3.0/config-setup/gfortran-debug.setup.csh @@ -4,6 +4,6 @@ #-------------------------------------------------------------------------------# setenv FC "gfortran" -setenv FCFLAGS "-fbounds-check -fimplicit-none -ffpe-trap=overflow,zero,invalid -ffree-form -fno-second-underscore -frecord-marker=4 -ggdb -Wall -Wconversion -std=f2003" +setenv FCFLAGS "-fbounds-check -fimplicit-none -ffpe-trap=overflow,zero,invalid -ffree-form -fno-second-underscore -frecord-marker=4 -ggdb -Wall -Wconversion -std=f2008" setenv LDFLAGS "" setenv LIBS "" diff --git a/var/external/crtm_2.2.3/config-setup/gfortran.setup b/var/external/crtm_2.3.0/config-setup/gfortran.setup similarity index 97% rename from var/external/crtm_2.2.3/config-setup/gfortran.setup rename to var/external/crtm_2.3.0/config-setup/gfortran.setup index dd262b5087..25eddf4689 100644 --- a/var/external/crtm_2.2.3/config-setup/gfortran.setup +++ b/var/external/crtm_2.3.0/config-setup/gfortran.setup @@ -15,7 +15,7 @@ export FCFLAGS="\ -ggdb \ -Wall \ -Wconversion \ --std=f2003" +-std=f2008" export LDFLAGS="" diff --git a/var/external/crtm_2.2.3/config-setup/gfortran.setup.csh b/var/external/crtm_2.3.0/config-setup/gfortran.setup.csh similarity index 96% rename from var/external/crtm_2.2.3/config-setup/gfortran.setup.csh rename to var/external/crtm_2.3.0/config-setup/gfortran.setup.csh index d777adb952..0aa63144d8 100644 --- a/var/external/crtm_2.2.3/config-setup/gfortran.setup.csh +++ b/var/external/crtm_2.3.0/config-setup/gfortran.setup.csh @@ -4,6 +4,6 @@ #-------------------------------------------------------------------------------# setenv FC "gfortran" -setenv FCFLAGS "-O3 -fimplicit-none -ffree-form -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -Wall -Wconversion -std=f2003" +setenv FCFLAGS "-O3 -fimplicit-none -ffree-form -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -Wall -Wconversion -std=f2008" setenv LDFLAGS "" setenv LIBS "" diff --git a/var/external/crtm_2.2.3/config-setup/ifort-debug.setup b/var/external/crtm_2.3.0/config-setup/ifort-debug.setup similarity index 90% rename from var/external/crtm_2.2.3/config-setup/ifort-debug.setup rename to var/external/crtm_2.3.0/config-setup/ifort-debug.setup index 202a673f92..8b1376c4ce 100644 --- a/var/external/crtm_2.2.3/config-setup/ifort-debug.setup +++ b/var/external/crtm_2.3.0/config-setup/ifort-debug.setup @@ -8,10 +8,10 @@ export FC="ifort" export FCFLAGS="\ -g \ -check bounds \ --e03 \ +-e08 \ -traceback \ -free \ --assume byterecl \ +-assume byterecl,realloc_lhs \ -fp-stack-check \ -mieee-fp" diff --git a/var/external/crtm_2.2.3/config-setup/ifort-debug.setup.csh b/var/external/crtm_2.3.0/config-setup/ifort-debug.setup.csh similarity index 71% rename from var/external/crtm_2.2.3/config-setup/ifort-debug.setup.csh rename to var/external/crtm_2.3.0/config-setup/ifort-debug.setup.csh index 1129a27237..82c5fb835a 100644 --- a/var/external/crtm_2.2.3/config-setup/ifort-debug.setup.csh +++ b/var/external/crtm_2.3.0/config-setup/ifort-debug.setup.csh @@ -4,6 +4,6 @@ #-------------------------------------------------------------------------------# setenv FC "ifort" -setenv FCFLAGS "-g -check bounds -e03 -traceback -free -assume byterecl -fp-stack-check -mieee-fp" +setenv FCFLAGS "-g -check bounds -e08 -traceback -free -assume byterecl,realloc_lhs -fp-stack-check -mieee-fp" setenv LDFLAGS "" setenv LIBS "" diff --git a/var/external/crtm_2.2.3/config-setup/ifort.setup b/var/external/crtm_2.3.0/config-setup/ifort.setup similarity index 90% rename from var/external/crtm_2.2.3/config-setup/ifort.setup rename to var/external/crtm_2.3.0/config-setup/ifort.setup index 01eafee3f9..7700ab5557 100644 --- a/var/external/crtm_2.2.3/config-setup/ifort.setup +++ b/var/external/crtm_2.3.0/config-setup/ifort.setup @@ -8,8 +8,9 @@ export FC="ifort" export FCFLAGS="\ -O3 \ -fp-model source \ +-e08 \ -free \ --assume byterecl" +-assume byterecl,realloc_lhs" export LDFLAGS="" diff --git a/var/external/crtm_2.2.3/config-setup/ifort.setup.csh b/var/external/crtm_2.3.0/config-setup/ifort.setup.csh similarity index 78% rename from var/external/crtm_2.2.3/config-setup/ifort.setup.csh rename to var/external/crtm_2.3.0/config-setup/ifort.setup.csh index 2be9665817..18ec964671 100644 --- a/var/external/crtm_2.2.3/config-setup/ifort.setup.csh +++ b/var/external/crtm_2.3.0/config-setup/ifort.setup.csh @@ -4,6 +4,6 @@ #-------------------------------------------------------------------------------# setenv FC "ifort" -setenv FCFLAGS "-O3 -fp-model source -free -assume byterecl" +setenv FCFLAGS "-O2 -fp-model source -free -e08 -assume byterecl,realloc_lhs" setenv LDFLAGS "" setenv LIBS "" diff --git a/var/external/crtm_2.2.3/config-setup/pgf95-debug.setup b/var/external/crtm_2.3.0/config-setup/pgf95-debug.setup similarity index 100% rename from var/external/crtm_2.2.3/config-setup/pgf95-debug.setup rename to var/external/crtm_2.3.0/config-setup/pgf95-debug.setup diff --git a/var/external/crtm_2.2.3/config-setup/pgf95-debug.setup.csh b/var/external/crtm_2.3.0/config-setup/pgf95-debug.setup.csh similarity index 100% rename from var/external/crtm_2.2.3/config-setup/pgf95-debug.setup.csh rename to var/external/crtm_2.3.0/config-setup/pgf95-debug.setup.csh diff --git a/var/external/crtm_2.2.3/config-setup/pgf95.setup b/var/external/crtm_2.3.0/config-setup/pgf95.setup similarity index 100% rename from var/external/crtm_2.2.3/config-setup/pgf95.setup rename to var/external/crtm_2.3.0/config-setup/pgf95.setup diff --git a/var/external/crtm_2.2.3/config-setup/pgf95.setup.csh b/var/external/crtm_2.3.0/config-setup/pgf95.setup.csh similarity index 100% rename from var/external/crtm_2.2.3/config-setup/pgf95.setup.csh rename to var/external/crtm_2.3.0/config-setup/pgf95.setup.csh diff --git a/var/external/crtm_2.2.3/config-setup/xlf2003-debug.setup b/var/external/crtm_2.3.0/config-setup/xlf2003-debug.setup similarity index 95% rename from var/external/crtm_2.2.3/config-setup/xlf2003-debug.setup rename to var/external/crtm_2.3.0/config-setup/xlf2003-debug.setup index d9b42bc8a9..3fef057067 100644 --- a/var/external/crtm_2.2.3/config-setup/xlf2003-debug.setup +++ b/var/external/crtm_2.3.0/config-setup/xlf2003-debug.setup @@ -13,7 +13,7 @@ export FCFLAGS="\ -qflttrap=ov:zero:en \ -qinitauto \ -qhalt=W \ --qlanglvl=2003pure \ +-qlanglvl=2008pure \ -qmaxmem=-1 \ -qsuffix=f=f90:cpp=fpp:cpp=F90" diff --git a/var/external/crtm_2.2.3/config-setup/xlf2003-debug.setup.csh b/var/external/crtm_2.3.0/config-setup/xlf2003-debug.setup.csh similarity index 85% rename from var/external/crtm_2.2.3/config-setup/xlf2003-debug.setup.csh rename to var/external/crtm_2.3.0/config-setup/xlf2003-debug.setup.csh index e15a81144d..9cac6cb8ed 100644 --- a/var/external/crtm_2.2.3/config-setup/xlf2003-debug.setup.csh +++ b/var/external/crtm_2.3.0/config-setup/xlf2003-debug.setup.csh @@ -4,6 +4,6 @@ #-------------------------------------------------------------------------------# setenv FC "xlf2003" -setenv FCFLAGS "-qcheck -qdbg -qextchk -qfloat=nomaf:rndsngl -qflttrap=ov:zero:en -qinitauto -qhalt=W -qlanglvl=2003pure -qmaxmem=-1 -qsuffix=f=f90:cpp=fpp:cpp=F90" +setenv FCFLAGS "-qcheck -qdbg -qextchk -qfloat=nomaf:rndsngl -qflttrap=ov:zero:en -qinitauto -qhalt=W -qlanglvl=2008pure -qmaxmem=-1 -qsuffix=f=f90:cpp=fpp:cpp=F90" setenv LDFLAGS "" setenv LIBS "" diff --git a/var/external/crtm_2.2.3/config-setup/xlf2003.setup b/var/external/crtm_2.3.0/config-setup/xlf2003.setup similarity index 95% rename from var/external/crtm_2.2.3/config-setup/xlf2003.setup rename to var/external/crtm_2.3.0/config-setup/xlf2003.setup index 98a349e9d4..d3e91c3d00 100644 --- a/var/external/crtm_2.2.3/config-setup/xlf2003.setup +++ b/var/external/crtm_2.3.0/config-setup/xlf2003.setup @@ -9,7 +9,7 @@ export FCFLAGS="\ -qdbg \ -qarch=auto \ -qhalt=W \ --qlanglvl=2003pure \ +-qlanglvl=2008pure \ -qsuffix=f=f90:cpp=F90 \ -qstrict \ -NS32768 \ diff --git a/var/external/crtm_2.2.3/config-setup/xlf2003.setup.csh b/var/external/crtm_2.3.0/config-setup/xlf2003.setup.csh similarity index 84% rename from var/external/crtm_2.2.3/config-setup/xlf2003.setup.csh rename to var/external/crtm_2.3.0/config-setup/xlf2003.setup.csh index 174da5ddc6..9c0f255e1c 100644 --- a/var/external/crtm_2.2.3/config-setup/xlf2003.setup.csh +++ b/var/external/crtm_2.3.0/config-setup/xlf2003.setup.csh @@ -4,6 +4,6 @@ #-------------------------------------------------------------------------------# setenv FC "xlf2003" -setenv FCFLAGS "-qdbg -qarch=auto -qhalt=W -qlanglvl=2003pure -qsuffix=f=f90:cpp=fpp:cpp=F90 -qstrict -NS32768 -O3" +setenv FCFLAGS "-qdbg -qarch=auto -qhalt=W -qlanglvl=2008pure -qsuffix=f=f90:cpp=fpp:cpp=F90 -qstrict -NS32768 -O3" setenv LDFLAGS "-O3" setenv LIBS "-lmass -lm" diff --git a/var/external/crtm_2.3.0/crtm_release_notes.txt b/var/external/crtm_2.3.0/crtm_release_notes.txt new file mode 100644 index 0000000000..df282085d0 --- /dev/null +++ b/var/external/crtm_2.3.0/crtm_release_notes.txt @@ -0,0 +1,39 @@ +Release Notes: CRTM library v2.3.0 + +$Revision: 99117 $ + +v2.3.0 - released November 21, 2017 + + * Made scientific changes to include: + 1. All-Sky radiance simulation under cloud_fraction condition. + 2. Use of all-sky transmittances in FASTEM-X reflection correction. + 3. Improve surface reflectance in radiative transfer calculation for Microwave under + scattering condition. + 4. Add ATMS SeaIce emissivity module. + 5. Fix the simulation near 3.9 mscron by adding solar contribution in ADA_Module. + 6. Updates of CRTM Coefficients for ABI_GOES-R, AHI_Himawari-8. + 7. Updates of CRTM antenna correction coefficients for MHS_N19/Metop-a. + 8. Update AIRS coefficients for including NLTE correction. + 9. Add new coefficients for: CrIS-fsrB1/B2/B3_NPP, CrIS*_N20, CrIS-fsr431_npp/n20, + AHI_Himawari-9, ABI_G16, VIIRS-JPSS1, ATMS_N20, ATMS_N20-SRF, COWVR, tropics_designed_v1. + + * Made structure change and bug fix: + 1. Bug fix for the function CRTM_Compute_SfcOptics_AD in CRTM_SfcOptics.f90 + 2. Change CRTM_MW_Water_SfcOptics.f90 interface variable dimension. + 3. Remove the channel number in the “all channels” included CRTM coefficient files, + e.g. “cris1305_npp” would become simple “cris_npp”. + 4. Remove “ERRMSG” option in the [DE]ALLOCATE functions to fix an error when using + gfortran compiler. + 5. Change “Data Statement” to “Array Assignment” in 6 Surface Emissivity modules + to fix a compile failure when using -e08 in ifort/16.0.+. + 6. Add CloudFraction test in check_crtm.fpp. + + * In this release, there is a new feature for the simulation of all-sky (cloudy) + radiance, which utilizes Fortran class function, and now CRTM will support the + new compiler with class function, such as ifort version (14.0+, 15.0+, 16.0+), + gfortran version (gcc 4.8.5, 4.9, 5.4, 6.4, 7.2), pgi/17.3, ftn/2.3.0. + + * Compute resource information + + N/A. This is a library used in the GSI. + diff --git a/var/external/crtm_2.2.3/libsrc/ACCoeff_Binary_IO.f90 b/var/external/crtm_2.3.0/libsrc/ACCoeff_Binary_IO.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ACCoeff_Binary_IO.f90 rename to var/external/crtm_2.3.0/libsrc/ACCoeff_Binary_IO.f90 index 3e47a55339..73c50d279c 100644 --- a/var/external/crtm_2.2.3/libsrc/ACCoeff_Binary_IO.f90 +++ b/var/external/crtm_2.3.0/libsrc/ACCoeff_Binary_IO.f90 @@ -44,7 +44,7 @@ MODULE ACCoeff_Binary_IO ! Module parameters ! ----------------- CHARACTER(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = & - '$Id: ACCoeff_Binary_IO.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ACCoeff_Binary_IO.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE' ! Default message length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/ACCoeff_Define.f90 b/var/external/crtm_2.3.0/libsrc/ACCoeff_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ACCoeff_Define.f90 rename to var/external/crtm_2.3.0/libsrc/ACCoeff_Define.f90 index 4b2a4cc885..b0e21bd954 100644 --- a/var/external/crtm_2.2.3/libsrc/ACCoeff_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/ACCoeff_Define.f90 @@ -63,7 +63,7 @@ MODULE ACCoeff_Define ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: ACCoeff_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ACCoeff_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(Double), PARAMETER :: ZERO = 0.0_Double REAL(Double), PARAMETER :: ONE = 1.0_Double diff --git a/var/external/crtm_2.2.3/libsrc/ADA_Module.f90 b/var/external/crtm_2.3.0/libsrc/ADA_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ADA_Module.f90 rename to var/external/crtm_2.3.0/libsrc/ADA_Module.f90 index c3407a9e85..32bb31f216 100644 --- a/var/external/crtm_2.2.3/libsrc/ADA_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/ADA_Module.f90 @@ -388,7 +388,7 @@ SUBROUTINE CRTM_AMOM_layer( n_streams, & ! Input, number of streams END IF ! compute visible part for visible channels during daytime - IF( RTV%Visible_Flag_true ) THEN + IF( RTV%Solar_Flag_true ) THEN N2 = 2 * nZ N2_1 = N2 - 1 source_up = ZERO @@ -822,7 +822,7 @@ SUBROUTINE CRTM_AMOM_layer_TL( n_streams, & ! Input, number of streams ! ! for visible channels at daytime - IF( RTV%Visible_Flag_true ) THEN + IF( RTV%Solar_Flag_true ) THEN N2 = 2 * nZ N2_1 = N2 - 1 V0 = ZERO @@ -1252,7 +1252,7 @@ SUBROUTINE CRTM_AMOM_layer_AD( n_streams, & ! Input, number of streams thermal_up_AD(:) = source_up_AD(:) thermal_down_AD(:) = source_down_AD(:) - IF( RTV%Visible_Flag_true ) THEN + IF( RTV%Solar_Flag_true ) THEN N2 = 2 * nZ N2_1 = N2 - 1 diff --git a/var/external/crtm_2.2.3/libsrc/AOvar_Define.f90 b/var/external/crtm_2.3.0/libsrc/AOvar_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/AOvar_Define.f90 rename to var/external/crtm_2.3.0/libsrc/AOvar_Define.f90 index e0d9001591..56fcfbc5c5 100644 --- a/var/external/crtm_2.2.3/libsrc/AOvar_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/AOvar_Define.f90 @@ -61,7 +61,7 @@ MODULE AOvar_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: AOvar_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: AOvar_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: AOVAR_RELEASE = 1 ! This determines structure and file formats. INTEGER, PARAMETER :: AOVAR_VERSION = 1 ! This is just the default data version. diff --git a/var/external/crtm_2.2.3/libsrc/ASvar_Define.f90 b/var/external/crtm_2.3.0/libsrc/ASvar_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ASvar_Define.f90 rename to var/external/crtm_2.3.0/libsrc/ASvar_Define.f90 index 27fa28ef14..4c54ac85ff 100644 --- a/var/external/crtm_2.2.3/libsrc/ASvar_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/ASvar_Define.f90 @@ -64,7 +64,7 @@ MODULE ASvar_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: ASvar_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ASvar_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: ASVAR_RELEASE = 1 ! This determines structure and file formats. INTEGER, PARAMETER :: ASVAR_VERSION = 1 ! This is just the default data version. diff --git a/var/external/crtm_2.2.3/libsrc/AerosolCoeff_Binary_IO.f90 b/var/external/crtm_2.3.0/libsrc/AerosolCoeff_Binary_IO.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/AerosolCoeff_Binary_IO.f90 rename to var/external/crtm_2.3.0/libsrc/AerosolCoeff_Binary_IO.f90 index 4a3e7c66b8..6c1cfb7160 100644 --- a/var/external/crtm_2.2.3/libsrc/AerosolCoeff_Binary_IO.f90 +++ b/var/external/crtm_2.3.0/libsrc/AerosolCoeff_Binary_IO.f90 @@ -44,7 +44,7 @@ MODULE AerosolCoeff_Binary_IO ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: AerosolCoeff_Binary_IO.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: AerosolCoeff_Binary_IO.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE' ! Default message length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/AerosolCoeff_Define.f90 b/var/external/crtm_2.3.0/libsrc/AerosolCoeff_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/AerosolCoeff_Define.f90 rename to var/external/crtm_2.3.0/libsrc/AerosolCoeff_Define.f90 index 656074ff37..6428899842 100644 --- a/var/external/crtm_2.2.3/libsrc/AerosolCoeff_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/AerosolCoeff_Define.f90 @@ -59,7 +59,7 @@ MODULE AerosolCoeff_Define ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: AerosolCoeff_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: AerosolCoeff_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Current valid release and version numbers INTEGER, PARAMETER :: AEROSOLCOEFF_RELEASE = 3 ! This determines structure and file formats. INTEGER, PARAMETER :: AEROSOLCOEFF_VERSION = 1 ! This is just the data version for the release. diff --git a/var/external/crtm_2.2.3/libsrc/Azimuth_Emissivity_F6_Module.f90 b/var/external/crtm_2.3.0/libsrc/Azimuth_Emissivity_F6_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Azimuth_Emissivity_F6_Module.f90 rename to var/external/crtm_2.3.0/libsrc/Azimuth_Emissivity_F6_Module.f90 index 0795fbac9d..0c67425d34 100644 --- a/var/external/crtm_2.2.3/libsrc/Azimuth_Emissivity_F6_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/Azimuth_Emissivity_F6_Module.f90 @@ -40,7 +40,7 @@ MODULE Azimuth_Emissivity_F6_Module ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Azimuth_Emissivity_F6_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Azimuth_Emissivity_F6_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: POINT5 = 0.5_fp diff --git a/var/external/crtm_2.2.3/libsrc/Azimuth_Emissivity_Module.f90 b/var/external/crtm_2.3.0/libsrc/Azimuth_Emissivity_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Azimuth_Emissivity_Module.f90 rename to var/external/crtm_2.3.0/libsrc/Azimuth_Emissivity_Module.f90 index 3d68a247e0..ec31383ff2 100644 --- a/var/external/crtm_2.2.3/libsrc/Azimuth_Emissivity_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/Azimuth_Emissivity_Module.f90 @@ -42,7 +42,7 @@ MODULE Azimuth_Emissivity_Module ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Azimuth_Emissivity_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Azimuth_Emissivity_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: ONE = 1.0_fp diff --git a/var/external/crtm_2.2.3/libsrc/Binary_File_Utility.f90 b/var/external/crtm_2.3.0/libsrc/Binary_File_Utility.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Binary_File_Utility.f90 rename to var/external/crtm_2.3.0/libsrc/Binary_File_Utility.f90 index a4be9d794d..b8c820e06f 100644 --- a/var/external/crtm_2.2.3/libsrc/Binary_File_Utility.f90 +++ b/var/external/crtm_2.3.0/libsrc/Binary_File_Utility.f90 @@ -53,7 +53,7 @@ MODULE Binary_File_Utility ! Parameters ! ---------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Binary_File_Utility.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Binary_File_Utility.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Magic number header value for byte-swap checks INTEGER(Long), PARAMETER :: MAGIC_NUMBER = 123456789_Long ! Integer "logicals" for I/O diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_AOD_Module.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_AOD_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_AOD_Module.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_AOD_Module.f90 index 416773a56e..a619c2add8 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_AOD_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_AOD_Module.f90 @@ -69,7 +69,7 @@ MODULE CRTM_AOD_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_AOD_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_AOD_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Adjoint_Module.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Adjoint_Module.f90 similarity index 60% rename from var/external/crtm_2.2.3/libsrc/CRTM_Adjoint_Module.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Adjoint_Module.f90 index 4115a56c6f..edf44fe5cd 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Adjoint_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Adjoint_Module.f90 @@ -31,21 +31,31 @@ MODULE CRTM_Adjoint_Module SpcCoeff_IsInfraredSensor , & SpcCoeff_IsMicrowaveSensor, & SpcCoeff_IsVisibleSensor - USE CRTM_Atmosphere_Define, ONLY: CRTM_Atmosphere_type, & - CRTM_Atmosphere_Destroy, & - CRTM_Atmosphere_IsValid, & - CRTM_Atmosphere_AddLayerCopy, & + USE CRTM_Atmosphere_Define, ONLY: CRTM_Atmosphere_type , & + CRTM_Atmosphere_Destroy , & + CRTM_Atmosphere_IsValid , & + CRTM_Atmosphere_Zero , & + CRTM_Atmosphere_AddLayerCopy , & + CRTM_Atmosphere_NonVariableCopy, & CRTM_Get_PressureLevelIdx - USE CRTM_Surface_Define, ONLY: CRTM_Surface_type, & - CRTM_Surface_IsValid + USE CRTM_Surface_Define, ONLY: CRTM_Surface_type , & + CRTM_Surface_IsValid , & + CRTM_Surface_NonVariableCopy USE CRTM_Geometry_Define, ONLY: CRTM_Geometry_type, & CRTM_Geometry_IsValid USE CRTM_ChannelInfo_Define, ONLY: CRTM_ChannelInfo_type, & CRTM_ChannelInfo_n_Channels + USE CRTM_RTSolution_Define, ONLY: CRTM_RTSolution_type, & + CRTM_RTSolution_Destroy, & + CRTM_RTSolution_Zero USE CRTM_Options_Define, ONLY: CRTM_Options_type, & CRTM_Options_IsValid - USE CRTM_Atmosphere, ONLY: CRTM_Atmosphere_AddLayers, & - CRTM_Atmosphere_AddLayers_AD + USE CRTM_Atmosphere, ONLY: CRTM_Atmosphere_AddLayers , & + CRTM_Atmosphere_AddLayers_AD , & + CRTM_Atmosphere_IsFractional , & + CRTM_Atmosphere_Coverage , & + CRTM_Atmosphere_ClearSkyCopy , & + CRTM_Atmosphere_ClearSkyCopy_AD USE CRTM_GeometryInfo_Define, ONLY: CRTM_GeometryInfo_type, & CRTM_GeometryInfo_SetValue, & CRTM_GeometryInfo_GetValue @@ -69,22 +79,22 @@ MODULE CRTM_Adjoint_Module CRTM_Compute_AerosolScatter_AD USE CRTM_CloudScatter, ONLY: CRTM_Compute_CloudScatter , & CRTM_Compute_CloudScatter_AD - USE CRTM_AtmOptics, ONLY: AOvar_type , & - AOvar_Create, & - CRTM_No_Scattering , & - CRTM_Include_Scattering , & - CRTM_Compute_Transmittance , & - CRTM_Compute_Transmittance_AD, & - CRTM_Combine_AtmOptics , & - CRTM_Combine_AtmOptics_AD - USE CRTM_SfcOptics_Define, ONLY: CRTM_SfcOptics_type , & + USE CRTM_AtmOptics, ONLY: CRTM_Include_Scattering , & + CRTM_Compute_Transmittance , & + CRTM_Compute_Transmittance_AD , & + CRTM_AtmOptics_Combine , & + CRTM_AtmOptics_Combine_AD , & + CRTM_AtmOptics_NoScatterCopy , & + CRTM_AtmOptics_NoScatterCopy_AD + USE CRTM_SfcOptics_Define, ONLY: OPERATOR(+) , & + CRTM_SfcOptics_type , & CRTM_SfcOptics_Associated, & CRTM_SfcOptics_Create , & - CRTM_SfcOptics_Destroy + CRTM_SfcOptics_Destroy , & + CRTM_SfcOptics_Zero USE CRTM_SfcOptics, ONLY: CRTM_Compute_SurfaceT , & CRTM_Compute_SurfaceT_AD - USE CRTM_RTSolution, ONLY: CRTM_RTSolution_type , & - CRTM_Compute_nStreams , & + USE CRTM_RTSolution, ONLY: CRTM_Compute_nStreams , & CRTM_Compute_RTSolution , & CRTM_Compute_RTSolution_AD USE CRTM_AntennaCorrection, ONLY: CRTM_Compute_AntCorr, & @@ -104,8 +114,14 @@ MODULE CRTM_Adjoint_Module USE NLTECoeff_Define, ONLY: NLTECoeff_Associated USE CRTM_Planck_Functions, ONLY: CRTM_Planck_Temperature , & CRTM_Planck_Temperature_AD + USE CRTM_CloudCover_Define, ONLY: CRTM_CloudCover_type ! Internal variable definition modules + ! ...AtmOptics + USE AOvar_Define, ONLY: AOvar_type, & + AOvar_Associated, & + AOvar_Destroy , & + AOvar_Create ! ...CloudScatter USE CSvar_Define, ONLY: CSvar_type, & CSvar_Associated, & @@ -143,7 +159,7 @@ MODULE CRTM_Adjoint_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Adjoint_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Adjoint_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS @@ -297,28 +313,33 @@ FUNCTION CRTM_Adjoint( & ! Local variables CHARACTER(256) :: Message LOGICAL :: Options_Present - LOGICAL :: Check_Input - LOGICAL :: User_Emissivity, User_Direct_Reflectivity, User_N_Streams - LOGICAL :: User_AntCorr, Compute_AntCorr - LOGICAL :: Apply_NLTE_Correction + LOGICAL :: compute_antenna_correction LOGICAL :: Atmosphere_Invalid, Surface_Invalid, Geometry_Invalid, Options_Invalid - INTEGER :: RT_Algorithm_Id + INTEGER :: Status_FWD, Status_AD INTEGER :: iFOV - INTEGER :: nc, na INTEGER :: n, n_Sensors, SensorIndex INTEGER :: l, n_Channels, ChannelIndex INTEGER :: m, n_Profiles - INTEGER :: j, ln + INTEGER :: ln INTEGER :: n_Full_Streams, mth_Azi + INTEGER :: cloud_coverage_flag REAL(fp) :: Source_ZA REAL(fp) :: Wavenumber REAL(fp) :: transmittance, transmittance_AD + REAL(fp) :: transmittance_clear, transmittance_clear_AD + REAL(fp) :: r_cloudy ! Local ancillary input structure TYPE(CRTM_AncillaryInput_type) :: AncillaryInput ! Local options structure for default values - TYPE(CRTM_Options_type) :: Default_Options + TYPE(CRTM_Options_type) :: Default_Options, Opt ! Local atmosphere structure for extra layering TYPE(CRTM_Atmosphere_type) :: Atm, Atm_AD + ! Clear sky structures + TYPE(CRTM_Atmosphere_type) :: Atm_Clear , Atm_Clear_AD + TYPE(CRTM_AtmOptics_type) :: AtmOptics_Clear , AtmOptics_Clear_AD + TYPE(CRTM_SfcOptics_type) :: SfcOptics_Clear , SfcOptics_Clear_AD + TYPE(CRTM_RTSolution_type) :: RTSolution_Clear, RTSolution_Clear_AD + TYPE(RTV_type) :: RTV_Clear ! Component variables TYPE(CRTM_GeometryInfo_type) :: GeometryInfo TYPE(CRTM_Predictor_type) :: Predictor, Predictor_AD @@ -332,7 +353,9 @@ FUNCTION CRTM_Adjoint( & TYPE(AOvar_type) :: AOvar ! AtmOptics TYPE(RTV_type) :: RTV ! RTSolution ! NLTE correction term predictors - TYPE(NLTE_Predictor_type) :: NLTE_Predictor, NLTE_Predictor_AD + TYPE(NLTE_Predictor_type) :: NLTE_Predictor, NLTE_Predictor_AD + ! Cloud cover object + TYPE(CRTM_CloudCover_type) :: CloudCover, CloudCover_AD ! ------ @@ -387,6 +410,10 @@ FUNCTION CRTM_Adjoint( & END IF + ! Reinitialise the output RTSolution + CALL CRTM_RTSolution_Zero(RTSolution) + + ! Allocate the profile independent surface optics local structure CALL CRTM_SfcOptics_Create( SfcOptics , MAX_N_ANGLES, MAX_N_STOKES ) CALL CRTM_SfcOptics_Create( SfcOptics_AD, MAX_N_ANGLES, MAX_N_STOKES ) @@ -423,90 +450,24 @@ FUNCTION CRTM_Adjoint( & ! Copy over forward "non-variable" inputs to adjoint outputs - ! ...Atmosphere - Atmosphere_AD(m)%Climatology = Atmosphere(m)%Climatology - DO j = 1, Atmosphere(m)%n_Absorbers - Atmosphere_AD(m)%Absorber_ID(j) = Atmosphere(m)%Absorber_ID(j) - Atmosphere_AD(m)%Absorber_Units(j) = Atmosphere(m)%Absorber_Units(j) - END DO - ! Loop over and assign cloud types - DO nc = 1, Atmosphere(m)%n_Clouds - Atmosphere_AD(m)%Cloud(nc)%Type = Atmosphere(m)%Cloud(nc)%Type - END DO - ! Loop over and assign aerosol types - DO na = 1, Atmosphere(m)%n_Aerosols - Atmosphere_AD(m)%Aerosol(na)%Type = Atmosphere(m)%Aerosol(na)%Type - END DO - ! ...Surface - Surface_AD(m)%Land_Coverage = Surface(m)%Land_Coverage - Surface_AD(m)%Water_Coverage = Surface(m)%Water_Coverage - Surface_AD(m)%Snow_Coverage = Surface(m)%Snow_Coverage - Surface_AD(m)%Ice_Coverage = Surface(m)%Ice_Coverage - Surface_AD(m)%Land_Type = Surface(m)%Land_Type - Surface_AD(m)%Water_Type = Surface(m)%Water_Type - Surface_AD(m)%Snow_Type = Surface(m)%Snow_Type - Surface_AD(m)%Ice_Type = Surface(m)%Ice_Type - + CALL CRTM_Atmosphere_NonVariableCopy( Atmosphere(m), Atmosphere_AD(m) ) + CALL CRTM_Surface_NonVariableCopy( Surface(m), Surface_AD(m) ) ! Check the optional Options structure argument - ! ...Specify default actions - Check_Input = Default_Options%Check_Input - User_Emissivity = Default_Options%Use_Emissivity - User_AntCorr = Default_Options%Use_Antenna_Correction - Apply_NLTE_Correction = Default_Options%Apply_NLTE_Correction - RT_Algorithm_Id = Default_Options%RT_Algorithm_Id - User_N_Streams = Default_Options%Use_N_Streams - ! ...Check the Options argument - IF (Options_Present) THEN - ! Override input checker with option - Check_Input = Options(m)%Check_Input - ! Check if the supplied emissivity should be used - User_Emissivity = Options(m)%Use_Emissivity - IF ( Options(m)%Use_Emissivity ) THEN - ! Are the channel dimensions consistent - IF ( Options(m)%n_Channels < n_Channels ) THEN - Error_Status = FAILURE - WRITE( Message,'( "Input Options channel dimension (", i0, ") is less ", & - &"than the number of requested channels (",i0, ")" )' ) & - Options(m)%n_Channels, n_Channels - CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) - RETURN - END IF - ! Check if the supplied direct reflectivity should be used - User_Direct_Reflectivity = Options(m)%Use_Direct_Reflectivity - END IF - ! Check if antenna correction should be attempted - User_AntCorr = Options(m)%Use_Antenna_Correction - ! Set NLTE correction option - Apply_NLTE_Correction = Options(m)%Apply_NLTE_Correction - - + Opt = Default_Options + IF ( Options_Present ) THEN + Opt = Options(m) ! Copy over ancillary input AncillaryInput%SSU = Options(m)%SSU AncillaryInput%Zeeman = Options(m)%Zeeman - ! Copy over surface optics input - SfcOptics%Use_New_MWSSEM = .NOT. Options(m)%Use_Old_MWSSEM - ! Specify the RT algorithm - RT_Algorithm_Id = Options(m)%RT_Algorithm_Id - ! Check if n_Streams should be used - User_N_Streams = Options(m)%Use_N_Streams - ! Check value for nstreams - IF ( User_N_Streams ) THEN - IF ( Options(m)%n_Streams <= 0 .OR. MOD(Options(m)%n_Streams,2) /= 0 .OR. & - Options(m)%n_Streams > MAX_N_STREAMS ) THEN - Error_Status = FAILURE - WRITE( Message,'( "Input Options n_Streams (", i0, ") is invalid" )' ) & - Options(m)%n_Streams - CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) - RETURN - END IF - END IF END IF + ! ...Assign the option specific SfcOptics input + SfcOptics%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM ! Check the input data if required - IF ( Check_Input ) THEN + IF ( Opt%Check_Input ) THEN ! ...Mandatory inputs Atmosphere_Invalid = .NOT. CRTM_Atmosphere_IsValid( Atmosphere(m) ) Surface_Invalid = .NOT. CRTM_Surface_IsValid( Surface(m) ) @@ -526,6 +487,28 @@ FUNCTION CRTM_Adjoint( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF + ! Are the channel dimensions consistent if emissivity is passed? + IF ( Options(m)%Use_Emissivity ) THEN + IF ( Options(m)%n_Channels < n_Channels ) THEN + Error_Status = FAILURE + WRITE( Message,'( "Input Options channel dimension (", i0, ") is less ", & + &"than the number of requested channels (",i0, ")" )' ) & + Options(m)%n_Channels, n_Channels + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + ! Check value for user-defined n_Streams + IF ( Options(m)%Use_N_Streams ) THEN + IF ( Options(m)%n_Streams <= 0 .OR. MOD(Options(m)%n_Streams,2) /= 0 .OR. & + Options(m)%n_Streams > MAX_N_STREAMS ) THEN + Error_Status = FAILURE + WRITE( Message,'( "Input Options n_Streams (", i0, ") is invalid" )' ) & + Options(m)%n_Streams + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF END IF END IF @@ -541,10 +524,6 @@ FUNCTION CRTM_Adjoint( & Source_Zenith_Angle = Source_ZA ) - ! Average surface skin temperature for multi-surface types - CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics ) - - ! Add extra layers to current atmosphere profile ! if necessary to handle upper atmosphere Error_Status = CRTM_Atmosphere_AddLayers( Atmosphere(m), Atm ) @@ -565,6 +544,9 @@ FUNCTION CRTM_Adjoint( & END IF ! ...Similarly extend a copy of the input adjoint atmosphere Atm_AD = CRTM_Atmosphere_AddLayerCopy( Atmosphere_AD(m), Atm%n_Added_Layers ) + + + ! Prepare the atmospheric optics structures ! ...Allocate the atmospheric optics structures based on Atm extension CALL CRTM_AtmOptics_Create( AtmOptics, & Atm%n_Layers , & @@ -581,11 +563,9 @@ FUNCTION CRTM_Adjoint( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF - IF (Options_Present) THEN - ! Set Scattering Switch - AtmOptics%Include_Scattering = Options(m)%Include_Scattering - AtmOptics_AD%Include_Scattering = Options(m)%Include_Scattering - END IF + ! ...Set the Scattering Switch + AtmOptics%Include_Scattering = Opt%Include_Scattering + AtmOptics_AD%Include_Scattering = Opt%Include_Scattering ! ...Allocate the atmospheric optics internal structure CALL AOvar_Create( AOvar, Atm%n_Layers ) @@ -609,6 +589,59 @@ FUNCTION CRTM_Adjoint( & END IF + ! Determine the type of cloud coverage + cloud_coverage_flag = CRTM_Atmosphere_Coverage( atm ) + + + ! 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 + WRITE( Message,'("Error computing cloud cover in profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + ! ...Mold the adjoint object based on the forward, and reinitialise + CloudCover_AD = CloudCover + CALL CloudCover_AD%Set_To_Zero() + + ! Allocate some of the CLEAR sky structure for fractional cloud coverage + ! (The AtmOptics structures are allocated during a copy) + ! ...Clear sky atmosphere + Status_FWD = CRTM_Atmosphere_ClearSkyCopy(Atm, Atm_Clear) + Status_AD = CRTM_Atmosphere_ClearSkyCopy(Atm, Atm_Clear_AD) + IF ( Status_FWD /= SUCCESS .OR. Status_AD /= SUCCESS ) THEN + Error_status = FAILURE + WRITE( Message,'("Error copying CLEAR SKY Atmosphere structures for profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + CALL CRTM_Atmosphere_Zero( Atm_Clear_AD ) + ! ...Clear sky SfcOptics + CALL CRTM_SfcOptics_Create( SfcOptics_Clear , MAX_N_ANGLES, MAX_N_STOKES ) + CALL CRTM_SfcOptics_Create( SfcOptics_Clear_AD, MAX_N_ANGLES, MAX_N_STOKES ) + IF ( (.NOT. CRTM_SfcOptics_Associated(SfcOptics_Clear)) .OR. & + (.NOT. CRTM_SfcOptics_Associated(SfcOptics_Clear_AD))) THEN + Error_Status = FAILURE + WRITE( Message,'("Error allocating CLEAR SKY SfcOptics data structures for profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + CALL CRTM_SfcOptics_Zero( SfcOptics_Clear_AD ) + ! ...Copy over surface optics input + SfcOptics_Clear%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM + SfcOptics_Clear_AD%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM + ! ...CLEAR SKY average surface skin temperature for multi-surface types + CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics_Clear ) + END IF + + + ! Average surface skin temperature for multi-surface types + CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics ) + + ! ----------- ! SENSOR LOOP ! ----------- @@ -623,13 +656,9 @@ FUNCTION CRTM_Adjoint( & ! Check if antenna correction to be applied for current sensor - IF ( User_AntCorr .AND. & - ACCoeff_Associated( SC(SensorIndex)%AC ) .AND. & - iFOV /= 0 ) THEN - Compute_AntCorr = .TRUE. - ELSE - Compute_AntCorr = .FALSE. - END IF + compute_antenna_correction = ( Opt%Use_Antenna_Correction .AND. & + ACCoeff_Associated( SC(SensorIndex)%AC ) .AND. & + iFOV /= 0 ) ! Allocate the AtmAbsorption predictor structures @@ -660,9 +689,10 @@ FUNCTION CRTM_Adjoint( & ! Allocate the RTV structure if necessary - IF( (Atm%n_Clouds > 0 .OR. & - Atm%n_Aerosols > 0 .OR. & - SpcCoeff_IsVisibleSensor( SC(SensorIndex) ) ) .and. AtmOptics%Include_Scattering ) THEN + IF( ( Atm%n_Clouds > 0 .OR. & + Atm%n_Aerosols > 0 .OR. & + SpcCoeff_IsVisibleSensor(SC(SensorIndex)) ) .AND. & + AtmOptics%Include_Scattering ) THEN CALL RTV_Create( RTV, MAX_N_ANGLES, MAX_N_LEGENDRE_TERMS, Atm%n_Layers ) IF ( .NOT. RTV_Associated(RTV) ) THEN Error_Status=FAILURE @@ -672,12 +702,12 @@ FUNCTION CRTM_Adjoint( & RETURN END IF ! Assign algorithm selector - RTV%RT_Algorithm_Id = RT_Algorithm_Id + RTV%RT_Algorithm_Id = Opt%RT_Algorithm_Id END IF ! Compute NLTE correction predictors - IF ( Apply_NLTE_Correction ) THEN + IF ( Opt%Apply_NLTE_Correction ) THEN CALL Compute_NLTE_Predictor( & SC(SensorIndex)%NC, & ! Input Atm , & ! Input @@ -707,15 +737,27 @@ FUNCTION CRTM_Adjoint( & RTSolution_AD(ln,m)%WMO_Satellite_Id = RTSolution(ln,m)%WMO_Satellite_Id RTSolution_AD(ln,m)%WMO_Sensor_Id = RTSolution(ln,m)%WMO_Sensor_Id RTSolution_AD(ln,m)%Sensor_Channel = RTSolution(ln,m)%Sensor_Channel + ! ...Same for clear structures + RTSolution_Clear%Sensor_Id = RTSolution(ln,m)%Sensor_Id + RTSolution_Clear%WMO_Satellite_Id = RTSolution(ln,m)%WMO_Satellite_Id + RTSolution_Clear%WMO_Sensor_Id = RTSolution(ln,m)%WMO_Sensor_Id + RTSolution_Clear%Sensor_Channel = RTSolution(ln,m)%Sensor_Channel + RTSolution_Clear_AD%Sensor_Id = RTSolution(ln,m)%Sensor_Id + RTSolution_Clear_AD%WMO_Satellite_Id = RTSolution(ln,m)%WMO_Satellite_Id + RTSolution_Clear_AD%WMO_Sensor_Id = RTSolution(ln,m)%WMO_Sensor_Id + RTSolution_Clear_AD%Sensor_Channel = RTSolution(ln,m)%Sensor_Channel ! Initialisations CALL CRTM_AtmOptics_Zero( AtmOptics ) + CALL CRTM_AtmOptics_Zero( AtmOptics_AD ) transmittance_AD = ZERO + CALL CRTM_RTSolution_Zero( RTSolution_Clear ) + CALL CRTM_RTSolution_Zero( RTSolution_Clear_AD ) ! Determine the number of streams (n_Full_Streams) in up+downward directions - IF ( User_N_Streams ) THEN + IF ( Opt%Use_N_Streams ) THEN n_Full_Streams = Options(m)%n_Streams RTSolution(ln,m)%n_Full_Streams = n_Full_Streams + 2 RTSolution(ln,m)%Scattering_Flag = .TRUE. @@ -728,6 +770,8 @@ FUNCTION CRTM_Adjoint( & ! ...Transfer stream count to scattering structures AtmOptics%n_Legendre_Terms = n_Full_Streams AtmOptics_AD%n_Legendre_Terms = n_Full_Streams + ! ...Ensure clear-sky object dimensions are consistent + AtmOptics_Clear_AD%n_Legendre_Terms = AtmOptics_AD%n_Legendre_Terms ! Compute the gas absorption @@ -739,11 +783,6 @@ FUNCTION CRTM_Adjoint( & AAVar ) ! Internal variable output - ! Compute the clear-sky atmospheric transmittance - ! for use in FASTEM-X reflection correction - CALL CRTM_Compute_Transmittance(AtmOptics,transmittance) - - ! Compute the molecular scattering properties ! ...Solar radiation IF( SC(SensorIndex)%Solar_Irradiance(ChannelIndex) > ZERO .AND. & @@ -779,6 +818,27 @@ FUNCTION CRTM_Adjoint( & ELSE RTV%Visible_Flag_true = .FALSE. RTV%n_Azi = 0 + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTV_Clear%Visible_Flag_true = .FALSE. + RTV_Clear%n_Azi = 0 + END IF + END IF + + + ! Copy the clear-sky AtmOptics + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + Status_FWD = CRTM_AtmOptics_NoScatterCopy( AtmOptics, AtmOptics_Clear ) + Status_AD = CRTM_AtmOptics_NoScatterCopy( AtmOptics, AtmOptics_Clear_AD ) + IF ( Status_FWD /= SUCCESS .OR. Status_AD /= SUCCESS ) THEN + Error_Status = FAILURE + WRITE( Message,'("Error copying CLEAR SKY AtmOptics for ",a,& + &", channel ",i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + ! Initialise the adjoint + CALL CRTM_AtmOptics_Zero( AtmOptics_Clear_AD ) END IF @@ -818,33 +878,46 @@ FUNCTION CRTM_Adjoint( & ! Compute the combined atmospheric optical properties IF( AtmOptics%Include_Scattering ) THEN - CALL CRTM_Combine_AtmOptics( AtmOptics, AOvar ) + CALL CRTM_AtmOptics_Combine( AtmOptics, AOvar ) END IF ! ...Save vertically integrated scattering optical depth for output RTSolution(ln,m)%SOD = AtmOptics%Scattering_Optical_Depth - ! Turn off FASTEM-X reflection correction for scattering conditions - IF ( CRTM_Include_Scattering(AtmOptics) .AND. SpcCoeff_IsMicrowaveSensor( SC(SensorIndex) ) ) THEN - SfcOptics%Transmittance = -ONE - ELSE - SfcOptics%Transmittance = transmittance + ! Compute the all-sky atmospheric transmittance + ! for use in FASTEM-X reflection correction + CALL CRTM_Compute_Transmittance(AtmOptics,transmittance) + SfcOptics%Transmittance = transmittance + ! ...Clear sky for fractional cloud cover + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + CALL CRTM_Compute_Transmittance(AtmOptics_Clear,transmittance_clear) + SfcOptics_Clear%Transmittance = transmittance_clear END IF ! Fill the SfcOptics structure for the optional emissivity input case. - ! ...Indicate SfcOptics ARE to be computed - SfcOptics%Compute = .TRUE. - ! ...Change SfcOptics emissivity/reflectivity contents/computation status - IF ( User_Emissivity ) THEN + SfcOptics%Compute = .TRUE. + SfcOptics_Clear%Compute = .TRUE. + IF ( Opt%Use_Emissivity ) THEN SfcOptics%Compute = .FALSE. - SfcOptics%Emissivity(1,1) = Options(m)%Emissivity(ln) - SfcOptics%Reflectivity(1,1,1,1) = ONE - Options(m)%Emissivity(ln) - IF ( User_Direct_Reflectivity ) THEN - SfcOptics%Direct_Reflectivity(1,1) = Options(m)%Direct_Reflectivity(ln) + SfcOptics%Emissivity(1,1) = Opt%Emissivity(ln) + SfcOptics%Reflectivity(1,1,1,1) = ONE - Opt%Emissivity(ln) + IF ( Opt%Use_Direct_Reflectivity ) THEN + SfcOptics%Direct_Reflectivity(1,1) = Opt%Direct_Reflectivity(ln) ELSE SfcOptics%Direct_Reflectivity(1,1) = SfcOptics%Reflectivity(1,1,1,1) END IF + ! ...Repeat for fractional clear-sky case + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + SfcOptics_Clear%Compute = .FALSE. + SfcOptics_Clear%Emissivity(1,1) = Opt%Emissivity(ln) + SfcOptics_Clear%Reflectivity(1,1,1,1) = ONE - Opt%Emissivity(ln) + IF ( Opt%Use_Direct_Reflectivity ) THEN + SfcOptics_Clear%Direct_Reflectivity(1,1) = Opt%Direct_Reflectivity(ln) + ELSE + SfcOptics_Clear%Direct_Reflectivity(1,1) = SfcOptics%Reflectivity(1,1,1,1) + END IF + END IF END IF @@ -852,8 +925,6 @@ FUNCTION CRTM_Adjoint( & ! mth_Azi = 0 is for an azimuth-averaged value (IR, MW) ! ...Initialise radiance RTSolution(ln,m)%Radiance = ZERO - ! ...Initialise adjoint atmospheric optics - CALL CRTM_AtmOptics_Zero( AtmOptics_AD ) @@ -890,51 +961,106 @@ FUNCTION CRTM_Adjoint( & RETURN END IF - ! Compute non-LTE correction to radiance if required - IF ( Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) & - CALL Compute_NLTE_Correction( & - SC(SensorIndex)%NC , & ! Input - ChannelIndex , & ! Input - NLTE_Predictor , & ! Input - RTSolution(ln,m)%Radiance ) ! In/Output - - ! Convert the radiance to brightness temperature - CALL CRTM_Planck_Temperature( & - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m)%Radiance , & ! Input - RTSolution(ln,m)%Brightness_Temperature ) ! Output - - ! Compute Antenna correction to brightness temperature if required - IF ( Compute_AntCorr ) THEN - CALL CRTM_Compute_AntCorr( & - GeometryInfo , & ! Input - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m) ) ! Output - CALL CRTM_Compute_AntCorr_AD( & - GeometryInfo , & ! Input - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution_AD(ln,m) ) ! Output + + ! Repeat clear sky for fractionally cloudy atmospheres + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTV_Clear%mth_Azi = 0 !RTV%mth_Azi + SfcOptics_Clear%mth_Azi = 0 !SfcOptics%mth_Azi + Error_Status = CRTM_Compute_RTSolution( & + Atm_Clear , & ! Input + Surface(m) , & ! Input + AtmOptics_Clear , & ! Input + SfcOptics_Clear , & ! Input + GeometryInfo , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + RTSolution_Clear, & ! Output + RTV_Clear ) ! Internal variable output + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'( "Error computing CLEAR SKY RTSolution for ", a, & + &", channel ", i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + + + ! Combine cloudy and clear radiances for fractional cloud coverage + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + r_cloudy = RTSolution(ln,m)%Radiance ! Save the 100% cloudy radiance + RTSolution(ln,m)%Radiance = & + ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_Clear%Radiance) + & + (CloudCover%Total_Cloud_Cover * RTSolution(ln,m)%Radiance) + ! ...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)) + + + ! Perform clear-sky post and pre-processing + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + ! Radiance post-processing + CALL Post_Process_RTSolution(RTSolution_Clear) + RTSolution(ln,m)%R_Clear = RTSolution_Clear%Radiance + RTSolution(ln,m)%Tb_Clear = RTSolution_Clear%Brightness_Temperature + + ! Adjoint radiance pre-processing + RTSolution_Clear_AD%Brightness_Temperature = RTSolution_Clear_AD%Brightness_Temperature + & + RTSolution_AD(ln,m)%Tb_Clear + RTSolution_AD(ln,m)%Tb_Clear = ZERO + RTSolution_Clear_AD%Radiance = RTSolution_Clear_AD%Radiance + & + RTSolution_AD(ln,m)%R_Clear + RTSolution_AD(ln,m)%R_Clear = ZERO + CALL Pre_Process_RTSolution_AD(RTSolution_Clear, RTSolution_Clear_AD) + END IF + + + ! The adjoint radiance pre-processing + CALL Pre_Process_RTSolution_AD(RTSolution(ln,m), RTSolution_AD(ln,m)) + + + ! More fractionally cloudy atmospheres processing + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + + ! The adjoint of the clear and cloudy radiance combination + CloudCover_AD%Total_Cloud_Cover = CloudCover_AD%Total_Cloud_Cover + & + RTSolution_AD(ln,m)%Total_Cloud_Cover + RTSolution_AD(ln,m)%Total_Cloud_Cover = ZERO + RTSolution_Clear_AD%Radiance = RTSolution_Clear_AD%Radiance + & + ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_AD(ln,m)%Radiance) + CloudCover_AD%Total_Cloud_Cover = CloudCover_AD%Total_Cloud_Cover + & + ((r_cloudy - RTSolution_Clear%Radiance) * RTSolution_AD(ln,m)%Radiance) + RTSolution_AD(ln,m)%Radiance = CloudCover%Total_Cloud_Cover * RTSolution_AD(ln,m)%Radiance + + ! The adjoint of the clear sky radiative transfer for fractionally cloudy atmospheres + Error_Status = CRTM_Compute_RTSolution_AD( & + Atm_Clear , & ! FWD Input + Surface(m) , & ! FWD Input + AtmOptics_Clear , & ! FWD Input + SfcOptics_Clear , & ! FWD Input + RTSolution_Clear , & ! FWD Input + RTSolution_Clear_AD, & ! AD Input + GeometryInfo , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + Atm_Clear_AD , & ! AD Output + Surface_AD(m) , & ! AD Output + AtmOptics_Clear_AD , & ! AD Output + SfcOptics_Clear_AD , & ! AD Output + RTV_Clear ) ! Internal variable input + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'( "Error computing CLEAR SKY RTSolution_AD for ", a, & + &", channel ", i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF END IF - ! Compute the Planck temperature adjoijnt - CALL CRTM_Planck_Temperature_AD( & - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m)%Radiance , & ! Input - RTSolution_AD(ln,m)%Brightness_Temperature, & ! Input - RTSolution_AD(ln,m)%Radiance ) ! Output - RTSolution_AD(ln,m)%Brightness_Temperature = ZERO - - ! Compute non-LTE correction adjoint if required - IF ( Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) & - CALL Compute_NLTE_Correction_AD( & - SC(SensorIndex)%NC , & ! Input - ChannelIndex , & ! Input - RTSolution_AD(ln,m)%Radiance, & ! Input - NLTE_Predictor_AD ) ! Output ! The adjoint of the radiative transfer Error_Status = CRTM_Compute_RTSolution_AD( & @@ -965,7 +1091,7 @@ FUNCTION CRTM_Adjoint( & ! -------------- ! VISIBLE sensor ! -------------- - ! ...Fourier expansion over azimuth angle + ! Fourier expansion over azimuth angle Azimuth_Fourier_Loop: DO mth_Azi = 0, RTV%n_Azi ! Set dependent component counters @@ -991,6 +1117,100 @@ FUNCTION CRTM_Adjoint( & RETURN END IF + ! Repeat clear sky for fractionally cloudy atmospheres + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTV_Clear%mth_Azi = RTV%mth_Azi + SfcOptics_Clear%mth_Azi = SfcOptics%mth_Azi + Error_Status = CRTM_Compute_RTSolution( & + Atm_Clear , & ! Input + Surface(m) , & ! Input + AtmOptics_Clear , & ! Input + SfcOptics_Clear , & ! Input + GeometryInfo , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + RTSolution_Clear, & ! Output + RTV_Clear ) ! Internal variable output + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'( "Error computing CLEAR SKY RTSolution for ", a, & + &", channel ", i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + END DO Azimuth_Fourier_Loop + + + ! All of the "in-between" FWD and AD processing is for fractional cloud coverage only + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + + ! FORWARD #1: Combine cloudy and clear radiances for fractional cloud coverage + r_cloudy = RTSolution(ln,m)%Radiance ! Save the 100% cloudy radiance + RTSolution(ln,m)%Radiance = & + ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_Clear%Radiance) + & + (CloudCover%Total_Cloud_Cover * RTSolution(ln,m)%Radiance) + ! FORWARD #2: Save the cloud cover and clear radiance in the output structure + RTSolution(ln,m)%Total_Cloud_Cover = CloudCover%Total_Cloud_Cover + RTSolution(ln,m)%R_Clear = RTSolution_Clear%Radiance + RTSolution(ln,m)%Tb_Clear = ZERO ! No Tb for visible + + ! ADJOINT #2: Of the cloud cover and clear radiance saving + RTSolution_Clear_AD%Tb_Clear = ZERO ! No Tb for visible + RTSolution_Clear_AD%Radiance = RTSolution_Clear_AD%Radiance + & + RTSolution_AD(ln,m)%R_Clear + RTSolution_AD(ln,m)%R_Clear = ZERO + CloudCover_AD%Total_Cloud_Cover = CloudCover_AD%Total_Cloud_Cover + & + RTSolution_AD(ln,m)%Total_Cloud_Cover + RTSolution_AD(ln,m)%Total_Cloud_Cover = ZERO + + ! ADJOINT #1: Of the clear+cloudy combination + RTSolution_Clear_AD%Radiance = RTSolution_Clear_AD%Radiance + & + ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_AD(ln,m)%Radiance) + CloudCover_AD%Total_Cloud_Cover = CloudCover_AD%Total_Cloud_Cover + & + ((r_cloudy - RTSolution_Clear%Radiance) * RTSolution_AD(ln,m)%Radiance) + RTSolution_AD(ln,m)%Radiance = CloudCover%Total_Cloud_Cover * RTSolution_AD(ln,m)%Radiance + END IF + + + ! Adjoint Fourier expansion over azimuth angle + Azimuth_Fourier_Loop_AD: DO mth_Azi = 0, RTV%n_Azi + + + ! Set dependent component counters + RTV%mth_Azi = mth_Azi + SfcOptics%mth_Azi = mth_Azi + + + ! The adjoint of the clear sky radiative transfer for fractionally cloudy atmospheres + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTV_Clear%mth_Azi = RTV%mth_Azi + SfcOptics_Clear%mth_Azi = SfcOptics%mth_Azi + Error_Status = CRTM_Compute_RTSolution_AD( & + Atm_Clear , & ! FWD Input + Surface(m) , & ! FWD Input + AtmOptics_Clear , & ! FWD Input + SfcOptics_Clear , & ! FWD Input + RTSolution_Clear , & ! FWD Input + RTSolution_Clear_AD, & ! AD Input + GeometryInfo , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + Atm_Clear_AD , & ! AD Output + Surface_AD(m) , & ! AD Output + AtmOptics_Clear_AD , & ! AD Output + SfcOptics_Clear_AD , & ! AD Output + RTV_Clear ) ! Internal variable input + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'( "Error computing CLEAR SKY RTSolution_AD for ", a, & + &", channel ", i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + + ! The adjoint of the radiative transfer Error_Status = CRTM_Compute_RTSolution_AD( & Atm , & ! FWD Input @@ -1014,14 +1234,7 @@ FUNCTION CRTM_Adjoint( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF - END DO Azimuth_Fourier_Loop - - ! Still want to convert the final FORWARD radiance to brightness temperature - CALL CRTM_Planck_Temperature( & - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m)%Radiance , & ! Input - RTSolution(ln,m)%Brightness_Temperature ) ! Output + END DO Azimuth_Fourier_Loop_AD END IF Sensor_Dependent_RTSolution ! ################################################### @@ -1029,9 +1242,25 @@ FUNCTION CRTM_Adjoint( & ! ################################################### + ! Compute the adjoint of the all-sky atmospheric transmittance + ! for use in FASTEM-X reflection correction + transmittance_AD = SfcOptics_AD%transmittance + SfcOptics_AD%transmittance = ZERO + CALL CRTM_Compute_Transmittance_AD(AtmOptics,transmittance_AD,AtmOptics_AD) + ! ...Clear sky for fractional cloud cover + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + transmittance_clear_AD = SfcOptics_Clear_AD%transmittance + SfcOptics_Clear_AD%transmittance = ZERO + CALL CRTM_Compute_Transmittance_AD(AtmOptics_Clear,transmittance_clear_AD,AtmOptics_Clear_AD) + END IF + + ! Compute the adjoint of the combined atmospheric optical properties + AtmOptics_AD%Scattering_Optical_Depth = AtmOptics_AD%Scattering_Optical_Depth + & + RTSolution_AD(ln,m)%SOD + RTSolution_AD(ln,m)%SOD = ZERO IF( AtmOptics%Include_Scattering ) THEN - CALL CRTM_Combine_AtmOptics_AD( AtmOptics, AtmOptics_AD, AOvar ) + CALL CRTM_AtmOptics_Combine_AD( AtmOptics, AtmOptics_AD, AOvar ) END IF @@ -1073,6 +1302,19 @@ FUNCTION CRTM_Adjoint( & END IF + ! Adjoint of clear-sky AtmOptics copy + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + Error_Status = CRTM_AtmOptics_NoScatterCopy_AD( AtmOptics, AtmOptics_Clear_AD, AtmOptics_AD ) + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'("Error computing CLEAR SKY AtmOptics_AD for ",a,& + &", channel ",i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + + ! Compute the adjoint molecular scattering properties IF( RTV%Visible_Flag_true ) THEN Wavenumber = SC(SensorIndex)%Wavenumber(ChannelIndex) @@ -1092,14 +1334,6 @@ FUNCTION CRTM_Adjoint( & END IF - ! Compute the adjoint of the total atmospheric transmittance - IF ( CRTM_No_Scattering(AtmOptics) .AND. SpcCoeff_IsMicrowaveSensor(SC(SensorIndex)) ) THEN - transmittance_AD = SfcOptics_AD%transmittance - SfcOptics_AD%transmittance = ZERO - CALL CRTM_Compute_Transmittance_AD(AtmOptics,transmittance_AD,AtmOptics_AD) - END IF - - ! Compute the adjoint gaseous absorption CALL CRTM_Compute_AtmAbsorption_AD( SensorIndex , & ! Input ChannelIndex , & ! Input @@ -1115,7 +1349,7 @@ FUNCTION CRTM_Adjoint( & ! Adjoint of the NLTE correction predictor calculations - IF ( Apply_NLTE_Correction ) THEN + IF ( Opt%Apply_NLTE_Correction ) THEN CALL Compute_NLTE_Predictor_AD( & NLTE_Predictor , & ! Input NLTE_Predictor_AD, & ! Input @@ -1132,43 +1366,152 @@ FUNCTION CRTM_Adjoint( & Atm_AD , & ! AD Output PVar ) ! Internal variable input - - ! Deallocate local sensor dependent data structures - ! ...RTV structure - IF ( RTV_Associated(RTV) ) CALL RTV_Destroy(RTV) - ! ...Predictor structures - CALL CRTM_Predictor_Destroy( Predictor ) - CALL CRTM_Predictor_Destroy( Predictor_AD ) - END DO Sensor_Loop - ! Postprocess some input data - ! ...Adjoint of average surface skin temperature for multi-surface types + ! Adjoint of average surface skin temperature for multi-surface types CALL CRTM_Compute_SurfaceT_AD( Surface(m), SfcOptics_AD, Surface_AD(m) ) - ! ...Adjoint of the atmosphere layer addition + + + ! Adjoint of cloud cover setup + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + + ! Post process the CLEAR sky structures for fractional cloud coverage + ! ...Clear sky SfcOptics + CALL CRTM_Compute_SurfaceT_AD( Surface(m), SfcOptics_Clear_AD, Surface_AD(m) ) + ! ...Clear sky atmosphere + Error_Status = CRTM_Atmosphere_ClearSkyCopy_AD(Atm, Atm_Clear_AD, Atm_AD) + IF ( Error_Status /= SUCCESS ) THEN + Error_status = FAILURE + WRITE( Message,'("Error copying CLEAR SKY adjoint Atmosphere structure for profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + + ! Adjoint of the cloud coverage + Error_Status = CloudCover_AD%Compute_CloudCover_AD(CloudCover, atm, atm_AD) + IF ( Error_Status /= SUCCESS ) THEN + Error_Status = FAILURE + WRITE( Message,'("Error computing ADJOINT cloud cover for profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + + + ! Adjoint of the atmosphere layer addition Error_Status = CRTM_Atmosphere_AddLayers_AD( Atmosphere(m), Atm_AD, Atmosphere_AD(m) ) IF ( Error_Status /= SUCCESS ) THEN Error_Status = FAILURE - WRITE( Message,'("Error adding AD extra layers to profile #",i0)' ) m + WRITE( Message,'("Error adding ADJOINT extra layers to profile #",i0)' ) m CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF - - ! Deallocate local sensor independent data structures - ! ...Atmospheric optics - CALL CRTM_AtmOptics_Destroy( AtmOptics ) - CALL CRTM_AtmOptics_Destroy( AtmOptics_AD ) - END DO Profile_Loop - ! Destroy any remaining structures + ! Clean up + CALL CRTM_Predictor_Destroy( Predictor ) + CALL CRTM_Predictor_Destroy( Predictor_AD ) + CALL CRTM_AtmOptics_Destroy( AtmOptics ) + CALL CRTM_AtmOptics_Destroy( AtmOptics_AD ) + CALL CRTM_AtmOptics_Destroy( AtmOptics_Clear ) + CALL CRTM_AtmOptics_Destroy( AtmOptics_Clear_AD ) CALL CRTM_SfcOptics_Destroy( SfcOptics ) CALL CRTM_SfcOptics_Destroy( SfcOptics_AD ) - CALL CRTM_Atmosphere_Destroy( Atm_AD ) + CALL CRTM_SfcOptics_Destroy( SfcOptics_Clear ) + CALL CRTM_SfcOptics_Destroy( SfcOptics_Clear_AD ) CALL CRTM_Atmosphere_Destroy( Atm ) + CALL CRTM_Atmosphere_Destroy( Atm_AD ) + CALL CRTM_Atmosphere_Destroy( Atm_Clear ) + CALL CRTM_Atmosphere_Destroy( Atm_Clear_AD ) + ! ...Internal variables + CALL AOvar_Destroy( AOvar ) + CALL CSvar_Destroy( CSvar ) + CALL ASvar_Destroy( ASvar ) + CALL RTV_Destroy( RTV ) + + +CONTAINS + + + ! ---------------------------------------------------------------- + ! Local subroutine to post-process the FORWARD radiance, as it is + ! the same for all-sky and fractional clear-sky cases. + ! + ! 1. Apply non-LTE correction to radiance + ! 2. Convert radiance to brightness temperature + ! 3. Apply antenna correction to brightness temperature + ! ---------------------------------------------------------------- + + SUBROUTINE Post_Process_RTSolution(rts) + TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: rts + + ! Compute non-LTE correction to radiance if required + IF ( Opt%Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) THEN + CALL Compute_NLTE_Correction( & + SC(SensorIndex)%NC, & ! Input + ChannelIndex , & ! Input + NLTE_Predictor , & ! Input + rts%Radiance ) ! In/Output + END IF + ! Convert the radiance to brightness temperature + CALL CRTM_Planck_Temperature( & + SensorIndex , & ! Input + ChannelIndex , & ! Input + rts%Radiance , & ! Input + rts%Brightness_Temperature ) ! Output + ! Compute Antenna correction to brightness temperature if required + IF ( compute_antenna_correction ) THEN + CALL CRTM_Compute_AntCorr( & + GeometryInfo, & ! Input + SensorIndex , & ! Input + ChannelIndex, & ! Input + rts ) ! Output + END IF + + END SUBROUTINE Post_Process_RTSolution + + + ! ---------------------------------------------------------------- + ! Local subroutine to pre-process the ADJOINT radiance, as it is + ! the same for all-sky and fractional clear-sky cases. + ! + ! 1. Apply adjoint antenna correction to brightness temperatures + ! 2. Convert adjoint radiances to brightness temperatures + ! 3. Apply adjoint non-LTE correction to radiances + ! ---------------------------------------------------------------- + + SUBROUTINE Pre_Process_RTSolution_AD(rts, rts_AD) + TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: rts, rts_AD + + ! Compute adjoint antenna correction to brightness temperature if required + IF ( compute_antenna_correction ) THEN + CALL CRTM_Compute_AntCorr_AD( & + GeometryInfo, & ! Input + SensorIndex , & ! Input + ChannelIndex, & ! Input + rts_AD ) ! Output + END IF + ! Compute the Planck temperature adjoint + CALL CRTM_Planck_Temperature_AD( & + SensorIndex , & ! Input + ChannelIndex , & ! Input + rts%Radiance , & ! Input + rts_AD%Brightness_Temperature, & ! Input + rts_AD%Radiance ) ! Output + rts_AD%Brightness_Temperature = ZERO + ! Compute non-LTE correction adjoint if required + IF ( Opt%Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) THEN + CALL Compute_NLTE_Correction_AD( & + SC(SensorIndex)%NC, & ! Input + ChannelIndex , & ! Input + rts_AD%Radiance , & ! Input + NLTE_Predictor_AD ) ! Output + END IF + + END SUBROUTINE Pre_Process_RTSolution_AD END FUNCTION CRTM_Adjoint diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_AerosolCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_AerosolCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_AerosolCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_AerosolCoeff.f90 index 5995ace371..e63474df20 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_AerosolCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_AerosolCoeff.f90 @@ -54,7 +54,7 @@ MODULE CRTM_AerosolCoeff ! ----------------- ! RCS Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_AerosolCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_AerosolCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_AerosolScatter.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_AerosolScatter.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_AerosolScatter.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_AerosolScatter.f90 index 5a1a0702f3..774554a8ba 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_AerosolScatter.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_AerosolScatter.f90 @@ -89,7 +89,7 @@ MODULE CRTM_AerosolScatter ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_AerosolScatter.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_AerosolScatter.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 ! Number of stream angle definitions diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Aerosol_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Aerosol_Define.f90 similarity index 95% rename from var/external/crtm_2.2.3/libsrc/CRTM_Aerosol_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Aerosol_Define.f90 index 7426f3eacb..29658d14cb 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Aerosol_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Aerosol_Define.f90 @@ -54,6 +54,7 @@ MODULE CRTM_Aerosol_Define PUBLIC :: CRTM_Aerosol_type ! Operators PUBLIC :: OPERATOR(==) + PUBLIC :: OPERATOR(/=) PUBLIC :: OPERATOR(+) PUBLIC :: OPERATOR(-) ! Procedures @@ -82,6 +83,10 @@ MODULE CRTM_Aerosol_Define MODULE PROCEDURE CRTM_Aerosol_Equal END INTERFACE OPERATOR(==) + INTERFACE OPERATOR(/=) + MODULE PROCEDURE CRTM_Aerosol_NotEqual + END INTERFACE OPERATOR(/=) + INTERFACE OPERATOR(+) MODULE PROCEDURE CRTM_Aerosol_Add END INTERFACE OPERATOR(+) @@ -101,7 +106,7 @@ MODULE CRTM_Aerosol_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Aerosol_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Aerosol_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Aerosol types and names INTEGER, PARAMETER :: N_VALID_AEROSOL_CATEGORIES = 8 INTEGER, PARAMETER :: INVALID_AEROSOL = 0 @@ -196,7 +201,8 @@ FUNCTION CRTM_Aerosol_CategoryList(list) RESULT(err_stat) CHARACTER(ML) :: alloc_msg, msg INTEGER :: alloc_stat err_stat = SUCCESS - ALLOCATE( list(0:N_VALID_AEROSOL_CATEGORIES), STAT=alloc_stat, ERRMSG=alloc_msg ) + !ALLOCATE( list(0:N_VALID_AEROSOL_CATEGORIES), STAT=alloc_stat, ERRMSG=alloc_msg ) + ALLOCATE( list(0:N_VALID_AEROSOL_CATEGORIES), STAT=alloc_stat ) IF ( alloc_stat /= 0 ) THEN err_stat = FAILURE msg = 'Aerosol category list result not allocated -'//TRIM(alloc_msg) @@ -700,19 +706,20 @@ ELEMENTAL FUNCTION CRTM_Aerosol_Compare( & n = DEFAULT_N_SIGFIG END IF - ! Check the structure association status - IF ( (.NOT. CRTM_Aerosol_Associated(x)) .OR. & - (.NOT. CRTM_Aerosol_Associated(y)) ) RETURN + ! Check the object association status + IF ( CRTM_Aerosol_Associated(x) .NEQV. CRTM_Aerosol_Associated(y) ) RETURN - ! Check scalars + ! Check contents + ! ...Dimensions and scalars IF ( (x%n_Layers /= y%n_Layers) .OR. & (x%Type /= y%Type ) ) RETURN - - ! Check arrays - IF ( (.NOT. ALL(Compares_Within_Tolerance(x%Effective_Radius,y%Effective_Radius,n))) .OR. & - (.NOT. ALL(Compares_Within_Tolerance(x%Concentration ,y%Concentration ,n))) ) RETURN - - ! If we get here, the structures are comparable + ! ...Arrays + IF ( CRTM_Aerosol_Associated(x) .AND. CRTM_Aerosol_Associated(y) ) THEN + IF ( (.NOT. ALL(Compares_Within_Tolerance(x%Effective_Radius,y%Effective_Radius,n))) .OR. & + (.NOT. ALL(Compares_Within_Tolerance(x%Concentration ,y%Concentration ,n))) ) RETURN + END IF + + ! If we get here, the objects are comparable is_comparable = .TRUE. END FUNCTION CRTM_Aerosol_Compare @@ -1295,22 +1302,67 @@ ELEMENTAL FUNCTION CRTM_Aerosol_Equal( x, y ) RESULT( is_equal ) ! Set up is_equal = .FALSE. - ! Check the structure association status - IF ( (.NOT. CRTM_Aerosol_Associated(x)) .OR. & - (.NOT. CRTM_Aerosol_Associated(y)) ) RETURN + ! Check the object association status + IF ( CRTM_Aerosol_Associated(x) .NEQV. CRTM_Aerosol_Associated(y) ) RETURN ! Check contents ! ...Scalars IF ( (x%n_Layers /= y%n_Layers) .OR. (x%Type /= y%Type) ) RETURN ! ...Arrays - n = x%n_Layers - IF ( ALL(x%Effective_Radius(1:n) .EqualTo. y%Effective_Radius(1:n) ) .AND. & - ALL(x%Concentration(1:n) .EqualTo. y%Concentration(1:n) ) ) & - is_equal = .TRUE. + IF ( CRTM_Aerosol_Associated(x) .AND. CRTM_Aerosol_Associated(y) ) THEN + n = x%n_Layers + IF ( .NOT. (ALL(x%Effective_Radius(1:n) .EqualTo. y%Effective_Radius(1:n) ) .AND. & + ALL(x%Concentration(1:n) .EqualTo. y%Concentration(1:n) )) ) RETURN + END IF + + ! If we get here, then... + is_equal = .TRUE. END FUNCTION CRTM_Aerosol_Equal +!------------------------------------------------------------------------------ +! +! NAME: +! CRTM_Aerosol_NotEqual +! +! PURPOSE: +! Elemental function to test the inequality of two CRTM Aerosol objects. +! Used in OPERATOR(/=) interface block. +! +! This function is syntactic sugar. +! +! CALLING SEQUENCE: +! not_equal = CRTM_Aerosol_NotEqual( x, y ) +! +! or +! +! IF ( x /= y ) THEN +! ... +! END IF +! +! OBJECTS: +! x, y: Two CRTM Aerosol objects to be compared. +! UNITS: N/A +! TYPE: CRTM_Aerosol_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! not_equal: Logical value indicating whether the inputs are not equal. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Same as inputs. +! +!------------------------------------------------------------------------------ + + ELEMENTAL FUNCTION CRTM_Aerosol_NotEqual( x, y ) RESULT( not_equal ) + TYPE(CRTM_Aerosol_type), INTENT(IN) :: x, y + LOGICAL :: not_equal + not_equal = .NOT. (x == y) + END FUNCTION CRTM_Aerosol_NotEqual + + !-------------------------------------------------------------------------------- ! ! NAME: diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_AncillaryInput_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_AncillaryInput_Define.f90 similarity index 90% rename from var/external/crtm_2.2.3/libsrc/CRTM_AncillaryInput_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_AncillaryInput_Define.f90 index 67e578bd56..744374b60b 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_AncillaryInput_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_AncillaryInput_Define.f90 @@ -25,7 +25,7 @@ MODULE CRTM_AncillaryInput_Define ! ----------------- ! Version Id for the module CHARACTER(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_AncillaryInput_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_AncillaryInput_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' !-------------------- ! Structure defintion diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_AntennaCorrection.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_AntennaCorrection.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_AntennaCorrection.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_AntennaCorrection.f90 index 17d64ef9bc..fffaa43a51 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_AntennaCorrection.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_AntennaCorrection.f90 @@ -41,7 +41,7 @@ MODULE CRTM_AntennaCorrection ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_AntennaCorrection.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_AntennaCorrection.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_AtmAbsorption.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_AtmAbsorption.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_AtmAbsorption.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_AtmAbsorption.f90 index 4a738dbb00..ae44f845d4 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_AtmAbsorption.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_AtmAbsorption.f90 @@ -70,7 +70,7 @@ MODULE CRTM_AtmAbsorption ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_AtmAbsorption.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_AtmAbsorption.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_AtmOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_AtmOptics.f90 similarity index 67% rename from var/external/crtm_2.2.3/libsrc/CRTM_AtmOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_AtmOptics.f90 index df27380c5f..aee8fb8c1f 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_AtmOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_AtmOptics.f90 @@ -22,7 +22,10 @@ MODULE CRTM_AtmOptics MAX_N_LAYERS, & BS_THRESHOLD, & SCATTERING_ALBEDO_THRESHOLD - USE CRTM_AtmOptics_Define, ONLY: CRTM_AtmOptics_type + USE CRTM_AtmOptics_Define, ONLY: CRTM_AtmOptics_type , & + CRTM_AtmOptics_Associated, & + CRTM_AtmOptics_Create , & + CRTM_AtmOptics_Zero ! Internal variable definition module USE AOvar_Define, ONLY: AOvar_type, & AOvar_Associated, & @@ -41,21 +44,30 @@ MODULE CRTM_AtmOptics PUBLIC :: AOvar_type ! Procedures PUBLIC :: AOvar_Create + PUBLIC :: CRTM_No_Scattering PUBLIC :: CRTM_Include_Scattering + PUBLIC :: CRTM_Compute_Transmittance PUBLIC :: CRTM_Compute_Transmittance_TL PUBLIC :: CRTM_Compute_Transmittance_AD - PUBLIC :: CRTM_Combine_AtmOptics - PUBLIC :: CRTM_Combine_AtmOptics_TL - PUBLIC :: CRTM_Combine_AtmOptics_AD + + PUBLIC :: CRTM_AtmOptics_Combine + PUBLIC :: CRTM_AtmOptics_Combine_TL + PUBLIC :: CRTM_AtmOptics_Combine_AD + + PUBLIC :: CRTM_AtmOptics_NoScatterCopy + PUBLIC :: CRTM_AtmOptics_NoScatterCopy_TL + PUBLIC :: CRTM_AtmOptics_NoScatterCopy_AD ! --------------- ! Module parameters ! --------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_AtmOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_AtmOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' + ! Message string length + INTEGER, PARAMETER :: ML = 256 CONTAINS @@ -322,14 +334,14 @@ END SUBROUTINE CRTM_Compute_Transmittance_AD !:sdoc+: ! ! NAME: -! CRTM_Combine_AtmOptics +! CRTM_AtmOptics_Combine ! ! PURPOSE: ! Subroutine to combine the optical properties from AtmAbsorption, ! CloudScatter, and AerosolScatter calculations. ! ! CALLING SEQUENCE: -! CALL CRTM_Combine_AtmOptics( AtmOptics, & +! CALL CRTM_AtmOptics_Combine( AtmOptics, & ! AOvar ) ! ! OUTPUTS: @@ -351,14 +363,14 @@ END SUBROUTINE CRTM_Compute_Transmittance_AD !:sdoc-: !-------------------------------------------------------------------------------- - SUBROUTINE CRTM_Combine_AtmOptics( & + SUBROUTINE CRTM_AtmOptics_Combine( & AtmOptics, & ! Output AOvar ) ! Internal variable output ! Arguments TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics TYPE(AOvar_type) , INTENT(IN OUT) :: AOvar ! Local parameters - CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Combine_AtmOptics' + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_Combine' ! Local variables INTEGER :: i, k, l @@ -414,7 +426,7 @@ SUBROUTINE CRTM_Combine_AtmOptics( & END DO Layer_Loop - END SUBROUTINE CRTM_Combine_AtmOptics + END SUBROUTINE CRTM_AtmOptics_Combine @@ -422,14 +434,14 @@ END SUBROUTINE CRTM_Combine_AtmOptics !:sdoc+: ! ! NAME: -! CRTM_Combine_AtmOptics_TL +! CRTM_AtmOptics_Combine_TL ! ! PURPOSE: ! Subroutine to combine the tangent-linear optical properties from ! AtmAbsorption, CloudScatter, and AerosolScatter calculations. ! ! CALLING SEQUENCE: -! CALL CRTM_Combine_AtmOptics_TL( AtmOptics , & +! CALL CRTM_AtmOptics_Combine_TL( AtmOptics , & ! AtmOptics_TL, & ! AOvar ) ! INPUTS: @@ -458,7 +470,7 @@ END SUBROUTINE CRTM_Combine_AtmOptics !:sdoc-: !-------------------------------------------------------------------------------- - SUBROUTINE CRTM_Combine_AtmOptics_TL( & + SUBROUTINE CRTM_AtmOptics_Combine_TL( & AtmOptics , & ! FWD Input AtmOptics_TL, & ! TL Output AOvar ) ! Internal variable input @@ -467,7 +479,7 @@ SUBROUTINE CRTM_Combine_AtmOptics_TL( & TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics_TL TYPE(AOvar_type) , INTENT(IN) :: AOvar ! Local parameters - CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Combine_AtmOptics_TL' + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_Combine_TL' ! Local variables INTEGER :: i, k, l REAL(fp) :: optical_depth_TL @@ -562,7 +574,7 @@ SUBROUTINE CRTM_Combine_AtmOptics_TL( & END DO Layer_Loop - END SUBROUTINE CRTM_Combine_AtmOptics_TL + END SUBROUTINE CRTM_AtmOptics_Combine_TL @@ -570,14 +582,14 @@ END SUBROUTINE CRTM_Combine_AtmOptics_TL !:sdoc+: ! ! NAME: -! CRTM_Combine_AtmOptics_AD +! CRTM_AtmOptics_Combine_AD ! ! PURPOSE: ! Subroutine to compute the adjoint form of the optical properties ! from AtmAbsorption, CloudScatter, and AerosolScatter calculations. ! ! CALLING SEQUENCE: -! CALL CRTM_Combine_AtmOptics_AD( AtmOptics, & +! CALL CRTM_AtmOptics_Combine_AD( AtmOptics, & ! AtmOptics_AD, & ! AOvar ) ! @@ -610,7 +622,7 @@ END SUBROUTINE CRTM_Combine_AtmOptics_TL !:sdoc-: !-------------------------------------------------------------------------------- - SUBROUTINE CRTM_Combine_AtmOptics_AD( & + SUBROUTINE CRTM_AtmOptics_Combine_AD( & AtmOptics , & ! FWD Input AtmOptics_AD, & ! AD Input AOvar ) ! Internal variable input @@ -619,7 +631,7 @@ SUBROUTINE CRTM_Combine_AtmOptics_AD( & TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics_AD TYPE(AOvar_type) , INTENT(IN) :: AOvar ! Local parameters - CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Combine_AtmOptics_AD' + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_Combine_AD' ! Local variables INTEGER :: i, k, l REAL(fp) :: w_AD @@ -724,6 +736,308 @@ SUBROUTINE CRTM_Combine_AtmOptics_AD( & END DO Layer_Loop - END SUBROUTINE CRTM_Combine_AtmOptics_AD + END SUBROUTINE CRTM_AtmOptics_Combine_AD + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_AtmOptics_NoScatterCopy +! +! PURPOSE: +! Function to copy an instance of a CRTM AtmOptics object +! but without the scattering information included. +! +! CALLING SEQUENCE: +! Error_Status = CRTM_AtmOptics_NoScatterCopy( AtmOptics, AtmOptics_Clear ) +! +! INPUTS: +! AtmOptics: AtmOptics object to copy +! UNITS: N/A +! TYPE: CRTM_AtmOptics_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! AtmOptics_Clear: Copy of the input AtmOptics object but without the +! scattering information. +! UNITS: N/A +! TYPE: CRTM_AtmOptics_type +! DIMENSION: Scalar +! 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 operation was successful +! == FAILURE an error occurred +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION CRTM_AtmOptics_NoScatterCopy( ao, ao_clear ) RESULT( err_stat ) + ! Arguments + TYPE(CRTM_AtmOptics_type), INTENT(IN) :: ao + TYPE(CRTM_AtmOptics_type), INTENT(OUT) :: ao_clear + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_NoScatterCopy' + ! Local variables + CHARACTER(ML) :: err_msg + + + ! Set up + err_stat = SUCCESS + ! ...Check input + IF ( .NOT. CRTM_AtmOptics_Associated(ao) ) THEN + err_stat = FAILURE + err_msg = 'Input AtmOptics structure not allocated' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + + + ! Create the output structure + CALL CRTM_AtmOptics_Create( ao_clear , & + ao%n_Layers, & + 0 , & ! No Legendre terms + 0 ) ! No phase element terms + IF ( .NOT. CRTM_AtmOptics_Associated(ao_clear) ) THEN + err_stat = FAILURE + err_msg = 'Error allocating output Clear-Sky AtmOptics structure' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + + + ! Set/Copy over the clear-sky data + ao_clear%Include_Scattering = .FALSE. + ao_clear%Optical_Depth = ao%Optical_Depth(1:ao%n_Layers) + + END FUNCTION CRTM_AtmOptics_NoScatterCopy + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_AtmOptics_NoScatterCopy_TL +! +! PURPOSE: +! Function to copy an instance of a tangent-linear CRTM AtmOptics object +! but without the scattering information included. +!! +! CALLING SEQUENCE: +! Error_Status = CRTM_AtmOptics_NoScatterCopy_TL( ao, ao_TL, ao_clear_TL ) +! +! INPUTS: +! ao: Forward AtmOptics object for consistency checking +! UNITS: N/A +! TYPE: CRTM_AtmOptics_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! ao_TL: Tangent-linear AtmOptics object to copy. This object +! must be the tangent-linear equivalent of the input +! forward AtmOptics object. +! This +! UNITS: N/A +! TYPE: CRTM_AtmOptics_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! ao_clear_TL: Copy of the input AtmOptics tangent-linear object but +! without scattering information. +! UNITS: N/A +! TYPE: CRTM_AtmOptics_type +! DIMENSION: Scalar +! 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 operation was successful +! == FAILURE an error occurred +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION CRTM_AtmOptics_NoScatterCopy_TL( & + ao , & ! FWD input + ao_TL , & ! TL input + ao_clear_TL) & ! TL output + RESULT( err_stat ) + ! Arguments + TYPE(CRTM_AtmOptics_type), INTENT(IN) :: ao + TYPE(CRTM_AtmOptics_type), INTENT(IN) :: ao_TL + TYPE(CRTM_AtmOptics_type), INTENT(OUT) :: ao_clear_TL + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_NoScatterCopy_TL' + ! Local variables + CHARACTER(ML) :: err_msg + + + ! Set up + err_stat = SUCCESS + ! ...Check input allocation + IF ( .NOT. CRTM_AtmOptics_Associated(ao ) .OR. & + .NOT. CRTM_AtmOptics_Associated(ao_TL) ) THEN + err_stat = FAILURE + err_msg = 'Input AtmOptics structures not allocated' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + ! ...Dimension consistency + IF ( (ao%n_Layers /= ao_TL%n_Layers ) .OR. & + (ao%n_Legendre_Terms /= ao_TL%n_Legendre_Terms) .OR. & + (ao%n_Phase_Elements /= ao_TL%n_Phase_Elements) ) THEN + err_stat = FAILURE + err_msg = 'Input AtmOptics structures have incongruent dimensions' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + + + ! Create the output structure + CALL CRTM_AtmOptics_Create( ao_clear_TL , & + ao_TL%n_Layers, & + 0 , & ! No Legendre terms + 0 ) ! No phase element terms + IF ( .NOT. CRTM_AtmOptics_Associated(ao_clear_TL) ) THEN + err_stat = FAILURE + err_msg = 'Error allocating output Clear-Sky AtmOptics structure' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + + + ! Set/Copy over the clear-sky data + ao_clear_TL%Include_Scattering = .FALSE. + ao_clear_TL%Optical_Depth = ao_TL%Optical_Depth(1:ao_TL%n_Layers) + + END FUNCTION CRTM_AtmOptics_NoScatterCopy_TL + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_AtmOptics_NoScatterCopy_AD +! +! PURPOSE: +! Function to perform the adjoint copy of an instance of the CRTM +! AtmOptics object without the scattering information included. +! +! CALLING SEQUENCE: +! Error_Status = CRTM_AtmOptics_NoScatterCopy_AD( ao, ao_clear_AD, ao_AD ) +! +! INPUTS: +! ao: AtmOptics object for consistency checking +! UNITS: N/A +! TYPE: CRTM_AtmOptics_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! ao_clear_AD: Adjoint Clear-Sky AtmOptics structure to copy +! UNITS: N/A +! TYPE: CRTM_AtmOptics_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! ao_AD: Adjoint copy of the input AtmOptics. This object +! must be the adjoint equivalent of the input +! forward AtmOptics object. +! UNITS: N/A +! TYPE: CRTM_AtmOptics_type +! DIMENSION: Scalar +! 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 operation was successful +! == FAILURE an error occurred +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION CRTM_AtmOptics_NoScatterCopy_AD( & + ao , & ! FWD input + ao_clear_AD, & ! AD input + ao_AD ) & ! AD output + RESULT( err_stat ) + ! Arguments + TYPE(CRTM_AtmOptics_type), INTENT(IN) :: ao + TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: ao_clear_AD + TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: ao_AD + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_NoScatterCopy_AD' + ! Local variables + CHARACTER(ML) :: err_msg + INTEGER :: k + + + ! Set up + err_stat = SUCCESS + ! ...Check input allocation + IF ( .NOT. CRTM_AtmOptics_Associated(ao ) .OR. & + .NOT. CRTM_AtmOptics_Associated(ao_clear_AD) .OR. & + .NOT. CRTM_AtmOptics_Associated(ao_AD ) ) THEN + err_stat = FAILURE + err_msg = 'Input AtmOptics structures not allocated' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + ! ...Dimensional consistency + IF ( (ao%n_Layers /= ao_AD%n_Layers ) .OR. & + (ao%n_Legendre_Terms /= ao_AD%n_Legendre_Terms) .OR. & + (ao%n_Phase_Elements /= ao_AD%n_Phase_Elements) ) THEN + err_stat = FAILURE + err_msg = 'Input AtmOptics and AtmOptics_AD structures have incongruent dimensions' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + IF ( ao_clear_AD%n_Layers /= ao_AD%n_Layers ) THEN + err_stat = FAILURE + err_msg = 'Input AtmOptics_Clear_AD structure has incongruent dimensions' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + ! ...Non-layer dependent data consistency + IF ( (ao%Include_Scattering .NEQV. ao_AD%Include_Scattering) .OR. & + ao_clear_AD%Include_Scattering ) THEN + err_stat = FAILURE + err_msg = 'AtmOptics structures have incongruent Scattering flags' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + + + ! Adjoint copy of data + k = ao%n_Layers + ao_AD%Optical_Depth(1:k) = ao_AD%Optical_Depth(1:k) + ao_clear_AD%Optical_Depth(1:k) + + + ! Zero the clear result, as it has no more impact + CALL CRTM_AtmOptics_Zero( ao_clear_AD ) + + END FUNCTION CRTM_AtmOptics_NoScatterCopy_AD END MODULE CRTM_AtmOptics diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_AtmOptics_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_AtmOptics_Define.f90 similarity index 92% rename from var/external/crtm_2.2.3/libsrc/CRTM_AtmOptics_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_AtmOptics_Define.f90 index 4bbbef6d50..5143c48e4d 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_AtmOptics_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_AtmOptics_Define.f90 @@ -37,6 +37,7 @@ MODULE CRTM_AtmOptics_Define PUBLIC :: CRTM_AtmOptics_type ! Operators PUBLIC :: OPERATOR(==) + PUBLIC :: OPERATOR(+) PUBLIC :: OPERATOR(-) ! Procedures PUBLIC :: CRTM_AtmOptics_Associated @@ -59,6 +60,10 @@ MODULE CRTM_AtmOptics_Define INTERFACE OPERATOR(==) MODULE PROCEDURE CRTM_AtmOptics_Equal END INTERFACE OPERATOR(==) + + INTERFACE OPERATOR(+) + MODULE PROCEDURE CRTM_AtmOptics_Add + END INTERFACE OPERATOR(+) INTERFACE OPERATOR(-) MODULE PROCEDURE CRTM_AtmOptics_Subtract @@ -73,7 +78,7 @@ MODULE CRTM_AtmOptics_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_AtmOptics_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_AtmOptics_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: ATMOPTICS_RELEASE = 4 ! This determines structure and file formats. ! Close status for write errors @@ -83,7 +88,6 @@ MODULE CRTM_AtmOptics_Define REAL(fp), PARAMETER :: ONE = 1.0_fp ! String lengths INTEGER, PARAMETER :: ML = 256 ! Message length - INTEGER, PARAMETER :: SL = 80 ! String length ! ------------------------------ @@ -151,11 +155,9 @@ MODULE CRTM_AtmOptics_Define ! ! FUNCTION RESULT: ! Status: The return value is a logical value indicating the -! status of the NLTE members. -! .TRUE. - if ANY of the AtmOptics allocatable members -! are in use. -! .FALSE. - if ALL of the AtmOptics allocatable members -! are not in use. +! status of the object components. +! .TRUE. - if the array components are allocated. +! .FALSE. - if the array components are not allocated. ! UNITS: N/A ! TYPE: LOGICAL ! DIMENSION: Same as input @@ -195,12 +197,6 @@ END FUNCTION CRTM_AtmOptics_Associated ELEMENTAL SUBROUTINE CRTM_AtmOptics_Destroy( self ) TYPE(CRTM_AtmOptics_type), INTENT(OUT) :: self self%Is_Allocated = .FALSE. - self%n_Layers = 0 - self%n_Legendre_Terms = 0 - self%n_Phase_Elements = 0 - self%Max_Layers = 0 - self%Max_Legendre_Terms = 0 - self%Max_Phase_Elements = 0 END SUBROUTINE CRTM_AtmOptics_Destroy @@ -236,14 +232,12 @@ END SUBROUTINE CRTM_AtmOptics_Destroy ! ! n_Legendre_Terms: The number of Legendre polynomial terms for the ! phase matrix. -! Must be > 0 ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Same as n_Layers input. ! ATTRIBUTES: INTENT(IN) ! ! n_Phase_Elements: The number of phase elements for the phase matrix. -! Must be > 0 ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Same as n_Layers input. @@ -272,9 +266,7 @@ ELEMENTAL SUBROUTINE CRTM_AtmOptics_Create( & INTEGER :: alloc_stat ! Check input - IF ( n_Layers < 1 .OR. & - n_Legendre_Terms < 1 .OR. & - n_Phase_Elements < 1 ) THEN + IF ( n_Layers < 1 ) THEN CALL CRTM_AtmOptics_Destroy( self ) RETURN END IF @@ -1411,13 +1403,13 @@ END FUNCTION CRTM_AtmOptics_WriteFile ELEMENTAL FUNCTION CRTM_AtmOptics_Equal( x, y ) RESULT( is_equal ) TYPE(CRTM_AtmOptics_type), INTENT(IN) :: x, y LOGICAL :: is_equal + INTEGER :: k, ip, ic ! Set up is_equal = .FALSE. ! Check the object association status - IF ( (.NOT. CRTM_AtmOptics_Associated(x)) .OR. & - (.NOT. CRTM_AtmOptics_Associated(y)) ) RETURN + IF ( CRTM_AtmOptics_Associated(x) .NEQV. CRTM_AtmOptics_Associated(y) ) RETURN ! Check contents ! ...Release/version info @@ -1426,21 +1418,96 @@ ELEMENTAL FUNCTION CRTM_AtmOptics_Equal( x, y ) RESULT( is_equal ) IF ( (x%n_Layers /= y%n_Layers ) .OR. & (x%n_Legendre_Terms /= y%n_Legendre_Terms) .OR. & (x%n_Phase_Elements /= y%n_Phase_Elements) ) RETURN - ! ...Scalar data - IF ( x%Scattering_Optical_Depth .EqualTo. y%Scattering_Optical_Depth ) & + ! ...Scalars + IF ( .NOT. (x%Scattering_Optical_Depth .EqualTo. y%Scattering_Optical_Depth) ) RETURN + ! ...Arrays is_equal = .TRUE. ! ...Array data - is_equal = is_equal .AND. & - ALL(x%Optical_Depth(1:x%n_Layers) .EqualTo. y%Optical_Depth(1:y%n_Layers) ) .AND. & - ALL(x%Single_Scatter_Albedo(1:x%n_Layers) .EqualTo. y%Single_Scatter_Albedo(1:y%n_Layers)) .AND. & - ALL(x%Asymmetry_Factor(1:x%n_Layers) .EqualTo. y%Asymmetry_Factor(1:y%n_Layers) ) .AND. & - ALL(x%Delta_Truncation(1:x%n_Layers) .EqualTo. y%Delta_Truncation(1:y%n_Layers) ) .AND. & - ALL(x%Phase_Coefficient(0:x%n_Legendre_Terms, 1:x%n_Phase_Elements, 1:x%n_Layers) .EqualTo. & - y%Phase_Coefficient(0:y%n_Legendre_Terms, 1:y%n_Phase_Elements, 1:y%n_Layers) ) + IF ( CRTM_AtmOptics_Associated(x) .AND. CRTM_AtmOptics_Associated(y) ) THEN + k = x%n_Layers + ip = x%n_Phase_Elements + ic = x%n_Legendre_Terms + k = x%n_Layers + IF ( .NOT. (ALL(x%Optical_Depth(1:k) .EqualTo. y%Optical_Depth(1:k) ) .AND. & + ALL(x%Single_Scatter_Albedo(1:k) .EqualTo. y%Single_Scatter_Albedo(1:k)) .AND. & + ALL(x%Asymmetry_Factor(1:k) .EqualTo. y%Asymmetry_Factor(1:k) ) .AND. & + ALL(x%Delta_Truncation(1:k) .EqualTo. y%Delta_Truncation(1:k) ) .AND. & + ALL(x%Phase_Coefficient(0:ic, 1:ip, 1:k) .EqualTo. & + y%Phase_Coefficient(0:ic, 1:ip, 1:k))) ) RETURN + END IF + + + ! If we get here, then... + is_equal = .TRUE. END FUNCTION CRTM_AtmOptics_Equal +!-------------------------------------------------------------------------------- +! +! NAME: +! CRTM_AtmOptics_Add +! +! PURPOSE: +! Pure function to add two CRTM AtmOptics objects. +! Used in OPERATOR(+) interface block. +! +! CALLING SEQUENCE: +! aosum = CRTM_AtmOptics_Add( ao1, ao2 ) +! +! or +! +! aosum = ao1 + ao2 +! +! +! INPUTS: +! ao1, ao2: The AtmOptics objects to add. +! UNITS: N/A +! TYPE: CRTM_AtmOptics_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! RESULT: +! aosum: AtmOptics object containing the added components. +! UNITS: N/A +! TYPE: CRTM_AtmOptics_type +! DIMENSION: Scalar +! +!-------------------------------------------------------------------------------- + + ELEMENTAL FUNCTION CRTM_AtmOptics_Add( ao1, ao2 ) RESULT( aosum ) + TYPE(CRTM_AtmOptics_type), INTENT(IN) :: ao1, ao2 + TYPE(CRTM_AtmOptics_type) :: aosum + INTEGER :: ic, ip, k + + ! Check input + ! ...If input structures not allocated, do nothing + IF ( (.NOT. CRTM_AtmOptics_Associated(ao1)) .OR. & + (.NOT. CRTM_AtmOptics_Associated(ao2)) ) RETURN + ! ...If input structure for different sizes, do nothing + IF ( ao1%n_Layers /= ao2%n_Layers .OR. & + ao1%n_Legendre_Terms /= ao2%n_Legendre_Terms .OR. & + ao1%n_Phase_Elements /= ao2%n_Phase_Elements ) RETURN + + ! Copy the first structure + aosum = ao1 + + ! And add its components to the second one + ! ...The scalar values + aosum%Scattering_Optical_Depth = aosum%Scattering_Optical_Depth + ao2%Scattering_Optical_Depth + ! ...The arrays + k = aosum%n_Layers + ip = aosum%n_Phase_Elements + ic = aosum%n_Legendre_Terms + aosum%Optical_Depth(1:k) = aosum%Optical_Depth(1:k) + ao2%Optical_Depth(1:k) + aosum%Single_Scatter_Albedo(1:k) = aosum%Single_Scatter_Albedo(1:k) + ao2%Single_Scatter_Albedo(1:k) + aosum%Asymmetry_Factor(1:k) = aosum%Asymmetry_Factor(1:k) + ao2%Asymmetry_Factor(1:k) + aosum%Delta_Truncation(1:k) = aosum%Delta_Truncation(1:k) + ao2%Delta_Truncation(1:k) + aosum%Phase_Coefficient(0:ic,1:ip,1:k) = aosum%Phase_Coefficient(0:ic,1:ip,1:k) + ao2%Phase_Coefficient(0:ic,1:ip,1:k) + + END FUNCTION CRTM_AtmOptics_Add + + !-------------------------------------------------------------------------------- ! ! NAME: @@ -1486,9 +1553,6 @@ ELEMENTAL FUNCTION CRTM_AtmOptics_Subtract( ao1, ao2 ) RESULT( aodiff ) IF ( ao1%n_Layers /= ao2%n_Layers .OR. & ao1%n_Legendre_Terms /= ao2%n_Legendre_Terms .OR. & ao1%n_Phase_Elements /= ao2%n_Phase_Elements ) RETURN - ! ...If input structure for different scattering setup, do nothing - IF ( (ao1%Include_Scattering .NEQV. ao2%Include_Scattering ) .AND. & - (ao1%lOffset /= ao2%lOffset ) ) RETURN ! Copy the first structure aodiff = ao1 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Atmosphere.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Atmosphere.f90 similarity index 52% rename from var/external/crtm_2.2.3/libsrc/CRTM_Atmosphere.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Atmosphere.f90 index 9152d159cf..1fb7543935 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Atmosphere.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Atmosphere.f90 @@ -19,7 +19,8 @@ MODULE CRTM_Atmosphere USE Message_Handler , ONLY: SUCCESS, FAILURE, WARNING, Display_Message USE CRTM_Parameters , ONLY: ZERO, ONE, POINT_5, SET, & TOA_PRESSURE , & - MINIMUM_ABSORBER_AMOUNT + MINIMUM_ABSORBER_AMOUNT, & + WATER_CONTENT_THRESHOLD USE CRTM_Atmosphere_Define, ONLY: CRTM_Atmosphere_type , & OPERATOR(==), & OPERATOR(+), & @@ -45,9 +46,18 @@ MODULE CRTM_Atmosphere ! Everything private by default PRIVATE ! Module procedures + PUBLIC :: CRTM_Atmosphere_Coverage + PUBLIC :: CRTM_Atmosphere_IsClear + PUBLIC :: CRTM_Atmosphere_IsFractional + PUBLIC :: CRTM_Atmosphere_IsOvercast + PUBLIC :: CRTM_Atmosphere_AddLayers PUBLIC :: CRTM_Atmosphere_AddLayers_TL PUBLIC :: CRTM_Atmosphere_AddLayers_AD + + PUBLIC :: CRTM_Atmosphere_ClearSkyCopy + PUBLIC :: CRTM_Atmosphere_ClearSkyCopy_TL + PUBLIC :: CRTM_Atmosphere_ClearSkyCopy_AD ! iAtm entities ! ...Structure PUBLIC :: iAtm_type @@ -60,12 +70,20 @@ MODULE CRTM_Atmosphere ! ----------------- ! Module parameters ! ----------------- - ! RCS Id for the module - CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: CRTM_Atmosphere.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & + '$Id: CRTM_Atmosphere.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 + ! The cloud coverage type + INTEGER, PARAMETER :: CLEAR = -1 + INTEGER, PARAMETER :: FRACTIONAL = 0 + INTEGER, PARAMETER :: OVERCAST = 1 +! CHARACTER(*), PARAMETER, DIMENSION( -1:1 ) :: & +! CLOUD_COVERAGE_NAME = [ 'Clear sky ', & +! 'Fractional coverage', & +! 'Overcast ' ] + CONTAINS @@ -78,6 +96,106 @@ MODULE CRTM_Atmosphere !################################################################################ !################################################################################ + FUNCTION CRTM_Atmosphere_IsClear(coverage_flag) RESULT(is_clear) + INTEGER, INTENT(IN) :: coverage_flag + LOGICAL :: is_clear + is_clear = coverage_flag == CLEAR + END FUNCTION CRTM_Atmosphere_IsClear + + FUNCTION CRTM_Atmosphere_IsFractional(coverage_flag) RESULT(is_fractional) + INTEGER, INTENT(IN) :: coverage_flag + LOGICAL :: is_fractional + is_fractional = coverage_flag == FRACTIONAL + END FUNCTION CRTM_Atmosphere_IsFractional + + FUNCTION CRTM_Atmosphere_IsOvercast(coverage_flag) RESULT(is_overcast) + INTEGER, INTENT(IN) :: coverage_flag + LOGICAL :: is_overcast + is_overcast = coverage_flag == OVERCAST + END FUNCTION CRTM_Atmosphere_IsOvercast + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_Atmosphere_Coverage +! +! PURPOSE: +! Function to determine the cloud coverage type for an input +! atmosphere. +! +! CALLING SEQUENCE: +! coverage_flag = CRTM_Atmosphere_Coverage( atm ) ! Input +! +! INPUTS: +! atm: Atmosphere structure for which the coverage type is +! to be determined. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! coverage_flag: An integer defining the coverage type. Valid +! parameterised values are: +! CLEAR +! FRACTIONAL +! OVERCAST +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + FUNCTION CRTM_Atmosphere_Coverage(atm) RESULT(coverage_flag) + ! Arguments + TYPE(CRTM_Atmosphere_type), INTENT(IN) :: atm + ! Function result + INTEGER :: coverage_flag + ! Local parameters + REAL(fp), PARAMETER :: MIN_COVERAGE_THRESHOLD = 1.0e-06_fp + REAL(fp), PARAMETER :: MAX_COVERAGE_THRESHOLD = ONE - MIN_COVERAGE_THRESHOLD + ! Local variables + LOGICAL :: cloudy_layer_mask(atm%n_Layers) + INTEGER :: idx(atm%n_Layers) + INTEGER :: n, nc, k + + ! Default clear + coverage_flag = CLEAR + IF ( atm%n_Clouds == 0 ) RETURN + + ! Check each cloud separately + Cloud_Loop: DO n = 1, atm%n_Clouds + + ! Determine if there are ANY cloudy layers + cloudy_layer_mask = atm%Cloud(n)%Water_Content > WATER_CONTENT_THRESHOLD + nc = COUNT(cloudy_layer_mask) + IF ( nc == 0 ) CYCLE Cloud_Loop + + ! Get the indices of those cloudy layers + idx(1:nc) = PACK([(k, k=1,atm%Cloud(n)%n_Layers)], cloudy_layer_mask) + + ! Check for ANY fractional coverage + ! ??? How to do this without the loop ??? + DO k = 1, nc +! IF ( (atm%Cloud_Fraction(idx(k)) > MIN_COVERAGE_THRESHOLD) .AND. & +! (atm%Cloud_Fraction(idx(k)) < MAX_COVERAGE_THRESHOLD) ) THEN + IF ( (atm%Cloud_Fraction(idx(k)) > MIN_COVERAGE_THRESHOLD) ) THEN + coverage_flag = FRACTIONAL + RETURN + END IF + END DO + +! ! Check for ALL totally clear or totally cloudy +! IF ( ALL(atm%Cloud_Fraction(idx(1:nc)) < MIN_COVERAGE_THRESHOLD) .OR. & +! ALL(atm%Cloud_Fraction(idx(1:nc)) > MAX_COVERAGE_THRESHOLD) ) coverage_flag = OVERCAST + + END DO Cloud_Loop + + END FUNCTION CRTM_Atmosphere_Coverage + + !-------------------------------------------------------------------------------- !:sdoc+: ! @@ -241,6 +359,7 @@ FUNCTION CRTM_Atmosphere_AddLayers( & Atm_Out%Level_Pressure(0:n) = iAtm%pl Atm_Out%Pressure(1:n) = iAtm%p Atm_Out%Temperature(1:n) = iAtm%t + Atm_Out%Cloud_Fraction(1:n) = ZERO DO j = 1, Atm_Out%n_Absorbers Atm_Out%Absorber(1:n,j) = iAtm%a(:,j) END DO @@ -508,6 +627,9 @@ FUNCTION CRTM_Atmosphere_AddLayers_AD( & ! ...Pressure data Atm_In_AD%Pressure(1:no) = Atm_In_AD%Pressure(1:no) + Atm_Out_AD%Pressure(n+1:nt) Atm_In_AD%Level_Pressure(0:no) = Atm_In_AD%Level_Pressure(0:no) + Atm_Out_AD%Level_Pressure(n:nt) + ! ...Cloud fraction data + Atm_In_AD%Cloud_Fraction(1:no) = Atm_In_AD%Cloud_Fraction(1:no) + & + Atm_Out_AD%Cloud_Fraction(n+1:nt) ! Zero the output atmosphere structure @@ -515,6 +637,379 @@ FUNCTION CRTM_Atmosphere_AddLayers_AD( & END FUNCTION CRTM_Atmosphere_AddLayers_AD + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_Atmosphere_ClearSkyCopy +! +! PURPOSE: +! Function to copy an instance of the CRTM Atmosphere object +! but without the clouds included. +! +! CALLING SEQUENCE: +! Error_Status = CRTM_Atmosphere_ClearSkyCopy( Atm, Atm_Clear ) +! +! INPUTS: +! Atm: Atmosphere structure to copy +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! Atm_Clear: Copy of the input atmosphere but withut cloud information. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! 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 operation was successful +! == FAILURE an error occurred +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION CRTM_Atmosphere_ClearSkyCopy( atm, atm_clear ) RESULT( err_stat ) + ! Arguments + TYPE(CRTM_Atmosphere_type), INTENT(IN) :: atm + TYPE(CRTM_Atmosphere_type), INTENT(OUT) :: atm_clear + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Atmosphere_ClearSkyCopy' + ! Local variables + CHARACTER(ML) :: err_msg + INTEGER :: i, k + + + ! Set up + err_stat = SUCCESS + ! ...Check input + IF ( .NOT. CRTM_Atmosphere_Associated(atm) ) THEN + err_stat = FAILURE + err_msg = 'Input Atmosphere structure not allocated' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + + + ! Create the output structure + CALL CRTM_Atmosphere_Create( atm_clear , & + atm%n_Layers , & + atm%n_Absorbers, & + 0 , & ! NO CLOUDS ! + atm%n_Aerosols ) + IF ( .NOT. CRTM_Atmosphere_Associated(atm_clear) ) THEN + err_stat = FAILURE + err_msg = 'Error allocating output Clear-Sky Atmosphere structure' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + + + ! Copy over data + ! ...Extra dimensions + atm_clear%n_Added_Layers = atm%n_Added_Layers + ! ...Layer independent data + atm_clear%Climatology = atm%Climatology + atm_clear%Absorber_ID = atm%Absorber_ID + atm_clear%Absorber_Units = atm%Absorber_Units + ! ...Layer dependent data + k = atm%n_Layers + atm_clear%Level_Pressure = atm%Level_Pressure(0:k) + atm_clear%Pressure = atm%Pressure(1:k) + atm_clear%Temperature = atm%Temperature(1:k) + atm_clear%Absorber = atm%Absorber(1:k,:) + atm_clear%Cloud_Fraction = atm%Cloud_Fraction(1:k) + ! ...Aerosol components + IF ( atm%n_Aerosols > 0 ) THEN + DO i = 1, atm%n_Aerosols + atm_clear%Aerosol(i) = atm%Aerosol(i) + END DO + END IF + + END FUNCTION CRTM_Atmosphere_ClearSkyCopy + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_Atmosphere_ClearSkyCopy_TL +! +! PURPOSE: +! Function to copy an instance of a tangent-linear CRTM Atmosphere object +! but without the clouds included. +!! +! CALLING SEQUENCE: +! Error_Status = CRTM_Atmosphere_ClearSkyCopy_TL( Atm, Atm_TL, Atm_Clear_TL ) +! +! INPUTS: +! Atm: Atmosphere object for consistency checking +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Atm_TL: Tangent-linear Atmosphere object to copy. This object +! must be the tangent-linear equivalent of the input +! forward Atm object. +! This +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! Atm_Clear_TL: Copy of the input atmosphere but withut cloud information. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! 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 operation was successful +! == FAILURE an error occurred +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION CRTM_Atmosphere_ClearSkyCopy_TL( & + atm , & ! FWD input + atm_TL , & ! TL input + atm_clear_TL) & ! TL output + RESULT( err_stat ) + ! Arguments + TYPE(CRTM_Atmosphere_type), INTENT(IN) :: atm + TYPE(CRTM_Atmosphere_type), INTENT(IN) :: atm_TL + TYPE(CRTM_Atmosphere_type), INTENT(OUT) :: atm_clear_TL + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Atmosphere_ClearSkyCopy_TL' + ! Local variables + CHARACTER(ML) :: err_msg + INTEGER :: i, k + + + ! Set up + err_stat = SUCCESS + ! ...Check input allocation + IF ( .NOT. CRTM_Atmosphere_Associated(atm ) .OR. & + .NOT. CRTM_Atmosphere_Associated(atm_TL) ) THEN + err_stat = FAILURE + err_msg = 'Input Atmosphere structures not allocated' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + ! ...Dimension consistency + IF ( (atm%n_Layers /= atm_TL%n_Layers ) .OR. & + (atm%n_Absorbers /= atm_TL%n_Absorbers ) .OR. & + (atm%n_Clouds /= atm_TL%n_Clouds ) .OR. & + (atm%n_Aerosols /= atm_TL%n_Aerosols ) .OR. & + (atm%n_Added_Layers /= atm_TL%n_Added_Layers) ) THEN + err_stat = FAILURE + err_msg = 'Input Atmosphere structures have incongruent dimensions' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + ! ...Non-layer dependent data consistency + IF ( (atm%Climatology /= atm_TL%Climatology ) .OR. & + ANY(atm%Absorber_ID /= atm_TL%Absorber_ID ) .OR. & + ANY(atm%Absorber_Units /= atm_TL%Absorber_Units) ) THEN + err_stat = FAILURE + err_msg = 'Input Atmosphere structures have incongruent layer independent data' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + + + ! Create the output structure + CALL CRTM_Atmosphere_Create( atm_clear_TL , & + atm_TL%n_Layers , & + atm_TL%n_Absorbers, & + 0 , & ! NO CLOUDS ! + atm_TL%n_Aerosols ) + IF ( .NOT. CRTM_Atmosphere_Associated(atm_clear_TL) ) THEN + err_stat = FAILURE + err_msg = 'Error allocating output Clear-Sky Atmosphere structure' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + + + ! Copy over data + ! ...Extra dimensions + atm_clear_TL%n_Added_Layers = atm_TL%n_Added_Layers + ! ...Layer independent data + atm_clear_TL%Climatology = atm_TL%Climatology + atm_clear_TL%Absorber_ID = atm_TL%Absorber_ID + atm_clear_TL%Absorber_Units = atm_TL%Absorber_Units + ! ...Layer dependent data + k = atm%n_Layers + atm_clear_TL%Level_Pressure = atm_TL%Level_Pressure(0:k) + atm_clear_TL%Pressure = atm_TL%Pressure(1:k) + atm_clear_TL%Temperature = atm_TL%Temperature(1:k) + atm_clear_TL%Absorber = atm_TL%Absorber(1:k,:) + atm_clear_TL%Cloud_Fraction = atm_TL%Cloud_Fraction(1:k) + ! ...Aerosol components + IF ( atm_TL%n_Aerosols > 0 ) THEN + DO i = 1, atm_TL%n_Aerosols + atm_clear_TL%Aerosol(i) = atm_TL%Aerosol(i) + END DO + END IF + + END FUNCTION CRTM_Atmosphere_ClearSkyCopy_TL + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_Atmosphere_ClearSkyCopy_AD +! +! PURPOSE: +! Function to perform the adjoint copy of an instance of the CRTM +! Atmosphere object without the clouds included. +! +! CALLING SEQUENCE: +! Error_Status = CRTM_Atmosphere_ClearSkyCopy_AD( Atm, Atm_Clear_AD, Atm_AD ) +! +! INPUTS: +! Atm: Atmosphere object for consistency checking +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! Atm_Clear_AD: Adjoint Clear-Sky Atmosphere structure to copy +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! Atm_AD: Adjoint copy of the input atmosphere. This object +! must be the adjoint equivalent of the input +! forward Atm object. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! 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 operation was successful +! == FAILURE an error occurred +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION CRTM_Atmosphere_ClearSkyCopy_AD( & + atm , & ! FWD input + atm_clear_AD, & ! AD input + atm_AD ) & ! AD output + RESULT( err_stat ) + ! Arguments + TYPE(CRTM_Atmosphere_type), INTENT(IN) :: atm + TYPE(CRTM_Atmosphere_type), INTENT(IN OUT) :: atm_clear_AD + TYPE(CRTM_Atmosphere_type), INTENT(IN OUT) :: atm_AD + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Atmosphere_ClearSkyCopy_AD' + ! Local variables + CHARACTER(ML) :: err_msg + INTEGER :: i, k + + + ! Set up + err_stat = SUCCESS + ! ...Check input allocation + IF ( .NOT. CRTM_Atmosphere_Associated(atm ) .OR. & + .NOT. CRTM_Atmosphere_Associated(atm_clear_AD) .OR. & + .NOT. CRTM_Atmosphere_Associated(atm_AD ) ) THEN + err_stat = FAILURE + err_msg = 'Input Atmosphere structures not allocated' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + ! ...Dimensional consistency + IF ( (atm%n_Layers /= atm_AD%n_Layers ) .OR. & + (atm%n_Absorbers /= atm_AD%n_Absorbers ) .OR. & + (atm%n_Clouds /= atm_AD%n_Clouds ) .OR. & + (atm%n_Aerosols /= atm_AD%n_Aerosols ) .OR. & + (atm%n_Added_Layers /= atm_AD%n_Added_Layers) ) THEN + err_stat = FAILURE + err_msg = 'Input Atm and Atm_AD structures have incongruent dimensions' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + IF ( (atm_clear_AD%n_Layers /= atm_AD%n_Layers ) .OR. & + (atm_clear_AD%n_Absorbers /= atm_AD%n_Absorbers ) .OR. & + (atm_clear_AD%n_Aerosols /= atm_AD%n_Aerosols ) .OR. & + (atm_clear_AD%n_Clouds /= 0 ) .OR. & ! NO CLOUDS ! + (atm_clear_AD%n_Added_Layers /= atm_AD%n_Added_Layers) ) THEN + err_stat = FAILURE + err_msg = 'Input Atm_Clear_AD structures has incongruent dimensions' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + ! ...Non-layer dependent data consistency + IF ( (atm%Climatology /= atm_AD%Climatology ) .OR. & + ANY(atm%Absorber_ID /= atm_AD%Absorber_ID ) .OR. & + ANY(atm%Absorber_Units /= atm_AD%Absorber_Units) .OR. & + (atm%Climatology /= atm_clear_AD%Climatology ) .OR. & + ANY(atm%Absorber_ID /= atm_clear_AD%Absorber_ID ) .OR. & + ANY(atm%Absorber_Units /= atm_clear_AD%Absorber_Units) ) THEN + err_stat = FAILURE + err_msg = 'Atmosphere structures have incongruent layer independent data' + CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) + RETURN + END IF + + + ! Adjoint copy of data + ! ...Aerosol components + IF ( atm%n_Aerosols > 0 ) THEN + DO i = 1, atm%n_Aerosols + atm_AD%Aerosol(i) = atm_AD%Aerosol(i) + atm_clear_AD%Aerosol(i) + END DO + END IF + ! ...Layer dependent data + k = atm%n_Layers + atm_AD%Level_Pressure(0:k) = atm_AD%Level_Pressure(0:k) + atm_clear_AD%Level_Pressure(0:k) + atm_AD%Pressure(1:k) = atm_AD%Pressure(1:k) + atm_clear_AD%Pressure(1:k) + atm_AD%Temperature(1:k) = atm_AD%Temperature(1:k) + atm_clear_AD%Temperature(1:k) + atm_AD%Absorber(1:k,:) = atm_AD%Absorber(1:k,:) + atm_clear_AD%Absorber(1:k,:) + atm_AD%Cloud_Fraction(1:k) = atm_AD%Cloud_Fraction(1:k) + atm_clear_AD%Cloud_Fraction(1:k) + + + ! Zero the clear result, as it has no more impact + CALL CRTM_Atmosphere_Zero( atm_clear_AD ) + + END FUNCTION CRTM_Atmosphere_ClearSkyCopy_AD + + + + !################################################################################## !################################################################################## !## ## diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Atmosphere_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Atmosphere_Define.f90 similarity index 91% rename from var/external/crtm_2.2.3/libsrc/CRTM_Atmosphere_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Atmosphere_Define.f90 index b530c28a53..8fdf40f7c1 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Atmosphere_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Atmosphere_Define.f90 @@ -97,6 +97,7 @@ MODULE CRTM_Atmosphere_Define PRIVATE ! Operators PUBLIC :: OPERATOR(==) + PUBLIC :: OPERATOR(/=) PUBLIC :: OPERATOR(+) PUBLIC :: OPERATOR(-) ! Cloud entities @@ -192,6 +193,7 @@ MODULE CRTM_Atmosphere_Define PUBLIC :: CRTM_Atmosphere_Destroy PUBLIC :: CRTM_Atmosphere_Create PUBLIC :: CRTM_Atmosphere_AddLayerCopy + PUBLIC :: CRTM_Atmosphere_NonVariableCopy PUBLIC :: CRTM_Atmosphere_Zero PUBLIC :: CRTM_Atmosphere_IsValid PUBLIC :: CRTM_Atmosphere_Inspect @@ -204,7 +206,7 @@ MODULE CRTM_Atmosphere_Define ! ...Utilities PUBLIC :: CRTM_Get_AbsorberIdx PUBLIC :: CRTM_Get_PressureLevelIdx - + PUBLIC :: CRTM_Atmosphere_Add ! ------------------- ! Procedure overloads @@ -213,6 +215,10 @@ MODULE CRTM_Atmosphere_Define MODULE PROCEDURE CRTM_Atmosphere_Equal END INTERFACE OPERATOR(==) + INTERFACE OPERATOR(/=) + MODULE PROCEDURE CRTM_Atmosphere_NotEqual + END INTERFACE OPERATOR(/=) + INTERFACE OPERATOR(+) MODULE PROCEDURE CRTM_Atmosphere_Add END INTERFACE OPERATOR(+) @@ -242,7 +248,7 @@ MODULE CRTM_Atmosphere_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Atmosphere_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Atmosphere_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! The absorber IDs. Use HITRAN definitions INTEGER, PARAMETER :: N_VALID_ABSORBER_IDS = 32 @@ -345,6 +351,7 @@ MODULE CRTM_Atmosphere_Define 'Subarctic summer ', & 'Subarctic winter ', & 'U.S. Standard Atmosphere' /) + ! Literal constants REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: ONE = 1.0_fp @@ -381,6 +388,7 @@ MODULE CRTM_Atmosphere_Define REAL(fp), ALLOCATABLE :: Pressure(:) ! K REAL(fp), ALLOCATABLE :: Temperature(:) ! K REAL(fp), ALLOCATABLE :: Absorber(:,:) ! K x J + REAL(fp), ALLOCATABLE :: Cloud_Fraction(:) ! K ! Clouds associated with each profile TYPE(CRTM_Cloud_type), ALLOCATABLE :: Cloud(:) ! Nc ! Aerosols associated with each profile @@ -559,6 +567,7 @@ ELEMENTAL SUBROUTINE CRTM_Atmosphere_Create( & Atm%Pressure( n_Layers ), & Atm%Temperature( n_Layers ), & Atm%Absorber( n_Layers, n_Absorbers ), & + Atm%Cloud_Fraction( n_Layers ), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN @@ -603,6 +612,7 @@ ELEMENTAL SUBROUTINE CRTM_Atmosphere_Create( & Atm%Pressure = ZERO Atm%Temperature = ZERO Atm%Absorber = ZERO + Atm%Cloud_Fraction = ZERO ! Set allocation indicator Atm%Is_Allocated = .TRUE. @@ -676,16 +686,17 @@ ELEMENTAL FUNCTION CRTM_Atmosphere_AddLayerCopy( & ! Assign data atm_out%n_Added_Layers = atm%n_Added_Layers+na ! ...Layer independent data - atm_out%Climatology = atm%Climatology - atm_out%Absorber_ID = atm%Absorber_ID - atm_out%Absorber_Units = atm%Absorber_Units + atm_out%Climatology = atm%Climatology + atm_out%Absorber_ID = atm%Absorber_ID + atm_out%Absorber_Units = atm%Absorber_Units ! ...Layer dependent data no = atm%n_Layers nt = atm_out%n_Layers - atm_out%Level_Pressure(na:nt) = atm%Level_Pressure(0:no) - atm_out%Pressure(na+1:nt) = atm%Pressure(1:no) - atm_out%Temperature(na+1:nt) = atm%Temperature(1:no) - atm_out%Absorber(na+1:nt,:) = atm%Absorber(1:no,:) + atm_out%Level_Pressure(na:nt) = atm%Level_Pressure(0:no) + atm_out%Pressure(na+1:nt) = atm%Pressure(1:no) + atm_out%Temperature(na+1:nt) = atm%Temperature(1:no) + atm_out%Absorber(na+1:nt,:) = atm%Absorber(1:no,:) + atm_out%Cloud_Fraction(na+1:nt) = atm%Cloud_Fraction(1:no) ! ...Cloud components IF ( atm%n_Clouds > 0 ) THEN DO i = 1, atm%n_Clouds @@ -702,6 +713,65 @@ ELEMENTAL FUNCTION CRTM_Atmosphere_AddLayerCopy( & END FUNCTION CRTM_Atmosphere_AddLayerCopy +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_Atmosphere_NonVariableCopy +! +! PURPOSE: +! Elemental utility subroutine to copy the "non-variable" data (climatology +! flag, absorber id/units, cloud type, aerosol type) from one instance of +! a CRTM Atmosphere object to another (usually a TL or AD one). +! +! NOTE: No error checking is performed in this procedure. It is assumed the +! two arguments are congruent in terms of absorber, cloud, and +! aerosol count. +! +! CALLING SEQUENCE: +! CALL CRTM_Atmosphere_NonVariableCopy( atm, modified_atm ) +! +! OBJECTS: +! atm: Atmosphere object from which to copy. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(IN) +! +! IN/OUTPUTS: +! modified_atm: Existing Atmosphere object to be modified. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Conformable with atm input +! ATTRIBUTES: INTENT(IN OUT) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + ELEMENTAL SUBROUTINE CRTM_Atmosphere_NonVariableCopy( atm, modified_atm ) + ! Arguments + TYPE(CRTM_Atmosphere_type), INTENT(IN) :: atm + TYPE(CRTM_Atmosphere_type), INTENT(IN OUT) :: modified_atm + ! Local variables + INTEGER :: j, n + + modified_atm%Climatology = atm%Climatology + DO j = 1, atm%n_Absorbers + modified_atm%Absorber_ID(j) = atm%Absorber_ID(j) + modified_atm%Absorber_Units(j) = atm%Absorber_Units(j) + END DO + ! Loop over and assign cloud types + DO n = 1, atm%n_Clouds + modified_atm%Cloud(n)%Type = atm%Cloud(n)%Type + END DO + ! Loop over and assign aerosol types + DO n = 1, atm%n_Aerosols + modified_atm%Aerosol(n)%Type = atm%Aerosol(n)%Type + END DO + + END SUBROUTINE CRTM_Atmosphere_NonVariableCopy + + !-------------------------------------------------------------------------------- !:sdoc+: ! @@ -737,14 +807,12 @@ ELEMENTAL SUBROUTINE CRTM_Atmosphere_Zero( Atmosphere ) ! Do nothing if structure is unused IF ( .NOT. CRTM_Atmosphere_Associated(Atmosphere) ) RETURN - ! Reset the added layer count - Atmosphere%n_Added_Layers = 0 - - ! Only zero out the data arrays - Atmosphere%Level_Pressure = ZERO - Atmosphere%Pressure = ZERO - Atmosphere%Temperature = ZERO - Atmosphere%Absorber = ZERO + ! Zero out the data + Atmosphere%Level_Pressure = ZERO + Atmosphere%Pressure = ZERO + Atmosphere%Temperature = ZERO + Atmosphere%Absorber = ZERO + Atmosphere%Cloud_Fraction = ZERO ! Reset the structure components IF ( Atmosphere%n_Clouds > 0 ) CALL CRTM_Cloud_Zero( Atmosphere%Cloud ) @@ -871,10 +939,15 @@ FUNCTION CRTM_Atmosphere_IsValid( Atm ) RESULT( IsValid ) IsValid = .FALSE. ENDIF IF ( ANY(Atm%Absorber < ZERO ) ) THEN - msg = 'Negative level absorber found' + msg = 'Negative layer absorber found' CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ) IsValid = .FALSE. ENDIF + IF ( ANY(Atm%Cloud_Fraction < ZERO) .OR. ANY(Atm%Cloud_Fraction > ONE) ) THEN + msg = 'Invalid layer cloud fraction found' + CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ) + IsValid = .FALSE. + ENDIF ! ...Structure components IF ( Atm%n_Clouds > 0 ) THEN DO nc = 1, Atm%n_Clouds @@ -972,6 +1045,8 @@ SUBROUTINE Scalar_Inspect( Atm, Unit ) TRIM(ABSORBER_UNITS_NAME(Atm%Absorber_Units(j))) WRITE(fid, '(5(1x,es13.6,:))') Atm%Absorber(1:k,j) END DO + WRITE(fid, '(3x,"Layer cloud fraction:")') + WRITE(fid, '(5(1x,es13.6,:))') Atm%Cloud_Fraction(1:k) ! Cloud information IF ( Atm%n_Clouds > 0 ) CALL CRTM_Cloud_Inspect(Atm%Cloud, Unit=Unit) ! Aerosol information @@ -1080,6 +1155,7 @@ ELEMENTAL FUNCTION CRTM_Atmosphere_Compare( & y, & n_SigFig ) & RESULT( is_comparable ) + ! Arguments TYPE(CRTM_Atmosphere_type), INTENT(IN) :: x, y INTEGER, OPTIONAL, INTENT(IN) :: n_SigFig LOGICAL :: is_comparable @@ -1095,39 +1171,40 @@ ELEMENTAL FUNCTION CRTM_Atmosphere_Compare( & n = DEFAULT_N_SIGFIG END IF - ! Check the structure association status - IF ( (.NOT. CRTM_Atmosphere_Associated(x)) .OR. & - (.NOT. CRTM_Atmosphere_Associated(y)) ) RETURN + ! Check the object association status + IF ( CRTM_Atmosphere_Associated(x) .NEQV. CRTM_Atmosphere_Associated(y) ) RETURN - ! Check scalars + ! Check contents + ! ...Dimensions IF ( (x%n_Layers /= y%n_Layers ) .OR. & (x%n_Absorbers /= y%n_Absorbers) .OR. & (x%n_Clouds /= y%n_Clouds ) .OR. & - (x%n_Aerosols /= y%n_Aerosols ) .OR. & - (x%Climatology /= y%Climatology) ) RETURN - - ! Check integer arrays - j = x%n_Absorbers - IF ( ANY(x%Absorber_ID(1:j) /= y%Absorber_ID(1:j) ) .OR. & - ANY(x%Absorber_Units(1:j) /= y%Absorber_Units(1:j)) ) RETURN - - ! Check floating point arrays - IF ( (.NOT. ALL(Compares_Within_Tolerance(x%Level_Pressure,y%Level_Pressure,n))) .OR. & - (.NOT. ALL(Compares_Within_Tolerance(x%Pressure ,y%Pressure ,n))) .OR. & - (.NOT. ALL(Compares_Within_Tolerance(x%Temperature ,y%Temperature ,n))) .OR. & - (.NOT. ALL(Compares_Within_Tolerance(x%Absorber ,y%Absorber ,n))) ) RETURN - - ! Check clouds - IF ( x%n_Clouds > 0 ) THEN - IF ( .NOT. ALL(CRTM_Cloud_Compare(x%Cloud,y%Cloud,n_SigFig=n)) ) RETURN - END IF - - ! Check aerosols - IF ( x%n_Aerosols > 0 ) THEN - IF ( .NOT. ALL(CRTM_Aerosol_Compare(x%Aerosol,y%Aerosol,n_SigFig=n)) ) RETURN + (x%n_Aerosols /= y%n_Aerosols ) ) RETURN + ! ...Scalars + IF ( (x%Climatology /= y%Climatology) ) RETURN + ! ...Arrays + IF ( CRTM_Atmosphere_Associated(x) .AND. CRTM_Atmosphere_Associated(y) ) THEN + ! ...Integer arrays + j = x%n_Absorbers + IF ( ANY(x%Absorber_ID(1:j) /= y%Absorber_ID(1:j) ) .OR. & + ANY(x%Absorber_Units(1:j) /= y%Absorber_Units(1:j)) ) RETURN + ! ...Floating point arrays + IF ( (.NOT. ALL(Compares_Within_Tolerance(x%Level_Pressure,y%Level_Pressure,n))) .OR. & + (.NOT. ALL(Compares_Within_Tolerance(x%Pressure ,y%Pressure ,n))) .OR. & + (.NOT. ALL(Compares_Within_Tolerance(x%Temperature ,y%Temperature ,n))) .OR. & + (.NOT. ALL(Compares_Within_Tolerance(x%Absorber ,y%Absorber ,n))) .OR. & + (.NOT. ALL(Compares_Within_Tolerance(x%Cloud_Fraction,y%Cloud_Fraction,n)))) RETURN + ! ...Clouds + IF ( x%n_Clouds > 0 ) THEN + IF ( .NOT. ALL(CRTM_Cloud_Compare(x%Cloud,y%Cloud,n_SigFig=n)) ) RETURN + END IF + ! ...Aerosols + IF ( x%n_Aerosols > 0 ) THEN + IF ( .NOT. ALL(CRTM_Aerosol_Compare(x%Aerosol,y%Aerosol,n_SigFig=n)) ) RETURN + END IF END IF - ! If we get here, the structures are comparable + ! If we get here, the objects are comparable is_comparable = .TRUE. END FUNCTION CRTM_Atmosphere_Compare @@ -1580,7 +1657,8 @@ FUNCTION Read_Atmosphere_Rank1( & CALL Read_Cleanup(); RETURN END IF ! ...Allocate the return structure array - ALLOCATE(Atmosphere(n_input_profiles), STAT=alloc_stat, ERRMSG=alloc_msg) + !ALLOCATE(Atmosphere(n_input_profiles), STAT=alloc_stat, ERRMSG=alloc_msg) + ALLOCATE(Atmosphere(n_input_profiles), STAT=alloc_stat) IF ( alloc_stat /= 0 ) THEN msg = 'Error allocating Atmosphere array - '//TRIM(alloc_msg) CALL Read_Cleanup(); RETURN @@ -1627,7 +1705,8 @@ SUBROUTINE Read_CleanUp() msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) END IF IF ( ALLOCATED(Atmosphere) ) THEN - DEALLOCATE(Atmosphere, STAT=alloc_stat, ERRMSG=alloc_msg) + !DEALLOCATE(Atmosphere, STAT=alloc_stat, ERRMSG=alloc_msg) + DEALLOCATE(Atmosphere, STAT=alloc_stat) IF ( alloc_stat /= 0 ) & msg = TRIM(msg)//'; Error deallocating Atmosphere array during error cleanup - '//& TRIM(alloc_msg) @@ -1695,7 +1774,8 @@ FUNCTION Read_Atmosphere_Rank2( & END IF ! ...Allocate the return structure array ALLOCATE(Atmosphere(n_input_channels, n_input_profiles), & - STAT=alloc_stat, ERRMSG=alloc_msg) + STAT=alloc_stat) + !STAT=alloc_stat, ERRMSG=alloc_msg) IF ( alloc_stat /= 0 ) THEN msg = 'Error allocating Atmosphere array - '//TRIM(alloc_msg) CALL Read_Cleanup(); RETURN @@ -1745,7 +1825,8 @@ SUBROUTINE Read_CleanUp() msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) END IF IF ( ALLOCATED(Atmosphere) ) THEN - DEALLOCATE(Atmosphere, STAT=alloc_stat, ERRMSG=alloc_msg) + !DEALLOCATE(Atmosphere, STAT=alloc_stat, ERRMSG=alloc_msg) + DEALLOCATE(Atmosphere, STAT=alloc_stat) IF ( alloc_stat /= 0 ) & msg = TRIM(msg)//'; Error deallocating Atmosphere array during error cleanup - '//& TRIM(alloc_msg) @@ -2080,40 +2161,87 @@ ELEMENTAL FUNCTION CRTM_Atmosphere_Equal( x, y ) RESULT( is_equal ) ! Set up is_equal = .FALSE. - ! Check the structure association status - IF ( (.NOT. CRTM_Atmosphere_Associated(x)) .OR. & - (.NOT. CRTM_Atmosphere_Associated(y)) ) RETURN + ! Check the object association status + IF ( CRTM_Atmosphere_Associated(x) .NEQV. CRTM_Atmosphere_Associated(y) ) RETURN ! Check contents - ! ...Scalars + ! ...Dimensions IF ( (x%n_Layers /= y%n_Layers ) .OR. & (x%n_Absorbers /= y%n_Absorbers) .OR. & (x%n_Clouds /= y%n_Clouds ) .OR. & - (x%n_Aerosols /= y%n_Aerosols ) .OR. & - (x%Climatology /= y%Climatology) ) RETURN + (x%n_Aerosols /= y%n_Aerosols ) ) RETURN + ! ...Scalars + IF ( (x%Climatology /= y%Climatology) ) RETURN ! ...Arrays - k = x%n_Layers - j = x%n_Absorbers - IF ( ALL(x%Absorber_ID(1:j) == y%Absorber_ID(1:j) ) .AND. & - ALL(x%Absorber_Units(1:j) == y%Absorber_Units(1:j)) .AND. & - ALL(x%Level_Pressure(0:) .EqualTo. y%Level_Pressure(0:)) .AND. & - ALL(x%Pressure(1:k) .EqualTo. y%Pressure(1:k) ) .AND. & - ALL(x%Temperature(1:k) .EqualTo. y%Temperature(1:k) ) .AND. & - ALL(x%Absorber(1:k,1:j) .EqualTo. y%Absorber(1:k,1:j) ) ) is_equal = .TRUE. - ! ...Clouds - IF ( x%n_Clouds > 0 ) THEN - IF ( ALL(CRTM_Cloud_Associated(x%Cloud)) .AND. ALL(CRTM_Cloud_Associated(y%Cloud)) ) & - is_equal = is_equal .AND. ALL(x%Cloud == y%Cloud) - END IF - ! ...Aerosols - IF ( x%n_Aerosols > 0 ) THEN - IF ( ALL(CRTM_Aerosol_Associated(x%Aerosol)) .AND. ALL(CRTM_Aerosol_Associated(y%Aerosol)) ) & - is_equal = is_equal .AND. ALL(x%Aerosol == y%Aerosol) + IF ( CRTM_Atmosphere_Associated(x) .AND. CRTM_Atmosphere_Associated(y) ) THEN + k = x%n_Layers + j = x%n_Absorbers + IF ( .NOT. (ALL(x%Absorber_ID(1:j) == y%Absorber_ID(1:j) ) .AND. & + ALL(x%Absorber_Units(1:j) == y%Absorber_Units(1:j)) .AND. & + ALL(x%Level_Pressure(0:k) .EqualTo. y%Level_Pressure(0:k)) .AND. & + ALL(x%Pressure(1:k) .EqualTo. y%Pressure(1:k) ) .AND. & + ALL(x%Temperature(1:k) .EqualTo. y%Temperature(1:k) ) .AND. & + ALL(x%Absorber(1:k,1:j) .EqualTo. y%Absorber(1:k,1:j) ) .AND. & + ALL(x%Cloud_Fraction(1:k) .EqualTo. y%Cloud_Fraction(1:k))) ) RETURN + ! ...Clouds + IF ( x%n_Clouds > 0 ) THEN + IF ( .NOT. ALL(x%Cloud == y%Cloud) ) RETURN + END IF + ! ...Aerosols + IF ( x%n_Aerosols > 0 ) THEN + IF ( .NOT. ALL(x%Aerosol == y%Aerosol) ) RETURN + END IF END IF + + + ! If we get here, then... + is_equal = .TRUE. END FUNCTION CRTM_Atmosphere_Equal +!------------------------------------------------------------------------------ +! +! NAME: +! CRTM_Atmosphere_NotEqual +! +! PURPOSE: +! Elemental function to test the inequality of two CRTM Atmosphere objects. +! Used in OPERATOR(/=) interface block. +! +! This function is syntactic sugar. +! +! CALLING SEQUENCE: +! not_equal = CRTM_Atmosphere_NotEqual( x, y ) +! +! or +! +! IF ( x /= y ) THEN +! ... +! END IF +! +! OBJECTS: +! x, y: Two CRTM Atmosphere objects to be compared. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! not_equal: Logical value indicating whether the inputs are not equal. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Same as inputs. +! +!------------------------------------------------------------------------------ + + ELEMENTAL FUNCTION CRTM_Atmosphere_NotEqual( x, y ) RESULT( not_equal ) + TYPE(CRTM_Atmosphere_type), INTENT(IN) :: x, y + LOGICAL :: not_equal + not_equal = .NOT. (x == y) + END FUNCTION CRTM_Atmosphere_NotEqual + + !-------------------------------------------------------------------------------- ! ! NAME: @@ -2163,7 +2291,7 @@ ELEMENTAL FUNCTION CRTM_Atmosphere_Add( atm1, atm2 ) RESULT( atmsum ) atm1%n_Clouds /= atm2%n_Clouds .OR. & atm1%n_Aerosols /= atm2%n_Aerosols .OR. & atm1%n_Added_Layers /= atm2%n_Added_Layers ) RETURN - ! ...Dimenions the same, check absorber info + ! ...Dimensions the same, check absorber info IF ( ANY(atm1%Absorber_ID /= atm2%Absorber_ID ) .OR. & ANY(atm1%Absorber_Units /= atm2%Absorber_Units) ) RETURN @@ -2177,6 +2305,7 @@ ELEMENTAL FUNCTION CRTM_Atmosphere_Add( atm1, atm2 ) RESULT( atmsum ) atmsum%Pressure(1:k) = atmsum%Pressure(1:k) + atm2%Pressure(1:k) atmsum%Temperature(1:k) = atmsum%Temperature(1:k) + atm2%Temperature(1:k) atmsum%Absorber(1:k,1:j) = atmsum%Absorber(1:k,1:j) + atm2%Absorber(1:k,1:j) + atmsum%Cloud_Fraction(1:k) = atmsum%Cloud_Fraction(1:k) + atm2%Cloud_Fraction(1:k) ! ...Cloud component IF ( atm1%n_Clouds > 0 ) THEN DO i = 1, atm1%n_Clouds @@ -2243,7 +2372,7 @@ ELEMENTAL FUNCTION CRTM_Atmosphere_Subtract( atm1, atm2 ) RESULT( atmdiff ) atm1%n_Clouds /= atm2%n_Clouds .OR. & atm1%n_Aerosols /= atm2%n_Aerosols .OR. & atm1%n_Added_Layers /= atm2%n_Added_Layers ) RETURN - ! ...Dimenions the same, check absorber info + ! ...Dimensions the same, check absorber info IF ( ANY(atm1%Absorber_ID /= atm2%Absorber_ID ) .OR. & ANY(atm1%Absorber_Units /= atm2%Absorber_Units) ) RETURN @@ -2257,6 +2386,7 @@ ELEMENTAL FUNCTION CRTM_Atmosphere_Subtract( atm1, atm2 ) RESULT( atmdiff ) atmdiff%Pressure(1:k) = atmdiff%Pressure(1:k) - atm2%Pressure(1:k) atmdiff%Temperature(1:k) = atmdiff%Temperature(1:k) - atm2%Temperature(1:k) atmdiff%Absorber(1:k,1:j) = atmdiff%Absorber(1:k,1:j) - atm2%Absorber(1:k,1:j) + atmdiff%Cloud_Fraction(1:k) = atmdiff%Cloud_Fraction(1:k) - atm2%Cloud_Fraction(1:k) ! ...Cloud component IF ( atm1%n_Clouds > 0 ) THEN DO i = 1, atm1%n_Clouds @@ -2350,7 +2480,8 @@ FUNCTION Read_Record( & atm%Level_Pressure, & atm%Pressure, & atm%Temperature, & - atm%Absorber + atm%Absorber, & + atm%Cloud_Fraction IF ( io_stat /= 0 ) THEN msg = 'Error reading atmospheric profile data - '//TRIM(io_msg) CALL Read_Record_Cleanup(); RETURN @@ -2465,7 +2596,8 @@ FUNCTION Write_Record( & atm%Level_Pressure(0:atm%n_Layers), & atm%Pressure(1:atm%n_Layers), & atm%Temperature(1:atm%n_Layers), & - atm%Absorber(1:atm%n_Layers,:) + atm%Absorber(1:atm%n_Layers,:), & + atm%Cloud_Fraction(1:atm%n_Layers) IF ( io_stat /= 0 ) THEN msg = 'Error writing atmospheric profile data - '//TRIM(io_msg) CALL Write_Record_Cleanup(); RETURN diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_ChannelInfo_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_ChannelInfo_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_ChannelInfo_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_ChannelInfo_Define.f90 index 84bc61600c..28cb064e66 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_ChannelInfo_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_ChannelInfo_Define.f90 @@ -62,7 +62,7 @@ MODULE CRTM_ChannelInfo_Define ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_ChannelInfo_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_ChannelInfo_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_CloudCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_CloudCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_CloudCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_CloudCoeff.f90 index 4072a69880..bd5df1f53c 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_CloudCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_CloudCoeff.f90 @@ -53,7 +53,7 @@ MODULE CRTM_CloudCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_CloudCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_CloudCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.3.0/libsrc/CRTM_CloudCover_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_CloudCover_Define.f90 new file mode 100644 index 0000000000..7246f2a221 --- /dev/null +++ b/var/external/crtm_2.3.0/libsrc/CRTM_CloudCover_Define.f90 @@ -0,0 +1,1973 @@ +! +! CRTM_CloudCover_Define +! +! Module defining the CRTM Cloud Cover object and its methods. +! +! +! CREATION HISTORY: +! Written by: Paul van Delst, 16-Sep-2015 +! paul.vandelst@noaa.gov +! + +MODULE CRTM_CloudCover_Define + + + ! ----------------- + ! Environment setup + ! ----------------- + ! Intrinsic modules + USE ISO_Fortran_Env , ONLY: OUTPUT_UNIT + ! Module use + USE Type_Kinds , ONLY: fp + USE File_Utility , ONLY: File_Open + USE Message_Handler , ONLY: SUCCESS, FAILURE, WARNING, INFORMATION, Display_Message + USE Compare_Float_Numbers , ONLY: DEFAULT_N_SIGFIG, & + OPERATOR(.EqualTo.), & + Compares_Within_Tolerance + USE CRTM_Parameters , ONLY: ZERO, ONE, & + WATER_CONTENT_THRESHOLD + USE CRTM_Atmosphere_Define, ONLY: CRTM_Atmosphere_type, & + CRTM_Atmosphere_Associated + USE CRTM_Cloud_Define , ONLY: OPERATOR(==), & + OPERATOR(+), & + CRTM_Cloud_type, & + CRTM_Cloud_Associated, & + CRTM_Cloud_Zero + ! Disable implicit typing + IMPLICIT NONE + + + ! ------------ + ! Visibilities + ! ------------ + ! Everything private by default + PRIVATE + ! Parameters + PUBLIC :: DEFAULT_OVERLAP_ID + ! Datatypes + PUBLIC :: CRTM_CloudCover_type + ! "Class" methods + PUBLIC :: CloudCover_Maximum_Overlap + PUBLIC :: CloudCover_Random_Overlap + PUBLIC :: CloudCover_MaxRan_Overlap + PUBLIC :: CloudCover_Average_Overlap + PUBLIC :: CloudCover_Overcast_Overlap + PUBLIC :: CloudCover_Overlap_IsValid + PUBLIC :: CloudCover_Overlap_Name + + + ! ----------------- + ! Module parameters + ! ----------------- + CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & + '$Id: CRTM_CloudCover_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' + ! The valid cloud categories and names +! INTEGER, PARAMETER :: N_OVERLAPS = 4 + INTEGER, PARAMETER :: N_OVERLAPS = 5 + INTEGER, PARAMETER :: INVALID_OVERLAP_ID = 0 + INTEGER, PARAMETER :: MAXIMUM_OVERLAP_ID = 1 + INTEGER, PARAMETER :: RANDOM_OVERLAP_ID = 2 + INTEGER, PARAMETER :: MAXRAN_OVERLAP_ID = 3 + INTEGER, PARAMETER :: AVERAGE_OVERLAP_ID = 4 + INTEGER, PARAMETER :: OVERCAST_OVERLAP_ID =5 + CHARACTER(*), PARAMETER :: OVERLAP_NAMES(0:N_OVERLAPS) = & + [ 'Invalid ', & + 'Maximum ', & + 'Random ', & + 'Maximum-random', & + 'Average ', & + 'Overcast ' ] + INTEGER, PARAMETER :: DEFAULT_OVERLAP_ID = AVERAGE_OVERLAP_ID + ! Message string length + INTEGER, PARAMETER :: ML = 256 + ! File status on close after write error + CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE' + + + ! ----------------------------- + ! CloudCover object definitions + ! ----------------------------- + ! Private object for intermediate results + ! Only used and acessible in this module + TYPE, PRIVATE :: iVar_type + ! Housekeeping + LOGICAL :: Is_Allocated = .FALSE. ! Allocation indicator + INTEGER :: n_Layers = 0 ! K dimension. + INTEGER :: n_Clouds = 0 ! N dimension. + ! Data + REAL(fp), ALLOCATABLE :: prod(:) ! 0:K. Product across layers + REAL(fp), ALLOCATABLE :: lwc(:) ! 1:K. Total layer water content for ALL clouds + REAL(fp), ALLOCATABLE :: wc_sum(:) ! 0:K. Cumulative sum of lwc at each layer + REAL(fp), ALLOCATABLE :: cwc_sum(:) ! 0:K. Cumulative sum of the weighted lwc at each layer + REAL(fp), ALLOCATABLE :: wc(:,:) ! 1:N 1:K. layer water content for each cloud type + REAL(fp), ALLOCATABLE :: maxcov(:) ! 1:K. Max cloud fraction between two layers + CONTAINS + PROCEDURE, PASS(self) :: Is_Usable => iVar_Is_Usable + PROCEDURE, PASS(self) :: Destroy => iVar_Destroy + PROCEDURE, PASS(self) :: Create => iVar_Create + PROCEDURE, PASS(self) :: Inspect => iVar_Inspect + PROCEDURE, PASS(self) :: Set_To_Zero => iVar_Set_To_Zero + PROCEDURE :: iVar_Equal + PROCEDURE :: iVar_NotEqual + PROCEDURE :: iVar_Compare + GENERIC :: OPERATOR(==) => iVar_Equal + GENERIC :: OPERATOR(/=) => iVar_NotEqual + GENERIC :: OPERATOR(.Compare.) => iVar_Compare + END TYPE iVar_type + + + ! The main object definition + !:tdoc+: + TYPE :: CRTM_CloudCover_type + ! Housekeeping + LOGICAL :: Is_Allocated = .FALSE. ! Allocation indicator + INTEGER :: n_Layers = 0 ! K dimension. + ! Data + INTEGER :: Overlap = DEFAULT_OVERLAP_ID ! Overlap type identifier + REAL(fp) :: Total_Cloud_Cover = ZERO ! Cloud cover used in RT + REAL(fp), ALLOCATABLE :: Cloud_Fraction(:) ! K. The physical cloud fraction + REAL(fp), ALLOCATABLE :: Cloud_Cover(:) ! K. The overlap cloud cover + ! Intermediate results + TYPE(iVar_type) :: iVar ! FWD results for TL/AD + CONTAINS + PRIVATE + PROCEDURE, PUBLIC, PASS(self) :: Overlap_Id + PROCEDURE, PUBLIC, PASS(self) :: Overlap_Name + PROCEDURE, PUBLIC, PASS(self) :: Compute_CloudCover + PROCEDURE, PUBLIC, PASS(self_TL) :: Compute_CloudCover_TL + PROCEDURE, PUBLIC, PASS(self_AD) :: Compute_CloudCover_AD + PROCEDURE, PUBLIC, PASS(self) :: Is_Usable + PROCEDURE, PUBLIC, PASS(self) :: Destroy + PROCEDURE, PUBLIC, PASS(self) :: Create + PROCEDURE, PUBLIC, PASS(self) :: Inspect + PROCEDURE, PUBLIC, PASS(self) :: Set_To_Zero + PROCEDURE :: Equal + PROCEDURE :: NotEqual + PROCEDURE :: Compare_ + GENERIC, PUBLIC :: OPERATOR(==) => Equal + GENERIC, PUBLIC :: OPERATOR(/=) => NotEqual + GENERIC, PUBLIC :: OPERATOR(.Compare.) => Compare_ + END TYPE CRTM_CloudCover_type + !:tdoc-: + +CONTAINS + + +!################################################################################ +!################################################################################ +!## ## +!## ## PUBLIC MODULE PROCEDURES ## ## +!## ## +!################################################################################ +!################################################################################ + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CloudCover_Maximum_Overlap +! CloudCover_Random_Overlap +! CloudCover_MaxRan_Overlap +! CloudCover_Average_Overlap +! CloudCover_Overcast_Overlap +! +! PURPOSE: +! Group of pure functions to supply the overlap methodology indicator. +! +! CALLING SEQUENCE: +! id = CloudCover_Maximum_Overlap() +! id = CloudCover_Random_Overlap() +! id = CloudCover_MaxRan_Overlap() +! id = CloudCover_Average_Overlap() +! id = CloudCover_Overcast_Overlap() +! +! FUNCTION RESULT: +! id: The return value is an integer defining the overlap methodology. +! The actual number value of these integers in a CRTM release can +! change at any time based upon code updates. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + PURE FUNCTION CloudCover_Maximum_Overlap() RESULT(id) + INTEGER :: id + id = MAXIMUM_OVERLAP_ID + END FUNCTION CloudCover_Maximum_Overlap + + PURE FUNCTION CloudCover_Random_Overlap() RESULT(id) + INTEGER :: id + id = RANDOM_OVERLAP_ID + END FUNCTION CloudCover_Random_Overlap + + PURE FUNCTION CloudCover_MaxRan_Overlap() RESULT(id) + INTEGER :: id + id = MAXRAN_OVERLAP_ID + END FUNCTION CloudCover_MaxRan_Overlap + + PURE FUNCTION CloudCover_Average_Overlap() RESULT(id) + INTEGER :: id + id = AVERAGE_OVERLAP_ID + END FUNCTION CloudCover_Average_Overlap + + PURE FUNCTION CloudCover_Overcast_Overlap() RESULT(id) + INTEGER :: id + id = OVERCAST_OVERLAP_ID + END FUNCTION CloudCover_Overcast_Overlap + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CloudCover_Overlap_IsValid +! +! PURPOSE: +! Pure function to test if an overlap methodology identifier is valid. +! +! CALLING SEQUENCE: +! is_valid = CloudCover_Overlap_IsValid( id ) +! +! INPUTS: +! id: The overlap methodology identifier. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! is_valid: Logical variable indicating whether or not the input overlap +! methodology identifier is valid. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + PURE FUNCTION CloudCover_Overlap_IsValid(id) RESULT(is_valid) + INTEGER, INTENT(IN) :: id + LOGICAL :: is_valid + is_valid = (id >= 1 .AND. id <= N_OVERLAPS) + END FUNCTION CloudCover_Overlap_IsValid + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CloudCover_Overlap_Name +! +! PURPOSE: +! Pure function to return a string description of the overlap methodology +! given its identifier. +! +! CALLING SEQUENCE: +! name = CloudCover_Overlap_Name( id ) +! +! INPUTS: +! id: The overlap methodology identifier. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! name: Character variable containing a short descriptor of the overlap +! methodology. If the input identifier is invalid, the returned +! string is "Invalid". +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + PURE FUNCTION CloudCover_Overlap_Name(id) RESULT(name) + INTEGER, INTENT(IN) :: id + CHARACTER(LEN(OVERLAP_NAMES(1))) :: name + IF ( CloudCover_Overlap_IsValid(id) ) THEN + name = OVERLAP_NAMES(id) + ELSE + name = OVERLAP_NAMES(INVALID_OVERLAP_ID) + END IF + END FUNCTION CloudCover_Overlap_Name + + + +!################################################################################ +!################################################################################ +!## ## +!## ## PUBLIC MODULE METHODS ## ## +!## ## +!################################################################################ +!################################################################################ + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! Overlap_Id +! +! PURPOSE: +! Function method to return the overlap methodology identifier of a +! CloudCover object. +! +! CALLING SEQUENCE: +! id = cc_obj%Overlap_Id() +! +! OBJECTS: +! cc_obj: Cloud cover object for which the overlap methodology identifier +! is required. +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! FUNCTION RESULT: +! id: The return value is an integer defining the overlap methodology. +! The actual number value of these integers in a CRTM release can +! change at any time based upon code updates. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + PURE FUNCTION Overlap_Id(self) RESULT(id) + CLASS(CRTM_CloudCover_type), INTENT(IN) :: self + INTEGER :: id + id = self%Overlap + IF ( id < 1 .OR. id > N_OVERLAPS ) id = INVALID_OVERLAP_ID + END FUNCTION Overlap_Id + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! Overlap_Name +! +! PURPOSE: +! Function method to return a string description of the overlap methodology +! that has been set for a CloudCover object. +! +! CALLING SEQUENCE: +! name = cc_obj%Overlap_Name() +! +! OBJECTS: +! cc_obj: Cloud cover object for which the overlap methodology descriptor +! is required. +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! name: Character variable containing a short descriptor of the overlap +! methodology. If the object's overlap methodology identifier is +! invalid, the returned string is "Invalid". +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + PURE FUNCTION Overlap_Name(self) RESULT(name) + CLASS(CRTM_CloudCover_type), INTENT(IN) :: self + CHARACTER(LEN(OVERLAP_NAMES(1))) :: name + name = OVERLAP_NAMES(self%Overlap_Id()) + END FUNCTION Overlap_Name + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! Compute_CloudCover +! +! PURPOSE: +! Function method to compute the cloud cover profile given a supplied +! Atmosphere object, and populate the CloudCover object with the +! results. +! +! CALLING SEQUENCE: +! err_stat = cc_obj%Compute_CloudCover( & +! atmosphere , & +! Overlap = overlap ) +! +! OBJECTS: +! cc_obj: Cloud cover object which is to be populated with cloud +! cover results. +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! INPUTS: +! atmosphere: Atmopshere object containing the layer cloud fraction +! profile, and the actual cloud profiles for when cloud +! water content averaging of the cloud cover is selected. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! overlap: Set this argument to a flag defining the cloud coverage +! algorithm used. Supplied module functions providing valid flag +! output are: +! CloudCover_Maximum_Overlap(): Use maximum overlap method. +! CloudCover_Random_Overlap() : Use random overlap method. +! CloudCover_MaxRan_Overlap() : Use maximum-random overlap method. +! CloudCover_Average_Overlap(): Use cloud content weighted averaged method. [DEFAULT] +! CloudCover_Overcast_Overlap():Overcast. [Test] +! If not specified, the default is the cloud content weighted +! averaged method +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! FUNCTION RESULT: +! 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 successful +! == FAILURE, an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION Compute_CloudCover( & + self , & ! Output + atm , & ! In/Output + overlap) & ! Optional input + RESULT(err_stat) + ! Arguments + CLASS(CRTM_CloudCover_type), INTENT(OUT) :: self + TYPE(CRTM_Atmosphere_type) , INTENT(INOUT):: atm + INTEGER, OPTIONAL, INTENT(IN) :: overlap + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'CRTM_CloudCover_Define::Compute_CloudCover' + REAL(fp), PARAMETER :: MIN_COVERAGE_THRESHOLD = 1.0e-06_fp + REAL(fp), PARAMETER :: MAX_COVERAGE_THRESHOLD = ONE - MIN_COVERAGE_THRESHOLD + ! Local variables + CHARACTER(ML) :: err_msg + INTEGER :: overlap_method + INTEGER :: n_layers + INTEGER :: n_clouds + INTEGER :: n + ! Check input + err_stat = SUCCESS + IF ( .NOT. CRTM_Atmosphere_Associated(atm) ) THEN + err_msg = 'Input atmosphere is not usable' + err_stat = FAILURE + CALL Display_Message(PROCEDURE_NAME, err_msg, err_stat); RETURN + END IF + ! ...Overlap keyword + overlap_method = DEFAULT_OVERLAP_ID + IF ( PRESENT(overlap) ) overlap_method = overlap + ! ...and check it. + IF ( .NOT. CloudCover_Overlap_IsValid(overlap_method) ) THEN + err_msg = 'Invalid overlap assumption' + err_stat = FAILURE + CALL Display_Message(PROCEDURE_NAME, err_msg, err_stat); RETURN + END IF + + + ! Create the output object + n_layers = Atm%n_Layers + n_clouds = Atm%n_Clouds +! CALL self%Create(n_layers, Forward = .TRUE., Error_Message = err_msg) + CALL self%Create(n_layers, n_clouds, Forward = .TRUE., Error_Message = err_msg) + IF ( .NOT. self%Is_Usable() ) THEN + err_stat = FAILURE + CALL Display_Message(PROCEDURE_NAME, err_msg, err_stat); RETURN + END IF + + + ! Set the object quantities + self%Overlap = overlap_method + self%Cloud_Fraction = atm%Cloud_Fraction(1:atm%n_Layers) + + DO n = 1, n_clouds + self%iVar%wc(n,1:n_layers) = atm%Cloud(n)%Water_Content(1:n_layers) ! save for TL/AD + END DO + + ! Compute the cloud cover + SELECT CASE (self%Overlap) + CASE (MAXIMUM_OVERLAP_ID); CALL Compute_Maximum_Overlap() + CASE (RANDOM_OVERLAP_ID) ; CALL Compute_Random_Overlap() + CASE (MAXRAN_OVERLAP_ID) ; CALL Compute_MaxRan_Overlap() + CASE (AVERAGE_OVERLAP_ID); CALL Compute_Average_Overlap() + CASE (OVERCAST_OVERLAP_ID);CALL Compute_Overcast_Overlap() + END SELECT + + ! Add cloud scaling here! + ! Partition all hydrometeors into cloudy column + IF (self%Total_Cloud_Cover > MIN_COVERAGE_THRESHOLD) then + DO n = 1, n_clouds + ! scaled cloud water content + atm%Cloud(n)%Water_Content(1:n_layers) = atm%Cloud(n)%Water_Content(1:n_layers) / self%Total_Cloud_Cover + END DO + END IF + + CONTAINS + + SUBROUTINE Compute_Maximum_Overlap() + INTEGER :: k + self%Cloud_Cover(1) = self%Cloud_Fraction(1) + DO k = 2, n_layers + IF ( self%Cloud_Fraction(k) > self%Cloud_Cover(k-1) ) THEN + self%Cloud_Cover(k) = self%Cloud_Fraction(k) + ELSE + self%Cloud_Cover(k) = self%Cloud_Cover(k-1) + END IF + END DO + self%Total_Cloud_Cover = self%Cloud_Cover(n_layers) + END SUBROUTINE Compute_Maximum_Overlap + +! SUBROUTINE Compute_Random_Overlap() +! INTEGER :: k +! REAL(fp) :: prod +! prod = ONE +! self%iVar%prod(0) = prod +! DO k = 1, n_layers +! prod = prod * (ONE - self%Cloud_Fraction(k)) +! self%Cloud_Cover(k) = ONE - prod +! self%iVar%prod(k) = prod ! Save for TL/AD +! END DO +! self%Total_Cloud_Cover = self%Cloud_Cover(n_layers) +! END SUBROUTINE Compute_Random_Overlap + SUBROUTINE Compute_Random_Overlap() + INTEGER :: k + REAL(fp) :: prod(0:n_layers) + prod(0) = ONE + self%iVar%prod(0) = prod(0) + DO k = 1, n_layers + if (self%Cloud_Fraction(k) > MIN_COVERAGE_THRESHOLD) then + prod(k) = prod(k-1) * (ONE - self%Cloud_Fraction(k)) + else + prod(k) = prod(k-1) + endif + self%Cloud_Cover(k) = ONE - prod(k) + self%iVar%prod(k) = prod(k) ! Save for TL/AD + END DO + self%Total_Cloud_Cover = self%Cloud_Cover(n_layers) + END SUBROUTINE Compute_Random_Overlap + +! SUBROUTINE Compute_MaxRan_Overlap() +! INTEGER :: k +! REAL(fp) :: prod +! prod = ONE - self%Cloud_Fraction(1) +! self%iVar%prod(1) = prod +! self%Cloud_Cover(1) = ONE - prod +! DO k = 2, n_layers +! IF ( self%Cloud_Fraction(k) > self%Cloud_Fraction(k-1) ) THEN +! prod = prod * (ONE - self%Cloud_Fraction(k)) / (ONE - self%Cloud_Fraction(k-1)) +! END IF +! self%Cloud_Cover(k) = ONE - prod +! self%iVar%prod(k) = prod ! Save for TL/AD +! END DO +! self%Total_Cloud_Cover = self%Cloud_Cover(n_layers) +! END SUBROUTINE Compute_MaxRan_Overlap + SUBROUTINE Compute_MaxRan_Overlap() + INTEGER :: k + REAL(fp) :: prod, maxcov + + prod = ONE - self%Cloud_Fraction(1) + self%Cloud_Cover(1) = ONE - prod + self%iVar%prod(1) = prod + self%iVar%maxcov(1) = ONE - self%Cloud_Fraction(1) + DO k= 2, n_layers + maxcov = (ONE - MAX(self%Cloud_Fraction(k-1), self%Cloud_Fraction(k))) + prod = prod * maxcov / (one - self%Cloud_Fraction(k-1)) + self%iVar%maxcov(k) = maxcov + self%iVar%prod(k) = prod + self%Cloud_Cover(k) = ONE - prod + ENDDO + self%Total_Cloud_Cover = self%Cloud_Cover(n_layers) + END SUBROUTINE Compute_MaxRan_Overlap + + SUBROUTINE Compute_Average_Overlap() + INTEGER :: k, n + + ! Give the variables shorter names + ASSOCIATE( lwc => self%iVar%lwc , & + wc_sum => self%iVar%wc_sum , & + cwc_sum => self%iVar%cwc_sum , & + cf => self%Cloud_Fraction, & + cc => self%Cloud_Cover , & + cloud => atm%Cloud ) + + ! The total layer water content + lwc = ZERO + DO n = 1, SIZE(cloud) + WHERE (cloud(n)%Water_Content > WATER_CONTENT_THRESHOLD ) & + lwc = lwc + cloud(n)%Water_Content(1:n_layers) + END DO + + ! The cloud cover profile + wc_sum(0) = ZERO + cwc_sum(0) = ZERO + DO k = 1, n_layers + wc_sum(k) = wc_sum(k-1) + lwc(k) + cwc_sum(k) = cwc_sum(k-1) + (cf(k) * lwc(k)) + IF ( wc_sum(k) > ZERO ) cc(k) = cwc_sum(k)/wc_sum(k) + END DO + + END ASSOCIATE + + ! Extract out the total cloud cover + self%Total_Cloud_Cover = self%Cloud_Cover(n_layers) + + END SUBROUTINE Compute_Average_Overlap + + SUBROUTINE Compute_Overcast_Overlap() + + self%Total_Cloud_Cover = ONE + + END SUBROUTINE Compute_Overcast_Overlap + + END FUNCTION Compute_CloudCover + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! Compute_CloudCover_TL +! +! PURPOSE: +! Function method to compute the tangent-linear cloud cover profile for +! supplied forward model results and a Atmosphere perturbation, and populate +! the tangent-linear CloudCover object with the results. +! +! CALLING SEQUENCE: +! err_stat = cc_obj_TL%Compute_CloudCover_TL( & +! cc_FWD , & +! atmosphere , & +! atmosphere_TL ) +! +! OBJECTS: +! cc_obj_TL: The tangent-linear cloud cover object which is to be +! populated with perturbed cloud cover results. +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! INPUTS: +! cc_FWD: The forward model cloud cover object. +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! atmosphere: Atmopshere object containing the layer cloud fraction +! profile, and the actual cloud profiles for when cloud +! water content averaging of the cloud cover is selected. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! atmosphere_TL: The tangent-linear atmosphere object containing the layer +! cloud fraction perturbation profile, and the cloud amount +! perturbation profiles for when cloud water content averaging +! of the cloud cover is selected. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! 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 successful +! == FAILURE, an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION Compute_CloudCover_TL( & + self_TL, & ! Output + cc_FWD , & ! Input + atm , & ! Input + atm_TL ) & ! In/Outupt + RESULT(err_stat) + ! Arguments + CLASS(CRTM_CloudCover_type), INTENT(OUT) :: self_TL + CLASS(CRTM_CloudCover_type), INTENT(IN) :: cc_FWD + TYPE(CRTM_Atmosphere_type) , INTENT(IN) :: atm + TYPE(CRTM_Atmosphere_type) , INTENT(INOUT):: atm_TL + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'CRTM_CloudCover_Define::Compute_CloudCover_TL' + REAL(fp), PARAMETER :: MIN_COVERAGE_THRESHOLD = 1.0e-06_fp + REAL(fp), PARAMETER :: MAX_COVERAGE_THRESHOLD = ONE - MIN_COVERAGE_THRESHOLD + ! Local variables + CHARACTER(ML) :: err_msg + INTEGER :: n_layers + INTEGER :: n_clouds + INTEGER :: n + ! Check inputs + err_stat = SUCCESS + IF ( .NOT. cc_FWD%Is_Usable( Include_iVar=.TRUE. ) ) THEN + err_msg = 'Input forward cloud cover object is not usable' + err_stat = FAILURE + CALL Display_Message(PROCEDURE_NAME, err_msg, err_stat); RETURN + END IF + IF ( .NOT. CRTM_Atmosphere_Associated(atm) ) THEN + err_msg = 'Input atmosphere object is not usable' + err_stat = FAILURE + CALL Display_Message(PROCEDURE_NAME, err_msg, err_stat); RETURN + END IF + IF ( .NOT. CRTM_Atmosphere_Associated(atm_TL) ) THEN + err_msg = 'Input tangent-linear atmosphere object is not usable' + err_stat = FAILURE + CALL Display_Message(PROCEDURE_NAME, err_msg, err_stat); RETURN + END IF + + + ! Create the output object + n_layers = Atm_TL%n_Layers + n_clouds = Atm_TL%n_Clouds +! CALL self_TL%Create(n_layers, Error_Message = err_msg) + CALL self_TL%Create(n_layers, n_clouds, Error_Message = err_msg) + IF ( .NOT. self_TL%Is_Usable() ) THEN + err_stat = FAILURE + CALL Display_Message(PROCEDURE_NAME, err_msg, err_stat); RETURN + END IF + + + ! Set the object quantities + self_TL%Overlap = cc_FWD%Overlap + self_TL%Cloud_Fraction = atm_TL%Cloud_Fraction(1:atm_TL%n_Layers) + + + ! Compute the cloud cover + SELECT CASE (self_TL%Overlap) + CASE (MAXIMUM_OVERLAP_ID); CALL Compute_Maximum_Overlap_TL() + CASE (RANDOM_OVERLAP_ID) ; CALL Compute_Random_Overlap_TL() + CASE (MAXRAN_OVERLAP_ID) ; CALL Compute_MaxRan_Overlap_TL() + CASE (AVERAGE_OVERLAP_ID); CALL Compute_Average_Overlap_TL() + CASE (OVERCAST_OVERLAP_ID);CALL Compute_Overcast_Overlap_TL() + END SELECT + + ! Add TL of cloud scaling here! + ! Partition all hydrometeors into cloudy column + IF (cc_FWD%Total_Cloud_Cover > MIN_COVERAGE_THRESHOLD) then + DO n = 1, n_clouds + atm_TL%Cloud(n)%Water_Content(1:n_layers) = & + atm_TL%Cloud(n)%Water_Content(1:n_layers) / cc_FWD%Total_Cloud_Cover & + - self_TL%Total_Cloud_Cover * cc_FWD%iVar%wc(n,1:n_layers) / (cc_FWD%Total_Cloud_Cover**2) + END DO + END IF + + CONTAINS + + SUBROUTINE Compute_Maximum_Overlap_TL() + INTEGER :: k + self_TL%Cloud_Cover(1) = self_TL%Cloud_Fraction(1) + DO k = 2, n_layers + IF ( cc_FWD%Cloud_Fraction(k) > cc_FWD%Cloud_Cover(k-1) ) THEN + self_TL%Cloud_Cover(k) = self_TL%Cloud_Fraction(k) + ELSE + self_TL%Cloud_Cover(k) = self_TL%Cloud_Cover(k-1) + END IF + END DO + self_TL%Total_Cloud_Cover = self_TL%Cloud_Cover(n_layers) + END SUBROUTINE Compute_Maximum_Overlap_TL + +! SUBROUTINE Compute_Random_Overlap_TL() +! INTEGER :: k +! REAL(fp) :: prod_TL +! prod_TL = ZERO +! DO k = 1, n_layers +! prod_TL = (ONE - cc_FWD%Cloud_Fraction(k))*prod_TL - & +! cc_FWD%iVar%prod(k-1)*self_TL%Cloud_Fraction(k) +! self_TL%Cloud_Cover(k) = -prod_TL +! END DO +! self_TL%Total_Cloud_Cover = self_TL%Cloud_Cover(n_layers) +! END SUBROUTINE Compute_Random_Overlap_TL + SUBROUTINE Compute_Random_Overlap_TL() + INTEGER :: k + REAL(fp) :: prod_TL(0:n_layers) + prod_TL = ZERO + prod_TL(0) = ZERO + DO k = 1, n_layers + if (cc_FWD%Cloud_Fraction(k) > MIN_COVERAGE_THRESHOLD) then + prod_TL(k) = (ONE - cc_FWD%Cloud_Fraction(k))*prod_TL(k-1) - & + cc_FWD%iVar%prod(k-1)*self_TL%Cloud_Fraction(k) + else + prod_TL(k) = prod_TL(k-1) + endif + self_TL%Cloud_Cover(k) = -prod_TL(k) + END DO + self_TL%Total_Cloud_Cover = self_TL%Cloud_Cover(n_layers) + END SUBROUTINE Compute_Random_Overlap_TL + +! SUBROUTINE Compute_MaxRan_Overlap_TL() +! INTEGER :: k +! REAL(fp) :: prod_TL, denom +! +! ! Give the variables shorter names +! ASSOCIATE( prod => cc_FWD%iVar%prod , & +! cf => cc_FWD%Cloud_Fraction , & +! cf_TL => self_TL%Cloud_Fraction, & +! cc_TL => self_TL%Cloud_Cover ) +! +! ! The cloud cover profile +! prod_TL = -cf_TL(1) +! cc_TL(1) = -prod_TL ! == self_TL%Cloud_Fraction(1) +! DO k = 2, n_layers +! IF ( cf(k) > cf(k-1) ) THEN +! !>>orig +! denom = ONE/(ONE - cf(k-1)) +! prod_TL = ((ONE - cf(k)) * denom * prod_TL) - & +! (prod(k-1) * denom * cf_TL(k) ) + & +! (prod(k-1) * (ONE - cf(k)) * denom**2 * cf_TL(k-1)) +! !<>test +! ! prod_TL = ( ((ONE - cf(k)) / (ONE - cf(k-1))) * prod_TL ) - & +! ! ( (prod(k-1) / (ONE - cf(k-1))) * cf_TL(k) ) + & +! ! ( ((prod(k-1) * (ONE - cf(k))) / (ONE - cf(k-1))**2) * cf_TL(k-1) ) +! !< cc_FWD%Cloud_Fraction(k))) THEN + maxcov_TL = -self_TL%Cloud_Fraction(k-1) + ELSE IF ((cc_FWD%Cloud_Fraction(k-1) < cc_FWD%Cloud_Fraction(k))) THEN + maxcov_TL = -self_TL%Cloud_Fraction(k) + ELSE IF ((CC_FWD%Cloud_Fraction(k-1) == cc_FWD%Cloud_Fraction(k))) THEN + maxcov_TL = -self_TL%Cloud_Fraction(k) + ENDIF + prod_TL = prod_TL * cc_FWD%iVar%maxcov(k) / (one - cc_FWD%Cloud_Fraction(k-1)) + & + & self_TL%Cloud_Fraction(k-1) * cc_FWD%iVar%prod(k-1) * cc_FWD%iVar%maxcov(k) / & + & (one - cc_FWD%Cloud_Fraction(k-1)) ** 2 + & + & maxcov_TL * cc_FWD%iVar%prod(k-1) / (one - cc_FWD%Cloud_Fraction(k-1)) + self_TL%Cloud_Cover(k) = -prod_TL + ENDDO + self_TL%Total_Cloud_Cover = self_TL%Cloud_Cover(n_layers) + END SUBROUTINE Compute_MaxRan_Overlap_TL + + SUBROUTINE Compute_Average_Overlap_TL() + INTEGER :: k, n + REAL(fp) :: lwc_TL(n_Layers), wc_sum_TL(0:n_Layers), cwc_sum_TL(0:n_Layers) + REAL(fp) :: denom + + ! Give the variables shorter names + ASSOCIATE( lwc => cc_FWD%iVar%lwc , & + wc_sum => cc_FWD%iVar%wc_sum , & + cwc_sum => cc_FWD%iVar%cwc_sum , & + cf => cc_FWD%Cloud_Fraction , & + cc => cc_FWD%Cloud_Cover , & + ! cloud => atm%Cloud , & !orig + cloud => cc_FWD%iVar%wc , & + cf_TL => self_TL%Cloud_Fraction, & + cc_TL => self_TL%Cloud_Cover , & + cloud_TL => atm_TL%Cloud ) + + ! The total layer water content + lwc_TL = ZERO + DO n = 1, atm_TL%n_Clouds + ! WHERE (cloud(n)%Water_Content(1:n_layers) > WATER_CONTENT_THRESHOLD ) & !orig + WHERE (cloud(n,1:n_layers) > WATER_CONTENT_THRESHOLD ) & + lwc_TL = lwc_TL + cloud_TL(n)%Water_Content(1:n_layers) + END DO + + ! The cloud cover profile + wc_sum_TL(0) = ZERO + cwc_sum_TL(0) = ZERO + DO k = 1, n_layers + wc_sum_TL(k) = wc_sum_TL(k-1) + lwc_TL(k) + cwc_sum_TL(k) = cwc_sum_TL(k-1) + (cf(k) * lwc_TL(k)) + (lwc(k) * cf_TL(k)) + IF ( wc_sum(k) > ZERO ) THEN + denom = ONE/wc_sum(k) + cc_TL(k) = (denom * cwc_sum_TL(k)) - & + (denom**2 * cwc_sum(k) * wc_sum_TL(k) ) + END IF + END DO + + END ASSOCIATE + + ! Extract out the tangent-linear total cloud cover + self_TL%Total_Cloud_Cover = self_TL%Cloud_Cover(n_layers) + + END SUBROUTINE Compute_Average_Overlap_TL + + SUBROUTINE Compute_Overcast_Overlap_TL() + + self_TL%Total_Cloud_Cover = ZERO + + END SUBROUTINE Compute_Overcast_Overlap_TL + + END FUNCTION Compute_CloudCover_TL + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! Compute_CloudCover_AD +! +! PURPOSE: +! Function method to compute the adjoint cloud cover profile for supplied +! forward model results and populate the Atmosphere adjoint object +! with the results. +! +! CALLING SEQUENCE: +! err_stat = cc_obj_AD%Compute_CloudCover_AD( & +! cc_FWD , & +! atmosphere , & +! atmosphere_AD ) +! +! OBJECTS: +! cc_obj_AD: The adjoint cloud cover object. This object contains +! data on input, but is zeroed out upon output. +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! cc_FWD: The forward model cloud cover object. +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! atmosphere: Atmopshere object containing the layer cloud fraction +! profile, and the actual cloud profiles for when cloud +! water content averaging of the cloud cover is selected. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! atmosphere_AD: The adjoint atmosphere object containing the results of the +! adjoint calculation. The adjoint cloud fraction profile +! will be modified on output. For the weighted average cloud +! clover method, the adjoint cloud water amounts will also be +! modified. +! UNITS: N/A +! TYPE: CRTM_Atmosphere_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! FUNCTION RESULT: +! 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 successful +! == FAILURE, an unrecoverable error occurred. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + FUNCTION Compute_CloudCover_AD( & + self_AD, & ! Input, but modified on output + cc_FWD , & ! Input + atm , & ! Input + atm_AD ) & ! Output, but contains information on input + RESULT(err_stat) + ! Arguments + CLASS(CRTM_CloudCover_type), INTENT(IN OUT) :: self_AD + CLASS(CRTM_CloudCover_type), INTENT(IN) :: cc_FWD + TYPE(CRTM_Atmosphere_type) , INTENT(IN) :: atm + TYPE(CRTM_Atmosphere_type) , INTENT(IN OUT) :: atm_AD + ! Function result + INTEGER :: err_stat + ! Local parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'CRTM_CloudCover_Define::Compute_CloudCover_AD' + REAL(fp), PARAMETER :: MIN_COVERAGE_THRESHOLD = 1.0e-06_fp + REAL(fp), PARAMETER :: MAX_COVERAGE_THRESHOLD = ONE - MIN_COVERAGE_THRESHOLD + + ! Local variables + CHARACTER(ML) :: err_msg + INTEGER :: n_layers + INTEGER :: n_clouds + INTEGER :: n + REAL(fp):: sum_wc + + ! Check inputs + err_stat = SUCCESS + IF ( .NOT. self_AD%Is_Usable() ) THEN + err_msg = 'In/output adjoint cloud cover object is not usable' + err_stat = FAILURE + CALL Display_Message(PROCEDURE_NAME, err_msg, err_stat); RETURN + END IF + IF ( .NOT. cc_FWD%Is_Usable( Include_iVar=.TRUE. ) ) THEN + err_msg = 'Input forward cloud cover object is not usable' + err_stat = FAILURE + CALL Display_Message(PROCEDURE_NAME, err_msg, err_stat); RETURN + END IF + IF ( .NOT. CRTM_Atmosphere_Associated(atm) ) THEN + err_msg = 'Input atmosphere object is not usable' + err_stat = FAILURE + CALL Display_Message(PROCEDURE_NAME, err_msg, err_stat); RETURN + END IF + IF ( .NOT. CRTM_Atmosphere_Associated(atm_AD) ) THEN + err_msg = 'In/output adjoint atmosphere object is not usable' + err_stat = FAILURE + CALL Display_Message(PROCEDURE_NAME, err_msg, err_stat); RETURN + END IF + + + ! Set the object quantities + n_layers = atm_AD%n_Layers + n_clouds = atm_AD%n_Clouds + self_AD%Overlap = cc_FWD%Overlap + + ! Add AD of cloud scaling here! + ! Partition all hydrometeors into cloudy column + IF (cc_FWD%Total_Cloud_Cover > MIN_COVERAGE_THRESHOLD) then + + sum_wc = ZERO + DO n = 1, n_clouds + sum_wc = sum_wc & + + SUM(atm_AD%Cloud(n)%Water_Content(1:n_layers) * cc_FWD%iVar%wc(n,1:n_layers)) + ENDDO + sum_wc = sum_wc / (cc_FWD%Total_Cloud_Cover**2) +!>>test +! sum_wc = ZERO +! DO n = 1, n_clouds +! sum_wc = sum_wc & +! + SUM( (atm_AD%Cloud(n)%Water_Content(1:n_layers) / cc_FWD%Total_Cloud_Cover) & +! * (cc_FWD%iVar%wc(n,1:n_layers) / cc_FWD%Total_Cloud_Cover) ) +! ENDDO +!< cc_FWD%Cloud_Cover(k-1) ) THEN + self_AD%Cloud_Fraction(k) = self_AD%Cloud_Fraction(k) + self_AD%Cloud_Cover(k) + ELSE + self_AD%Cloud_Cover(k-1) = self_AD%Cloud_Cover(k-1) + self_AD%Cloud_Cover(k) + END IF + self_AD%Cloud_Cover(k) = ZERO + END DO + self_AD%Cloud_Fraction(1) = self_AD%Cloud_Fraction(1) + self_AD%Cloud_Cover(1) + self_AD%Cloud_Cover(1) = ZERO + END SUBROUTINE Compute_Maximum_Overlap_AD + + +! SUBROUTINE Compute_Random_Overlap_AD() +! INTEGER :: k +! REAL(fp) :: prod_AD +! prod_AD = ZERO +! self_AD%Cloud_Cover(n_layers) = self_AD%Cloud_Cover(n_layers) + self_AD%Total_Cloud_Cover +! self_AD%Total_Cloud_Cover = ZERO +! DO k = n_layers, 1, -1 +! prod_AD = prod_AD - self_AD%Cloud_Cover(k) +! self_AD%Cloud_Cover(k) = ZERO +! self_AD%Cloud_Fraction(k) = self_AD%Cloud_Fraction(k) - (cc_FWD%iVar%prod(k-1)*prod_AD) +! prod_AD = (ONE - cc_FWD%Cloud_Fraction(k))*prod_AD +! END DO +! prod_AD = ZERO +! END SUBROUTINE Compute_Random_Overlap_AD + SUBROUTINE Compute_Random_Overlap_AD() + INTEGER :: k + REAL(fp) :: prod_AD(0:n_layers) + prod_AD = ZERO + prod_AD(n_layers) = ZERO + self_AD%Cloud_Cover(n_layers) = self_AD%Cloud_Cover(n_layers) + self_AD%Total_Cloud_Cover + self_AD%Total_Cloud_Cover = ZERO + DO k = n_layers, 1, -1 + prod_AD(k) = prod_AD(k) - self_AD%Cloud_Cover(k) + self_AD%Cloud_Cover(k) = ZERO + if (cc_FWD%Cloud_Fraction(k) > MIN_COVERAGE_THRESHOLD) then + self_AD%Cloud_Fraction(k) = self_AD%Cloud_Fraction(k) - (cc_FWD%iVar%prod(k-1)*prod_AD(k)) + prod_AD(k-1) = prod_AD(k-1)+(ONE - cc_FWD%Cloud_Fraction(k))*prod_AD(k) + prod_AD(k) = ZERO + else + prod_AD(k-1) = prod_AD(k-1)+ prod_AD(k) + prod_AD(k) = ZERO + endif + END DO + prod_AD(0) = ZERO + END SUBROUTINE Compute_Random_Overlap_AD + +! SUBROUTINE Compute_MaxRan_Overlap_AD() +! INTEGER :: k +! REAL(fp) :: prod_AD, denom +! prod_AD = ZERO +! self_AD%Cloud_Cover(n_layers) = self_AD%Cloud_Cover(n_layers) + self_AD%Total_Cloud_Cover +! self_AD%Total_Cloud_Cover = ZERO +! DO k = n_layers, 2, -1 +! prod_AD = prod_AD - self_AD%Cloud_Cover(k) +! self_AD%Cloud_Cover(k) = ZERO +! IF ( cc_FWD%Cloud_Fraction(k) > cc_FWD%Cloud_Fraction(k-1) ) THEN +! denom = ONE/(ONE - cc_FWD%Cloud_Fraction(k-1)) +! self_AD%Cloud_Fraction(k-1) = self_AD%Cloud_Fraction(k-1) + & +! (cc_FWD%iVar%prod(k-1) * (ONE - cc_FWD%Cloud_Fraction(k)) * denom**2 * prod_AD) +! self_AD%Cloud_Fraction(k) = self_AD%Cloud_Fraction(k) - & +! (cc_FWD%iVar%prod(k-1) * denom * prod_AD) +! prod_AD = (ONE - cc_FWD%Cloud_Fraction(k)) * denom * prod_AD +! END IF +! END DO +! prod_AD = prod_AD - self_AD%Cloud_Cover(1) +! self_AD%Cloud_Cover(1) = ZERO +! self_AD%Cloud_Fraction(1) = self_AD%Cloud_Fraction(1) - prod_AD +! prod_AD = ZERO +! END SUBROUTINE Compute_MaxRan_Overlap_AD + SUBROUTINE Compute_MaxRan_Overlap_AD() + INTEGER :: k + REAL(fp) :: prod_AD + REAL(fp) :: maxcov_AD + prod_AD = ZERO + maxcov_AD = ZERO + self_AD%Cloud_Cover(n_layers) = self_AD%Cloud_Cover(n_layers) + self_AD%Total_Cloud_Cover + self_AD%Total_Cloud_Cover = ZERO + DO k = n_layers, 2, - 1 + prod_AD = prod_AD - self_AD%Cloud_Cover(k) + self_AD%Cloud_Cover(k) = ZERO + self_AD%Cloud_Fraction(k-1) = self_AD%Cloud_Fraction(k-1) + & + & prod_AD * cc_FWD%iVar%prod(k-1) * cc_FWD%iVar%maxcov(k) / (one - cc_FWD%Cloud_Fraction(k-1)) ** 2 + maxcov_AD = & + & maxcov_AD + prod_AD * cc_FWD%iVar%prod(k-1) / (one - cc_FWD%Cloud_Fraction(k-1)) + prod_AD = & + & prod_AD * cc_FWD%iVar%maxcov(k) / (one - cc_FWD%Cloud_Fraction(k-1)) + IF ((cc_FWD%Cloud_Fraction(k-1) > cc_FWD%Cloud_Fraction(k))) THEN + self_AD%Cloud_Fraction(k-1) = self_AD%Cloud_Fraction(k-1) - maxcov_AD + maxcov_AD = zero + ELSE IF ((cc_FWD%Cloud_Fraction(k-1) < cc_FWD%Cloud_Fraction(k))) THEN + self_AD%Cloud_Fraction(k) = self_AD%Cloud_Fraction(k) - maxcov_AD + maxcov_AD = zero + ELSE IF ((cc_FWD%Cloud_Fraction(k-1) == cc_FWD%Cloud_Fraction(k))) THEN + self_AD%Cloud_Fraction(k) = self_AD%Cloud_Fraction(k) - maxcov_AD + maxcov_AD = ZERO + ENDIF + ENDDO + prod_AD = prod_AD - maxcov_AD + self_AD%Cloud_Cover(1) = ZERO + self_AD%Cloud_Fraction(1) = self_AD%Cloud_Fraction(1) - prod_AD + prod_AD = ZERO + END SUBROUTINE Compute_MaxRan_Overlap_AD + + SUBROUTINE Compute_Average_Overlap_AD() + INTEGER :: k, n + REAL(fp) :: lwc_AD(n_Layers), wc_sum_AD(0:n_Layers), cwc_sum_AD(0:n_Layers) + REAL(fp) :: denom + + ! Initialise local adjoint variables + lwc_AD = ZERO + wc_sum_AD = ZERO + cwc_sum_AD = ZERO + + ! Adjoint of the total cloud cover + self_AD%Cloud_Cover(n_layers) = self_AD%Cloud_Cover(n_layers) + self_AD%Total_Cloud_Cover + self_AD%Total_Cloud_Cover = ZERO + ! Adjoint of the cloud cover profile + ASSOCIATE( lwc => cc_FWD%iVar%lwc , & + wc_sum => cc_FWD%iVar%wc_sum , & + cwc_sum => cc_FWD%iVar%cwc_sum , & + cf => cc_FWD%Cloud_Fraction , & + ! cloud => atm%Cloud , & !orig + cloud => cc_FWD%iVar%wc , & + cf_AD => self_AD%Cloud_Fraction, & + cc_AD => self_AD%Cloud_Cover , & + cloud_AD => atm_AD%Cloud ) + + DO k = n_layers, 1, -1 + IF ( wc_sum(k) > ZERO ) THEN + denom = ONE/wc_sum(k) + wc_sum_AD(k) = wc_sum_AD(k) - (denom**2 * cwc_sum(k) * cc_AD(k)) + cwc_sum_AD(k) = cwc_sum_AD(k) + (denom * cc_AD(k)) + cc_AD(k) = ZERO + END IF + + cf_AD(k) = cf_AD(k) + (lwc(k) * cwc_sum_AD(k)) + lwc_AD(k) = lwc_AD(k) + (cf(k) * cwc_sum_AD(k)) + cwc_sum_AD(k-1) = cwc_sum_AD(k-1) + cwc_sum_AD(k) + cwc_sum_AD(k) = ZERO + + lwc_AD(k) = lwc_AD(k) + wc_sum_AD(k) + wc_sum_AD(k-1) = wc_sum_AD(k-1) + wc_sum_AD(k) + wc_sum_AD(k) = ZERO + END DO + wc_sum_AD(0) = ZERO + cwc_sum_AD(0) = ZERO + + + ! Adjoint of the total layer water content + DO n = 1, SIZE(cloud_AD) + ! WHERE (cloud(n)%Water_Content(1:n_layers) > WATER_CONTENT_THRESHOLD ) & !orig + WHERE (cloud(n,1:n_layers) > WATER_CONTENT_THRESHOLD ) & + cloud_AD(n)%Water_Content(1:n_layers) = cloud_AD(n)%Water_Content(1:n_layers) + lwc_AD + END DO + lwc_AD = ZERO + + END ASSOCIATE + + END SUBROUTINE Compute_Average_Overlap_AD + + SUBROUTINE Compute_Overcast_Overlap_AD() + + self_AD%Total_Cloud_Cover = ZERO + + END SUBROUTINE Compute_Overcast_Overlap_AD + + END FUNCTION Compute_CloudCover_AD + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! Is_Usable +! +! PURPOSE: +! Elemental function method to test the status of CloudCover objects to +! determien if they are usable. +! +! CALLING SEQUENCE: +! status = cc_obj%Is_Usable( Include_iVar = Include_iVar ) +! +! OBJECTS: +! cc_obj: Cloud cover object which is to have its usability tested. +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! Include_iVar: Set this optional logical flag to alos check the status +! of the intermediate variable sub-object. +! IF .FALSE. - the subobject is NOT tested [DEFAULT] +! .TRUE. - the subobject is tested +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Conformable with object. +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! FUNCTION RESULT: +! status: The return value is a logical value indicating the +! usable status of the object. +! .TRUE. - if the object is usable. +! .FALSE. - if the object is NOT usable. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Same as object +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + ELEMENTAL FUNCTION Is_Usable( self, Include_iVar ) RESULT( status ) + CLASS(CRTM_CloudCover_type), INTENT(IN) :: self + LOGICAL, OPTIONAL , INTENT(IN) :: Include_iVar + LOGICAL :: status + status = self%Is_Allocated + IF ( PRESENT(Include_iVar) ) THEN + IF ( Include_iVar ) status = status .AND. self%iVar%Is_Usable() + END IF + END FUNCTION Is_Usable + + ELEMENTAL FUNCTION iVar_Is_Usable( self ) RESULT( status ) + CLASS(iVar_type), INTENT(IN) :: self + LOGICAL :: status + status = self%Is_Allocated + END FUNCTION iVar_Is_Usable + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! Destroy +! +! PURPOSE: +! Elemental subroutine method to re-initialize CloudCover objects. +! +! CALLING SEQUENCE: +! CALL cc_obj%Destroy() +! +! OBJECTS: +! cc_obj: Re-initialized cloud cover object(s). +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(OUT) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + ELEMENTAL SUBROUTINE Destroy( self ) + CLASS(CRTM_CloudCover_type), INTENT(INOUT) :: self + self%Is_Allocated = .FALSE. + END SUBROUTINE Destroy + + ELEMENTAL SUBROUTINE iVar_Destroy( self ) + CLASS(iVar_type), INTENT(INOUT) :: self + self%Is_Allocated = .FALSE. + END SUBROUTINE iVar_Destroy + +! SUBROUTINE Cleanup(self) +! TYPE(CRTM_CloudCover_type) :: self +! CALL self%Destroy() +! END SUBROUTINE Cleanup + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! Create +! +! PURPOSE: +! Elemental subroutine method to create instances of CloudCover objects. +! +! CALLING SEQUENCE: +! CALL cc_obj%Create( n_Layers, & +! n_Clouds, & +! Forward = Forward, & +! Error_Message = Error_Message ) +! +! OBJECTS: +! cc_obj: Cloud cover object +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(OUT) +! +! INPUTS: +! n_Layers: Number of layers for which there is cloud data. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Conformable with object. +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! Forward: Set this optional logical flag to allocate the sub-object to +! hold the intermediate forward model results. +! IF .FALSE. - the subobject is NOT allocated [DEFAULT] +! .TRUE. - the subobject is allocated +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Conformable with object. +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! OPTIONAL OUTPUTS: +! Error_Message: If an error occurred creating the object, this +! argument will contain error information. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Conformable with object. +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + ELEMENTAL SUBROUTINE Create( & + self , & + n_Layers , & + n_Clouds , & + Forward , & + Error_Message ) + ! Arguments + CLASS(CRTM_CloudCover_type), INTENT(INOUT) :: self + INTEGER , INTENT(IN) :: n_Layers + INTEGER , INTENT(IN) :: n_Clouds + LOGICAL, OPTIONAL, INTENT(IN) :: Forward + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Error_Message + ! Local variables + CHARACTER(ML) :: alloc_msg + INTEGER :: alloc_stat + LOGICAL :: allocate_ivar + + + ! Check input + IF ( n_Layers < 1 ) THEN + IF ( PRESENT(Error_Message) ) Error_Message = 'Invalid dimension inputs' + RETURN + END IF + allocate_ivar = .FALSE. + IF ( PRESENT(Forward) ) allocate_ivar = Forward + + + ! Intermediate variable object + IF ( allocate_ivar ) THEN +! CALL self%iVar%Create(n_Layers, Error_Message = Error_Message) + CALL self%iVar%Create(n_Layers, n_Clouds, Error_Message = Error_Message) + IF ( .NOT. self%iVar%Is_Usable() ) RETURN + END IF + + + ! Main object + ! ...Perform the allocations + ALLOCATE( self%Cloud_Fraction( n_Layers ), & + self%Cloud_Cover( n_Layers ), & + STAT = alloc_stat ) + !STAT = alloc_stat, ERRMSG = alloc_msg ) + IF ( alloc_stat /= 0 ) THEN + IF ( PRESENT(Error_Message) ) Error_Message = alloc_msg + RETURN + END IF + ! ...Initialise + self%n_Layers = n_Layers + self%Cloud_Fraction = ZERO + self%Cloud_Cover = ZERO + ! ...Set allocation indicator + self%Is_Allocated = .TRUE. + + END SUBROUTINE Create + + + ELEMENTAL SUBROUTINE iVar_Create( & + self , & + n_Layers , & + n_Clouds , & + Error_Message ) + ! Arguments + CLASS(iVar_type) , INTENT(INOUT) :: self + INTEGER , INTENT(IN) :: n_Layers + INTEGER , INTENT(IN) :: n_Clouds + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Error_Message + ! Local variables + CHARACTER(ML) :: alloc_msg + INTEGER :: alloc_stat + + ! Check input + IF ( n_Layers < 1 ) THEN + IF ( PRESENT(Error_Message) ) Error_Message = 'iVar: Invalid dimension input' + RETURN + END IF + + ! Perform the allocations + ALLOCATE( self%prod( 0:n_Layers ), & + self%lwc( 1:n_Layers ), & + self%wc_sum( 0:n_Layers ), & + self%wc( 1:n_Clouds, 1:n_Layers ), & + self%maxcov( 1:n_Layers ), & + self%cwc_sum( 0:n_Layers ), & + STAT = alloc_stat ) + !STAT = alloc_stat, ERRMSG = alloc_msg ) + IF ( alloc_stat /= 0 ) THEN + IF ( PRESENT(Error_Message) ) Error_Message = 'iVar: '//TRIM(alloc_msg) + RETURN + END IF + + ! Initialise + self%n_Layers = n_Layers + self%n_Clouds = n_Clouds + self%prod = ZERO + self%lwc = ZERO + self%wc = ZERO + self%maxcov = ZERO + self%wc_sum = ZERO + self%cwc_sum = ZERO + + ! Set allocation indicator + self%Is_Allocated = .TRUE. + + END SUBROUTINE iVar_Create + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! Inspect +! +! PURPOSE: +! Subroutine method to display the contents of a CloudCover object. +! +! CALLING SEQUENCE: +! CALL cc_obj%Inspect( Hires=hires, Unit=unit, Verbose=Verbose ) +! +! OBJECTS: +! cc_obj: Cloud cover object +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! Hires: Set this logical argument to output object contents with +! more significant digits. +! If == .FALSE., output format is 'es13.6' [DEFAULT]. +! == .TRUE., output format is 'es22.15' +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! 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 +! +! Verbose: Set this logical argument to output the intermediate variable +! sub-object contents if they are available. +! If == .FALSE., the intermediate variables are NOT output [DEFAULT]. +! == .TRUE., the intermediate variables are output if available +! If not specified, default is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE Inspect( self, Hires, Unit, Verbose ) + ! Arguments + CLASS(CRTM_CloudCover_type), INTENT(IN) :: self + LOGICAL, OPTIONAL, INTENT(IN) :: Hires + INTEGER, OPTIONAL, INTENT(IN) :: Unit + LOGICAL, OPTIONAL, INTENT(IN) :: Verbose + ! Local variables + INTEGER :: fid + CHARACTER(20) :: fmtstring + LOGICAL :: verbose_inspect + + ! Setup + fmtstring = 'es13.6' + IF ( PRESENT(Hires) ) THEN + IF ( Hires ) fmtstring = 'es22.15' + END IF + fid = OUTPUT_UNIT + IF ( PRESENT(Unit) ) THEN + IF ( File_Open(Unit) ) fid = Unit + END IF + verbose_inspect = .FALSE. + IF ( PRESENT(Verbose) ) verbose_inspect = Verbose + + ! The inspection output + WRITE(fid,'(1x,"CLOUDCOVER OBJECT")') + WRITE(fid,'(3x,"n_Layers :",1x,i0)') self%n_Layers + WRITE(fid,'(3x,"Overlap :",1x,a )') self%Overlap_Name() + WRITE(fid,'(3x,"Total cloud cover :",1x,'//TRIM(fmtstring)//')') self%Total_Cloud_Cover + IF ( .NOT. self%Is_Usable() ) RETURN + WRITE(fid,'(3x,"Cloud_Fraction:")') + WRITE(fid,'(5(1x,'//TRIM(fmtstring)//',:))') self%Cloud_Fraction + WRITE(fid,'(3x,"Cloud_Cover:")') + WRITE(fid,'(5(1x,'//TRIM(fmtstring)//',:))') self%Cloud_Cover + + ! The intermediate variable sub-object + IF ( verbose_inspect ) CALL self%iVar%Inspect() + + END SUBROUTINE Inspect + + + SUBROUTINE iVar_Inspect(self, Hires, Unit ) + ! Arguments + CLASS(iVar_Type) , INTENT(IN) :: self + LOGICAL, OPTIONAL, INTENT(IN) :: Hires + INTEGER, OPTIONAL, INTENT(IN) :: Unit + ! Local variables + INTEGER :: fid + CHARACTER(20) :: fmtstring + + ! Setup + fmtstring = 'es13.6' + IF ( PRESENT(Hires) ) THEN + IF ( Hires ) fmtstring = 'es22.15' + END IF + fid = OUTPUT_UNIT + IF ( PRESENT(Unit) ) THEN + IF ( File_Open(Unit) ) fid = Unit + END IF + + ! The inspection output + WRITE(fid,'(3x,"CLOUDCOVER iVar SUB-OBJECT")') + WRITE(fid,'(5x,"n_Layers :",1x,i0)') self%n_Layers + WRITE(fid,'(7x,"Layer-to-layer product:")') + WRITE(fid,'(5(1x,'//TRIM(fmtstring)//',:))') self%prod + WRITE(fid,'(7x,"Layer water content for all clouds:")') + WRITE(fid,'(5(1x,'//TRIM(fmtstring)//',:))') self%lwc + WRITE(fid,'(7x,"Cumulative layer water content for all clouds:")') + WRITE(fid,'(5(1x,'//TRIM(fmtstring)//',:))') self%wc_sum + WRITE(fid,'(7x,"Cumulative cloud fraction weighted layer water content for all clouds:")') + WRITE(fid,'(5(1x,'//TRIM(fmtstring)//',:))') self%cwc_sum + + END SUBROUTINE iVar_Inspect + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! Set_To_Zero +! +! PURPOSE: +! Elemental subroutine method to zero out the data arrays in a +! CloudCover object. +! +! CALLING SEQUENCE: +! CALL cc_obj%Set_To_Zero() +! +! OBJECTS: +! cc_obj: Cloud cover object +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(IN OUT) +! +! COMMENTS: +! - The dimension components of the object are *NOT* set to zero. +! - The overlap methodology identifier component is *NOT* reset. +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + ELEMENTAL SUBROUTINE Set_To_Zero( self ) + CLASS(CRTM_CloudCover_type), INTENT(IN OUT) :: self + ! Do nothing if structure is unused + IF ( .NOT. self%Is_Usable() ) RETURN + ! Only zero out the data + self%Total_Cloud_Cover = ZERO + self%Cloud_Fraction = ZERO + self%Cloud_Cover = ZERO + ! The intermediate variable sub-object + CALL self%iVar%Set_To_Zero() + + END SUBROUTINE Set_To_Zero + + + ELEMENTAL SUBROUTINE iVar_Set_To_Zero( self ) + CLASS(iVar_type), INTENT(IN OUT) :: self + ! Do nothing if structure is unused + IF ( .NOT. self%Is_Usable() ) RETURN + ! Only zero out the data + self%prod = ZERO + self%lwc = ZERO + self%wc_sum = ZERO + self%cwc_sum = ZERO + END SUBROUTINE iVar_Set_To_Zero + + + +!################################################################################## +!################################################################################## +!## ## +!## ## OPERATOR METHODS ## ## +!## ## +!################################################################################## +!################################################################################## + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! == +! +! PURPOSE: +! Operator method to test the equality of two CloudCover objects. +! +! CALLING SEQUENCE: +! IF ( x == y ) THEN +! ... +! END IF +! +! OBJECTS: +! x, y: Two cloud cover object to be compared. +! UNITS: N/A +! TYPE: CRTM_CloudCover_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!------------------------------------------------------------------------------ + + ELEMENTAL FUNCTION Equal( x, y ) RESULT( is_equal ) + CLASS(CRTM_CloudCover_type), INTENT(IN) :: x, y + LOGICAL :: is_equal + + ! Set up + is_equal = .FALSE. + + ! Check the object association status + IF ( x%Is_Usable() .NEQV. y%Is_Usable() ) RETURN + + ! Check contents + ! ...Dimensions + IF ( x%n_Layers /= y%n_Layers ) RETURN + ! ...Scalars + IF ( .NOT. ((x%Overlap == y%Overlap ) .AND. & + (x%Total_Cloud_Cover .EqualTo. y%Total_Cloud_Cover)) ) RETURN + ! ...Arrays + IF ( x%Is_Usable() .AND. y%Is_Usable() ) THEN + IF ( .NOT. (ALL(x%Cloud_Fraction .EqualTo. y%Cloud_Fraction) .AND. & + ALL(x%Cloud_Cover .EqualTo. y%Cloud_Cover )) ) RETURN + ! Intermediate variable subobject + IF ( .NOT. (x%iVar == y%iVar) ) RETURN + END IF + + + ! If we get here, then... + is_equal = .TRUE. + + END FUNCTION Equal + + + ELEMENTAL FUNCTION iVar_Equal( x, y ) RESULT( is_equal ) + CLASS(iVar_type), INTENT(IN) :: x, y + LOGICAL :: is_equal + + ! Set up + is_equal = .FALSE. + + ! Check the object association status + IF ( x%Is_Usable() .NEQV. y%Is_Usable() ) RETURN + + ! Check contents + ! ...Dimensions + IF ( x%n_Layers /= y%n_Layers ) RETURN + ! ...Arrays + IF ( x%Is_Usable() .AND. y%Is_Usable() ) THEN + IF ( .NOT. (ALL(x%prod .EqualTo. y%prod ) .AND. & + ALL(x%lwc .EqualTo. y%lwc ) .AND. & + ALL(x%wc_sum .EqualTo. y%wc_sum ) .AND. & + ALL(x%cwc_sum .EqualTo. y%cwc_sum)) ) RETURN + END IF + + ! If we get here, then... + is_equal = .TRUE. + + END FUNCTION iVar_Equal + + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! /= +! +! PURPOSE: +! Operator method to test the inequality of two CloudCover objects. +! +! CALLING SEQUENCE: +! IF ( x /= y ) THEN +! ... +! END IF +! +! OBJECTS: +! x, y: Two cloud cover objects to be compared. +! UNITS: N/A +! TYPE: CRTM_CloudCover_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!------------------------------------------------------------------------------ + + ELEMENTAL FUNCTION NotEqual( x, y ) RESULT( not_equal ) + CLASS(CRTM_CloudCover_type), INTENT(IN) :: x, y + LOGICAL :: not_equal + not_equal = .NOT. (x == y) + END FUNCTION NotEqual + + ELEMENTAL FUNCTION iVar_NotEqual( x, y ) RESULT( not_equal ) + CLASS(iVar_type), INTENT(IN) :: x, y + LOGICAL :: not_equal + not_equal = .NOT. (x == y) + END FUNCTION iVar_NotEqual + + +!------------------------------------------------------------------------------ +!:sdoc+: +! +! NAME: +! .Compare. +! +! PURPOSE: +! Operator method to compare two CloudCover objects. +! +! This procedure performs similarly to the == operator, but is non-elemental +! to allow for informational output when a difference is found between the +! two objects being compared. +! +! Mostly used for debugging. +! +! CALLING SEQUENCE: +! IF ( x .Compare. y ) THEN +! ... +! END IF +! +! OBJECTS: +! x, y: The cloud cover objects to compare. +! UNITS: N/A +! CLASS: CRTM_CloudCover_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!------------------------------------------------------------------------------ + + FUNCTION Compare_( x, y ) RESULT( is_equal ) + CLASS(CRTM_CloudCover_type), INTENT(IN) :: x, y + LOGICAL :: is_equal + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_CloudCover_Define::Compare' + ! Local variable + CHARACTER(ML) :: msg + + ! Set up + is_equal = .TRUE. + + ! Check the object association status + IF ( x%Is_Usable() .NEQV. y%Is_Usable() ) THEN + msg = 'Object association statuses are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + + ! Check contents + ! ...Dimensions + IF ( x%n_Layers /= y%n_Layers ) THEN + msg = 'Object dimensions are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + ! Scalars + IF ( x%Overlap /= y%Overlap ) THEN + msg = 'Object overlap assumptions are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + IF ( .NOT. (x%Total_Cloud_Cover .EqualTo. y%Total_Cloud_Cover) ) THEN + msg = 'Object Total_Cloud_Cover values are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + ! ...Arrays and sub-objects + IF ( x%Is_Usable() .AND. y%Is_Usable() ) THEN + IF ( .NOT. ALL(x%Cloud_Fraction .EqualTo. y%Cloud_Fraction) ) THEN + msg = 'Object Cloud_Fraction data are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + IF ( .NOT. ALL(x%Cloud_Cover .EqualTo. y%Cloud_Cover) ) THEN + msg = 'Object Cloud_Cover data are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + IF ( .NOT. (x%iVar .Compare. y%iVar) ) THEN + msg = 'Object iVar subobject data are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + END IF + + END FUNCTION Compare_ + + + FUNCTION iVar_Compare( x, y ) RESULT( is_equal ) + CLASS(iVar_type), INTENT(IN) :: x, y + LOGICAL :: is_equal + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_CloudCover_Define::iVar_Compare' + ! Local variable + CHARACTER(ML) :: msg + + ! Set up + is_equal = .TRUE. + + ! Check the object association status + IF ( x%Is_Usable() .NEQV. y%Is_Usable() ) THEN + msg = 'Object association statuses are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + + ! Check contents + ! ...Dimensions + IF ( x%n_Layers /= y%n_Layers ) THEN + msg = 'Object dimensions are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + ! ...Arrays + IF ( x%Is_Usable() .AND. y%Is_Usable() ) THEN + IF ( .NOT. ALL(x%prod .EqualTo. y%prod) ) THEN + msg = 'Object prod data are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + IF ( .NOT. ALL(x%lwc .EqualTo. y%lwc) ) THEN + msg = 'Object lwc data are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + IF ( .NOT. ALL(x%wc_sum .EqualTo. y%wc_sum) ) THEN + msg = 'Object wc_sum data are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + IF ( .NOT. ALL(x%cwc_sum .EqualTo. y%cwc_sum) ) THEN + msg = 'Object cwc_sum data are different' + CALL Display_Message(ROUTINE_NAME, msg, FAILURE) + is_equal = .FALSE. + END IF + END IF + + END FUNCTION iVar_Compare + +END MODULE CRTM_CloudCover_Define diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_CloudScatter.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_CloudScatter.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_CloudScatter.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_CloudScatter.f90 index ec27ea6feb..dfa4868123 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_CloudScatter.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_CloudScatter.f90 @@ -86,7 +86,7 @@ MODULE CRTM_CloudScatter ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_CloudScatter.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_CloudScatter.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 ! Number of stream angle definitions diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Cloud_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Cloud_Define.f90 similarity index 94% rename from var/external/crtm_2.2.3/libsrc/CRTM_Cloud_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Cloud_Define.f90 index 3a8cb82393..4795b6de76 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Cloud_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Cloud_Define.f90 @@ -53,6 +53,7 @@ MODULE CRTM_Cloud_Define PUBLIC :: CRTM_Cloud_type ! Operators PUBLIC :: OPERATOR(==) + PUBLIC :: OPERATOR(/=) PUBLIC :: OPERATOR(+) PUBLIC :: OPERATOR(-) ! Procedures @@ -81,6 +82,10 @@ MODULE CRTM_Cloud_Define MODULE PROCEDURE CRTM_Cloud_Equal END INTERFACE OPERATOR(==) + INTERFACE OPERATOR(/=) + MODULE PROCEDURE CRTM_Cloud_NotEqual + END INTERFACE OPERATOR(/=) + INTERFACE OPERATOR(+) MODULE PROCEDURE CRTM_Cloud_Add END INTERFACE OPERATOR(+) @@ -100,7 +105,7 @@ MODULE CRTM_Cloud_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Cloud_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Cloud_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! The valid cloud categories and names INTEGER, PARAMETER :: N_VALID_CLOUD_CATEGORIES = 6 INTEGER, PARAMETER :: INVALID_CLOUD = 0 @@ -190,7 +195,8 @@ FUNCTION CRTM_Cloud_CategoryList(list) RESULT(err_stat) CHARACTER(ML) :: alloc_msg, msg INTEGER :: alloc_stat err_stat = SUCCESS - ALLOCATE( list(0:N_VALID_CLOUD_CATEGORIES), STAT=alloc_stat, ERRMSG=alloc_msg ) + !ALLOCATE( list(0:N_VALID_CLOUD_CATEGORIES), STAT=alloc_stat, ERRMSG=alloc_msg ) + ALLOCATE( list(0:N_VALID_CLOUD_CATEGORIES), STAT=alloc_stat ) IF ( alloc_stat /= 0 ) THEN err_stat = FAILURE msg = 'Cloud category list result not allocated -'//TRIM(alloc_msg) @@ -702,20 +708,21 @@ ELEMENTAL FUNCTION CRTM_Cloud_Compare( & n = DEFAULT_N_SIGFIG END IF - ! Check the structure association status - IF ( (.NOT. CRTM_Cloud_Associated(x)) .OR. & - (.NOT. CRTM_Cloud_Associated(y)) ) RETURN + ! Check the object association status + IF ( CRTM_Cloud_Associated(x) .NEQV. CRTM_Cloud_Associated(y) ) RETURN - ! Check scalars + ! Check contents + ! ...Scalars IF ( (x%n_Layers /= y%n_Layers) .OR. & (x%Type /= y%Type ) ) RETURN + ! ...Arrays + IF ( CRTM_Cloud_Associated(x) .AND. CRTM_Cloud_Associated(y) ) THEN + IF ( (.NOT. ALL(Compares_Within_Tolerance(x%Effective_Radius ,y%Effective_Radius ,n))) .OR. & + (.NOT. ALL(Compares_Within_Tolerance(x%Effective_Variance,y%Effective_Variance,n))) .OR. & + (.NOT. ALL(Compares_Within_Tolerance(x%Water_Content ,y%Water_Content ,n))) ) RETURN + END IF - ! Check arrays - IF ( (.NOT. ALL(Compares_Within_Tolerance(x%Effective_Radius ,y%Effective_Radius ,n))) .OR. & - (.NOT. ALL(Compares_Within_Tolerance(x%Effective_Variance,y%Effective_Variance,n))) .OR. & - (.NOT. ALL(Compares_Within_Tolerance(x%Water_Content ,y%Water_Content ,n))) ) RETURN - - ! If we get here, the structures are comparable + ! If we get here, the objects are comparable is_comparable = .TRUE. END FUNCTION CRTM_Cloud_Compare @@ -1018,7 +1025,8 @@ FUNCTION CRTM_Cloud_ReadFile( & CALL Read_Cleanup(); RETURN END IF ! ...Allocate the return structure array - ALLOCATE(Cloud(nc), STAT=alloc_stat, ERRMSG=alloc_msg) + !ALLOCATE(Cloud(nc), STAT=alloc_stat, ERRMSG=alloc_msg) + ALLOCATE(Cloud(nc), STAT=alloc_stat) IF ( alloc_stat /= 0 ) THEN msg = 'Error allocating Cloud array - '//TRIM(alloc_msg) CALL Read_Cleanup(); RETURN @@ -1064,7 +1072,8 @@ SUBROUTINE Read_CleanUp() msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) END IF IF ( ALLOCATED(Cloud) ) THEN - DEALLOCATE(Cloud, STAT=alloc_stat, ERRMSG=alloc_msg) + !DEALLOCATE(Cloud, STAT=alloc_stat, ERRMSG=alloc_msg) + DEALLOCATE(Cloud, STAT=alloc_stat) IF ( alloc_stat /= 0 ) & msg = TRIM(msg)//'; Error deallocating Cloud array during error cleanup - '//& TRIM(alloc_msg) @@ -1306,23 +1315,68 @@ ELEMENTAL FUNCTION CRTM_Cloud_Equal( x, y ) RESULT( is_equal ) ! Set up is_equal = .FALSE. - ! Check the structure association status - IF ( (.NOT. CRTM_Cloud_Associated(x)) .OR. & - (.NOT. CRTM_Cloud_Associated(y)) ) RETURN + ! Check the object association status + IF ( CRTM_Cloud_Associated(x) .NEQV. CRTM_Cloud_Associated(y) ) RETURN ! Check contents ! ...Scalars IF ( (x%n_Layers /= y%n_Layers) .OR. (x%Type /= y%Type) ) RETURN ! ...Arrays - n = x%n_Layers - IF ( ALL(x%Effective_Radius(1:n) .EqualTo. y%Effective_Radius(1:n) ) .AND. & - ALL(x%Effective_Variance(1:n) .EqualTo. y%Effective_Variance(1:n)) .AND. & - ALL(x%Water_Content(1:n) .EqualTo. y%Water_Content(1:n) ) ) & - is_equal = .TRUE. + IF ( CRTM_Cloud_Associated(x) .AND. CRTM_Cloud_Associated(y) ) THEN + n = x%n_Layers + IF ( .NOT. (ALL(x%Effective_Radius(1:n) .EqualTo. y%Effective_Radius(1:n) ) .AND. & + ALL(x%Effective_Variance(1:n) .EqualTo. y%Effective_Variance(1:n)) .AND. & + ALL(x%Water_Content(1:n) .EqualTo. y%Water_Content(1:n) )) ) RETURN + END IF + + ! If we get here, then... + is_equal = .TRUE. END FUNCTION CRTM_Cloud_Equal +!------------------------------------------------------------------------------ +! +! NAME: +! CRTM_Cloud_NotEqual +! +! PURPOSE: +! Elemental function to test the inequality of two CRTM Cloud objects. +! Used in OPERATOR(/=) interface block. +! +! This function is syntactic sugar. +! +! CALLING SEQUENCE: +! not_equal = CRTM_Cloud_NotEqual( x, y ) +! +! or +! +! IF ( x /= y ) THEN +! ... +! END IF +! +! OBJECTS: +! x, y: Two CRTM Cloud objects to be compared. +! UNITS: N/A +! TYPE: CRTM_Cloud_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! not_equal: Logical value indicating whether the inputs are not equal. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Same as inputs. +! +!------------------------------------------------------------------------------ + + ELEMENTAL FUNCTION CRTM_Cloud_NotEqual( x, y ) RESULT( not_equal ) + TYPE(CRTM_Cloud_type), INTENT(IN) :: x, y + LOGICAL :: not_equal + not_equal = .NOT. (x == y) + END FUNCTION CRTM_Cloud_NotEqual + + !-------------------------------------------------------------------------------- ! ! NAME: diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Fastem1.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Fastem1.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/CRTM_Fastem1.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Fastem1.f90 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_FastemX.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_FastemX.f90 similarity index 98% rename from var/external/crtm_2.2.3/libsrc/CRTM_FastemX.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_FastemX.f90 index 2c0eed9bf8..9dd1999198 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_FastemX.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_FastemX.f90 @@ -111,7 +111,7 @@ MODULE CRTM_FastemX ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_FastemX.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_FastemX.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! FASTEM6 version number for use with azimuth model INTEGER, PARAMETER :: FASTEM6 = 6 @@ -144,6 +144,7 @@ MODULE CRTM_FastemX REAL(fp) :: Temperature = ZERO REAL(fp) :: Salinity = ZERO REAL(fp) :: Wind_Speed = ZERO + INTEGER :: n_Angles = ZERO ! ...Optional LOGICAL :: Azimuth_Angle_Valid = .FALSE. REAL(fp) :: Azimuth_Angle = ZERO @@ -151,6 +152,7 @@ MODULE CRTM_FastemX REAL(fp) :: Transmittance = ZERO ! The zenith angle term REAL(fp) :: cos_z = ONE + REAL(fp) :: cos_z_mod = ONE ! The permittivity term COMPLEX(fp) :: Permittivity = ZERO ! The Fresnel reflectivity terms @@ -302,6 +304,7 @@ MODULE CRTM_FastemX SUBROUTINE Compute_FastemX( & MWwaterCoeff , & ! Input Frequency , & ! Input + n_Angles , & ! Input Zenith_Angle , & ! Input Temperature , & ! Input Salinity , & ! Input @@ -314,6 +317,7 @@ SUBROUTINE Compute_FastemX( & ! Arguments TYPE(MWwaterCoeff_type), INTENT(IN) :: MWwaterCoeff REAL(fp), INTENT(IN) :: Frequency + INTEGER, INTENT(IN) :: n_Angles REAL(fp), INTENT(IN) :: Zenith_Angle REAL(fp), INTENT(IN) :: Temperature REAL(fp), INTENT(IN) :: Salinity @@ -331,8 +335,13 @@ SUBROUTINE Compute_FastemX( & iVar%Temperature = Temperature iVar%Salinity = Salinity iVar%Wind_Speed = Wind_Speed + iVar%n_Angles = n_Angles ! ...Save derived variables iVar%cos_z = COS(Zenith_Angle*DEGREES_TO_RADIANS) + iVar%cos_z_mod = COS(Zenith_Angle*DEGREES_TO_RADIANS) + if (n_Angles > 1 .and. Zenith_Angle > 60.0_fp) & + iVar%cos_z_mod = COS(60.0_fp*DEGREES_TO_RADIANS) + ! Permittivity calculation CALL Ocean_Permittivity( Temperature, Salinity, Frequency, & @@ -425,7 +434,7 @@ SUBROUTINE Compute_FastemX( & CALL Reflection_Correction( & MWwaterCoeff%RCCoeff, & iVar%Frequency , & - iVar%cos_z , & + iVar%cos_z_mod , & iVar%Wind_Speed, & Transmittance , & iVar%Rv_Mod , & diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Forward_Module.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Forward_Module.f90 similarity index 70% rename from var/external/crtm_2.2.3/libsrc/CRTM_Forward_Module.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Forward_Module.f90 index 36578b0064..db23c61f7a 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Forward_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Forward_Module.f90 @@ -41,9 +41,15 @@ MODULE CRTM_Forward_Module CRTM_Geometry_IsValid USE CRTM_ChannelInfo_Define, ONLY: CRTM_ChannelInfo_type, & CRTM_ChannelInfo_n_Channels + USE CRTM_RTSolution_Define, ONLY: CRTM_RTSolution_type , & + CRTM_RTSolution_Destroy, & + CRTM_RTSolution_Zero USE CRTM_Options_Define, ONLY: CRTM_Options_type, & CRTM_Options_IsValid - USE CRTM_Atmosphere, ONLY: CRTM_Atmosphere_AddLayers + USE CRTM_Atmosphere, ONLY: CRTM_Atmosphere_AddLayers , & + CRTM_Atmosphere_IsFractional, & + CRTM_Atmosphere_Coverage, & + CRTM_Atmosphere_ClearSkyCopy USE CRTM_GeometryInfo_Define, ONLY: CRTM_GeometryInfo_type, & CRTM_GeometryInfo_SetValue, & CRTM_GeometryInfo_GetValue @@ -63,18 +69,16 @@ MODULE CRTM_Forward_Module CRTM_AtmOptics_Zero USE CRTM_AerosolScatter, ONLY: CRTM_Compute_AerosolScatter USE CRTM_CloudScatter, ONLY: CRTM_Compute_CloudScatter - USE CRTM_AtmOptics, ONLY: AOvar_type , & - AOvar_Create, & - CRTM_Include_Scattering, & + USE CRTM_AtmOptics, ONLY: CRTM_Include_Scattering , & CRTM_Compute_Transmittance, & - CRTM_Combine_AtmOptics + CRTM_AtmOptics_Combine , & + CRTM_AtmOptics_NoScatterCopy USE CRTM_SfcOptics_Define, ONLY: CRTM_SfcOptics_type , & CRTM_SfcOptics_Associated, & CRTM_SfcOptics_Create , & CRTM_SfcOptics_Destroy USE CRTM_SfcOptics, ONLY: CRTM_Compute_SurfaceT - USE CRTM_RTSolution, ONLY: CRTM_RTSolution_type , & - CRTM_Compute_nStreams , & + USE CRTM_RTSolution, ONLY: CRTM_Compute_nStreams , & CRTM_Compute_RTSolution USE CRTM_AntennaCorrection, ONLY: CRTM_Compute_AntCorr USE CRTM_MoleculeScatter, ONLY: CRTM_Compute_MoleculeScatter @@ -88,8 +92,14 @@ MODULE CRTM_Forward_Module USE ACCoeff_Define, ONLY: ACCoeff_Associated USE NLTECoeff_Define, ONLY: NLTECoeff_Associated USE CRTM_Planck_Functions, ONLY: CRTM_Planck_Temperature + USE CRTM_CloudCover_Define, ONLY: CRTM_CloudCover_type ! Internal variable definition modules + ! ...AtmOptics + USE AOvar_Define, ONLY: AOvar_type, & + AOvar_Associated, & + AOvar_Destroy , & + AOvar_Create ! ...CloudScatter USE CSvar_Define, ONLY: CSvar_type, & CSvar_Associated, & @@ -101,7 +111,7 @@ MODULE CRTM_Forward_Module ASvar_Destroy , & ASvar_Create ! ...Radiative transfer - USE RTV_Define, ONLY: RTV_type , & + USE RTV_Define, ONLY: RTV_type, & RTV_Associated, & RTV_Destroy , & RTV_Create @@ -128,7 +138,7 @@ MODULE CRTM_Forward_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Forward_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Forward_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS @@ -237,28 +247,30 @@ FUNCTION CRTM_Forward( & ! Local variables CHARACTER(256) :: Message LOGICAL :: Options_Present - LOGICAL :: Check_Input - LOGICAL :: User_Emissivity, User_Direct_Reflectivity, User_N_Streams - LOGICAL :: User_AntCorr, Compute_AntCorr - LOGICAL :: Apply_NLTE_Correction + LOGICAL :: compute_antenna_correction LOGICAL :: Atmosphere_Invalid, Surface_Invalid, Geometry_Invalid, Options_Invalid - INTEGER :: RT_Algorithm_Id INTEGER :: iFOV INTEGER :: n, n_Sensors, SensorIndex INTEGER :: l, n_Channels, ChannelIndex INTEGER :: m, n_Profiles INTEGER :: ln INTEGER :: n_Full_Streams, mth_Azi + INTEGER :: cloud_coverage_flag REAL(fp) :: Source_ZA REAL(fp) :: Wavenumber - REAL(fp) :: Aircraft_Pressure - REAL(fp) :: transmittance + REAL(fp) :: transmittance, transmittance_clear ! Local ancillary input structure TYPE(CRTM_AncillaryInput_type) :: AncillaryInput - ! Local options structure for default values - TYPE(CRTM_Options_type) :: Default_Options + ! Local options structure for default and use values + TYPE(CRTM_Options_type) :: Default_Options, Opt ! Local atmosphere structure for extra layering TYPE(CRTM_Atmosphere_type) :: Atm + ! Clear sky structures + TYPE(CRTM_Atmosphere_type) :: Atm_Clear + TYPE(CRTM_AtmOptics_type) :: AtmOptics_Clear + TYPE(CRTM_SfcOptics_type) :: SfcOptics_Clear + TYPE(CRTM_RTSolution_type) :: RTSolution_Clear + TYPE(RTV_type) :: RTV_Clear ! Component variables TYPE(CRTM_GeometryInfo_type) :: GeometryInfo TYPE(CRTM_Predictor_type) :: Predictor @@ -273,6 +285,8 @@ FUNCTION CRTM_Forward( & TYPE(RTV_type) :: RTV ! RTSolution ! NLTE correction term predictor TYPE(NLTE_Predictor_type) :: NLTE_Predictor + ! Cloud cover object + TYPE(CRTM_CloudCover_type) :: CloudCover ! ------ @@ -323,6 +337,10 @@ FUNCTION CRTM_Forward( & END IF + ! Reinitialise the output RTSolution + CALL CRTM_RTSolution_Zero(RTSolution) + + ! Allocate the profile independent surface opticss local structure CALL CRTM_SfcOptics_Create( SfcOptics, MAX_N_ANGLES, MAX_N_STOKES ) IF ( .NOT. CRTM_SfcOptics_Associated(SfcOptics) ) THEN @@ -357,65 +375,19 @@ FUNCTION CRTM_Forward( & ! Check the optional Options structure argument - ! ...Specify default actions - Check_Input = Default_Options%Check_Input - User_Emissivity = Default_Options%Use_Emissivity - User_AntCorr = Default_Options%Use_Antenna_Correction - Apply_NLTE_Correction = Default_Options%Apply_NLTE_Correction - RT_Algorithm_Id = Default_Options%RT_Algorithm_Id - User_N_Streams = Default_Options%Use_N_Streams - Aircraft_Pressure = Default_Options%Aircraft_Pressure - ! ...Check the Options argument - IF (Options_Present) THEN - ! Override input checker with option - Check_Input = Options(m)%Check_Input - ! Check if the supplied emissivity should be used - User_Emissivity = Options(m)%Use_Emissivity - IF ( Options(m)%Use_Emissivity ) THEN - ! Are the channel dimensions consistent - IF ( Options(m)%n_Channels < n_Channels ) THEN - Error_Status = FAILURE - WRITE( Message,'( "Input Options channel dimension (", i0, ") is less ", & - &"than the number of requested channels (",i0, ")" )' ) & - Options(m)%n_Channels, n_Channels - CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) - RETURN - END IF - ! Check if the supplied direct reflectivity should be used - User_Direct_Reflectivity = Options(m)%Use_Direct_Reflectivity - END IF - ! Check if antenna correction should be attempted - User_AntCorr = Options(m)%Use_Antenna_Correction - ! Set NLTE correction option - Apply_NLTE_Correction = Options(m)%Apply_NLTE_Correction - ! Set aircraft pressure altitude - Aircraft_Pressure = Options(m)%Aircraft_Pressure - - ! Copy over ancillary input + Opt = Default_Options + IF ( Options_Present ) THEN + Opt = Options(m) + ! Copy over ancillary input (just add AncillaryInput structure to options?) AncillaryInput%SSU = Options(m)%SSU AncillaryInput%Zeeman = Options(m)%Zeeman - ! Copy over surface optics input - SfcOptics%Use_New_MWSSEM = .NOT. Options(m)%Use_Old_MWSSEM - ! Specify the RT algorithm - RT_Algorithm_Id = Options(m)%RT_Algorithm_Id - ! Check if n_Streams should be used - User_N_Streams = Options(m)%Use_N_Streams - ! Check value for nstreams - IF ( User_N_Streams ) THEN - IF ( Options(m)%n_Streams <= 0 .OR. MOD(Options(m)%n_Streams,2) /= 0 .OR. & - Options(m)%n_Streams > MAX_N_STREAMS ) THEN - Error_Status = FAILURE - WRITE( Message,'( "Input Options n_Streams (", i0, ") is invalid" )' ) & - Options(m)%n_Streams - CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) - RETURN - END IF - END IF END IF + ! ...Assign the option specific SfcOptics input + SfcOptics%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM ! Check the input data if required - IF ( Check_Input ) THEN + IF ( Opt%Check_Input ) THEN ! ...Mandatory inputs Atmosphere_Invalid = .NOT. CRTM_Atmosphere_IsValid( Atmosphere(m) ) Surface_Invalid = .NOT. CRTM_Surface_IsValid( Surface(m) ) @@ -435,6 +407,28 @@ FUNCTION CRTM_Forward( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF + ! Are the channel dimensions consistent if emissivity is passed? + IF ( Options(m)%Use_Emissivity ) THEN + IF ( Options(m)%n_Channels < n_Channels ) THEN + Error_Status = FAILURE + WRITE( Message,'( "Input Options channel dimension (", i0, ") is less ", & + &"than the number of requested channels (",i0, ")" )' ) & + Options(m)%n_Channels, n_Channels + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + ! Check value for user-defined n_Streams + IF ( Options(m)%Use_N_Streams ) THEN + IF ( Options(m)%n_Streams <= 0 .OR. MOD(Options(m)%n_Streams,2) /= 0 .OR. & + Options(m)%n_Streams > MAX_N_STREAMS ) THEN + Error_Status = FAILURE + WRITE( Message,'( "Input Options n_Streams (", i0, ") is invalid" )' ) & + Options(m)%n_Streams + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF END IF END IF @@ -450,10 +444,6 @@ FUNCTION CRTM_Forward( & Source_Zenith_Angle = Source_ZA ) - ! Average surface skin temperature for multi-surface types - CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics ) - - ! Add extra layers to current atmosphere profile ! if necessary to handle upper atmosphere Error_Status = CRTM_Atmosphere_AddLayers( Atmosphere(m), Atm ) @@ -471,43 +461,26 @@ FUNCTION CRTM_Forward( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF - ! ...Allocate the atmospheric optics structures based on Atm extension + + + ! Prepare the atmospheric optics structures + ! ...Allocate the AtmOptics structure based on Atm extension CALL CRTM_AtmOptics_Create( AtmOptics, & Atm%n_Layers , & MAX_N_LEGENDRE_TERMS, & MAX_N_PHASE_ELEMENTS ) - IF (Options_Present) THEN - ! Set Scattering Switch - AtmOptics%Include_Scattering = Options(m)%Include_Scattering - END IF IF ( .NOT. CRTM_AtmOptics_Associated( Atmoptics ) ) THEN Error_Status = FAILURE WRITE( Message,'("Error allocating AtmOptics data structure for profile #",i0)' ) m CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF + ! ...Set the scattering switch + AtmOptics%Include_Scattering = Opt%Include_Scattering ! ...Allocate the atmospheric optics internal structure CALL AOvar_Create( AOvar, Atm%n_Layers ) - ! Process aircraft pressure altitude - IF ( Aircraft_Pressure > ZERO ) THEN - RTV%aircraft%rt = .TRUE. - RTV%aircraft%idx = CRTM_Get_PressureLevelIdx(Atm, Aircraft_Pressure) - ! ...Issue warning if profile level is TOO different from flight level - IF ( ABS(Atm%Level_Pressure(RTV%aircraft%idx)-Aircraft_Pressure) > AIRCRAFT_PRESSURE_THRESHOLD ) THEN - WRITE( Message,'("Difference between aircraft pressure level (",es13.6,& - &"hPa) and closest input profile level (",es13.6,& - &"hPa) is larger than recommended (",f4.1,"hPa) for profile #",i0)') & - Aircraft_Pressure, Atm%Level_Pressure(RTV%aircraft%idx), & - AIRCRAFT_PRESSURE_THRESHOLD, m - CALL Display_Message( ROUTINE_NAME, Message, WARNING ) - END IF - ELSE - RTV%aircraft%rt = .FALSE. - END IF - - ! Allocate the scattering internal variables if necessary ! ...Cloud IF ( Atm%n_Clouds > 0 ) THEN @@ -527,6 +500,68 @@ FUNCTION CRTM_Forward( & END IF + ! Determine the type of cloud coverage + cloud_coverage_flag = CRTM_Atmosphere_Coverage( atm ) + + + ! 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 + WRITE( Message,'("Error computing cloud cover in profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + + ! Allocate all the CLEAR sky structures for fractional cloud coverage + ! ...A clear sky atmosphere + Error_Status = CRTM_Atmosphere_ClearSkyCopy(Atm, Atm_Clear) + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'("Error copying CLEAR SKY atmopshere in profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + ! ...Clear sky SfcOptics + CALL CRTM_SfcOptics_Create( SfcOptics_Clear, MAX_N_ANGLES, MAX_N_STOKES ) + IF ( .NOT. CRTM_SfcOptics_Associated(SfcOptics_Clear) ) THEN + Error_Status = FAILURE + WRITE( Message,'("Error allocating CLEAR SKY SfcOptics data structure for profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + ! ...Copy over surface optics input + SfcOptics_Clear%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM + ! ...CLEAR SKY average surface skin temperature for multi-surface types + CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics_Clear ) + END IF + + + ! Average surface skin temperature for multi-surface types + CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics ) + + + ! Process aircraft pressure altitude + IF ( Opt%Aircraft_Pressure > ZERO ) THEN + RTV%aircraft%rt = .TRUE. + RTV%aircraft%idx = CRTM_Get_PressureLevelIdx(Atm, Opt%Aircraft_Pressure) + ! ...Issue warning if profile level is TOO different from flight level + IF ( ABS(Atm%Level_Pressure(RTV%aircraft%idx)-Opt%Aircraft_Pressure) > AIRCRAFT_PRESSURE_THRESHOLD ) THEN + WRITE( Message,'("Difference between aircraft pressure level (",es13.6,& + &"hPa) and closest input profile level (",es13.6,& + &"hPa) is larger than recommended (",f4.1,"hPa) for profile #",i0)') & + Opt%Aircraft_Pressure, Atm%Level_Pressure(RTV%aircraft%idx), & + AIRCRAFT_PRESSURE_THRESHOLD, m + CALL Display_Message( ROUTINE_NAME, Message, WARNING ) + END IF + ELSE + RTV%aircraft%rt = .FALSE. + END IF + + + + ! ----------- ! SENSOR LOOP ! ----------- @@ -541,13 +576,9 @@ FUNCTION CRTM_Forward( & ! Check if antenna correction to be applied for current sensor - IF ( User_AntCorr .AND. & - ACCoeff_Associated( SC(SensorIndex)%AC ) .AND. & - iFOV /= 0 ) THEN - Compute_AntCorr = .TRUE. - ELSE - Compute_AntCorr = .FALSE. - END IF + compute_antenna_correction = ( Opt%Use_Antenna_Correction .AND. & + ACCoeff_Associated( SC(SensorIndex)%AC ) .AND. & + iFOV /= 0 ) ! Compute predictors for AtmAbsorption calcs @@ -573,9 +604,10 @@ FUNCTION CRTM_Forward( & ! Allocate the RTV structure if necessary - IF( (Atm%n_Clouds > 0 .OR. & - Atm%n_Aerosols > 0 .OR. & - SpcCoeff_IsVisibleSensor( SC(SensorIndex) ) ) .and. AtmOptics%Include_Scattering ) THEN + IF( ( Atm%n_Clouds > 0 .OR. & + Atm%n_Aerosols > 0 .OR. & + SpcCoeff_IsVisibleSensor(SC(SensorIndex)) ) .AND. & + AtmOptics%Include_Scattering ) THEN CALL RTV_Create( RTV, MAX_N_ANGLES, MAX_N_LEGENDRE_TERMS, Atm%n_Layers ) IF ( .NOT. RTV_Associated(RTV) ) THEN Error_Status=FAILURE @@ -585,12 +617,12 @@ FUNCTION CRTM_Forward( & RETURN END IF ! Assign algorithm selector - RTV%RT_Algorithm_Id = RT_Algorithm_Id + RTV%RT_Algorithm_Id = Opt%RT_Algorithm_Id END IF ! Compute NLTE correction predictors - IF ( Apply_NLTE_Correction ) THEN + IF ( Opt%Apply_NLTE_Correction ) THEN CALL Compute_NLTE_Predictor( & SC(SensorIndex)%NC, & ! Input Atm , & ! Input @@ -620,10 +652,13 @@ FUNCTION CRTM_Forward( & ! Initialisations CALL CRTM_AtmOptics_Zero( AtmOptics ) + CALL CRTM_AtmOptics_Zero( AtmOptics_Clear ) + CALL CRTM_RTSolution_Zero( RTSolution_Clear ) + ! Determine the number of streams (n_Full_Streams) in up+downward directions - IF ( User_N_Streams ) THEN - n_Full_Streams = Options(m)%n_Streams + IF ( Opt%Use_N_Streams ) THEN + n_Full_Streams = Opt%n_Streams RTSolution(ln,m)%n_Full_Streams = n_Full_Streams + 2 RTSolution(ln,m)%Scattering_Flag = .TRUE. ELSE @@ -649,19 +684,15 @@ FUNCTION CRTM_Forward( & AtmOptics%Optical_Depth = AtmOptics%Optical_Depth * (RTSolution(ln,m)%Gamma + ONE) - ! Compute the clear-sky atmospheric transmittance - ! for use in FASTEM-X reflection correction - CALL CRTM_Compute_Transmittance(AtmOptics,transmittance) - - ! Compute the molecular scattering properties ! ...Solar radiation - IF( SC(SensorIndex)%Solar_Irradiance(ChannelIndex) > ZERO .AND. & - Source_ZA < MAX_SOURCE_ZENITH_ANGLE ) THEN - RTV%Solar_Flag_true = .TRUE. + IF ( SC(SensorIndex)%Solar_Irradiance(ChannelIndex) > ZERO .AND. & + Source_ZA < MAX_SOURCE_ZENITH_ANGLE ) THEN + RTV%Solar_Flag_true = .TRUE. + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) RTV_Clear%Solar_Flag_true = .TRUE. END IF ! ...Visible channel with solar radiation - IF( SpcCoeff_IsVisibleSensor( SC(SensorIndex) ) .AND. RTV%Solar_Flag_true ) THEN + IF ( SpcCoeff_IsVisibleSensor(SC(SensorIndex)) .AND. RTV%Solar_Flag_true ) THEN RTV%Visible_Flag_true = .TRUE. ! Rayleigh phase function has 0, 1, 2 components. IF( AtmOptics%n_Legendre_Terms < 4 ) THEN @@ -688,6 +719,23 @@ FUNCTION CRTM_Forward( & ELSE RTV%Visible_Flag_true = .FALSE. RTV%n_Azi = 0 + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTV_Clear%Visible_Flag_true = .FALSE. + RTV_Clear%n_Azi = 0 + END IF + END IF + + + ! Copy the clear-sky AtmOptics + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + Error_Status = CRTM_AtmOptics_NoScatterCopy( AtmOptics, AtmOptics_Clear ) + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'("Error copying CLEAR SKY AtmOptics for ",a,& + &", channel ",i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF END IF @@ -727,34 +775,47 @@ FUNCTION CRTM_Forward( & ! Compute the combined atmospheric optical properties IF( AtmOptics%Include_Scattering ) THEN - CALL CRTM_Combine_AtmOptics( AtmOptics, AOvar ) + CALL CRTM_AtmOptics_Combine( AtmOptics, AOvar ) END IF - ! ...Save vertically integrated scattering optical depth fro output + ! ...Save vertically integrated scattering optical depth for output RTSolution(ln,m)%SOD = AtmOptics%Scattering_Optical_Depth - ! Turn off FASTEM-X reflection correction for scattering conditions - IF ( CRTM_Include_Scattering(AtmOptics) .AND. SpcCoeff_IsMicrowaveSensor( SC(SensorIndex) ) ) THEN - SfcOptics%Transmittance = -ONE - ELSE - SfcOptics%Transmittance = transmittance + ! Compute the all-sky atmospheric transmittance + ! for use in FASTEM-X reflection correction + CALL CRTM_Compute_Transmittance(AtmOptics,transmittance) + SfcOptics%Transmittance = transmittance + ! ...Clear sky for fractional cloud cover + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + CALL CRTM_Compute_Transmittance(AtmOptics_Clear,transmittance_clear) + SfcOptics_Clear%Transmittance = transmittance_clear END IF - - ! Fill the SfcOptics structure for the optional emissivity input case. - ! ...Indicate SfcOptics ARE to be computed - SfcOptics%Compute = .TRUE. - ! ...Change SfcOptics emissivity/reflectivity contents/computation status - IF ( User_Emissivity ) THEN + ! Fill the SfcOptics structures for the optional emissivity input case. + SfcOptics%Compute = .TRUE. + SfcOptics_Clear%Compute = .TRUE. + IF ( Opt%Use_Emissivity ) THEN + ! ...Cloudy/all-sky case SfcOptics%Compute = .FALSE. - SfcOptics%Emissivity(1,1) = Options(m)%Emissivity(ln) - SfcOptics%Reflectivity(1,1,1,1) = ONE - Options(m)%Emissivity(ln) - IF ( User_Direct_Reflectivity ) THEN - SfcOptics%Direct_Reflectivity(1,1) = Options(m)%Direct_Reflectivity(ln) + SfcOptics%Emissivity(1,1) = Opt%Emissivity(ln) + SfcOptics%Reflectivity(1,1,1,1) = ONE - Opt%Emissivity(ln) + IF ( Opt%Use_Direct_Reflectivity ) THEN + SfcOptics%Direct_Reflectivity(1,1) = Opt%Direct_Reflectivity(ln) ELSE SfcOptics%Direct_Reflectivity(1,1) = SfcOptics%Reflectivity(1,1,1,1) END IF + ! ...Repeat for fractional clear-sky case + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + SfcOptics_Clear%Compute = .FALSE. + SfcOptics_Clear%Emissivity(1,1) = Opt%Emissivity(ln) + SfcOptics_Clear%Reflectivity(1,1,1,1) = ONE - Opt%Emissivity(ln) + IF ( Opt%Use_Direct_Reflectivity ) THEN + SfcOptics_Clear%Direct_Reflectivity(1,1) = Opt%Direct_Reflectivity(ln) + ELSE + SfcOptics_Clear%Direct_Reflectivity(1,1) = SfcOptics%Reflectivity(1,1,1,1) + END IF + END IF END IF @@ -787,54 +848,117 @@ FUNCTION CRTM_Forward( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF + + + ! Repeat clear sky for fractionally cloudy atmospheres + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTV_Clear%mth_Azi = mth_Azi + SfcOptics_Clear%mth_Azi = mth_Azi + Error_Status = CRTM_Compute_RTSolution( & + Atm_Clear , & ! Input + Surface(m) , & ! Input + AtmOptics_Clear , & ! Input + SfcOptics_Clear , & ! Input + GeometryInfo , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + RTSolution_Clear, & ! Output + RTV_Clear ) ! Internal variable output + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'( "Error computing CLEAR SKY RTSolution for ", a, & + &", channel ", i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + END DO Azimuth_Fourier_Loop - ! Compute non-LTE correction to radiance if required - IF ( Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) THEN - CALL Compute_NLTE_Correction( & - SC(SensorIndex)%NC , & ! Input - ChannelIndex , & ! Input - NLTE_Predictor , & ! Input - RTSolution(ln,m)%Radiance ) ! In/Output - END IF - ! Convert the radiance to brightness temperature - CALL CRTM_Planck_Temperature( & - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m)%Radiance , & ! Input - RTSolution(ln,m)%Brightness_Temperature ) ! Output - - ! Compute Antenna correction to brightness temperature if required - IF ( Compute_AntCorr ) THEN - CALL CRTM_Compute_AntCorr( & - GeometryInfo , & ! Input - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m) ) ! Output + ! Combine cloudy and clear radiances for fractional cloud coverage + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTSolution(ln,m)%Radiance = & + ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_Clear%Radiance) + & + (CloudCover%Total_Cloud_Cover * RTSolution(ln,m)%Radiance) + ! ...Save the cloud cover in the output structure + RTSolution(ln,m)%Total_Cloud_Cover = CloudCover%Total_Cloud_Cover END IF - END DO Channel_Loop - ! Deallocate local sensor dependent data structures - ! ...RTV structure - IF ( RTV_Associated(RTV) ) CALL RTV_Destroy(RTV) - ! ...Predictor structure - CALL CRTM_Predictor_Destroy( Predictor ) + ! The radiance post-processing + CALL Post_Process_RTSolution(RTSolution(ln,m)) - END DO Sensor_Loop + ! Perform clear-sky post-processing + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + CALL Post_Process_RTSolution(RTSolution_Clear) + ! ...Save the results in the output structure + RTSolution(ln,m)%R_Clear = RTSolution_Clear%Radiance + RTSolution(ln,m)%Tb_Clear = RTSolution_Clear%Brightness_Temperature + END IF - ! Deallocate local sensor independent data structures - ! ...Atmospheric optics - CALL CRTM_AtmOptics_Destroy( AtmOptics ) + END DO Channel_Loop + + END DO Sensor_Loop END DO Profile_Loop - ! Destroy any remaining structures + ! Clean up + CALL CRTM_Predictor_Destroy( Predictor ) + CALL CRTM_AtmOptics_Destroy( AtmOptics ) + CALL CRTM_AtmOptics_Destroy( AtmOptics_Clear ) CALL CRTM_SfcOptics_Destroy( SfcOptics ) + CALL CRTM_SfcOptics_Destroy( SfcOptics_Clear ) CALL CRTM_Atmosphere_Destroy( Atm ) + CALL CRTM_Atmosphere_Destroy( Atm_Clear ) + ! ...Internal variables + CALL AOvar_Destroy( AOvar ) + CALL CSvar_Destroy( CSvar ) + CALL ASvar_Destroy( ASvar ) + CALL RTV_Destroy( RTV ) + + + CONTAINS + + + ! ---------------------------------------------------------------- + ! Local subroutine to post-process the radiance, as it is the same + ! for all-sky and fractional clear-sky cases. + ! + ! 1. Apply non-LTE correction to radiance + ! 2. Convert radiance to brightness temperature + ! 3. Apply antenna correction to brightness temperature + ! ---------------------------------------------------------------- + + SUBROUTINE Post_Process_RTSolution(rts) + TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: rts + + ! Compute non-LTE correction to radiance if required + IF ( Opt%Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) THEN + CALL Compute_NLTE_Correction( & + SC(SensorIndex)%NC, & ! Input + ChannelIndex , & ! Input + NLTE_Predictor , & ! Input + rts%Radiance ) ! In/Output + END IF + ! Convert the radiance to brightness temperature + CALL CRTM_Planck_Temperature( & + SensorIndex , & ! Input + ChannelIndex , & ! Input + rts%Radiance , & ! Input + rts%Brightness_Temperature ) ! Output + ! Compute Antenna correction to brightness temperature if required + IF ( compute_antenna_correction ) THEN + CALL CRTM_Compute_AntCorr( & + GeometryInfo, & ! Input + SensorIndex , & ! Input + ChannelIndex, & ! Input + rts ) ! Output + END IF + + END SUBROUTINE Post_Process_RTSolution END FUNCTION CRTM_Forward diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_GeometryInfo.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_GeometryInfo.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_GeometryInfo.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_GeometryInfo.f90 index 917d8d637d..881eac50be 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_GeometryInfo.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_GeometryInfo.f90 @@ -49,7 +49,7 @@ MODULE CRTM_GeometryInfo ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_GeometryInfo.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_GeometryInfo.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Metres->kilometres conversion factor REAL(fp), PARAMETER :: M_TO_KM = 1.0e-03_fp diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_GeometryInfo_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_GeometryInfo_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_GeometryInfo_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_GeometryInfo_Define.f90 index 446b303e44..b4ff55a4ca 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_GeometryInfo_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_GeometryInfo_Define.f90 @@ -87,7 +87,7 @@ MODULE CRTM_GeometryInfo_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_GeometryInfo_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_GeometryInfo_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 @@ -862,7 +862,8 @@ FUNCTION CRTM_GeometryInfo_ReadFile( & CALL Read_Cleanup(); RETURN END IF ! ...Allocate the return structure array - ALLOCATE(GeometryInfo(n_input_profiles), STAT=alloc_stat, ERRMSG=alloc_msg) + !ALLOCATE(GeometryInfo(n_input_profiles), STAT=alloc_stat, ERRMSG=alloc_msg) + ALLOCATE(GeometryInfo(n_input_profiles), STAT=alloc_stat) IF ( alloc_stat /= 0 ) THEN msg = 'Error allocating GeometryInfo array - '//TRIM(alloc_msg) CALL Read_Cleanup(); RETURN @@ -907,7 +908,8 @@ SUBROUTINE Read_CleanUp() msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) END IF IF ( ALLOCATED(GeometryInfo) ) THEN - DEALLOCATE(GeometryInfo, STAT=alloc_stat, ERRMSG=alloc_msg) + !DEALLOCATE(GeometryInfo, STAT=alloc_stat, ERRMSG=alloc_msg) + DEALLOCATE(GeometryInfo, STAT=alloc_stat) IF ( alloc_stat /= 0 ) & msg = TRIM(msg)//'; Error deallocating GeometryInfo array during error cleanup - '//& TRIM(alloc_msg) diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Geometry_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Geometry_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_Geometry_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Geometry_Define.f90 index b3aa574594..020ad56b35 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Geometry_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Geometry_Define.f90 @@ -84,7 +84,7 @@ MODULE CRTM_Geometry_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Geometry_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Geometry_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(fp), PARAMETER :: ZERO = 0.0_fp ! Message string length @@ -1166,7 +1166,8 @@ FUNCTION CRTM_Geometry_ReadFile( & CALL Read_Cleanup(); RETURN END IF ! ...Allocate the return structure array - ALLOCATE(Geometry(n_input_profiles), STAT=alloc_stat, ERRMSG=alloc_msg) + !ALLOCATE(Geometry(n_input_profiles), STAT=alloc_stat, ERRMSG=alloc_msg) + ALLOCATE(Geometry(n_input_profiles), STAT=alloc_stat) IF ( alloc_stat /= 0 ) THEN msg = 'Error allocating Geometry array - '//TRIM(alloc_msg) CALL Read_Cleanup(); RETURN @@ -1213,7 +1214,8 @@ SUBROUTINE Read_CleanUp() msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) END IF IF ( ALLOCATED(Geometry) ) THEN - DEALLOCATE(Geometry, STAT=alloc_stat, ERRMSG=alloc_msg) + !DEALLOCATE(Geometry, STAT=alloc_stat, ERRMSG=alloc_msg) + DEALLOCATE(Geometry, STAT=alloc_stat) IF ( alloc_stat /= 0 ) & msg = TRIM(msg)//'; Error deallocating Geometry array during error cleanup - '//& TRIM(alloc_msg) diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_IRSSEM.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_IRSSEM.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_IRSSEM.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_IRSSEM.f90 index e0ea0940be..8f3c6d4b5c 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_IRSSEM.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_IRSSEM.f90 @@ -51,7 +51,7 @@ MODULE CRTM_IRSSEM ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_IRSSEM.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_IRSSEM.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_IR_Ice_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_IR_Ice_SfcOptics.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_IR_Ice_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_IR_Ice_SfcOptics.f90 index 8528b2de12..ed9dc0ec3d 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_IR_Ice_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_IR_Ice_SfcOptics.f90 @@ -53,7 +53,7 @@ MODULE CRTM_IR_Ice_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_IR_Ice_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_IR_Ice_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_IR_Land_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_IR_Land_SfcOptics.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_IR_Land_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_IR_Land_SfcOptics.f90 index 799aa0caf3..27a6fd9d39 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_IR_Land_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_IR_Land_SfcOptics.f90 @@ -52,7 +52,7 @@ MODULE CRTM_IR_Land_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_IR_Land_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_IR_Land_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_IR_Snow_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_IR_Snow_SfcOptics.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_IR_Snow_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_IR_Snow_SfcOptics.f90 index 00f5d12fde..2be08755d1 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_IR_Snow_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_IR_Snow_SfcOptics.f90 @@ -53,7 +53,7 @@ MODULE CRTM_IR_Snow_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_IR_Snow_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_IR_Snow_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_IR_Water_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_IR_Water_SfcOptics.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_IR_Water_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_IR_Water_SfcOptics.f90 index ede85416ea..da450e01e6 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_IR_Water_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_IR_Water_SfcOptics.f90 @@ -54,7 +54,7 @@ MODULE CRTM_IR_Water_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_IR_Water_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_IR_Water_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Coefficients for Sigma**2 in the Cox & Munk slope probability density function REAL(fp), PARAMETER :: CM_1 = 0.003_fp, CM_2 = 5.12e-3_fp diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_IRiceCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_IRiceCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_IRiceCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_IRiceCoeff.f90 index 9ad93269a5..796ad547a5 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_IRiceCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_IRiceCoeff.f90 @@ -53,7 +53,7 @@ MODULE CRTM_IRiceCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_IRiceCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_IRiceCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 512 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_IRlandCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_IRlandCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_IRlandCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_IRlandCoeff.f90 index 07f6a80645..d6cb420dd3 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_IRlandCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_IRlandCoeff.f90 @@ -54,7 +54,7 @@ MODULE CRTM_IRlandCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_IRlandCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_IRlandCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 512 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_IRsnowCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_IRsnowCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_IRsnowCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_IRsnowCoeff.f90 index a836cf0da8..0ba95522fc 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_IRsnowCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_IRsnowCoeff.f90 @@ -53,7 +53,7 @@ MODULE CRTM_IRsnowCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_IRsnowCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_IRsnowCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 512 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_IRwaterCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_IRwaterCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_IRwaterCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_IRwaterCoeff.f90 index 61e35f4806..01bd8eb6b8 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_IRwaterCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_IRwaterCoeff.f90 @@ -53,7 +53,7 @@ MODULE CRTM_IRwaterCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_IRwaterCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_IRwaterCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 512 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Interpolation.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Interpolation.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_Interpolation.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Interpolation.f90 index 903039da90..4593f06be9 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Interpolation.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Interpolation.f90 @@ -64,7 +64,7 @@ MODULE CRTM_Interpolation ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_RCS_ID=& - '$Id: CRTM_Interpolation.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Interpolation.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: ONE = 1.0_fp INTEGER, PARAMETER :: ORDER = 2 ! Quadratic diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_K_Matrix_Module.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_K_Matrix_Module.f90 similarity index 60% rename from var/external/crtm_2.2.3/libsrc/CRTM_K_Matrix_Module.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_K_Matrix_Module.f90 index 78927feaa1..d9827faee5 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_K_Matrix_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_K_Matrix_Module.f90 @@ -31,21 +31,33 @@ MODULE CRTM_K_Matrix_Module SpcCoeff_IsInfraredSensor , & SpcCoeff_IsMicrowaveSensor, & SpcCoeff_IsVisibleSensor - USE CRTM_Atmosphere_Define, ONLY: CRTM_Atmosphere_type, & - CRTM_Atmosphere_Destroy, & - CRTM_Atmosphere_IsValid, & - CRTM_Atmosphere_AddLayerCopy, & + USE CRTM_Atmosphere_Define, ONLY: OPERATOR(+) , & + CRTM_Atmosphere_type , & + CRTM_Atmosphere_Associated , & + CRTM_Atmosphere_Destroy , & + CRTM_Atmosphere_IsValid , & + CRTM_Atmosphere_Zero , & + CRTM_Atmosphere_AddLayerCopy , & + CRTM_Atmosphere_NonVariableCopy, & CRTM_Get_PressureLevelIdx - USE CRTM_Surface_Define, ONLY: CRTM_Surface_type, & - CRTM_Surface_IsValid + USE CRTM_Surface_Define, ONLY: CRTM_Surface_type , & + CRTM_Surface_IsValid , & + CRTM_Surface_NonVariableCopy USE CRTM_Geometry_Define, ONLY: CRTM_Geometry_type, & CRTM_Geometry_IsValid USE CRTM_ChannelInfo_Define, ONLY: CRTM_ChannelInfo_type, & CRTM_ChannelInfo_n_Channels + USE CRTM_RTSolution_Define, ONLY: CRTM_RTSolution_type , & + CRTM_RTSolution_Destroy, & + CRTM_RTSolution_Zero USE CRTM_Options_Define, ONLY: CRTM_Options_type, & CRTM_Options_IsValid - USE CRTM_Atmosphere, ONLY: CRTM_Atmosphere_AddLayers, & - CRTM_Atmosphere_AddLayers_AD + USE CRTM_Atmosphere, ONLY: CRTM_Atmosphere_AddLayers , & + CRTM_Atmosphere_AddLayers_AD , & + CRTM_Atmosphere_IsFractional , & + CRTM_Atmosphere_Coverage , & + CRTM_Atmosphere_ClearSkyCopy , & + CRTM_Atmosphere_ClearSkyCopy_AD USE CRTM_GeometryInfo_Define, ONLY: CRTM_GeometryInfo_type, & CRTM_GeometryInfo_SetValue, & CRTM_GeometryInfo_GetValue @@ -75,16 +87,19 @@ MODULE CRTM_K_Matrix_Module CRTM_Include_Scattering , & CRTM_Compute_Transmittance , & CRTM_Compute_Transmittance_AD, & - CRTM_Combine_AtmOptics , & - CRTM_Combine_AtmOptics_AD - USE CRTM_SfcOptics_Define, ONLY: CRTM_SfcOptics_type , & + CRTM_AtmOptics_Combine , & + CRTM_AtmOptics_Combine_AD , & + CRTM_AtmOptics_NoScatterCopy , & + CRTM_AtmOptics_NoScatterCopy_AD + USE CRTM_SfcOptics_Define, ONLY: OPERATOR(+) , & + CRTM_SfcOptics_type , & CRTM_SfcOptics_Associated, & CRTM_SfcOptics_Create , & - CRTM_SfcOptics_Destroy + CRTM_SfcOptics_Destroy , & + CRTM_SfcOptics_Zero, crtm_sfcoptics_inspect USE CRTM_SfcOptics, ONLY: CRTM_Compute_SurfaceT , & CRTM_Compute_SurfaceT_AD - USE CRTM_RTSolution, ONLY: CRTM_RTSolution_type , & - CRTM_Compute_nStreams , & + USE CRTM_RTSolution, ONLY: CRTM_Compute_nStreams , & CRTM_Compute_RTSolution , & CRTM_Compute_RTSolution_AD USE CRTM_AntennaCorrection, ONLY: CRTM_Compute_AntCorr, & @@ -104,8 +119,14 @@ MODULE CRTM_K_Matrix_Module USE NLTECoeff_Define, ONLY: NLTECoeff_Associated USE CRTM_Planck_Functions, ONLY: CRTM_Planck_Temperature , & CRTM_Planck_Temperature_AD + USE CRTM_CloudCover_Define, ONLY: CRTM_CloudCover_type ! Internal variable definition modules + ! ...AtmOptics + USE AOvar_Define, ONLY: AOvar_type, & + AOvar_Associated, & + AOvar_Destroy , & + AOvar_Create ! ...CloudScatter USE CSvar_Define, ONLY: CSvar_type, & CSvar_Associated, & @@ -144,7 +165,7 @@ MODULE CRTM_K_Matrix_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_K_Matrix_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_K_Matrix_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS @@ -298,28 +319,33 @@ FUNCTION CRTM_K_Matrix( & ! Local variables CHARACTER(256) :: Message LOGICAL :: Options_Present - LOGICAL :: Check_Input - LOGICAL :: User_Emissivity, User_Direct_Reflectivity, User_N_Streams - LOGICAL :: User_AntCorr, Compute_AntCorr - LOGICAL :: Apply_NLTE_Correction + LOGICAL :: compute_antenna_correction LOGICAL :: Atmosphere_Invalid, Surface_Invalid, Geometry_Invalid, Options_Invalid - INTEGER :: RT_Algorithm_Id + INTEGER :: Status_FWD, Status_K INTEGER :: iFOV - INTEGER :: nc, na INTEGER :: n, n_Sensors, SensorIndex INTEGER :: l, n_Channels, ChannelIndex INTEGER :: m, n_Profiles - INTEGER :: j, ln + INTEGER :: ln INTEGER :: n_Full_Streams, mth_Azi + INTEGER :: cloud_coverage_flag REAL(fp) :: Source_ZA REAL(fp) :: Wavenumber REAL(fp) :: transmittance, transmittance_K + REAL(fp) :: transmittance_clear, transmittance_clear_K + REAL(fp) :: r_cloudy ! Local ancillary input structure TYPE(CRTM_AncillaryInput_type) :: AncillaryInput ! Local options structure for default values - TYPE(CRTM_Options_type) :: Default_Options + TYPE(CRTM_Options_type) :: Default_Options, Opt ! Local atmosphere structure for extra layering TYPE(CRTM_Atmosphere_type) :: Atm, Atm_K + ! Clear sky structures + TYPE(CRTM_Atmosphere_type) :: Atm_Clear , Atm_Clear_K + TYPE(CRTM_AtmOptics_type) :: AtmOptics_Clear , AtmOptics_Clear_K + TYPE(CRTM_SfcOptics_type) :: SfcOptics_Clear , SfcOptics_Clear_K + TYPE(CRTM_RTSolution_type) :: RTSolution_Clear, RTSolution_Clear_K + TYPE(RTV_type) :: RTV_Clear ! Component variables TYPE(CRTM_GeometryInfo_type) :: GeometryInfo TYPE(CRTM_Predictor_type) :: Predictor, Predictor_K @@ -334,6 +360,8 @@ FUNCTION CRTM_K_Matrix( & TYPE(RTV_type) :: RTV ! RTSolution ! NLTE correction term predictors TYPE(NLTE_Predictor_type) :: NLTE_Predictor, NLTE_Predictor_K + ! Cloud cover object + TYPE(CRTM_CloudCover_type) :: CloudCover, CloudCover_K ! ------ ! SET UP @@ -393,6 +421,10 @@ FUNCTION CRTM_K_Matrix( & END IF + ! Reinitialise the output RTSolution + CALL CRTM_RTSolution_Zero(RTSolution) + + ! Allocate the profile independent surface optics local structure CALL CRTM_SfcOptics_Create( SfcOptics , MAX_N_ANGLES, MAX_N_STOKES ) CALL CRTM_SfcOptics_Create( SfcOptics_K, MAX_N_ANGLES, MAX_N_STOKES ) @@ -430,90 +462,25 @@ FUNCTION CRTM_K_Matrix( & ! Copy over forward "non-variable" inputs to K-matrix outputs DO l = 1, n_Channels - ! ...Atmosphere - Atmosphere_K(l,m)%Climatology = Atmosphere(m)%Climatology - ! Loop over absorbers - DO j = 1, Atmosphere(m)%n_Absorbers - Atmosphere_K(l,m)%Absorber_ID(j) = Atmosphere(m)%Absorber_ID(j) - Atmosphere_K(l,m)%Absorber_Units(j) = Atmosphere(m)%Absorber_Units(j) - END DO - ! Loop over and assign cloud types - DO nc = 1, Atmosphere(m)%n_Clouds - Atmosphere_K(l,m)%Cloud(nc)%Type = Atmosphere(m)%Cloud(nc)%Type - END DO - ! Loop over and assign aerosol types - DO na = 1, Atmosphere(m)%n_Aerosols - Atmosphere_K(l,m)%Aerosol(na)%Type = Atmosphere(m)%Aerosol(na)%Type - END DO - ! ...Surface - Surface_K(l,m)%Land_Coverage = Surface(m)%Land_Coverage - Surface_K(l,m)%Water_Coverage = Surface(m)%Water_Coverage - Surface_K(l,m)%Snow_Coverage = Surface(m)%Snow_Coverage - Surface_K(l,m)%Ice_Coverage = Surface(m)%Ice_Coverage - Surface_K(l,m)%Land_Type = Surface(m)%Land_Type - Surface_K(l,m)%Water_Type = Surface(m)%Water_Type - Surface_K(l,m)%Snow_Type = Surface(m)%Snow_Type - Surface_K(l,m)%Ice_Type = Surface(m)%Ice_Type + CALL CRTM_Atmosphere_NonVariableCopy( Atmosphere(m), Atmosphere_K(l,m) ) + CALL CRTM_Surface_NonVariableCopy( Surface(m), Surface_K(l,m) ) END DO ! Check the optional Options structure argument - ! ...Specify default actions - Check_Input = Default_Options%Check_Input - User_Emissivity = Default_Options%Use_Emissivity - User_AntCorr = Default_Options%Use_Antenna_Correction - Apply_NLTE_Correction = Default_Options%Apply_NLTE_Correction - RT_Algorithm_Id = Default_Options%RT_Algorithm_Id - User_N_Streams = Default_Options%Use_N_Streams - ! ...Check the Options argument - IF (Options_Present) THEN - ! Override input checker with option - Check_Input = Options(m)%Check_Input - ! Check if the supplied emissivity should be used - User_Emissivity = Options(m)%Use_Emissivity - IF ( Options(m)%Use_Emissivity ) THEN - ! Are the channel dimensions consistent - IF ( Options(m)%n_Channels < n_Channels ) THEN - Error_Status = FAILURE - WRITE( Message,'( "Input Options channel dimension (", i0, ") is less ", & - &"than the number of requested channels (",i0, ")" )' ) & - Options(m)%n_Channels, n_Channels - CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) - RETURN - END IF - ! Check if the supplied direct reflectivity should be used - User_Direct_Reflectivity = Options(m)%Use_Direct_Reflectivity - END IF - ! Check if antenna correction should be attempted - User_AntCorr = Options(m)%Use_Antenna_Correction - ! Set NLTE correction option - Apply_NLTE_Correction = Options(m)%Apply_NLTE_Correction - + Opt = Default_Options + IF ( Options_Present ) THEN + Opt = Options(m) ! Copy over ancillary input AncillaryInput%SSU = Options(m)%SSU AncillaryInput%Zeeman = Options(m)%Zeeman - ! Copy over surface optics input - SfcOptics%Use_New_MWSSEM = .NOT. Options(m)%Use_Old_MWSSEM - ! Specify the RT algorithm - RT_Algorithm_Id = Options(m)%RT_Algorithm_ID - ! Check if n_Streams should be used - User_N_Streams = Options(m)%Use_N_Streams - ! Check value for nstreams - IF ( User_N_Streams ) THEN - IF ( Options(m)%n_Streams <= 0 .OR. MOD(Options(m)%n_Streams,2) /= 0 .OR. & - Options(m)%n_Streams > MAX_N_STREAMS ) THEN - Error_Status = FAILURE - WRITE( Message,'( "Input Options n_Streams (", i0, ") is invalid" )' ) & - Options(m)%n_Streams - CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) - RETURN - END IF - END IF END IF + ! ...Assign the option specific SfcOptics input + SfcOptics%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM ! Check the input data if required - IF ( Check_Input ) THEN + IF ( Opt%Check_Input ) THEN ! ...Mandatory inputs Atmosphere_Invalid = .NOT. CRTM_Atmosphere_IsValid( Atmosphere(m) ) Surface_Invalid = .NOT. CRTM_Surface_IsValid( Surface(m) ) @@ -533,6 +500,28 @@ FUNCTION CRTM_K_Matrix( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF + ! Are the channel dimensions consistent if emissivity is passed? + IF ( Options(m)%Use_Emissivity ) THEN + IF ( Options(m)%n_Channels < n_Channels ) THEN + Error_Status = FAILURE + WRITE( Message,'( "Input Options channel dimension (", i0, ") is less ", & + &"than the number of requested channels (",i0, ")" )' ) & + Options(m)%n_Channels, n_Channels + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + ! Check value for user-defined n_Streams + IF ( Options(m)%Use_N_Streams ) THEN + IF ( Options(m)%n_Streams <= 0 .OR. MOD(Options(m)%n_Streams,2) /= 0 .OR. & + Options(m)%n_Streams > MAX_N_STREAMS ) THEN + Error_Status = FAILURE + WRITE( Message,'( "Input Options n_Streams (", i0, ") is invalid" )' ) & + Options(m)%n_Streams + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF END IF END IF @@ -548,10 +537,6 @@ FUNCTION CRTM_K_Matrix( & Source_Zenith_Angle = Source_ZA ) - ! Average surface skin temperature for multi-surface types - CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics ) - - ! Add extra layers to current atmosphere profile ! if necessary to handle upper atmosphere Error_Status = CRTM_Atmosphere_AddLayers( Atmosphere(m), Atm ) @@ -570,6 +555,9 @@ FUNCTION CRTM_K_Matrix( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF + + + ! Prepare the atmospheric optics structures ! ...Allocate the atmospheric optics structures based on Atm extension CALL CRTM_AtmOptics_Create( AtmOptics, & Atm%n_Layers , & @@ -586,11 +574,9 @@ FUNCTION CRTM_K_Matrix( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF - IF (Options_Present) THEN - ! Set Scattering Switch - AtmOptics%Include_Scattering = Options(m)%Include_Scattering - AtmOptics_K%Include_Scattering = Options(m)%Include_Scattering - END IF + ! ...Set the Scattering Switch + AtmOptics%Include_Scattering = Opt%Include_Scattering + AtmOptics_K%Include_Scattering = Opt%Include_Scattering ! ...Allocate the atmospheric optics internal structure CALL AOvar_Create( AOvar, Atm%n_Layers ) @@ -614,6 +600,56 @@ FUNCTION CRTM_K_Matrix( & END IF + ! Determine the type of cloud coverage + cloud_coverage_flag = CRTM_Atmosphere_Coverage( atm ) + + + ! 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 + WRITE( Message,'("Error computing cloud cover in profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + ! ...Mold the K-matrix object based on the forward, and reinitialise + CloudCover_K = CloudCover + CALL CloudCover_K%Set_To_Zero() + + ! Allocate some of the CLEAR sky structure for fractional cloud coverage + ! (The AtmOptics structures are allocated during a copy) + ! ...Clear sky atmosphere + Error_Status = CRTM_Atmosphere_ClearSkyCopy(Atm, Atm_Clear) + IF ( Error_Status /= SUCCESS ) THEN + Error_status = FAILURE + WRITE( Message,'("Error copying CLEAR SKY Atmosphere structures for profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + ! ...Clear sky SfcOptics + CALL CRTM_SfcOptics_Create( SfcOptics_Clear , MAX_N_ANGLES, MAX_N_STOKES ) + CALL CRTM_SfcOptics_Create( SfcOptics_Clear_K, MAX_N_ANGLES, MAX_N_STOKES ) + IF ( (.NOT. CRTM_SfcOptics_Associated(SfcOptics_Clear)) .OR. & + (.NOT. CRTM_SfcOptics_Associated(SfcOptics_Clear_K))) THEN + Error_Status = FAILURE + WRITE( Message,'("Error allocating CLEAR SKY SfcOptics data structures for profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + ! ...Copy over surface optics input + SfcOptics_Clear%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM + ! ...CLEAR SKY average surface skin temperature for multi-surface types + CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics_Clear ) + END IF + + + ! Average surface skin temperature for multi-surface types + CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics ) + + + ! ----------- ! SENSOR LOOP ! ----------- @@ -628,13 +664,9 @@ FUNCTION CRTM_K_Matrix( & ! Check if antenna correction to be applied for current sensor - IF ( User_AntCorr .AND. & - ACCoeff_Associated( SC(SensorIndex)%AC ) .AND. & - iFOV /= 0 ) THEN - Compute_AntCorr = .TRUE. - ELSE - Compute_AntCorr = .FALSE. - END IF + compute_antenna_correction = ( Opt%Use_Antenna_Correction .AND. & + ACCoeff_Associated( SC(SensorIndex)%AC ) .AND. & + iFOV /= 0 ) ! Allocate the AtmAbsorption predictor structures @@ -667,9 +699,10 @@ FUNCTION CRTM_K_Matrix( & ! Allocate the RTV structure if necessary - IF( (Atm%n_Clouds > 0 .OR. & - Atm%n_Aerosols > 0 .OR. & - SpcCoeff_IsVisibleSensor( SC(SensorIndex) ) ) .and. AtmOptics%Include_Scattering ) THEN + IF( ( Atm%n_Clouds > 0 .OR. & + Atm%n_Aerosols > 0 .OR. & + SpcCoeff_IsVisibleSensor(SC(SensorIndex)) ) .AND. & + AtmOptics%Include_Scattering ) THEN CALL RTV_Create( RTV, MAX_N_ANGLES, MAX_N_LEGENDRE_TERMS, Atm%n_Layers ) IF ( .NOT. RTV_Associated(RTV) ) THEN Error_Status=FAILURE @@ -679,12 +712,12 @@ FUNCTION CRTM_K_Matrix( & RETURN END IF ! Assign algorithm selector - RTV%RT_Algorithm_Id = RT_Algorithm_Id + RTV%RT_Algorithm_Id = Opt%RT_Algorithm_Id END IF - ! Compute NLTE predictors - IF ( Apply_NLTE_Correction ) THEN + ! Compute NLTE correction predictors + IF ( Opt%Apply_NLTE_Correction ) THEN CALL Compute_NLTE_Predictor( & SC(SensorIndex)%NC, & ! Input Atm , & ! Input @@ -715,19 +748,48 @@ FUNCTION CRTM_K_Matrix( & 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 RTSolution_K(ln,m)%Sensor_Channel = RTSolution(ln,m)%Sensor_Channel + ! ...Same for clear structures + RTSolution_Clear%Sensor_Id = RTSolution(ln,m)%Sensor_Id + RTSolution_Clear%WMO_Satellite_Id = RTSolution(ln,m)%WMO_Satellite_Id + RTSolution_Clear%WMO_Sensor_Id = RTSolution(ln,m)%WMO_Sensor_Id + RTSolution_Clear%Sensor_Channel = RTSolution(ln,m)%Sensor_Channel + RTSolution_Clear_K%Sensor_Id = RTSolution(ln,m)%Sensor_Id + RTSolution_Clear_K%WMO_Satellite_Id = RTSolution(ln,m)%WMO_Satellite_Id + RTSolution_Clear_K%WMO_Sensor_Id = RTSolution(ln,m)%WMO_Sensor_Id + RTSolution_Clear_K%Sensor_Channel = RTSolution(ln,m)%Sensor_Channel ! Initialisations CALL CRTM_AtmOptics_Zero( AtmOptics ) + CALL CRTM_AtmOptics_Zero( AtmOptics_K ) + CALL CRTM_AtmOptics_Zero( AtmOptics_Clear ) + CALL CRTM_AtmOptics_Zero( AtmOptics_Clear_K ) transmittance_K = ZERO + CALL CRTM_RTSolution_Zero( RTSolution_Clear ) + CALL CRTM_RTSolution_Zero( RTSolution_Clear_K ) ! Copy the input K-matrix atmosphere with extra layers if necessary Atm_K = CRTM_Atmosphere_AddLayerCopy( Atmosphere_K(ln,m), Atm%n_Added_Layers ) + ! ...Same for K-matrix CLEAR sky structure for fractional cloud coverage + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + Error_Status = CRTM_Atmosphere_ClearSkyCopy(Atm_K, Atm_Clear_K) + IF ( Error_Status /= SUCCESS ) THEN + Error_status = FAILURE + WRITE( Message,'("Error copying CLEAR SKY Atmosphere_K structure for ",a,& + &", channel ",i0,", profile #",i0)') & + TRIM(ChannelInfo(n)%Sensor_ID), & + ChannelInfo(n)%Sensor_Channel(l), & + m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + CALL CRTM_Atmosphere_Zero( Atm_Clear_K ) + END IF ! Determine the number of streams (n_Full_Streams) in up+downward directions - IF ( User_N_Streams ) THEN + IF ( Opt%Use_N_Streams ) THEN n_Full_Streams = Options(m)%n_Streams RTSolution(ln,m)%n_Full_Streams = n_Full_Streams + 2 RTSolution(ln,m)%Scattering_Flag = .TRUE. @@ -740,6 +802,8 @@ FUNCTION CRTM_K_Matrix( & ! ...Transfer stream count to scattering structures AtmOptics%n_Legendre_Terms = n_Full_Streams AtmOptics_K%n_Legendre_Terms = n_Full_Streams + ! ...Ensure clear-sky object dimensions are consistent + AtmOptics_Clear_K%n_Legendre_Terms = AtmOptics_K%n_Legendre_Terms ! Compute the gas absorption @@ -755,11 +819,6 @@ FUNCTION CRTM_K_Matrix( & AtmOptics%Optical_Depth = AtmOptics%Optical_Depth * (RTSolution(ln,m)%Gamma + ONE) - ! Compute the clear-sky atmospheric transmittance - ! for use in FASTEM-X reflection correction - CALL CRTM_Compute_Transmittance(AtmOptics,transmittance) - - ! Compute the molecular scattering properties ! ...Solar radiation IF( SC(SensorIndex)%Solar_Irradiance(ChannelIndex) > ZERO .AND. & @@ -795,6 +854,27 @@ FUNCTION CRTM_K_Matrix( & ELSE RTV%Visible_Flag_true = .FALSE. RTV%n_Azi = 0 + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTV_Clear%Visible_Flag_true = .FALSE. + RTV_Clear%n_Azi = 0 + END IF + END IF + + + ! Copy the clear-sky AtmOptics + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + Status_FWD = CRTM_AtmOptics_NoScatterCopy( AtmOptics, AtmOptics_Clear ) + Status_K = CRTM_AtmOptics_NoScatterCopy( AtmOptics, AtmOptics_Clear_K ) + IF ( Status_FWD /= SUCCESS .OR. Status_K /= SUCCESS ) THEN + Error_Status = FAILURE + WRITE( Message,'("Error copying CLEAR SKY AtmOptics for ",a,& + &", channel ",i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + ! Initialise the adjoint + CALL CRTM_AtmOptics_Zero( AtmOptics_Clear_K ) END IF @@ -834,34 +914,46 @@ FUNCTION CRTM_K_Matrix( & ! Compute the combined atmospheric optical properties IF( AtmOptics%Include_Scattering ) THEN - CALL CRTM_Combine_AtmOptics( AtmOptics, AOvar ) + CALL CRTM_AtmOptics_Combine( AtmOptics, AOvar ) END IF ! ...Save vertically integrated scattering optical depth for output RTSolution(ln,m)%SOD = AtmOptics%Scattering_Optical_Depth - ! Turn off FASTEM-X reflection correction for scattering conditions - IF ( CRTM_Include_Scattering(AtmOptics) .AND. SpcCoeff_IsMicrowaveSensor( SC(SensorIndex) ) ) THEN - SfcOptics%Transmittance = -ONE - ELSE - SfcOptics%Transmittance = transmittance + ! Compute the all-sky atmospheric transmittance + ! for use in FASTEM-X reflection correction + CALL CRTM_Compute_Transmittance(AtmOptics,transmittance) + SfcOptics%Transmittance = transmittance + ! ...Clear sky for fractional cloud cover + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + CALL CRTM_Compute_Transmittance(AtmOptics_Clear,transmittance_clear) + SfcOptics_Clear%Transmittance = transmittance_clear END IF ! Fill the SfcOptics structure for the optional emissivity input case. - ! ...Indicate SfcOptics ARE to be computed - SfcOptics%Compute = .TRUE. - ! Change SfcOptics emissivity/reflectivity contents/computation status - IF ( User_Emissivity ) THEN + SfcOptics%Compute = .TRUE. + SfcOptics_Clear%Compute = .TRUE. + IF ( Opt%Use_Emissivity ) THEN SfcOptics%Compute = .FALSE. - SfcOptics%Emissivity(1,1) = Options(m)%Emissivity(ln) - SfcOptics%Reflectivity(1,1,1,1) = ONE - Options(m)%Emissivity(ln) - IF ( User_Direct_Reflectivity ) THEN - SfcOptics%Direct_Reflectivity(1,1) = Options(m)%Direct_Reflectivity(ln) + SfcOptics%Emissivity(1,1) = Opt%Emissivity(ln) + SfcOptics%Reflectivity(1,1,1,1) = ONE - Opt%Emissivity(ln) + IF ( Opt%Use_Direct_Reflectivity ) THEN + SfcOptics%Direct_Reflectivity(1,1) = Opt%Direct_Reflectivity(ln) ELSE SfcOptics%Direct_Reflectivity(1,1) = SfcOptics%Reflectivity(1,1,1,1) END IF - + ! ...Repeat for fractional clear-sky case + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + SfcOptics_Clear%Compute = .FALSE. + SfcOptics_Clear%Emissivity(1,1) = Opt%Emissivity(ln) + SfcOptics_Clear%Reflectivity(1,1,1,1) = ONE - Opt%Emissivity(ln) + IF ( Opt%Use_Direct_Reflectivity ) THEN + SfcOptics_Clear%Direct_Reflectivity(1,1) = Opt%Direct_Reflectivity(ln) + ELSE + SfcOptics_Clear%Direct_Reflectivity(1,1) = SfcOptics%Reflectivity(1,1,1,1) + END IF + END IF END IF @@ -869,8 +961,6 @@ FUNCTION CRTM_K_Matrix( & ! mth_Azi = 0 is for an azimuth-averaged value (IR, MW) ! ...Initialise radiance RTSolution(ln,m)%Radiance = ZERO - ! ...Initialise K-matrix atmospheric optics - CALL CRTM_AtmOptics_Zero( AtmOptics_K ) @@ -907,51 +997,105 @@ FUNCTION CRTM_K_Matrix( & RETURN END IF - ! Compute non-LTE correction to radiance if required - IF ( Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) & - CALL Compute_NLTE_Correction( & - SC(SensorIndex)%NC , & ! Input - ChannelIndex , & ! Input - NLTE_Predictor , & ! Input - RTSolution(ln,m)%Radiance ) ! In/Output - - ! Convert the radiance to brightness temperature - CALL CRTM_Planck_Temperature( & - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m)%Radiance , & ! Input - RTSolution(ln,m)%Brightness_Temperature ) ! Output - - ! Compute Antenna correction to brightness temperature if required - IF ( Compute_AntCorr ) THEN - CALL CRTM_Compute_AntCorr( & - GeometryInfo , & ! Input - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m) ) ! Output - CALL CRTM_Compute_AntCorr_AD( & - GeometryInfo , & ! Input - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution_K(ln,m) ) ! Output + + ! Perform clear sky calcs for fractionally cloudy atmospheres + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + + ! Repeat radiative transfer for clear-sky + RTV_Clear%mth_Azi = RTV%mth_Azi + SfcOptics_Clear%mth_Azi = SfcOptics%mth_Azi + Error_Status = CRTM_Compute_RTSolution( & + Atm_Clear , & ! Input + Surface(m) , & ! Input + AtmOptics_Clear , & ! Input + SfcOptics_Clear , & ! Input + GeometryInfo , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + RTSolution_Clear, & ! Output + RTV_Clear ) ! Internal variable output + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'( "Error computing CLEAR SKY RTSolution for ", a, & + &", channel ", i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + + ! Combine cloudy and clear radiances for fractional cloud coverage + r_cloudy = RTSolution(ln,m)%Radiance ! Save the 100% cloudy radiance + RTSolution(ln,m)%Radiance = & + ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_Clear%Radiance) + & + (CloudCover%Total_Cloud_Cover * RTSolution(ln,m)%Radiance) + ! ...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)) + + + ! Perform clear-sky post and pre-processing + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + ! Radiance post-processing + CALL Post_Process_RTSolution(RTSolution_Clear) + RTSolution(ln,m)%R_Clear = RTSolution_Clear%Radiance + RTSolution(ln,m)%Tb_Clear = RTSolution_Clear%Brightness_Temperature + + ! Adjoint radiance pre-processing + RTSolution_Clear_K%Brightness_Temperature = RTSolution_Clear_K%Brightness_Temperature + & + RTSolution_K(ln,m)%Tb_Clear + RTSolution_K(ln,m)%Tb_Clear = ZERO + RTSolution_Clear_K%Radiance = RTSolution_Clear_K%Radiance + & + RTSolution_K(ln,m)%R_Clear + RTSolution_K(ln,m)%R_Clear = ZERO + CALL Pre_Process_RTSolution_K(RTSolution_Clear, RTSolution_Clear_K) + END IF + + + ! The adjoint radiance pre-processing + CALL Pre_Process_RTSolution_K(RTSolution(ln,m), RTSolution_K(ln,m)) + + + ! More fractionally cloudy atmospheres processing + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + + ! The adjoint of the clear and cloudy radiance combination + CloudCover_K%Total_Cloud_Cover = CloudCover_K%Total_Cloud_Cover + & + RTSolution_K(ln,m)%Total_Cloud_Cover + RTSolution_K(ln,m)%Total_Cloud_Cover = ZERO + RTSolution_Clear_K%Radiance = RTSolution_Clear_K%Radiance + & + ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_K(ln,m)%Radiance) + CloudCover_K%Total_Cloud_Cover = CloudCover_K%Total_Cloud_Cover + & + ((r_cloudy - RTSolution_Clear%Radiance) * RTSolution_K(ln,m)%Radiance) + RTSolution_K(ln,m)%Radiance = CloudCover%Total_Cloud_Cover * RTSolution_K(ln,m)%Radiance + + ! The adjoint of the clear sky radiative transfer for fractionally cloudy atmospheres + Error_Status = CRTM_Compute_RTSolution_AD( & + Atm_Clear , & ! FWD Input + Surface(m) , & ! FWD Input + AtmOptics_Clear , & ! FWD Input + SfcOptics_Clear , & ! FWD Input + RTSolution_Clear , & ! FWD Input + RTSolution_Clear_K, & ! K Input + GeometryInfo , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + Atm_Clear_K , & ! K Output + Surface_K(ln,m) , & ! K Output + AtmOptics_Clear_K , & ! K Output + SfcOptics_Clear_K , & ! K Output + RTV_Clear ) ! Internal variable input + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'( "Error computing CLEAR SKY RTSolution_K for ", a, & + &", channel ", i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF END IF - ! Compute the Planck temperature adjoijnt - CALL CRTM_Planck_Temperature_AD( & - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m)%Radiance , & ! Input - RTSolution_K(ln,m)%Brightness_Temperature, & ! Input - RTSolution_K(ln,m)%Radiance ) ! Output - RTSolution_K(ln,m)%Brightness_Temperature = ZERO - - ! Compute non-LTE correction adjoint if required - IF ( Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) & - CALL Compute_NLTE_Correction_AD( & - SC(SensorIndex)%NC , & ! Input - ChannelIndex , & ! Input - RTSolution_K(ln,m)%Radiance, & ! Input - NLTE_Predictor_K ) ! Output ! The adjoint of the radiative transfer Error_Status = CRTM_Compute_RTSolution_AD( & @@ -1008,6 +1152,100 @@ FUNCTION CRTM_K_Matrix( & RETURN END IF + + ! Repeat clear sky for fractionally cloudy atmospheres + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTV_Clear%mth_Azi = RTV%mth_Azi + SfcOptics_Clear%mth_Azi = SfcOptics%mth_Azi + Error_Status = CRTM_Compute_RTSolution( & + Atm_Clear , & ! Input + Surface(m) , & ! Input + AtmOptics_Clear , & ! Input + SfcOptics_Clear , & ! Input + GeometryInfo , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + RTSolution_Clear, & ! Output + RTV_Clear ) ! Internal variable output + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'( "Error computing CLEAR SKY RTSolution for ", a, & + &", channel ", i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + END DO Azimuth_Fourier_Loop + + + ! All of the "in-between" FWD and AD processing is for fractional cloud coverage only + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + + ! FORWARD #1: Combine cloudy and clear radiances for fractional cloud coverage + r_cloudy = RTSolution(ln,m)%Radiance ! Save the 100% cloudy radiance + RTSolution(ln,m)%Radiance = & + ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_Clear%Radiance) + & + (CloudCover%Total_Cloud_Cover * RTSolution(ln,m)%Radiance) + ! FORWARD #2: Save the cloud cover and clear radiance in the output structure + RTSolution(ln,m)%Total_Cloud_Cover = CloudCover%Total_Cloud_Cover + RTSolution(ln,m)%R_Clear = RTSolution_Clear%Radiance + RTSolution(ln,m)%Tb_Clear = ZERO ! No Tb for visible + + ! ADJOINT #2: Of the cloud cover and clear radiance saving + RTSolution_Clear_K%Tb_Clear = ZERO ! No Tb for visible + RTSolution_Clear_K%Radiance = RTSolution_Clear_K%Radiance + & + RTSolution_K(ln,m)%R_Clear + RTSolution_K(ln,m)%R_Clear = ZERO + CloudCover_K%Total_Cloud_Cover = CloudCover_K%Total_Cloud_Cover + & + RTSolution_K(ln,m)%Total_Cloud_Cover + RTSolution_K(ln,m)%Total_Cloud_Cover = ZERO + + ! ADJOINT #1: Of the clear+cloudy combination + RTSolution_Clear_K%Radiance = RTSolution_Clear_K%Radiance + & + ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_K(ln,m)%Radiance) + CloudCover_K%Total_Cloud_Cover = CloudCover_K%Total_Cloud_Cover + & + ((r_cloudy - RTSolution_Clear%Radiance) * RTSolution_K(ln,m)%Radiance) + RTSolution_K(ln,m)%Radiance = CloudCover%Total_Cloud_Cover * RTSolution_K(ln,m)%Radiance + END IF + + + ! Adjoint Fourier expansion over azimuth angle + Azimuth_Fourier_Loop_K: DO mth_Azi = 0, RTV%n_Azi + + ! Set dependent component counters + RTV%mth_Azi = mth_Azi + SfcOptics%mth_Azi = mth_Azi + + + ! The adjoint of the clear sky radiative transfer for fractionally cloudy atmospheres + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTV_Clear%mth_Azi = RTV%mth_Azi + SfcOptics_Clear%mth_Azi = SfcOptics%mth_Azi + Error_Status = CRTM_Compute_RTSolution_AD( & + Atm_Clear , & ! FWD Input + Surface(m) , & ! FWD Input + AtmOptics_Clear , & ! FWD Input + SfcOptics_Clear , & ! FWD Input + RTSolution_Clear , & ! FWD Input + RTSolution_Clear_K, & ! AD Input + GeometryInfo , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + Atm_Clear_K , & ! AD Output + Surface_K(ln,m) , & ! AD Output + AtmOptics_Clear_K , & ! AD Output + SfcOptics_Clear_K , & ! AD Output + RTV_Clear ) ! Internal variable input + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'( "Error computing CLEAR SKY RTSolution_AD for ", a, & + &", channel ", i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + + ! The adjoint of the radiative transfer Error_Status = CRTM_Compute_RTSolution_AD( & Atm , & ! FWD Input @@ -1031,14 +1269,7 @@ FUNCTION CRTM_K_Matrix( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF - END DO Azimuth_Fourier_Loop - - ! Still want to convert the final FORWARD radiance to brightness temperature - CALL CRTM_Planck_Temperature( & - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m)%Radiance , & ! Input - RTSolution(ln,m)%Brightness_Temperature ) ! Output + END DO Azimuth_Fourier_Loop_K END IF Sensor_Dependent_RTSolution ! ################################################### @@ -1046,9 +1277,25 @@ FUNCTION CRTM_K_Matrix( & ! ################################################### + ! Compute the adjoint of the all-sky atmospheric transmittance + ! for use in FASTEM-X reflection correction + transmittance_K = SfcOptics_K%transmittance + SfcOptics_K%transmittance = ZERO + CALL CRTM_Compute_Transmittance_AD(AtmOptics,transmittance_K,AtmOptics_K) + ! ...Clear sky for fractional cloud cover + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + transmittance_clear_K = SfcOptics_Clear_K%transmittance + SfcOptics_Clear_K%transmittance = ZERO + CALL CRTM_Compute_Transmittance_AD(AtmOptics_Clear,transmittance_clear_K,AtmOptics_Clear_K) + END IF + + ! Compute the adjoint of the combined atmospheric optical properties + AtmOptics_K%Scattering_Optical_Depth = AtmOptics_K%Scattering_Optical_Depth + & + RTSolution_K(ln,m)%SOD + RTSolution_K(ln,m)%SOD = ZERO IF( AtmOptics%Include_Scattering ) THEN - CALL CRTM_Combine_AtmOptics_AD( AtmOptics, AtmOptics_K, AOvar ) + CALL CRTM_AtmOptics_Combine_AD( AtmOptics, AtmOptics_K, AOvar ) END IF @@ -1090,6 +1337,19 @@ FUNCTION CRTM_K_Matrix( & END IF + ! Adjoint of clear-sky AtmOptics copy + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + Error_Status = CRTM_AtmOptics_NoScatterCopy_AD( AtmOptics, AtmOptics_Clear_K, AtmOptics_K ) + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'("Error computing CLEAR SKY AtmOptics_K for ",a,& + &", channel ",i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + + ! Compute the adjoint molecular scattering properties IF( RTV%Visible_Flag_true ) THEN Wavenumber = SC(SensorIndex)%Wavenumber(ChannelIndex) @@ -1109,14 +1369,6 @@ FUNCTION CRTM_K_Matrix( & END IF - ! Compute the adjoint of the total atmospheric transmittance - IF ( CRTM_No_Scattering(AtmOptics) .AND. SpcCoeff_IsMicrowaveSensor(SC(SensorIndex)) ) THEN - transmittance_K = SfcOptics_K%transmittance - SfcOptics_K%transmittance = ZERO - CALL CRTM_Compute_Transmittance_AD(AtmOptics,transmittance_K,AtmOptics_K) - END IF - - ! Compute the adjoint gaseous absorption CALL CRTM_Compute_AtmAbsorption_AD( SensorIndex , & ! Input ChannelIndex, & ! Input @@ -1133,7 +1385,7 @@ FUNCTION CRTM_K_Matrix( & ! K-matrix of the NLTE correction predictor calculations - IF ( Apply_NLTE_Correction ) THEN + IF ( Opt%Apply_NLTE_Correction ) THEN CALL Compute_NLTE_Predictor_AD( & NLTE_Predictor , & ! Input NLTE_Predictor_K , & ! Input @@ -1151,44 +1403,167 @@ FUNCTION CRTM_K_Matrix( & PVar ) ! Internal variable input - ! Postprocess some input data - ! ...K-matrix of average surface skin temperature for multi-surface types + ! K-matrix of average surface skin temperature for multi-surface types CALL CRTM_Compute_SurfaceT_AD( Surface(m), SfcOptics_K, Surface_K(ln,m) ) - ! ...K-matrix of the atmosphere layer addition + + + ! Adjoint of cloud cover setup + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + + ! Post process the CLEAR sky structures for fractional cloud coverage + ! ...Clear sky SfcOptics + CALL CRTM_Compute_SurfaceT_AD( Surface(m), SfcOptics_Clear_K, Surface_K(ln,m) ) + CALL CRTM_SfcOptics_Zero(SfcOptics_Clear_K) + ! ...Clear sky atmosphere + Error_Status = CRTM_Atmosphere_ClearSkyCopy_AD(Atm, Atm_Clear_K, Atm_K) + IF ( Error_Status /= SUCCESS ) THEN + Error_status = FAILURE + WRITE( Message,'("Error computing CLEAR SKY Atm_K object for ",a,& + &", channel ",i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), & + ChannelInfo(n)%Sensor_Channel(l), & + m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + + ! K-matrix of the cloud coverage + Error_Status = CloudCover_K%Compute_CloudCover_AD(CloudCover, atm, atm_K) + IF ( Error_Status /= SUCCESS ) THEN + Error_Status = FAILURE + WRITE( Message,'("Error computing K-MATRIX cloud cover for ",a,& + &", channel ",i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), & + ChannelInfo(n)%Sensor_Channel(l), & + m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + + + ! K-matrix of the atmosphere layer addition Error_Status = CRTM_Atmosphere_AddLayers_AD( Atmosphere(m), Atm_K, Atmosphere_K(ln,m) ) IF ( Error_Status /= SUCCESS ) THEN Error_Status = FAILURE - WRITE( Message,'("Error adding AD extra layers to profile #",i0)' ) m + WRITE( Message,'("Error computing K-MATRIX atmosphere extra layers for ",a,& + &", channel ",i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), & + ChannelInfo(n)%Sensor_Channel(l), & + m CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF - + END DO Channel_Loop - - ! Deallocate local sensor dependent data structures - ! ...RTV structure - IF ( RTV_Associated(RTV) ) CALL RTV_Destroy(RTV) - ! ...Predictor structures - CALL CRTM_Predictor_Destroy( Predictor ) - CALL CRTM_Predictor_Destroy( Predictor_K ) - END DO Sensor_Loop - - ! Deallocate local sensor independent data structures - ! ...Atmospheric optics - CALL CRTM_AtmOptics_Destroy( AtmOptics ) - CALL CRTM_AtmOptics_Destroy( AtmOptics_K ) - END DO Profile_Loop - ! Destroy any remaining structures + ! Clean up + CALL CRTM_Predictor_Destroy( Predictor ) + CALL CRTM_Predictor_Destroy( Predictor_K ) + CALL CRTM_AtmOptics_Destroy( AtmOptics ) + CALL CRTM_AtmOptics_Destroy( AtmOptics_K ) + CALL CRTM_AtmOptics_Destroy( AtmOptics_Clear ) + CALL CRTM_AtmOptics_Destroy( AtmOptics_Clear_K ) CALL CRTM_SfcOptics_Destroy( SfcOptics ) CALL CRTM_SfcOptics_Destroy( SfcOptics_K ) - CALL CRTM_Atmosphere_Destroy( Atm_K ) + CALL CRTM_SfcOptics_Destroy( SfcOptics_Clear ) + CALL CRTM_SfcOptics_Destroy( SfcOptics_Clear_K ) CALL CRTM_Atmosphere_Destroy( Atm ) + CALL CRTM_Atmosphere_Destroy( Atm_K ) + CALL CRTM_Atmosphere_Destroy( Atm_Clear ) + CALL CRTM_Atmosphere_Destroy( Atm_Clear_K ) + ! ...Internal variables + CALL AOvar_Destroy( AOvar ) + CALL CSvar_Destroy( CSvar ) + CALL ASvar_Destroy( ASvar ) + CALL RTV_Destroy( RTV ) + + + +CONTAINS + + + ! ---------------------------------------------------------------- + ! Local subroutine to post-process the FORWARD radiance, as it is + ! the same for all-sky and fractional clear-sky cases. + ! + ! 1. Apply non-LTE correction to radiance + ! 2. Convert radiance to brightness temperature + ! 3. Apply antenna correction to brightness temperature + ! ---------------------------------------------------------------- + + SUBROUTINE Post_Process_RTSolution(rts) + TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: rts + + ! Compute non-LTE correction to radiance if required + IF ( Opt%Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) THEN + CALL Compute_NLTE_Correction( & + SC(SensorIndex)%NC, & ! Input + ChannelIndex , & ! Input + NLTE_Predictor , & ! Input + rts%Radiance ) ! In/Output + END IF + ! Convert the radiance to brightness temperature + CALL CRTM_Planck_Temperature( & + SensorIndex , & ! Input + ChannelIndex , & ! Input + rts%Radiance , & ! Input + rts%Brightness_Temperature ) ! Output + ! Compute Antenna correction to brightness temperature if required + IF ( compute_antenna_correction ) THEN + CALL CRTM_Compute_AntCorr( & + GeometryInfo, & ! Input + SensorIndex , & ! Input + ChannelIndex, & ! Input + rts ) ! Output + END IF + + END SUBROUTINE Post_Process_RTSolution + + + ! ---------------------------------------------------------------- + ! Local subroutine to pre-process the K-MATRIX radiance, as it is + ! the same for all-sky and fractional clear-sky cases. + ! + ! 1. Apply adjoint antenna correction to brightness temperatures + ! 2. Convert adjoint radiances to brightness temperatures + ! 3. Apply adjoint non-LTE correction to radiances + ! ---------------------------------------------------------------- + + SUBROUTINE Pre_Process_RTSolution_K(rts, rts_K) + TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: rts, rts_K + + ! Compute adjoint antenna correction to brightness temperature if required + IF ( compute_antenna_correction ) THEN + CALL CRTM_Compute_AntCorr_AD( & + GeometryInfo, & ! Input + SensorIndex , & ! Input + ChannelIndex, & ! Input + rts_K ) ! Output + END IF + ! Compute the Planck temperature adjoint + CALL CRTM_Planck_Temperature_AD( & + SensorIndex , & ! Input + ChannelIndex , & ! Input + rts%Radiance , & ! Input + rts_K%Brightness_Temperature, & ! Input + rts_K%Radiance ) ! Output + rts_K%Brightness_Temperature = ZERO + ! Compute non-LTE correction adjoint if required + IF ( Opt%Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) THEN + CALL Compute_NLTE_Correction_AD( & + SC(SensorIndex)%NC, & ! Input + ChannelIndex , & ! Input + rts_K%Radiance , & ! Input + NLTE_Predictor_K ) ! Output + END IF + + END SUBROUTINE Pre_Process_RTSolution_K END FUNCTION CRTM_K_Matrix diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_LifeCycle.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_LifeCycle.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_LifeCycle.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_LifeCycle.f90 index 1c6bb60240..a580a44598 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_LifeCycle.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_LifeCycle.f90 @@ -76,7 +76,7 @@ MODULE CRTM_LifeCycle ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_LifeCycle.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_LifeCycle.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! String lengths INTEGER, PARAMETER :: ML = 256 ! Error message length INTEGER, PARAMETER :: SL = 5000 ! Maximum length for path+filenames diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_LowFrequency_MWSSEM.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_LowFrequency_MWSSEM.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_LowFrequency_MWSSEM.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_LowFrequency_MWSSEM.f90 index 190c8cce72..0dc24d5234 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_LowFrequency_MWSSEM.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_LowFrequency_MWSSEM.f90 @@ -68,7 +68,7 @@ MODULE CRTM_LowFrequency_MWSSEM ! ----------------- ! RCS Id for the module CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: CRTM_LowFrequency_MWSSEM.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_LowFrequency_MWSSEM.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Various quantities REAL(fp), PARAMETER :: LOW_F_THRESHOLD = 20.0_fp ! Frequency threshold for permittivity models(GHz) diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_MW_Ice_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_MW_Ice_SfcOptics.f90 similarity index 93% rename from var/external/crtm_2.2.3/libsrc/CRTM_MW_Ice_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_MW_Ice_SfcOptics.f90 index abb789325d..609939d1ed 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_MW_Ice_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_MW_Ice_SfcOptics.f90 @@ -38,13 +38,16 @@ MODULE CRTM_MW_Ice_SfcOptics WMO_SSMI , & WMO_MSU , & WMO_MHS , & - WMO_SSMIS + WMO_SSMIS, & + WMO_ATMS USE NESDIS_AMSU_SICEEM_Module, ONLY: NESDIS_ICEEM_AMSU USE NESDIS_AMSRE_SICEEM_Module, ONLY: NESDIS_AMSRE_SSICEEM USE NESDIS_SSMI_SICEEM_Module, ONLY: NESDIS_SSMI_SIceEM USE NESDIS_SEAICE_PHYEM_Module, ONLY: NESDIS_SIce_Phy_EM USE NESDIS_MHS_SICEEM_Module, ONLY: NESDIS_ICEEM_MHS USE NESDIS_SSMIS_SeaIceEM_Module, ONLY: NESDIS_SSMIS_IceEM + USE NESDIS_ATMS_SeaICE_Module, ONLY: NESDIS_ATMS_SeaICE + ! Disable implicit typing IMPLICIT NONE @@ -66,7 +69,7 @@ MODULE CRTM_MW_Ice_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_MW_Ice_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_MW_Ice_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! -------------------------------------- @@ -185,6 +188,7 @@ FUNCTION Compute_MW_Ice_SfcOptics( & INTEGER, PARAMETER :: AMSRE_H_INDEX(6) = (/2, 4, 6, 8, 10, 12/) ! AMSRE channels with H pol. INTEGER, PARAMETER :: AMSUA_INDEX(4) = (/1, 2, 3, 15/) INTEGER, PARAMETER :: SSMIS_INDEX(8) = (/13,12,14,16,15,17,18,8/) ! With swapped polarisations + INTEGER, PARAMETER :: ATMS_INDEX(5) = (/1, 2, 3, 16,17/) ! With mixed polarisations ! Local variables INTEGER :: i REAL(fp) :: Sensor_Zenith_Angle @@ -197,6 +201,18 @@ FUNCTION Compute_MW_Ice_SfcOptics( & ! Compute the surface emissivities Sensor_Type: SELECT CASE( Surface%SensorData%WMO_Sensor_ID ) + ! ATMSemissivity model + CASE( WMO_ATMS ) + DO i = 1, SfcOptics%n_Angles + CALL NESDIS_ATMS_SeaICE( Sensor_Zenith_Angle, & ! Input, Degree + SfcOptics%Angle(i), & ! Input, Degree + SC(SensorIndex)%Frequency(ChannelIndex), & ! Input, GHz + Surface%Ice_Temperature, & ! Input, K + Surface%SensorData%Tb(ATMS_INDEX), & ! Input, ATMS + SfcOptics%Emissivity(i,2), & ! Output, H component + SfcOptics%Emissivity(i,1) ) ! Output, V component + END DO + ! AMSU-A emissivity model CASE( WMO_AMSUA ) diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_MW_Land_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_MW_Land_SfcOptics.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_MW_Land_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_MW_Land_SfcOptics.f90 index 92bb3590ce..077a3cd863 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_MW_Land_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_MW_Land_SfcOptics.f90 @@ -50,7 +50,7 @@ MODULE CRTM_MW_Land_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_MW_Land_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_MW_Land_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message length INTEGER, PARAMETER :: ML = 256 ! Valid type indices for the microwave land emissivity model diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_MW_Snow_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_MW_Snow_SfcOptics.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_MW_Snow_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_MW_Snow_SfcOptics.f90 index 343d5db81d..3816deb703 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_MW_Snow_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_MW_Snow_SfcOptics.f90 @@ -69,7 +69,7 @@ MODULE CRTM_MW_Snow_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_MW_Snow_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_MW_Snow_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! -------------------------------------- diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_MW_Water_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_MW_Water_SfcOptics.f90 similarity index 97% rename from var/external/crtm_2.2.3/libsrc/CRTM_MW_Water_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_MW_Water_SfcOptics.f90 index 2be7baed00..bd2f0d20df 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_MW_Water_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_MW_Water_SfcOptics.f90 @@ -64,7 +64,7 @@ MODULE CRTM_MW_Water_SfcOptics ! ----------------- ! RCS Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_MW_Water_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_MW_Water_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Low frequency model threshold REAL(fp), PARAMETER :: LOW_F_THRESHOLD = 20.0_fp ! GHz @@ -76,9 +76,9 @@ MODULE CRTM_MW_Water_SfcOptics TYPE :: iVar_type PRIVATE ! FastemX model internal variable structure - TYPE(FastemX_type) :: FastemX_Var + TYPE(FastemX_type), DIMENSION(MAX_N_ANGLES) :: FastemX_Var ! Low frequency model internal variable structure - TYPE(LF_MWSSEM_type) :: LF_MWSSEM_Var + TYPE(LF_MWSSEM_type), DIMENSION(MAX_N_ANGLES) :: LF_MWSSEM_Var ! Fastem outputs REAL(fp), DIMENSION(MAX_N_ANGLES) :: dEH_dTs = ZERO REAL(fp), DIMENSION(MAX_N_ANGLES) :: dEH_dWindSpeed = ZERO @@ -193,7 +193,7 @@ FUNCTION Compute_MW_Water_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 :: err_stat ! Local parameters @@ -225,11 +225,12 @@ FUNCTION Compute_MW_Water_SfcOptics( & CALL Compute_FastemX( & MWwaterC , & ! Input model coefficients Frequency , & ! Input + SfcOptics%n_Angles , & ! Input SfcOptics%Angle(i) , & ! Input Surface%Water_Temperature , & ! Input Surface%Salinity , & ! Input Surface%Wind_Speed , & ! Input - iVar%FastemX_Var , & ! Internal variable output + iVar%FastemX_Var(i) , & ! Internal variable output SfcOptics%Emissivity(i,:) , & ! Output Reflectivity , & ! Output Azimuth_Angle = SfcOptics%Azimuth_Angle, & ! Optional input @@ -252,7 +253,7 @@ FUNCTION Compute_MW_Water_SfcOptics( & Surface%Salinity , & ! Input Surface%Wind_Speed , & ! Input SfcOptics%Emissivity(i,:), & ! Output - iVar%LF_MWSSEM_Var ) ! Internal variable output + iVar%LF_MWSSEM_Var(i) ) ! Internal variable output SfcOptics%Reflectivity(i,1,i,1) = ONE-SfcOptics%Emissivity(i,1) SfcOptics%Reflectivity(i,2,i,2) = ONE-SfcOptics%Emissivity(i,2) END DO @@ -431,12 +432,14 @@ FUNCTION Compute_MW_Water_SfcOptics_TL( & Surface_TL%Water_Temperature , & ! TL Input Surface_TL%Salinity , & ! TL Input Surface_TL%Wind_Speed , & ! TL Input - iVar%FastemX_Var , & ! Internal variable input + iVar%FastemX_Var(i) , & ! Internal variable input SfcOptics_TL%Emissivity(i,:) , & ! TL Output Reflectivity_TL , & ! TL Output Azimuth_Angle_TL = Surface_TL%Wind_Direction, & ! Optional TL input Transmittance_TL = SfcOptics_TL%Transmittance ) ! Optional TL input DO j = 1, N_STOKES + !we probably need further low-level check and modifications + !SfcOptics_TL%Reflectivity(i,j,i,j) = -Reflectivity_TL(j) SfcOptics_TL%Reflectivity(i,j,i,j) = Reflectivity_TL(j) END DO END DO @@ -452,7 +455,7 @@ FUNCTION Compute_MW_Water_SfcOptics_TL( & Surface_TL%Salinity , & ! TL Input Surface_TL%Wind_Speed , & ! TL Input SfcOptics_TL%Emissivity(i,:), & ! TL Output - iVar%LF_MWSSEM_Var ) ! Internal variable input + iVar%LF_MWSSEM_Var(i) ) ! Internal variable input SfcOptics_TL%Reflectivity(i,1,i,1) = -SfcOptics_TL%Emissivity(i,1) SfcOptics_TL%Reflectivity(i,2,i,2) = -SfcOptics_TL%Emissivity(i,2) END DO @@ -632,7 +635,7 @@ FUNCTION Compute_MW_Water_SfcOptics_AD( & MWwaterC , & ! Input model coefficients SfcOptics_AD%Emissivity(i,:) , & ! AD Input Reflectivity_ad , & ! AD Input - iVar%FastemX_Var , & ! Internal variable input + iVar%FastemX_Var(i) , & ! Internal variable input Surface_AD%Water_Temperature , & ! AD Output Surface_AD%Salinity , & ! AD Output Surface_AD%Wind_Speed , & ! AD Output @@ -654,7 +657,7 @@ FUNCTION Compute_MW_Water_SfcOptics_AD( & Surface_AD%Water_Temperature, & ! AD Output Surface_AD%Salinity , & ! AD Output Surface_AD%Wind_Speed , & ! AD Output - iVar%LF_MWSSEM_Var ) ! Internal variable input + iVar%LF_MWSSEM_Var(i) ) ! Internal variable input END DO ELSE ! Call Fastem1 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_MWwaterCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_MWwaterCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_MWwaterCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_MWwaterCoeff.f90 index eea76ec9ed..ac07eb7cbf 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_MWwaterCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_MWwaterCoeff.f90 @@ -53,7 +53,7 @@ MODULE CRTM_MWwaterCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_MWwaterCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_MWwaterCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 512 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Model_Profiles.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Model_Profiles.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_Model_Profiles.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Model_Profiles.f90 index f1d808dbf0..1fb0238071 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Model_Profiles.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Model_Profiles.f90 @@ -47,7 +47,7 @@ MODULE CRTM_Model_Profiles ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: CRTM_Model_Profiles.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Model_Profiles.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Model dimension info INTEGER, PARAMETER :: N_MODEL_LEVELS = 101 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Module.fpp b/var/external/crtm_2.3.0/libsrc/CRTM_Module.fpp similarity index 95% rename from var/external/crtm_2.2.3/libsrc/CRTM_Module.fpp rename to var/external/crtm_2.3.0/libsrc/CRTM_Module.fpp index 664aeff0af..c6be595269 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Module.fpp +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Module.fpp @@ -45,7 +45,7 @@ MODULE CRTM_Module ! Module parameters ! ----------------- CHARACTER(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Module.fpp 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Module.fpp 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CHARACTER(*), PRIVATE, PARAMETER :: CRTM_VERSION_ID = & #include "CRTM_Version.inc" diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_MoleculeScatter.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_MoleculeScatter.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_MoleculeScatter.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_MoleculeScatter.f90 index e6706166f8..23d8747ab2 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_MoleculeScatter.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_MoleculeScatter.f90 @@ -38,7 +38,7 @@ MODULE CRTM_MoleculeScatter ! ----------------- ! RCS Id for the module CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: CRTM_MoleculeScatter.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_MoleculeScatter.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Rayleigh factor REAL(fp), PARAMETER :: RFACTOR = 27.0363_fp ! = 287.0/9.8*923.1907/1000.0 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_NLTECorrection.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_NLTECorrection.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_NLTECorrection.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_NLTECorrection.f90 index 64ed4bf905..eeaf58034a 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_NLTECorrection.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_NLTECorrection.f90 @@ -52,7 +52,7 @@ MODULE CRTM_NLTECorrection ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_NLTECorrection.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_NLTECorrection.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Options_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Options_Define.f90 similarity index 67% rename from var/external/crtm_2.2.3/libsrc/CRTM_Options_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Options_Define.f90 index ee3b4141d7..9775512406 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Options_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Options_Define.f90 @@ -25,7 +25,8 @@ MODULE CRTM_Options_Define ReadGAtts_Binary_File , & WriteLogical_Binary_File, & ReadLogical_Binary_File - USE CRTM_Parameters , ONLY: RT_ADA + USE CRTM_Parameters , ONLY: RT_ADA, RT_SOI, & + MAX_N_STREAMS USE SSU_Input_Define , ONLY: SSU_Input_type, & OPERATOR(==), & SSU_Input_IsValid, & @@ -42,6 +43,14 @@ MODULE CRTM_Options_Define Zeeman_Input_SetValue, & Zeeman_Input_ReadFile, & Zeeman_Input_WriteFile + USE CRTM_CloudCover_Define, ONLY: DEFAULT_OVERLAP_ID, & + CloudCover_Maximum_Overlap, & + CloudCover_Random_Overlap , & + CloudCover_MaxRan_Overlap , & + CloudCover_Average_Overlap, & + CloudCover_Overcast_Overlap, & + CloudCover_Overlap_IsValid, & + CloudCover_Overlap_Name ! Disable implicit typing IMPLICIT NONE @@ -53,6 +62,9 @@ MODULE CRTM_Options_Define PRIVATE ! Datatypes PUBLIC :: CRTM_Options_type + ! ...Inherited types + PUBLIC :: SSU_Input_type + PUBLIC :: Zeeman_Input_type ! Operators PUBLIC :: OPERATOR(==) ! Public procedures @@ -62,20 +74,27 @@ MODULE CRTM_Options_Define PUBLIC :: CRTM_Options_IsValid PUBLIC :: CRTM_Options_Inspect PUBLIC :: CRTM_Options_DefineVersion + PUBLIC :: CRTM_Options_SetValue + PUBLIC :: CRTM_Options_SetEmissivity PUBLIC :: CRTM_Options_InquireFile PUBLIC :: CRTM_Options_ReadFile PUBLIC :: CRTM_Options_WriteFile ! ...Inherited procedures PUBLIC :: SSU_Input_GetValue PUBLIC :: SSU_Input_SetValue + PUBLIC :: Zeeman_Input_GetValue PUBLIC :: Zeeman_Input_SetValue - ! ------------------- ! Procedure overloads ! ------------------- + INTERFACE CRTM_Options_SetEmissivity + MODULE PROCEDURE SetEmissivity_scalar + MODULE PROCEDURE SetEmissivity_rank1 + END INTERFACE CRTM_Options_SetEmissivity + INTERFACE OPERATOR(==) MODULE PROCEDURE CRTM_Options_Equal END INTERFACE OPERATOR(==) @@ -85,7 +104,7 @@ MODULE CRTM_Options_Define ! Module parameters ! ----------------- CHARACTER(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Options_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Options_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(Double), PARAMETER :: ZERO = 0.0_Double REAL(Double), PARAMETER :: ONE = 1.0_Double @@ -133,6 +152,9 @@ MODULE CRTM_Options_Define ! Cloud/Aerosol scattering to be included. LOGICAL :: Include_Scattering = .TRUE. + ! Cloud cover overlap id is set to averaging type by default + INTEGER(Long) :: Overlap_Id = DEFAULT_OVERLAP_ID + ! User defined emissivity/reflectivity ! ...Dimensions INTEGER(Long) :: n_Channels = 0 ! L dimension @@ -150,6 +172,7 @@ MODULE CRTM_Options_Define ! Zeeman-splitting input TYPE(Zeeman_Input_type) :: Zeeman + END TYPE CRTM_Options_type !:tdoc-: @@ -165,6 +188,378 @@ MODULE CRTM_Options_Define !################################################################################ !################################################################################ +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_Options_SetValue +! +! PURPOSE: +! Elemental subroutine to set the values of the non-dimensional, +! non-contained-object CRTM_Options object components. +! +! CALLING SEQUENCE: +! CALL CRTM_Options_SetValue( & +! Options , & +! Check_Input = Check_Input , & +! Use_Old_MWSSEM = Use_Old_MWSSEM , & +! Use_Antenna_Correction = Use_Antenna_Correction , & +! Apply_NLTE_Correction = Apply_NLTE_Correction , & +! Set_ADA_RT = Set_ADA_RT , & +! Set_SOI_RT = Set_SOI_RT , & +! Include_Scattering = Include_Scattering , & +! Set_Maximum_Overlap = Set_Maximum_Overlap , & +! Set_Random_Overlap = Set_Random_Overlap , & +! Set_MaxRan_Overlap = Set_MaxRan_Overlap , & +! Set_Average_Overlap = Set_Average_Overlap , & +! Set_Overcast_Overlap = Set_Overcast_Overlap , & +! Use_Emissivity = Use_Emissivity , & +! Use_Direct_Reflectivity = Use_Direct_Reflectivity, & +! n_Streams = n_Streams , & +! Aircraft_Pressure = Aircraft_Pressure ) +! +! OBJECTS: +! Options: Options object for which the indicated component +! values are to be set. +! UNITS: N/A +! TYPE: CRTM_Options_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(IN OUT) +! +! OPTIONAL INPUTS: +! Check_Input: Set this logical argument to control checking of +! the CRTM input data. +! If == .TRUE. , the CRTM input data is checked [DEFAULT] +! == .FALSE., no input data checking is done. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Conformable with Options object +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Use_Old_MWSSEM: Set this logical argument to invoke the previous version +! of the microwave sea surface emissivity model. +! If == .TRUE. , the old model is used. +! == .FALSE., the current model is used [DEFAULT] +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Conformable with Options object +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Use_Antenna_Correction: Set this logical argument to apply an antenna correction +! to the computed brightness temperatures for certain +! microwave instruments (AMSU-A/B, MHS) +! If == .TRUE. , antenna correction is applied +! == .FALSE., no correction is applied [DEFAULT] +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Conformable with Options object +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Apply_NLTE_Correction: Set this logical argument to apply an non-LTE correction +! to shortwave infrared radiances. +! If == .TRUE. , non-LTE correction is applied [DEFAULT] +! == .FALSE., no correction is applied +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Conformable with Options object +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Set_ADA_RT: +! Set_SOI_RT: Set this logical argument to use the specified algorithm +! for scattering radiative transfer. +! If == .TRUE. , the corresponding RT algorithm is used. +! Note: - By default, the ADA algorithm is used. +! - If MORE THAN ONE argument is specified, the +! the default ADA algorithm is used. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Conformable with Options object +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Include_Scattering: Set this logical argument to control the inclusion of +! cloud and aerosol scattering in the radiative transfer. +! If == .TRUE. , scattering calculations are performed [DEFAULT] +! == .FALSE., only cloud/aerosol absorption is considered. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Conformable with Options object +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Set_Maximum_Overlap: +! Set_Random_Overlap: +! Set_MaxRan_Overlap: +! Set_Average_Overlap: Use these logical arguments to set the cloud overlap +! methodology for fractionally cloudy input profiles. +! If == .TRUE. , the corresponding overlap method is used. +! Note: - By default, the average overlap method is used. +! - If MORE THAN ONE overlap argument is specified, +! the default overlap method is used. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Conformable with Options object +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Use_Emissivity: Set this logical argument to control the use of the emissivity +! spectrum included in the object. +! If == .TRUE. , use the included emissivity spectrum +! == .FALSE., let the CRTM compute the emissivity spectrum +! Note: - This argument is ignored if the object does not +! contain any emissivity data +! - See the CRTM_Options_SetEmissivity() procedure for +! loading emissivity data into an Options object. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Conformable with Options object +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Use_Direct_Reflectivity: Set this logical argument to control the use of the direct +! reflectivity spectrum included in the object. +! If == .TRUE. , use the included direct reflectivity spectrum +! == .FALSE., let the CRTM compute the direct reflectivity spectrum +! Note: - This argument is ignored if the object does not +! contain any direct reflectivity data +! - See the CRTM_Options_SetEmissivity() procedure for +! loading direct relfectivity data into an Options object. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Conformable with Options object +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! n_Streams: Set this integer argument to the number of streams (up + down) +! to use in the radiative transfer solver for scattering +! atmospheres. +! By default, a channel-specific value is selected based +! on the Mie parameter. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Conformable with Options object +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Aircraft_Pressure: Set this real argument to aircraft pressure level to use +! for an aircraft instrument simulation. +! Note: This option has not been rigorously tested. +! UNITS: hPa +! TYPE: REAL(fp) +! DIMENSION: Conformable with Options object +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + ELEMENTAL SUBROUTINE CRTM_Options_SetValue( & + self , & + Check_Input , & + Use_Old_MWSSEM , & + Use_Antenna_Correction , & + Apply_NLTE_Correction , & + Set_ADA_RT , & + Set_SOI_RT , & + Include_Scattering , & + Set_Maximum_Overlap , & + Set_Random_Overlap , & + Set_MaxRan_Overlap , & + Set_Average_Overlap , & + Set_Overcast_Overlap , & + Use_Emissivity , & + Use_Direct_Reflectivity, & + n_Streams , & + Aircraft_Pressure ) + ! Arguments + TYPE(CRTM_Options_type), INTENT(IN OUT) :: self + LOGICAL , OPTIONAL, INTENT(IN) :: Check_Input + LOGICAL , OPTIONAL, INTENT(IN) :: Use_Old_MWSSEM + LOGICAL , OPTIONAL, INTENT(IN) :: Use_Antenna_Correction + LOGICAL , OPTIONAL, INTENT(IN) :: Apply_NLTE_Correction + LOGICAL , OPTIONAL, INTENT(IN) :: Set_ADA_RT + LOGICAL , OPTIONAL, INTENT(IN) :: Set_SOI_RT + LOGICAL , OPTIONAL, INTENT(IN) :: Include_Scattering + LOGICAL , OPTIONAL, INTENT(IN) :: Set_Maximum_Overlap + LOGICAL , OPTIONAL, INTENT(IN) :: Set_Random_Overlap + LOGICAL , OPTIONAL, INTENT(IN) :: Set_MaxRan_Overlap + LOGICAL , OPTIONAL, INTENT(IN) :: Set_Average_Overlap + LOGICAL , OPTIONAL, INTENT(IN) :: Set_Overcast_Overlap + LOGICAL , OPTIONAL, INTENT(IN) :: Use_Emissivity + LOGICAL , OPTIONAL, INTENT(IN) :: Use_Direct_Reflectivity + INTEGER , OPTIONAL, INTENT(IN) :: n_Streams + REAL(fp), OPTIONAL, INTENT(IN) :: Aircraft_Pressure + + ! Set the "direct copy" components + IF ( PRESENT(Check_Input ) ) self%Check_Input = Check_Input + IF ( PRESENT(Use_Old_MWSSEM ) ) self%Use_Old_MWSSEM = Use_Old_MWSSEM + IF ( PRESENT(Use_Antenna_Correction) ) self%Use_Antenna_Correction = Use_Antenna_Correction + IF ( PRESENT(Apply_NLTE_Correction ) ) self%Apply_NLTE_Correction = Apply_NLTE_Correction + IF ( PRESENT(Include_Scattering ) ) self%Include_Scattering = Include_Scattering + IF ( PRESENT(Aircraft_Pressure ) ) self%Aircraft_Pressure = Aircraft_Pressure + + ! Set the "minimal processing" components + IF ( PRESENT(n_Streams) ) THEN + self%Use_n_Streams = .TRUE. + self%n_Streams = n_Streams + END IF + + ! Only one RT algorithm allowed! + IF ( COUNT([PRESENT(Set_ADA_RT), PRESENT(Set_SOI_RT)]) > 1 ) THEN + self%RT_Algorithm_Id = RT_ADA + ELSE + IF ( PRESENT(Set_ADA_RT) ) self%RT_Algorithm_Id = RT_ADA + IF ( PRESENT(Set_SOI_RT) ) self%RT_Algorithm_Id = RT_SOI + END IF + + ! Only one overlap option allowed! + IF ( COUNT([PRESENT(Set_Maximum_Overlap), PRESENT(Set_Random_Overlap ), & + PRESENT(Set_MaxRan_Overlap ), PRESENT(Set_Average_Overlap), & + PRESENT(Set_Overcast_Overlap) ]) > 1 ) THEN + self%Overlap_Id = DEFAULT_OVERLAP_ID + ELSE + IF ( PRESENT(Set_Maximum_Overlap) ) self%Overlap_Id = CloudCover_Maximum_Overlap() + IF ( PRESENT(Set_Random_Overlap ) ) self%Overlap_Id = CloudCover_Random_Overlap() + IF ( PRESENT(Set_MaxRan_Overlap ) ) self%Overlap_Id = CloudCover_MaxRan_Overlap() + IF ( PRESENT(Set_Average_Overlap) ) self%Overlap_Id = CloudCover_Average_Overlap() + IF ( PRESENT(Set_Overcast_Overlap)) self%Overlap_Id = CloudCover_Overcast_Overlap() + END IF + + ! The emissivity and reflectivity spectra + IF ( PRESENT(Use_Emissivity) ) & + self%Use_Emissivity = Use_Emissivity .AND. self%Is_Allocated + + IF ( PRESENT(Use_Direct_Reflectivity) ) & + self%Use_Direct_Reflectivity = Use_Direct_Reflectivity .AND. self%Is_Allocated + + END SUBROUTINE CRTM_Options_SetValue + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_Options_SetEmissivity +! +! PURPOSE: +! Subroutine to set the values of the emissivity and direct reflectivity +! spectra in a CRTM_Options object. +! +! This procedure also sets the usage flags for the emissivity and direct +! reflectivity after successful assignment. See also the CRTM_Options_SetValue() +! procedure. +! +! CALLING SEQUENCE: +! CALL CRTM_Options_SetEmissivity( & +! Options , & +! Emissivity , & +! Direct_Reflectivity = Direct_Reflectivity ) +! +! OBJECTS: +! Options: Options object for which the emissivity and +! direct reflectivity are to be set. +! values are to be set. +! UNITS: N/A +! TYPE: CRTM_Options_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! Emissivity: Emissivity scalar value or spectrum array. +! If SCALAR: - The Options object MUST already be allocated. +! - The scalar value is applied to every element +! of the object emissivity array. +! RANK-1: - The object emissivity array is (re)allocated +! as necessary. +! UNITS: N/A +! TYPE: REAL(fp) +! DIMENSION: Scalar or Rank-1 +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! Direct_Reflectivity: Direct reflectivity scalar value or spectrum array. +! If SCALAR: - The Options object MUST already be allocated. +! - The scalar value is applied to every element +! of the object direct reflectivity array. +! RANK-1: - The array size must be the same as the +! input emissivity array. If not, the +! object direct reflectivity array is +! (re)allocated and set to zero. +! UNITS: N/A +! TYPE: REAL(fp) +! DIMENSION: Same as Emissivity argument +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE SetEmissivity_scalar( & + self , & + Emissivity, & + Direct_Reflectivity) + ! Arguments + TYPE(CRTM_Options_type), INTENT(IN OUT) :: self + REAL(fp), INTENT(IN) :: Emissivity + REAL(fp), OPTIONAL, INTENT(IN) :: Direct_Reflectivity + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Options_SetEmissivity(Scalar)' + ! Local variables + CHARACTER(ML) :: msg + + ! Setup + self%Use_Emissivity = .FALSE. ! Turn it off + self%Use_Direct_Reflectivity = .FALSE. ! Turn it off + IF ( .NOT. CRTM_Options_Associated(self) ) THEN + msg = 'Options object not allocated. Disabling emissivity/direct reflectivity' + CALL Display_Message( ROUTINE_NAME, msg, FAILURE ) + RETURN + END IF + + ! Assign the emissivity + self%Emissivity = Emissivity + self%Use_Emissivity = .TRUE. + + ! Assign the direct reflectivity if supplied + IF ( PRESENT(Direct_Reflectivity) ) THEN + self%Direct_Reflectivity = Direct_Reflectivity + self%Use_Direct_Reflectivity = .TRUE. + END IF + + END SUBROUTINE SetEmissivity_scalar + + + SUBROUTINE SetEmissivity_rank1( & + self , & + Emissivity, & + Direct_Reflectivity) + ! Arguments + TYPE(CRTM_Options_type), INTENT(IN OUT) :: self + REAL(fp), INTENT(IN) :: Emissivity(:) + REAL(fp), OPTIONAL, INTENT(IN) :: Direct_Reflectivity(:) + ! Local parameters + CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Options_SetEmissivity(Rank-1)' + ! Local variables + CHARACTER(ML) :: msg + INTEGER :: i + + ! Setup + self%Use_Direct_Reflectivity = .FALSE. ! Turn it off + + ! Assign the emissivity + self%Emissivity = Emissivity ! Auto (re)allocation + self%Use_Emissivity = .TRUE. + self%n_Channels = SIZE(Emissivity) + + ! Assign the direct reflectivity if supplied + IF ( PRESENT(Direct_Reflectivity) ) THEN + IF ( SIZE(Direct_Reflectivity) == self%n_Channels ) THEN + self%Direct_Reflectivity = Direct_Reflectivity ! Auto (re)allocation + self%Use_Direct_Reflectivity = .TRUE. + ELSE + msg = 'Size of Direct_Reflectivity argument different from Emissivity. Disabling' + CALL Display_Message( ROUTINE_NAME, msg, WARNING ) + self%Direct_Reflectivity = [(ZERO,i=1,self%n_Channels)] ! Auto (re)allocation + self%Use_Direct_Reflectivity = .FALSE. + END IF + END IF + + ! Set the allocation flag + self%Is_Allocated = ALLOCATED(self%Emissivity) .AND. ALLOCATED(self%Direct_Reflectivity) + + END SUBROUTINE SetEmissivity_rank1 !-------------------------------------------------------------------------------- !:sdoc+: ! @@ -343,28 +738,37 @@ FUNCTION CRTM_Options_IsValid( self ) RESULT( IsValid ) ! Setup IsValid = .TRUE. + ! Check n_Streams + IF ( self%Use_n_Streams ) THEN + IF ( self%n_Streams < 1 .OR. self%n_Streams > MAX_N_STREAMS ) THEN + msg = 'Invalid n_Streams' + CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ) + IsValid = .FALSE. + END IF + END IF + ! Check emissivity options IF ( self%Use_Emissivity .OR. self%Use_Direct_Reflectivity ) THEN - IsValid = CRTM_Options_Associated(self) - IF ( .NOT. IsValid ) THEN - msg = 'Options structure not allocated' - CALL Display_Message( ROUTINE_NAME, TRIM(msg), INFORMATION ) - RETURN - ENDIF - IF ( self%Use_Emissivity ) THEN - IF ( ANY(self%Emissivity < ZERO) .OR. ANY(self%Emissivity > ONE) ) THEN - msg = 'Invalid emissivity' - CALL Display_Message( ROUTINE_NAME, TRIM(msg), INFORMATION ) - IsValid = .FALSE. + IF ( CRTM_Options_Associated(self) ) THEN + IF ( self%Use_Emissivity ) THEN + IF ( ANY(self%Emissivity < ZERO) .OR. ANY(self%Emissivity > ONE) ) THEN + msg = 'Invalid emissivity' + CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ) + IsValid = .FALSE. + END IF END IF - END IF - IF ( self%Use_Direct_Reflectivity ) THEN - IF ( ANY(self%Direct_Reflectivity < ZERO) .OR. ANY(self%Direct_Reflectivity > ONE) ) THEN - msg = 'Invalid direct reflectivity' - CALL Display_Message( ROUTINE_NAME, TRIM(msg), INFORMATION ) - IsValid = .FALSE. + IF ( self%Use_Direct_Reflectivity ) THEN + IF ( ANY(self%Direct_Reflectivity < ZERO) .OR. ANY(self%Direct_Reflectivity > ONE) ) THEN + msg = 'Invalid direct reflectivity' + CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ) + IsValid = .FALSE. + END IF END IF - END IF + ELSE + msg = 'Options structure not allocated for emissivity usage' + CALL Display_Message( ROUTINE_NAME, msg, INFORMATION ) + IsValid = .FALSE. + ENDIF END IF ! Check SSU input options @@ -373,6 +777,9 @@ FUNCTION CRTM_Options_IsValid( self ) RESULT( IsValid ) ! Check Zeeman input options IsValid = Zeeman_Input_IsValid( self%Zeeman ) .AND. IsValid + ! Check cloud overlap option validity + IsValid = CloudCover_Overlap_IsValid( self%Overlap_Id ) .AND. IsValid + END FUNCTION CRTM_Options_IsValid @@ -409,8 +816,9 @@ SUBROUTINE CRTM_Options_Inspect( self ) WRITE(*,'(3x,"Aircraft pressure altitude :",1x,es13.6)') self%Aircraft_Pressure WRITE(*,'(3x,"RT algorithm Id :",1x,i0)') self%RT_Algorithm_Id WRITE(*,'(3x,"Include scattering flag :",1x,l1)') self%Include_Scattering - WRITE(*,'(3x,"Use n_Streams flag :",1x,l1)') self%Use_N_Streams + WRITE(*,'(3x,"Use n_Streams flag :",1x,l1)') self%Use_n_Streams WRITE(*,'(3x,"n_Streams :",1x,i0)') self%n_Streams + WRITE(*,'(3x,"Cloud cover overlap method :",1x,a )') TRIM(CloudCover_Overlap_Name(self%Overlap_Id)) ! ...Emissivity component IF ( CRTM_Options_Associated(self) ) THEN WRITE(*,'(3x,"Emissivity component")') @@ -420,6 +828,7 @@ SUBROUTINE CRTM_Options_Inspect( self ) WRITE(*,'(5x,"Use direct reflectivity flag :",1x,l1)') self%Use_Direct_Reflectivity WRITE(*,'(5x,"Emissivity :")') WRITE(*,'(5(1x,es13.6,:))') self%Emissivity + WRITE(*,'(5x,"Use direct reflectivity flag :",1x,l1)') self%Use_Direct_Reflectivity WRITE(*,'(5x,"Direct reflectivity :")') WRITE(*,'(5(1x,es13.6,:))') self%Direct_Reflectivity END IF @@ -956,7 +1365,8 @@ ELEMENTAL FUNCTION CRTM_Options_Equal( x, y ) RESULT( is_equal ) (x%Aircraft_Pressure .EqualTo. y%Aircraft_Pressure ) .AND. & (x%Use_n_Streams .EQV. y%Use_n_Streams ) .AND. & (x%n_Streams == y%n_Streams ) .AND. & - (x%Include_Scattering .EQV. y%Include_Scattering ) + (x%Include_Scattering .EQV. y%Include_Scattering ) .AND. & + (x%Overlap_Id == y%Overlap_Id ) ! Emissivity component is_equal = is_equal .AND. & @@ -1091,6 +1501,12 @@ FUNCTION Read_Record( & msg = 'Error reading include scattering option' CALL Read_Record_Cleanup(); RETURN END IF + ! ...Cloud cover overlap methodology identifier + READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%Overlap_Id + IF ( io_stat /= 0 ) THEN + msg = 'Error reading Overlap_Id optional value - '//TRIM(io_msg) + CALL Read_Record_Cleanup(); RETURN + END IF ! Read the emissivity/reflectivity data @@ -1259,6 +1675,12 @@ FUNCTION Write_Record( & msg = 'Error writing include scattering option' CALL Write_Record_Cleanup(); RETURN END IF + ! ...Cloud cover overlap methodology identifier + WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) opt%Overlap_Id + IF ( io_stat /= 0 ) THEN + msg = 'Error writing Overlap_Id optional value - '//TRIM(io_msg) + CALL Write_Record_Cleanup(); RETURN + END IF ! Write the emissivity/reflectivity data diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Parameters.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Parameters.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/CRTM_Parameters.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Parameters.f90 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Planck_Functions.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Planck_Functions.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_Planck_Functions.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Planck_Functions.f90 index 80aa7bb3c8..18c8a6e7da 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Planck_Functions.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Planck_Functions.f90 @@ -38,7 +38,7 @@ MODULE CRTM_Planck_Functions ! Parameters ! ---------- CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: CRTM_Planck_Functions.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Planck_Functions.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Predictor.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Predictor.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_Predictor.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Predictor.f90 index 982c6ea513..f67b07909a 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Predictor.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Predictor.f90 @@ -78,7 +78,7 @@ MODULE CRTM_Predictor ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Predictor.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Predictor.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Predictor_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Predictor_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_Predictor_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Predictor_Define.f90 index 7bf13974d5..84df1eb4ad 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Predictor_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Predictor_Define.f90 @@ -65,7 +65,7 @@ MODULE CRTM_Predictor_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Predictor_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Predictor_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_RTSolution.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_RTSolution.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_RTSolution.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_RTSolution.f90 index a214418c84..b58b14f69c 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_RTSolution.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_RTSolution.f90 @@ -66,7 +66,7 @@ MODULE CRTM_RTSolution ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_RTSolution.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_RTSolution.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_RTSolution_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_RTSolution_Define.f90 similarity index 87% rename from var/external/crtm_2.2.3/libsrc/CRTM_RTSolution_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_RTSolution_Define.f90 index d66874ba65..17c3a797c2 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_RTSolution_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_RTSolution_Define.f90 @@ -98,9 +98,10 @@ MODULE CRTM_RTSolution_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_RTSolution_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$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 @@ -122,7 +123,7 @@ MODULE CRTM_RTSolution_Define INTEGER :: WMO_Sensor_ID = INVALID_WMO_SENSOR_ID INTEGER :: Sensor_Channel = 0 ! RT algorithm information - CHARACTER(STRLEN*5) :: RT_Algorithm_Name = '' + CHARACTER(STRLEN) :: RT_Algorithm_Name = '' ! Internal variables. Users do not need to worry about these. LOGICAL :: Scattering_Flag = .TRUE. INTEGER :: n_Full_Streams = 0 @@ -130,6 +131,7 @@ MODULE CRTM_RTSolution_Define ! 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 @@ -137,10 +139,14 @@ MODULE CRTM_RTSolution_Define 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 - ! Radiative transfer results for a single channel/node + REAL(fp), ALLOCATABLE :: Single_Scatter_Albedo(:) ! K + ! Radiative transfer results for a single channel REAL(fp) :: Radiance = ZERO REAL(fp) :: Brightness_Temperature = ZERO REAL(fp) :: Gamma = ZERO @@ -272,6 +278,7 @@ ELEMENTAL SUBROUTINE CRTM_RTSolution_Create( RTSolution, n_Layers ) 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 @@ -282,6 +289,7 @@ ELEMENTAL SUBROUTINE CRTM_RTSolution_Create( RTSolution, n_Layers ) 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. @@ -322,6 +330,7 @@ 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 @@ -329,6 +338,9 @@ ELEMENTAL SUBROUTINE CRTM_RTSolution_Zero( RTSolution ) 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 RTSolution%Gamma = ZERO @@ -338,6 +350,7 @@ ELEMENTAL SUBROUTINE CRTM_RTSolution_Zero( RTSolution ) 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 @@ -391,26 +404,31 @@ SUBROUTINE Scalar_Inspect( RTSolution, Unit ) 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,"Radiance : ",es13.6)') RTSolution%Radiance - WRITE(fid,'(3x,"Brightness Temperature : ",es13.6)') RTSolution%Brightness_Temperature - WRITE(fid,'(3x,"Gamma : ",es13.6)') RTSolution%Gamma + 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 + WRITE(fid,'(3x,"Gamma : ",es13.6)') RTSolution%Gamma IF ( .NOT. CRTM_RTSolution_Associated(RTSolution) ) RETURN WRITE(fid,'(3x,"n_Layers : ",i0)') RTSolution%n_Layers - WRITE(fid,'(3x,"Upwelling Radiance :")') + 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,'(3x,"Layer Optical Depth :")') WRITE(fid,'(5(1x,es13.6,:))') RTSolution%Layer_Optical_Depth END SUBROUTINE Scalar_Inspect @@ -543,6 +561,9 @@ ELEMENTAL FUNCTION CRTM_RTSolution_Compare( & .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 @@ -620,11 +641,12 @@ FUNCTION CRTM_RTSolution_Statistics(rts, rts_stats) RESULT( err_stat ) 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, ERRMSG = alloc_msg ) + 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 @@ -646,7 +668,6 @@ FUNCTION CRTM_RTSolution_Statistics(rts, rts_stats) RESULT( err_stat ) rts_stats(l,1) = rts_stats(l,1)/factor END DO - ! Compute the standard deviation DO m = 1, n_profiles DO l = 1, n_channels @@ -658,11 +679,10 @@ FUNCTION CRTM_RTSolution_Statistics(rts, rts_stats) RESULT( err_stat ) rts_stats(l,2) = SQRT(rts_stats(l,2)/factor) END DO - ! Replace the algorithm identifier - rts_stats(:,1)%RT_Algorithm_Name = 'Object average' - rts_stats(:,2)%RT_Algorithm_Name = 'Object standard deviation' - + rts_stats(:,1)%RT_Algorithm_Name = 'Average' + rts_stats(:,2)%RT_Algorithm_Name = 'Standard deviation' + END FUNCTION CRTM_RTSolution_Statistics @@ -812,7 +832,7 @@ END FUNCTION CRTM_RTSolution_InquireFile ! UNITS: N/A ! TYPE: CRTM_RTSolution_type ! DIMENSION: Rank-2 (n_Channels x n_Profiles) -! ATTRIBUTES: INTENT(OUT) +! ATTRIBUTES: INTENT(OUT), ALLOCATABLE ! ! OPTIONAL INPUTS: ! Quiet: Set this logical argument to suppress INFORMATION @@ -857,17 +877,15 @@ FUNCTION CRTM_RTSolution_ReadFile( & Quiet , & ! Optional input n_Channels , & ! Optional output n_Profiles , & ! Optional output - Old_Version, & ! Optional input (Allow reading of previous version files) Debug ) & ! Optional input (Debug output control) RESULT( err_stat ) ! Arguments - CHARACTER(*), INTENT(IN) :: Filename - TYPE(CRTM_RTSolution_type), INTENT(OUT) :: RTSolution(:,:) - LOGICAL, OPTIONAL, INTENT(IN) :: Quiet - INTEGER, OPTIONAL, INTENT(OUT) :: n_Channels - INTEGER, OPTIONAL, INTENT(OUT) :: n_Profiles - LOGICAL, OPTIONAL, INTENT(IN) :: Old_Version - LOGICAL, OPTIONAL, INTENT(IN) :: Debug + 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 @@ -875,11 +893,13 @@ FUNCTION 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_file_channels, n_input_channels - INTEGER :: m, n_file_profiles, n_input_profiles + INTEGER :: l, n_input_channels + INTEGER :: m, n_input_profiles ! Set up @@ -900,37 +920,24 @@ FUNCTION CRTM_RTSolution_ReadFile( & ! Read the dimensions - READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) n_file_channels, n_file_profiles + 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 - ! ...Check if n_Channels in file is > size of output array - n_input_channels = SIZE(RTSolution,DIM=1) - IF ( n_file_channels > n_input_channels ) THEN - WRITE( msg,'("Number of channels, ",i0," > size of the output RTSolution", & - &" array dimension, ",i0,". Only the first ",i0, & - &" channels will be read.")' ) & - n_file_channels, n_input_channels, n_input_channels - CALL Display_Message( ROUTINE_NAME, msg, WARNING ) - END IF - n_input_channels = MIN(n_input_channels, n_file_channels) - ! ...Check if n_Profiles in file is > size of output array - n_input_profiles = SIZE(RTSolution,DIM=2) - IF ( n_file_profiles > n_input_profiles ) THEN - WRITE( msg,'( "Number of profiles, ",i0," > size of the output RTSolution", & - &" array dimension, ",i0,". Only the first ",i0, & - &" profiles will be read.")' ) & - n_file_profiles, n_input_profiles, n_input_profiles - CALL Display_Message( ROUTINE_NAME, msg, WARNING ) + ! ...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 - n_input_profiles = MIN(n_input_profiles, n_file_profiles) ! 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), Old_Version=Old_Version ) + 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) @@ -968,7 +975,13 @@ SUBROUTINE Read_CleanUp() IF ( io_stat /= 0 ) & msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) END IF - CALL CRTM_RTSolution_Destroy( RTSolution ) + 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 @@ -1193,6 +1206,9 @@ ELEMENTAL FUNCTION CRTM_RTSolution_Equal( x, y ) RESULT( is_equal ) (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. @@ -1259,7 +1275,7 @@ ELEMENTAL FUNCTION CRTM_RTSolution_Add( rts1, rts2 ) RESULT( rtssum ) ! And add the second one's components to it ! ...Handle RT_Algorithm_Name - rtssum%RT_Algorithm_Name = 'Object add' + rtssum%RT_Algorithm_Name = 'Addition' ! ...The scalar values rtssum%SOD = rtssum%SOD + rts2%SOD rtssum%Surface_Emissivity = rtssum%Surface_Emissivity + rts2%Surface_Emissivity @@ -1268,6 +1284,9 @@ ELEMENTAL FUNCTION CRTM_RTSolution_Add( rts1, rts2 ) RESULT( rtssum ) 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) @@ -1337,7 +1356,7 @@ ELEMENTAL FUNCTION CRTM_RTSolution_Subtract( rts1, rts2 ) RESULT( rtsdiff ) ! And subtract the second one's components from it ! ...Handle RT_Algorithm_Name - rtsdiff%RT_Algorithm_Name = 'Object subtract' + rtsdiff%RT_Algorithm_Name = 'Subtraction' ! ...The scalar values rtsdiff%SOD = rtsdiff%SOD - rts2%SOD rtsdiff%Surface_Emissivity = rtsdiff%Surface_Emissivity - rts2%Surface_Emissivity @@ -1346,6 +1365,9 @@ ELEMENTAL FUNCTION CRTM_RTSolution_Subtract( rts1, rts2 ) RESULT( rtsdiff ) 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) @@ -1412,23 +1434,26 @@ ELEMENTAL FUNCTION CRTM_RTSolution_Exponent( rts, power ) RESULT( rts_power ) ! Raise the components to the supplied power ! ...Handle RT_Algorithm_Name - rts_power%RT_Algorithm_Name = 'Object exponent' + 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%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%Radiance = (rts_power%Radiance)**power - rts_power%Brightness_Temperature = (rts_power%Brightness_Temperature)**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 + 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 @@ -1483,23 +1508,26 @@ ELEMENTAL FUNCTION CRTM_RTSolution_Normalise( rts, factor ) RESULT( rts_normal ) ! Raise the components to the supplied normal ! ...Handle RT_Algorithm_Name - rts_normal%RT_Algorithm_Name = 'Object normalise' + 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%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%Radiance = rts_normal%Radiance/factor - rts_normal%Brightness_Temperature = rts_normal%Brightness_Temperature/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 + 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 @@ -1546,23 +1574,26 @@ ELEMENTAL FUNCTION CRTM_RTSolution_Sqrt( rts ) RESULT( rts_sqrt ) ! Raise the components to the supplied normal ! ...Handle RT_Algorithm_Name - rts_sqrt%RT_Algorithm_Name = 'Object SQRT()' + 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%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%Radiance = SQRT(rts_sqrt%Radiance) - rts_sqrt%Brightness_Temperature = SQRT(rts_sqrt%Brightness_Temperature) + 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)) + 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 @@ -1578,13 +1609,11 @@ END FUNCTION CRTM_RTSolution_Sqrt FUNCTION Read_Record( & fid, & ! Input - rts, & ! Output - old_version) & ! Optional input + rts) & ! Output RESULT( err_stat ) ! Arguments INTEGER, INTENT(IN) :: fid TYPE(CRTM_RTSolution_type), INTENT(OUT) :: rts - LOGICAL, OPTIONAL, INTENT(IN) :: old_version ! Function result INTEGER :: err_stat ! Function parameters @@ -1594,13 +1623,10 @@ FUNCTION Read_Record( & CHARACTER(ML) :: io_msg INTEGER :: io_stat INTEGER :: n_layers - LOGICAL :: current_version ! Set up err_stat = SUCCESS - ! ...PRocess optional arguments - current_version = .TRUE. - IF ( PRESENT(old_version) ) current_version = .NOT. old_version + ! Read the dimensions READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) n_layers @@ -1649,22 +1675,19 @@ FUNCTION Read_Record( & rts%Up_Radiance , & rts%Down_Radiance , & rts%Down_Solar_Radiance , & - rts%Surface_Planck_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 - IF ( current_version ) THEN - READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) & - rts%Upwelling_Overcast_Radiance , & - rts%Upwelling_Radiance, & - rts%Layer_Optical_Depth - ELSE - READ( fid,IOSTAT=io_stat,IOMSG=io_msg ) & - rts%Upwelling_Radiance , & - rts%Layer_Optical_Depth - END IF + 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 @@ -1743,7 +1766,7 @@ FUNCTION Write_Record( & END IF - ! Write the sensor info + ! Write the RT algorithm name WRITE( fid,IOSTAT=io_stat,IOMSG=io_msg ) & rts%RT_Algorithm_Name IF ( io_stat /= 0 ) THEN @@ -1760,7 +1783,10 @@ FUNCTION Write_Record( & rts%Up_Radiance , & rts%Down_Radiance , & rts%Down_Solar_Radiance , & - rts%Surface_Planck_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 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_SEcategory.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_SEcategory.f90 similarity index 98% rename from var/external/crtm_2.2.3/libsrc/CRTM_SEcategory.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_SEcategory.f90 index 0e45b346a3..fd2a1a5a5e 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_SEcategory.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_SEcategory.f90 @@ -50,7 +50,7 @@ MODULE CRTM_SEcategory ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_SEcategory.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_SEcategory.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_SensorData_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_SensorData_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_SensorData_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_SensorData_Define.f90 index 8fcc492f7c..668c63c61b 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_SensorData_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_SensorData_Define.f90 @@ -82,7 +82,7 @@ MODULE CRTM_SensorData_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_SensorData_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_SensorData_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 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_SensorInfo.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_SensorInfo.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_SensorInfo.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_SensorInfo.f90 index d8520f26e4..c69ba2223e 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_SensorInfo.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_SensorInfo.f90 @@ -32,7 +32,7 @@ MODULE CRTM_SensorInfo ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: CRTM_SensorInfo.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_SensorInfo.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! WMO SENSOR codes from COMMON CODE TABLE C-8 INTEGER, PUBLIC, PARAMETER :: WMO_HIRS2 = 605 INTEGER, PUBLIC, PARAMETER :: WMO_MSU = 623 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_SfcOptics.f90 similarity index 98% rename from var/external/crtm_2.2.3/libsrc/CRTM_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_SfcOptics.f90 index 1b2646539c..3ae4b1e360 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_SfcOptics.f90 @@ -119,7 +119,7 @@ MODULE CRTM_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message length INTEGER, PARAMETER :: ML = 256 @@ -2084,7 +2084,13 @@ 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 + 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 ! ------------------------------------ @@ -2099,7 +2105,9 @@ FUNCTION CRTM_Compute_SfcOptics_AD( & SfcOptics_AD%Reflectivity(1:nZ,1:nL,1:nZ,1:nL) = & SfcOptics_AD%Reflectivity(1:nZ,1:nL,1:nZ,1:nL) + & (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) ! Compute the surface optics adjoints Error_Status = Compute_IR_Ice_SfcOptics_AD( SfcOptics_AD ) IF ( Error_Status /= SUCCESS ) THEN @@ -2126,7 +2134,9 @@ FUNCTION CRTM_Compute_SfcOptics_AD( & SfcOptics_AD%Reflectivity(1:nZ,1:nL,1:nZ,1:nL) = & SfcOptics_AD%Reflectivity(1:nZ,1:nL,1:nZ,1:nL) + & (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) ! Compute the surface optics adjoints Error_Status = Compute_IR_Snow_SfcOptics_AD( SfcOptics_AD ) IF ( Error_Status /= SUCCESS ) THEN @@ -2153,7 +2163,9 @@ FUNCTION CRTM_Compute_SfcOptics_AD( & SfcOptics_AD%Reflectivity(1:nZ,1:nL,1:nZ,1:nL) = & SfcOptics_AD%Reflectivity(1:nZ,1:nL,1:nZ,1:nL) + & (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) ! Compute the surface optics adjoints Error_Status = Compute_IR_Water_SfcOptics_AD( & Surface , & ! Input @@ -2188,7 +2200,9 @@ FUNCTION CRTM_Compute_SfcOptics_AD( & SfcOptics_AD%Reflectivity(1:nZ,1:nL,1:nZ,1:nL) = & SfcOptics_AD%Reflectivity(1:nZ,1:nL,1:nZ,1:nL) + & (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) ! Compute the surface optics adjoints ! **STUB PROCEDURE** Error_Status = Compute_IR_Land_SfcOptics_AD( SfcOptics_AD ) diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_SfcOptics_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_SfcOptics_Define.f90 similarity index 62% rename from var/external/crtm_2.2.3/libsrc/CRTM_SfcOptics_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_SfcOptics_Define.f90 index 4e659b96e6..ec7737c1fc 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_SfcOptics_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_SfcOptics_Define.f90 @@ -37,10 +37,13 @@ MODULE CRTM_SfcOptics_Define PUBLIC :: CRTM_SfcOptics_type ! Operators PUBLIC :: OPERATOR(==) + PUBLIC :: OPERATOR(+) + PUBLIC :: OPERATOR(-) ! Procedures PUBLIC :: CRTM_SfcOptics_Associated PUBLIC :: CRTM_SfcOptics_Destroy PUBLIC :: CRTM_SfcOptics_Create + PUBLIC :: CRTM_SfcOptics_Zero PUBLIC :: CRTM_SfcOptics_Inspect PUBLIC :: CRTM_SfcOptics_DefineVersion PUBLIC :: CRTM_SfcOptics_Compare @@ -52,13 +55,21 @@ MODULE CRTM_SfcOptics_Define INTERFACE OPERATOR(==) MODULE PROCEDURE CRTM_SfcOptics_Equal END INTERFACE OPERATOR(==) + + INTERFACE OPERATOR(+) + MODULE PROCEDURE CRTM_SfcOptics_Add + END INTERFACE OPERATOR(+) + + INTERFACE OPERATOR(-) + MODULE PROCEDURE CRTM_SfcOptics_Subtract + END INTERFACE OPERATOR(-) ! ----------------- ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_SfcOptics_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_SfcOptics_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! ----------------------------------- @@ -184,10 +195,10 @@ MODULE CRTM_SfcOptics_Define !:sdoc-: !-------------------------------------------------------------------------------- - ELEMENTAL FUNCTION CRTM_SfcOptics_Associated( SfcOptics ) RESULT( Status ) - TYPE(CRTM_SfcOptics_type), INTENT(IN) :: SfcOptics + ELEMENTAL FUNCTION CRTM_SfcOptics_Associated( self ) RESULT( Status ) + TYPE(CRTM_SfcOptics_type), INTENT(IN) :: self LOGICAL :: Status - Status = SfcOptics%Is_Allocated + Status = self%Is_Allocated END FUNCTION CRTM_SfcOptics_Associated @@ -213,9 +224,9 @@ END FUNCTION CRTM_SfcOptics_Associated !:sdoc-: !-------------------------------------------------------------------------------- - ELEMENTAL SUBROUTINE CRTM_SfcOptics_Destroy( SfcOptics ) - TYPE(CRTM_SfcOptics_type), INTENT(OUT) :: SfcOptics - SfcOptics%Is_Allocated = .FALSE. + ELEMENTAL SUBROUTINE CRTM_SfcOptics_Destroy( self ) + TYPE(CRTM_SfcOptics_type), INTENT(OUT) :: self + self%Is_Allocated = .FALSE. END SUBROUTINE CRTM_SfcOptics_Destroy @@ -229,32 +240,40 @@ END SUBROUTINE CRTM_SfcOptics_Destroy ! Elemental subroutine to create an instance of the CRTM SfcOptics object. ! ! CALLING SEQUENCE: -! CALL CRTM_SfcOptics_Create( SfcOptics, n_Layers ) +! CALL CRTM_SfcOptics_Create( SfcOptics, n_Angles, n_Stokes ) ! ! OBJECTS: -! SfcOptics: SfcOptics structure. +! SfcOptics: SfcOptics structure. ! UNITS: N/A ! TYPE: CRTM_SfcOptics_type ! DIMENSION: Scalar or any rank ! ATTRIBUTES: INTENT(OUT) ! ! INPUTS: -! n_Layers: Number of layers for which there is SfcOptics data. +! n_Angles: Number of angles for which there is SfcOptics data. ! Must be > 0. ! UNITS: N/A ! TYPE: INTEGER -! DIMENSION: Same as SfcOptics object +! DIMENSION: Conformable with SfcOptics object +! ATTRIBUTES: INTENT(IN) +! +! n_Stokes: Number of Stokes components for which there is SfcOptics +! data. +! Must be > 0. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Conformable with SfcOptics object ! ATTRIBUTES: INTENT(IN) ! !:sdoc-: !-------------------------------------------------------------------------------- ELEMENTAL SUBROUTINE CRTM_SfcOptics_Create( & - SfcOptics, & + self, & n_Angles , & n_Stokes ) ! Arguments - TYPE(CRTM_SfcOptics_type), INTENT(OUT) :: SfcOptics + TYPE(CRTM_SfcOptics_type), INTENT(OUT) :: self INTEGER, INTENT(IN) :: n_Angles INTEGER, INTENT(IN) :: n_Stokes ! Local variables @@ -264,31 +283,67 @@ ELEMENTAL SUBROUTINE CRTM_SfcOptics_Create( & IF ( n_Angles < 1 .OR. n_Stokes < 1 ) RETURN ! Perform the allocation - ALLOCATE( SfcOptics%Angle( n_Angles ), & - SfcOptics%Weight( n_Angles ), & - SfcOptics%Emissivity( n_Angles, n_Stokes ), & - SfcOptics%Reflectivity( n_Angles, n_Stokes, n_Angles, n_Stokes), & - SfcOptics%Direct_Reflectivity( n_Angles, n_Stokes ), & + ALLOCATE( self%Angle( n_Angles ), & + self%Weight( n_Angles ), & + self%Emissivity( n_Angles, n_Stokes ), & + self%Reflectivity( n_Angles, n_Stokes, n_Angles, n_Stokes), & + self%Direct_Reflectivity( n_Angles, n_Stokes ), & STAT = alloc_stat ) IF ( alloc_stat /= 0 ) RETURN ! Initialise ! ...Dimensions - SfcOptics%n_Angles = n_Angles - SfcOptics%n_Stokes = n_Stokes + self%n_Angles = n_Angles + self%n_Stokes = n_Stokes ! ...Arrays - SfcOptics%Angle = ZERO - SfcOptics%Weight = ZERO - SfcOptics%Emissivity = ZERO - SfcOptics%Reflectivity = ZERO - SfcOptics%Direct_Reflectivity = ZERO + self%Angle = ZERO + self%Weight = ZERO + self%Emissivity = ZERO + self%Reflectivity = ZERO + self%Direct_Reflectivity = ZERO ! Set allocation indicator - SfcOptics%Is_Allocated = .TRUE. + self%Is_Allocated = .TRUE. END SUBROUTINE CRTM_SfcOptics_Create +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_SfcOptics_Zero +! +! PURPOSE: +! Elemental subroutine to initialise the components of an SfcOptics +! object to a value of zero. +! +! CALLING SEQUENCE: +! CALL CRTM_SfcOptics_Zero( SfcOptics ) +! +! OBJECTS: +! SfcOptics: SfcOptics object which is to have its components +! set to a zero value. +! UNITS: N/A +! TYPE: CRTM_SfcOptics_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(IN OUT) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + ELEMENTAL SUBROUTINE CRTM_SfcOptics_Zero( self ) + TYPE(CRTM_SfcOptics_type), INTENT(IN OUT) :: self + self%Azimuth_Angle = 999.9_fp + self%Transmittance = ZERO + self%Surface_Temperature = ZERO + IF ( .NOT. CRTM_SfcOptics_Associated( self ) ) RETURN + self%Emissivity = ZERO + self%Reflectivity = ZERO + self%Direct_Reflectivity = ZERO + END SUBROUTINE CRTM_SfcOptics_Zero + + !-------------------------------------------------------------------------------- !:sdoc+: ! @@ -311,32 +366,32 @@ END SUBROUTINE CRTM_SfcOptics_Create !:sdoc-: !-------------------------------------------------------------------------------- - SUBROUTINE CRTM_SfcOptics_Inspect( SfcOptics ) - TYPE(CRTM_SfcOptics_type), INTENT(IN) :: SfcOptics + SUBROUTINE CRTM_SfcOptics_Inspect( self ) + TYPE(CRTM_SfcOptics_type), INTENT(IN) :: self WRITE(*, '(1x,"SfcOptics OBJECT")') ! Dimensions - WRITE(*, '(3x,"n_Angles :",1x,i0)') SfcOptics%n_Angles - WRITE(*, '(3x,"n_Stokes :",1x,i0)') SfcOptics%n_Stokes + WRITE(*, '(3x,"n_Angles :",1x,i0)') self%n_Angles + WRITE(*, '(3x,"n_Stokes :",1x,i0)') self%n_Stokes ! Display components - WRITE(*, '(3x,"Compute flag :",1x,l1)') SfcOptics%Compute - WRITE(*, '(3x,"Use_New_MWSSEM flag :",1x,l1)') SfcOptics%Use_New_MWSSEM - WRITE(*, '(3x," MWSSEM- azimuth angle :",1x,es13.6)') SfcOptics%Azimuth_Angle - WRITE(*, '(3x," MWSSEM- transmittance :",1x,es13.6)') SfcOptics%Transmittance - WRITE(*, '(3x,"Satellite view angle index:",1x,i0)') SfcOptics%Index_Sat_Ang - WRITE(*, '(3x,"Azimuth Fourier component :",1x,i0)') SfcOptics%mth_Azi - WRITE(*, '(3x,"Weighted mean Tsfc :",1x,es13.6)') SfcOptics%Surface_Temperature - IF ( .NOT. CRTM_SfcOptics_Associated(SfcOptics) ) RETURN + WRITE(*, '(3x,"Compute flag :",1x,l1)') self%Compute + WRITE(*, '(3x,"Use_New_MWSSEM flag :",1x,l1)') self%Use_New_MWSSEM + WRITE(*, '(3x," MWSSEM- azimuth angle :",1x,es13.6)') self%Azimuth_Angle + WRITE(*, '(3x," MWSSEM- transmittance :",1x,es13.6)') self%Transmittance + WRITE(*, '(3x,"Satellite view angle index:",1x,i0)') self%Index_Sat_Ang + WRITE(*, '(3x,"Azimuth Fourier component :",1x,i0)') self%mth_Azi + WRITE(*, '(3x,"Weighted mean Tsfc :",1x,es13.6)') self%Surface_Temperature + IF ( .NOT. CRTM_SfcOptics_Associated(self) ) RETURN WRITE(*, '(3x,"Angle :")') - WRITE(*, '(5(1x,es13.6,:))') SfcOptics%Angle + WRITE(*, '(5(1x,es13.6,:))') self%Angle WRITE(*, '(3x,"Weight :")') - WRITE(*, '(5(1x,es13.6,:))') SfcOptics%Weight + WRITE(*, '(5(1x,es13.6,:))') self%Weight WRITE(*, '(3x,"Emissivity :")') - WRITE(*, '(5(1x,es13.6,:))') SfcOptics%Emissivity + WRITE(*, '(5(1x,es13.6,:))') self%Emissivity WRITE(*, '(3x,"Reflectivity :")') - WRITE(*, '(5(1x,es13.6,:))') SfcOptics%Reflectivity + WRITE(*, '(5(1x,es13.6,:))') self%Reflectivity WRITE(*, '(3x,"Direct_Reflectivity :")') - WRITE(*, '(5(1x,es13.6,:))') SfcOptics%Direct_Reflectivity + WRITE(*, '(5(1x,es13.6,:))') self%Direct_Reflectivity END SUBROUTINE CRTM_SfcOptics_Inspect @@ -504,28 +559,152 @@ ELEMENTAL FUNCTION CRTM_SfcOptics_Equal( x, y ) RESULT( is_equal ) is_equal = .FALSE. ! Check the structure association status - IF ( (.NOT. CRTM_SfcOptics_Associated(x)) .OR. & - (.NOT. CRTM_SfcOptics_Associated(y)) ) RETURN + IF ( CRTM_SfcOptics_Associated(x) .NEQV. CRTM_SfcOptics_Associated(y) ) RETURN ! Check contents ! ...Dimensions IF ( (x%n_Angles /= y%n_Angles) .OR. & (x%n_Stokes /= y%n_Stokes) ) RETURN - ! ...Everything else - IF ( (x%Compute .EQV. y%Compute ) .AND. & - (x%Use_New_MWSSEM .EQV. y%Use_New_MWSSEM ) .AND. & - (x%Azimuth_Angle .EqualTo. y%Azimuth_Angle ) .AND. & - (x%Transmittance .EqualTo. y%Transmittance ) .AND. & - (x%Index_Sat_Ang == y%Index_Sat_Ang ) .AND. & - (x%mth_Azi == y%mth_Azi ) .AND. & - (x%Surface_Temperature .EqualTo. y%Surface_Temperature) .AND. & - ALL(x%Angle .EqualTo. y%Angle ) .AND. & - ALL(x%Weight .EqualTo. y%Weight ) .AND. & - ALL(x%Emissivity .EqualTo. y%Emissivity ) .AND. & - ALL(x%Reflectivity .EqualTo. y%Reflectivity ) .AND. & - ALL(x%Direct_Reflectivity .EqualTo. y%Direct_Reflectivity) ) & - is_equal = .TRUE. + ! ...Scalars + IF ( .NOT. ((x%Compute .EQV. y%Compute ) .AND. & + (x%Use_New_MWSSEM .EQV. y%Use_New_MWSSEM ) .AND. & + (x%Azimuth_Angle .EqualTo. y%Azimuth_Angle ) .AND. & + (x%Transmittance .EqualTo. y%Transmittance ) .AND. & + (x%Index_Sat_Ang == y%Index_Sat_Ang ) .AND. & + (x%mth_Azi == y%mth_Azi ) .AND. & + (x%Surface_Temperature .EqualTo. y%Surface_Temperature)) ) RETURN + ! ...Arrays + IF ( CRTM_SfcOptics_Associated(x) .AND. CRTM_SfcOptics_Associated(y) ) THEN + IF ( .NOT. (ALL(x%Angle .EqualTo. y%Angle ) .AND. & + ALL(x%Weight .EqualTo. y%Weight ) .AND. & + ALL(x%Emissivity .EqualTo. y%Emissivity ) .AND. & + ALL(x%Reflectivity .EqualTo. y%Reflectivity ) .AND. & + ALL(x%Direct_Reflectivity .EqualTo. y%Direct_Reflectivity)) ) RETURN + END IF + + + ! If we get here, then... + is_equal = .TRUE. END FUNCTION CRTM_SfcOptics_Equal + +!------------------------------------------------------------------------------ +! +! NAME: +! CRTM_SfcOptics_Add +! +! PURPOSE: +! Pure function to add two CRTM_SfcOptics objects. +! Used in OPERATOR(+) interface block. +! +! CALLING SEQUENCE: +! sosum = CRTM_SfcOptics_Add( so1, so2 ) +! +! or +! +! sosum = so1 + so2 +! +! INPUTS: +! so1, so2: Two CRTM SfcOptics objects to be added. +! UNITS: N/A +! TYPE: CRTM_SfcOptics_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! RESULT: +! sosum: SfcOptics object containing the added components. +! UNITS: N/A +! TYPE: CRTM_SfcOptics_type +! DIMENSION: Scalar +! +!------------------------------------------------------------------------------ + + ELEMENTAL FUNCTION CRTM_SfcOptics_Add( so1, so2 ) RESULT( sosum ) + TYPE(CRTM_SfcOptics_type), INTENT(IN) :: so1, so2 + TYPE(CRTM_SfcOptics_type) :: sosum + + ! Check the structure association status + IF ( (.NOT. CRTM_SfcOptics_Associated(so1)) .OR. & + (.NOT. CRTM_SfcOptics_Associated(so2)) ) RETURN + + ! Check contents + ! ...Dimensions + IF ( (so1%n_Angles /= so2%n_Angles) .OR. & + (so1%n_Stokes /= so2%n_Stokes) ) RETURN + + ! Copy the first structure + sosum = so1 + + ! And add its components to the second one + ! ...The scalar values + sosum%Transmittance = sosum%Transmittance + so2%Transmittance + sosum%Surface_Temperature = sosum%Surface_Temperature + so2%Surface_Temperature + ! ...The arrays + sosum%Reflectivity = sosum%Reflectivity + so2%Reflectivity + sosum%Direct_Reflectivity = sosum%Direct_Reflectivity + so2%Direct_Reflectivity + sosum%Emissivity = sosum%Emissivity + so2%Emissivity + + END FUNCTION CRTM_SfcOptics_Add + + + +!------------------------------------------------------------------------------ +! +! NAME: +! CRTM_SfcOptics_Subtract +! +! PURPOSE: +! Pure function to subtract two CRTM_SfcOptics objects. +! Used in OPERATOR(-) interface block. +! +! CALLING SEQUENCE: +! sodiff = CRTM_SfcOptics_Subtract( so1, so2 ) +! +! or +! +! sodiff = so1 - so2 +! +! INPUTS: +! so1, so2: Two CRTM SfcOptics objects to be subtracted. +! UNITS: N/A +! TYPE: CRTM_SfcOptics_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! RESULT: +! sodiff: SfcOptics object containing the differenced components. +! UNITS: N/A +! TYPE: CRTM_SfcOptics_type +! DIMENSION: Scalar +! +!------------------------------------------------------------------------------ + + ELEMENTAL FUNCTION CRTM_SfcOptics_Subtract( so1, so2 ) RESULT( sodiff ) + TYPE(CRTM_SfcOptics_type), INTENT(IN) :: so1, so2 + TYPE(CRTM_SfcOptics_type) :: sodiff + + ! Check the structure association status + IF ( (.NOT. CRTM_SfcOptics_Associated(so1)) .OR. & + (.NOT. CRTM_SfcOptics_Associated(so2)) ) RETURN + + ! Check contents + ! ...Dimensions + IF ( (so1%n_Angles /= so2%n_Angles) .OR. & + (so1%n_Stokes /= so2%n_Stokes) ) RETURN + + ! Copy the first structure + sodiff = so1 + + ! And subtract the second one from it + ! ...The scalar values + sodiff%Transmittance = sodiff%Transmittance - so2%Transmittance + sodiff%Surface_Temperature = sodiff%Surface_Temperature - so2%Surface_Temperature + ! ...The arrays + sodiff%Reflectivity = sodiff%Reflectivity - so2%Reflectivity + sodiff%Direct_Reflectivity = sodiff%Direct_Reflectivity - so2%Direct_Reflectivity + sodiff%Emissivity = sodiff%Emissivity - so2%Emissivity + + END FUNCTION CRTM_SfcOptics_Subtract + END MODULE CRTM_SfcOptics_Define diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_SpcCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_SpcCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_SpcCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_SpcCoeff.f90 index 58d48bb790..daea5b8115 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_SpcCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_SpcCoeff.f90 @@ -103,7 +103,7 @@ MODULE CRTM_SpcCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_SpcCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_SpcCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Surface_Define.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Surface_Define.f90 similarity index 97% rename from var/external/crtm_2.2.3/libsrc/CRTM_Surface_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Surface_Define.f90 index 52b32888c9..47f16f52a0 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Surface_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Surface_Define.f90 @@ -83,6 +83,7 @@ MODULE CRTM_Surface_Define PUBLIC :: CRTM_Surface_Associated PUBLIC :: CRTM_Surface_Destroy PUBLIC :: CRTM_Surface_Create + PUBLIC :: CRTM_Surface_NonVariableCopy PUBLIC :: CRTM_Surface_Zero PUBLIC :: CRTM_Surface_IsValid PUBLIC :: CRTM_Surface_Inspect @@ -125,7 +126,7 @@ MODULE CRTM_Surface_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Surface_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Surface_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 @@ -322,11 +323,6 @@ END FUNCTION CRTM_Surface_Associated ELEMENTAL SUBROUTINE CRTM_Surface_Destroy( Sfc ) TYPE(CRTM_Surface_type), INTENT(OUT) :: Sfc -!gfortran compiler (V4.4.0 and 4.3.3) and older PGI compilers can -!not handle INTENT(OUT) properly, add a dummy local type so that -!Sfc is forced to be re-initialized. - TYPE(CRTM_Surface_type) :: Dummy - Sfc = Dummy Sfc%Is_Allocated = .TRUE. ! Placeholder for future expansion END SUBROUTINE CRTM_Surface_Destroy @@ -383,6 +379,56 @@ ELEMENTAL SUBROUTINE CRTM_Surface_Create( & END SUBROUTINE CRTM_Surface_Create +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! CRTM_Surface_NonVariableCopy +! +! PURPOSE: +! Elemental utility subroutine to copy the "non-variable" data (coverages +! and surface types) from one instance of a CRTM Surface object to another +! (usually a TL or AD one). +! +! NOTE: No error checking is performed in this procedure. +! +! CALLING SEQUENCE: +! CALL CRTM_Surface_NonVariableCopy( sfc, modified_sfc ) +! +! OBJECTS: +! sfc: Surface object from which to copy. +! UNITS: N/A +! TYPE: CRTM_Surface_type +! DIMENSION: Scalar or any rank +! ATTRIBUTES: INTENT(IN) +! +! IN/OUTPUTS: +! modified_sfc: Existing Surface object to be modified. +! UNITS: N/A +! TYPE: CRTM_Surface_type +! DIMENSION: Conformable with sfc input +! ATTRIBUTES: INTENT(IN OUT) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + ELEMENTAL SUBROUTINE CRTM_Surface_NonVariableCopy( sfc, modified_sfc ) + TYPE(CRTM_Surface_type), INTENT(IN) :: sfc + TYPE(CRTM_Surface_type), INTENT(IN OUT) :: modified_sfc + + modified_sfc%Land_Coverage = sfc%Land_Coverage + 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 + + !-------------------------------------------------------------------------------- !:sdoc+: ! @@ -1070,7 +1116,8 @@ FUNCTION Read_Surface_Rank1( & CALL Read_Cleanup(); RETURN END IF ! ...Allocate the return structure array - ALLOCATE(Surface(n_input_profiles), STAT=alloc_stat, ERRMSG=alloc_msg) + !ALLOCATE(Surface(n_input_profiles), STAT=alloc_stat, ERRMSG=alloc_msg) + ALLOCATE(Surface(n_input_profiles), STAT=alloc_stat) IF ( alloc_stat /= 0 ) THEN msg = 'Error allocating Surface array - '//TRIM(alloc_msg) CALL Read_Cleanup(); RETURN @@ -1117,7 +1164,8 @@ SUBROUTINE Read_CleanUp() msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) END IF IF ( ALLOCATED(Surface) ) THEN - DEALLOCATE(Surface, STAT=alloc_stat, ERRMSG=alloc_msg) + !DEALLOCATE(Surface, STAT=alloc_stat, ERRMSG=alloc_msg) + DEALLOCATE(Surface, STAT=alloc_stat) IF ( alloc_stat /= 0 ) & msg = TRIM(msg)//'; Error deallocating Surface array during error cleanup - '//& TRIM(alloc_msg) @@ -1184,7 +1232,8 @@ FUNCTION Read_Surface_Rank2( & CALL Read_Cleanup(); RETURN END IF ! ...Allocate the return structure array - ALLOCATE(Surface(n_input_channels, n_input_profiles), STAT=alloc_stat, ERRMSG=alloc_msg) + !ALLOCATE(Surface(n_input_channels, n_input_profiles), STAT=alloc_stat, ERRMSG=alloc_msg) + ALLOCATE(Surface(n_input_channels, n_input_profiles), STAT=alloc_stat) IF ( alloc_stat /= 0 ) THEN msg = 'Error allocating Surface array - '//TRIM(alloc_msg) CALL Read_Cleanup(); RETURN @@ -1235,7 +1284,8 @@ SUBROUTINE Read_CleanUp() msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg) END IF IF ( ALLOCATED(Surface) ) THEN - DEALLOCATE(Surface, STAT=alloc_stat, ERRMSG=alloc_msg) + !DEALLOCATE(Surface, STAT=alloc_stat, ERRMSG=alloc_msg) + DEALLOCATE(Surface, STAT=alloc_stat) IF ( alloc_stat /= 0 ) & msg = TRIM(msg)//'; Error deallocating Surface array during error cleanup - '//& TRIM(alloc_msg) diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Tangent_Linear_Module.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Tangent_Linear_Module.f90 similarity index 68% rename from var/external/crtm_2.2.3/libsrc/CRTM_Tangent_Linear_Module.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Tangent_Linear_Module.f90 index cba0dbc940..76a2ffacb2 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Tangent_Linear_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Tangent_Linear_Module.f90 @@ -40,10 +40,17 @@ MODULE CRTM_Tangent_Linear_Module CRTM_Geometry_IsValid USE CRTM_ChannelInfo_Define, ONLY: CRTM_ChannelInfo_type, & CRTM_ChannelInfo_n_Channels + USE CRTM_RTSolution_Define, ONLY: CRTM_RTSolution_type , & + CRTM_RTSolution_Destroy, & + CRTM_RTSolution_Zero USE CRTM_Options_Define, ONLY: CRTM_Options_type, & CRTM_Options_IsValid - USE CRTM_Atmosphere, ONLY: CRTM_Atmosphere_AddLayers, & - CRTM_Atmosphere_AddLayers_TL + USE CRTM_Atmosphere, ONLY: CRTM_Atmosphere_AddLayers , & + CRTM_Atmosphere_AddLayers_TL , & + CRTM_Atmosphere_IsFractional , & + CRTM_Atmosphere_Coverage , & + CRTM_Atmosphere_ClearSkyCopy , & + CRTM_Atmosphere_ClearSkyCopy_TL USE CRTM_GeometryInfo_Define, ONLY: CRTM_GeometryInfo_type, & CRTM_GeometryInfo_SetValue, & CRTM_GeometryInfo_GetValue @@ -67,50 +74,47 @@ MODULE CRTM_Tangent_Linear_Module CRTM_Compute_AerosolScatter_TL USE CRTM_CloudScatter, ONLY: CRTM_Compute_CloudScatter , & CRTM_Compute_CloudScatter_TL - USE CRTM_AtmOptics, ONLY: AOvar_type , & - AOvar_Create, & - CRTM_Include_Scattering, & - CRTM_Compute_Transmittance , & - CRTM_Compute_Transmittance_TL, & - CRTM_Combine_AtmOptics , & - CRTM_Combine_AtmOptics_TL + USE CRTM_AtmOptics, ONLY: CRTM_Include_Scattering, & + CRTM_Compute_Transmittance , & + CRTM_Compute_Transmittance_TL , & + CRTM_AtmOptics_Combine , & + CRTM_AtmOptics_Combine_TL , & + CRTM_AtmOptics_NoScatterCopy , & + CRTM_AtmOptics_NoScatterCopy_TL USE CRTM_SfcOptics_Define, ONLY: CRTM_SfcOptics_type , & CRTM_SfcOptics_Associated, & CRTM_SfcOptics_Create , & CRTM_SfcOptics_Destroy USE CRTM_SfcOptics, ONLY: CRTM_Compute_SurfaceT , & CRTM_Compute_SurfaceT_TL - USE CRTM_RTSolution, ONLY: CRTM_RTSolution_type , & - CRTM_Compute_nStreams , & + USE CRTM_RTSolution, ONLY: CRTM_Compute_nStreams , & CRTM_Compute_RTSolution , & CRTM_Compute_RTSolution_TL - USE RTV_Define, ONLY: RTV_type , & - RTV_Associated, & - RTV_Destroy , & - RTV_Create USE CRTM_AntennaCorrection, ONLY: CRTM_Compute_AntCorr, & CRTM_Compute_AntCorr_TL USE CRTM_MoleculeScatter, ONLY: CRTM_Compute_MoleculeScatter, & CRTM_Compute_MoleculeScatter_TL USE CRTM_AncillaryInput_Define, ONLY: CRTM_AncillaryInput_type - USE CRTM_CloudCoeff, ONLY: CRTM_CloudCoeff_IsLoaded USE CRTM_AerosolCoeff, ONLY: CRTM_AerosolCoeff_IsLoaded - USE CRTM_NLTECorrection, ONLY: NLTE_Predictor_type , & NLTE_Predictor_IsActive , & Compute_NLTE_Predictor , & Compute_NLTE_Predictor_TL , & Compute_NLTE_Correction , & Compute_NLTE_Correction_TL - USE ACCoeff_Define, ONLY: ACCoeff_Associated USE NLTECoeff_Define, ONLY: NLTECoeff_Associated - USE CRTM_Planck_Functions, ONLY: CRTM_Planck_Temperature , & CRTM_Planck_Temperature_TL + USE CRTM_CloudCover_Define, ONLY: CRTM_CloudCover_type ! Internal variable definition modules + ! ...AtmOptics + USE AOvar_Define, ONLY: AOvar_type, & + AOvar_Associated, & + AOvar_Destroy , & + AOvar_Create ! ...CloudScatter USE CSvar_Define, ONLY: CSvar_type, & CSvar_Associated, & @@ -121,6 +125,11 @@ MODULE CRTM_Tangent_Linear_Module ASvar_Associated, & ASvar_Destroy , & ASvar_Create + ! ...Radiative transfer + USE RTV_Define, ONLY: RTV_type, & + RTV_Associated, & + RTV_Destroy , & + RTV_Create ! ----------------------- @@ -144,7 +153,7 @@ MODULE CRTM_Tangent_Linear_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Tangent_Linear_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Tangent_Linear_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS @@ -281,12 +290,8 @@ FUNCTION CRTM_Tangent_Linear( & ! Local variables CHARACTER(256) :: Message LOGICAL :: Options_Present - LOGICAL :: Check_Input - LOGICAL :: User_Emissivity, User_Direct_Reflectivity, User_N_Streams - LOGICAL :: User_AntCorr, Compute_AntCorr - LOGICAL :: Apply_NLTE_Correction + LOGICAL :: compute_antenna_correction LOGICAL :: Atmosphere_Invalid, Surface_Invalid, Geometry_Invalid, Options_Invalid - INTEGER :: RT_Algorithm_Id INTEGER :: Status_FWD, Status_TL INTEGER :: iFOV INTEGER :: n, n_Sensors, SensorIndex @@ -294,15 +299,24 @@ FUNCTION CRTM_Tangent_Linear( & INTEGER :: m, n_Profiles INTEGER :: ln INTEGER :: n_Full_Streams, mth_Azi + INTEGER :: cloud_coverage_flag REAL(fp) :: Source_ZA REAL(fp) :: Wavenumber REAL(fp) :: transmittance, transmittance_TL + REAL(fp) :: transmittance_clear, transmittance_clear_TL + REAL(fp) :: r_cloudy ! Local ancillary input structure TYPE(CRTM_AncillaryInput_type) :: AncillaryInput - ! Local options structure for default values - TYPE(CRTM_Options_type) :: Default_Options + ! Local options structure for default and use values + TYPE(CRTM_Options_type) :: Default_Options, Opt ! Local atmosphere structure for extra layering TYPE(CRTM_Atmosphere_type) :: Atm, Atm_TL + ! Clear sky structures + TYPE(CRTM_Atmosphere_type) :: Atm_Clear , Atm_Clear_TL + TYPE(CRTM_AtmOptics_type) :: AtmOptics_Clear , AtmOptics_Clear_TL + TYPE(CRTM_SfcOptics_type) :: SfcOptics_Clear , SfcOptics_Clear_TL + TYPE(CRTM_RTSolution_type) :: RTSolution_Clear, RTSolution_Clear_TL + TYPE(RTV_type) :: RTV_Clear ! Component variables TYPE(CRTM_GeometryInfo_type) :: GeometryInfo TYPE(CRTM_Predictor_type) :: Predictor, Predictor_TL @@ -316,7 +330,9 @@ FUNCTION CRTM_Tangent_Linear( & TYPE(AOvar_type) :: AOvar ! AtmOptics TYPE(RTV_type) :: RTV ! RTSolution ! NLTE correction term predictors - TYPE(NLTE_Predictor_type) :: NLTE_Predictor, NLTE_Predictor_TL + TYPE(NLTE_Predictor_type) :: NLTE_Predictor, NLTE_Predictor_TL + ! Cloud cover object + TYPE(CRTM_CloudCover_type) :: CloudCover, CloudCover_TL ! ------ @@ -371,6 +387,10 @@ FUNCTION CRTM_Tangent_Linear( & END IF + ! Reinitialise the output RTSolution + CALL CRTM_RTSolution_Zero(RTSolution) + + ! Allocate the profile independent surface optics local structure CALL CRTM_SfcOptics_Create( SfcOptics , MAX_N_ANGLES, MAX_N_STOKES ) CALL CRTM_SfcOptics_Create( SfcOptics_TL, MAX_N_ANGLES, MAX_N_STOKES ) @@ -407,62 +427,20 @@ FUNCTION CRTM_Tangent_Linear( & ! Check the optional Options structure argument - ! ...Specify default actions - Check_Input = Default_Options%Check_Input - User_Emissivity = Default_Options%Use_Emissivity - User_AntCorr = Default_Options%Use_Antenna_Correction - Apply_NLTE_Correction = Default_Options%Apply_NLTE_Correction - RT_Algorithm_Id = Default_Options%RT_Algorithm_Id - User_N_Streams = Default_Options%Use_N_Streams - ! ...Check the Options argument - IF (Options_Present) THEN - ! Override input checker with option - Check_Input = Options(m)%Check_Input - ! Check if the supplied emissivity should be used - User_Emissivity = Options(m)%Use_Emissivity - IF ( Options(m)%Use_Emissivity ) THEN - ! Are the channel dimensions consistent - IF ( Options(m)%n_Channels < n_Channels ) THEN - Error_Status = FAILURE - WRITE( Message,'( "Input Options channel dimension (", i0, ") is less ", & - &"than the number of requested channels (",i0, ")" )' ) & - Options(m)%n_Channels, n_Channels - CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) - RETURN - END IF - ! Check if the supplied direct reflectivity should be used - User_Direct_Reflectivity = Options(m)%Use_Direct_Reflectivity - END IF - ! Check if antenna correction should be attempted - User_AntCorr = Options(m)%Use_Antenna_Correction - ! Set NLTE correction option - Apply_NLTE_Correction = Options(m)%Apply_NLTE_Correction - + Opt = Default_Options + IF ( Options_Present ) THEN + Opt = Options(m) ! Copy over ancillary input AncillaryInput%SSU = Options(m)%SSU AncillaryInput%Zeeman = Options(m)%Zeeman - ! Copy over surface optics input - SfcOptics%Use_New_MWSSEM = .NOT. Options(m)%Use_Old_MWSSEM - ! Specify the RT algorithm - RT_Algorithm_Id = Options(m)%RT_Algorithm_Id - ! Check if n_Streams should be used - User_N_Streams = Options(m)%Use_N_Streams - ! Check value for nstreams - IF ( User_N_Streams ) THEN - IF ( Options(m)%n_Streams <= 0 .OR. MOD(Options(m)%n_Streams,2) /= 0 .OR. & - Options(m)%n_Streams > MAX_N_STREAMS ) THEN - Error_Status = FAILURE - WRITE( Message,'( "Input Options n_Streams (", i0, ") is invalid" )' ) & - Options(m)%n_Streams - CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) - RETURN - END IF - END IF END IF + ! ...Assign the option specific SfcOptics input + SfcOptics%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM + SfcOptics_TL%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM ! Check the input data if required - IF ( Check_Input ) THEN + IF ( Opt%Check_Input ) THEN ! ...Mandatory inputs Atmosphere_Invalid = .NOT. CRTM_Atmosphere_IsValid( Atmosphere(m) ) Surface_Invalid = .NOT. CRTM_Surface_IsValid( Surface(m) ) @@ -482,6 +460,28 @@ FUNCTION CRTM_Tangent_Linear( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF + ! Are the channel dimensions consistent if emissivity is passed? + IF ( Options(m)%Use_Emissivity ) THEN + IF ( Options(m)%n_Channels < n_Channels ) THEN + Error_Status = FAILURE + WRITE( Message,'( "Input Options channel dimension (", i0, ") is less ", & + &"than the number of requested channels (",i0, ")" )' ) & + Options(m)%n_Channels, n_Channels + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + ! Check value for user-defined n_Streams + IF ( Options(m)%Use_N_Streams ) THEN + IF ( Options(m)%n_Streams <= 0 .OR. MOD(Options(m)%n_Streams,2) /= 0 .OR. & + Options(m)%n_Streams > MAX_N_STREAMS ) THEN + Error_Status = FAILURE + WRITE( Message,'( "Input Options n_Streams (", i0, ") is invalid" )' ) & + Options(m)%n_Streams + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF END IF END IF @@ -497,11 +497,6 @@ FUNCTION CRTM_Tangent_Linear( & Source_Zenith_Angle = Source_ZA ) - ! Average surface skin temperature for multi-surface types - CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics ) - CALL CRTM_Compute_SurfaceT_TL( Surface(m), Surface_TL(m), SfcOptics_TL ) - - ! Add extra layers to current atmosphere profile ! if necessary to handle upper atmosphere Error_Status = CRTM_Atmosphere_AddLayers( Atmosphere(m), Atm ) @@ -527,7 +522,10 @@ FUNCTION CRTM_Tangent_Linear( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF - ! ...Allocate the atmospheric optics structures based on Atm extension + + + ! Prepre the atmospheric optics structures + ! ...Allocate the AtmOptics structures based on Atm extension CALL CRTM_AtmOptics_Create( AtmOptics, & Atm%n_Layers , & MAX_N_LEGENDRE_TERMS, & @@ -536,18 +534,16 @@ FUNCTION CRTM_Tangent_Linear( & Atm%n_Layers , & MAX_N_LEGENDRE_TERMS, & MAX_N_PHASE_ELEMENTS ) - IF ( .NOT. CRTM_AtmOptics_Associated( Atmoptics ) .OR. & - .NOT. CRTM_AtmOptics_Associated( Atmoptics_TL ) ) THEN + IF ( (.NOT. CRTM_AtmOptics_Associated( Atmoptics )) .OR. & + (.NOT. CRTM_AtmOptics_Associated( Atmoptics_TL )) ) THEN Error_Status = FAILURE WRITE( Message,'("Error allocating AtmOptics data structures for profile #",i0)' ) m CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF - IF (Options_Present) THEN - ! Set Scattering Switch - AtmOptics%Include_Scattering = Options(m)%Include_Scattering - AtmOptics_TL%Include_Scattering = Options(m)%Include_Scattering - END IF + ! ...Set the scattering switch + AtmOptics%Include_Scattering = Opt%Include_Scattering + AtmOptics_TL%Include_Scattering = Opt%Include_Scattering ! ...Allocate the atmospheric optics internal structure CALL AOvar_Create( AOvar, Atm%n_Layers ) @@ -571,6 +567,57 @@ FUNCTION CRTM_Tangent_Linear( & END IF + ! Determine the type of cloud coverage + cloud_coverage_flag = CRTM_Atmosphere_Coverage( atm ) + + + ! Setup for fractional cloud coverage + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + + ! Compute cloudcover + Status_FWD = CloudCover%Compute_CloudCover(atm, Overlap = opt%Overlap_Id) + Status_TL = CloudCover_TL%Compute_CloudCover_TL(CloudCover, atm, atm_TL) + IF ( Status_FWD /= SUCCESS .OR. Status_TL /= SUCCESS ) THEN + Error_Status = FAILURE + WRITE( Message,'("Error computing cloud cover for profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + + ! Allocate all the CLEAR sky structures for fractional cloud coverage + ! ...Clear sky atmosphere + Status_FWD = CRTM_Atmosphere_ClearSkyCopy(Atm, Atm_Clear) + Status_TL = CRTM_Atmosphere_ClearSkyCopy_TL(Atm, Atm_TL, Atm_Clear_TL) + IF ( Status_FWD /= SUCCESS .OR. Status_TL /= SUCCESS ) THEN + Error_status = FAILURE + WRITE( Message,'("Error copying CLEAR SKY Atmopshere structures for profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + ! ...Clear sky SfcOptics + CALL CRTM_SfcOptics_Create( SfcOptics_Clear , MAX_N_ANGLES, MAX_N_STOKES ) + CALL CRTM_SfcOptics_Create( SfcOptics_Clear_TL, MAX_N_ANGLES, MAX_N_STOKES ) + IF ( (.NOT. CRTM_SfcOptics_Associated(SfcOptics_Clear)) .OR. & + (.NOT. CRTM_SfcOptics_Associated(SfcOptics_Clear_TL))) THEN + Error_Status = FAILURE + WRITE( Message,'("Error allocating CLEAR SKY SfcOptics data structures for profile #",i0)' ) m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + ! ...Copy over surface optics input + SfcOptics_Clear%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM + SfcOptics_Clear_TL%Use_New_MWSSEM = .NOT. Opt%Use_Old_MWSSEM + ! ...CLEAR SKY average surface skin temperature for multi-surface types + CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics_Clear ) + CALL CRTM_Compute_SurfaceT_TL( Surface(m), Surface_TL(m), SfcOptics_Clear_TL ) + END IF + + + ! Average surface skin temperature for multi-surface types + CALL CRTM_Compute_SurfaceT( Surface(m), SfcOptics ) + CALL CRTM_Compute_SurfaceT_TL( Surface(m), Surface_TL(m), SfcOptics_TL ) + + ! ----------- ! SENSOR LOOP ! ----------- @@ -585,13 +632,9 @@ FUNCTION CRTM_Tangent_Linear( & ! Check if antenna correction to be applied for current sensor - IF ( User_AntCorr .AND. & - ACCoeff_Associated( SC(SensorIndex)%AC ) .AND. & - iFOV /= 0 ) THEN - Compute_AntCorr = .TRUE. - ELSE - Compute_AntCorr = .FALSE. - END IF + compute_antenna_correction = ( Opt%Use_Antenna_Correction .AND. & + ACCoeff_Associated( SC(SensorIndex)%AC ) .AND. & + iFOV /= 0 ) ! Compute predictors for AtmAbsorption calcs @@ -630,9 +673,10 @@ FUNCTION CRTM_Tangent_Linear( & ! Allocate the RTV structure if necessary - IF( (Atm%n_Clouds > 0 .OR. & - Atm%n_Aerosols > 0 .OR. & - SpcCoeff_IsVisibleSensor( SC(SensorIndex) ) ) .and. AtmOptics%Include_Scattering ) THEN + IF( ( Atm%n_Clouds > 0 .OR. & + Atm%n_Aerosols > 0 .OR. & + SpcCoeff_IsVisibleSensor(SC(SensorIndex)) ) .AND. & + AtmOptics%Include_Scattering ) THEN CALL RTV_Create( RTV, MAX_N_ANGLES, MAX_N_LEGENDRE_TERMS, Atm%n_Layers ) IF ( .NOT. RTV_Associated(RTV) ) THEN Error_Status=FAILURE @@ -642,12 +686,12 @@ FUNCTION CRTM_Tangent_Linear( & RETURN END IF ! Assign algorithm selector - RTV%RT_Algorithm_Id = RT_Algorithm_Id + RTV%RT_Algorithm_Id = Opt%RT_Algorithm_Id END IF ! Compute NLTE correction predictors - IF ( Apply_NLTE_Correction ) THEN + IF ( Opt%Apply_NLTE_Correction ) THEN CALL Compute_NLTE_Predictor( & SC(SensorIndex)%NC, & ! Input Atm , & ! Input @@ -686,11 +730,15 @@ FUNCTION CRTM_Tangent_Linear( & ! Initialisations CALL CRTM_AtmOptics_Zero( AtmOptics ) CALL CRTM_AtmOptics_Zero( AtmOptics_TL ) + CALL CRTM_AtmOptics_Zero( AtmOptics_Clear ) + CALL CRTM_AtmOptics_Zero( AtmOptics_Clear_TL ) + CALL CRTM_RTSolution_Zero( RTSolution_Clear ) + CALL CRTM_RTSolution_Zero( RTSolution_Clear_TL ) ! Determine the number of streams (n_Full_Streams) in up+downward directions - IF ( User_N_Streams ) THEN - n_Full_Streams = Options(m)%n_Streams + IF ( Opt%Use_N_Streams ) THEN + n_Full_Streams = Opt%n_Streams RTSolution(ln,m)%n_Full_Streams = n_Full_Streams + 2 RTSolution(ln,m)%Scattering_Flag = .TRUE. ELSE @@ -724,14 +772,6 @@ FUNCTION CRTM_Tangent_Linear( & AtmOptics%Optical_Depth * RTSolution_TL(ln,m)%Gamma - ! Compute the total atmospheric transmittance - ! for use in FASTEM-X reflection correction - CALL CRTM_Compute_Transmittance(AtmOptics,transmittance) - SfcOptics%Transmittance = transmittance - CALL CRTM_Compute_Transmittance_TL(AtmOptics,AtmOptics_TL,transmittance_TL) - SfcOptics_TL%Transmittance = transmittance_TL - - ! Compute the molecular scattering properties ! ...Solar radiation IF( SC(SensorIndex)%Solar_Irradiance(ChannelIndex) > ZERO .AND. & @@ -772,6 +812,25 @@ FUNCTION CRTM_Tangent_Linear( & ELSE RTV%Visible_Flag_true = .FALSE. RTV%n_Azi = 0 + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTV_Clear%Visible_Flag_true = .FALSE. + RTV_Clear%n_Azi = 0 + END IF + END IF + + + ! Copy the clear-sky AtmOptics + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + Status_FWD = CRTM_AtmOptics_NoScatterCopy( AtmOptics, AtmOptics_Clear ) + Status_TL = CRTM_AtmOptics_NoScatterCopy_TL( AtmOptics, AtmOptics_TL, AtmOptics_Clear_TL ) + IF ( Status_FWD /= SUCCESS .OR. Status_TL /= SUCCESS ) THEN + Error_Status = FAILURE + WRITE( Message,'("Error copying CLEAR SKY AtmOptics for ",a,& + &", channel ",i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF END IF @@ -827,34 +886,53 @@ FUNCTION CRTM_Tangent_Linear( & ! Compute the combined atmospheric optical properties IF( AtmOptics%Include_Scattering ) THEN - CALL CRTM_Combine_AtmOptics( AtmOptics, AOvar ) - CALL CRTM_Combine_AtmOptics_TL( AtmOptics, AtmOptics_TL, AOvar ) + CALL CRTM_AtmOptics_Combine( AtmOptics, AOvar ) + CALL CRTM_AtmOptics_Combine_TL( AtmOptics, AtmOptics_TL, AOvar ) END IF ! ...Save vertically integrated scattering optical depth for output - RTSolution(ln,m)%SOD = AtmOptics%Scattering_Optical_Depth + RTSolution(ln,m)%SOD = AtmOptics%Scattering_Optical_Depth + RTSolution_TL(ln,m)%SOD = AtmOptics_TL%Scattering_Optical_Depth - ! Turn off FASTEM-X reflection correction for scattering conditions - IF ( CRTM_Include_Scattering(AtmOptics) .AND. SpcCoeff_IsMicrowaveSensor( SC(SensorIndex) ) ) THEN - SfcOptics%Transmittance = -ONE - ELSE - SfcOptics%Transmittance = transmittance + ! Compute the all-sky atmospheric transmittance + ! for use in FASTEM-X reflection correction + CALL CRTM_Compute_Transmittance(AtmOptics,transmittance) + SfcOptics%Transmittance = transmittance + CALL CRTM_Compute_Transmittance_TL(AtmOptics,AtmOptics_TL,transmittance_TL) + SfcOptics_TL%Transmittance = transmittance_TL + ! ...Clear sky for fractional cloud cover + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + CALL CRTM_Compute_Transmittance(AtmOptics_Clear,transmittance_clear) + SfcOptics_Clear%Transmittance = transmittance_clear + CALL CRTM_Compute_Transmittance_TL(AtmOptics_Clear,AtmOptics_Clear_TL,transmittance_clear_TL) + SfcOptics_Clear_TL%Transmittance = transmittance_clear_TL END IF ! Fill the SfcOptics structure for the optional emissivity input case. - ! ...Indicate SfcOptics ARE to be computed - SfcOptics%Compute = .TRUE. - ! ...Change SfcOptics emissivity/reflectivity contents/computation status - IF ( User_Emissivity ) THEN + SfcOptics%Compute = .TRUE. + SfcOptics_Clear%Compute = .TRUE. + IF ( Opt%Use_Emissivity ) THEN + ! ...Cloudy/all-sky case SfcOptics%Compute = .FALSE. - SfcOptics%Emissivity(1,1) = Options(m)%Emissivity(ln) - SfcOptics%Reflectivity(1,1,1,1) = ONE - Options(m)%Emissivity(ln) - IF ( User_Direct_Reflectivity ) THEN - SfcOptics%Direct_Reflectivity(1,1) = Options(m)%Direct_Reflectivity(ln) + SfcOptics%Emissivity(1,1) = Opt%Emissivity(ln) + SfcOptics%Reflectivity(1,1,1,1) = ONE - Opt%Emissivity(ln) + IF ( Opt%Use_Direct_Reflectivity ) THEN + SfcOptics%Direct_Reflectivity(1,1) = Opt%Direct_Reflectivity(ln) ELSE SfcOptics%Direct_Reflectivity(1,1) = SfcOptics%Reflectivity(1,1,1,1) END IF + ! ...Repeat for fractional clear-sky case + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + SfcOptics_Clear%Compute = .FALSE. + SfcOptics_Clear%Emissivity(1,1) = Opt%Emissivity(ln) + SfcOptics_Clear%Reflectivity(1,1,1,1) = ONE - Opt%Emissivity(ln) + IF ( Opt%Use_Direct_Reflectivity ) THEN + SfcOptics_Clear%Direct_Reflectivity(1,1) = Opt%Direct_Reflectivity(ln) + ELSE + SfcOptics_Clear%Direct_Reflectivity(1,1) = SfcOptics%Reflectivity(1,1,1,1) + END IF + END IF END IF @@ -912,74 +990,176 @@ FUNCTION CRTM_Tangent_Linear( & CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) RETURN END IF + + + ! Do clear-sky calculation for fractionally cloudy atmospheres + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + RTV_Clear%mth_Azi = mth_Azi + SfcOptics_Clear%mth_Azi = mth_Azi + ! ...Forward model + Error_Status = CRTM_Compute_RTSolution( & + Atm_Clear , & ! Input + Surface(m) , & ! Input + AtmOptics_Clear , & ! Input + SfcOptics_Clear , & ! Input + GeometryInfo , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + RTSolution_Clear, & ! Output + RTV_Clear ) ! Internal variable output + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'( "Error computing CLEAR SKY RTSolution for ", a, & + &", channel ", i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + + ! ...Tangent-linear model + Error_Status = CRTM_Compute_RTSolution_TL( & + Atm_Clear , & ! FWD Input + Surface(m) , & ! FWD Input + AtmOptics_Clear , & ! FWD Input + SfcOptics_Clear , & ! FWD Input + RTSolution_Clear , & ! FWD Input + Atm_Clear_TL , & ! TL Input + Surface_TL(m) , & ! TL Input + AtmOptics_Clear_TL , & ! TL Input + SfcOptics_Clear_TL , & ! TL Input + GeometryInfo , & ! Input + SensorIndex , & ! Input + ChannelIndex , & ! Input + RTSolution_Clear_TL, & ! TL Output + RTV_Clear ) ! Internal variable input + IF ( Error_Status /= SUCCESS ) THEN + WRITE( Message,'( "Error computing CLEAR SKY RTSolution_TL for ", a, & + &", channel ", i0,", profile #",i0)' ) & + TRIM(ChannelInfo(n)%Sensor_ID), ChannelInfo(n)%Sensor_Channel(l), m + CALL Display_Message( ROUTINE_NAME, Message, Error_Status ) + RETURN + END IF + END IF + END DO Azimuth_Fourier_Loop - ! Compute non-LTE correction to radiance if required - IF ( Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) THEN - CALL Compute_NLTE_Correction( & - SC(SensorIndex)%NC , & ! Input - ChannelIndex , & ! Input - NLTE_Predictor , & ! Input - RTSolution(ln,m)%Radiance ) ! In/Output - CALL Compute_NLTE_Correction_TL( & - SC(SensorIndex)%NC , & ! Input - ChannelIndex , & ! Input - NLTE_Predictor_TL , & ! Input - RTSolution_TL(ln,m)%Radiance ) ! In/Output - END IF - ! Convert the radiance to brightness temperature - CALL CRTM_Planck_Temperature( & - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m)%Radiance , & ! Input - RTSolution(ln,m)%Brightness_Temperature ) ! Output - CALL CRTM_Planck_Temperature_TL( & - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m)%Radiance , & ! Input - RTSolution_TL(ln,m)%Radiance , & ! Input - RTSolution_TL(ln,m)%Brightness_Temperature ) ! Output - - ! Compute Antenna correction to brightness temperature if required - IF ( Compute_AntCorr ) THEN - CALL CRTM_Compute_AntCorr( & - GeometryInfo , & ! Input - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution(ln,m) ) ! Output - CALL CRTM_Compute_AntCorr_TL( & - GeometryInfo , & ! Input - SensorIndex , & ! Input - ChannelIndex , & ! Input - RTSolution_TL(ln,m) ) ! Output + ! 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?) + r_cloudy = RTSolution(ln,m)%Radiance + ! ...Forward radiance + RTSolution(ln,m)%Radiance = & + ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_Clear%Radiance) + & + (CloudCover%Total_Cloud_Cover * RTSolution(ln,m)%Radiance) + ! ...Tangent-linear radince + RTSolution_TL(ln,m)%Radiance = & + ((r_cloudy - RTSolution_Clear%Radiance) * CloudCover_TL%Total_Cloud_Cover) + & + ((ONE - CloudCover%Total_Cloud_Cover) * RTSolution_Clear_TL%Radiance ) + & + (CloudCover%Total_Cloud_Cover * RTSolution_TL(ln,m)%Radiance ) + ! ...Save the cloud cover in the output structures + RTSolution(ln,m)%Total_Cloud_Cover = CloudCover%Total_Cloud_Cover + RTSolution_TL(ln,m)%Total_Cloud_Cover = CloudCover_TL%Total_Cloud_Cover END IF - END DO Channel_Loop - - ! Deallocate local sensor dependent data structures - ! ...RTV structure - IF ( RTV_Associated(RTV) ) CALL RTV_Destroy(RTV) - ! ...Predictor structures - CALL CRTM_Predictor_Destroy( Predictor ) - CALL CRTM_Predictor_Destroy( Predictor_TL ) - END DO Sensor_Loop + ! The radiance post-processing + CALL Post_Process_RTSolution(RTSolution(ln,m), RTSolution_TL(ln,m)) + + + ! Perform clear-sky post-processing + IF ( CRTM_Atmosphere_IsFractional(cloud_coverage_flag) ) THEN + CALL Post_Process_RTSolution(RTSolution_Clear, RTSolution_Clear_TL) + ! ...Save the results in the output structure + RTSolution(ln,m)%R_Clear = RTSolution_Clear%Radiance + RTSolution(ln,m)%Tb_Clear = RTSolution_Clear%Brightness_Temperature + RTSolution_TL(ln,m)%R_Clear = RTSolution_Clear_TL%Radiance + RTSolution_TL(ln,m)%Tb_Clear = RTSolution_Clear_TL%Brightness_Temperature + END IF + END DO Channel_Loop - ! Deallocate local sensor independent data structures - ! ...Atmospheric optics - CALL CRTM_AtmOptics_Destroy( AtmOptics ) - CALL CRTM_AtmOptics_Destroy( AtmOptics_TL ) + END DO Sensor_Loop END DO Profile_Loop - ! Destroy any remaining structures + ! Clean up + CALL CRTM_Predictor_Destroy( Predictor ) + CALL CRTM_Predictor_Destroy( Predictor_TL ) + CALL CRTM_AtmOptics_Destroy( AtmOptics ) + CALL CRTM_AtmOptics_Destroy( AtmOptics_TL ) + CALL CRTM_AtmOptics_Destroy( AtmOptics_Clear ) + CALL CRTM_AtmOptics_Destroy( AtmOptics_Clear_TL ) CALL CRTM_SfcOptics_Destroy( SfcOptics ) CALL CRTM_SfcOptics_Destroy( SfcOptics_TL ) - CALL CRTM_Atmosphere_Destroy( Atm_TL ) + CALL CRTM_SfcOptics_Destroy( SfcOptics_Clear ) + CALL CRTM_SfcOptics_Destroy( SfcOptics_Clear_TL ) CALL CRTM_Atmosphere_Destroy( Atm ) + CALL CRTM_Atmosphere_Destroy( Atm_TL ) + CALL CRTM_Atmosphere_Destroy( Atm_Clear ) + CALL CRTM_Atmosphere_Destroy( Atm_Clear_TL ) + ! ...Internal variables + CALL AOvar_Destroy( AOvar ) + CALL CSvar_Destroy( CSvar ) + CALL ASvar_Destroy( ASvar ) + CALL RTV_Destroy( RTV ) + + + CONTAINS + + + ! ---------------------------------------------------------------- + ! Local subroutine to post-process the radiance, as it is the same + ! for all-sky and fractional clear-sky cases. + ! + ! 1. Apply non-LTE correction to radiances + ! 2. Convert radiances to brightness temperatures + ! 3. Apply antenna correction to brightness temperatures + ! ---------------------------------------------------------------- + + SUBROUTINE Post_Process_RTSolution(rts, rts_TL) + TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: rts, rts_TL + + ! Compute non-LTE correction to radiance if required + IF ( Opt%Apply_NLTE_Correction .AND. NLTE_Predictor_IsActive(NLTE_Predictor) ) THEN + CALL Compute_NLTE_Correction( & + SC(SensorIndex)%NC, & ! Input + ChannelIndex , & ! Input + NLTE_Predictor , & ! Input + rts%Radiance ) ! In/Output + CALL Compute_NLTE_Correction_TL( & + SC(SensorIndex)%NC, & ! Input + ChannelIndex , & ! Input + NLTE_Predictor_TL , & ! Input + rts_TL%Radiance ) ! In/Output + END IF + ! Convert the radiance to brightness temperature + CALL CRTM_Planck_Temperature( & + SensorIndex , & ! Input + ChannelIndex , & ! Input + rts%Radiance , & ! Input + rts%Brightness_Temperature ) ! Output + CALL CRTM_Planck_Temperature_TL( & + SensorIndex , & ! Input + ChannelIndex , & ! Input + rts%Radiance , & ! Input + rts_TL%Radiance , & ! Input + rts_TL%Brightness_Temperature ) ! Output + ! Compute Antenna correction to brightness temperature if required + IF ( compute_antenna_correction ) THEN + CALL CRTM_Compute_AntCorr( & + GeometryInfo, & ! Input + SensorIndex , & ! Input + ChannelIndex, & ! Input + rts ) ! Output + CALL CRTM_Compute_AntCorr_TL( & + GeometryInfo, & ! Input + SensorIndex , & ! Input + ChannelIndex, & ! Input + rts_TL ) ! Output + END IF + + END SUBROUTINE Post_Process_RTSolution END FUNCTION CRTM_Tangent_Linear diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_TauCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_TauCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_TauCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_TauCoeff.f90 index b635671f15..bc1b700642 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_TauCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_TauCoeff.f90 @@ -73,7 +73,7 @@ MODULE CRTM_TauCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: CRTM_TauCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_TauCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! -------------------------------------- diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_Utility.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_Utility.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_Utility.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_Utility.f90 index 278c65ef2b..4b3b9eddf1 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_Utility.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Utility.f90 @@ -56,7 +56,7 @@ MODULE CRTM_UTILITY ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_Utility.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_Utility.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Numerical small threshold value in Eigensystem REAL(fp), PARAMETER :: EIGEN_THRESHOLD = 1.0e-20_fp diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_VIS_Ice_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_VIS_Ice_SfcOptics.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_VIS_Ice_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_VIS_Ice_SfcOptics.f90 index 1e69c33487..65a91aa309 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_VIS_Ice_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_VIS_Ice_SfcOptics.f90 @@ -49,7 +49,7 @@ MODULE CRTM_VIS_Ice_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_VIS_Ice_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_VIS_Ice_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_VIS_Land_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_VIS_Land_SfcOptics.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_VIS_Land_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_VIS_Land_SfcOptics.f90 index e1b99885f1..d758aeb904 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_VIS_Land_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_VIS_Land_SfcOptics.f90 @@ -49,7 +49,7 @@ MODULE CRTM_VIS_Land_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_VIS_Land_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_VIS_Land_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_VIS_Snow_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_VIS_Snow_SfcOptics.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_VIS_Snow_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_VIS_Snow_SfcOptics.f90 index 641707cc58..92c84c0de4 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_VIS_Snow_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_VIS_Snow_SfcOptics.f90 @@ -49,7 +49,7 @@ MODULE CRTM_VIS_Snow_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_VIS_Snow_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_VIS_Snow_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_VIS_Water_SfcOptics.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_VIS_Water_SfcOptics.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_VIS_Water_SfcOptics.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_VIS_Water_SfcOptics.f90 index 71db6513cb..d059afb009 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_VIS_Water_SfcOptics.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_VIS_Water_SfcOptics.f90 @@ -49,7 +49,7 @@ MODULE CRTM_VIS_Water_SfcOptics ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_VIS_Water_SfcOptics.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_VIS_Water_SfcOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_VISiceCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_VISiceCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_VISiceCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_VISiceCoeff.f90 index c2a6fbde5c..48dd34f6e6 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_VISiceCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_VISiceCoeff.f90 @@ -53,7 +53,7 @@ MODULE CRTM_VISiceCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_VISiceCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_VISiceCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 512 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_VISlandCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_VISlandCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_VISlandCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_VISlandCoeff.f90 index 26337cee39..fec23944dd 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_VISlandCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_VISlandCoeff.f90 @@ -53,7 +53,7 @@ MODULE CRTM_VISlandCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_VISlandCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_VISlandCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 512 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_VISsnowCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_VISsnowCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_VISsnowCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_VISsnowCoeff.f90 index 2d2c097fbf..6074bfe5bd 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_VISsnowCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_VISsnowCoeff.f90 @@ -53,7 +53,7 @@ MODULE CRTM_VISsnowCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_VISsnowCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_VISsnowCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 512 diff --git a/var/external/crtm_2.2.3/libsrc/CRTM_VISwaterCoeff.f90 b/var/external/crtm_2.3.0/libsrc/CRTM_VISwaterCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CRTM_VISwaterCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/CRTM_VISwaterCoeff.f90 index 7c36da842e..342a864eb5 100644 --- a/var/external/crtm_2.2.3/libsrc/CRTM_VISwaterCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/CRTM_VISwaterCoeff.f90 @@ -53,7 +53,7 @@ MODULE CRTM_VISwaterCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CRTM_VISwaterCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CRTM_VISwaterCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 512 diff --git a/var/external/crtm_2.3.0/libsrc/CRTM_Version.inc b/var/external/crtm_2.3.0/libsrc/CRTM_Version.inc new file mode 100644 index 0000000000..18af496b45 --- /dev/null +++ b/var/external/crtm_2.3.0/libsrc/CRTM_Version.inc @@ -0,0 +1 @@ +'v2.3.0' diff --git a/var/external/crtm_2.2.3/libsrc/CSvar_Define.f90 b/var/external/crtm_2.3.0/libsrc/CSvar_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CSvar_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CSvar_Define.f90 index 06e5ec6760..3eb0e307ae 100644 --- a/var/external/crtm_2.2.3/libsrc/CSvar_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CSvar_Define.f90 @@ -64,7 +64,7 @@ MODULE CSvar_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CSvar_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CSvar_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: CSVAR_RELEASE = 1 ! This determines structure and file formats. INTEGER, PARAMETER :: CSVAR_VERSION = 1 ! This is just the default data version. diff --git a/var/external/crtm_2.2.3/libsrc/CloudCoeff_Binary_IO.f90 b/var/external/crtm_2.3.0/libsrc/CloudCoeff_Binary_IO.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CloudCoeff_Binary_IO.f90 rename to var/external/crtm_2.3.0/libsrc/CloudCoeff_Binary_IO.f90 index bcbd16c723..6cf7555c80 100644 --- a/var/external/crtm_2.2.3/libsrc/CloudCoeff_Binary_IO.f90 +++ b/var/external/crtm_2.3.0/libsrc/CloudCoeff_Binary_IO.f90 @@ -43,7 +43,7 @@ MODULE CloudCoeff_Binary_IO ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CloudCoeff_Binary_IO.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CloudCoeff_Binary_IO.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE' ! Default message length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/CloudCoeff_Define.f90 b/var/external/crtm_2.3.0/libsrc/CloudCoeff_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/CloudCoeff_Define.f90 rename to var/external/crtm_2.3.0/libsrc/CloudCoeff_Define.f90 index 2b22f8e38d..d59afc302c 100644 --- a/var/external/crtm_2.2.3/libsrc/CloudCoeff_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/CloudCoeff_Define.f90 @@ -56,7 +56,7 @@ MODULE CloudCoeff_Define ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: CloudCoeff_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: CloudCoeff_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! CloudCoeff init values REAL(Double), PARAMETER :: ZERO = 0.0_Double ! Keyword set value diff --git a/var/external/crtm_2.2.3/libsrc/Common_RTSolution.f90 b/var/external/crtm_2.3.0/libsrc/Common_RTSolution.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Common_RTSolution.f90 rename to var/external/crtm_2.3.0/libsrc/Common_RTSolution.f90 index 604dc4f9aa..a3e84d17b6 100644 --- a/var/external/crtm_2.2.3/libsrc/Common_RTSolution.f90 +++ b/var/external/crtm_2.3.0/libsrc/Common_RTSolution.f90 @@ -238,6 +238,8 @@ FUNCTION Assign_Common_Input( & ! Assign only the optical depth profile ! defined by the user input layering RTSolution%Layer_Optical_Depth(1:no) = AtmOptics%Optical_Depth(na+1:nt) + RTSolution%Single_Scatter_Albedo(1:no) = AtmOptics%Single_Scatter_Albedo(na+1:nt) + RTSolution%SSA_Max = MAXVAL(AtmOptics%Single_Scatter_Albedo) END IF ! Required SpcCoeff components RTV%Cosmic_Background_Radiance = SC(SensorIndex)%Cosmic_Background_Radiance(ChannelIndex) diff --git a/var/external/crtm_2.2.3/libsrc/Compare_Float_Numbers.f90 b/var/external/crtm_2.3.0/libsrc/Compare_Float_Numbers.f90 similarity index 95% rename from var/external/crtm_2.2.3/libsrc/Compare_Float_Numbers.f90 rename to var/external/crtm_2.3.0/libsrc/Compare_Float_Numbers.f90 index a22864470d..278096bab0 100644 --- a/var/external/crtm_2.2.3/libsrc/Compare_Float_Numbers.f90 +++ b/var/external/crtm_2.3.0/libsrc/Compare_Float_Numbers.f90 @@ -27,6 +27,8 @@ MODULE Compare_Float_Numbers ! ------------ PRIVATE ! Parameters + PUBLIC :: SP_N_SIGFIG + PUBLIC :: DP_N_SIGFIG PUBLIC :: DEFAULT_N_SIGFIG ! Operators PUBLIC :: OPERATOR (.EqualTo.) @@ -85,7 +87,7 @@ MODULE Compare_Float_Numbers ! ----------------- ! Module Version Id CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Compare_Float_Numbers.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Compare_Float_Numbers.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Numeric literals REAL(Single), PARAMETER :: SP_ZERO = 0.0_Single REAL(Double), PARAMETER :: DP_ZERO = 0.0_Double @@ -95,10 +97,16 @@ MODULE Compare_Float_Numbers REAL(Double), PARAMETER :: DP_TEN = 10.0_Double REAL(Single), PARAMETER :: SP_HUNDRED = 100.0_Single REAL(Double), PARAMETER :: DP_HUNDRED = 100.0_Double - REAL(Single), PARAMETER :: SP_COMPARE_CUTOFF = 1.0e-15_Single - REAL(Double), PARAMETER :: DP_COMPARE_CUTOFF = 1.0e-15_Double + ! Default cutoff value for comparisons + REAL(Single), PARAMETER :: SP_COMPARE_CUTOFF = TINY(1.0_Single) + REAL(Double), PARAMETER :: DP_COMPARE_CUTOFF = TINY(1.0_Double) + ! Minimum exponents for precisions + INTEGER, PARAMETER :: SP_MIN_EXPONENT = -RANGE(1.0_Single) + INTEGER, PARAMETER :: DP_MIN_EXPONENT = -RANGE(1.0_Double) ! Default number of significant figures - INTEGER, PARAMETER :: DEFAULT_N_SIGFIG = 6 + INTEGER, PARAMETER :: SP_N_SIGFIG = 7 + INTEGER, PARAMETER :: DP_N_SIGFIG = 15 + INTEGER, PARAMETER :: DEFAULT_N_SIGFIG = SP_N_SIGFIG CONTAINS @@ -527,7 +535,7 @@ END FUNCTION Compare_Complex_Double ! specified number of significant figures. ! ! CALLING SEQUENCE: -! Result = Tolerance( x, n ) +! tol = Tolerance( x, n ) ! ! INPUT ARGUMENTS: ! x: Floating point value for which a tolerance value is required. @@ -546,15 +554,15 @@ END FUNCTION Compare_Complex_Double ! tolerance is required. ! UNITS: N/A ! TYPE: INTEGER -! DIMENSION: Scalar or same as input x. +! DIMENSION: Conformable with input x. ! ATTRIBUTES: INTENT(IN) ! ! FUNCTION RESULT: -! Result: The return value is a tolerance value that can be used to +! tol: The return value is a tolerance value that can be used to ! compare two numbers. ! UNITS: N/A ! TYPE: Same as input x. -! DIMENSION: Same as input x. +! DIMENSION: Conformable with input x. !:sdoc-: !---------------------------------------------------------------------------------- @@ -565,10 +573,11 @@ ELEMENTAL FUNCTION Tolerance_Real_Single(x,n) RESULT( Tolerance ) INTEGER :: e IF (ABS(x) > SP_ZERO) THEN e = FLOOR(LOG10(ABS(x))) - n - Tolerance = SP_TEN**e ELSE - Tolerance = SP_ONE + e = -n END IF + e = MAX(e,SP_MIN_EXPONENT) + Tolerance = SP_TEN**e END FUNCTION Tolerance_Real_Single ELEMENTAL FUNCTION Tolerance_Real_Double(x,n) RESULT( Tolerance ) @@ -578,10 +587,11 @@ ELEMENTAL FUNCTION Tolerance_Real_Double(x,n) RESULT( Tolerance ) INTEGER :: e IF (ABS(x) > DP_ZERO) THEN e = FLOOR(LOG10(ABS(x))) - n - Tolerance = DP_TEN**e ELSE - Tolerance = DP_ONE + e = -n END IF + e = MAX(e,DP_MIN_EXPONENT) + Tolerance = DP_TEN**e END FUNCTION Tolerance_Real_Double ELEMENTAL FUNCTION Tolerance_Complex_Single(x,n) RESULT( Tolerance ) @@ -641,8 +651,7 @@ END FUNCTION Tolerance_Complex_Double ! OPTIONAL INPUTS: ! cutoff: Floating point value below which the comparison is not ! performed. In this case, the function result will be .TRUE. -! If not specified, the default value is 1.0e-15 for real -! input, or (1.0e-15,1.0e-15) for complex input. +! If not specified, the default value is TINY(). ! UNITS: N/A ! TYPE: Same as input x ! DIMENSION: Scalar or same as input x, y. diff --git a/var/external/crtm_2.2.3/libsrc/DateTime_Utility.f90 b/var/external/crtm_2.3.0/libsrc/DateTime_Utility.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/DateTime_Utility.f90 rename to var/external/crtm_2.3.0/libsrc/DateTime_Utility.f90 index ff12bd967a..66abd797d5 100644 --- a/var/external/crtm_2.2.3/libsrc/DateTime_Utility.f90 +++ b/var/external/crtm_2.3.0/libsrc/DateTime_Utility.f90 @@ -45,7 +45,7 @@ MODULE DateTime_Utility ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: DateTime_Utility.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: DateTime_Utility.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' INTEGER, PARAMETER :: NL = 20 diff --git a/var/external/crtm_2.2.3/libsrc/Date_Utility.f90 b/var/external/crtm_2.3.0/libsrc/Date_Utility.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Date_Utility.f90 rename to var/external/crtm_2.3.0/libsrc/Date_Utility.f90 index 8a516a3526..a820f1224c 100644 --- a/var/external/crtm_2.2.3/libsrc/Date_Utility.f90 +++ b/var/external/crtm_2.3.0/libsrc/Date_Utility.f90 @@ -39,7 +39,7 @@ MODULE Date_Utility ! Parameters ! ---------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Date_Utility.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Date_Utility.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! String length for character functions INTEGER, PARAMETER :: NL = 20 ! Number of Months in a Year diff --git a/var/external/crtm_2.2.3/libsrc/Ellison.f90 b/var/external/crtm_2.3.0/libsrc/Ellison.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Ellison.f90 rename to var/external/crtm_2.3.0/libsrc/Ellison.f90 index 98f759cb5d..a0bce2d78c 100644 --- a/var/external/crtm_2.2.3/libsrc/Ellison.f90 +++ b/var/external/crtm_2.3.0/libsrc/Ellison.f90 @@ -46,7 +46,7 @@ MODULE Ellison ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Ellison.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Ellison.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: POINT5 = 0.5_fp REAL(fp), PARAMETER :: ONE = 1.0_fp diff --git a/var/external/crtm_2.2.3/libsrc/Emission_Module.f90 b/var/external/crtm_2.3.0/libsrc/Emission_Module.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/Emission_Module.f90 rename to var/external/crtm_2.3.0/libsrc/Emission_Module.f90 diff --git a/var/external/crtm_2.2.3/libsrc/Endian_Utility.f90 b/var/external/crtm_2.3.0/libsrc/Endian_Utility.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Endian_Utility.f90 rename to var/external/crtm_2.3.0/libsrc/Endian_Utility.f90 index 5a9302aa28..b05037e0a5 100644 --- a/var/external/crtm_2.2.3/libsrc/Endian_Utility.f90 +++ b/var/external/crtm_2.3.0/libsrc/Endian_Utility.f90 @@ -556,11 +556,11 @@ END MODULE Endian_Utility ! -- MODIFICATION HISTORY -- !------------------------------------------------------------------------------- ! -! $Id: Endian_Utility.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $ +! $Id: Endian_Utility.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $ ! ! $Date: 2004/12/01 19:35:15 $ ! -! $Revision: 60152 $ +! $Revision: 99117 $ ! ! $State: Exp $ ! diff --git a/var/external/crtm_2.2.3/libsrc/File_Utility.f90 b/var/external/crtm_2.3.0/libsrc/File_Utility.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/File_Utility.f90 rename to var/external/crtm_2.3.0/libsrc/File_Utility.f90 index 125f631dd8..7494174b2d 100644 --- a/var/external/crtm_2.2.3/libsrc/File_Utility.f90 +++ b/var/external/crtm_2.3.0/libsrc/File_Utility.f90 @@ -350,11 +350,11 @@ END MODULE File_Utility ! -- MODIFICATION HISTORY -- !------------------------------------------------------------------------------- ! -! $Id: File_Utility.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $ +! $Id: File_Utility.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $ ! ! $Date: 2006/03/17 21:05:12 $ ! -! $Revision: 60152 $ +! $Revision: 99117 $ ! ! $Name: $ ! diff --git a/var/external/crtm_2.2.3/libsrc/FitCoeff_Define.f90 b/var/external/crtm_2.3.0/libsrc/FitCoeff_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/FitCoeff_Define.f90 rename to var/external/crtm_2.3.0/libsrc/FitCoeff_Define.f90 index 1be292a467..261b38fbdb 100644 --- a/var/external/crtm_2.2.3/libsrc/FitCoeff_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/FitCoeff_Define.f90 @@ -120,7 +120,7 @@ MODULE FitCoeff_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: FitCoeff_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: FitCoeff_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: FITCOEFF_RELEASE = 1 ! This determines structure and file formats. INTEGER, PARAMETER :: FITCOEFF_VERSION = 1 ! This is just the default data version. diff --git a/var/external/crtm_2.2.3/libsrc/FitCoeff_Destroy.inc b/var/external/crtm_2.3.0/libsrc/FitCoeff_Destroy.inc similarity index 100% rename from var/external/crtm_2.2.3/libsrc/FitCoeff_Destroy.inc rename to var/external/crtm_2.3.0/libsrc/FitCoeff_Destroy.inc diff --git a/var/external/crtm_2.2.3/libsrc/FitCoeff_Equal.inc b/var/external/crtm_2.3.0/libsrc/FitCoeff_Equal.inc similarity index 100% rename from var/external/crtm_2.2.3/libsrc/FitCoeff_Equal.inc rename to var/external/crtm_2.3.0/libsrc/FitCoeff_Equal.inc diff --git a/var/external/crtm_2.2.3/libsrc/FitCoeff_Info.inc b/var/external/crtm_2.3.0/libsrc/FitCoeff_Info.inc similarity index 100% rename from var/external/crtm_2.2.3/libsrc/FitCoeff_Info.inc rename to var/external/crtm_2.3.0/libsrc/FitCoeff_Info.inc diff --git a/var/external/crtm_2.2.3/libsrc/FitCoeff_ReadFile.inc b/var/external/crtm_2.3.0/libsrc/FitCoeff_ReadFile.inc similarity index 100% rename from var/external/crtm_2.2.3/libsrc/FitCoeff_ReadFile.inc rename to var/external/crtm_2.3.0/libsrc/FitCoeff_ReadFile.inc diff --git a/var/external/crtm_2.2.3/libsrc/FitCoeff_SetValue.inc b/var/external/crtm_2.3.0/libsrc/FitCoeff_SetValue.inc similarity index 100% rename from var/external/crtm_2.2.3/libsrc/FitCoeff_SetValue.inc rename to var/external/crtm_2.3.0/libsrc/FitCoeff_SetValue.inc diff --git a/var/external/crtm_2.2.3/libsrc/FitCoeff_WriteFile.inc b/var/external/crtm_2.3.0/libsrc/FitCoeff_WriteFile.inc similarity index 100% rename from var/external/crtm_2.2.3/libsrc/FitCoeff_WriteFile.inc rename to var/external/crtm_2.3.0/libsrc/FitCoeff_WriteFile.inc diff --git a/var/external/crtm_2.2.3/libsrc/Foam_Utility_Module.f90 b/var/external/crtm_2.3.0/libsrc/Foam_Utility_Module.f90 similarity index 98% rename from var/external/crtm_2.2.3/libsrc/Foam_Utility_Module.f90 rename to var/external/crtm_2.3.0/libsrc/Foam_Utility_Module.f90 index eed0c2d056..4659d52247 100644 --- a/var/external/crtm_2.2.3/libsrc/Foam_Utility_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/Foam_Utility_Module.f90 @@ -36,7 +36,7 @@ MODULE Foam_Utility_Module ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Foam_Utility_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Foam_Utility_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(fp), PARAMETER :: ZERO = 0.0_fp diff --git a/var/external/crtm_2.2.3/libsrc/Fresnel.f90 b/var/external/crtm_2.3.0/libsrc/Fresnel.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Fresnel.f90 rename to var/external/crtm_2.3.0/libsrc/Fresnel.f90 index 9cf1316410..0970739d3f 100644 --- a/var/external/crtm_2.2.3/libsrc/Fresnel.f90 +++ b/var/external/crtm_2.3.0/libsrc/Fresnel.f90 @@ -35,7 +35,7 @@ MODULE Fresnel ! ----------------- ! RCS Id for the module CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: Fresnel.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Fresnel.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: POINT5 = 0.5_fp REAL(fp), PARAMETER :: ONE = 1.0_fp diff --git a/var/external/crtm_2.2.3/libsrc/Fundamental_Constants.f90 b/var/external/crtm_2.3.0/libsrc/Fundamental_Constants.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Fundamental_Constants.f90 rename to var/external/crtm_2.3.0/libsrc/Fundamental_Constants.f90 index 5544795743..f1bd4491ec 100644 --- a/var/external/crtm_2.2.3/libsrc/Fundamental_Constants.f90 +++ b/var/external/crtm_2.3.0/libsrc/Fundamental_Constants.f90 @@ -45,7 +45,7 @@ MODULE Fundamental_Constants ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Fundamental_Constants.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Fundamental_Constants.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Numeric literals REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: ONE = 1.0_fp diff --git a/var/external/crtm_2.2.3/libsrc/Guillou.f90 b/var/external/crtm_2.3.0/libsrc/Guillou.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Guillou.f90 rename to var/external/crtm_2.3.0/libsrc/Guillou.f90 index 4ce27a3875..2685d7846a 100644 --- a/var/external/crtm_2.2.3/libsrc/Guillou.f90 +++ b/var/external/crtm_2.3.0/libsrc/Guillou.f90 @@ -44,7 +44,7 @@ MODULE Guillou ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Guillou.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Guillou.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: POINT5 = 0.5_fp REAL(fp), PARAMETER :: ONE = 1.0_fp diff --git a/var/external/crtm_2.2.3/libsrc/Hyperbolic_Step.f90 b/var/external/crtm_2.3.0/libsrc/Hyperbolic_Step.f90 similarity index 98% rename from var/external/crtm_2.2.3/libsrc/Hyperbolic_Step.f90 rename to var/external/crtm_2.3.0/libsrc/Hyperbolic_Step.f90 index 0fca1479f9..aa3a86a40e 100644 --- a/var/external/crtm_2.2.3/libsrc/Hyperbolic_Step.f90 +++ b/var/external/crtm_2.3.0/libsrc/Hyperbolic_Step.f90 @@ -31,7 +31,7 @@ MODULE Hyperbolic_Step ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Hyperbolic_Step.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Hyperbolic_Step.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literals REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: POINT5 = 0.5_fp diff --git a/var/external/crtm_2.2.3/libsrc/IRwaterCoeff_Define.f90 b/var/external/crtm_2.3.0/libsrc/IRwaterCoeff_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/IRwaterCoeff_Define.f90 rename to var/external/crtm_2.3.0/libsrc/IRwaterCoeff_Define.f90 index 44e9afed72..120e8677b4 100644 --- a/var/external/crtm_2.2.3/libsrc/IRwaterCoeff_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/IRwaterCoeff_Define.f90 @@ -60,7 +60,7 @@ MODULE IRwaterCoeff_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: IRwaterCoeff_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: IRwaterCoeff_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Current valid release and version INTEGER, PARAMETER :: IRWATERCOEFF_RELEASE = 3 ! This determines structure and file formats. INTEGER, PARAMETER :: IRWATERCOEFF_VERSION = 2 ! This is just the default data version. diff --git a/var/external/crtm_2.2.3/libsrc/LSEatlas_Define.f90 b/var/external/crtm_2.3.0/libsrc/LSEatlas_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/LSEatlas_Define.f90 rename to var/external/crtm_2.3.0/libsrc/LSEatlas_Define.f90 index 93d73b3f75..fe80c4624f 100644 --- a/var/external/crtm_2.2.3/libsrc/LSEatlas_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/LSEatlas_Define.f90 @@ -64,7 +64,7 @@ MODULE LSEatlas_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: LSEatlas_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: LSEatlas_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Datatype information CHARACTER(*), PARAMETER :: LSEATLAS_DATATYPE = 'LSEatlas' ! Current valid release and version diff --git a/var/external/crtm_2.2.3/libsrc/Large_Scale_Correction_Module.f90 b/var/external/crtm_2.3.0/libsrc/Large_Scale_Correction_Module.f90 similarity index 98% rename from var/external/crtm_2.2.3/libsrc/Large_Scale_Correction_Module.f90 rename to var/external/crtm_2.3.0/libsrc/Large_Scale_Correction_Module.f90 index 9571fa9174..6e4e8c223b 100644 --- a/var/external/crtm_2.2.3/libsrc/Large_Scale_Correction_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/Large_Scale_Correction_Module.f90 @@ -61,7 +61,7 @@ MODULE Large_Scale_Correction_Module ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Large_Scale_Correction_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Large_Scale_Correction_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(fp), PARAMETER :: ZERO = 0.0_fp diff --git a/var/external/crtm_2.2.3/libsrc/Liu.f90 b/var/external/crtm_2.3.0/libsrc/Liu.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Liu.f90 rename to var/external/crtm_2.3.0/libsrc/Liu.f90 index 9919e04be8..1a378a8b50 100644 --- a/var/external/crtm_2.2.3/libsrc/Liu.f90 +++ b/var/external/crtm_2.3.0/libsrc/Liu.f90 @@ -42,7 +42,7 @@ MODULE Liu ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Liu.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Liu.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants ! ----------------- diff --git a/var/external/crtm_2.2.3/libsrc/MWwaterCoeff_Define.f90 b/var/external/crtm_2.3.0/libsrc/MWwaterCoeff_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/MWwaterCoeff_Define.f90 rename to var/external/crtm_2.3.0/libsrc/MWwaterCoeff_Define.f90 index 6cfc55ac83..8f8b250f49 100644 --- a/var/external/crtm_2.2.3/libsrc/MWwaterCoeff_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/MWwaterCoeff_Define.f90 @@ -60,7 +60,7 @@ MODULE MWwaterCoeff_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: MWwaterCoeff_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: MWwaterCoeff_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: MWWATERCOEFF_RELEASE = 1 ! This determines structure and file formats. INTEGER, PARAMETER :: MWWATERCOEFF_VERSION = 1 ! This is just the default data version. diff --git a/var/external/crtm_2.2.3/libsrc/MWwaterLUT_Define.f90 b/var/external/crtm_2.3.0/libsrc/MWwaterLUT_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/MWwaterLUT_Define.f90 rename to var/external/crtm_2.3.0/libsrc/MWwaterLUT_Define.f90 index c48f7dd6a6..e678f54b86 100644 --- a/var/external/crtm_2.2.3/libsrc/MWwaterLUT_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/MWwaterLUT_Define.f90 @@ -62,7 +62,7 @@ MODULE MWwaterLUT_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: MWwaterLUT_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: MWwaterLUT_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: MWWATERLUT_RELEASE = 1 ! This determines structure and file formats. INTEGER, PARAMETER :: MWWATERLUT_VERSION = 1 ! This is just the default data version. diff --git a/var/external/crtm_2.2.3/libsrc/Message_Handler.f90 b/var/external/crtm_2.3.0/libsrc/Message_Handler.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/Message_Handler.f90 rename to var/external/crtm_2.3.0/libsrc/Message_Handler.f90 diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_AMSRE_SICEEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_AMSRE_SICEEM_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NESDIS_AMSRE_SICEEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_AMSRE_SICEEM_Module.f90 index 1403372bf8..429e5de762 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_AMSRE_SICEEM_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_AMSRE_SICEEM_Module.f90 @@ -41,7 +41,7 @@ MODULE NESDIS_AMSRE_SICEEM_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_AMSRE_SICEEM_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_AMSRE_SICEEM_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' INTEGER, PUBLIC, PARAMETER :: N_FREQ= 7 diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_AMSRE_SNOWEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_AMSRE_SNOWEM_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NESDIS_AMSRE_SNOWEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_AMSRE_SNOWEM_Module.f90 index 10a717eac3..7be67d3e66 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_AMSRE_SNOWEM_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_AMSRE_SNOWEM_Module.f90 @@ -43,7 +43,7 @@ MODULE NESDIS_AMSRE_SNOWEM_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_AMSRE_SNOWEM_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_AMSRE_SNOWEM_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_AMSU_SICEEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_AMSU_SICEEM_Module.f90 similarity index 93% rename from var/external/crtm_2.2.3/libsrc/NESDIS_AMSU_SICEEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_AMSU_SICEEM_Module.f90 index dfb8d73119..931e4a9437 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_AMSU_SICEEM_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_AMSU_SICEEM_Module.f90 @@ -39,7 +39,7 @@ MODULE NESDIS_AMSU_SICEEM_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_AMSU_SICEEM_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_AMSU_SICEEM_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS @@ -340,19 +340,20 @@ subroutine AMSU_IATs(frequency,tba,ts,em_vector) integer :: k,ich real(fp) :: coe(100) + save coe ! Fitting Coefficients Using Tb1, Tb2, Tb4 and Ts - data (coe(k),k=1,5)/ 9.815214e-001_fp, 3.783815e-003_fp, & - 6.391155e-004_fp, -9.106375e-005_fp, -4.263206e-003_fp/ - data (coe(k),k=21,25)/ 9.047181e-001_fp, -2.782826e-004_fp, & - 4.664207e-003_fp, -3.121744e-005_fp, -3.976189e-003_fp/ - data (coe(k),k=41,45)/ 1.163853e+000_fp, -1.419205e-003_fp, & - 5.505238e-003_fp, 1.506867e-003_fp, -6.157735e-003_fp/ - data (coe(k),k=61,65)/ 1.020753e+000_fp, -8.666064e-004_fp, & - 9.624331e-004_fp, 4.878773e-003_fp, -5.055044e-003_fp/ - data (coe(k),k=81,85)/ 1.438246e+000_fp, 5.667756e-004_fp, & - -2.621972e-003_fp, 5.928146e-003_fp, -5.856687e-003_fp/ - save coe + coe(1:5) = (/ 9.815214e-001_fp, 3.783815e-003_fp, & + 6.391155e-004_fp, -9.106375e-005_fp, -4.263206e-003_fp/) + coe(21:25) = (/ 9.047181e-001_fp, -2.782826e-004_fp, & + 4.664207e-003_fp, -3.121744e-005_fp, -3.976189e-003_fp/) + coe(41:45) = (/ 1.163853e+000_fp, -1.419205e-003_fp, & + 5.505238e-003_fp, 1.506867e-003_fp, -6.157735e-003_fp/) + coe(61:65) = (/ 1.020753e+000_fp, -8.666064e-004_fp, & + 9.624331e-004_fp, 4.878773e-003_fp, -5.055044e-003_fp/) + coe(81:85) = (/ 1.438246e+000_fp, 5.667756e-004_fp, & + -2.621972e-003_fp, 5.928146e-003_fp, -5.856687e-003_fp/) +! save coe ! Calculate emissivity discriminators at five AMSU window channels @@ -421,18 +422,19 @@ subroutine AMSU_IBTs(theta,frequency,tbb,ts,em_vector) integer :: i,k,ich,nvalid_ch real(fp) :: coe(nch*(ncoe+1)) + save coe ! Fitting Coefficients at 31.4 GHz - data (coe(k),k=1,7)/ 2.239429e+000_fp, -2.153967e-002_fp, & + coe(1:7) = (/ 2.239429e+000_fp, -2.153967e-002_fp, & 5.785736e-005_fp, 1.366728e-002_fp, & - -3.749251e-005_fp, -5.128486e-002_fp, -2.184161e-003_fp/ - data (coe(k),k=11,17)/ 1.768085e+000_fp, -1.643430e-002_fp, & + -3.749251e-005_fp, -5.128486e-002_fp, -2.184161e-003_fp/) + coe(11:17) = (/ 1.768085e+000_fp, -1.643430e-002_fp, & 4.850989e-005_fp, 1.288753e-002_fp, & - -3.628051e-005_fp, -4.751277e-002_fp, -2.580649e-003_fp/ - data (coe(k),k=21,27)/ 8.910227e-001_fp, 6.170706e-003_fp, & + -3.628051e-005_fp, -4.751277e-002_fp, -2.580649e-003_fp/) + coe(21:27) = (/ 8.910227e-001_fp, 6.170706e-003_fp, & -3.772921e-006_fp, -4.146567e-004_fp, & - -2.208121e-006_fp, -3.163193e-002_fp, -3.863217e-003_fp/ - save coe + -2.208121e-006_fp, -3.163193e-002_fp, -3.863217e-003_fp/) +! save coe ! Calculate emissivity discriminators at five AMSU window channels do ich = 1, nwch-2 @@ -502,7 +504,7 @@ subroutine siem_interpolate(frequency,discriminator,emissivity) integer,parameter:: ncand = 16,nch =5 integer:: i real(fp) :: frequency,freq(nch),emissivity,discriminator(*) - data freq/23.8_fp, 31.4_fp, 50.3_fp,89.0_fp, 150.0_fp/ + freq = (/23.8_fp, 31.4_fp, 50.3_fp,89.0_fp, 150.0_fp/) ! Estimate sea ice emissivity at a required frequency diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_AMSU_SnowEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_AMSU_SnowEM_Module.f90 similarity index 89% rename from var/external/crtm_2.2.3/libsrc/NESDIS_AMSU_SnowEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_AMSU_SnowEM_Module.f90 index 44261d6065..e6eddfc686 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_AMSU_SnowEM_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_AMSU_SnowEM_Module.f90 @@ -40,7 +40,7 @@ MODULE NESDIS_AMSU_SnowEM_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_AMSU_SnowEM_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_AMSU_SnowEM_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS @@ -785,157 +785,157 @@ subroutine AMSU_ABTs(frequency,tb,ts,snow_type,em_vector) data nmodel/5,10,13,16,18,24,30,31,32,33,34,35,36,37,38/ ! Fitting coefficients for five discriminators - data (DI_coe(1,k),k=0,ncoe-1)/ & + DI_coe(1,0:ncoe-1) = (/ & 3.285557e-002_fp, 2.677179e-005_fp, & 4.553101e-003_fp, 5.639352e-005_fp, & -1.825188e-004_fp, 1.636145e-004_fp, & - 1.680881e-005_fp, -1.708405e-004_fp/ - data (DI_coe(2,k),k=0,ncoe-1)/ & + 1.680881e-005_fp, -1.708405e-004_fp/) + DI_coe(2,0:ncoe-1) = (/ & -4.275539e-002_fp, -2.541453e-005_fp, & 4.154796e-004_fp, 1.703443e-004_fp, & 4.350142e-003_fp, 2.452873e-004_fp, & - -4.748506e-003_fp, 2.293836e-004_fp/ - data (DI_coe(3,k),k=0,ncoe-1)/ & + -4.748506e-003_fp, 2.293836e-004_fp/) + DI_coe(3,0:ncoe-1) = (/ & -1.870173e-001_fp, -1.061678e-004_fp, & 2.364055e-004_fp, -2.834876e-005_fp, & 4.899651e-003_fp, -3.418847e-004_fp, & - -2.312224e-004_fp, 9.498600e-004_fp/ - data (DI_coe(4,k),k=0,ncoe-1)/ & + -2.312224e-004_fp, 9.498600e-004_fp/) + DI_coe(4,0:ncoe-1) = (/ & -2.076519e-001_fp, 8.475901e-004_fp, & -2.072679e-003_fp, -2.064717e-003_fp, & 2.600452e-003_fp, 2.503923e-003_fp, & - 5.179711e-004_fp, 4.667157e-005_fp/ - data (DI_coe(5,k),k=0,ncoe-1)/ & + 5.179711e-004_fp, 4.667157e-005_fp/) + DI_coe(5,0:ncoe-1) = (/ & -1.442609e-001_fp, -8.075003e-005_fp, & -1.790933e-004_fp, -1.986887e-004_fp, & 5.495115e-004_fp, -5.871732e-004_fp, & - 4.517280e-003_fp, 7.204695e-004_fp/ + 4.517280e-003_fp, 7.204695e-004_fp/) ! Fitting coefficients for emissivity index at 31.4 GHz - data LI_coe/ & + LI_coe = (/ & 7.963632e-001_fp, 7.215580e-003_fp, & -2.015921e-005_fp, -1.508286e-003_fp, & - 1.731405e-005_fp, -4.105358e-003_fp/ + 1.731405e-005_fp, -4.105358e-003_fp/) ! Fitting coefficients for emissivity index at 150 GHz - data HI_coe/ & + HI_coe = (/ & 1.012160e+000_fp, 6.100397e-003_fp, & -1.774347e-005_fp, -4.028211e-003_fp, & 1.224470e-005_fp, 2.345612e-003_fp, & -5.376814e-006_fp, -2.795332e-003_fp, & 8.072756e-006_fp, 3.529615e-003_fp, & - 1.955293e-006_fp, -4.942230e-003_fp/ + 1.955293e-006_fp, -4.942230e-003_fp/) ! Six thresholds for sixteen candidate snow types ! Note: some snow type contains several possible ! selections for six thresholds !1 Wet Snow - data (threshold(1,k),k=1,6)/0.88_fp,0.86_fp,-999.9_fp,& - 0.01_fp,0.01_fp,200._fp/ - data (threshold(2,k),k=1,6)/0.88_fp,0.85_fp,-999.9_fp,& - 0.06_fp,0.10_fp,200._fp/ - data (threshold(3,k),k=1,6)/0.88_fp,0.83_fp,-0.02_fp,& - 0.12_fp,0.16_fp,204._fp/ - data (threshold(4,k),k=1,6)/0.90_fp,0.89_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ - data (threshold(5,k),k=1,6)/0.92_fp,0.85_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ + threshold(1,1:6) = (/0.88_fp,0.86_fp,-999.9_fp,& + 0.01_fp,0.01_fp,200._fp/) + threshold(2,1:6) = (/0.88_fp,0.85_fp,-999.9_fp,& + 0.06_fp,0.10_fp,200._fp/) + threshold(3,1:6) = (/0.88_fp,0.83_fp,-0.02_fp,& + 0.12_fp,0.16_fp,204._fp/) + threshold(4,1:6) = (/0.90_fp,0.89_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) + threshold(5,1:6) = (/0.92_fp,0.85_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) !2 Grass_after_Snow - data (threshold(6,k),k=1,6)/0.84_fp,0.83_fp,-999.9_fp,& - 0.08_fp,0.10_fp,195._fp/ - data (threshold(7,k),k=1,6)/0.85_fp,0.85_fp,-999.9_fp,& - 0.10_fp,-999.9_fp,190._fp/ - data (threshold(8,k),k=1,6)/0.86_fp,0.81_fp,-999.9_fp,& - 0.12_fp,-999.9_fp,200._fp/ - data (threshold(9,k),k=1,6)/0.86_fp,0.81_fp,0.0_fp,& - 0.12_fp,-999.9_fp,189._fp/ - data (threshold(10,k),k=1,6)/0.90_fp,0.81_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,195._fp/ + threshold(6,1:6) = (/0.84_fp,0.83_fp,-999.9_fp,& + 0.08_fp,0.10_fp,195._fp/) + threshold(7,1:6) = (/0.85_fp,0.85_fp,-999.9_fp,& + 0.10_fp,-999.9_fp,190._fp/) + threshold(8,1:6) = (/0.86_fp,0.81_fp,-999.9_fp,& + 0.12_fp,-999.9_fp,200._fp/) + threshold(9,1:6) = (/0.86_fp,0.81_fp,0.0_fp,& + 0.12_fp,-999.9_fp,189._fp/) + threshold(10,1:6) = (/0.90_fp,0.81_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,195._fp/) !3 RS_Snow (A) - data (threshold(11,k),k=1,6)/0.80_fp,0.76_fp,-999.9_fp,& - 0.05_fp,-999.9_fp,185._fp/ - data (threshold(12,k),k=1,6)/0.82_fp,0.78_fp,-999.9_fp,& - -999.9_fp,0.25_fp,180._fp/ - data (threshold(13,k),k=1,6)/0.90_fp,0.76_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,180._fp/ + threshold(11,1:6) = (/0.80_fp,0.76_fp,-999.9_fp,& + 0.05_fp,-999.9_fp,185._fp/) + threshold(12,1:6) = (/0.82_fp,0.78_fp,-999.9_fp,& + -999.9_fp,0.25_fp,180._fp/) + threshold(13,1:6) = (/0.90_fp,0.76_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,180._fp/) !4 Powder Snow - data (threshold(14,k),k=1,6)/0.89_fp,0.73_fp,-999.9_fp,& - 0.20_fp,-999.9_fp,-999.9_fp/ - data (threshold(15,k),k=1,6)/0.89_fp,0.75_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ - data (threshold(16,k),k=1,6)/0.93_fp,0.72_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ + threshold(14,1:6) = (/0.89_fp,0.73_fp,-999.9_fp,& + 0.20_fp,-999.9_fp,-999.9_fp/) + threshold(15,1:6) = (/0.89_fp,0.75_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) + threshold(16,1:6) = (/0.93_fp,0.72_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) !5 RS_Snow (B) - data (threshold(17,k),k=1,6)/0.82_fp,0.70_fp,-999.9_fp,& - 0.20_fp,-999.9_fp,160._fp/ - data (threshold(18,k),k=1,6)/0.83_fp,0.70_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,160._fp/ + threshold(17,1:6) = (/0.82_fp,0.70_fp,-999.9_fp,& + 0.20_fp,-999.9_fp,160._fp/) + threshold(18,1:6) = (/0.83_fp,0.70_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,160._fp/) !6 RS_Snow (C) - data (threshold(19,k),k=1,6)/0.75_fp,0.76_fp,-999.9_fp,& - 0.08_fp,-999.9_fp,172._fp/ - data (threshold(20,k),k=1,6)/0.77_fp,0.72_fp,-999.9_fp,& - 0.12_fp,0.15_fp,175._fp/ - data (threshold(21,k),k=1,6)/0.78_fp,0.74_fp,-999.9_fp,& - -999.9_fp,0.20_fp,172._fp/ - data (threshold(22,k),k=1,6)/0.80_fp,0.77_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,170._fp/ - data (threshold(23,k),k=1,6)/0.82_fp,-999.9_fp,-999.9_fp,& - 0.15_fp,0.22_fp,170._fp/ - data (threshold(24,k),k=1,6)/0.82_fp,0.73_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,170._fp/ + threshold(19,1:6) = (/0.75_fp,0.76_fp,-999.9_fp,& + 0.08_fp,-999.9_fp,172._fp/) + threshold(20,1:6) = (/0.77_fp,0.72_fp,-999.9_fp,& + 0.12_fp,0.15_fp,175._fp/) + threshold(21,1:6) = (/0.78_fp,0.74_fp,-999.9_fp,& + -999.9_fp,0.20_fp,172._fp/) + threshold(22,1:6) = (/0.80_fp,0.77_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,170._fp/) + threshold(23,1:6) = (/0.82_fp,-999.9_fp,-999.9_fp,& + 0.15_fp,0.22_fp,170._fp/) + threshold(24,1:6) = (/0.82_fp,0.73_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,170._fp/) !7 RS_Snow (D) - data (threshold(25,k),k=1,6)/0.75_fp,0.70_fp,-999.9_fp,& - 0.15_fp,0.25_fp,167._fp/ - data (threshold(26,k),k=1,6)/0.77_fp,0.76_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ - data (threshold(27,k),k=1,6)/0.80_fp,0.72_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ - data (threshold(28,k),k=1,6)/0.77_fp,0.73_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ - - data (threshold(29,k),k=1,6)/0.81_fp,0.71_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ - data (threshold(30,k),k=1,6)/0.82_fp,0.69_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ + threshold(25,1:6) = (/0.75_fp,0.70_fp,-999.9_fp,& + 0.15_fp,0.25_fp,167._fp/) + threshold(26,1:6) = (/0.77_fp,0.76_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) + threshold(27,1:6) = (/0.80_fp,0.72_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) + threshold(28,1:6) = (/0.77_fp,0.73_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) + + threshold(29,1:6) = (/0.81_fp,0.71_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) + threshold(30,1:6) = (/0.82_fp,0.69_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) !8 Thin Crust Snow - data (threshold(31,k),k=1,6)/0.88_fp,0.58_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ + threshold(31,1:6) = (/0.88_fp,0.58_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) !9 RS_Snow (E) - data (threshold(32,k),k=1,6)/0.73_fp,0.67_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ + threshold(32,1:6) = (/0.73_fp,0.67_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) !10 Bottom Crust Snow (A) - data (threshold(33,k),k=1,6)/0.83_fp,0.66_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ + threshold(33,1:6) = (/0.83_fp,0.66_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) !11 Shallow Snow - data (threshold(34,k),k=1,6)/0.82_fp,0.60_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ + threshold(34,1:6) = (/0.82_fp,0.60_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) !12 Deep Snow - data (threshold(35,k),k=1,6)/0.77_fp,0.60_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ + threshold(35,1:6) = (/0.77_fp,0.60_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) !13 Crust Snow - data (threshold(36,k),k=1,6)/0.77_fp,0.7_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ + threshold(36,1:6) = (/0.77_fp,0.7_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) !14 Medium Snow - data (threshold(37,k),k=1,6)/-999.9_fp,0.55_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ + threshold(37,1:6) = (/-999.9_fp,0.55_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) !15 Bottom Crust Snow(B) - data (threshold(38,k),k=1,6)/0.74_fp,-999.9_fp,-999.9_fp,& - -999.9_fp,-999.9_fp,-999.9_fp/ + threshold(38,1:6) = (/0.74_fp,-999.9_fp,-999.9_fp,& + -999.9_fp,-999.9_fp,-999.9_fp/) !16 Thick Crust Snow ! lowest priority: No constraints @@ -1168,46 +1168,47 @@ subroutine AMSU_AB(frequency,tb,snow_type,em_vector) integer :: i,snow_type,k,ich,nvalid_ch real(fp) :: coe(nwch*(ncoe+1)) + save coe ! Fitting Coefficients at 23.8 GHz: Using Tb1 ~ Tb3 - data (coe(k),k=1,7)/& + coe(1:7) = (/& -1.326040e+000_fp, 2.475904e-002_fp, & -5.741361e-005_fp, -1.889650e-002_fp, & 6.177911e-005_fp, 1.451121e-002_fp, & - -4.925512e-005_fp/ + -4.925512e-005_fp/) ! Fitting Coefficients at 31.4 GHz: Using Tb1 ~ Tb3 - data (coe(k),k=12,18)/ & + coe(12:18) = (/ & -1.250541e+000_fp, 1.911161e-002_fp, & -5.460238e-005_fp, -1.266388e-002_fp, & 5.745064e-005_fp, 1.313985e-002_fp, & - -4.574811e-005_fp/ + -4.574811e-005_fp/) ! Fitting Coefficients at 50.3 GHz: Using Tb1 ~ Tb3 - data (coe(k),k=23,29)/ & + coe(23:29) = (/ & -1.246754e+000_fp, 2.368658e-002_fp, & -8.061774e-005_fp, -3.206323e-002_fp, & 1.148107e-004_fp, 2.688353e-002_fp, & - -7.358356e-005_fp/ + -7.358356e-005_fp/) ! Fitting Coefficients at 89 GHz: Using Tb1 ~ Tb4 - data (coe(k),k=34,42)/ & + coe(34:42) = (/ & -1.278780e+000_fp, 1.625141e-002_fp, & -4.764536e-005_fp, -1.475181e-002_fp, & 5.107766e-005_fp, 1.083021e-002_fp, & -4.154825e-005_fp, 7.703879e-003_fp, & - -6.351148e-006_fp/ + -6.351148e-006_fp/) ! Fitting Coefficients at 150 GHz: Using Tb1 ~ Tb5 - data (coe(k),k=45,55)/& + coe(45:55) = (/& -1.691077e+000_fp, 3.352403e-002_fp, & -7.310338e-005_fp, -4.396138e-002_fp, & 1.028994e-004_fp, 2.301014e-002_fp, & -7.070810e-005_fp, 1.270231e-002_fp, & -2.139023e-005_fp, -2.257991e-003_fp, & - 1.269419e-005_fp/ + 1.269419e-005_fp/) - save coe +! save coe ! Calculate emissivity discriminators at five AMSU window channels do ich = 1, nwch @@ -1280,43 +1281,44 @@ subroutine AMSU_ATs(frequency,tba,ts,snow_type,em_vector) integer :: snow_type,i,k,ich,nvalid_ch real(fp) :: coe(nch*(ncoe+1)) + save coe ! Fitting Coefficients at 23.8 GHz: Using Tb1, Tb2 and Ts - data (coe(k),k=1,6)/ & + coe(1:6) = (/ & 8.210105e-001_fp, 1.216432e-002_fp, & - -2.113875e-005_fp, -6.416648e-003_fp, & - 1.809047e-005_fp, -4.206605e-003_fp/ + -2.113875e-005_fp, -6.416648e-003_fp, & + 1.809047e-005_fp, -4.206605e-003_fp /) ! Fitting Coefficients at 31.4 GHz: Using Tb1, Tb2 and Ts - data (coe(k),k=11,16)/ & + coe(11:16) = (/ & 7.963632e-001_fp, 7.215580e-003_fp, & -2.015921e-005_fp, -1.508286e-003_fp, & - 1.731405e-005_fp, -4.105358e-003_fp/ + 1.731405e-005_fp, -4.105358e-003_fp /) ! Fitting Coefficients at 50.3 GHz: Using Tb1, Tb2, Tb3 and Ts - data (coe(k),k=21,28)/ & + coe(21:28) = (/ & 1.724160e+000_fp, 5.556665e-003_fp, & -2.915872e-005_fp, -1.146713e-002_fp, & 4.724243e-005_fp, 3.851791e-003_fp, & - -5.581535e-008_fp, -5.413451e-003_fp/ + -5.581535e-008_fp, -5.413451e-003_fp /) ! Fitting Coefficients at 89 GHz: Using Tb1 ~ Tb4 and Ts - data (coe(k),k=31,40)/ & + coe(31:40) = (/ & 9.962065e-001_fp, 1.584161e-004_fp, & -3.988934e-006_fp, 3.427638e-003_fp, & -5.084836e-006_fp, -6.178904e-004_fp, & 1.115315e-006_fp, 9.440962e-004_fp, & - 9.711384e-006_fp, -4.259102e-003_fp/ + 9.711384e-006_fp, -4.259102e-003_fp /) ! Fitting Coefficients at 150 GHz: Using Tb1 ~ Tb4 and Ts - data (coe(k),k=41,50)/ & + coe(41:50) = (/ & -5.244422e-002_fp, 2.025879e-002_fp, & -3.739231e-005_fp, -2.922355e-002_fp, & 5.810726e-005_fp, 1.376275e-002_fp, & -3.757061e-005_fp, 6.434187e-003_fp, & - 6.190403e-007_fp, -2.944785e-003_fp/ + 6.190403e-007_fp, -2.944785e-003_fp/) - save coe +! save coe ! Calculate emissivity discriminators at five AMSU window channels DO ich = 1, nwch @@ -1388,39 +1390,39 @@ subroutine AMSU_amsua(frequency,tba,snow_type,em_vector) real(fp) :: em_vector(*),emissivity,frequency,discriminator(nwch) integer :: snow_type,i,k,ich,nvalid_ch real(fp) :: coe(50) - + save coe ! Fitting Coefficients at 23.8 GHz: Using Tb1 ~ Tb3 - data (coe(k),k=1,7)/ & + coe(1:7) = (/ & -1.326040e+000_fp, 2.475904e-002_fp, -5.741361e-005_fp, & -1.889650e-002_fp, 6.177911e-005_fp, 1.451121e-002_fp, & - -4.925512e-005_fp/ + -4.925512e-005_fp/) ! Fitting Coefficients at 31.4 GHz: Using Tb1 ~ Tb3 - data (coe(k),k=11,17)/ & + coe(11:17) = (/ & -1.250541e+000_fp, 1.911161e-002_fp, -5.460238e-005_fp, & -1.266388e-002_fp, 5.745064e-005_fp, 1.313985e-002_fp, & - -4.574811e-005_fp/ + -4.574811e-005_fp/) ! Fitting Coefficients at 50.3 GHz: Using Tb1 ~ Tb3 - data (coe(k),k=21,27)/ & + coe(21:27) = (/ & -1.246754e+000_fp, 2.368658e-002_fp, -8.061774e-005_fp, & -3.206323e-002_fp, 1.148107e-004_fp, 2.688353e-002_fp, & - -7.358356e-005_fp/ + -7.358356e-005_fp/) ! Fitting Coefficients at 89 GHz: Using Tb1 ~ Tb4 - data (coe(k),k=31,39)/ & + coe(31:39) = (/ & -1.278780e+000_fp, 1.625141e-002_fp, -4.764536e-005_fp, & -1.475181e-002_fp, 5.107766e-005_fp, 1.083021e-002_fp, & - -4.154825e-005_fp, 7.703879e-003_fp, -6.351148e-006_fp/ + -4.154825e-005_fp, 7.703879e-003_fp, -6.351148e-006_fp/) ! Fitting Coefficients at 150 GHz: Using Tb1 ~ Tb4 - data (coe(k),k=41,49)/ & + coe(41:49) = (/ & -1.624857e+000_fp, 3.138243e-002_fp, -6.757028e-005_fp, & -4.178496e-002_fp, 9.691893e-005_fp, 2.165964e-002_fp, & - -6.702349e-005_fp, 1.111658e-002_fp, -1.050708e-005_fp/ + -6.702349e-005_fp, 1.111658e-002_fp, -1.050708e-005_fp/) - save coe +! save coe ! Calculate emissivity discriminators at five AMSU window channels @@ -1502,18 +1504,18 @@ subroutine AMSU_BTs(frequency,tbb,ts,snow_type,em_vector) real(fp) :: em_vector(*),emissivity,ts,frequency,ed0(nwch),discriminator(5) integer :: snow_type,i,k,ich,nvalid_ch real(fp) :: coe(nch*(ncoe+1)) - + save coe ! Fitting Coefficients at 31.4 GHz: Using Tb4, Tb5 and Ts - data (coe(k),k=1,6)/ 3.110967e-001_fp, 1.100175e-002_fp, -1.677626e-005_fp, & - -4.020427e-003_fp, 9.242240e-006_fp, -2.363207e-003_fp/ + coe(1:6) = (/ 3.110967e-001_fp, 1.100175e-002_fp, -1.677626e-005_fp, & + -4.020427e-003_fp, 9.242240e-006_fp, -2.363207e-003_fp/) ! Fitting Coefficients at 89 GHz: Using Tb4, Tb5 and Ts - data (coe(k),k=11,16)/ 1.148098e+000_fp, 1.452926e-003_fp, 1.037081e-005_fp, & - 1.340696e-003_fp, -5.185640e-006_fp, -4.546382e-003_fp / + coe(11:16) = (/ 1.148098e+000_fp, 1.452926e-003_fp, 1.037081e-005_fp, & + 1.340696e-003_fp, -5.185640e-006_fp, -4.546382e-003_fp /) ! Fitting Coefficients at 150 GHz: Using Tb4, Tb5 and Ts - data (coe(k),k=21,26)/ 1.165323e+000_fp, -1.030435e-003_fp, 4.828009e-006_fp, & - 4.851731e-003_fp, -2.588049e-006_fp, -4.990193e-003_fp/ - save coe + coe(21:26) = (/ 1.165323e+000_fp, -1.030435e-003_fp, 4.828009e-006_fp, & + 4.851731e-003_fp, -2.588049e-006_fp, -4.990193e-003_fp/) +! save coe ! Calculate emissivity discriminators at five AMSU window channels do ich = 1, nwch @@ -1592,18 +1594,18 @@ subroutine AMSU_amsub(frequency,tbb,snow_type,em_vector) real(fp) :: em_vector(*),emissivity,frequency,ed0(nwch),discriminator(5) integer :: snow_type,i,k,ich,nvalid_ch real(fp) :: coe(50) - + save coe ! Fitting Coefficients at 31.4 GHz: Using Tb4, Tb5 - data (coe(k),k=1,5)/-4.015636e-001_fp,9.297894e-003_fp, -1.305068e-005_fp, & - 3.717131e-004_fp, -4.364877e-006_fp/ + coe(1:5) = (/-4.015636e-001_fp,9.297894e-003_fp, -1.305068e-005_fp, & + 3.717131e-004_fp, -4.364877e-006_fp/) ! Fitting Coefficients at 89 GHz: Using Tb4, Tb5 - data (coe(k),k=11,15)/-2.229547e-001_fp, -1.828402e-003_fp,1.754807e-005_fp, & - 9.793681e-003_fp, -3.137189e-005_fp/ + coe(11:15) = (/-2.229547e-001_fp, -1.828402e-003_fp,1.754807e-005_fp, & + 9.793681e-003_fp, -3.137189e-005_fp/) ! Fitting Coefficients at 150 GHz: Using Tb4, Tb5 - data (coe(k),k=21,25)/-3.395416e-001_fp,-4.632656e-003_fp,1.270735e-005_fp, & - 1.413038e-002_fp,-3.133239e-005_fp/ - save coe + coe(21:25) = (/-3.395416e-001_fp,-4.632656e-003_fp,1.270735e-005_fp, & + 1.413038e-002_fp,-3.133239e-005_fp/) +! save coe ! Calculate emissivity discriminators at five AMSU window channels do ich = 1, nwch @@ -1688,7 +1690,9 @@ subroutine AMSU_ALandEM_Snow(theta,frequency,snow_depth,ts,snow_type,em_vector) integer snow_type,ich real(fp) freq_3w(nw_ind),esh_3w(nw_ind),esv_3w(nw_ind) complex(fp) eair - data freq_3w/31.4_fp,89.0_fp,150.0_fp/ + save freq_3w + + freq_3w = (/31.4_fp,89.0_fp,150.0_fp/) eair = cmplx(one,-zero,fp) @@ -1776,23 +1780,23 @@ subroutine ems_adjust(theta,frequency,depth,ts,esv_3w,esh_3w,em_vector,snow_type save dem_coe - data (dem_coe(1,k),k=0,ncoe-1)/ 2.306844e+000_Double, -7.287718e-003_Double, & + dem_coe(1,0:ncoe-1) = (/ 2.306844e+000_Double, -7.287718e-003_Double, & -6.433248e-004_Double, 1.664216e-005_Double, & - 4.766508e-007_Double, -1.754184e+000_Double/ + 4.766508e-007_Double, -1.754184e+000_Double/) - data (dem_coe(2,k),k=0,ncoe-1)/ 3.152527e+000_Double, -1.823670e-002_Double, & + dem_coe(2,0:ncoe-1) = (/ 3.152527e+000_Double, -1.823670e-002_Double, & -9.535361e-004_Double, 3.675516e-005_Double, & - 9.609477e-007_Double, -1.113725e+000_Double/ + 9.609477e-007_Double, -1.113725e+000_Double/) - data (dem_coe(3,k),k=0,ncoe-1)/ 3.492495e+000_Double, -2.184545e-002_Double, & + dem_coe(3,0:ncoe-1) = (/ 3.492495e+000_Double, -2.184545e-002_Double, & 6.536696e-005_Double, 4.464352e-005_Double, & - -6.305717e-008_Double, -1.221087e+000_Double/ + -6.305717e-008_Double, -1.221087e+000_Double/) ! diff --git a/var/external/crtm_2.3.0/libsrc/NESDIS_ATMS_SeaICE_LIB.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_ATMS_SeaICE_LIB.f90 new file mode 100644 index 0000000000..853fa8a425 --- /dev/null +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_ATMS_SeaICE_LIB.f90 @@ -0,0 +1,173 @@ +!-------------------------------------------------------------------------------- +!M+ +! NAME: +! NESDIS_SnowEM_ATMS_Parameters Module +! +! PURPOSE: +! Module containing the snow emissivity library ATMS channels. The library contain 16 +! pre-defined snow spectrum which characterize 16 basic snow types. This library is used +! together with a snow-typing algorithm to implement the library-based snow emissivity modeling. +! +! CATEGORY: +! Surface : MW Surface Snow Emissivity Model Parameters +! +! LANGUAGE: +! Fortran-95 +! +! CALLING SEQUENCE: +! USE SnowEM_Parameters Module +! +! MODULES: +! Type_Kinds: Module containing definitions for kinds of variable types. +! +! +! INCLUDE FILES: +! None. +! +! EXTERNALS: +! None. +! +! COMMON BLOCKS: +! None. +! +! FILES ACCESSED: +! None. +! +! CREATION HISTORY: +! Written by: Ming Chen,IMSG Inc., ming.chen@noaa.gov (04-28-2012) +! +! and Fuzhong Weng, NOAA/NESDIS/ORA, Fuzhong.Weng@noaa.gov +! +! +! Copyright (C) 2012 Fuzhong Weng and Ming Chen +! +! This program is free software; you can redistribute it and/or modify it under the terms of the GNU +! General Public License as published by the Free Software Foundation; either version 2 of the License, +! or (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even +! the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +! License for more details. +! +! You should have received a copy of the GNU General Public License along with this program; if not, write +! to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +!M- +!-------------------------------------------------------------------------------- + +MODULE NESDIS_ATMS_SeaIce_LIB + + USE Type_Kinds, ONLY: fp, ip + IMPLICIT NONE + + + INTEGER(ip), PUBLIC, PARAMETER :: N_FREQ_ATMS = 13 + INTEGER(ip), PUBLIC, PARAMETER :: N_SEAICE_TYPES = 13 + INTEGER(ip), PUBLIC, PARAMETER :: N_FREQ_AMSRE = 7 + INTEGER(ip), PUBLIC, PARAMETER :: INVALID_SEAICE_TYPE = -1 + + CHARACTER(LEN=20),DIMENSION(N_SEAICE_TYPES), & + PUBLIC, PARAMETER :: SEAICE_TYPE_NAMES=(/ & + 'RS_ICE_A_EMISS ',& !1 + 'RS_ICE_B_EMISS ',& !2 + 'MIXED_NEWICE_SNOW_EM',& !3 + 'NARE_NEWICE_EMISS ',& !4 + 'BROKEN_ICE_EMISS ',& !5 + 'FIRST_YEAR_ICE_EMISS',& !6 + 'COMPOSITE_PACK_ICE ',& !7 + 'RS_ICE_C_EMISS ',& !8 + 'FAST_ICE_EMISS ',& !9 + 'RS_ICE_D_EMISS ',& !10 + 'RS_ICE_E_EMISS ',& !11 + 'RS_ICE_F_EMISS ',& !12 + 'GREASE_ICE_EMISS '/) !13 + + REAL(fp),PUBLIC,PARAMETER, DIMENSION(N_FREQ_ATMS) :: FREQUENCY_ATMS = & + (/23.80_fp,31.40_fp,50.30_fp,51.76_fp,52.80_fp,53.60_fp,54.40_fp, & + 54.90_fp,55.50_fp,57.30_fp,88.20_fp,165.50_fp,183.30_fp/) + + + ! Define sixteen MW H-Pol emissivity spectra for ATMS ALGORITHMS + REAL(fp),PUBLIC,PARAMETER,DIMENSION(N_FREQ_ATMS,N_SEAICE_TYPES) :: SEAICE_EMISS_ATMS_H = RESHAPE((/ & + 0.94_fp,0.95_fp,0.94_fp,0.94_fp,0.94_fp,0.94_fp,0.94_fp,0.94_fp,0.94_fp,0.94_fp,0.92_fp,0.91_fp,0.91_fp,& !1 + 0.86_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.88_fp,0.87_fp,0.87_fp,& !2 + 0.85_fp,0.84_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.82_fp,0.80_fp,0.79_fp,& !3 + 0.76_fp,0.77_fp,0.76_fp,0.76_fp,0.76_fp,0.76_fp,0.76_fp,0.76_fp,0.76_fp,0.75_fp,0.73_fp,0.73_fp,0.73_fp,& !4 + 0.77_fp,0.79_fp,0.78_fp,0.78_fp,0.78_fp,0.77_fp,0.77_fp,0.77_fp,0.77_fp,0.77_fp,0.72_fp,0.69_fp,0.68_fp,& !5 + 0.88_fp,0.87_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.82_fp,0.82_fp,0.82_fp,0.76_fp,0.66_fp,0.64_fp,& !6 + 0.82_fp,0.80_fp,0.76_fp,0.76_fp,0.75_fp,0.75_fp,0.75_fp,0.75_fp,0.75_fp,0.74_fp,0.67_fp,0.56_fp,0.53_fp,& !7 + 0.78_fp,0.73_fp,0.67_fp,0.66_fp,0.66_fp,0.66_fp,0.66_fp,0.66_fp,0.66_fp,0.65_fp,0.60_fp,0.56_fp,0.54_fp,& !8 + 0.76_fp,0.74_fp,0.69_fp,0.69_fp,0.68_fp,0.68_fp,0.68_fp,0.68_fp,0.68_fp,0.67_fp,0.60_fp,0.52_fp,0.50_fp,& !9 + 0.70_fp,0.70_fp,0.67_fp,0.67_fp,0.67_fp,0.66_fp,0.66_fp,0.66_fp,0.66_fp,0.66_fp,0.59_fp,0.53_fp,0.52_fp,& !10 + 0.61_fp,0.62_fp,0.63_fp,0.63_fp,0.64_fp,0.64_fp,0.64_fp,0.64_fp,0.64_fp,0.64_fp,0.67_fp,0.69_fp,0.70_fp,& !11 + 0.57_fp,0.59_fp,0.61_fp,0.61_fp,0.61_fp,0.61_fp,0.61_fp,0.61_fp,0.61_fp,0.62_fp,0.64_fp,0.65_fp,0.65_fp,& !12 + 0.45_fp,0.47_fp,0.50_fp,0.50_fp,0.51_fp,0.51_fp,0.51_fp,0.51_fp,0.51_fp,0.51_fp,0.54_fp,0.56_fp,0.57_fp & !13 + /),(/N_FREQ_ATMS,N_SEAICE_TYPES/)) + + + ! Define sixteen MW V-Pol emissivity spectra for ATMS ALGORITHMS + REAL(fp),PUBLIC,PARAMETER,DIMENSION(N_FREQ_ATMS,N_SEAICE_TYPES) :: SEAICE_EMISS_ATMS_V = RESHAPE((/ & + 0.99_fp,0.99_fp,0.99_fp,0.99_fp,0.99_fp,0.99_fp,0.99_fp,0.99_fp,0.99_fp,0.99_fp,0.98_fp,0.97_fp,0.97_fp,& !1 + 0.98_fp,0.97_fp,0.96_fp,0.96_fp,0.96_fp,0.96_fp,0.96_fp,0.96_fp,0.96_fp,0.96_fp,0.94_fp,0.93_fp,0.93_fp,& !2 + 0.94_fp,0.93_fp,0.92_fp,0.92_fp,0.91_fp,0.91_fp,0.91_fp,0.91_fp,0.91_fp,0.91_fp,0.88_fp,0.86_fp,0.85_fp,& !3 + 0.91_fp,0.91_fp,0.90_fp,0.90_fp,0.90_fp,0.90_fp,0.90_fp,0.90_fp,0.90_fp,0.90_fp,0.88_fp,0.88_fp,0.88_fp,& !4 + 0.91_fp,0.91_fp,0.90_fp,0.90_fp,0.90_fp,0.90_fp,0.90_fp,0.90_fp,0.90_fp,0.89_fp,0.87_fp,0.84_fp,0.83_fp,& !5 + 0.97_fp,0.96_fp,0.92_fp,0.92_fp,0.92_fp,0.91_fp,0.91_fp,0.91_fp,0.91_fp,0.91_fp,0.84_fp,0.74_fp,0.72_fp,& !6 + 0.93_fp,0.91_fp,0.85_fp,0.84_fp,0.84_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.82_fp,0.72_fp,0.61_fp,0.58_fp,& !7 + 0.86_fp,0.79_fp,0.73_fp,0.72_fp,0.72_fp,0.72_fp,0.72_fp,0.72_fp,0.72_fp,0.71_fp,0.66_fp,0.62_fp,0.60_fp,& !8 + 0.91_fp,0.87_fp,0.81_fp,0.80_fp,0.80_fp,0.80_fp,0.80_fp,0.79_fp,0.79_fp,0.79_fp,0.69_fp,0.61_fp,0.59_fp,& !9 + 0.88_fp,0.88_fp,0.85_fp,0.85_fp,0.85_fp,0.84_fp,0.84_fp,0.84_fp,0.84_fp,0.84_fp,0.77_fp,0.71_fp,0.70_fp,& !10 + 0.82_fp,0.83_fp,0.85_fp,0.85_fp,0.85_fp,0.85_fp,0.85_fp,0.85_fp,0.85_fp,0.85_fp,0.86_fp,0.88_fp,0.89_fp,& !11 + 0.78_fp,0.80_fp,0.82_fp,0.82_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.86_fp,0.87_fp,0.87_fp,& !12 + 0.72_fp,0.74_fp,0.78_fp,0.78_fp,0.78_fp,0.78_fp,0.78_fp,0.78_fp,0.78_fp,0.78_fp,0.82_fp,0.84_fp,0.85_fp & !13 + /),(/N_FREQ_ATMS,N_SEAICE_TYPES/)) + + + ! Define sixteen Mixed MW emissivity spectra for ATMS ALGORITHMS + REAL(fp),PUBLIC,PARAMETER,DIMENSION(N_FREQ_ATMS,N_SEAICE_TYPES) :: SEAICE_EMISS_ATMS_LIB = RESHAPE((/ & + 0.97_fp,0.97_fp,0.96_fp,0.96_fp,0.96_fp,0.96_fp,0.96_fp,0.96_fp,0.96_fp,0.96_fp,0.95_fp,0.94_fp,0.94_fp,& !1 + 0.92_fp,0.92_fp,0.92_fp,0.92_fp,0.92_fp,0.92_fp,0.92_fp,0.92_fp,0.92_fp,0.92_fp,0.91_fp,0.90_fp,0.90_fp,& !2 + 0.90_fp,0.89_fp,0.88_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.85_fp,0.83_fp,0.82_fp,& !3 + 0.84_fp,0.84_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.81_fp,0.80_fp,0.80_fp,& !4 + 0.84_fp,0.85_fp,0.84_fp,0.84_fp,0.84_fp,0.84_fp,0.83_fp,0.83_fp,0.83_fp,0.83_fp,0.80_fp,0.76_fp,0.75_fp,& !5 + 0.93_fp,0.91_fp,0.88_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.87_fp,0.86_fp,0.80_fp,0.70_fp,0.68_fp,& !6 + 0.88_fp,0.85_fp,0.80_fp,0.80_fp,0.79_fp,0.79_fp,0.79_fp,0.79_fp,0.79_fp,0.78_fp,0.70_fp,0.58_fp,0.56_fp,& !7 + 0.82_fp,0.76_fp,0.70_fp,0.69_fp,0.69_fp,0.69_fp,0.69_fp,0.69_fp,0.69_fp,0.68_fp,0.63_fp,0.59_fp,0.57_fp,& !8 + 0.84_fp,0.81_fp,0.75_fp,0.74_fp,0.74_fp,0.74_fp,0.74_fp,0.74_fp,0.73_fp,0.73_fp,0.65_fp,0.57_fp,0.55_fp,& !9 + 0.79_fp,0.79_fp,0.76_fp,0.76_fp,0.76_fp,0.75_fp,0.75_fp,0.75_fp,0.75_fp,0.75_fp,0.68_fp,0.62_fp,0.61_fp,& !10 + 0.72_fp,0.72_fp,0.74_fp,0.74_fp,0.74_fp,0.74_fp,0.74_fp,0.74_fp,0.74_fp,0.74_fp,0.76_fp,0.79_fp,0.79_fp,& !11 + 0.68_fp,0.69_fp,0.72_fp,0.72_fp,0.72_fp,0.72_fp,0.72_fp,0.72_fp,0.72_fp,0.72_fp,0.75_fp,0.76_fp,0.76_fp,& !12 + 0.59_fp,0.61_fp,0.64_fp,0.64_fp,0.64_fp,0.64_fp,0.64_fp,0.64_fp,0.64_fp,0.65_fp,0.68_fp,0.70_fp,0.71_fp & !13 + /),(/N_FREQ_ATMS,N_SEAICE_TYPES/)) + + +CONTAINS + + FUNCTION SeaIceType_Name2Index(sname) RESULT(sindex) + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: sname + ! Function result + INTEGER :: sindex + INTEGER :: Idx + + sindex=INVALID_SEAICE_TYPE + DO Idx=1, N_SEAICE_TYPES + IF(TRIM(sname) .EQ. TRIM(SeaIce_TYPE_NAMES(Idx))) THEN + sindex=Idx + EXIT + ENDIF + ENDDO + RETURN + END FUNCTION SeaIceType_Name2Index + + + FUNCTION SeaIceType_Index2Name(sindex) RESULT(sname) + ! Arguments + INTEGER, INTENT(IN) :: sindex + ! Function result + CHARACTER(LEN=100) :: sname + + sname=TRIM(SeaIce_TYPE_NAMES(sindex)) + RETURN + END FUNCTION SeaIceType_Index2Name + +END MODULE NESDIS_ATMS_SeaIce_LIB diff --git a/var/external/crtm_2.3.0/libsrc/NESDIS_ATMS_SeaICE_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_ATMS_SeaICE_Module.f90 new file mode 100644 index 0000000000..563c49f539 --- /dev/null +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_ATMS_SeaICE_Module.f90 @@ -0,0 +1,421 @@ +!-------------------------------------------------------------------------------- +!M+ +! NAME: +! NESDIS_ATMS_SeaICE_Module +! +! PURPOSE: +! Module containing the seaice-typing algorithm. A general interface is used to call the +! seaice-typing algorithm in terms of the input arguments. This Module is used together with +! NESDIS_ATMS_SeaICE_LIB Module to implement the library-based seaIce emissivity model. +! +! REFERENCES: +! Yan, B., F. Weng and K.Okamoto,2004: "A microwave snow emissivity model, 8th Specialist Meeting on +! +! Microwave Radiometry and Remote Sension Applications,24-27 February, 2004, Rome, Italy. +! +! CATEGORY: +! Surface : MW Surface SeaICE Emissivity of ATMS +! +! LANGUAGE: +! Fortran-95 +! +! CALLING SEQUENCE: +! +! USE NESDIS_ATMS_SeaICE_Module +! +! MODULES: +! Type_Kinds: Module containing definitions for kinds of variable types +! +! NESDIS_LandEM_Module: Module containing the microwave land emissivity model +! +! NESDIS_ATMS_SeaICE_LIB: Module containing the predefined microwave seaice emissivity spectra +! +! CONTAINS: +! +! PUBLIC SUNPROGRAMS: +! +! NESDIS_ATMS_SEAICE: Subroutine to calculate the microwave seaice emissivity from ATMS +! +! +! PRIVATE SUBPROGRAMS: +! These subroutines are used to determine the snow types from the brightness temperatures(TB) +! of five ATMS window channels( 23.8 GHz, 31.4 GHz, 50.3 GHz, 88.2 GHz, 165.5 GHz) and/or +! surface temperature plus snow depth. The five channels are further divided into two +! groups: Group-1 ( 23.8 GHz, 31.4 GHz, 50.3 GHz, 88.2 GHz) and Group-2 (88.2 GHz, 165.5GHz), +! corresponding to the window channels of AMSU-A and AMSU-B, respectively. +! Different combinations of available ATMS window-channel and surface observations result +! in differenet snow-typing algotrithms: + +! ATMS_SEAICE_ByTBTs : by the TBs of all the five ATMS channels and surface temperature (regression-based) +! ATMS_SEAICE_ByTBTs_D : by the TBs of all the five ATMS channels and surface temperature (diagnosis-based) +! siem_interpolate : Subroutine to perform frequency interpolation of snow emissivity +! +! INCLUDE FILES: +! None. +! +! EXTERNALS: +! None. +! +! COMMON BLOCKS: +! None. +! +! FILES ACCESSED: +! None. +! +! CREATION HISTORY: +! Written by: Ming Chen, IMSG Inc., Banghua.Yan@noaa.gov (04-28-2012) +! +! +! and Fuzhong Weng, NOAA/NESDIS/ORA, Fuzhong.Weng@noaa.gov +! +! Copyright (C) 2012 Fuzhong Weng and Ming Chen +! +! This program is free software; you can redistribute it and/or modify it under the terms of the GNU +! General Public License as published by the Free Software Foundation; either version 2 of the License, +! or (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even +! the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +! License for more details. +! +! You should have received a copy of the GNU General Public License along with this program; if not, write +! to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +!M- +!-------------------------------------------------------------------------------- + +MODULE NESDIS_ATMS_SeaICE_Module + + ! ----------------- + ! Environment setup + ! ----------------- + ! Module use + USE Type_Kinds, ONLY: fp + USE NESDIS_LandEM_Module + USE NESDIS_ATMS_SeaICE_LIB + + ! Disable implicit typing + IMPLICIT NONE + + ! ------------ + ! Visibilities + ! ------------ + PRIVATE + PUBLIC :: NESDIS_ATMS_SeaICE + + ! ----------------- + ! Module parameters + ! ----------------- + ! Version Id for the module + CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & + '$Id: NESDIS_ATMS_SeaICE_Module.f90 21141 2012-09-14 17:40:43Z paul.vandelst@noaa.gov $' + + +CONTAINS + + + SUBROUTINE NESDIS_ATMS_SeaICE(Satellite_Angle, & ! INPUT + User_Angle, & ! INPUT + frequency, & ! INPUT + Ts, & ! INPUT + Tbs, & ! INPUT + Emissivity_H, & ! OUTPUT + Emissivity_V) ! OUTPUT + + + INTEGER, PARAMETER:: nwch = 5 + REAL(fp):: Satellite_Angle,User_Angle,Satellite_theta,frequency,Ts + REAL(fp):: em_vector(2),esh1,esv1,esh2,esv2,desh,desv,dem + REAL(fp):: tbs(nwch) + REAL(fp), INTENT(out) :: Emissivity_H, Emissivity_V + + + ! Initialization + em_vector(1) = 0.82_fp + em_vector(2) = 0.85_fp + Satellite_theta = User_Angle*pi/180.0_fp + + ! Check available data + IF ((Ts <= 150.0_fp) .OR. (Ts >= 280.0_fp) ) Ts = 260.0 + + ! Emissivity at the local zenith angle of satellite measurements + CALL ATMS_SeaICE_ByTbTs_D(frequency,tbs,Ts,em_vector) + ! Get the emissivity angle dependence + CALL NESDIS_LandEM(Satellite_Angle,Frequency,0.0_fp,0.0_fp,Ts,Ts,0.0_fp,9,13,2.0_fp,esh1,esv1) + CALL NESDIS_LandEM(User_Angle,Frequency,0.0_fp,0.0_fp,Ts,Ts,0.0_fp,9,13,2.0_fp,esh2,esv2) + desh = esh1 - esh2 + desv = esv1 - esv2 + dem = ( desh + desv ) * 0.5_fp + + ! Emissivity at User's Angle + Emissivity_H = em_vector(1) - dem; Emissivity_V = em_vector(2)- dem + + IF(Emissivity_H > ONE) Emissivity_H = ONE + IF(Emissivity_V > ONE) Emissivity_V = ONE + + IF(Emissivity_H < 0.3_fp) Emissivity_H = 0.3_fp + IF(Emissivity_V < 0.3_fp) Emissivity_V = 0.3_fp + + + END SUBROUTINE NESDIS_ATMS_SeaICE + + + + SUBROUTINE ATMS_SeaICE_ByTbTs_D(frequency,tb,ts,em_vector) + + !----------------------------------------------------------------------------------------------------------! + !$$$ subprogram documentation block + ! + ! subprogram: Calculate emissivity by diagnosis-based algorithm + ! + ! + ! abstract: + ! Diagnose the snow type, and use the emissivity spectrum of the snow type as the first-guess to diagnose + ! the magnitude of necessary adjustment with respect to window-channel TBs and surface temperature Ts. Perfrom + ! necessary interpolation/extrapolation a required frequency and user angle. + ! + ! + ! input argument list: + ! + ! frequency - frequency in GHz + ! theta - local zenith angle (currently, not used here) + ! tb[1] ~ tb[5] - brightness temperature at five ATMS window channels: + ! tb[1] : 23.8 GHz + ! tb[2] : 31.4 GHz + ! tb[3] : 50.3 GHz + ! tb[4] : 88.2 GHz + ! tb[5] : 165.5 GHz + ! + ! output argument list: + ! + ! em_vector[1] and [2] - emissivity at two polarizations. + ! set esv = esh here and will be updated + ! snow_type - snow type + ! + ! + ! remarks: + ! + ! program history log: + ! Ming Chen, IMSG at NOAA/NESDIS/STAR date: 2012-04-28 + ! + ! + !----------------------------------------------------------------------------------------------------------! + + INTEGER , PARAMETER :: ntype = N_SEAICE_TYPES, nch = N_FREQ_ATMS, nwch = 5 + REAL(fp), PARAMETER :: earthrad = 6374._fp, satheight = 833.4_fp + INTEGER :: freq_idx,sice_type + REAL(fp) :: frequency + REAL(fp) :: em(nch,ntype), em_vector(:) + REAL(fp) :: tb(:),freq(nch) + REAL(fp) :: ts, emissivity + REAL(fp) :: ediff(ntype), X(nwch),Y(nwch),emw(nwch) + REAL(fp) :: XX,XY,del,dem,dem2,delta,deltb + INTEGER :: minlc(1) + INTEGER :: windex(nwch)=(/1,2,3,11,12/) ! window channel index of the library spectrum + + ! Sixteen candidate snow emissivity spectra + em = SEAICE_EMISS_ATMS_LIB + freq = FREQUENCY_ATMS + + minlc =minloc(ABS(freq-frequency)); freq_idx=minlc(1) + + !*** IDENTIFY SEAICE TYPE + sice_type = 4 !default + ediff=abs(Tb(1)/em(1,:)-Tb(2)/em(2,:))+abs(Tb(2)/em(2,:)-Tb(4)/em(11,:)) + minlc = minloc(ediff) ; sice_type=minlc(1) + + !*** adjustment from the library values + emw=em(windex,sice_type) + X=1.0/emw ; Y=LOG(Tb/(Ts*emw)) + IF(frequency >100_fp) THEN + XX=DOT_PRODUCT(X((/1,2,4,5/)),X((/1,2,4,5/))) + XY=DOT_PRODUCT(X((/1,2,4,5/)),Y((/1,2,4,5/))) + del=XY/XX + deltb=Tb(3)-Tb(5) + ELSE + XX=DOT_PRODUCT(X((/1,2,4/)),X((/1,2,4/))) + XY=DOT_PRODUCT(X((/1,2,4/)),Y((/1,2,4/))) + del=XY/XX + deltb=Tb(3)-Tb(4) + ENDIF + dem = 0.0_fp; delta = 0.0_fp + IF(frequency <= 30.0_fp ) dem = .9*del + IF(frequency > 30._fp .AND. frequency <= 40.0_fp ) dem = 0.9*del + IF(frequency > 40._fp .AND. frequency <= 50.0_fp ) dem = 0.9*del + IF(frequency > 50_fp) THEN + IF(del .LE. 0.0_fp .AND. ABS(deltb) .LT. 30.0_fp) delta=0.5+deltb/50.0 + IF(del .LE. 0.0_fp .AND. ABS(deltb) .GE. 30.0_fp) delta=1.0+deltb/50.0 + IF(del .GT. 0.0_fp .AND. ABS(deltb) .LT. 35.0_fp) delta=1.05-deltb/70.0 + IF(del .GT. 0.0_fp .AND. ABS(deltb) .GE. 35.0_fp) delta=.85-deltb/70.0 + IF(frequency <= 100.0_fp) dem = 0.9*del+(delta*del-del)*(frequency-50.0)/(100.0-50.0) + IF(frequency > 100.0_fp) dem = 0.65*delta*del + ENDIF + dem2=dem + + emissivity = em(freq_idx,sice_type)+(dem+dem2)/2.0 + IF (emissivity > 1.0_fp )emissivity = 1.0_fp + IF (emissivity <= 0.3_fp )emissivity = 0.3_fp + + em_vector(1) = emissivity + em_vector(2) = emissivity + + RETURN + + END SUBROUTINE ATMS_SeaICE_ByTbTs_D + + + SUBROUTINE ATMS_SeaICE_ByTbTs(frequency,tb,ts,em_vector) + + !----------------------------------------------------------------------------------------------------------! + !$$$ subprogram documentation block + ! + ! subprogram: Calculate emissivity by diagnosis-based algorithm + ! + ! + ! abstract: + ! Diagnose the snow type, and use the emissivity spectrum of the snow type as the first-guess to diagnose + ! the magnitude of necessary adjustment with respect to window-channel TBs and surface temperature Ts. Perfrom + ! necessary interpolation/extrapolation a required frequency and user angle. + ! + ! + ! input argument list: + ! + ! frequency - frequency in GHz + ! theta - local zenith angle (currently, not used here) + ! tb[1] ~ tb[5] - brightness temperature at five ATMS window channels: + ! tb[1] : 23.8 GHz + ! tb[2] : 31.4 GHz + ! tb[3] : 50.3 GHz + ! tb[4] : 88.2 GHz + ! tb[5] : 165.5 GHz + ! + ! output argument list: + ! + ! em_vector[1] and [2] - emissivity at two polarizations. + ! set esv = esh here and will be updated + ! snow_type - snow type + ! + ! + ! remarks: + ! + ! program history log: + ! Ming Chen, IMSG at NOAA/NESDIS/STAR date: 2012-04-28 + ! + ! + !----------------------------------------------------------------------------------------------------------! + + + INTEGER, PARAMETER :: nch =10, nwch = 5, ncoe = 4 + REAL(fp) :: tb(:) + REAL(fp) :: em_vector(*),emissivity,ts,frequency,discriminator(nwch) + INTEGER :: ich + REAL(fp),SAVE :: coe(100) + REAL(fp) :: X(nwch),Y(nwch) + REAL(fp) :: XX,XY,del,deltb + + + ! Fitting Coefficients Using Tb1, Tb2, Tb4 and Ts + coe(1:5) =(/ 9.815214e-001_fp, 3.783815e-003_fp, 6.391155e-004_fp, -9.106375e-005_fp, -4.263206e-003_fp/) + coe(21:25)=(/ 9.047181e-001_fp, -2.782826e-004_fp, 4.664207e-003_fp, -3.121744e-005_fp, -3.976189e-003_fp/) + coe(41:45)=(/ 1.163853e+000_fp, -1.419205e-003_fp, 5.505238e-003_fp, 1.506867e-003_fp, -6.157735e-003_fp/) + coe(61:65)=(/ 1.020753e+000_fp, -8.666064e-004_fp, 9.624331e-004_fp, 4.878773e-003_fp, -5.055044e-003_fp/) + coe(81:85)=(/ 1.438246e+000_fp, 5.667756e-004_fp,-2.621972e-003_fp, 5.928146e-003_fp, -5.856687e-003_fp/) + + + ! Calculate emissivity discriminators at five ATMS window channels + + DO ich = 1, nwch + discriminator(ich) = coe(1+(ich-1)*20) + discriminator(ich) = discriminator(ich) + coe((ich-1)*20 + 2)*tb(1) & + + coe((ich-1)*20 + 3)*tb(2) & + + coe((ich-1)*20 + 4)*tb(4) & + + coe( (ich-1)*20 + 5 )*ts + END DO + + X=1.0/discriminator ; Y=LOG(Tb/(Ts*discriminator)) + IF(frequency >100_fp) THEN + XX=DOT_PRODUCT(X((/1,2,4,5/)),X((/1,2,4,5/))) + XY=DOT_PRODUCT(X((/1,2,4,5/)),Y((/1,2,4,5/))) + del=XY/XX + deltb=Tb(3)-Tb(5) + ELSE + XX=DOT_PRODUCT(X((/1,2,4/)),X((/1,2,4/))) + XY=DOT_PRODUCT(X((/1,2,4/)),Y((/1,2,4/))) + del=XY/XX + deltb=Tb(3)-Tb(4) + ENDIF + + discriminator= discriminator+del + emissivity = 0.32_fp + call siem_interpolate(frequency,discriminator,emissivity) + + em_vector(1) = emissivity + em_vector(2) = emissivity + + + END SUBROUTINE ATMS_SeaICE_ByTbTs + + + SUBROUTINE siem_interpolate(frequency,discriminator,emissivity) + !------------------------------------------------------------------------------------------------------------ + !$$$ subprogram documentation block + ! . . . . + ! subprogram: + ! + ! prgmmr:Banghua Yan org: nesdis date: 2004-03-01 + ! + ! abstract: + ! (1) Find one snow emissivity spectrum to mimic the emission property of the + ! realistic snow condition using a set of discrminators + ! (2) Interpolate/extrapolate emissivity at a required frequency + ! + ! program history log: + ! + ! input argument list: + ! + ! frequency - frequency in GHz + ! discriminators - emissivity discriminators at five ATMS window channels + ! discriminator[1] : emissivity discriminator at 23.8 GHz + ! discriminator[2] : emissivity discriminator at 31.4 GHz + ! discriminator[3] : emissivity discriminator at 50.3 GHz + ! discriminator[4] : emissivity discriminator at 89 GHz + ! discriminator[5] : emissivity discriminator at 150 GHz + ! + ! Note: discriminator(1) and discriminator(3) are missing value in + ! 'ATMS & Ts', and 'MODL' options., which are defined to as -999.9, + ! output argument list: + ! + ! em_vector[1] and [2] - emissivity at two polarizations. + ! seaice_type - snow type (reference [2]) + ! + ! remarks: + ! + ! attributes: + ! language: f90 + ! machine: ibm rs/6000 sp + ! + !------------------------------------------------------------------------------------------------------------ + + INTEGER, PARAMETER :: ncand = 16,nch =5 + INTEGER :: i + REAL(fp):: frequency,emissivity,discriminator(*) + REAL(fp):: freq(nch) = (/23.8_fp, 31.4_fp, 50.3_fp,89.0_fp, 150.0_fp/) + + !Estimate sea ice emissivity at a required frequency + DO i = 2, nch + IF(frequency < freq(1)) exit + IF(frequency >= freq(nch)) exit + IF(frequency < freq(i)) THEN + emissivity = discriminator(i-1) + (discriminator(i)-discriminator(i-1))* & + (frequency - freq(i-1))/(freq(i) - freq(i-1)) + exit + ENDIF + END DO + + IF(frequency < freq(1)) emissivity = discriminator(1) + + ! Assume emissivity = constant at frequencies >= 150 GHz + IF(frequency >= freq(nch)) emissivity = discriminator(nch) + + END SUBROUTINE siem_interpolate + +END MODULE NESDIS_ATMS_SeaICE_Module diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_ATMS_SnowEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_ATMS_SnowEM_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NESDIS_ATMS_SnowEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_ATMS_SnowEM_Module.f90 index 31c8e2f9dd..6622015a67 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_ATMS_SnowEM_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_ATMS_SnowEM_Module.f90 @@ -881,18 +881,18 @@ SUBROUTINE ATMS_SNOW_ByTB_B(frequency,tbb,snow_type,em_vector) REAL(fp) :: em_vector(:),emissivity,frequency,ed0(nwch),discriminator(5) INTEGER :: snow_type,i,k,ich,nvalid_ch REAL(fp) :: coe(50) - + SAVE coe ! Fitting Coefficients at 31.4 GHz: Using Tb4, Tb5 - DATA (coe(k),k=1,5)/-4.015636e-001_fp,9.297894e-003_fp, -1.305068e-005_fp, & - 3.717131e-004_fp, -4.364877e-006_fp/ + coe(1:5) = (/-4.015636e-001_fp,9.297894e-003_fp, -1.305068e-005_fp, & + 3.717131e-004_fp, -4.364877e-006_fp/) ! Fitting Coefficients at 89 GHz: Using Tb4, Tb5 - DATA (coe(k),k=11,15)/-2.229547e-001_fp, -1.828402e-003_fp,1.754807e-005_fp, & - 9.793681e-003_fp, -3.137189e-005_fp/ + coe(11:15) = (/-2.229547e-001_fp, -1.828402e-003_fp,1.754807e-005_fp, & + 9.793681e-003_fp, -3.137189e-005_fp/) ! Fitting Coefficients at 150 GHz: Using Tb4, Tb5 - DATA (coe(k),k=21,25)/-3.395416e-001_fp,-4.632656e-003_fp,1.270735e-005_fp, & - 1.413038e-002_fp,-3.133239e-005_fp/ - SAVE coe + coe(21:25) = (/-3.395416e-001_fp,-4.632656e-003_fp,1.270735e-005_fp, & + 1.413038e-002_fp,-3.133239e-005_fp/) +! SAVE coe ! Calculate emissivity discriminators at five ATMS window channels DO ich = 1, nwch @@ -991,22 +991,22 @@ SUBROUTINE ATMS_SNOW_ByTBTs(frequency,tb,ts,snow_type,em_vector) LOGICAL:: pick_status,tindex(nind) SAVE threshold,DI_coe,LI_coe, HI_coe,nmodel - DATA nmodel/5,10,13,16,18,24,30,31,32,33,34,35,36,37,38/ + nmodel = (/5,10,13,16,18,24,30,31,32,33,34,35,36,37,38/) ! Fitting coefficients for emissivity index at 31.4 GHz - DATA LI_coe/ & + LI_coe = (/ & 7.963632e-001_fp, 7.215580e-003_fp, & -2.015921e-005_fp, -1.508286e-003_fp, & - 1.731405e-005_fp, -4.105358e-003_fp/ + 1.731405e-005_fp, -4.105358e-003_fp/) ! Fitting coefficients for emissivity index at 150 GHz - DATA HI_coe/ & + HI_coe = (/ & 1.012160e+000_fp, 6.100397e-003_fp, & -1.774347e-005_fp, -4.028211e-003_fp, & 1.224470e-005_fp, 2.345612e-003_fp, & -5.376814e-006_fp, -2.795332e-003_fp, & 8.072756e-006_fp, 3.529615e-003_fp, & - 1.955293e-006_fp, -4.942230e-003_fp/ + 1.955293e-006_fp, -4.942230e-003_fp/) ! Fitting coefficients for five discriminators DI_coe(1,0:ncoe-1)=(/ 3.285557e-002_fp, 2.677179e-005_fp, & @@ -1462,7 +1462,7 @@ SUBROUTINE ATMS_ALandEM_Snow(theta,frequency,snow_depth,ts,snow_type,em_vector) INTEGER snow_type,ich REAL(fp) freq_3w(nw_ind),esh_3w(nw_ind),esv_3w(nw_ind) COMPLEX(fp) eair - DATA freq_3w/31.4_fp,89.0_fp,150.0_fp/ + freq_3w = (/31.4_fp,89.0_fp,150.0_fp/) eair = cmplx(one,-zero,fp) diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_LandEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_LandEM_Module.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/NESDIS_LandEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_LandEM_Module.f90 diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_MHS_SICEEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_MHS_SICEEM_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NESDIS_MHS_SICEEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_MHS_SICEEM_Module.f90 index a7fdae8dfc..9dd32dd1c7 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_MHS_SICEEM_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_MHS_SICEEM_Module.f90 @@ -42,7 +42,7 @@ MODULE NESDIS_MHS_SICEEM_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_MHS_SICEEM_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_MHS_SICEEM_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_MHS_SnowEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_MHS_SnowEM_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NESDIS_MHS_SnowEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_MHS_SnowEM_Module.f90 index 2c347a4d07..e295f22557 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_MHS_SnowEM_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_MHS_SnowEM_Module.f90 @@ -41,7 +41,7 @@ MODULE NESDIS_MHS_SNOWEM_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_MHS_SnowEM_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_MHS_SnowEM_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_SEAICE_PHYEM_MODULE.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_SEAICE_PHYEM_MODULE.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NESDIS_SEAICE_PHYEM_MODULE.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_SEAICE_PHYEM_MODULE.f90 index 9ea8a97250..8fbb334d1e 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_SEAICE_PHYEM_MODULE.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_SEAICE_PHYEM_MODULE.f90 @@ -33,7 +33,7 @@ MODULE NESDIS_SEAICE_PHYEM_MODULE ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_SEAICE_PHYEM_MODULE.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_SEAICE_PHYEM_MODULE.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_SSMIS_SeaIceEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_SSMIS_SeaIceEM_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NESDIS_SSMIS_SeaIceEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_SSMIS_SeaIceEM_Module.f90 index 80de89759b..eb19eca098 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_SSMIS_SeaIceEM_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_SSMIS_SeaIceEM_Module.f90 @@ -43,7 +43,7 @@ MODULE NESDIS_SSMIS_SeaIceEM_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_SSMIS_SeaIceEM_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_SSMIS_SeaIceEM_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_SSMIS_SnowEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_SSMIS_SnowEM_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NESDIS_SSMIS_SnowEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_SSMIS_SnowEM_Module.f90 index f4800e4c0e..c575a27b70 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_SSMIS_SnowEM_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_SSMIS_SnowEM_Module.f90 @@ -44,7 +44,7 @@ MODULE NESDIS_SSMIS_SnowEM_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_SSMIS_SnowEM_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_SSMIS_SnowEM_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_SSMI_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_SSMI_Module.f90 similarity index 91% rename from var/external/crtm_2.2.3/libsrc/NESDIS_SSMI_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_SSMI_Module.f90 index 5626cfdf68..26431b50e4 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_SSMI_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_SSMI_Module.f90 @@ -40,7 +40,7 @@ MODULE NESDIS_SSMI_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_SSMI_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_SSMI_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS @@ -352,48 +352,48 @@ subroutine NESDIS_SSMI_SSICEEM_CORE(Snow_status,Ice_status,frequency,Ts,tv,th,em logical Snow_status,Ice_status,data_invalid - + save coe_v,coe_h ! ice - data (coe_v(1,1,k),k=1,5)/ -8.722723e-002_fp, 1.064573e-002_fp, & - -5.333843e-003_fp, -1.394910e-003_fp, 4.007640e-004_fp/ - data (coe_v(1,2,k),k=1,5)/-1.373924e-001_fp, 6.580569e-003_fp, & - -9.991220e-004_fp, -1.476022e-003_fp, 4.131816e-004_fp/ - data (coe_v(1,3,k),k=1,5)/ -2.329867e-001_fp, 6.419856e-003_fp, & - -5.260987e-003_fp, 3.342582e-003_fp, 4.139272e-004_fp/ - data (coe_v(1,4,k),k=1,5)/ -3.528638e-001_fp, 6.342649e-003_fp, & - -5.002575e-003_fp, -1.469298e-003_fp, 5.529711e-003_fp/ - data (coe_h(1,1,k),k=1,4)/ & + coe_v(1,1,1:5) = (/ -8.722723e-002_fp, 1.064573e-002_fp, & + -5.333843e-003_fp, -1.394910e-003_fp, 4.007640e-004_fp/) + coe_v(1,2,1:5) = (/-1.373924e-001_fp, 6.580569e-003_fp, & + -9.991220e-004_fp, -1.476022e-003_fp, 4.131816e-004_fp/) + coe_v(1,3,1:5) = (/ -2.329867e-001_fp, 6.419856e-003_fp, & + -5.260987e-003_fp, 3.342582e-003_fp, 4.139272e-004_fp/) + coe_v(1,4,1:5) = (/ -3.528638e-001_fp, 6.342649e-003_fp, & + -5.002575e-003_fp, -1.469298e-003_fp, 5.529711e-003_fp/) + coe_h(1,1,1:4) = (/ & -1.338736e-001_fp, 6.229798e-003_fp, -2.169491e-003_fp, & - 5.706367e-004_fp/ - data (coe_h(1,2,k),k=1,4)/ & + 5.706367e-004_fp/) + coe_h(1,2,1:4) = (/ & -2.747500e-001_fp, 2.041477e-003_fp, 2.581898e-003_fp, & - 5.924890e-004_fp/ - data (coe_h(1,3,k),k=1,4)/ & + 5.924890e-004_fp/) + coe_h(1,3,1:4) = (/ & -3.889575e-001_fp, 2.188889e-003_fp, -2.253243e-003_fp, & - 5.750499e-003_fp/ + 5.750499e-003_fp/) !snow - data (coe_v(2,1,k),k=1,5)/ 1.109066e-001_fp, 5.449409e-003_fp, & - 1.835799e-004_fp, -1.765248e-003_fp, -2.996101e-004_fp/ - data (coe_v(2,2,k),k=1,5)/ 9.356505e-002_fp, 1.320617e-003_fp, & - 4.449195e-003_fp, -1.786960e-003_fp, -3.479687e-004_fp/ - data (coe_v(2,3,k),k=1,5)/ 6.387097e-002_fp, 1.252447e-003_fp, & - 1.998846e-004_fp, 2.680219e-003_fp, -3.740141e-004_fp/ - data (coe_v(2,4,k),k=1,5)/ 4.150689e-002_fp, 1.420274e-003_fp, & - 1.223339e-004_fp, -1.948946e-003_fp, 4.248289e-003_fp/ - - data (coe_h(2,1,k),k=1,4)/ & + coe_v(2,1,1:5) = (/ 1.109066e-001_fp, 5.449409e-003_fp, & + 1.835799e-004_fp, -1.765248e-003_fp, -2.996101e-004_fp/) + coe_v(2,2,1:5) = (/ 9.356505e-002_fp, 1.320617e-003_fp, & + 4.449195e-003_fp, -1.786960e-003_fp, -3.479687e-004_fp/) + coe_v(2,3,1:5) = (/ 6.387097e-002_fp, 1.252447e-003_fp, & + 1.998846e-004_fp, 2.680219e-003_fp, -3.740141e-004_fp/) + coe_v(2,4,1:5) = (/ 4.150689e-002_fp, 1.420274e-003_fp, & + 1.223339e-004_fp, -1.948946e-003_fp, 4.248289e-003_fp/) + + coe_h(2,1,1:4) = (/ & 8.503807e-002_fp, 5.357374e-003_fp, -1.361660e-003_fp, & - -3.319696e-004_fp/ - data (coe_h(2,2,k),k=1,4)/ & + -3.319696e-004_fp/) + coe_h(2,2,1:4) = (/ & 4.200333e-002_fp, 1.278894e-003_fp, 2.963129e-003_fp, & - -4.087036e-004_fp/ - data (coe_h(2,3,k),k=1,4)/ & + -4.087036e-004_fp/) + coe_h(2,3,1:4) = (/ & 2.082461e-002_fp, 1.438480e-003_fp, -1.723992e-003_fp, & - 4.194914e-003_fp/ + 4.194914e-003_fp/) - save coe_v,coe_h +! save coe_v,coe_h ! Initialization diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_SSMI_SIceEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_SSMI_SIceEM_Module.f90 similarity index 94% rename from var/external/crtm_2.2.3/libsrc/NESDIS_SSMI_SIceEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_SSMI_SIceEM_Module.f90 index 1f12739614..d579646389 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_SSMI_SIceEM_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_SSMI_SIceEM_Module.f90 @@ -43,7 +43,7 @@ MODULE NESDIS_SSMI_SIceEM_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_SSMI_SIceEM_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_SSMI_SIceEM_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS @@ -335,27 +335,27 @@ subroutine SSMI_IceEM_CORE(frequency,Ts,tv,th,em_vector) logical data_invalid + save coe_v,coe_h - - data (coe_v(1,k),k=1,5)/ -8.722723e-002_fp, 1.064573e-002_fp, & - -5.333843e-003_fp, -1.394910e-003_fp, 4.007640e-004_fp/ - data (coe_v(2,k),k=1,5)/-1.373924e-001_fp, 6.580569e-003_fp, & - -9.991220e-004_fp, -1.476022e-003_fp, 4.131816e-004_fp/ - data (coe_v(3,k),k=1,5)/ -2.329867e-001_fp, 6.419856e-003_fp, & - -5.260987e-003_fp, 3.342582e-003_fp, 4.139272e-004_fp/ - data (coe_v(4,k),k=1,5)/ -3.528638e-001_fp, 6.342649e-003_fp, & - -5.002575e-003_fp, -1.469298e-003_fp, 5.529711e-003_fp/ - data (coe_h(1,k),k=1,4)/ & + coe_v(1,1:5) = (/ -8.722723e-002_fp, 1.064573e-002_fp, & + -5.333843e-003_fp, -1.394910e-003_fp, 4.007640e-004_fp/) + coe_v(2,1:5) = (/-1.373924e-001_fp, 6.580569e-003_fp, & + -9.991220e-004_fp, -1.476022e-003_fp, 4.131816e-004_fp/) + coe_v(3,1:5) = (/ -2.329867e-001_fp, 6.419856e-003_fp, & + -5.260987e-003_fp, 3.342582e-003_fp, 4.139272e-004_fp/) + coe_v(4,1:5) = (/ -3.528638e-001_fp, 6.342649e-003_fp, & + -5.002575e-003_fp, -1.469298e-003_fp, 5.529711e-003_fp/) + coe_h(1,1:4) = (/ & -1.338736e-001_fp, 6.229798e-003_fp, -2.169491e-003_fp, & - 5.706367e-004_fp/ - data (coe_h(2,k),k=1,4)/ & + 5.706367e-004_fp/) + coe_h(2,1:4) = (/ & -2.747500e-001_fp, 2.041477e-003_fp, 2.581898e-003_fp, & - 5.924890e-004_fp/ - data (coe_h(3,k),k=1,4)/ & + 5.924890e-004_fp/) + coe_h(3,1:4) = (/ & -3.889575e-001_fp, 2.188889e-003_fp, -2.253243e-003_fp, & - 5.750499e-003_fp/ + 5.750499e-003_fp/) - save coe_v,coe_h +! save coe_v,coe_h ! Initialization diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_SSMI_SnowEM_Module.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_SSMI_SnowEM_Module.f90 similarity index 94% rename from var/external/crtm_2.2.3/libsrc/NESDIS_SSMI_SnowEM_Module.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_SSMI_SnowEM_Module.f90 index 4ad0427a27..57c75e3f59 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_SSMI_SnowEM_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_SSMI_SnowEM_Module.f90 @@ -43,7 +43,7 @@ MODULE NESDIS_SSMI_SnowEM_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_SSMI_SnowEM_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_SSMI_SnowEM_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS @@ -338,29 +338,29 @@ subroutine SSMI_SnowEM_CORE(frequency,Ts,tv,th,em_vector) logical data_invalid - + save coe_v,coe_h !snow - data (coe_v(1,k),k=1,5)/ 1.109066e-001_fp, 5.449409e-003_fp, & - 1.835799e-004_fp, -1.765248e-003_fp, -2.996101e-004_fp/ - data (coe_v(2,k),k=1,5)/ 9.356505e-002_fp, 1.320617e-003_fp, & - 4.449195e-003_fp, -1.786960e-003_fp, -3.479687e-004_fp/ - data (coe_v(3,k),k=1,5)/ 6.387097e-002_fp, 1.252447e-003_fp, & - 1.998846e-004_fp, 2.680219e-003_fp, -3.740141e-004_fp/ - data (coe_v(4,k),k=1,5)/ 4.150689e-002_fp, 1.420274e-003_fp, & - 1.223339e-004_fp, -1.948946e-003_fp, 4.248289e-003_fp/ - - data (coe_h(1,k),k=1,4)/ & + coe_v(1,1:5) = (/ 1.109066e-001_fp, 5.449409e-003_fp, & + 1.835799e-004_fp, -1.765248e-003_fp, -2.996101e-004_fp/) + coe_v(2,1:5) = (/ 9.356505e-002_fp, 1.320617e-003_fp, & + 4.449195e-003_fp, -1.786960e-003_fp, -3.479687e-004_fp/) + coe_v(3,1:5) = (/ 6.387097e-002_fp, 1.252447e-003_fp, & + 1.998846e-004_fp, 2.680219e-003_fp, -3.740141e-004_fp/) + coe_v(4,1:5) = (/ 4.150689e-002_fp, 1.420274e-003_fp, & + 1.223339e-004_fp, -1.948946e-003_fp, 4.248289e-003_fp/) + + coe_h(1,1:4) = (/ & 8.503807e-002_fp, 5.357374e-003_fp, -1.361660e-003_fp, & - -3.319696e-004_fp/ - data (coe_h(2,k),k=1,4)/ & + -3.319696e-004_fp/) + coe_h(2,1:4) = (/ & 4.200333e-002_fp, 1.278894e-003_fp, 2.963129e-003_fp, & - -4.087036e-004_fp/ - data (coe_h(3,k),k=1,4)/ & + -4.087036e-004_fp/) + coe_h(3,1:4) = (/ & 2.082461e-002_fp, 1.438480e-003_fp, -1.723992e-003_fp, & - 4.194914e-003_fp/ + 4.194914e-003_fp/) - save coe_v,coe_h +! save coe_v,coe_h ! Initialization diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_SnowEM_ATMS_Parameters.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_SnowEM_ATMS_Parameters.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/NESDIS_SnowEM_ATMS_Parameters.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_SnowEM_ATMS_Parameters.f90 diff --git a/var/external/crtm_2.2.3/libsrc/NESDIS_SnowEM_Parameters.f90 b/var/external/crtm_2.3.0/libsrc/NESDIS_SnowEM_Parameters.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NESDIS_SnowEM_Parameters.f90 rename to var/external/crtm_2.3.0/libsrc/NESDIS_SnowEM_Parameters.f90 index 79879a12d8..60d71157b7 100644 --- a/var/external/crtm_2.2.3/libsrc/NESDIS_SnowEM_Parameters.f90 +++ b/var/external/crtm_2.3.0/libsrc/NESDIS_SnowEM_Parameters.f90 @@ -33,7 +33,7 @@ MODULE NESDIS_SnowEM_Parameters ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NESDIS_SnowEM_Parameters.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NESDIS_SnowEM_Parameters.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Snow types INTEGER, PUBLIC, PARAMETER :: INVALID_SNOW_TYPE = -999 diff --git a/var/external/crtm_2.2.3/libsrc/NLTECoeff_Binary_IO.f90 b/var/external/crtm_2.3.0/libsrc/NLTECoeff_Binary_IO.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NLTECoeff_Binary_IO.f90 rename to var/external/crtm_2.3.0/libsrc/NLTECoeff_Binary_IO.f90 index e2b6adbe2c..a82bc61615 100644 --- a/var/external/crtm_2.2.3/libsrc/NLTECoeff_Binary_IO.f90 +++ b/var/external/crtm_2.3.0/libsrc/NLTECoeff_Binary_IO.f90 @@ -47,7 +47,7 @@ MODULE NLTECoeff_Binary_IO ! Module parameters ! ----------------- CHARACTER(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = & - '$Id: NLTECoeff_Binary_IO.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NLTECoeff_Binary_IO.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE' ! Default message length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/NLTECoeff_Define.f90 b/var/external/crtm_2.3.0/libsrc/NLTECoeff_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NLTECoeff_Define.f90 rename to var/external/crtm_2.3.0/libsrc/NLTECoeff_Define.f90 index 8e42d0d428..33b2e72905 100644 --- a/var/external/crtm_2.2.3/libsrc/NLTECoeff_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/NLTECoeff_Define.f90 @@ -67,7 +67,7 @@ MODULE NLTECoeff_Define ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NLTECoeff_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NLTECoeff_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(Double), PARAMETER :: ZERO = 0.0_Double REAL(Double), PARAMETER :: ONE = 1.0_Double @@ -101,7 +101,7 @@ MODULE NLTECoeff_Define INTEGER(Long) :: n_NLTE_Channels = 0 ! n4 dimension INTEGER(Long) :: n_Channels = 0 ! n5 dimension ! ..."Internal" dimension -!comment out to allow PGI 13.3 to compile INTEGER(Long) :: n_Layers = N_LAYERS + INTEGER(Long) :: n_Layers = N_LAYERS ! Sensor info CHARACTER(SL) :: Sensor_Id = '' INTEGER(Long) :: WMO_Satellite_ID = INVALID_WMO_SATELLITE_ID diff --git a/var/external/crtm_2.2.3/libsrc/NLTE_Parameters.f90 b/var/external/crtm_2.3.0/libsrc/NLTE_Parameters.f90 similarity index 96% rename from var/external/crtm_2.2.3/libsrc/NLTE_Parameters.f90 rename to var/external/crtm_2.3.0/libsrc/NLTE_Parameters.f90 index 5c68cc2116..8bbf42d6b4 100644 --- a/var/external/crtm_2.2.3/libsrc/NLTE_Parameters.f90 +++ b/var/external/crtm_2.3.0/libsrc/NLTE_Parameters.f90 @@ -46,7 +46,7 @@ MODULE NLTE_Parameters ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NLTE_Parameters.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NLTE_Parameters.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Pressure levels for computing mean temperatures in the two layers INTEGER, PARAMETER :: N_NLTE_LAYERS = 2 diff --git a/var/external/crtm_2.2.3/libsrc/NLTE_Predictor_Define.f90 b/var/external/crtm_2.3.0/libsrc/NLTE_Predictor_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NLTE_Predictor_Define.f90 rename to var/external/crtm_2.3.0/libsrc/NLTE_Predictor_Define.f90 index 6e02d7a28b..67fbc948be 100644 --- a/var/external/crtm_2.2.3/libsrc/NLTE_Predictor_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/NLTE_Predictor_Define.f90 @@ -57,7 +57,7 @@ MODULE NLTE_Predictor_Define ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: NLTE_Predictor_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NLTE_Predictor_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 diff --git a/var/external/crtm_2.2.3/libsrc/NLTE_Predictor_IO.f90 b/var/external/crtm_2.3.0/libsrc/NLTE_Predictor_IO.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/NLTE_Predictor_IO.f90 rename to var/external/crtm_2.3.0/libsrc/NLTE_Predictor_IO.f90 index 6d50ee8cd9..050ff4e860 100644 --- a/var/external/crtm_2.2.3/libsrc/NLTE_Predictor_IO.f90 +++ b/var/external/crtm_2.3.0/libsrc/NLTE_Predictor_IO.f90 @@ -42,7 +42,7 @@ MODULE NLTE_Predictor_IO ! Module parameters ! ----------------- CHARACTER(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = & - '$Id: NLTE_Predictor_IO.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: NLTE_Predictor_IO.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE' ! Default message length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/ODAS_AtmAbsorption.f90 b/var/external/crtm_2.3.0/libsrc/ODAS_AtmAbsorption.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODAS_AtmAbsorption.f90 rename to var/external/crtm_2.3.0/libsrc/ODAS_AtmAbsorption.f90 index a990d26c27..4a42619569 100644 --- a/var/external/crtm_2.2.3/libsrc/ODAS_AtmAbsorption.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODAS_AtmAbsorption.f90 @@ -57,7 +57,7 @@ MODULE ODAS_AtmAbsorption ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: ODAS_AtmAbsorption.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODAS_AtmAbsorption.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! ------------------------------------------ diff --git a/var/external/crtm_2.2.3/libsrc/ODAS_Binary_IO.f90 b/var/external/crtm_2.3.0/libsrc/ODAS_Binary_IO.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODAS_Binary_IO.f90 rename to var/external/crtm_2.3.0/libsrc/ODAS_Binary_IO.f90 index d426ff94f5..33cfdcd342 100644 --- a/var/external/crtm_2.2.3/libsrc/ODAS_Binary_IO.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODAS_Binary_IO.f90 @@ -47,7 +47,7 @@ MODULE ODAS_Binary_IO ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: ODAS_Binary_IO.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODAS_Binary_IO.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message character length INTEGER, PARAMETER :: ML = 512 ! Keyword set value diff --git a/var/external/crtm_2.2.3/libsrc/ODAS_Define.f90 b/var/external/crtm_2.3.0/libsrc/ODAS_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODAS_Define.f90 rename to var/external/crtm_2.3.0/libsrc/ODAS_Define.f90 index 389bfb5ea6..d2db245290 100644 --- a/var/external/crtm_2.2.3/libsrc/ODAS_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODAS_Define.f90 @@ -69,7 +69,7 @@ MODULE ODAS_Define ! ----------------- ! RCS Id for the module CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: ODAS_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODAS_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! ODAS invalid values INTEGER, PARAMETER :: IP_INVALID = -1 REAL(Double), PARAMETER :: FP_INVALID = -1.0_Double diff --git a/var/external/crtm_2.2.3/libsrc/ODAS_Predictor.f90 b/var/external/crtm_2.3.0/libsrc/ODAS_Predictor.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODAS_Predictor.f90 rename to var/external/crtm_2.3.0/libsrc/ODAS_Predictor.f90 index 35ae47fe82..596a1cd736 100644 --- a/var/external/crtm_2.2.3/libsrc/ODAS_Predictor.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODAS_Predictor.f90 @@ -70,7 +70,7 @@ MODULE ODAS_Predictor ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: ODAS_Predictor.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODAS_Predictor.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Absorbers in the gas absorption model diff --git a/var/external/crtm_2.2.3/libsrc/ODAS_Predictor_Define.f90 b/var/external/crtm_2.3.0/libsrc/ODAS_Predictor_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODAS_Predictor_Define.f90 rename to var/external/crtm_2.3.0/libsrc/ODAS_Predictor_Define.f90 index 036edaf727..6d97dac291 100644 --- a/var/external/crtm_2.2.3/libsrc/ODAS_Predictor_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODAS_Predictor_Define.f90 @@ -59,7 +59,7 @@ MODULE ODAS_Predictor_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: ODAS_Predictor_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODAS_Predictor_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: ODAS_PREDICTOR_RELEASE = 3 ! This determines structure and file formats. INTEGER, PARAMETER :: ODAS_PREDICTOR_VERSION = 1 ! This is just the default data version. diff --git a/var/external/crtm_2.2.3/libsrc/ODAS_TauCoeff.f90 b/var/external/crtm_2.3.0/libsrc/ODAS_TauCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODAS_TauCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/ODAS_TauCoeff.f90 index 69f1e8d392..3857fc66af 100644 --- a/var/external/crtm_2.2.3/libsrc/ODAS_TauCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODAS_TauCoeff.f90 @@ -61,7 +61,7 @@ MODULE ODAS_TauCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER, PRIVATE :: MODULE_RCS_ID = & - '$Id: ODAS_TauCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODAS_TauCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! -------------------------------------- diff --git a/var/external/crtm_2.2.3/libsrc/ODPS_AtmAbsorption.f90 b/var/external/crtm_2.3.0/libsrc/ODPS_AtmAbsorption.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/ODPS_AtmAbsorption.f90 rename to var/external/crtm_2.3.0/libsrc/ODPS_AtmAbsorption.f90 diff --git a/var/external/crtm_2.2.3/libsrc/ODPS_Binary_IO.f90 b/var/external/crtm_2.3.0/libsrc/ODPS_Binary_IO.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/ODPS_Binary_IO.f90 rename to var/external/crtm_2.3.0/libsrc/ODPS_Binary_IO.f90 diff --git a/var/external/crtm_2.2.3/libsrc/ODPS_CoordinateMapping.f90 b/var/external/crtm_2.3.0/libsrc/ODPS_CoordinateMapping.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODPS_CoordinateMapping.f90 rename to var/external/crtm_2.3.0/libsrc/ODPS_CoordinateMapping.f90 index 29cefbe3db..9a038a0ac1 100644 --- a/var/external/crtm_2.2.3/libsrc/ODPS_CoordinateMapping.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODPS_CoordinateMapping.f90 @@ -57,7 +57,7 @@ MODULE ODPS_CoordinateMapping ! ----------------- ! RCS Id for the module CHARACTER(*), PRIVATE, PARAMETER :: MODULE_RCS_ID = & - '$Id: ODPS_CoordinateMapping.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODPS_CoordinateMapping.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/ODPS_Define.f90 b/var/external/crtm_2.3.0/libsrc/ODPS_Define.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/ODPS_Define.f90 rename to var/external/crtm_2.3.0/libsrc/ODPS_Define.f90 diff --git a/var/external/crtm_2.2.3/libsrc/ODPS_Predictor.f90 b/var/external/crtm_2.3.0/libsrc/ODPS_Predictor.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/ODPS_Predictor.f90 rename to var/external/crtm_2.3.0/libsrc/ODPS_Predictor.f90 diff --git a/var/external/crtm_2.2.3/libsrc/ODPS_Predictor_Define.f90 b/var/external/crtm_2.3.0/libsrc/ODPS_Predictor_Define.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/ODPS_Predictor_Define.f90 rename to var/external/crtm_2.3.0/libsrc/ODPS_Predictor_Define.f90 diff --git a/var/external/crtm_2.2.3/libsrc/ODPS_TauCoeff.f90 b/var/external/crtm_2.3.0/libsrc/ODPS_TauCoeff.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/ODPS_TauCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/ODPS_TauCoeff.f90 diff --git a/var/external/crtm_2.2.3/libsrc/ODSSU_AtmAbsorption.f90 b/var/external/crtm_2.3.0/libsrc/ODSSU_AtmAbsorption.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODSSU_AtmAbsorption.f90 rename to var/external/crtm_2.3.0/libsrc/ODSSU_AtmAbsorption.f90 index 13be4392d6..3cd111c118 100644 --- a/var/external/crtm_2.2.3/libsrc/ODSSU_AtmAbsorption.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODSSU_AtmAbsorption.f90 @@ -79,7 +79,7 @@ MODULE ODSSU_AtmAbsorption ! Parameters ! ---------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: ODSSU_AtmAbsorption.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODSSU_AtmAbsorption.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/ODSSU_Binary_IO.f90 b/var/external/crtm_2.3.0/libsrc/ODSSU_Binary_IO.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODSSU_Binary_IO.f90 rename to var/external/crtm_2.3.0/libsrc/ODSSU_Binary_IO.f90 index 657060ff63..8fc968030a 100644 --- a/var/external/crtm_2.2.3/libsrc/ODSSU_Binary_IO.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODSSU_Binary_IO.f90 @@ -52,7 +52,7 @@ MODULE ODSSU_Binary_IO ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: ODSSU_Binary_IO.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODSSU_Binary_IO.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Keyword set value INTEGER, PARAMETER :: SET = 1 ! Message character length diff --git a/var/external/crtm_2.2.3/libsrc/ODSSU_Define.f90 b/var/external/crtm_2.3.0/libsrc/ODSSU_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODSSU_Define.f90 rename to var/external/crtm_2.3.0/libsrc/ODSSU_Define.f90 index 8288aed64c..1af4221c19 100644 --- a/var/external/crtm_2.2.3/libsrc/ODSSU_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODSSU_Define.f90 @@ -58,7 +58,7 @@ MODULE ODSSU_Define ! ----------------- ! RCS Id for the module CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: ODSSU_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODSSU_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! ODSSU invalid values INTEGER, PARAMETER :: IP_INVALID = -1 REAL(Double), PARAMETER :: FP_INVALID = -1.0_Double diff --git a/var/external/crtm_2.2.3/libsrc/ODSSU_TauCoeff.f90 b/var/external/crtm_2.3.0/libsrc/ODSSU_TauCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODSSU_TauCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/ODSSU_TauCoeff.f90 index a92f93268f..22c6a1c03f 100644 --- a/var/external/crtm_2.2.3/libsrc/ODSSU_TauCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODSSU_TauCoeff.f90 @@ -60,7 +60,7 @@ MODULE ODSSU_TauCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER, PRIVATE :: MODULE_RCS_ID = & - '$Id: ODSSU_TauCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODSSU_TauCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! -------------------------------------- diff --git a/var/external/crtm_2.2.3/libsrc/ODZeeman_AtmAbsorption.f90 b/var/external/crtm_2.3.0/libsrc/ODZeeman_AtmAbsorption.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODZeeman_AtmAbsorption.f90 rename to var/external/crtm_2.3.0/libsrc/ODZeeman_AtmAbsorption.f90 index da57b30023..7da6f9f266 100644 --- a/var/external/crtm_2.2.3/libsrc/ODZeeman_AtmAbsorption.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODZeeman_AtmAbsorption.f90 @@ -75,7 +75,7 @@ MODULE ODZeeman_AtmAbsorption ! Parameters ! ---------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: ODZeeman_AtmAbsorption.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODZeeman_AtmAbsorption.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/ODZeeman_Predictor.f90 b/var/external/crtm_2.3.0/libsrc/ODZeeman_Predictor.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/ODZeeman_Predictor.f90 rename to var/external/crtm_2.3.0/libsrc/ODZeeman_Predictor.f90 diff --git a/var/external/crtm_2.2.3/libsrc/ODZeeman_TauCoeff.f90 b/var/external/crtm_2.3.0/libsrc/ODZeeman_TauCoeff.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/ODZeeman_TauCoeff.f90 rename to var/external/crtm_2.3.0/libsrc/ODZeeman_TauCoeff.f90 index dfb27f9f6b..f4d26d44a3 100644 --- a/var/external/crtm_2.2.3/libsrc/ODZeeman_TauCoeff.f90 +++ b/var/external/crtm_2.3.0/libsrc/ODZeeman_TauCoeff.f90 @@ -52,7 +52,7 @@ MODULE ODZeeman_TauCoeff ! Module parameters ! ----------------- CHARACTER(*), PARAMETER, PRIVATE :: MODULE_RCS_ID = & - '$Id: ODZeeman_TauCoeff.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: ODZeeman_TauCoeff.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! -------------------------------------- diff --git a/var/external/crtm_2.2.3/libsrc/PAFV_Define.f90 b/var/external/crtm_2.3.0/libsrc/PAFV_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/PAFV_Define.f90 rename to var/external/crtm_2.3.0/libsrc/PAFV_Define.f90 index b335ca9071..c877c6588f 100644 --- a/var/external/crtm_2.2.3/libsrc/PAFV_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/PAFV_Define.f90 @@ -59,7 +59,7 @@ MODULE PAFV_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: PAFV_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: PAFV_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: PAFV_RELEASE = 2 ! This determines structure and file formats. INTEGER, PARAMETER :: PAFV_VERSION = 1 ! This is just the default data version. diff --git a/var/external/crtm_2.2.3/libsrc/Profile_Utility_Parameters.f90 b/var/external/crtm_2.3.0/libsrc/Profile_Utility_Parameters.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/Profile_Utility_Parameters.f90 rename to var/external/crtm_2.3.0/libsrc/Profile_Utility_Parameters.f90 diff --git a/var/external/crtm_2.2.3/libsrc/RTV_Define.f90 b/var/external/crtm_2.3.0/libsrc/RTV_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/RTV_Define.f90 rename to var/external/crtm_2.3.0/libsrc/RTV_Define.f90 index ec3d22c163..3b6d16f461 100644 --- a/var/external/crtm_2.2.3/libsrc/RTV_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/RTV_Define.f90 @@ -65,7 +65,7 @@ MODULE RTV_Define ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: RTV_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: RTV_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Threshold for determing if an additional stream ! angle is required for the satellite zenith angle diff --git a/var/external/crtm_2.2.3/libsrc/Reflection_Correction_Module.f90 b/var/external/crtm_2.3.0/libsrc/Reflection_Correction_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Reflection_Correction_Module.f90 rename to var/external/crtm_2.3.0/libsrc/Reflection_Correction_Module.f90 index f6d80cf3e6..6534da6fd2 100644 --- a/var/external/crtm_2.2.3/libsrc/Reflection_Correction_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/Reflection_Correction_Module.f90 @@ -50,7 +50,7 @@ MODULE Reflection_Correction_Module ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Reflection_Correction_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Reflection_Correction_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(fp), PARAMETER :: ZERO = 0.0_fp diff --git a/var/external/crtm_2.2.3/libsrc/SEcategory_Define.f90 b/var/external/crtm_2.3.0/libsrc/SEcategory_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/SEcategory_Define.f90 rename to var/external/crtm_2.3.0/libsrc/SEcategory_Define.f90 index 0fa0e330a0..0a9f709924 100644 --- a/var/external/crtm_2.2.3/libsrc/SEcategory_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/SEcategory_Define.f90 @@ -67,7 +67,7 @@ MODULE SEcategory_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: SEcategory_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: SEcategory_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Datatype information CHARACTER(*), PARAMETER :: SECATEGORY_DATATYPE = 'SEcategory' ! Release and version diff --git a/var/external/crtm_2.2.3/libsrc/SOI_Module.f90 b/var/external/crtm_2.3.0/libsrc/SOI_Module.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/SOI_Module.f90 rename to var/external/crtm_2.3.0/libsrc/SOI_Module.f90 index bfdeb968c8..1a101cf164 100644 --- a/var/external/crtm_2.2.3/libsrc/SOI_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/SOI_Module.f90 @@ -50,7 +50,7 @@ MODULE SOI_Module ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: SOI_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: SOI_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/SSU_Input_Define.f90 b/var/external/crtm_2.3.0/libsrc/SSU_Input_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/SSU_Input_Define.f90 rename to var/external/crtm_2.3.0/libsrc/SSU_Input_Define.f90 index d909d8f84b..f59a61c24d 100644 --- a/var/external/crtm_2.2.3/libsrc/SSU_Input_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/SSU_Input_Define.f90 @@ -58,7 +58,7 @@ MODULE SSU_Input_Define ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: SSU_Input_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: SSU_Input_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: SSU_INPUT_RELEASE = 1 ! This determines structure and file formats. INTEGER, PARAMETER :: SSU_INPUT_VERSION = 1 ! This is just the default data version. diff --git a/var/external/crtm_2.2.3/libsrc/Search_Utility.f90 b/var/external/crtm_2.3.0/libsrc/Search_Utility.f90 similarity index 98% rename from var/external/crtm_2.2.3/libsrc/Search_Utility.f90 rename to var/external/crtm_2.3.0/libsrc/Search_Utility.f90 index ee5a5ad764..0685980c2f 100644 --- a/var/external/crtm_2.2.3/libsrc/Search_Utility.f90 +++ b/var/external/crtm_2.3.0/libsrc/Search_Utility.f90 @@ -33,7 +33,7 @@ MODULE Search_Utility ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Search_Utility.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Search_Utility.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' CONTAINS diff --git a/var/external/crtm_2.2.3/libsrc/SensorInfo_Parameters.f90 b/var/external/crtm_2.3.0/libsrc/SensorInfo_Parameters.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/SensorInfo_Parameters.f90 rename to var/external/crtm_2.3.0/libsrc/SensorInfo_Parameters.f90 diff --git a/var/external/crtm_2.2.3/libsrc/Slope_Variance.f90 b/var/external/crtm_2.3.0/libsrc/Slope_Variance.f90 similarity index 98% rename from var/external/crtm_2.2.3/libsrc/Slope_Variance.f90 rename to var/external/crtm_2.3.0/libsrc/Slope_Variance.f90 index 36b3fbb501..0edd0e1dd5 100644 --- a/var/external/crtm_2.2.3/libsrc/Slope_Variance.f90 +++ b/var/external/crtm_2.3.0/libsrc/Slope_Variance.f90 @@ -42,7 +42,7 @@ MODULE Slope_Variance ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Slope_Variance.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Slope_Variance.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(fp), PARAMETER :: ZERO = 0.0_fp diff --git a/var/external/crtm_2.2.3/libsrc/Small_Scale_Correction_Module.f90 b/var/external/crtm_2.3.0/libsrc/Small_Scale_Correction_Module.f90 similarity index 98% rename from var/external/crtm_2.2.3/libsrc/Small_Scale_Correction_Module.f90 rename to var/external/crtm_2.3.0/libsrc/Small_Scale_Correction_Module.f90 index 0e12b5333c..465941483c 100644 --- a/var/external/crtm_2.2.3/libsrc/Small_Scale_Correction_Module.f90 +++ b/var/external/crtm_2.3.0/libsrc/Small_Scale_Correction_Module.f90 @@ -57,7 +57,7 @@ MODULE Small_Scale_Correction_Module ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Small_Scale_Correction_Module.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Small_Scale_Correction_Module.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(fp), PARAMETER :: ZERO = 0.0_fp diff --git a/var/external/crtm_2.2.3/libsrc/Sort_Utility.f90 b/var/external/crtm_2.3.0/libsrc/Sort_Utility.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/Sort_Utility.f90 rename to var/external/crtm_2.3.0/libsrc/Sort_Utility.f90 diff --git a/var/external/crtm_2.2.3/libsrc/SpcCoeff_Binary_IO.f90 b/var/external/crtm_2.3.0/libsrc/SpcCoeff_Binary_IO.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/SpcCoeff_Binary_IO.f90 rename to var/external/crtm_2.3.0/libsrc/SpcCoeff_Binary_IO.f90 index 821810453c..7b95dcb47a 100644 --- a/var/external/crtm_2.2.3/libsrc/SpcCoeff_Binary_IO.f90 +++ b/var/external/crtm_2.3.0/libsrc/SpcCoeff_Binary_IO.f90 @@ -52,7 +52,7 @@ MODULE SpcCoeff_Binary_IO ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: SpcCoeff_Binary_IO.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: SpcCoeff_Binary_IO.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Default message length INTEGER, PARAMETER :: ML = 512 ! Ancillary data indicator diff --git a/var/external/crtm_2.2.3/libsrc/SpcCoeff_Define.f90 b/var/external/crtm_2.3.0/libsrc/SpcCoeff_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/SpcCoeff_Define.f90 rename to var/external/crtm_2.3.0/libsrc/SpcCoeff_Define.f90 index a4f7b21f77..ba6ad9bc1b 100644 --- a/var/external/crtm_2.2.3/libsrc/SpcCoeff_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/SpcCoeff_Define.f90 @@ -135,7 +135,7 @@ MODULE SpcCoeff_Define ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: SpcCoeff_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: SpcCoeff_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Literal constants REAL(Double), PARAMETER :: ZERO = 0.0_Double ! Default message string length diff --git a/var/external/crtm_2.2.3/libsrc/Spectral_Units_Conversion.f90 b/var/external/crtm_2.3.0/libsrc/Spectral_Units_Conversion.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Spectral_Units_Conversion.f90 rename to var/external/crtm_2.3.0/libsrc/Spectral_Units_Conversion.f90 index 852670cc07..31ebddf9a9 100644 --- a/var/external/crtm_2.2.3/libsrc/Spectral_Units_Conversion.f90 +++ b/var/external/crtm_2.3.0/libsrc/Spectral_Units_Conversion.f90 @@ -37,7 +37,7 @@ MODULE Spectral_Units_Conversion ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Spectral_Units_Conversion.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Spectral_Units_Conversion.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' REAL(fp), PARAMETER :: ZERO = 0.0_fp REAL(fp), PARAMETER :: ONE = 1.0_fp diff --git a/var/external/crtm_2.2.3/libsrc/String_Utility.f90 b/var/external/crtm_2.3.0/libsrc/String_Utility.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/String_Utility.f90 rename to var/external/crtm_2.3.0/libsrc/String_Utility.f90 index 0103fe3c46..e543e320c8 100644 --- a/var/external/crtm_2.2.3/libsrc/String_Utility.f90 +++ b/var/external/crtm_2.3.0/libsrc/String_Utility.f90 @@ -43,7 +43,7 @@ MODULE String_Utility ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: String_Utility.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: String_Utility.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! List of character for case conversion CHARACTER(*), PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz' CHARACTER(*), PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' diff --git a/var/external/crtm_2.2.3/libsrc/Subset_Define.f90 b/var/external/crtm_2.3.0/libsrc/Subset_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Subset_Define.f90 rename to var/external/crtm_2.3.0/libsrc/Subset_Define.f90 index 06df12c8d9..e8a3912709 100644 --- a/var/external/crtm_2.2.3/libsrc/Subset_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/Subset_Define.f90 @@ -54,7 +54,7 @@ MODULE Subset_Define ! Module Parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Subset_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Subset_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! ----------------------------------- diff --git a/var/external/crtm_2.2.3/libsrc/TauCoeff_Define.f90 b/var/external/crtm_2.3.0/libsrc/TauCoeff_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/TauCoeff_Define.f90 rename to var/external/crtm_2.3.0/libsrc/TauCoeff_Define.f90 index 136dfe35af..3ef4e26724 100644 --- a/var/external/crtm_2.2.3/libsrc/TauCoeff_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/TauCoeff_Define.f90 @@ -60,7 +60,7 @@ MODULE TauCoeff_Define ! ----------------- ! RCS Id for the module CHARACTER(*), PARAMETER :: MODULE_RCS_ID = & - '$Id: TauCoeff_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: TauCoeff_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER , PARAMETER :: ML = 256 ! Sensor ID string length diff --git a/var/external/crtm_2.2.3/libsrc/Timing_Utility.f90 b/var/external/crtm_2.3.0/libsrc/Timing_Utility.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Timing_Utility.f90 rename to var/external/crtm_2.3.0/libsrc/Timing_Utility.f90 index 4b7734416f..7366c123fd 100644 --- a/var/external/crtm_2.2.3/libsrc/Timing_Utility.f90 +++ b/var/external/crtm_2.3.0/libsrc/Timing_Utility.f90 @@ -23,6 +23,7 @@ MODULE Timing_Utility PUBLIC :: Timing_End PUBLIC :: Timing_Display PUBLIC :: Timing_Inspect + PUBLIC :: Timing_ToString PUBLIC :: Timing_Set PUBLIC :: Timing_Get PUBLIC :: Timing_WriteFile @@ -34,7 +35,7 @@ MODULE Timing_Utility ! Parameters CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: Timing_Utility.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Timing_Utility.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' INTEGER, PARAMETER :: ML = 256 @@ -370,6 +371,7 @@ SUBROUTINE Timing_Get( & IF ( PRESENT(Is_Valid ) ) Is_Valid = self%Is_Valid END SUBROUTINE Timing_Get + !-------------------------------------------------------------------------------- !:sdoc+: ! diff --git a/var/external/crtm_2.2.3/libsrc/Type_Kinds.f90 b/var/external/crtm_2.3.0/libsrc/Type_Kinds.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/Type_Kinds.f90 rename to var/external/crtm_2.3.0/libsrc/Type_Kinds.f90 diff --git a/var/external/crtm_2.3.0/libsrc/UnitTest_Define.f90 b/var/external/crtm_2.3.0/libsrc/UnitTest_Define.f90 new file mode 100644 index 0000000000..67ad7d527c --- /dev/null +++ b/var/external/crtm_2.3.0/libsrc/UnitTest_Define.f90 @@ -0,0 +1,5392 @@ +! +! UnitTest_Define +! +! Module defining the UnitTest object +! +! +! CREATION HISTORY: +! Written by: Paul van Delst, 05-Feb-2007 +! paul.vandelst@noaa.gov +! + +MODULE UnitTest_Define + + ! ------------------ + ! Environment setup + ! ----------------- + ! Module usage + USE Type_Kinds , ONLY: Byte, Short, Long, Single, Double + USE Compare_Float_Numbers, ONLY: OPERATOR(.EqualTo.), & + Compares_Within_Tolerance + ! Disable implicit typing + IMPLICIT NONE + + + ! ------------ + ! Visibilities + ! ------------ + ! Everything private by default + PRIVATE + ! Datatypes + PUBLIC :: UnitTest_type + ! Procedures + ! **** These procedure interfaces are kept for legacy + ! **** purposes, but deprecated for new code + PUBLIC :: UnitTest_Init + PUBLIC :: UnitTest_Setup + PUBLIC :: UnitTest_Report + PUBLIC :: UnitTest_Summary + PUBLIC :: UnitTest_n_Passed + PUBLIC :: UnitTest_n_Failed + PUBLIC :: UnitTest_Passed + PUBLIC :: UnitTest_Failed + PUBLIC :: UnitTest_Assert + PUBLIC :: UnitTest_IsEqual + PUBLIC :: UnitTest_IsEqualWithin + PUBLIC :: UnitTest_IsWithinSigFig + + + ! --------------------- + ! Procedure overloading + ! --------------------- + + ! **** Pre-type-bound procedure interface definitions + ! **** Kept for legacy purposes, but deprecated for new code + INTERFACE UnitTest_Init + MODULE PROCEDURE Init + END INTERFACE UnitTest_Init + + INTERFACE UnitTest_Setup + MODULE PROCEDURE Setup + END INTERFACE UnitTest_Setup + + INTERFACE UnitTest_Report + MODULE PROCEDURE Report + END INTERFACE UnitTest_Report + + INTERFACE UnitTest_Summary + MODULE PROCEDURE Summary + END INTERFACE UnitTest_Summary + + INTERFACE UnitTest_n_Passed + MODULE PROCEDURE n_Passed + END INTERFACE UnitTest_n_Passed + + INTERFACE UnitTest_n_Failed + MODULE PROCEDURE n_Failed + END INTERFACE UnitTest_n_Failed + + INTERFACE UnitTest_Passed + MODULE PROCEDURE Passed + END INTERFACE UnitTest_Passed + + INTERFACE UnitTest_Failed + MODULE PROCEDURE Failed + END INTERFACE UnitTest_Failed + + INTERFACE UnitTest_Assert + MODULE PROCEDURE Assert + END INTERFACE UnitTest_Assert + + INTERFACE UnitTest_IsEqual + ! INTEGER(Byte) procedures + MODULE PROCEDURE intbyte_assert_equal_s + MODULE PROCEDURE intbyte_assert_equal_r1 + MODULE PROCEDURE intbyte_assert_equal_r2 + ! INTEGER(Short) procedures + MODULE PROCEDURE intshort_assert_equal_s + MODULE PROCEDURE intshort_assert_equal_r1 + MODULE PROCEDURE intshort_assert_equal_r2 + ! INTEGER(Long) procedures + MODULE PROCEDURE intlong_assert_equal_s + MODULE PROCEDURE intlong_assert_equal_r1 + MODULE PROCEDURE intlong_assert_equal_r2 + ! REAL(Single) procedures + MODULE PROCEDURE realsp_assert_equal_s + MODULE PROCEDURE realsp_assert_equal_r1 + MODULE PROCEDURE realsp_assert_equal_r2 + ! REAL(Double) procedures + MODULE PROCEDURE realdp_assert_equal_s + MODULE PROCEDURE realdp_assert_equal_r1 + MODULE PROCEDURE realdp_assert_equal_r2 + ! COMPLEX(Single) procedures + MODULE PROCEDURE complexsp_assert_equal_s + MODULE PROCEDURE complexsp_assert_equal_r1 + MODULE PROCEDURE complexsp_assert_equal_r2 + ! COMPLEX(Double) procedures + MODULE PROCEDURE complexdp_assert_equal_s + MODULE PROCEDURE complexdp_assert_equal_r1 + MODULE PROCEDURE complexdp_assert_equal_r2 + ! CHARACTER(*) procedures + MODULE PROCEDURE char_assert_equal_s + MODULE PROCEDURE char_assert_equal_r1 + MODULE PROCEDURE char_assert_equal_r2 + END INTERFACE UnitTest_IsEqual + + INTERFACE UnitTest_IsEqualWithin + ! REAL(Single) procedures + MODULE PROCEDURE realsp_assert_equalwithin_s + MODULE PROCEDURE realsp_assert_equalwithin_r1 + MODULE PROCEDURE realsp_assert_equalwithin_r2 + ! REAL(Double) procedures + MODULE PROCEDURE realdp_assert_equalwithin_s + MODULE PROCEDURE realdp_assert_equalwithin_r1 + MODULE PROCEDURE realdp_assert_equalwithin_r2 + ! COMPLEX(Single) procedures + MODULE PROCEDURE complexsp_assert_equalwithin_s + MODULE PROCEDURE complexsp_assert_equalwithin_r1 + MODULE PROCEDURE complexsp_assert_equalwithin_r2 + ! COMPLEX(Double) procedures + MODULE PROCEDURE complexdp_assert_equalwithin_s + MODULE PROCEDURE complexdp_assert_equalwithin_r1 + MODULE PROCEDURE complexdp_assert_equalwithin_r2 + END INTERFACE UnitTest_IsEqualWithin + + INTERFACE UnitTest_IsWithinSigFig + ! REAL(Single) procedures + MODULE PROCEDURE realsp_assert_withinsigfig_s + MODULE PROCEDURE realsp_assert_withinsigfig_r1 + MODULE PROCEDURE realsp_assert_withinsigfig_r2 + ! REAL(Double) procedures + MODULE PROCEDURE realdp_assert_withinsigfig_s + MODULE PROCEDURE realdp_assert_withinsigfig_r1 + MODULE PROCEDURE realdp_assert_withinsigfig_r2 + ! COMPLEX(Single) procedures + MODULE PROCEDURE complexsp_assert_withinsigfig_s + MODULE PROCEDURE complexsp_assert_withinsigfig_r1 + MODULE PROCEDURE complexsp_assert_withinsigfig_r2 + ! COMPLEX(Double) procedures + MODULE PROCEDURE complexdp_assert_withinsigfig_s + MODULE PROCEDURE complexdp_assert_withinsigfig_r1 + MODULE PROCEDURE complexdp_assert_withinsigfig_r2 + END INTERFACE UnitTest_IsWithinSigFig + + + ! ----------------- + ! Module parameters + ! ----------------- + CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & + '$Id: UnitTest_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' + INTEGER, PARAMETER :: SL = 512 + INTEGER, PARAMETER :: CR = 13 + INTEGER, PARAMETER :: LF = 10 + CHARACTER(2), PARAMETER :: CRLF = ACHAR(CR)//ACHAR(LF) + LOGICAL, PARAMETER :: DEFAULT_VERBOSE = .FALSE. + ! Message colours + CHARACTER(*), PARAMETER :: GREEN_COLOUR = ACHAR(27)//'[1;32m' + CHARACTER(*), PARAMETER :: RED_COLOUR = ACHAR(27)//'[1;31m' + CHARACTER(*), PARAMETER :: NO_COLOUR = ACHAR(27)//'[0m' + ! Message levels + INTEGER, PARAMETER :: N_MESSAGE_LEVELS = 6 + INTEGER, PARAMETER :: INIT_LEVEL = 1 + INTEGER, PARAMETER :: SETUP_LEVEL = 2 + INTEGER, PARAMETER :: TEST_LEVEL = 3 + INTEGER, PARAMETER :: REPORT_LEVEL = 4 + INTEGER, PARAMETER :: SUMMARY_LEVEL = 5 + INTEGER, PARAMETER :: INTERNAL_FAIL_LEVEL = 6 + CHARACTER(*), PARAMETER :: MESSAGE_LEVEL(N_MESSAGE_LEVELS) = & + [ 'INIT ', & + 'SETUP ', & + 'TEST ', & + 'REPORT ', & + 'SUMMARY ', & + 'INTERNAL FAILURE' ] + + + ! ------------------------ + ! Derived type definitions + ! ------------------------ + !:tdoc+: + TYPE :: UnitTest_type + PRIVATE + ! User accessible test settings + LOGICAL :: Verbose = DEFAULT_VERBOSE + CHARACTER(SL) :: Title = '' + CHARACTER(SL) :: Caller = '' + ! Internal test settings + ! ...Test result messaging + INTEGER :: Level = INIT_LEVEL + CHARACTER(SL) :: Procedure = '' + CHARACTER(SL) :: Message = '' + ! ...Test result (used for array argument procedures) + LOGICAL :: Test_Result = .TRUE. + ! ...Individual test counters + INTEGER :: n_Tests = 0 + INTEGER :: n_Passed_Tests = 0 + INTEGER :: n_Failed_Tests = 0 + ! ...All test counters + INTEGER :: n_AllTests = 0 + INTEGER :: n_Passed_AllTests = 0 + INTEGER :: n_Failed_AllTests = 0 + CONTAINS + PRIVATE + ! Public methods + PROCEDURE, PUBLIC, PASS(self) :: Init + PROCEDURE, PUBLIC, PASS(self) :: Setup + PROCEDURE, PUBLIC, PASS(self) :: Report + PROCEDURE, PUBLIC, PASS(self) :: Summary + PROCEDURE, PUBLIC, PASS(self) :: n_Passed + PROCEDURE, PUBLIC, PASS(self) :: n_Failed + PROCEDURE, PUBLIC, PASS(self) :: Passed + PROCEDURE, PUBLIC, PASS(self) :: Failed + PROCEDURE, PUBLIC, PASS(self) :: Assert + PROCEDURE, PUBLIC, PASS(self) :: Refute + GENERIC, PUBLIC :: Assert_Equal => & + intbyte_assert_equal_s, intbyte_assert_equal_r1, intbyte_assert_equal_r2, & + intshort_assert_equal_s, intshort_assert_equal_r1, intshort_assert_equal_r2, & + intlong_assert_equal_s, intlong_assert_equal_r1, intlong_assert_equal_r2, & + realsp_assert_equal_s, realsp_assert_equal_r1, realsp_assert_equal_r2, & + realdp_assert_equal_s, realdp_assert_equal_r1, realdp_assert_equal_r2, & + complexsp_assert_equal_s, complexsp_assert_equal_r1, complexsp_assert_equal_r2, & + complexdp_assert_equal_s, complexdp_assert_equal_r1, complexdp_assert_equal_r2, & + char_assert_equal_s, char_assert_equal_r1, char_assert_equal_r2 + PROCEDURE, PASS(self) :: intbyte_assert_equal_s + PROCEDURE, PASS(self) :: intbyte_assert_equal_r1 + PROCEDURE, PASS(self) :: intbyte_assert_equal_r2 + PROCEDURE, PASS(self) :: intshort_assert_equal_s + PROCEDURE, PASS(self) :: intshort_assert_equal_r1 + PROCEDURE, PASS(self) :: intshort_assert_equal_r2 + PROCEDURE, PASS(self) :: intlong_assert_equal_s + PROCEDURE, PASS(self) :: intlong_assert_equal_r1 + PROCEDURE, PASS(self) :: intlong_assert_equal_r2 + PROCEDURE, PASS(self) :: realsp_assert_equal_s + PROCEDURE, PASS(self) :: realsp_assert_equal_r1 + PROCEDURE, PASS(self) :: realsp_assert_equal_r2 + PROCEDURE, PASS(self) :: realdp_assert_equal_s + PROCEDURE, PASS(self) :: realdp_assert_equal_r1 + PROCEDURE, PASS(self) :: realdp_assert_equal_r2 + PROCEDURE, PASS(self) :: complexsp_assert_equal_s + PROCEDURE, PASS(self) :: complexsp_assert_equal_r1 + PROCEDURE, PASS(self) :: complexsp_assert_equal_r2 + PROCEDURE, PASS(self) :: complexdp_assert_equal_s + PROCEDURE, PASS(self) :: complexdp_assert_equal_r1 + PROCEDURE, PASS(self) :: complexdp_assert_equal_r2 + PROCEDURE, PASS(self) :: char_assert_equal_s + PROCEDURE, PASS(self) :: char_assert_equal_r1 + PROCEDURE, PASS(self) :: char_assert_equal_r2 + GENERIC, PUBLIC :: Refute_Equal => & + intbyte_refute_equal_s, intbyte_refute_equal_r1, intbyte_refute_equal_r2, & + intshort_refute_equal_s, intshort_refute_equal_r1, intshort_refute_equal_r2, & + intlong_refute_equal_s, intlong_refute_equal_r1, intlong_refute_equal_r2, & + realsp_refute_equal_s, realsp_refute_equal_r1, realsp_refute_equal_r2, & + realdp_refute_equal_s, realdp_refute_equal_r1, realdp_refute_equal_r2, & + complexsp_refute_equal_s, complexsp_refute_equal_r1, complexsp_refute_equal_r2, & + complexdp_refute_equal_s, complexdp_refute_equal_r1, complexdp_refute_equal_r2, & + char_refute_equal_s, char_refute_equal_r1, char_refute_equal_r2 + PROCEDURE, PASS(self) :: intbyte_refute_equal_s + PROCEDURE, PASS(self) :: intbyte_refute_equal_r1 + PROCEDURE, PASS(self) :: intbyte_refute_equal_r2 + PROCEDURE, PASS(self) :: intshort_refute_equal_s + PROCEDURE, PASS(self) :: intshort_refute_equal_r1 + PROCEDURE, PASS(self) :: intshort_refute_equal_r2 + PROCEDURE, PASS(self) :: intlong_refute_equal_s + PROCEDURE, PASS(self) :: intlong_refute_equal_r1 + PROCEDURE, PASS(self) :: intlong_refute_equal_r2 + PROCEDURE, PASS(self) :: realsp_refute_equal_s + PROCEDURE, PASS(self) :: realsp_refute_equal_r1 + PROCEDURE, PASS(self) :: realsp_refute_equal_r2 + PROCEDURE, PASS(self) :: realdp_refute_equal_s + PROCEDURE, PASS(self) :: realdp_refute_equal_r1 + PROCEDURE, PASS(self) :: realdp_refute_equal_r2 + PROCEDURE, PASS(self) :: complexsp_refute_equal_s + PROCEDURE, PASS(self) :: complexsp_refute_equal_r1 + PROCEDURE, PASS(self) :: complexsp_refute_equal_r2 + PROCEDURE, PASS(self) :: complexdp_refute_equal_s + PROCEDURE, PASS(self) :: complexdp_refute_equal_r1 + PROCEDURE, PASS(self) :: complexdp_refute_equal_r2 + PROCEDURE, PASS(self) :: char_refute_equal_s + PROCEDURE, PASS(self) :: char_refute_equal_r1 + PROCEDURE, PASS(self) :: char_refute_equal_r2 + GENERIC, PUBLIC :: Assert_EqualWithin => & + realsp_assert_equalwithin_s, realsp_assert_equalwithin_r1, realsp_assert_equalwithin_r2, & + realdp_assert_equalwithin_s, realdp_assert_equalwithin_r1, realdp_assert_equalwithin_r2, & + complexsp_assert_equalwithin_s, complexsp_assert_equalwithin_r1, complexsp_assert_equalwithin_r2, & + complexdp_assert_equalwithin_s, complexdp_assert_equalwithin_r1, complexdp_assert_equalwithin_r2 + PROCEDURE, PASS(self) :: realsp_assert_equalwithin_s + PROCEDURE, PASS(self) :: realsp_assert_equalwithin_r1 + PROCEDURE, PASS(self) :: realsp_assert_equalwithin_r2 + PROCEDURE, PASS(self) :: realdp_assert_equalwithin_s + PROCEDURE, PASS(self) :: realdp_assert_equalwithin_r1 + PROCEDURE, PASS(self) :: realdp_assert_equalwithin_r2 + PROCEDURE, PASS(self) :: complexsp_assert_equalwithin_s + PROCEDURE, PASS(self) :: complexsp_assert_equalwithin_r1 + PROCEDURE, PASS(self) :: complexsp_assert_equalwithin_r2 + PROCEDURE, PASS(self) :: complexdp_assert_equalwithin_s + PROCEDURE, PASS(self) :: complexdp_assert_equalwithin_r1 + PROCEDURE, PASS(self) :: complexdp_assert_equalwithin_r2 + GENERIC, PUBLIC :: Refute_EqualWithin => & + realsp_refute_equalwithin_s, realsp_refute_equalwithin_r1, realsp_refute_equalwithin_r2, & + realdp_refute_equalwithin_s, realdp_refute_equalwithin_r1, realdp_refute_equalwithin_r2, & + complexsp_refute_equalwithin_s, complexsp_refute_equalwithin_r1, complexsp_refute_equalwithin_r2, & + complexdp_refute_equalwithin_s, complexdp_refute_equalwithin_r1, complexdp_refute_equalwithin_r2 + PROCEDURE, PASS(self) :: realsp_refute_equalwithin_s + PROCEDURE, PASS(self) :: realsp_refute_equalwithin_r1 + PROCEDURE, PASS(self) :: realsp_refute_equalwithin_r2 + PROCEDURE, PASS(self) :: realdp_refute_equalwithin_s + PROCEDURE, PASS(self) :: realdp_refute_equalwithin_r1 + PROCEDURE, PASS(self) :: realdp_refute_equalwithin_r2 + PROCEDURE, PASS(self) :: complexsp_refute_equalwithin_s + PROCEDURE, PASS(self) :: complexsp_refute_equalwithin_r1 + PROCEDURE, PASS(self) :: complexsp_refute_equalwithin_r2 + PROCEDURE, PASS(self) :: complexdp_refute_equalwithin_s + PROCEDURE, PASS(self) :: complexdp_refute_equalwithin_r1 + PROCEDURE, PASS(self) :: complexdp_refute_equalwithin_r2 + GENERIC, PUBLIC :: Assert_WithinSigfig => & + realsp_assert_withinsigfig_s, realsp_assert_withinsigfig_r1, realsp_assert_withinsigfig_r2, & + realdp_assert_withinsigfig_s, realdp_assert_withinsigfig_r1, realdp_assert_withinsigfig_r2, & + complexsp_assert_withinsigfig_s, complexsp_assert_withinsigfig_r1, complexsp_assert_withinsigfig_r2, & + complexdp_assert_withinsigfig_s, complexdp_assert_withinsigfig_r1, complexdp_assert_withinsigfig_r2 + PROCEDURE, PASS(self) :: realsp_assert_withinsigfig_s + PROCEDURE, PASS(self) :: realsp_assert_withinsigfig_r1 + PROCEDURE, PASS(self) :: realsp_assert_withinsigfig_r2 + PROCEDURE, PASS(self) :: realdp_assert_withinsigfig_s + PROCEDURE, PASS(self) :: realdp_assert_withinsigfig_r1 + PROCEDURE, PASS(self) :: realdp_assert_withinsigfig_r2 + PROCEDURE, PASS(self) :: complexsp_assert_withinsigfig_s + PROCEDURE, PASS(self) :: complexsp_assert_withinsigfig_r1 + PROCEDURE, PASS(self) :: complexsp_assert_withinsigfig_r2 + PROCEDURE, PASS(self) :: complexdp_assert_withinsigfig_s + PROCEDURE, PASS(self) :: complexdp_assert_withinsigfig_r1 + PROCEDURE, PASS(self) :: complexdp_assert_withinsigfig_r2 + GENERIC, PUBLIC :: Refute_WithinSigfig => & + realsp_refute_withinsigfig_s, realsp_refute_withinsigfig_r1, realsp_refute_withinsigfig_r2, & + realdp_refute_withinsigfig_s, realdp_refute_withinsigfig_r1, realdp_refute_withinsigfig_r2, & + complexsp_refute_withinsigfig_s, complexsp_refute_withinsigfig_r1, complexsp_refute_withinsigfig_r2, & + complexdp_refute_withinsigfig_s, complexdp_refute_withinsigfig_r1, complexdp_refute_withinsigfig_r2 + PROCEDURE, PASS(self) :: realsp_refute_withinsigfig_s + PROCEDURE, PASS(self) :: realsp_refute_withinsigfig_r1 + PROCEDURE, PASS(self) :: realsp_refute_withinsigfig_r2 + PROCEDURE, PASS(self) :: realdp_refute_withinsigfig_s + PROCEDURE, PASS(self) :: realdp_refute_withinsigfig_r1 + PROCEDURE, PASS(self) :: realdp_refute_withinsigfig_r2 + PROCEDURE, PASS(self) :: complexsp_refute_withinsigfig_s + PROCEDURE, PASS(self) :: complexsp_refute_withinsigfig_r1 + PROCEDURE, PASS(self) :: complexsp_refute_withinsigfig_r2 + PROCEDURE, PASS(self) :: complexdp_refute_withinsigfig_s + PROCEDURE, PASS(self) :: complexdp_refute_withinsigfig_r1 + PROCEDURE, PASS(self) :: complexdp_refute_withinsigfig_r2 + ! Private methods + PROCEDURE, PASS(self) :: Set_Property + PROCEDURE, PASS(self) :: Get_Property + PROCEDURE, PASS(self) :: Test_Passed + PROCEDURE, PASS(self) :: Test_Failed + PROCEDURE, PASS(self) :: Test_Increment + PROCEDURE, PASS(self) :: Display_Message + PROCEDURE, PASS(self) :: Test_Info_String + END TYPE UnitTest_type + !:tdoc-: + + +CONTAINS + + +!################################################################################ +!################################################################################ +!## ## +!## ## PUBLIC MODULE ROUTINES ## ## +!## ## +!################################################################################ +!################################################################################ + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Init +! +! PURPOSE: +! UnitTest initialisation method. +! +! This method should be called ONCE, BEFORE ANY tests are performed. +! +! CALLING SEQUENCE: +! CALL utest%Init( Verbose=Verbose ) +! +! OBJECTS: +! utest: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +! OPTIONAL INPUTS: +! Verbose: Logical argument to control length of reporting output. +! If == .FALSE., Only failed tests are reported [DEFAULT]. +! == .TRUE., Both failed and passed tests are reported. +! If not specified, default is .TRUE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE Init( self, Verbose ) + ! Arguments + CLASS(UnitTest_type), INTENT(OUT) :: self + LOGICAL, OPTIONAL, INTENT(IN) :: Verbose + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Init' + + ! Perform initialisation + CALL Set_Property( & + self, & + Verbose = Verbose , & + Level = INIT_LEVEL , & + Procedure = PROCEDURE_NAME, & + n_Tests = 0, & + n_Passed_Tests = 0, & + n_Failed_Tests = 0, & + n_AllTests = 0, & + n_Passed_AllTests = 0, & + n_Failed_AllTests = 0 ) + + CALL Display_Message( self ) + + END SUBROUTINE Init + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Setup +! +! PURPOSE: +! Individual test setup method. +! +! This method should be called BEFORE each set of tests performed. +! +! CALLING SEQUENCE: +! CALL utest_obj&Setup( Title , & +! Caller = Caller , & +! Verbose = Verbose ) +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! Title: Character string containing the title of the test +! to be performed. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL INPUTS: +! Caller: Character string containing the name of the calling +! subprogram. If not specified, default is an empty string. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Verbose: Logical argument to control length of reporting output. +! If == .FALSE., Only failed tests are reported [DEFAULT]. +! == .TRUE., Both failed and passed tests are reported. +! If not specified, default is .TRUE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE Setup( self, Title, Caller, Verbose ) + ! Arguments + CLASS(UnitTest_type) , INTENT(IN OUT) :: self + CHARACTER(*) , INTENT(IN) :: Title + CHARACTER(*), OPTIONAL, INTENT(IN) :: Caller + LOGICAL, OPTIONAL, INTENT(IN) :: Verbose + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Setup' + ! Variables + CHARACTER(SL) :: the_caller + CHARACTER(SL) :: message + + ! Check optional arguments + the_caller = '' + IF ( PRESENT(Caller) ) the_caller = '; CALLER: '//TRIM(ADJUSTL(Caller)) + + ! Create setup message + message = TRIM(ADJUSTL(Title))//TRIM(the_caller) + + ! Perform initialistion + CALL Set_Property( & + self, & + Title = Title , & + Caller = Caller , & + Verbose = Verbose , & + Level = SETUP_LEVEL , & + Procedure = PROCEDURE_NAME, & + Message = message , & + n_Tests = 0 , & + n_Passed_Tests = 0 , & + n_Failed_Tests = 0 ) + + CALL Display_Message( self ) + + END SUBROUTINE Setup + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Report +! +! PURPOSE: +! Individual test report method. +! +! This method should be called AFTER each set of tests performed. +! +! CALLING SEQUENCE: +! CALL utest_obj%Report() +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE Report( self ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Report' + ! Variables + INTEGER :: n_tests + INTEGER :: n_passed_tests + INTEGER :: n_failed_tests + CHARACTER(SL) :: message + CHARACTER(SL) :: attention + CHARACTER(SL) :: colour + + ! Retrieve required properties + CALL Get_Property( & + self, & + n_Tests = n_tests , & + n_Passed_Tests = n_passed_tests, & + n_Failed_Tests = n_failed_tests ) + + ! Test fail attention-grabber + colour = GREEN_COLOUR + attention = '' + IF ( n_failed_tests /= 0 ) THEN + colour = RED_COLOUR + attention = ' <----<<< **WARNING**' + END IF + + ! Generate report message + WRITE( message, & + '(a,a,3x,"Passed ",i0," of ",i0," tests", & + &a,3x,"Failed ",i0," of ",i0," tests",a,a)') & + TRIM(colour), CRLF, & + n_passed_tests, n_tests, & + CRLF, & + n_failed_tests, n_tests, & + TRIM(attention), NO_COLOUR + + ! Load object with report message + CALL Set_Property( & + self, & + Level = REPORT_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + + ! Report! + CALL Display_Message( self ) + + END SUBROUTINE Report + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Summary +! +! PURPOSE: +! Test suite report summary method. +! +! This method should be called ONCE, AFTER ALL tests are performed. +! +! CALLING SEQUENCE: +! CALL utest_obj%Summary() +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE Summary( self ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Summary' + ! Variables + INTEGER :: n_alltests + INTEGER :: n_passed_alltests + INTEGER :: n_failed_alltests + CHARACTER(SL) :: message + CHARACTER(SL) :: attention + CHARACTER(SL) :: colour + + ! Retrieve required properties + CALL Get_Property( & + self, & + n_AllTests = n_alltests , & + n_Passed_AllTests = n_passed_alltests, & + n_Failed_AllTests = n_failed_alltests ) + + ! Test fail attention-grabber + colour = GREEN_COLOUR + attention = '' + IF ( n_failed_alltests /= 0 ) THEN + colour = RED_COLOUR + attention = ' <----<<< **WARNING**' + END IF + + ! Generate summary + WRITE( message, & + '(a,a,1x,"Passed ",i0," of ",i0," total tests",& + &a,1x,"Failed ",i0," of ",i0," total tests",a,a)') & + TRIM(colour), CRLF, & + n_passed_alltests, n_alltests, & + CRLF, & + n_failed_alltests, n_alltests, & + TRIM(attention), NO_COLOUR + + ! Load object with summary message + CALL Set_Property( & + self, & + Level = SUMMARY_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + + ! Summarise! + CALL Display_Message( self ) + + END SUBROUTINE Summary + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::n_Passed +! +! PURPOSE: +! Method to return the number of tests passed. +! +! CALLING SEQUENCE: +! n = utest_obj%n_Passed() +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! n: The number of exercised unit tests that have passed. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + PURE INTEGER FUNCTION n_Passed( self ) + CLASS(UnitTest_type), INTENT(IN) :: self + CALL Get_Property( self, n_Passed_Tests = n_Passed ) + END FUNCTION n_Passed + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::n_Failed +! +! PURPOSE: +! Method to return the number of tests failed. +! +! CALLING SEQUENCE: +! n = utest_obj%n_Failed() +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! n: The number of exercised unit tests that have failed. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + PURE INTEGER FUNCTION n_Failed( self ) + CLASS(UnitTest_type), INTENT(IN) :: self + CALL Get_Property( self, n_Failed_Tests = n_Failed ) + END FUNCTION n_Failed + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Passed +! +! PURPOSE: +! Method to inform if the last test performed passed. +! +! CALLING SEQUENCE: +! result = utest_obj%Passed() +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! result: Logical to indicate if the last test performed passed. +! If == .TRUE., the last test passed, +! == .FALSE., the last test failed. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + PURE LOGICAL FUNCTION Passed( self ) + CLASS(UnitTest_type), INTENT(IN) :: self + CALL Get_Property( self, Test_Result = Passed ) + END FUNCTION Passed + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Failed +! +! PURPOSE: +! Method to inform if the last test performed failed. +! +! Syntactic sugar procedure. +! +! CALLING SEQUENCE: +! result = utest_obj%Failed() +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! FUNCTION RESULT: +! result: Logical to indicate if the last test performed failed. +! If == .TRUE., the last test failed, +! == .FALSE., the last test passed. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + PURE LOGICAL FUNCTION Failed( self ) + CLASS(UnitTest_type), INTENT(IN) :: self + Failed = .NOT. self%Passed() + END FUNCTION Failed + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Assert +! +! PURPOSE: +! Method to assert its logical argument as true. +! +! CALLING SEQUENCE: +! CALL utest_obj%Assert( boolean ) +! +! OBJECTS: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! boolean: The logical expression to assert. The test passes if the +! expression is .TRUE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE Assert(self, boolean) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + LOGICAL, INTENT(IN) :: boolean + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert' + ! Variables + LOGICAL :: verbose + CHARACTER(SL) :: message + + ! Setup + message = '' + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. boolean) ! Always output test failure + + ! Assert the test + IF ( boolean ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + + ! Generate the assertion message + CALL Test_Info_String( self, message ) + + ! Load the object with message + CALL Set_Property( & + self, & + Level = TEST_LEVEL , & + Procedure = PROCEDURE_NAME, & + Message = message ) + + ! Output the assertion result + IF ( verbose ) CALL Display_Message( self ) + + END SUBROUTINE Assert + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Refute +! +! PURPOSE: +! Method to refute its logical argument as false +! +! CALLING SEQUENCE: +! CALL utest_obj%Assert( boolean ) +! +! OBJECTS: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! boolean: The logical expression to refute. The test passes if the +! expression is .FALSE. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE Refute(self, boolean) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + LOGICAL, INTENT(IN) :: boolean + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute' + ! Variables + LOGICAL :: verbose + CHARACTER(SL) :: message + + ! Setup + message = '' + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. boolean ! Always output test failure + + ! Refute the test + IF ( .NOT. boolean ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + + ! Generate the refutation message + CALL Test_Info_String( self, message ) + + ! Load the object with message + CALL Set_Property( & + self, & + Level = TEST_LEVEL , & + Procedure = PROCEDURE_NAME, & + Message = message ) + + ! Output the refuation result + IF ( verbose ) CALL Display_Message( self ) + + END SUBROUTINE Refute + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Assert_Equal +! +! PURPOSE: +! Method to assert that two arguments are equal. +! +! CALLING SEQUENCE: +! CALL utest_obj%Assert_Equal( Expected, Actual ) +! +! OBJECTS: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! Expected: The expected value of the variable being tested. +! UNITS: N/A +! TYPE: INTEGER(Byte) , or +! INTEGER(Short) , or +! INTEGER(Long) , or +! REAL(Single) , or +! REAL(Double) , or +! COMPLEX(Single), or +! COMPLEX(Double), or +! CHARACTER(*) +! DIMENSION: Scalar, or +! Rank-1, or +! Rank-2 +! ATTRIBUTES: INTENT(IN) +! +! Actual: The actual value of the variable being tested. +! UNITS: N/A +! TYPE: Same as Expected input +! DIMENSION: Same as Expected input +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE intbyte_assert_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Byte), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[INTEGER(Byte)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = (Expected == Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",i0,a,& + &7x,"And got: ",i0)') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE intbyte_assert_equal_s + + + SUBROUTINE intbyte_assert_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Byte), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[INTEGER(Byte)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE intbyte_assert_equal_r1 + + + SUBROUTINE intbyte_assert_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Byte), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[INTEGER(Byte)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE intbyte_assert_equal_r2 + + + SUBROUTINE intshort_assert_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Short), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[INTEGER(Short)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = (Expected == Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",i0,a,& + &7x,"And got: ",i0)') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE intshort_assert_equal_s + + + SUBROUTINE intshort_assert_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Short), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[INTEGER(Short)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE intshort_assert_equal_r1 + + + SUBROUTINE intshort_assert_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Short), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[INTEGER(Short)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE intshort_assert_equal_r2 + + + SUBROUTINE intlong_assert_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Long), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[INTEGER(Long)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = (Expected == Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",i0,a,& + &7x,"And got: ",i0)') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE intlong_assert_equal_s + + + SUBROUTINE intlong_assert_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Long), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[INTEGER(Long)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE intlong_assert_equal_r1 + + + SUBROUTINE intlong_assert_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Long), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[INTEGER(Long)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE intlong_assert_equal_r2 + + + SUBROUTINE realsp_assert_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[REAL(Single)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = (Expected .EqualTo. Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",es25.18,a,& + &7x,"And got: ",es25.18)') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realsp_assert_equal_s + + + SUBROUTINE realsp_assert_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[REAL(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE realsp_assert_equal_r1 + + + SUBROUTINE realsp_assert_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[REAL(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE realsp_assert_equal_r2 + + + SUBROUTINE realdp_assert_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[REAL(Double)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = (Expected .EqualTo. Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",es25.18,a,& + &7x,"And got: ",es25.18)') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realdp_assert_equal_s + + + SUBROUTINE realdp_assert_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[REAL(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE realdp_assert_equal_r1 + + + SUBROUTINE realdp_assert_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[REAL(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE realdp_assert_equal_r2 + + + SUBROUTINE complexsp_assert_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[COMPLEX(Single)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = (Expected .EqualTo. Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ","(",es25.18,",",es25.18,")",a,& + &7x,"And got: ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexsp_assert_equal_s + + + SUBROUTINE complexsp_assert_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[COMPLEX(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE complexsp_assert_equal_r1 + + + SUBROUTINE complexsp_assert_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[COMPLEX(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE complexsp_assert_equal_r2 + + + SUBROUTINE complexdp_assert_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[COMPLEX(Double)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = (Expected .EqualTo. Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ","(",es25.18,",",es25.18,")",a,& + &7x,"And got: ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexdp_assert_equal_s + + + SUBROUTINE complexdp_assert_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[COMPLEX(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE complexdp_assert_equal_r1 + + + SUBROUTINE complexdp_assert_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[COMPLEX(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE complexdp_assert_equal_r2 + + + SUBROUTINE char_assert_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + CHARACTER(*), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[CHARACTER(*)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = (Expected == Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",">",a,"<",a,& + &7x,"And got: ",">",a,"<")') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE char_assert_equal_s + + + SUBROUTINE char_assert_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + CHARACTER(*), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[CHARACTER(*)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE char_assert_equal_r1 + + + SUBROUTINE char_assert_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + CHARACTER(*), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_Equal[CHARACTER(*)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE char_assert_equal_r2 + + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Refute_Equal +! +! PURPOSE: +! Method to refute that two arguments are equal. +! +! CALLING SEQUENCE: +! CALL utest_obj%Refute_Equal( Expected, Actual ) +! +! OBJECTS: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! Expected: The expected value of the variable being tested. +! UNITS: N/A +! TYPE: INTEGER(Byte) , or +! INTEGER(Short) , or +! INTEGER(Long) , or +! REAL(Single) , or +! REAL(Double) , or +! COMPLEX(Single), or +! COMPLEX(Double), or +! CHARACTER(*) +! DIMENSION: Scalar, or +! Rank-1, or +! Rank-2 +! ATTRIBUTES: INTENT(IN) +! +! Actual: The actual value of the variable being tested. +! UNITS: N/A +! TYPE: Same as Expected input +! DIMENSION: Same as Expected input +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE intbyte_refute_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Byte), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[INTEGER(Byte)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = .NOT.(Expected == Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",i0,a,& + &7x,"And got: ",i0)') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE intbyte_refute_equal_s + + + SUBROUTINE intbyte_refute_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Byte), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[INTEGER(Byte)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE intbyte_refute_equal_r1 + + + SUBROUTINE intbyte_refute_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Byte), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[INTEGER(Byte)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE intbyte_refute_equal_r2 + + + SUBROUTINE intshort_refute_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Short), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[INTEGER(Short)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = .NOT.(Expected == Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",i0,a,& + &7x,"And got: ",i0)') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE intshort_refute_equal_s + + + SUBROUTINE intshort_refute_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Short), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[INTEGER(Short)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE intshort_refute_equal_r1 + + + SUBROUTINE intshort_refute_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Short), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[INTEGER(Short)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE intshort_refute_equal_r2 + + + SUBROUTINE intlong_refute_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Long), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[INTEGER(Long)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = .NOT.(Expected == Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",i0,a,& + &7x,"And got: ",i0)') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE intlong_refute_equal_s + + + SUBROUTINE intlong_refute_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Long), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[INTEGER(Long)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE intlong_refute_equal_r1 + + + SUBROUTINE intlong_refute_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER(Long), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[INTEGER(Long)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE intlong_refute_equal_r2 + + + SUBROUTINE realsp_refute_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[REAL(Single)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = .NOT.(Expected .EqualTo. Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",es25.18,a,& + &7x,"And got: ",es25.18)') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realsp_refute_equal_s + + + SUBROUTINE realsp_refute_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[REAL(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE realsp_refute_equal_r1 + + + SUBROUTINE realsp_refute_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[REAL(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE realsp_refute_equal_r2 + + + SUBROUTINE realdp_refute_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[REAL(Double)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = .NOT.(Expected .EqualTo. Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",es25.18,a,& + &7x,"And got: ",es25.18)') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realdp_refute_equal_s + + + SUBROUTINE realdp_refute_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[REAL(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE realdp_refute_equal_r1 + + + SUBROUTINE realdp_refute_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[REAL(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE realdp_refute_equal_r2 + + + SUBROUTINE complexsp_refute_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[COMPLEX(Single)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = .NOT.(Expected .EqualTo. Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ","(",es25.18,",",es25.18,")",a,& + &7x,"And got: ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexsp_refute_equal_s + + + SUBROUTINE complexsp_refute_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[COMPLEX(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE complexsp_refute_equal_r1 + + + SUBROUTINE complexsp_refute_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[COMPLEX(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE complexsp_refute_equal_r2 + + + SUBROUTINE complexdp_refute_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[COMPLEX(Double)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = .NOT.(Expected .EqualTo. Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ","(",es25.18,",",es25.18,")",a,& + &7x,"And got: ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexdp_refute_equal_s + + + SUBROUTINE complexdp_refute_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[COMPLEX(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE complexdp_refute_equal_r1 + + + SUBROUTINE complexdp_refute_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[COMPLEX(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE complexdp_refute_equal_r2 + + + SUBROUTINE char_refute_equal_s( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + CHARACTER(*), INTENT(IN) :: Expected, Actual + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[CHARACTER(*)]' + ! Variables + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Assign the test + test = .NOT.(Expected == Actual) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( message, '(a,7x,"Expected: ",">",a,"<",a,& + &7x,"And got: ",">",a,"<")') & + CRLF, Expected, CRLF, Actual + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE char_refute_equal_s + + + SUBROUTINE char_refute_equal_r1( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + CHARACTER(*), INTENT(IN) :: Expected(:), Actual(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[CHARACTER(*)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_Equal( Expected(i), Actual(i) ) + END DO + END SUBROUTINE char_refute_equal_r1 + + + SUBROUTINE char_refute_equal_r2( self, Expected, Actual ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + CHARACTER(*), INTENT(IN) :: Expected(:,:), Actual(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_Equal[CHARACTER(*)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_Equal( Expected(i,j), Actual(i,j) ) + END DO + END DO + END SUBROUTINE char_refute_equal_r2 + + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Assert_EqualWithin +! +! PURPOSE: +! Method to assert that two floating point arguments are equal to +! within the specified tolerance. +! +! CALLING SEQUENCE: +! CALL utest_obj%Assert_EqualWithin( Expected, Actual, Tolerance ) +! +! OBJECTS: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! Expected: The expected value of the variable being tested. +! UNITS: N/A +! TYPE: REAL(Single) , or +! REAL(Double) , or +! COMPLEX(Single), or +! COMPLEX(Double) +! DIMENSION: Scalar, or +! Rank-1, or +! Rank-2 +! ATTRIBUTES: INTENT(IN) +! +! Actual: The actual value of the variable being tested. +! UNITS: N/A +! TYPE: Same as Expected input +! DIMENSION: Same as Expected input +! ATTRIBUTES: INTENT(IN) +! +! Tolerance: The tolerance to within which the Expected and Actual +! values must agree. If negative, the value of +! EPSILON(Expected) +! is used. +! UNITS: N/A +! TYPE: Same as Expected input +! DIMENSION: Same as Expected input +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE realsp_assert_equalwithin_s( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected, Actual, Tolerance + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[REAL(Single)]' + ! Variables + REAL(Single) :: delta + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Local delta for test + delta = Tolerance + IF ( delta < 0.0_Single ) delta = EPSILON(Expected) + ! ...Assign the test + test = (ABS(Expected-Actual) < delta) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ",es25.18,a,& + &7x,"To within : ",es25.18,a,& + &7x,"And got : ",es25.18,a,& + &7x,"|Difference| : ",es25.18)') & + CRLF, Expected, CRLF, delta, CRLF, Actual, CRLF, ABS(Expected-Actual) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realsp_assert_equalwithin_s + + + SUBROUTINE realsp_assert_equalwithin_r1( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[REAL(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_EqualWithin( Expected(i), Actual(i), Tolerance(i) ) + END DO + END SUBROUTINE realsp_assert_equalwithin_r1 + + + SUBROUTINE realsp_assert_equalwithin_r2( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[REAL(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_EqualWithin( Expected(i,j), Actual(i,j), Tolerance(i,j) ) + END DO + END DO + END SUBROUTINE realsp_assert_equalwithin_r2 + + + SUBROUTINE realdp_assert_equalwithin_s( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected, Actual, Tolerance + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[REAL(Double)]' + ! Variables + REAL(Double) :: delta + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Local delta for test + delta = Tolerance + IF ( delta < 0.0_Double ) delta = EPSILON(Expected) + ! ...Assign the test + test = (ABS(Expected-Actual) < delta) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ",es25.18,a,& + &7x,"To within : ",es25.18,a,& + &7x,"And got : ",es25.18,a,& + &7x,"|Difference| : ",es25.18)') & + CRLF, Expected, CRLF, delta, CRLF, Actual, CRLF, ABS(Expected-Actual) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realdp_assert_equalwithin_s + + + SUBROUTINE realdp_assert_equalwithin_r1( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[REAL(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_EqualWithin( Expected(i), Actual(i), Tolerance(i) ) + END DO + END SUBROUTINE realdp_assert_equalwithin_r1 + + + SUBROUTINE realdp_assert_equalwithin_r2( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[REAL(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_EqualWithin( Expected(i,j), Actual(i,j), Tolerance(i,j) ) + END DO + END DO + END SUBROUTINE realdp_assert_equalwithin_r2 + + + SUBROUTINE complexsp_assert_equalwithin_s( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected, Actual, Tolerance + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[COMPLEX(Single)]' + ! Variables + REAL(Single) :: deltar, deltai + REAL(Single) :: zr, zi + REAL(Single) :: dzr, dzi + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Split expected into real and imag + zr = REAL(Expected,Single) + zi = AIMAG(Expected) + ! ...Local delta for test + deltar = REAL(Tolerance,Single) + IF ( deltar < 0.0_Single ) deltar = EPSILON(zr) + deltai = AIMAG(Tolerance) + IF ( deltai < 0.0_Single ) deltai = EPSILON(zi) + ! ...Assign the test + dzr = ABS(zr - REAL(Actual,Single)) + dzi = ABS(zi - AIMAG(Actual)) + test = ((dzr < deltar) .AND. (dzi < deltai)) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ","(",es25.18,",",es25.18,")",a,& + &7x,"To within : ","(",es25.18,",",es25.18,")",a,& + &7x,"And got : ","(",es25.18,",",es25.18,")",a,& + &7x,"|Difference| : ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, CMPLX(deltar,deltai,Single), CRLF, Actual, CRLF, dzr, dzi + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexsp_assert_equalwithin_s + + + SUBROUTINE complexsp_assert_equalwithin_r1( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[COMPLEX(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_EqualWithin( Expected(i), Actual(i), Tolerance(i) ) + END DO + END SUBROUTINE complexsp_assert_equalwithin_r1 + + + SUBROUTINE complexsp_assert_equalwithin_r2( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[COMPLEX(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_EqualWithin( Expected(i,j), Actual(i,j), Tolerance(i,j) ) + END DO + END DO + END SUBROUTINE complexsp_assert_equalwithin_r2 + + + SUBROUTINE complexdp_assert_equalwithin_s( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected, Actual, Tolerance + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[COMPLEX(Double)]' + ! Variables + REAL(Double) :: deltar, deltai + REAL(Double) :: zr, zi + REAL(Double) :: dzr, dzi + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Split expected into real and imag + zr = REAL(Expected,Double) + zi = AIMAG(Expected) + ! ...Local delta for test + deltar = REAL(Tolerance,Double) + IF ( deltar < 0.0_Double ) deltar = EPSILON(zr) + deltai = AIMAG(Tolerance) + IF ( deltai < 0.0_Double ) deltai = EPSILON(zi) + ! ...Assign the test + dzr = ABS(zr - REAL(Actual,Double)) + dzi = ABS(zi - AIMAG(Actual)) + test = ((dzr < deltar) .AND. (dzi < deltai)) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ","(",es25.18,",",es25.18,")",a,& + &7x,"To within : ","(",es25.18,",",es25.18,")",a,& + &7x,"And got : ","(",es25.18,",",es25.18,")",a,& + &7x,"|Difference| : ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, CMPLX(deltar,deltai,Double), CRLF, Actual, CRLF, dzr, dzi + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexdp_assert_equalwithin_s + + + SUBROUTINE complexdp_assert_equalwithin_r1( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[COMPLEX(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_EqualWithin( Expected(i), Actual(i), Tolerance(i) ) + END DO + END SUBROUTINE complexdp_assert_equalwithin_r1 + + + SUBROUTINE complexdp_assert_equalwithin_r2( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_EqualWithin[COMPLEX(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_EqualWithin( Expected(i,j), Actual(i,j), Tolerance(i,j) ) + END DO + END DO + END SUBROUTINE complexdp_assert_equalwithin_r2 + + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Refute_EqualWithin +! +! PURPOSE: +! Method to refute that two floating point arguments are equal to +! within the specified tolerance. +! +! CALLING SEQUENCE: +! CALL utest_obj%Refute_EqualWithin( Expected, Actual, Tolerance ) +! +! OBJECTS: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! Expected: The expected value of the variable being tested. +! UNITS: N/A +! TYPE: REAL(Single) , or +! REAL(Double) , or +! COMPLEX(Single), or +! COMPLEX(Double) +! DIMENSION: Scalar, or +! Rank-1, or +! Rank-2 +! ATTRIBUTES: INTENT(IN) +! +! Actual: The actual value of the variable being tested. +! UNITS: N/A +! TYPE: Same as Expected input +! DIMENSION: Same as Expected input +! ATTRIBUTES: INTENT(IN) +! +! Tolerance: The tolerance to within which the Expected and Actual +! values must agree. If negative, the value of +! EPSILON(Expected) +! is used. +! UNITS: N/A +! TYPE: Same as Expected input +! DIMENSION: Same as Expected input +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE realsp_refute_equalwithin_s( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected, Actual, Tolerance + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[REAL(Single)]' + ! Variables + REAL(Single) :: delta + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Local delta for test + delta = Tolerance + IF ( delta < 0.0_Single ) delta = EPSILON(Expected) + ! ...Assign the test + test = .NOT.(ABS(Expected-Actual) < delta) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ",es25.18,a,& + &7x,"Outside of : ",es25.18,a,& + &7x,"And got : ",es25.18,a,& + &7x,"|Difference| : ",es25.18)') & + CRLF, Expected, CRLF, delta, CRLF, Actual, CRLF, ABS(Expected-Actual) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realsp_refute_equalwithin_s + + + SUBROUTINE realsp_refute_equalwithin_r1( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[REAL(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_EqualWithin( Expected(i), Actual(i), Tolerance(i) ) + END DO + END SUBROUTINE realsp_refute_equalwithin_r1 + + + SUBROUTINE realsp_refute_equalwithin_r2( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[REAL(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_EqualWithin( Expected(i,j), Actual(i,j), Tolerance(i,j) ) + END DO + END DO + END SUBROUTINE realsp_refute_equalwithin_r2 + + + SUBROUTINE realdp_refute_equalwithin_s( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected, Actual, Tolerance + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[REAL(Double)]' + ! Variables + REAL(Double) :: delta + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Local delta for test + delta = Tolerance + IF ( delta < 0.0_Double ) delta = EPSILON(Expected) + ! ...Assign the test + test = .NOT.(ABS(Expected-Actual) < delta) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ",es25.18,a,& + &7x,"Outside of : ",es25.18,a,& + &7x,"And got : ",es25.18,a,& + &7x,"|Difference| : ",es25.18)') & + CRLF, Expected, CRLF, delta, CRLF, Actual, CRLF, ABS(Expected-Actual) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realdp_refute_equalwithin_s + + + SUBROUTINE realdp_refute_equalwithin_r1( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[REAL(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_EqualWithin( Expected(i), Actual(i), Tolerance(i) ) + END DO + END SUBROUTINE realdp_refute_equalwithin_r1 + + + SUBROUTINE realdp_refute_equalwithin_r2( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[REAL(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_EqualWithin( Expected(i,j), Actual(i,j), Tolerance(i,j) ) + END DO + END DO + END SUBROUTINE realdp_refute_equalwithin_r2 + + + SUBROUTINE complexsp_refute_equalwithin_s( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected, Actual, Tolerance + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[COMPLEX(Single)]' + ! Variables + REAL(Single) :: deltar, deltai + REAL(Single) :: zr, zi + REAL(Single) :: dzr, dzi + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Split expected into real and imag + zr = REAL(Expected,Single) + zi = AIMAG(Expected) + ! ...Local delta for test + deltar = REAL(Tolerance,Single) + IF ( deltar < 0.0_Single ) deltar = EPSILON(zr) + deltai = AIMAG(Tolerance) + IF ( deltai < 0.0_Single ) deltai = EPSILON(zi) + ! ...Assign the test + dzr = ABS(zr - REAL(Actual,Single)) + dzi = ABS(zi - AIMAG(Actual)) + test = .NOT.((dzr < deltar) .AND. (dzi < deltai)) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ","(",es25.18,",",es25.18,")",a,& + &7x,"Outside of : ","(",es25.18,",",es25.18,")",a,& + &7x,"And got : ","(",es25.18,",",es25.18,")",a,& + &7x,"|Difference| : ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, CMPLX(deltar,deltai,Single), CRLF, Actual, CRLF, dzr, dzi + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexsp_refute_equalwithin_s + + + SUBROUTINE complexsp_refute_equalwithin_r1( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[COMPLEX(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_EqualWithin( Expected(i), Actual(i), Tolerance(i) ) + END DO + END SUBROUTINE complexsp_refute_equalwithin_r1 + + + SUBROUTINE complexsp_refute_equalwithin_r2( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[COMPLEX(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_EqualWithin( Expected(i,j), Actual(i,j), Tolerance(i,j) ) + END DO + END DO + END SUBROUTINE complexsp_refute_equalwithin_r2 + + + SUBROUTINE complexdp_refute_equalwithin_s( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected, Actual, Tolerance + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[COMPLEX(Double)]' + ! Variables + REAL(Double) :: deltar, deltai + REAL(Double) :: zr, zi + REAL(Double) :: dzr, dzi + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Split expected into real and imag + zr = REAL(Expected,Double) + zi = AIMAG(Expected) + ! ...Local delta for test + deltar = REAL(Tolerance,Double) + IF ( deltar < 0.0_Double ) deltar = EPSILON(zr) + deltai = AIMAG(Tolerance) + IF ( deltai < 0.0_Double ) deltai = EPSILON(zi) + ! ...Assign the test + dzr = ABS(zr - REAL(Actual,Double)) + dzi = ABS(zi - AIMAG(Actual)) + test = .NOT.((dzr < deltar) .AND. (dzi < deltai)) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ","(",es25.18,",",es25.18,")",a,& + &7x,"Outside of : ","(",es25.18,",",es25.18,")",a,& + &7x,"And got : ","(",es25.18,",",es25.18,")",a,& + &7x,"|Difference| : ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, CMPLX(deltar,deltai,Double), CRLF, Actual, CRLF, dzr, dzi + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexdp_refute_equalwithin_s + + + SUBROUTINE complexdp_refute_equalwithin_r1( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:), Actual(:), Tolerance(:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[COMPLEX(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_EqualWithin( Expected(i), Actual(i), Tolerance(i) ) + END DO + END SUBROUTINE complexdp_refute_equalwithin_r1 + + + SUBROUTINE complexdp_refute_equalwithin_r2( self, Expected, Actual, Tolerance ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:,:), Actual(:,:), Tolerance(:,:) + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_EqualWithin[COMPLEX(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_EqualWithin( Expected(i,j), Actual(i,j), Tolerance(i,j) ) + END DO + END DO + END SUBROUTINE complexdp_refute_equalwithin_r2 + + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Assert_WithinSigFig +! +! PURPOSE: +! Method to assert that two floating point arguments are equal to +! within the specified number of significant figures. +! +! CALLING SEQUENCE: +! CALL utest_obj%Assert_WithinSigFig( Expected, Actual, n_SigFig ) +! +! OBJECTS: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! Expected: The expected value of the variable being tested. +! UNITS: N/A +! TYPE: REAL(Single) , or +! REAL(Double) , or +! COMPLEX(Single), or +! COMPLEX(Double) +! DIMENSION: Scalar, or +! Rank-1, or +! Rank-2 +! ATTRIBUTES: INTENT(IN) +! +! Actual: The actual value of the variable being tested. +! UNITS: N/A +! TYPE: Same as Expected input +! DIMENSION: Same as Expected input +! ATTRIBUTES: INTENT(IN) +! +! n_SigFig: The number of sgnificant figures within which the +! expected and actual numbers are to be compared. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE realsp_assert_withinsigfig_s( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected, Actual + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[REAL(Single)]' + ! Variables + REAL(Single) :: epsilon_delta + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Compute the test cutoff + epsilon_delta = EPSILON(Expected) * REAL(RADIX(Expected),Single)**(EXPONENT(Expected)-1) + ! ...Assign the test + test = Compares_Within_Tolerance(Expected, Actual, n_SigFig, cutoff=epsilon_delta) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ",es25.18,a,& + &7x,"To within : ",i0," significant figures",a,& + &7x,"And got : ",es25.18,a,& + &7x,"|Difference| : ",es25.18)') & + CRLF, Expected, CRLF, n_SigFig, CRLF, Actual, CRLF, ABS(Expected-Actual) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realsp_assert_withinsigfig_s + + + SUBROUTINE realsp_assert_withinsigfig_r1( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:), Actual(:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[REAL(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_WithinSigfig( Expected(i), Actual(i), n_SigFig ) + END DO + END SUBROUTINE realsp_assert_withinsigfig_r1 + + + SUBROUTINE realsp_assert_withinsigfig_r2( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:,:), Actual(:,:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[REAL(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_WithinSigfig( Expected(i,j), Actual(i,j), n_SigFig ) + END DO + END DO + END SUBROUTINE realsp_assert_withinsigfig_r2 + + + SUBROUTINE realdp_assert_withinsigfig_s( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected, Actual + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[REAL(Double)]' + ! Variables + REAL(Double) :: epsilon_delta + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Compute the test cutoff + epsilon_delta = EPSILON(Expected) * REAL(RADIX(Expected),Double)**(EXPONENT(Expected)-1) + ! ...Assign the test + test = Compares_Within_Tolerance(Expected, Actual, n_SigFig, cutoff=epsilon_delta) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ",es25.18,a,& + &7x,"To within : ",i0," significant figures",a,& + &7x,"And got : ",es25.18,a,& + &7x,"|Difference| : ",es25.18)') & + CRLF, Expected, CRLF, n_SigFig, CRLF, Actual, CRLF, ABS(Expected-Actual) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realdp_assert_withinsigfig_s + + + SUBROUTINE realdp_assert_withinsigfig_r1( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:), Actual(:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[REAL(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_WithinSigfig( Expected(i), Actual(i), n_SigFig ) + END DO + END SUBROUTINE realdp_assert_withinsigfig_r1 + + + SUBROUTINE realdp_assert_withinsigfig_r2( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:,:), Actual(:,:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[REAL(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_WithinSigfig( Expected(i,j), Actual(i,j), n_SigFig ) + END DO + END DO + END SUBROUTINE realdp_assert_withinsigfig_r2 + + + SUBROUTINE complexsp_assert_withinsigfig_s( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected, Actual + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[COMPLEX(Single)]' + ! Variables + REAL(Single) :: ezr, ezi + REAL(Single) :: azr, azi + REAL(Single) :: epsilon_delta_r, epsilon_delta_i + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Split expected into real and imag + ezr = REAL(Expected,Single) + ezi = AIMAG(Expected) + azr = REAL(Actual,Single) + azi = AIMAG(Actual) + ! ...Compute the test cutoffs + epsilon_delta_r = EPSILON(ezr) * REAL(RADIX(ezr),Single)**(EXPONENT(ezr)-1) + epsilon_delta_i = EPSILON(ezi) * REAL(RADIX(ezi),Single)**(EXPONENT(ezi)-1) + ! ...Assign the test + test = Compares_Within_Tolerance(ezr, azr, n_SigFig, cutoff=epsilon_delta_r) .AND. & + Compares_Within_Tolerance(ezi, azi, n_SigFig, cutoff=epsilon_delta_i) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ","(",es25.18,",",es25.18,")",a,& + &7x,"To within : ",i0," significant figures",a,& + &7x,"And got : ","(",es25.18,",",es25.18,")",a,& + &7x,"|Difference| : ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, n_SigFig, CRLF, Actual, CRLF, CMPLX(ezr-azr,ezi-azi,Single) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexsp_assert_withinsigfig_s + + + SUBROUTINE complexsp_assert_withinsigfig_r1( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:), Actual(:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[COMPLEX(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_WithinSigfig( Expected(i), Actual(i), n_SigFig ) + END DO + END SUBROUTINE complexsp_assert_withinsigfig_r1 + + + SUBROUTINE complexsp_assert_withinsigfig_r2( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:,:), Actual(:,:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[COMPLEX(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_WithinSigfig( Expected(i,j), Actual(i,j), n_SigFig ) + END DO + END DO + END SUBROUTINE complexsp_assert_withinsigfig_r2 + + + SUBROUTINE complexdp_assert_withinsigfig_s( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected, Actual + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[COMPLEX(Double)]' + ! Variables + REAL(Double) :: ezr, ezi + REAL(Double) :: azr, azi + REAL(Double) :: epsilon_delta_r, epsilon_delta_i + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Split expected into real and imag + ezr = REAL(Expected,Double) + ezi = AIMAG(Expected) + azr = REAL(Actual,Double) + azi = AIMAG(Actual) + ! ...Compute the test cutoffs + epsilon_delta_r = EPSILON(ezr) * REAL(RADIX(ezr),Double)**(EXPONENT(ezr)-1) + epsilon_delta_i = EPSILON(ezi) * REAL(RADIX(ezi),Double)**(EXPONENT(ezi)-1) + ! ...Assign the test + test = Compares_Within_Tolerance(ezr, azr, n_SigFig, cutoff=epsilon_delta_r) .AND. & + Compares_Within_Tolerance(ezi, azi, n_SigFig, cutoff=epsilon_delta_i) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ","(",es25.18,",",es25.18,")",a,& + &7x,"To within : ",i0," significant figures",a,& + &7x,"And got : ","(",es25.18,",",es25.18,")",a,& + &7x,"|Difference| : ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, n_SigFig, CRLF, Actual, CRLF, CMPLX(ezr-azr,ezi-azi,Single) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexdp_assert_withinsigfig_s + + + SUBROUTINE complexdp_assert_withinsigfig_r1( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:), Actual(:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[COMPLEX(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Assert_WithinSigfig( Expected(i), Actual(i), n_SigFig ) + END DO + END SUBROUTINE complexdp_assert_withinsigfig_r1 + + + SUBROUTINE complexdp_assert_withinsigfig_r2( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:,:), Actual(:,:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Assert_WithinSigfig[COMPLEX(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Assert_WithinSigfig( Expected(i,j), Actual(i,j), n_SigFig ) + END DO + END DO + END SUBROUTINE complexdp_assert_withinsigfig_r2 + + + +!-------------------------------------------------------------------------------- +!:sdoc+: +! +! NAME: +! UnitTest::Refute_WithinSigFig +! +! PURPOSE: +! Method to refute that two floating point arguments are equal to +! within the specified number of significant figures. +! +! CALLING SEQUENCE: +! CALL utest_obj%Refute_WithinSigFig( Expected, Actual, n_SigFig ) +! +! OBJECTS: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! INPUTS: +! Expected: The expected value of the variable being tested. +! UNITS: N/A +! TYPE: REAL(Single) , or +! REAL(Double) , or +! COMPLEX(Single), or +! COMPLEX(Double) +! DIMENSION: Scalar, or +! Rank-1, or +! Rank-2 +! ATTRIBUTES: INTENT(IN) +! +! Actual: The actual value of the variable being tested. +! UNITS: N/A +! TYPE: Same as Expected input +! DIMENSION: Same as Expected input +! ATTRIBUTES: INTENT(IN) +! +! n_SigFig: The number of sgnificant figures within which the +! expected and actual numbers are to be compared. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +!:sdoc-: +!-------------------------------------------------------------------------------- + + SUBROUTINE realsp_refute_withinsigfig_s( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected, Actual + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[REAL(Single)]' + ! Variables + REAL(Single) :: epsilon_delta + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Compute the test cutoff + epsilon_delta = EPSILON(Expected) * REAL(RADIX(Expected),Single)**(EXPONENT(Expected)-1) + ! ...Assign the test + test = .NOT.(Compares_Within_Tolerance(Expected, Actual, n_SigFig, cutoff=epsilon_delta)) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ",es25.18,a,& + &7x,"Outside of : ",i0," significant figures",a,& + &7x,"And got : ",es25.18,a,& + &7x,"|Difference| : ",es25.18)') & + CRLF, Expected, CRLF, n_SigFig, CRLF, Actual, CRLF, ABS(Expected-Actual) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realsp_refute_withinsigfig_s + + + SUBROUTINE realsp_refute_withinsigfig_r1( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:), Actual(:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[REAL(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_WithinSigfig( Expected(i), Actual(i), n_SigFig ) + END DO + END SUBROUTINE realsp_refute_withinsigfig_r1 + + + SUBROUTINE realsp_refute_withinsigfig_r2( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Single), INTENT(IN) :: Expected(:,:), Actual(:,:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[REAL(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_WithinSigfig( Expected(i,j), Actual(i,j), n_SigFig ) + END DO + END DO + END SUBROUTINE realsp_refute_withinsigfig_r2 + + + SUBROUTINE realdp_refute_withinsigfig_s( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected, Actual + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[REAL(Double)]' + ! Variables + REAL(Double) :: epsilon_delta + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Compute the test cutoff + epsilon_delta = EPSILON(Expected) * REAL(RADIX(Expected),Double)**(EXPONENT(Expected)-1) + ! ...Assign the test + test = .NOT.(Compares_Within_Tolerance(Expected, Actual, n_SigFig, cutoff=epsilon_delta)) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ",es25.18,a,& + &7x,"Outside of : ",i0," significant figures",a,& + &7x,"And got : ",es25.18,a,& + &7x,"|Difference| : ",es25.18)') & + CRLF, Expected, CRLF, n_SigFig, CRLF, Actual, CRLF, ABS(Expected-Actual) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE realdp_refute_withinsigfig_s + + + SUBROUTINE realdp_refute_withinsigfig_r1( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:), Actual(:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[REAL(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_WithinSigfig( Expected(i), Actual(i), n_SigFig ) + END DO + END SUBROUTINE realdp_refute_withinsigfig_r1 + + + SUBROUTINE realdp_refute_withinsigfig_r2( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + REAL(Double), INTENT(IN) :: Expected(:,:), Actual(:,:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[REAL(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_WithinSigfig( Expected(i,j), Actual(i,j), n_SigFig ) + END DO + END DO + END SUBROUTINE realdp_refute_withinsigfig_r2 + + + SUBROUTINE complexsp_refute_withinsigfig_s( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected, Actual + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[COMPLEX(Single)]' + ! Variables + REAL(Single) :: ezr, ezi + REAL(Single) :: azr, azi + REAL(Single) :: epsilon_delta_r, epsilon_delta_i + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Split expected into real and imag + ezr = REAL(Expected,Single) + ezi = AIMAG(Expected) + azr = REAL(Actual,Single) + azi = AIMAG(Actual) + ! ...Compute the test cutoffs + epsilon_delta_r = EPSILON(ezr) * REAL(RADIX(ezr),Single)**(EXPONENT(ezr)-1) + epsilon_delta_i = EPSILON(ezi) * REAL(RADIX(ezi),Single)**(EXPONENT(ezi)-1) + ! ...Assign the test + test = .NOT.(Compares_Within_Tolerance(ezr, azr, n_SigFig, cutoff=epsilon_delta_r) .AND. & + Compares_Within_Tolerance(ezi, azi, n_SigFig, cutoff=epsilon_delta_i)) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ","(",es25.18,",",es25.18,")",a,& + &7x,"Outside of : ",i0," significant figures",a,& + &7x,"And got : ","(",es25.18,",",es25.18,")",a,& + &7x,"|Difference| : ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, n_SigFig, CRLF, Actual, CRLF, CMPLX(ezr-azr,ezi-azi,Single) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexsp_refute_withinsigfig_s + + + SUBROUTINE complexsp_refute_withinsigfig_r1( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:), Actual(:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[COMPLEX(Single)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_WithinSigfig( Expected(i), Actual(i), n_SigFig ) + END DO + END SUBROUTINE complexsp_refute_withinsigfig_r1 + + + SUBROUTINE complexsp_refute_withinsigfig_r2( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Single), INTENT(IN) :: Expected(:,:), Actual(:,:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[COMPLEX(Single)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_WithinSigfig( Expected(i,j), Actual(i,j), n_SigFig ) + END DO + END DO + END SUBROUTINE complexsp_refute_withinsigfig_r2 + + + SUBROUTINE complexdp_refute_withinsigfig_s( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected, Actual + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[COMPLEX(Double)]' + ! Variables + REAL(Double) :: ezr, ezi + REAL(Double) :: azr, azi + REAL(Double) :: epsilon_delta_r, epsilon_delta_i + LOGICAL :: test + LOGICAL :: verbose + CHARACTER(SL) :: message + ! Setup + ! ...Split expected into real and imag + ezr = REAL(Expected,Double) + ezi = AIMAG(Expected) + azr = REAL(Actual,Double) + azi = AIMAG(Actual) + ! ...Compute the test cutoffs + epsilon_delta_r = EPSILON(ezr) * REAL(RADIX(ezr),Double)**(EXPONENT(ezr)-1) + epsilon_delta_i = EPSILON(ezi) * REAL(RADIX(ezi),Double)**(EXPONENT(ezi)-1) + ! ...Assign the test + test = .NOT.(Compares_Within_Tolerance(ezr, azr, n_SigFig, cutoff=epsilon_delta_r) .AND. & + Compares_Within_Tolerance(ezi, azi, n_SigFig, cutoff=epsilon_delta_i)) + ! ...Locally modify properties for this test + CALL Get_Property( & + self, & + Verbose = verbose ) + verbose = verbose .OR. (.NOT. test) ! Always output test failure + ! Assert the test + IF ( test ) THEN + CALL Test_Passed( self ) + ELSE + CALL Test_Failed( self ) + END IF + ! Generate the test message + WRITE( Message, & + '(a,7x,"Expected : ","(",es25.18,",",es25.18,")",a,& + &7x,"Outside of : ",i0," significant figures",a,& + &7x,"And got : ","(",es25.18,",",es25.18,")",a,& + &7x,"|Difference| : ","(",es25.18,",",es25.18,")")') & + CRLF, Expected, CRLF, n_SigFig, CRLF, Actual, CRLF, CMPLX(ezr-azr,ezi-azi,Single) + ! Load the object with the message + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + ! Output the result + IF ( verbose ) CALL Display_Message( self ) + END SUBROUTINE complexdp_refute_withinsigfig_s + + + SUBROUTINE complexdp_refute_withinsigfig_r1( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:), Actual(:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[COMPLEX(Double)]' + ! Variables + INTEGER :: i, isize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected) + IF ( SIZE(Actual) /= isize ) THEN + CALL Test_Failed( self ) + WRITE( Message,'("Array sizes are diffferent -- Expected:",i0,"; Actual:",i0)') & + isize, SIZE(Actual) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO i = 1, isize + CALL self%Refute_WithinSigfig( Expected(i), Actual(i), n_SigFig ) + END DO + END SUBROUTINE complexdp_refute_withinsigfig_r1 + + + SUBROUTINE complexdp_refute_withinsigfig_r2( self, Expected, Actual, n_SigFig ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + COMPLEX(Double), INTENT(IN) :: Expected(:,:), Actual(:,:) + INTEGER, INTENT(IN) :: n_SigFig + ! Parameters + CHARACTER(*), PARAMETER :: PROCEDURE_NAME = 'UnitTest::Refute_WithinSigfig[COMPLEX(Double)]' + ! Variables + INTEGER :: i, j, isize, jsize + CHARACTER(SL) :: Message + ! Check array sizes + isize = SIZE(Expected,DIM=1); jsize = SIZE(Expected,DIM=2) + IF ( SIZE(Actual,DIM=1) /= isize .OR. & + SIZE(Actual,DIM=2) /= jsize ) THEN + CALL Test_Failed( self ) + WRITE( Message, & + '("Array sizes are diffferent -- Expected:(",i0,",",i0,"); Actual:(",i0,",",i0,")")') & + isize, jsize, & + SIZE(Actual,DIM=1), SIZE(Actual,DIM=2) + CALL Set_Property( & + self, & + Level = TEST_LEVEL, & + Procedure = PROCEDURE_NAME, & + Message = Message ) + CALL Display_Message( self ) + RETURN + ENDIF + ! Loop over elements + DO j = 1, jsize + DO i = 1, isize + CALL self%Refute_WithinSigfig( Expected(i,j), Actual(i,j), n_SigFig ) + END DO + END DO + END SUBROUTINE complexdp_refute_withinsigfig_r2 + + + + +!################################################################################ +!################################################################################ +!## ## +!## ## PRIVATE MODULE ROUTINES ## ## +!## ## +!################################################################################ +!################################################################################ + +!-------------------------------------------------------------------------------- +! +! NAME: +! UnitTest::Set_Property +! +! PURPOSE: +! Private method to set the properties of a UnitTest object. +! +! All WRITE access to the UnitTest object properties should be +! done using this method. +! +! CALLING SEQUENCE: +! CALL utest_obj%Set_Property( Verbose = Verbose , & +! Title = Title , & +! Caller = Caller , & +! Level = Level , & +! Procedure = Procedure , & +! Message = Message , & +! Test_Result = Test_Result , & +! n_Tests = n_Tests , & +! n_Passed_Tests = n_Passed_Tests , & +! n_Failed_Tests = n_Failed_Tests , & +! n_AllTests = n_AllTests , & +! n_Passed_AllTests = n_Passed_AllTests, & +! n_Failed_AllTests = n_Failed_AllTests ) +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +! OPTIONAL INPUTS: +! Verbose: Logical to control length of reporting output. +! If == .FALSE., Only failed tests are reported. +! == .TRUE., Both failed and passed tests are reported. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Title: Character string containing the title of the +! test to be performed. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Caller: Character string containing the name of the +! calling subprogram. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Level: Integer flag specifying the output message level. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Procedure: The name of the UnitTest procedure. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Message: Character string containing an informational +! message about the unit test performed. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Test_Result: Logical to contain the result of unit tests +! performed +! If == .TRUE., Test passed. +! == .FALSE., Test failed. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! n_Tests: The number of tests performed for the current +! unit test type, i.e. since the last call to +! UnitTest_Setup(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! n_Passed_Tests: The number of tests passed for the current +! unit test type, i.e. since the last call to +! UnitTest_Setup(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! n_Failed_Tests: The number of tests failed for the current +! unit test type, i.e. since the last call to +! UnitTest_Setup(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! n_AllTests: The total number of tests performed, i.e. since +! the last call to UnitTest_Init(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! n_Passed_AllTests: The total number of tests passed, i.e. since +! the last call to UnitTest_Init(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! n_Failed_AllTests: The total number of tests failed, i.e. since +! the last call to UnitTest_Init(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +!-------------------------------------------------------------------------------- + + PURE SUBROUTINE Set_Property( & + self , & ! Object + Verbose , & ! Optional input + Title , & ! Optional input + Caller , & ! Optional input + Level , & ! Optional input + Procedure , & ! Optional input + Message , & ! Optional input + Test_Result , & ! Optional input + n_Tests , & ! Optional input + n_Passed_Tests , & ! Optional input + n_Failed_Tests , & ! Optional input + n_AllTests , & ! Optional input + n_Passed_AllTests, & ! Optional input + n_Failed_AllTests ) ! Optional input + ! Arguments + CLASS(UnitTest_type) , INTENT(IN OUT) :: self + LOGICAL , OPTIONAL, INTENT(IN) :: Verbose + CHARACTER(*), OPTIONAL, INTENT(IN) :: Title + CHARACTER(*), OPTIONAL, INTENT(IN) :: Caller + INTEGER , OPTIONAL, INTENT(IN) :: Level + CHARACTER(*), OPTIONAL, INTENT(IN) :: Procedure + CHARACTER(*), OPTIONAL, INTENT(IN) :: Message + LOGICAL , OPTIONAL, INTENT(IN) :: Test_Result + INTEGER , OPTIONAL, INTENT(IN) :: n_Tests + INTEGER , OPTIONAL, INTENT(IN) :: n_Passed_Tests + INTEGER , OPTIONAL, INTENT(IN) :: n_Failed_Tests + INTEGER , OPTIONAL, INTENT(IN) :: n_AllTests + INTEGER , OPTIONAL, INTENT(IN) :: n_Passed_AllTests + INTEGER , OPTIONAL, INTENT(IN) :: n_Failed_AllTests + ! Set the object properties + IF ( PRESENT(Verbose ) ) self%Verbose = Verbose + IF ( PRESENT(Title ) ) self%Title = Title + IF ( PRESENT(Caller ) ) self%Caller = Caller + IF ( PRESENT(Level ) ) self%Level = Level + IF ( PRESENT(Procedure ) ) self%Procedure = Procedure + IF ( PRESENT(Message ) ) self%Message = Message + IF ( PRESENT(Test_Result ) ) self%Test_Result = Test_Result + IF ( PRESENT(n_Tests ) ) self%n_Tests = n_Tests + IF ( PRESENT(n_Passed_Tests ) ) self%n_Passed_Tests = n_Passed_Tests + IF ( PRESENT(n_Failed_Tests ) ) self%n_Failed_Tests = n_Failed_Tests + IF ( PRESENT(n_AllTests ) ) self%n_AllTests = n_AllTests + IF ( PRESENT(n_Passed_AllTests) ) self%n_Passed_AllTests = n_Passed_AllTests + IF ( PRESENT(n_Failed_AllTests) ) self%n_Failed_AllTests = n_Failed_AllTests + END SUBROUTINE Set_Property + + +!-------------------------------------------------------------------------------- +! +! NAME: +! UnitTest::Get_Property +! +! PURPOSE: +! Private method to get the properties of a UnitTest object. +! +! All READ access to the UnitTest object properties should be +! done using this method. +! +! CALLING SEQUENCE: +! CALL utest_obj%Get_Property( Verbose = Verbose , & +! Title = Title , & +! Caller = Caller , & +! Level = Level , & +! Procedure = Procedure , & +! Message = Message , & +! Test_Result = Test_Result , & +! n_Tests = n_Tests , & +! n_Passed_Tests = n_Passed_Tests , & +! n_Failed_Tests = n_Failed_Tests , & +! n_AllTests = n_AllTests , & +! n_Passed_AllTests = n_Passed_AllTests, & +! n_Failed_AllTests = n_Failed_AllTests ) +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OPTIONAL OUTPUTS: +! Verbose: Logical to control length of reporting output. +! If == .FALSE., Only failed tests are reported. +! == .TRUE., Both failed and passed tests are reported. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Title: Character string containing the title of the +! test to be performed. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Caller: Character string containing the name of the +! calling subprogram. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Level: Integer flag specifying the output message level. +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Procedure: The name of the last UnitTest Procedure called. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN), OPTIONAL +! +! Message: Character string containing an informational +! message about the last unit test performed. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! Test_Result: Logical containing the result of the last +! unit test performed +! If == .TRUE., Test passed. +! == .FALSE., Test failed. +! UNITS: N/A +! TYPE: LOGICAL +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! n_Tests: The number of tests performed for the current +! unit test type, i.e. since the last call to +! UnitTest_Setup(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! n_Passed_Tests: The number of tests passed for the current +! unit test type, i.e. since the last call to +! UnitTest_Setup(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! n_Failed_Tests: The number of tests failed for the current +! unit test type, i.e. since the last call to +! UnitTest_Setup(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! n_AllTests: The total number of tests performed, i.e. since +! the last call to UnitTest_Init(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! n_Passed_AllTests: The total number of tests passed, i.e. since +! the last call to UnitTest_Init(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +! n_Failed_AllTests: The total number of tests failed, i.e. since +! the last call to UnitTest_Init(). +! UNITS: N/A +! TYPE: INTEGER +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT), OPTIONAL +! +!------------------------------------------------------------------------------ + + PURE SUBROUTINE Get_Property( & + self , & ! Object + Verbose , & ! Optional output + Title , & ! Optional output + Caller , & ! Optional output + Level , & ! Optional output + Procedure , & ! Optional output + Message , & ! Optional output + Test_Result , & ! Optional output + n_Tests , & ! Optional output + n_Passed_Tests , & ! Optional output + n_Failed_Tests , & ! Optional output + n_AllTests , & ! Optional output + n_Passed_AllTests, & ! Optional output + n_Failed_AllTests ) ! Optional output + ! Arguments + CLASS(UnitTest_type) , INTENT(IN) :: self + LOGICAL , OPTIONAL, INTENT(OUT) :: Verbose + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Title + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Caller + INTEGER , OPTIONAL, INTENT(OUT) :: Level + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Procedure + CHARACTER(*), OPTIONAL, INTENT(OUT) :: Message + LOGICAL , OPTIONAL, INTENT(OUT) :: Test_Result + INTEGER , OPTIONAL, INTENT(OUT) :: n_Tests + INTEGER , OPTIONAL, INTENT(OUT) :: n_Passed_Tests + INTEGER , OPTIONAL, INTENT(OUT) :: n_Failed_Tests + INTEGER , OPTIONAL, INTENT(OUT) :: n_AllTests + INTEGER , OPTIONAL, INTENT(OUT) :: n_Passed_AllTests + INTEGER , OPTIONAL, INTENT(OUT) :: n_Failed_AllTests + ! Get the object properties + IF ( PRESENT(Verbose ) ) Verbose = self%Verbose + IF ( PRESENT(Title ) ) Title = self%Title + IF ( PRESENT(Caller ) ) Caller = self%Caller + IF ( PRESENT(Level ) ) Level = self%Level + IF ( PRESENT(Procedure ) ) Procedure = self%Procedure + IF ( PRESENT(Message ) ) Message = self%Message + IF ( PRESENT(Test_Result ) ) Test_Result = self%Test_Result + IF ( PRESENT(n_Tests ) ) n_Tests = self%n_Tests + IF ( PRESENT(n_Passed_Tests ) ) n_Passed_Tests = self%n_Passed_Tests + IF ( PRESENT(n_Failed_Tests ) ) n_Failed_Tests = self%n_Failed_Tests + IF ( PRESENT(n_AllTests ) ) n_AllTests = self%n_AllTests + IF ( PRESENT(n_Passed_AllTests) ) n_Passed_AllTests = self%n_Passed_AllTests + IF ( PRESENT(n_Failed_AllTests) ) n_Failed_AllTests = self%n_Failed_AllTests + END SUBROUTINE Get_Property + + +!-------------------------------------------------------------------------------- +! +! NAME: +! UnitTest::Test_Passed +! +! PURPOSE: +! Private method to increment passed test counters. +! +! CALLING SEQUENCE: +! CALL utest_obj%Test_Passed() +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +!-------------------------------------------------------------------------------- + + SUBROUTINE Test_Passed( self ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + ! Variables + INTEGER :: n_Passed_Tests, n_Passed_AllTests + + ! Increment total test counters + CALL self%Test_Increment() + + ! Increment the passed test counters + ! ...Get 'em + CALL self%Get_Property( & + n_Passed_Tests = n_Passed_Tests, & + n_Passed_AllTests = n_Passed_AllTests ) + ! ...Increment + n_Passed_Tests = n_Passed_Tests + 1 + n_Passed_AllTests = n_Passed_AllTests + 1 + ! ...Save 'em and set successful test result + CALL self%Set_Property( & + Test_Result = .TRUE., & + n_Passed_Tests = n_Passed_Tests, & + n_Passed_AllTests = n_Passed_AllTests ) + END SUBROUTINE Test_Passed + + +!-------------------------------------------------------------------------------- +! +! NAME: +! UnitTest::Test_Failed +! +! PURPOSE: +! Private method to increment failed test counters. +! +! CALLING SEQUENCE: +! CALL utest_obj%Test_Failed() +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +!-------------------------------------------------------------------------------- + + SUBROUTINE Test_Failed( self ) + ! Arguments + CLASS(UnitTest_type), INTENT(IN OUT) :: self + ! Variables + INTEGER :: n_Failed_Tests, n_Failed_AllTests + + ! Increment total test counters + CALL self%Test_Increment() + + ! Increment the failed test counters + ! ...Get 'em + CALL self%Get_Property( & + n_Failed_Tests = n_Failed_Tests, & + n_Failed_AllTests = n_Failed_AllTests ) + ! ...Increment + n_Failed_Tests = n_Failed_Tests + 1 + n_Failed_AllTests = n_Failed_AllTests + 1 + ! ...Save 'em and set unsuccessful test result + CALL self%Set_Property( & + Test_Result = .FALSE., & + n_Failed_Tests = n_Failed_Tests, & + n_Failed_AllTests = n_Failed_AllTests ) + END SUBROUTINE Test_Failed + + +!-------------------------------------------------------------------------------- +! +! NAME: +! UnitTest::Test_Increment +! +! PURPOSE: +! Private method to increment the test total counters. +! +! CALLING SEQUENCE: +! CALL utest_obj%Test_Increment() +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +!-------------------------------------------------------------------------------- + + SUBROUTINE Test_Increment( self ) + CLASS(UnitTest_type), INTENT(IN OUT) :: self + INTEGER :: n_Tests, n_AllTests + + CALL self%Get_Property( & + n_Tests = n_Tests, & + n_AllTests = n_AllTests ) + + n_Tests = n_Tests + 1 + n_AllTests = n_AllTests + 1 + + CALL self%Set_Property( & + n_Tests = n_Tests, & + n_AllTests = n_AllTests ) + END SUBROUTINE Test_Increment + + +!-------------------------------------------------------------------------------- +! +! NAME: +! UnitTest::Display_Message +! +! PURPOSE: +! Private method to display the unit test messages to stdout. +! +! CALLING SEQUENCE: +! CALL utest_obj%Display_Message() +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN OUT) +! +!-------------------------------------------------------------------------------- + + SUBROUTINE Display_Message( self ) + CLASS(UnitTest_type), INTENT(IN) :: self + ! Variables + INTEGER :: level + CHARACTER(SL) :: procedure + CHARACTER(SL) :: message + CHARACTER(SL) :: fmt + CHARACTER(SL) :: prefix + CHARACTER(SL) :: test_info + INTEGER :: n_spaces + + CALL self%Get_Property( & + Level = level, & + Procedure = procedure, & + Message = message ) + + ! Set output bits manually + test_info = '' + SELECT CASE(level) + CASE(INIT_LEVEL) + prefix = '/' + n_spaces = 1 + CASE(SETUP_LEVEL) + prefix = '/,3x,14("-"),/' + n_spaces = 3 + CASE(TEST_LEVEL) + prefix = '' + n_spaces = 5 + CALL self%Test_Info_String( test_info ) + CASE(REPORT_LEVEL) + prefix = '' + n_spaces = 3 + CASE(SUMMARY_LEVEL) + prefix = '/,1x,16("="),/' + n_spaces = 1 + CASE DEFAULT + level = INTERNAL_FAIL_LEVEL + prefix = '/,"INVALID MESSAGE LEVEL!!",/' + n_spaces = 15 + END SELECT + + ! Write the message to stdout + WRITE(fmt, '("(",a,i0,"x,""("",a,"") "",a,"": "",a,1x,a)")') TRIM(prefix), n_spaces + WRITE( *,FMT=fmt ) TRIM(MESSAGE_LEVEL(level)), TRIM(procedure), TRIM(test_info), TRIM(message) + + END SUBROUTINE Display_Message + + +!-------------------------------------------------------------------------------- +! +! NAME: +! UnitTest::Test_Info_String +! +! PURPOSE: +! Private method to construct an info string for message output. +! +! CALLING SEQUENCE: +! CALL utest_obj%Test_Info_String( info ) +! +! OBJECT: +! utest_obj: UnitTest object. +! UNITS: N/A +! CLASS: UnitTest_type +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(IN) +! +! OUTPUTS: +! info: Character string containing the test number and +! whether the test passed or failed. +! UNITS: N/A +! TYPE: CHARACTER(*) +! DIMENSION: Scalar +! ATTRIBUTES: INTENT(OUT) +! +!-------------------------------------------------------------------------------- + + SUBROUTINE Test_Info_String( self, info ) + CLASS(UnitTest_Type), INTENT(IN) :: self + CHARACTER(*), INTENT(OUT) :: info + INTEGER :: n_tests + CHARACTER(6) :: passfail + CALL self%Get_Property( n_Tests = n_Tests ) + IF ( self%Passed() ) THEN + passfail = 'PASSED' + ELSE + passfail = 'FAILED' + END IF + WRITE( info,'("Test#",i0,1x,a,".")') n_tests, passfail + END SUBROUTINE Test_Info_String + +END MODULE UnitTest_Define diff --git a/var/external/crtm_2.2.3/libsrc/Zeeman_Input_Define.f90 b/var/external/crtm_2.3.0/libsrc/Zeeman_Input_Define.f90 similarity index 99% rename from var/external/crtm_2.2.3/libsrc/Zeeman_Input_Define.f90 rename to var/external/crtm_2.3.0/libsrc/Zeeman_Input_Define.f90 index 5556fc4a4d..7eaacf18aa 100644 --- a/var/external/crtm_2.2.3/libsrc/Zeeman_Input_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/Zeeman_Input_Define.f90 @@ -54,7 +54,7 @@ MODULE Zeeman_Input_Define ! Module parameters ! ----------------- CHARACTER(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = & - '$Id: Zeeman_Input_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: Zeeman_Input_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Release and version INTEGER, PARAMETER :: ZEEMAN_INPUT_RELEASE = 1 ! This determines structure and file formats. INTEGER, PARAMETER :: ZEEMAN_INPUT_VERSION = 1 ! This is just the default data version. diff --git a/var/external/crtm_2.2.3/libsrc/Zeeman_Utility.f90 b/var/external/crtm_2.3.0/libsrc/Zeeman_Utility.f90 similarity index 100% rename from var/external/crtm_2.2.3/libsrc/Zeeman_Utility.f90 rename to var/external/crtm_2.3.0/libsrc/Zeeman_Utility.f90 diff --git a/var/external/crtm_2.2.3/libsrc/iAtm_Define.f90 b/var/external/crtm_2.3.0/libsrc/iAtm_Define.f90 similarity index 98% rename from var/external/crtm_2.2.3/libsrc/iAtm_Define.f90 rename to var/external/crtm_2.3.0/libsrc/iAtm_Define.f90 index ae4b4c7217..3ad3683130 100644 --- a/var/external/crtm_2.2.3/libsrc/iAtm_Define.f90 +++ b/var/external/crtm_2.3.0/libsrc/iAtm_Define.f90 @@ -40,7 +40,7 @@ MODULE iAtm_Define ! ----------------- ! Version Id for the module CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: iAtm_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' + '$Id: iAtm_Define.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 diff --git a/var/external/crtm_2.2.3/libsrc/make.dependencies b/var/external/crtm_2.3.0/libsrc/make.dependencies similarity index 86% rename from var/external/crtm_2.2.3/libsrc/make.dependencies rename to var/external/crtm_2.3.0/libsrc/make.dependencies index d520423b28..257922c0d2 100644 --- a/var/external/crtm_2.2.3/libsrc/make.dependencies +++ b/var/external/crtm_2.3.0/libsrc/make.dependencies @@ -9,7 +9,7 @@ Azimuth_Emissivity_F6_Module.o : Azimuth_Emissivity_F6_Module.f90 Search_Utility Azimuth_Emissivity_Module.o : Azimuth_Emissivity_Module.f90 FitCoeff_Define.o Type_Kinds.o Binary_File_Utility.o : Binary_File_Utility.f90 Endian_Utility.o Message_Handler.o File_Utility.o Type_Kinds.o CRTM_AOD_Module.o : CRTM_AOD_Module.f90 ASvar_Define.o CRTM_AerosolCoeff.o CRTM_RTSolution_Define.o CRTM_AerosolScatter.o CRTM_AtmOptics_Define.o CRTM_Options_Define.o CRTM_ChannelInfo_Define.o CRTM_Atmosphere_Define.o CRTM_Parameters.o Message_Handler.o -CRTM_Adjoint_Module.o : CRTM_Adjoint_Module.f90 RTV_Define.o ASvar_Define.o CSvar_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_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_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 AerosolCoeff_Binary_IO.o AerosolCoeff_Define.o Message_Handler.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 Message_Handler.o Type_Kinds.o CRTM_Aerosol_Define.o : CRTM_Aerosol_Define.f90 Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o @@ -22,11 +22,12 @@ CRTM_Atmosphere.o : CRTM_Atmosphere.f90 iAtm_Define.o CRTM_Model_Profiles.o CRTM CRTM_Atmosphere_Define.o : CRTM_Atmosphere_Define.f90 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_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_Binary_IO.o CloudCoeff_Define.o Message_Handler.o +CRTM_CloudCover_Define.o : CRTM_CloudCover_Define.f90 CRTM_Atmosphere_Define.o Compare_Float_Numbers.o Message_Handler.o File_Utility.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 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_Fastem1.o : CRTM_Fastem1.f90 CRTM_Parameters.o Type_Kinds.o CRTM_FastemX.o : CRTM_FastemX.f90 Azimuth_Emissivity_F6_Module.o Azimuth_Emissivity_Module.o Reflection_Correction_Module.o Large_Scale_Correction_Module.o Small_Scale_Correction_Module.o Foam_Utility_Module.o Liu.o Fresnel.o CRTM_Parameters.o MWwaterCoeff_Define.o Type_Kinds.o -CRTM_Forward_Module.o : CRTM_Forward_Module.f90 RTV_Define.o ASvar_Define.o CSvar_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_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_Forward_Module.o : CRTM_Forward_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_GeometryInfo.o : CRTM_GeometryInfo.f90 CRTM_GeometryInfo_Define.o CRTM_Parameters.o Date_Utility.o Message_Handler.o Type_Kinds.o CRTM_GeometryInfo_Define.o : CRTM_GeometryInfo_Define.f90 CRTM_Geometry_Define.o CRTM_Parameters.o Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o CRTM_Geometry_Define.o : CRTM_Geometry_Define.f90 CRTM_Parameters.o Date_Utility.o Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o @@ -40,7 +41,7 @@ CRTM_IRlandCoeff.o : CRTM_IRlandCoeff.f90 SEcategory_Define.o Message_Handler.o CRTM_IRsnowCoeff.o : CRTM_IRsnowCoeff.f90 SEcategory_Define.o Message_Handler.o CRTM_IRwaterCoeff.o : CRTM_IRwaterCoeff.f90 IRwaterCoeff_Define.o Message_Handler.o CRTM_Interpolation.o : CRTM_Interpolation.f90 Type_Kinds.o -CRTM_K_Matrix_Module.o : CRTM_K_Matrix_Module.f90 RTV_Define.o ASvar_Define.o CSvar_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_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_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_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 CRTM_LowFrequency_MWSSEM.o : CRTM_LowFrequency_MWSSEM.f90 CRTM_Interpolation.o CRTM_Parameters.o Ellison.o Guillou.o Fresnel.o Type_Kinds.o CRTM_MW_Ice_SfcOptics.o : CRTM_MW_Ice_SfcOptics.f90 NESDIS_SSMIS_SeaIceEM_Module.o NESDIS_MHS_SICEEM_Module.o NESDIS_SEAICE_PHYEM_MODULE.o NESDIS_SSMI_SIceEM_Module.o NESDIS_AMSRE_SICEEM_Module.o NESDIS_AMSU_SICEEM_Module.o CRTM_SensorInfo.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 @@ -51,7 +52,7 @@ CRTM_MWwaterCoeff.o : CRTM_MWwaterCoeff.f90 MWwaterCoeff_Define.o Message_Handle CRTM_Model_Profiles.o : CRTM_Model_Profiles.f90 CRTM_Atmosphere_Define.o Type_Kinds.o CRTM_MoleculeScatter.o : CRTM_MoleculeScatter.f90 CRTM_AtmOptics_Define.o CRTM_Atmosphere_Define.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o CRTM_NLTECorrection.o : CRTM_NLTECorrection.f90 NLTE_Predictor_Define.o NLTE_Parameters.o NLTECoeff_Define.o CRTM_GeometryInfo_Define.o CRTM_Atmosphere_Define.o CRTM_Parameters.o Type_Kinds.o -CRTM_Options_Define.o : CRTM_Options_Define.f90 Zeeman_Input_Define.o SSU_Input_Define.o CRTM_Parameters.o Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o +CRTM_Options_Define.o : CRTM_Options_Define.f90 CRTM_CloudCover_Define.o Zeeman_Input_Define.o SSU_Input_Define.o CRTM_Parameters.o Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o CRTM_Parameters.o : CRTM_Parameters.f90 Type_Kinds.o CRTM_Planck_Functions.o : CRTM_Planck_Functions.f90 CRTM_SpcCoeff.o CRTM_Parameters.o Type_Kinds.o CRTM_Predictor.o : CRTM_Predictor.f90 ODZeeman_AtmAbsorption.o ODPS_Predictor.o ODPS_Predictor_Define.o ODAS_Predictor.o ODAS_Predictor_Define.o CRTM_Predictor_Define.o CRTM_AtmOptics_Define.o CRTM_GeometryInfo_Define.o CRTM_AncillaryInput_Define.o CRTM_TauCoeff.o CRTM_Atmosphere_Define.o CRTM_Parameters.o Message_Handler.o Type_Kinds.o @@ -65,7 +66,7 @@ CRTM_SfcOptics.o : CRTM_SfcOptics.f90 CRTM_VIS_Ice_SfcOptics.o CRTM_VIS_Snow_Sfc CRTM_SfcOptics_Define.o : CRTM_SfcOptics_Define.f90 CRTM_Parameters.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o CRTM_SpcCoeff.o : CRTM_SpcCoeff.f90 CRTM_Parameters.o SpcCoeff_Binary_IO.o SpcCoeff_Define.o SensorInfo_Parameters.o Message_Handler.o CRTM_Surface_Define.o : CRTM_Surface_Define.f90 CRTM_SensorData_Define.o Binary_File_Utility.o File_Utility.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o -CRTM_Tangent_Linear_Module.o : CRTM_Tangent_Linear_Module.f90 ASvar_Define.o CSvar_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 RTV_Define.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_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_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_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 @@ -116,6 +117,8 @@ NESDIS_SSMI_SIceEM_Module.o : NESDIS_SSMI_SIceEM_Module.f90 NESDIS_LandEM_Module NESDIS_SSMI_SnowEM_Module.o : NESDIS_SSMI_SnowEM_Module.f90 NESDIS_LandEM_Module.o Type_Kinds.o NESDIS_SnowEM_ATMS_Parameters.o : NESDIS_SnowEM_ATMS_Parameters.f90 Type_Kinds.o NESDIS_SnowEM_Parameters.o NESDIS_SnowEM_Parameters.o : NESDIS_SnowEM_Parameters.f90 Type_Kinds.o +NESDIS_ATMS_SeaIce_LIB.o : NESDIS_ATMS_SeaIce_LIB.f90 Type_Kinds.o +NESDIS_ATMS_SeaICE_Module.o : NESDIS_ATMS_SeaICE_Module.f90 Type_Kinds.o NESDIS_LandEM_Module.o NESDIS_ATMS_SeaICE_LIB.o NLTECoeff_Binary_IO.o : NLTECoeff_Binary_IO.f90 NLTECoeff_Define.o Binary_File_Utility.o Message_Handler.o File_Utility.o Type_Kinds.o NLTECoeff_Define.o : NLTECoeff_Define.f90 SensorInfo_Parameters.o Subset_Define.o Compare_Float_Numbers.o Message_Handler.o Type_Kinds.o NLTE_Parameters.o : NLTE_Parameters.f90 Type_Kinds.o diff --git a/var/external/crtm_2.2.3/libsrc/make.filelist b/var/external/crtm_2.3.0/libsrc/make.filelist similarity index 96% rename from var/external/crtm_2.2.3/libsrc/make.filelist rename to var/external/crtm_2.3.0/libsrc/make.filelist index bead4ec268..f9fbe25c5f 100644 --- a/var/external/crtm_2.2.3/libsrc/make.filelist +++ b/var/external/crtm_2.3.0/libsrc/make.filelist @@ -1,7 +1,7 @@ # # The make include file of the source files to be used in the CRTM library build. # -# $Id: make.filelist 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $ +# $Id: make.filelist 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $ # # The list of files that need preprocessing @@ -55,6 +55,8 @@ FSRC_FILES = \ NESDIS_SSMIS_SnowEM_Module.f90 \ NESDIS_SnowEM_ATMS_Parameters.f90 \ NESDIS_ATMS_SnowEM_Module.f90 \ + NESDIS_ATMS_SeaICE_LIB.f90 \ + NESDIS_ATMS_SeaICE_Module.f90 \ CRTM_Utility.f90 \ CRTM_Interpolation.f90 \ CRTM_SpcCoeff.f90 \ @@ -71,6 +73,7 @@ FSRC_FILES = \ CRTM_Geometry_Define.f90 \ CRTM_GeometryInfo_Define.f90 CRTM_GeometryInfo.f90 \ CRTM_Atmosphere.f90 iAtm_Define.f90 \ + CRTM_CloudCover_Define.f90 \ CRTM_Model_Profiles.f90 \ CRTM_AerosolScatter.f90 ASvar_Define.f90 \ CRTM_CloudScatter.f90 CSvar_Define.f90 \ diff --git a/var/external/crtm_2.2.3/libsrc/makefile b/var/external/crtm_2.3.0/libsrc/makefile similarity index 100% rename from var/external/crtm_2.2.3/libsrc/makefile rename to var/external/crtm_2.3.0/libsrc/makefile diff --git a/var/external/crtm_2.2.3/makefile b/var/external/crtm_2.3.0/makefile similarity index 100% rename from var/external/crtm_2.2.3/makefile rename to var/external/crtm_2.3.0/makefile diff --git a/var/run/crtm_coeffs b/var/run/crtm_coeffs index 299ff83f4f..dd47bff9b3 120000 --- a/var/run/crtm_coeffs +++ b/var/run/crtm_coeffs @@ -1 +1 @@ -/glade/p/work/wrfhelp/WRFDA_files/crtm_coeffs_2.2.3 \ No newline at end of file +/glade/work/wrfhelp/WRFDA_files/crtm_coeffs_2.3.0 \ No newline at end of file