From eb228ce22f67c1ad3538a238accccb43d1cf971b Mon Sep 17 00:00:00 2001 From: Jonathan Guerrette Date: Wed, 28 Mar 2018 15:27:52 -0600 Subject: [PATCH 01/86] Updated WRFDA RTTOV interface to version 12.1 - code has been compiled with RTTOV12.1 - preliminary 3D-Var test w/ WRFDA arctic tutorial case + minimization appears successful + results differ from RTTOV11.3 due to RTTOV updates + quantitative analysis of results has not been performed Changes to be committed: modified: compile modified: var/da/da_radiance/da_get_innov_vector_rttov.inc modified: var/da/da_radiance/da_radiance.f90 modified: var/da/da_radiance/da_rttov.f90 modified: var/da/da_radiance/da_rttov_ad.inc modified: var/da/da_radiance/da_rttov_direct.inc modified: var/da/da_radiance/da_rttov_init.inc modified: var/da/da_radiance/da_rttov_k.inc modified: var/da/da_radiance/da_rttov_tl.inc modified: var/da/da_radiance/module_radiance.f90 --- compile | 67 ++++++++++--------- .../da_radiance/da_get_innov_vector_rttov.inc | 27 ++++---- var/da/da_radiance/da_radiance.f90 | 4 +- var/da/da_radiance/da_rttov.f90 | 7 +- var/da/da_radiance/da_rttov_ad.inc | 33 ++++----- var/da/da_radiance/da_rttov_direct.inc | 19 +++--- var/da/da_radiance/da_rttov_init.inc | 19 ++++++ var/da/da_radiance/da_rttov_k.inc | 27 ++++---- var/da/da_radiance/da_rttov_tl.inc | 33 ++++----- var/da/da_radiance/module_radiance.f90 | 15 +++-- 10 files changed, 145 insertions(+), 106 deletions(-) diff --git a/compile b/compile index 7890cc0c27..157e3bc78a 100755 --- a/compile +++ b/compile @@ -340,37 +340,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 "" @@ -383,6 +352,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/var/da/da_radiance/da_get_innov_vector_rttov.inc b/var/da/da_radiance/da_get_innov_vector_rttov.inc index 17d6b309c7..d18f57fb16 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(inst), & ! 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(inst), &! 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(inst)) 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..9fb30eb6ee 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,11 @@ 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(nsensor)) + 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 +135,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..1195814228 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), allocatable :: atlas(:) + integer(jpim), allocatable :: atlas_type(:), atlas_id(:) #endif type satinfo_type From 86c8b8f6f91ae5118468fedd9fa67692b6e71764 Mon Sep 17 00:00:00 2001 From: Jonathan Guerrette Date: Tue, 1 May 2018 12:13:40 -0600 Subject: [PATCH 02/86] Added GOES-16 observation I/O Still need to add/fix/improve: + Clear-sky - Cloud detection/mask - QC - Bias Correction + All-sky - Cloud Scattering in RTTOV and CRTM - Symmetric Error - QC - Bias Correction Changes to be committed: modified: ../../Registry/registry.var modified: da_radiance/da_get_satzen.inc new file: da_radiance/da_qc_goesabi.inc modified: da_radiance/da_qc_rad.inc modified: da_radiance/da_radiance.f90 modified: da_radiance/da_radiance1.f90 modified: da_radiance/da_radiance_init.inc new file: da_radiance/da_read_obs_ncgoesabi.inc modified: da_radiance/da_read_obs_ncgoesimg.inc modified: da_radiance/da_setup_radiance_structures.inc modified: da_setup_structures/da_setup_obs_structures.inc modified: da_setup_structures/da_setup_structures.f90 modified: da_tools/da_get_julian_time.inc new file: ../run/radiance_info/goes-16-abi.info new file: ../run/radiance_info/goes-17-abi.info --- Registry/registry.var | 1 + var/da/da_radiance/da_get_satzen.inc | 73 +- var/da/da_radiance/da_qc_goesabi.inc | 203 ++ var/da/da_radiance/da_qc_rad.inc | 5 +- var/da/da_radiance/da_radiance.f90 | 4 +- var/da/da_radiance/da_radiance1.f90 | 1 + var/da/da_radiance/da_radiance_init.inc | 3 + var/da/da_radiance/da_read_obs_ncgoesabi.inc | 1739 +++++++++++++++++ var/da/da_radiance/da_read_obs_ncgoesimg.inc | 2 +- .../da_setup_radiance_structures.inc | 9 + .../da_setup_obs_structures.inc | 9 +- .../da_setup_structures.f90 | 2 +- var/da/da_tools/da_get_julian_time.inc | 1 + var/run/radiance_info/goes-16-abi.info | 11 + var/run/radiance_info/goes-17-abi.info | 11 + 15 files changed, 2038 insertions(+), 36 deletions(-) create mode 100644 var/da/da_radiance/da_qc_goesabi.inc create mode 100644 var/da/da_radiance/da_read_obs_ncgoesabi.inc create mode 100644 var/run/radiance_info/goes-16-abi.info create mode 100644 var/run/radiance_info/goes-17-abi.info diff --git a/Registry/registry.var b/Registry/registry.var index b2169fee99..befa4e9f9e 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -185,6 +185,7 @@ rconfig logical use_iasiobs namelist,wrfvar4 1 .false. - "use rconfig logical use_seviriobs namelist,wrfvar4 1 .false. - "use_seviriobs" "" "" rconfig logical use_amsr2obs namelist,wrfvar4 1 .false. - "use_amsr2obs" "" "" rconfig logical use_goesimgobs namelist,wrfvar4 1 .false. - "use_goesimgobs" "" "" +rconfig logical use_goesabiobs namelist,wrfvar4 1 .false. - "use_goesabiobs" "" "" rconfig logical use_kma1dvar namelist,wrfvar4 1 .false. - "use_kma1dvar" "" "" rconfig logical use_filtered_rad namelist,wrfvar4 1 .false. - "use_filtered_rad" "" "" rconfig logical use_obs_errfac namelist,wrfvar4 1 .false. - "use_obs_errfac" "" "" diff --git a/var/da/da_radiance/da_get_satzen.inc b/var/da/da_radiance/da_get_satzen.inc index b522d24e62..fef99c8bbb 100644 --- a/var/da/da_radiance/da_get_satzen.inc +++ b/var/da/da_radiance/da_get_satzen.inc @@ -15,37 +15,48 @@ subroutine da_get_satzen ( lat,lon,sate_index,theta_true ) real, intent(out) :: theta_true real :: alat, alon, alon_sat - real :: theta, r_tmp, theta_tmp - - - alat = lat - alon = lon - - if (sate_index .eq. 11) then - alon_sat = -135.*pi/180. - else if (sate_index .eq. 12) then - alon_sat = -60.*pi/180. - else if (sate_index .eq. 13) then - alon_sat = -75.*pi/180. - else if (sate_index .eq. 14) then - alon_sat = -105.*pi/180. - else if (sate_index .eq. 15) then - alon_sat = -135.*pi/180. - else - write(*,*)'this satellite is not included' - stop - end if + real :: theta, r_tmp, theta_tmp, gam + + alat = lat + alon = lon + + if (sate_index .eq. 11) then + alon_sat = -135.*pi/180. + else if (sate_index .eq. 12) then + alon_sat = -60.*pi/180. + else if (sate_index .eq. 13) then + alon_sat = -75.*pi/180. + else if (sate_index .eq. 14) then + alon_sat = -105.*pi/180. + else if (sate_index .eq. 15) then + alon_sat = -135.*pi/180. + else if (sate_index .eq. 16) then +! alon_sat = -75.2*pi/180. !True Value? + alon_sat = -75.*pi/180. !Nominal Value +! else if (sate_index .eq. 17) then +! alon_sat = -137.*pi/180. + else + write(*,*)'this satellite is not included' + stop + end if - alat = alat*pi/180. - alon = alon*pi/180. - theta = abs(alon-alon_sat) - r_tmp = (2*earth_radius*sin(theta/2.)-earth_radius*(1-cos(alat))*sin(theta/2.))**2 & - +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(theta/2.))**2 - r_tmp = sqrt(r_tmp) - theta_true = 2*asin(r_tmp/earth_radius/2.) - theta_tmp = atan(earth_radius*sin(theta_true)/(satellite_height+earth_radius*(1-sin(theta_true)))) - theta_true = (theta_true+theta_tmp)*180./pi - - return + alat = alat*pi/180. + alon = alon*pi/180. + theta = abs(alon-alon_sat) +! r_tmp = (2*earth_radius*sin(theta/2.)-earth_radius*(1-cos(alat))*sin(theta/2.))**2 & +! +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(theta/2.))**2 +! r_tmp = sqrt(r_tmp) +! theta_true = 2*asin(r_tmp/earth_radius/2.) +! theta_tmp = atan(earth_radius*sin(theta_true)/(satellite_height+earth_radius*(1-sin(theta_true)))) +! theta_true = (theta_true+theta_tmp)*180./pi + + + !ZENITH, FROM SOLER et al., 1994 (spherical) (up to 1 deg difference with above code) + gam = acos( cos(alat) * cos(theta) ) + r_tmp = (satellite_height+earth_radius)**2 * ( 1.d0 + ( earth_radius / (satellite_height+earth_radius) )**2 - 2.d0 * (earth_radius) / (satellite_height+earth_radius) * cos(gam) ) + r_tmp = sqrt(r_tmp) + theta_true = asin((satellite_height+earth_radius) / r_tmp * sin(gam)) * 180.d0 / pi + + return end subroutine da_get_satzen diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc new file mode 100644 index 0000000000..08f7b4baac --- /dev/null +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -0,0 +1,203 @@ +subroutine da_qc_goesabi(it, i, nchan, ob, iv) + + !--------------------------------------------------------------------------- + ! Purpose: perform quality control for GOES-abi radiance data. + ! + ! + !Modeled after da_qc_goesimg.inc, still need to update for ABI + ! Method: Yang et al., 2017: Impact of assimilating GOES imager + ! clear-sky radiance with a rapid refresh assimilation + ! system for convection-permitting forecast over Mexico. + ! J. Geophys. Res. Atmos., 122, 5472–5490 + !--------------------------------------------------------------------------- + + implicit none + + integer, intent(in) :: it ! outer loop count + integer, intent(in) :: i ! sensor index. + integer, intent(in) :: nchan ! number of channel + type (y_type), intent(in) :: ob ! Observation structure. + type (iv_type), intent(inout) :: iv ! O-B structure. + + + ! local variables + logical :: lmix,lcould_read + real :: satzen + integer :: n,k,isflg,ios,fgat_rad_unit,sensor_id + integer :: scanpos + integer :: ngood(nchan),nrej(nchan),nrej_omb_abs(nchan), & + nrej_omb_std(nchan), & + nrej_clw,nrej_eccloud, num_proc_domain, nrej_mixsurface + + real :: inv_grosscheck + + character(len=30) :: filename + + if (trace_use_dull) call da_trace_entry("da_qc_goesabi.inc") + + ngood(:) = 0 + nrej(:) = 0 + nrej(:) = 0 + nrej_omb_abs(:) = 0 + nrej_omb_std(:) = 0 + nrej_clw = 0 + nrej_eccloud = 0 + nrej_mixsurface = 0 + num_proc_domain = 0 + sensor_id = 22 + + do n= iv%instid(i)%info%n1,iv%instid(i)%info%n2 + + if (iv%instid(i)%info%proc_domain(1,n)) & + num_proc_domain = num_proc_domain + 1 + + + ! 0.0 initialise QC by flags assuming good obs + !--------------------------------------------- + iv%instid(i)%tb_qc(:,n) = qc_good + + ! a. reject all channels over mixture surface type + !------------------------------------------------------ + isflg = iv%instid(i)%isflg(n) + lmix = (isflg==4) .or. (isflg==5) .or. (isflg==6) .or. (isflg==7) + if (lmix) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_mixsurface = nrej_mixsurface + 1 + end if + + if (isflg > 0) then ! if not over water + do k = 1, nchan ! IR window channel only used over water + if ( k .ne. 2 ) then + if (only_sea_rad) iv%instid(i)%tb_qc(k,n) = qc_bad + end if + end do + end if + + ! b. cloud detection + !----------------------------------------------------------- + if (.not.crtm_cloud) then + if (iv%instid(i)%clwp(n) >= 0.2) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_clw = nrej_clw + 1 + end if + +!!! NEED TO REDEFINE THESE FOR GOES-ABI CHANNELS (ichan=1-10 => band=7-16) +! if (iv%instid(i)%landsea_mask(n) == 0 ) then +! if (iv%instid(i)%tb_xb(3,n)-ob%instid(i)%tb(3,n)>3.5) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_eccloud = nrej_eccloud + 1 +! end if +! else +! if (iv%instid(i)%tb_xb(3,n)-ob%instid(i)%tb(3,n)>2.5) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_eccloud = nrej_eccloud + 1 +! end if +! end if + + end if + + ! c. check innovation + !----------------------------------------------------------- + do k = 1, nchan + + ! c.1. check absolute value of innovation + !------------------------------------------------ + if (.not.crtm_cloud) then + inv_grosscheck = 15.0 + if (use_satcv(2)) inv_grosscheck = 100.0 + if (abs(iv%instid(i)%tb_inv(k,n)) > inv_grosscheck) then + iv%instid(i)%tb_qc(k,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_omb_abs(k) = nrej_omb_abs(k) + 1 + end if + end if + + ! c.2. check relative value of innovation + ! and assign of the observation error (standard deviation) + !------------------------------------------------------------------------ + if (use_error_factor_rad) then ! if use error tuning factor + iv%instid(i)%tb_error(k,n) = & + satinfo(i)%error(k)*satinfo(i)%error_factor(k) + else + iv%instid(i)%tb_error(k,n) = satinfo(i)%error(k) + end if + + if (abs(iv%instid(i)%tb_inv(k,n)) > 3.0*iv%instid(i)%tb_error(k,n)) then + iv%instid(i)%tb_qc(k,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_omb_std(k) = nrej_omb_std(k) + 1 + end if + + end do ! chan + + + ! 2. Check iuse from information file (channel selection) + !----------------------------------------------------------- + do k = 1, nchan + if (satinfo(i)%iuse(k) .eq. -1) & + iv%instid(i)%tb_qc(k,n) = qc_bad + end do + + ! 3. Final QC decision + !--------------------------------------------- + do k = 1, nchan + if (iv%instid(i)%tb_qc(k,n) == qc_bad) then ! bad obs + iv%instid(i)%tb_error(k,n) = 500.0 + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej(k) = nrej(k) + 1 + else ! good obs + if (iv%instid(i)%info%proc_domain(1,n)) & + ngood(k) = ngood(k) + 1 + end if + end do ! chan + end do ! end loop pixel + + ! Do inter-processor communication to gather statistics. + call da_proc_sum_int (num_proc_domain) + call da_proc_sum_int (nrej_mixsurface) + call da_proc_sum_int (nrej_clw) + call da_proc_sum_int (nrej_eccloud) + call da_proc_sum_ints (nrej_omb_abs(:)) + call da_proc_sum_ints (nrej_omb_std(:)) + call da_proc_sum_ints (nrej(:)) + call da_proc_sum_ints (ngood(:)) + + if (rootproc) then + if (num_fgat_time > 1) then + write(filename,'(i2.2,a,i2.2)') it,'_qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time + else + write(filename,'(i2.2,a)') it, '_qcstat_'//trim(iv%instid(i)%rttovid_string) + end if + + call da_get_unit(fgat_rad_unit) + open(fgat_rad_unit,file=trim(filename),form='formatted',iostat=ios) + if (ios /= 0) then + write(unit=message(1),fmt='(A,A)') 'error opening the output file ', filename + call da_error(__FILE__,__LINE__,message(1:1)) + end if + + write(fgat_rad_unit, fmt='(/a/)') ' Quality Control Statistics for '//iv%instid(i)%rttovid_string + write(fgat_rad_unit,'(a20,i7)') ' num_proc_domain = ', num_proc_domain + write(fgat_rad_unit,'(a20,i7)') ' nrej_mixsurface = ', nrej_mixsurface + write(fgat_rad_unit,'(a20,i7)') ' nrej_clw = ', nrej_clw + write(fgat_rad_unit,'(a20,i7)') ' nrej_eccloud = ', nrej_eccloud + write(fgat_rad_unit,'(a20)') ' nrej_omb_abs(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_omb_abs(:) + write(fgat_rad_unit,'(a20)') ' nrej_omb_std(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_omb_std(:) + write(fgat_rad_unit,'(a20)') ' nrej(:) = ' + write(fgat_rad_unit,'(10i7)') nrej(:) + write(fgat_rad_unit,'(a20)') ' ngood(:) = ' + write(fgat_rad_unit,'(10i7)') ngood(:) + + close(fgat_rad_unit) + call da_free_unit(fgat_rad_unit) + end if + if (trace_use_dull) call da_trace_exit("da_qc_goesabi.inc") + +end subroutine da_qc_goesabi + diff --git a/var/da/da_radiance/da_qc_rad.inc b/var/da/da_radiance/da_qc_rad.inc index 7867bf2be5..d3c221b06c 100644 --- a/var/da/da_radiance/da_qc_rad.inc +++ b/var/da/da_radiance/da_qc_rad.inc @@ -14,7 +14,7 @@ subroutine da_qc_rad (it, ob, iv) integer :: i, nchan,p,j logical :: amsua, amsub, hirs, msu,airs, hsb, ssmis, mhs, iasi, seviri - logical :: mwts, mwhs, atms, amsr2, imager + logical :: mwts, mwhs, atms, amsr2, imager, abi integer, allocatable :: index(:) integer :: num_tovs_avg @@ -64,6 +64,7 @@ subroutine da_qc_rad (it, ob, iv) seviri = trim(rttov_inst_name(rtminit_sensor(i))) == 'seviri' amsr2 = trim(rttov_inst_name(rtminit_sensor(i))) == 'amsr2' imager = trim(rttov_inst_name(rtminit_sensor(i))) == 'imager' + abi = trim(rttov_inst_name(rtminit_sensor(i))) == 'abi' if (hirs) then ! 1.0 QC for HIRS @@ -98,6 +99,8 @@ subroutine da_qc_rad (it, ob, iv) call da_qc_amsr2(it,i,nchan,ob,iv) else if (imager) then call da_qc_goesimg(it,i,nchan,ob,iv) + else if (abi) then + call da_qc_goesabi(it,i,nchan,ob,iv) else write(unit=message(1),fmt='(A,A)') & "Unrecognized instrument",trim(rttov_inst_name(rtminit_sensor(i))) diff --git a/var/da/da_radiance/da_radiance.f90 b/var/da/da_radiance/da_radiance.f90 index 0bbc532488..96957fd287 100644 --- a/var/da/da_radiance/da_radiance.f90 +++ b/var/da/da_radiance/da_radiance.f90 @@ -58,7 +58,8 @@ module da_radiance use_rad,crtm_cloud, DT_cloud_model, global, use_varbc, freeze_varbc, & airs_warmest_fov, time_slots, interp_option, ids, ide, jds, jde, & ips, ipe, jps, jpe, simulated_rad_ngrid, obs_qc_pointer, use_blacklist_rad, use_satcv, & - use_goesimgobs, pi, earth_radius, satellite_height + use_goesimgobs, use_goesabiobs, pi, earth_radius, satellite_height, & + var4d, var4d_bin #ifdef CRTM use da_crtm, only : da_crtm_init, da_get_innov_vector_crtm @@ -123,6 +124,7 @@ module da_radiance #include "da_read_obs_bufrseviri.inc" #include "da_read_obs_hdf5amsr2.inc" #include "da_read_obs_ncgoesimg.inc" +#include "da_read_obs_ncgoesabi.inc" #include "da_get_satzen.inc" #include "da_allocate_rad_iv.inc" #include "da_initialize_rad_iv.inc" diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index ce6cc79877..73a09ce08b 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -234,6 +234,7 @@ module da_radiance1 #include "da_qc_seviri.inc" #include "da_qc_amsr2.inc" #include "da_qc_goesimg.inc" +#include "da_qc_goesabi.inc" #include "da_write_iv_rad_ascii.inc" #include "da_write_oa_rad_ascii.inc" #include "da_detsurtyp.inc" diff --git a/var/da/da_radiance/da_radiance_init.inc b/var/da/da_radiance/da_radiance_init.inc index 974be59060..4522b0d528 100644 --- a/var/da/da_radiance/da_radiance_init.inc +++ b/var/da/da_radiance/da_radiance_init.inc @@ -134,6 +134,9 @@ subroutine da_radiance_init(iv,ob) else if ( trim( crtm_sensor_name(rtminit_sensor(n))) == 'imgr' ) then nchanl(n) = 4 nscan(n) = 60 + else if ( trim( crtm_sensor_name(rtminit_sensor(n))) == 'abi' ) then + nchanl(n) = 10 + nscan(n) = 22 else write(unit=message(1),fmt='(A)') "Unrecognized instrument: " write(unit=message(2),fmt='(A,I4)') "rtminit_platform = ",rtminit_platform(n) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc new file mode 100644 index 0000000000..7359635a7a --- /dev/null +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -0,0 +1,1739 @@ +subroutine da_read_obs_ncgoesabi (iv, satellite_id) + + implicit none + + type (iv_type),intent (inout) :: iv + integer, intent(in) :: satellite_id ! 16 or 17 + + type(datalink_type), pointer :: head, p, current, prev, p_fgat + type(info_type) :: info + type(model_loc_type) :: loc + integer(i_kind), allocatable :: ptotal(:) + real(r_kind) :: crit + integer(i_kind) :: iout, iobs, i_dummy(1) + logical :: outside, outside_all, iuse, first_chan + logical :: found, head_found + + !! ABI Fixed Grid Variables + integer :: ny, nx + integer :: yoff_fd, xoff_fd + + !! Earth location info + real(r_kind) :: req, rpol, pph, nam +!!! real :: lat_sat, lon_sat ! Assume fixed values in da_get_satzen + real, allocatable :: lat(:,:), lon(:,:), satzen(:,:) + + !! Masks for data reduction + logical, allocatable :: & + earthmask(:,:), & + zenmask(:,:), & + fgatmask(:,:), & + allmask_local(:,:), & + allmask_global(:,:), & + patchmask(:,:), & + domainmask(:,:), & + radmask(:,:), & + thinmask(:,:) + + integer(kind=1), allocatable :: view_choice(:,:,:,:) + logical :: use_view_choice, best_view + + !! Brightness Temperature (K) + real, allocatable :: bt(:,:) + +!!! !! Temporary, only used for data I/O +!!! character(len=100) :: prefix="" +!!! character(len=10) :: nxthin +!!! logical :: print_grid = .false., & +!!! print_view = .false., & +!!! print_bt = .false. + + !! Iterates + integer :: ichan, ifile, iview, ifgat, ipass, ioff, & + jchan, jfile, jview, & + n, i, j, ix, iy + + !! Thinning Variables, need to replace with applicable WRFDA ones + integer, parameter :: xthin=1 + integer, parameter :: ythin=1 + + !! Satellite variables + integer(i_kind),parameter :: nchan = 10 + integer(i_kind),parameter :: nscan = 22 + integer, parameter :: platform_id = 4 ! GOES series + integer, parameter :: sensor_id = 44 ! ABI + integer, parameter :: channel_list(nchan) = (/7,8,9,10,11,12,13,14,15,16/) !List of all available channels + integer, parameter :: nviews=4 + integer(i_kind) :: inst + + character(len=14), parameter :: INST_PREFIX = 'OR_ABI-L1b-Rad' + + + !! File reading variables + character(len=1000) :: fname, fname_short, command + character(len=50) :: list_file, count_file + integer :: file_unit + + type date_type + integer :: yr, mt, dy, hr, mn, sc + end type + + type viewinfo + logical :: select + integer :: nfiles + character(len=1000) :: fpath + character(len=200), allocatable :: filename(:) + integer, allocatable :: filechan(:) + type(date_type), allocatable :: filedate(:) + logical, allocatable :: file_fgat_match(:,:) + real*8, allocatable :: fgat_time_diff(:,:) ! seconds + real*8, allocatable :: min_time_diff(:,:) ! seconds + integer, allocatable :: nfiles_used(:) + integer :: ny, nx, yoff, xoff + real, allocatable :: & + lat(:,:), lon(:,:), satzen(:,:) + logical, allocatable :: & + earthmask(:,:), zenmask(:,:), & + patchmask(:,:), domainmask(:,:) + character(len=2) :: name_short + character(len=10) :: name + end type viewinfo + + type(viewinfo), target, allocatable :: view_att(:) + type(viewinfo), pointer :: this_view + + integer :: first_file, tot_files_used, npass + integer :: ncid, varid + + !! WRFDA channel and satellite_id select + !! These should be inputs to the subroutine or global variables in WRFDA + !Could populate using .info file. Would reduce number of files to read... + integer, dimension(10) :: channel_select = (/7, 8, 9, 10, 11, 12, 13, 14, 15, 16/) + +!!! ! Global WRFDA obs timing info + character(len=19) :: fgat_times_c(num_fgat_time) + real(r_kind) :: fgat_times_r(num_fgat_time) +!!! real(r_kind) :: dt_fgat(2) ! (seconds) + + ! Local Obs date/time variables +!!! real(r_kind) :: j2000, j2000_fgat(num_fgat_time) + real(r_kind) :: obs_time + integer(i_kind) :: yr, mt, dy, hr, mn, sc, jdy + real(r_kind) :: timbdy(2) + + ! Other work variables + real(r_kind) :: dlon_earth,dlat_earth,dlon_earth_deg,dlat_earth_deg + real(r_kind) :: ngoes + integer(i_kind) :: num_goesabi_local, num_goesabi_global, num_goesabi_used, & + num_goesabi_used_tmp, num_goesabi_thinned + integer(i_kind) :: itx, itt + real, allocatable :: in(:), out(:) + + if (trace_use) call da_trace_entry("da_read_obs_ncgoesabi") + +! determine if satellite_id is supported +!----------------------------------------------------- + if(satellite_id .ne. 16 .and. & + satellite_id .ne. 17) then + write(unit=stdout,fmt='(A,I2.2,A)') 'goes satellite ', satellite_id, ' is not supported for abi instrument' + return + endif + +! determine if sensor triplet is in the sensor list +!----------------------------------------------------- + inst = 0 + do ngoes = 1, rtminit_nsensor + if (platform_id == rtminit_platform(ngoes) & + .and. sensor_id == rtminit_sensor(ngoes) & + .and. satellite_id == rtminit_satid(ngoes)) then + inst = ngoes + else + cycle + end if + end do + if (inst == 0) then + write(unit=message(1),fmt='(A,I2,A)') " goes-",satellite_id,"-abi is not in sensor list" + call da_warning(__FILE__,__LINE__, message(1:1)) + return + end if + + allocate(ptotal(0:num_fgat_time)) + ptotal(0:num_fgat_time) = 0 + iobs = 0 ! for thinning, argument is inout + + +! 1.0 Read (grid), parse, and select NC files: identify files for channels, views, times, overlap w/ patch/domain +!---------------------------------------------------------------------------------------------------------- +! 2.0 Read (BT) NC files: grab radiance data and convert to BT (K) +!---------------------------------------------------------------------------------------------------------- +! +! JJG: NEED TO ADD A MORE COMPLETE DESCRIPTION HERE +! + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Initialize ABI L1B reading + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do ifgat=1,num_fgat_time + if (num_fgat_time.eq.1 .or. (ifgat.gt.1 .and. ifgat.lt.num_fgat_time)) then + fgat_times_r(ifgat) = & + (time_slots(ifgat) + time_slots(ifgat-1)) / 2.D0 !minutes + else if (ifgat .eq. 1) then !First time slot is dt/2 (da_get_time_slots) + fgat_times_r(ifgat) = & + time_slots(ifgat-1) !minutes + else !Last time slot is dt/2 (da_get_time_slots) + fgat_times_r(ifgat) = & + time_slots(ifgat) !minutes + end if + + call da_get_cal_time(fgat_times_r(ifgat),yr,mt,dy,hr,mn,sc) + fgat_times_r(ifgat) = fgat_times_r(ifgat) * 60.D0 !seconds + + write(unit=fgat_times_c(ifgat), & + fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & + yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc + + end do + +!!! !! UPDATE THIS FOR VARIABLES AVAILABLE IN WRFDA +!!! !! Establish fgat j2000day for later comparisons +!!! fgat_time = analysis_date(1:19) +!!! read(fgat_time(1:4),fmt='(I4)') yr +!!! read(fgat_time(6:7),fmt='(I2.2)') mt +!!! read(fgat_time(9:10),fmt='(I2.2)') dy +!!! read(fgat_time(12:13),fmt='(I2.2)') hr +!!! read(fgat_time(15:16),fmt='(I2.2)') mn +!!! read(fgat_time(18:19),fmt='(I2.2)') sc +!!! call cal2j2000day(j2000_fgat(1),yr,mt,dy,hr,mn,sc) +! +!!! if ( var4d ) then +!!! dt_fgat(1) = - real(var4d_bin, 8) +!!! dt_fgat(2) = real(var4d_bin, 8) +! +!!! do ifgat = 2, num_fgat_time +!!! if (ifgat .lt. num_fgat_time) then +!!! j2000 = j2000_fgat(ifgat-1) + dt_fgat(2) / 86400.D0 +!!! call j2000day2cal(j2000,yr,mt,dy,hr,mn,sc) +!!! end if +! +!!! write(unit=fgat_times(ifgat), & +!!! fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & +!!! yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc +! +!!! call cal2j2000day(j2000_fgat(ifgat),yr,mt,dy,hr,mn,sc) +!!! end do +!!! else +!!! fgat_time = time_window_min(1:19) +!!! read(fgat_time(1:4),fmt='(I4)') yr +!!! read(fgat_time(6:7),fmt='(I2.2)') mt +!!! read(fgat_time(9:10),fmt='(I2.2)') dy +!!! read(fgat_time(12:13),fmt='(I2.2)') hr +!!! read(fgat_time(15:16),fmt='(I2.2)') mn +!!! read(fgat_time(18:19),fmt='(I2.2)') sc +!!! call cal2j2000day(j2000,yr,mt,dy,hr,mn,sc) +!!! dt_fgat(1) = (j2000 - j2000_fgat(1)) * 86400. * 2. +! +!!! fgat_time = time_window_max(1:19) +!!! read(fgat_time(1:4),fmt='(I4)') yr +!!! read(fgat_time(6:7),fmt='(I2.2)') mt +!!! read(fgat_time(9:10),fmt='(I2.2)') dy +!!! read(fgat_time(12:13),fmt='(I2.2)') hr +!!! read(fgat_time(15:16),fmt='(I2.2)') mn +!!! read(fgat_time(18:19),fmt='(I2.2)') sc +!!! call cal2j2000day(j2000,yr,mt,dy,hr,mn,sc) +!!! dt_fgat(2) = (j2000 - j2000_fgat(2)) * 86400. * 2. +! +!!! end if +!!! write(unit=stdout, fmt='(A)') 'num_fgat, j2000_fgat = ' +!!! write(unit=stdout, fmt='(F18.1)') num_fgat_time, j2000_fgat + + allocate(view_att(nviews)) + view_att(:)%select = .true. ! Need to set this according to namelist entries + view_att(1)%name_short = 'F' + view_att(2)%name_short = 'C' + view_att(3)%name_short = 'M1' + view_att(4)%name_short = 'M2' + + view_att(1)%name = 'Full Disk' + view_att(2)%name = 'CONUS' + view_att(3)%name = 'MESO1' + view_att(4)%name = 'MESO2' + + view_att(1)%fpath = './goes-fd/' + view_att(2)%fpath = './goes-conus/' + view_att(3)%fpath = './goes-meso/' + view_att(4)%fpath = './goes-meso/' + + !! Initialize local obs structures + allocate (head) + nullify (head % next ) + p => head + + num_goesabi_local = 0 + num_goesabi_global = 0 + num_goesabi_used = 0 + num_goesabi_thinned = 0 + + + !! Take 2 passes over the data: + !! + 1st pass: determine which views should be used for each fgat and each channel across observed domain + !! + 2nd pass: read radiance values and convert to BT + + npass = 1 + if (nviews.gt.1 .and. view_att(1)%select) npass = 2 + tot_files_used = 0 + + do ipass = 1, npass + write(unit=stdout,fmt=*) ' ' + write(unit=stdout,fmt=*) ' ' + write(unit=stdout,fmt='(A,I0,A,I2.2,A)') & + 'Starting pass ',ipass,& + ' of GOES-',satellite_id,' data processing' + + !! Loop over the available views for this instrument (ABI) + do iview = 1, nviews + this_view => view_att(iview) + if ( .not.this_view%select ) cycle + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Collect files available for this view + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (ipass .eq. 1) then + write(unit=stdout,fmt='(5A)') 'Searching for GOES ', trim(this_view%name) ,' files in ', trim(this_view%fpath),'...' + + ! Query fpath for files that begin with INST_PREFIX, name, and for this satellite_id + fname = trim(INST_PREFIX)//trim(this_view%name_short) + list_file = 'INST'//trim(this_view%name_short) + count_file = 'num_INST'//trim(this_view%name_short) + + call da_get_unit(file_unit) + + if (rootproc) then + write(command,fmt='(5A,I2.2,2A)')& + "find ",trim(this_view%fpath), & + " -type f -name '",trim(fname), & + "*G",satellite_id, & + "*' -printf '%P\n' > ",trim(list_file) + call execute_command_line (trim(command)) + + write(command,fmt='(4A)') "cat ",trim(list_file)," | wc -l > ",trim(count_file) + call execute_command_line (trim(command)) + + open(unit=file_unit,file=trim(count_file)) + read(file_unit,*) this_view%nfiles + close(file_unit) + i_dummy = this_view%nfiles + end if +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +!!! call wrf_dm_bcast_integer(i_dummy, 1) + call mpi_bcast ( i_dummy, 1, mpi_integer, root, comm, ierr ) + this_view%nfiles = i_dummy(1) +#endif + if (this_view%nfiles .lt. 1) then + if (iview .eq. 1) then + npass = 1 + end if + this_view%select = .false. + cycle + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Allocate/init components for this_view + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + allocate(this_view%filename(this_view%nfiles)) + allocate(this_view%filechan(this_view%nfiles)) + allocate(this_view%filedate(this_view%nfiles)) + allocate(this_view%file_fgat_match(this_view%nfiles,num_fgat_time)) + allocate(this_view%fgat_time_diff(this_view%nfiles,num_fgat_time)) + allocate(this_view%min_time_diff(nchan,num_fgat_time)) + allocate(this_view%nfiles_used(num_fgat_time)) + +!!! this_view%file_fgat_match = .true. + this_view%file_fgat_match = .false. +!!! this_view%fgat_time_diff = max(dt_fgat(1),dt_fgat(2)) + do ifgat=1,num_fgat_time + this_view%fgat_time_diff(:,ifgat) = & + (time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 !seconds + + this_view%min_time_diff(:,ifgat) = & + (time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 / 2.D0 !seconds + end do + +!!! this_view%min_time_diff = max(dt_fgat(1),dt_fgat(2)) / 2.D0 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Determine which of the files will be used based on user-definitions: + !! + fgat window length + !! + channels used + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Read the file names for this view + open(unit=file_unit,file=trim(list_file)) + read(file_unit, fmt='(A)') (this_view%filename(ifile), ifile=1,this_view%nfiles) + close(file_unit) + + call da_free_unit(file_unit) + + do ifile = 1, this_view%nfiles + + ioff = 0 + if (iview.eq.3 .or. iview.eq.4) ioff=1 + + ioff = ioff+19 + fname = trim(this_view%filename(ifile)) + read(fname(1+ioff:2+ioff),fmt='(I2.2)') this_view%filechan(ifile) + +!!! !! The channel could instead be read from band_id in each file, but +!!! !! opening/closing files for all channels is time consuming +!!! ierr=nf_open(trim(this_view%fpath)//trim(fname),nf_nowrite,ncid) +!!! ierr=nf_inq_varid(ncid,'band_id',varid) +!!! ierr=nf_get_var_int(ncid,varid,this_view%filechan(ifile)) +!!! ierr=nf_close(ncid) + + ! Check if channel is selected + if ( .not.any(this_view%filechan(ifile) .eq. channel_select) .or. & + .not.any(this_view%filechan(ifile) .eq. channel_list) ) then +!!! ierr=nf_close(ncid) +!!! this_view%file_fgat_match(ifile,:) = .false. + cycle + end if + + !! Determine central date of this file for obs binning + !obs START time + ioff = ioff + 8 + read(fname(1+ioff:4+ioff),fmt='(I4.4)') yr + read(fname(5+ioff:7+ioff),fmt='(I3.3)') jdy + read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr + read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn + read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc + call jday2cal(jdy, yr, mt, dy) +!!! call cal2j2000day(timbdy(1),yr,mt,dy,hr,mn,sc) + call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(1)) + + !obs END time + ioff = ioff + 16 + read(fname(1+ioff:4+ioff),fmt='(I4.4)') yr + read(fname(5+ioff:7+ioff),fmt='(I3.3)') jdy + read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr + read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn + read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc + call jday2cal(jdy, yr, mt, dy) +!!! call cal2j2000day(timbdy(2),yr,mt,dy,hr,mn,sc) + call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(2)) + +!!! j2000=(timbdy(1) + timbdy(2)) / 2.D0 + obs_time=(timbdy(1) + timbdy(2)) / 2.D0 + obs_time = obs_time + real(sc,8)/60.D0 + +!! The time it takes to read time_bounds from each file is not insignificant. Above method is much faster. +! !! Determine central date of this file for obs binning +!!! ierr=nf_open(trim(this_view%fpath)//trim(fname),nf_nowrite,ncid) +!!! ierr=nf_inq_varid(ncid,'time_bounds',varid) +!!! ierr=nf_get_var_double(ncid,varid,timbdy) +!!! ierr=nf_close(ncid) +!!! j2000=(timbdy(1) + timbdy(2)) / 2.D0 /86400.D0 + + +!!! call j2000day2cal(j2000,yr,mt,dy,hr,mn,sc) + + call da_get_cal_time(obs_time,yr,mt,dy,hr,mn,sc) + obs_time = obs_time * 60.D0 + + this_view%filedate(ifile)%yr = yr + this_view%filedate(ifile)%mt = mt + this_view%filedate(ifile)%dy = dy + this_view%filedate(ifile)%hr = hr + this_view%filedate(ifile)%mn = mn + this_view%filedate(ifile)%sc = sc + +!!! ! Compare this file j2000day to all fgat window j2000day's +!!! do ifgat = 1, num_fgat_time +!!! this_view%fgat_time_diff(ifile,ifgat) = 86400.D0 * (j2000 - j2000_fgat(ifgat)) +! +!!! write(unit=stdout, fmt='(F18.1)') this_view%fgat_time_diff(ifile,ifgat) +! +!!! if ( this_view%fgat_time_diff(ifile,ifgat) .lt. dt_fgat(1)/2. .or. & +!!! this_view%fgat_time_diff(ifile,ifgat) .gt. dt_fgat(2)/2. ) then +! +!!! this_view%file_fgat_match(ifile,ifgat) = .false. +!!! cycle +!!! end if +!!! call get_ichan(this_view%filechan(ifile), channel_list, nchan, ichan) +! +!!! ! Determine minimum time difference between this obs bin and available files for this view +!!! if ( abs(this_view%fgat_time_diff(ifile, ifgat)) .ge. this_view%min_time_diff(ichan, ifgat) ) then +!!! this_view%file_fgat_match(ifile,ifgat) = .false. +!!! exit +!!! else +!!! this_view%min_time_diff(ichan, ifgat) = abs(this_view%fgat_time_diff(ifile, ifgat)) +!!! end if +!!! end do + +!!! Eliminates need for j2000_fgat(ifgat), j2000day2cal, cal2j2000day, uses internal WRFDA timing subroutines + da_get_cal_time +!!! Using julian time precise to seconds due to MESO + + if ( obs_time < time_slots(0) * 60.D0 .or. & + obs_time >= time_slots(num_fgat_time) * 60.D0 ) then + cycle + end if + + do ifgat=1,num_fgat_time + this_view%file_fgat_match(ifile,ifgat) = & + ( obs_time >= time_slots(ifgat-1) * 60.D0 .and. & + obs_time < time_slots(ifgat) * 60.D0 ) + if (this_view%file_fgat_match(ifile,ifgat)) exit + end do + + this_view%fgat_time_diff(ifile,ifgat) = & + abs( obs_time - fgat_times_r(ifgat) ) + + call get_ichan(this_view%filechan(ifile), channel_list, nchan, ichan) + if ( abs(this_view%fgat_time_diff(ifile, ifgat)) .ge. & + this_view%min_time_diff(ichan, ifgat) ) then + this_view%file_fgat_match(ifile,ifgat) = .false. + else + this_view%min_time_diff(ichan, ifgat) = abs(this_view%fgat_time_diff(ifile, ifgat)) + end if + + if (count(this_view%file_fgat_match(ifile,:)) .gt. 1) then + print*, 'WARNING: More than one bin was selected for ',trim(fname) + print*, 'num_bin_per_file = ',count(this_view%file_fgat_match(ifile,:)) + print*, 'obs_time = ',obs_time + print*, 'Ignoring this file for reading.' + this_view%file_fgat_match(ifile,:) = .false. + cycle + end if + end do + end if + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Access netcdf channel/band files across all fgat windows + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + this_view%nfiles_used = 0 + + do ifgat = 1, num_fgat_time + if (count(this_view%file_fgat_match(:, ifgat)) .lt. 1) then + cycle + end if + + write(unit=stdout,fmt='(A,I0,A)') & + 'Processing GOES-',satellite_id,' ABI data for:' + write(unit=stdout,fmt='(2A)') & + ' ',fgat_times_c(ifgat) + +!! if ( ipass .eq. 1 .and. (npass.gt.1 .or. count(this_view%file_fgat_match(:, ifgat)).gt.1) ) then + if ( ipass .eq. 1 .and. count(this_view%file_fgat_match(:, ifgat)).gt.1 ) then + + ! Select a single file for this view, channel, and fgat + do ifile = 1, this_view%nfiles + if ( .not. this_view%file_fgat_match(ifile,ifgat) ) cycle + call get_ichan(this_view%filechan(ifile), channel_list, nchan, ichan) + if ( abs(this_view%fgat_time_diff(ifile, ifgat)) .gt. this_view%min_time_diff(ichan, ifgat) ) then + this_view%file_fgat_match(ifile,ifgat) = .false. + end if + end do + end if + + do ifile = 1, this_view%nfiles + if ( .not. this_view%file_fgat_match(ifile,ifgat) ) cycle + first_file = ifile + exit + end do + + fname_short = trim(this_view%filename(first_file)) + fname = trim(this_view%fpath)//trim(fname_short) + +write(stdout,fmt=*) 'TEST1' + + if ( ipass.eq.1 .and. sum(this_view%nfiles_used(:)).eq.0 ) then + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Get ABI metadata (first pass for FD, CONUS, MESO) + ! Only ny and nx need to be read for all views, but this is a cheap subroutine + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + write(unit=stdout,fmt='(2A)') & + ' Reading metadata for ',trim(this_view%name) + + call get_abil1b_metadata( & + fname, this_view%ny, this_view%nx, req, rpol, pph, nam)! , lat_sat, lon_sat ) + +write(stdout,fmt=*) 'TEST2' +write(stdout,fmt=*) this_view%ny, this_view%nx, req, rpol, pph, nam + + if ( iview.eq.1 .and. ipass.lt.npass ) then + allocate(view_choice(this_view%ny,this_view%nx,nchan,num_fgat_time)) + view_choice = 0 + +write(stdout,fmt=*) size(view_choice) +write(stdout,fmt=*) sizeof(view_choice) + + end if + end if + ny = this_view%ny + nx = this_view%nx +write(stdout,fmt=*) 'TEST3' + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Generate grid if + !! + CONUS or FD and first matching fgat + !! + MESO and any fgat (extent changes in time) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if ( ( any(iview.eq.(/1,2/)) .and. sum(this_view%nfiles_used(:)).eq.0 ) & + .or. any(iview.eq.(/3,4/)) ) then + + if (allocated(lat)) then + deallocate(lat) + deallocate(lon) + deallocate(satzen) + deallocate(earthmask) + deallocate(zenmask) + end if + + !! Allocate spatial information + allocate(lat(ny,nx)) + allocate(lon(ny,nx)) + allocate(satzen(ny,nx)) + allocate(earthmask(ny,nx)) + allocate(zenmask(ny,nx)) + allocate(patchmask(ny,nx)) + allocate(domainmask(ny,nx)) + +write(stdout,fmt=*) 'TEST4' + +write(stdout,fmt=*) sizeof(lat), size(lat) +write(stdout,fmt=*) sizeof(lon), size(lon) +write(stdout,fmt=*) sizeof(satzen), size(satzen) + +write(stdout,fmt=*) 'TEST5' + + if ( ipass.eq.2 .and. iview .eq. 1 ) then + ! Restore FD grid from memory + lat = this_view%lat + lon = this_view%lon + satzen = this_view%satzen + earthmask = this_view%earthmask + zenmask = this_view%zenmask + patchmask = this_view%patchmask + domainmask = this_view%domainmask + + deallocate(this_view%lat) + deallocate(this_view%lon) + deallocate(this_view%satzen) + deallocate(this_view%earthmask) + deallocate(this_view%zenmask) + deallocate(this_view%patchmask) + deallocate(this_view%domainmask) + + this_view%yoff = yoff_fd + this_view%xoff = xoff_fd + else +write(stdout,fmt=*) 'TEST6' + + ! Read grid from file + write(unit=stdout,fmt='(2A)') & + ' Reading grid info for ',trim(this_view%name) +write(stdout,fmt=*) 'TEST7' + + call get_abil1b_grid( fname, ny, nx, & + req, rpol, pph, nam, satellite_id, & + lat, lon, satzen, earthmask, zenmask, & + this_view%yoff, this_view%xoff ) +write(stdout,fmt=*) 'TEST8' + + !! With domain/patch pruning was here, view_choice can be allocated smaller + patchmask = .false. + domainmask = .false. + do ix = 1, nx +if (mod(ix,100).eq.0) write(stdout,fmt=*) 'TEST9', ix + + do iy = 1, ny + if (earthmask(iy,ix)) then + info%lon = lon(iy,ix) ! longitude + info%lat = lat(iy,ix) ! latitude + call da_llxy (info, loc, outside, outside_all) + patchmask(iy,ix) = outside + domainmask(iy,ix) = outside_all + end if + end do + end do + end if +write(stdout,fmt=*) 'TEST10' + + if ( iview.eq.1 ) then + yoff_fd = this_view%yoff + xoff_fd = this_view%xoff + this_view%yoff = 1 + this_view%xoff = 1 + else + this_view%yoff = this_view%yoff - yoff_fd + this_view%xoff = this_view%xoff - xoff_fd + end if +write(stdout,fmt=*) 'TEST11' + +!!!! print*,'yoff = ',this_view%yoff +!!!! print*,'xoff = ',this_view%xoff +!!!!!!! START GRID WRITE +!!! if ( ipass .eq. 1 .and. print_grid .and. iview.eq.1) then +!!! write(prefix,fmt='(3A)') & +!!! 'GRID_VIEW',trim(this_view%name_short),'_' +!!! if (iview .gt. 2) prefix = trim(prefix)// & +!!! fgat_times_c(ifgat)//'_' +! +!!! open(unit=31, & +!!! file=trim(prefix)//'lat.dat', & +!!! status='replace') +!!! open(unit=32, & +!!! file=trim(prefix)//'lon.dat', & +!!! status='replace') +!!! open(unit=33, & +!!! file=trim(prefix)//'satzen.dat', & +!!! status='replace') +! +!!! write(nxthin,fmt='(I0)') nx/xthin+1 +!!! do iy=1, ny, ythin +!!! write(31,fmt='('//trim(nxthin)//'F15.6)') lat (iy, 1:nx:xthin) +!!! write(32,fmt='('//trim(nxthin)//'F15.6)') lon (iy, 1:nx:xthin) +!!! write(33,fmt='('//trim(nxthin)//'F15.6)') satzen (iy, 1:nx:xthin) +!!! end do +!!! close(31) +!!! close(32) +!!! close(33) +!!! end if +!!!!!!! END GRID WRITE + end if + +write(stdout,fmt=*) 'TEST12' + + ! Loop over channels + ! This loop over channels could be parallelized, if needed for time savings + + ChannelLoop: do ichan = 1, nchan + + ifile = 0 + do jfile = 1, this_view%nfiles + if ( .not. this_view%file_fgat_match(jfile,ifgat) ) cycle + call get_ichan(this_view%filechan(jfile), channel_list, nchan, jchan) + if ( ichan .eq. jchan ) then + ifile = jfile + exit + end if + end do + if ( ifile .eq. 0 ) cycle + + this_view%nfiles_used(ifgat) = this_view%nfiles_used(ifgat) + 1 + + use_view_choice = ( sum(view_att(1)%nfiles_used(:)).gt.0 ) + + VIEW_SELECT: & + if ( ipass.lt.npass .and. use_view_choice ) then + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Determine which view has the closest observed + !! time to fgat for this channel + !! Note: this only needs to be done for a single channel, + !! unless individual channel files are missing at fgat. + !! Solution where file view availability differs by channel used here. + !! (only available when FD data present for one of the fgat times) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if ( iview.eq.1 ) then + view_choice(:,:, ichan, ifgat) = 1 + else + best_view = .true. +! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations + do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap + best_view = best_view .and. & + this_view%min_time_diff(ichan, ifgat) .lt. & + view_att(jview)%min_time_diff(ichan, ifgat) + end do + if ( best_view ) & + view_choice(this_view%yoff:ny+this_view%yoff-1, & + this_view%xoff:nx+this_view%xoff-1, & + ichan, ifgat) = iview + end if + +!!!!!!! START VIEW_CHOICE WRITE +!!! if ( this_view%nfiles_used(ifgat).eq.1 .and. print_view .and. iview.eq.nviews) then +!!! write(unit=stdout,fmt='(A)') & +!!! ' printing view_choice' +!!! +!!! write(prefix,fmt='(5A)') & +!!! 'VIEW',trim(this_view%name_short),'_', & +!!! fgat_times_c(ifgat),'_' +!!! +!!! open(unit=30,file=trim(prefix)//& +!!! 'CHOICE.dat',status='replace') +!!! write(nxthin,fmt='(I0)') view_att(1)%nx +!!! +!!! do iy=1, view_att(1)%ny +!!! write(30,fmt='('//trim(nxthin)//'I3)') view_choice (iy, 1:view_att(1)%nx, ichan, ifgat) +!!! end do +!!! +!!! close(30) +!!! end if +!!!!! END VIEW_CHOICE WRITE + else + if (inst == 0) cycle + + fname_short = trim(this_view%filename(ifile)) + fname = trim(this_view%fpath)//trim(fname_short) + + allocate(allmask_local(ny,nx)) + allocate(allmask_global(ny,nx)) + + !!Utilizing these masks to eliminate data: + !! + earthmask + !! + zenmask + !! + fgatmask [only if npass > 1] + !! + model domain mask + !! + patch mask + !! + thinning + + allmask_global = (earthmask .and. zenmask .and. domainmask) + allmask_local = (earthmask .and. zenmask .and. patchmask) + + ! Only use locations where this view is nearest to this fgat time + ! - only available when FD data present for any fgat time + if ( use_view_choice ) then + allocate(fgatmask(ny,nx)) + fgatmask = ( view_choice(this_view%yoff:ny+this_view%yoff-1, & + this_view%xoff:nx+this_view%xoff-1, & + ichan, ifgat) .eq. iview ) + + if ( count(fgatmask) .eq. 0 ) then + deallocate(fgatmask) + deallocate(allmask_local) + deallocate(allmask_global) + cycle + end if + allmask_local = (allmask_local .and. fgatmask) + allmask_global = (allmask_global .and. fgatmask) + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Read radiance and convert to brightness temp. + !! once per permutation of + !! + INST VIEW (FD, CONUS, MESOx2) + !! + fgat + !! + channel/band + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(unit=stdout,fmt='(2A)') & + ' Reading radiances: ',trim(fname_short) + +!!print*,this_view%fgat_time_diff(ifile,ifgat) + + ! Allocate this bt + allocate(bt(ny,nx)) + allocate(radmask(ny,nx)) + +! ! This reads in bt only for the local patch, +! ! reduces read time, but would mess up global count below +! call get_abil1b_bt( fname, ny, nx, allmask_local, & +! bt ) + + ! This reads in bt for whole domain, + ! creates valid plocal check at end of this subroutine, + ! could read only on rootproc and distribute data, + ! or switch to round-robin reading+distribution across channels + call get_abil1b_bt( fname, ny, nx, allmask_global, radmask, & + bt ) + + allmask_local = (allmask_local .and. radmask) + allmask_global = (allmask_global .and. radmask) + deallocate(radmask) + +!!!!!!! START BT WRITE +!!! if ( ipass .eq. npass .and. print_bt ) then +!!! write(prefix,fmt='(A,I2.2,5A)') & +!!! 'BT_C',this_view%filechan(ifile), & +!!! '_VIEW',trim(this_view%name_short),'_', & +!!! fgat_times_c(ifgat),'_' +!!! +!!! open(unit=30,file=trim(prefix)//'bt.dat',& +!!! status='replace') +!!! write(nxthin,fmt='(I0)') nx/xthin+1 +!!! +!!! do iy=1, ny, ythin +!!! write(30,fmt='('//trim(nxthin)//'F15.6)') bt(iy, 1:nx:xthin) +!!! end do +!!! +!!! close(30) +!!! end if +!!!!! END BT WRITE + + !! Write bt, lat, lon, and satzen to datalink structures + + first_chan = (this_view%nfiles_used(ifgat).eq.1) + if (first_chan) then + p_fgat => p + allocate(thinmask(ny,nx)) + thinmask = .false. + + yr = this_view%filedate(ifile)%yr + mt = this_view%filedate(ifile)%mt + dy = this_view%filedate(ifile)%dy + hr = this_view%filedate(ifile)%hr + mn = this_view%filedate(ifile)%mn + sc = this_view%filedate(ifile)%sc + else + p => p_fgat + end if + + do iy = 1, ny + do ix = 1, nx + + if (.not. allmask_global(iy,ix)) cycle + + if (first_chan) then + info%lon = lon(iy,ix) ! longitude + info%lat = lat(iy,ix) ! latitude + call da_llxy (info, loc, outside) + + ptotal(ifgat) = ptotal(ifgat) + 1 + num_goesabi_global = num_goesabi_global + 1 + end if + + if (.not. allmask_local(iy,ix)) cycle + + if (first_chan) & + num_goesabi_local = num_goesabi_local + 1 + + if (thinning) then + if (first_chan) then + dlat_earth = info%lat + dlon_earth = info%lon + if (dlon_earth=r360) dlon_earth = dlon_earth-r360 + dlat_earth = dlat_earth*deg2rad + dlon_earth = dlon_earth*deg2rad + crit = 1. + call map2grids(inst,ifgat,dlat_earth,dlon_earth,crit,iobs,itx,1,itt,iout,iuse) + if (.not. iuse) then + num_goesabi_thinned=num_goesabi_thinned+1 + thinmask(iy,ix) = .true. + cycle + end if + else + if (thinmask(iy,ix)) cycle + end if + end if + + if (first_chan) then + num_goesabi_used = num_goesabi_used + 1 + + write(unit=info%date_char, & + fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & + yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc + info%elv = 0.0 !aquaspot%selv + allocate ( p % tb_inv (1:nchan) ) + + p%info = info + p%loc = loc + p%landsea_mask = 1 ! ??? + if (use_view_choice) then + p%scanpos = & + (iy + this_view%yoff-1 - 1) * (nscan+1) / view_att(1)%ny + ! ??? "scan" position (IS THIS CORRECT?) + else + p%scanpos = & + (iy + this_view%yoff-1 - 1) * (nscan+1) / 5423 + ! ??? "scan" position (IS THIS CORRECT?) + end if + + p%satzen = satzen(iy,ix) + p%solzen = 0.0 + p%sensor_index = inst + p%ifgat = ifgat + end if + + ! Transfer BT from all files + p%tb_inv(ichan) = bt(iy,ix) + + if (first_chan) & + allocate (p%next) ! add next data + + p => p%next + + if (first_chan) & + nullify (p%next) + end do + end do + + deallocate(bt) + deallocate(allmask_local) + deallocate(allmask_global) + + if ( use_view_choice ) & + deallocate(fgatmask) + + end if VIEW_SELECT + + end do ChannelLoop + + if (this_view%nfiles_used(ifgat).ge.1) & + deallocate(thinmask) + + end do ! end fgat loop + + if (sum(this_view%nfiles_used) .gt. 0) then + if (iview.eq.1) then + ! Store FD grid in memory + if(ipass.eq.1) then + allocate(this_view%lat(this_view%ny,this_view%nx)) + allocate(this_view%lon(this_view%ny,this_view%nx)) + allocate(this_view%satzen(this_view%ny,this_view%nx)) + allocate(this_view%earthmask(this_view%ny,this_view%nx)) + allocate(this_view%zenmask(this_view%ny,this_view%nx)) + allocate(this_view%patchmask(this_view%ny,this_view%nx)) + allocate(this_view%domainmask(this_view%ny,this_view%nx)) + + this_view%lat = lat + this_view%lon = lon + this_view%satzen = satzen + this_view%earthmask = earthmask + this_view%zenmask = zenmask + this_view%patchmask = patchmask + this_view%domainmask = domainmask + end if + end if + + ! Deallocate static data + deallocate(lat) + deallocate(lon) + deallocate(satzen) + deallocate(earthmask) + deallocate(zenmask) + end if + + tot_files_used = tot_files_used + sum(view_att(iview)%nfiles_used) + + end do ! end view loop + + if (tot_files_used .lt. 1) then + write(unit=message(1),fmt='(A,I2,2A)') "No L1B data found for GOES-",satellite_id," using prefix ",INST_PREFIX + call da_warning(__FILE__,__LINE__, message(1:1)) + return + end if + end do ! end pass loop + + if (allocated(view_choice)) deallocate(view_choice) + + do iview = 1, nviews + if ( .not.view_att(iview)%select ) cycle + deallocate(view_att(iview)%filename) + deallocate(view_att(iview)%filechan) + deallocate(view_att(iview)%filedate) + deallocate(view_att(iview)%file_fgat_match) + deallocate(view_att(iview)%fgat_time_diff) + deallocate(view_att(iview)%min_time_diff) + deallocate(view_att(iview)%nfiles_used) + end do + deallocate(view_att) + +!------------------------------------------------------ + ! NOTE: Remainder of this subroutine copied from da_read_obs_ncgoesimg.inc + + if (thinning .and. num_goesabi_global > 0 ) then +#ifdef DM_PARALLEL + + ! Get minimum crit and associated processor index. + j = 0 + do ifgat = 1, num_fgat_time + j = j + thinning_grid(inst,ifgat)%itxmax + end do + + + allocate ( in (j) ) + allocate ( out (j) ) + j = 0 + do ifgat = 1, num_fgat_time + do i = 1, thinning_grid(inst,ifgat)%itxmax + j = j + 1 + in(j) = thinning_grid(inst,ifgat)%score_crit(i) + end do + end do + + call mpi_reduce(in, out, j, true_mpi_real, mpi_min, root, comm, ierr) + + call wrf_dm_bcast_real (out, j) + + j = 0 + do ifgat = 1, num_fgat_time + do i = 1, thinning_grid(inst,ifgat)%itxmax + j = j + 1 + if ( ABS(out(j)-thinning_grid(inst,ifgat)%score_crit(i)) > 1.0D-10 ) thinning_grid(inst,ifgat)%ibest_obs(i) = 0 + end do + end do + deallocate( in ) + deallocate( out ) + +#endif + ! Delete the nodes which being thinning out + p => head + prev => head + head_found = .false. + num_goesabi_used_tmp = num_goesabi_used + + do j = 1, num_goesabi_used_tmp + n = p%sensor_index + ifgat = p%ifgat + found = .false. + + do i = 1, thinning_grid(n,ifgat)%itxmax + if ( thinning_grid(n,ifgat)%ibest_obs(i) == j .and. thinning_grid(n,ifgat)%score_crit(i) < 9.99e6_r_kind ) then + found = .true. + exit + end if + end do + + ! free current data + if ( .not. found ) then + current => p + p => p%next + if ( head_found ) then + prev%next => p + else + head => p + prev => p + end if + deallocate ( current % tb_inv ) + ! deallocate ( current % cloud_flag ) + deallocate ( current ) + num_goesabi_thinned = num_goesabi_thinned + 1 + num_goesabi_used = num_goesabi_used - 1 + continue + end if + + if ( found .and. head_found ) then + prev => p + p => p%next + continue + end if + if ( found .and. .not. head_found ) then + head_found = .true. + head => p + prev => p + p => p%next + end if + + end do + + end if ! End of thinning +!stop + iv%total_rad_pixel = iv%total_rad_pixel + num_goesabi_used + iv%total_rad_channel = iv%total_rad_channel + num_goesabi_used*nchan + + iv%info(radiance)%nlocal = iv%info(radiance)%nlocal + num_goesabi_used + iv%info(radiance)%ntotal = iv%info(radiance)%ntotal + num_goesabi_global + + do i = 1, num_fgat_time + ptotal(i) = ptotal(i) + ptotal(i-1) + iv%info(radiance)%ptotal(i) = iv%info(radiance)%ptotal(i) + ptotal(i) + end do + if ( iv%info(radiance)%ptotal(num_fgat_time) /= iv%info(radiance)%ntotal ) then + write(unit=message(1),fmt='(A,I10,A,I10)') & + "Number of ntotal:",iv%info(radiance)%ntotal," is different from the sum of ptotal:", iv%info(radiance)%ptotal(num_fgat_time) + call da_warning(__FILE__,__LINE__,message(1:1)) + endif + + write(unit=stdout,fmt='(a)') 'num_goesabi_global, num_goesabi_local, num_goesabi_used, num_goesabi_thinned' + write(unit=stdout,fmt=*) num_goesabi_global, num_goesabi_local, num_goesabi_used, num_goesabi_thinned + + + ! 5.0 allocate innovation radiance structure + !---------------------------------------------------------------- + + + if (num_goesabi_used > 0) then + iv%instid(inst)%num_rad = num_goesabi_used + iv%instid(inst)%info%nlocal = num_goesabi_used + write(unit=stdout,FMT='(a,i3,2x,a,3x,i10)') & + 'Allocating space for radiance innov structure', & + inst, iv%instid(inst)%rttovid_string, iv%instid(inst)%num_rad + call da_allocate_rad_iv (inst, nchan, iv) + end if + + ! 6.0 assign sequential structure to innovation structure + !------------------------------------------------------------- + p => head + do n = 1, num_goesabi_used + i = p%sensor_index + call da_initialize_rad_iv (i, n, iv, p) + current => p + p => p%next + + ! free current data + deallocate ( current % tb_inv ) +!!! deallocate ( current % cloud_flag ) + deallocate ( current ) + end do + deallocate ( p ) + deallocate (ptotal) + +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif + + if (trace_use) call da_trace_exit("da_read_obs_ncgoesimg") + +end subroutine da_read_obs_ncgoesabi + + +subroutine get_ichan(channel, channel_list, nchan, ichan) !result(ichan) + + implicit none + + integer, intent(in) :: channel, nchan + integer, intent(in) :: channel_list(nchan) + integer, intent(out) :: ichan + integer :: i + + ichan = 0 + do i = 1, nchan + if (channel .eq. channel_list(i)) then + ichan = i + exit + end if + end do + +end subroutine get_ichan + + + +subroutine get_abil1b_metadata( filename, & + ydim, xdim, req, rpol, pph, nam) !, lat_sat, lon_sat ) + + implicit none + + character(*), intent(in) :: filename + + integer, intent(out) :: ydim, xdim + real(r_kind), intent(out) :: req, rpol, pph, nam +!!! real, intent(out) :: lat_sat, lon_sat + + integer :: ierr, ncid, varid, dimid + real(r_kind), parameter :: pi=3.1415926535898D0 +write(stdout,fmt=*) 'TEST13' + + ierr=nf_open(trim(filename),nf_nowrite,ncid) + call handle_err('Error opening file',ierr) +write(stdout,fmt=*) 'TEST14' + + !! Determine ABI satellite parameters (optional outputs) + ierr=nf_inq_dimid(ncid,'y',dimid) + ierr=nf_inq_dimlen(ncid,dimid,ydim) + ierr=nf_inq_dimid(ncid,'x',dimid) + ierr=nf_inq_dimlen(ncid,dimid,xdim) +write(stdout,fmt=*) 'TEST15' + + ierr=nf_inq_varid(ncid,'goes_imager_projection',varid) + ierr=nf_get_att_double(ncid,varid,'semi_major_axis',req) + ierr=nf_get_att_double(ncid,varid,'semi_minor_axis',rpol) + ierr=nf_get_att_double(ncid,varid,'perspective_point_height',pph) + ierr=nf_get_att_double(ncid,varid,'longitude_of_projection_origin',nam) + nam=nam*pi/180 +write(stdout,fmt=*) 'TEST16' + +!!! ierr=nf_inq_varid(ncid,'nominal_satellite_subpoint_lat',varid) +!!! ierr=nf_get_var_real(ncid,varid,lat_sat) +!!! ierr=nf_inq_varid(ncid,'nominal_satellite_subpoint_lon',varid) +!!! ierr=nf_get_var_real(ncid,varid,lon_sat) + +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif +write(stdout,fmt=*) 'TEST17' + + ierr=nf_close(ncid) + call handle_err('Error closing file',ierr) +write(stdout,fmt=*) 'TEST18' + + +end subroutine get_abil1b_metadata + +subroutine get_abil1b_grid( filename, ydim, xdim, req, rpol, pph, nam, satellite_id, & + lat, lon, satzen, earthmask, zenmask, & + yoff, xoff ) + + implicit none + + character(*), intent(in) :: filename + integer, intent(in) :: ydim, xdim, satellite_id + real(r_kind), intent(in) :: req, rpol, pph, nam +!!! real, intent(in) :: lon_sat + + real, intent(out) :: lat(ydim,xdim), lon(ydim,xdim), satzen(ydim,xdim) + logical, intent(out) :: earthmask(ydim, xdim), zenmask(ydim, xdim) + integer, intent(out) :: yoff, xoff + + real :: yy(ydim), xx(xdim) + integer :: ierr, ncid, varid + integer :: iy, ix + real :: slp, itp + real(r_kind) :: hh + + real :: alat, alon ! , alon_sat + real :: theta, theta1, theta2, r1 + + real, parameter :: rre=6371.004*1e3 + real(r_kind), parameter :: pi=3.1415926535898D0 + real, parameter :: satzen_limit=75.0 + real, parameter :: fillv=-999.000 +write(stdout,fmt=*) 'TEST19' + + ierr=nf_open(trim(filename),nf_nowrite,ncid) + call handle_err('Error opening file',ierr) +write(stdout,fmt=*) 'TEST20' + + ierr=nf_inq_varid(ncid,'y',varid) +write(stdout,fmt=*) 'TEST21' + + ierr=nf_get_var_real(ncid,varid,yy) +write(stdout,fmt=*) 'TEST22' + + ierr=nf_get_att_real(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_real(ncid,varid,'add_offset',itp) + yy = yy*slp+itp + yoff = floor(itp/slp) +write(stdout,fmt=*) 'TEST23' + + ierr=nf_inq_varid(ncid,'x',varid) +write(stdout,fmt=*) 'TEST24' + + ierr=nf_get_var_real(ncid,varid,xx) +write(stdout,fmt=*) 'TEST25' + + ierr=nf_get_att_real(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_real(ncid,varid,'add_offset',itp) + xx = xx*slp+itp + xoff = floor(itp/slp) + +write(stdout,fmt=*) 'TEST26' + + earthmask=.false. +write(stdout,fmt=*) 'TEST27' + + zenmask=.false. +write(stdout,fmt=*) 'TEST28' + +!!! alon_sat=lon_sat*pi/180.D0 + + hh=pph+req +write(stdout,fmt=*) 'TEST29' + +write(stdout,fmt=*) hh,pph,req,rpol,nam,slp,itp,xoff,yoff +write(stdout,fmt=*) 'TEST30' + + lat = fillv +write(stdout,fmt=*) 'TEST31' + + lon = fillv +write(stdout,fmt=*) 'TEST32' + + satzen = fillv +write(stdout,fmt=*) 'TEST33' + do ix=1,xdim +if (mod(ix,100).eq.0) write(stdout,fmt=*) 'TEST34', ix + + do iy=1,ydim + call get_abil1b_latlon(yy(iy),xx(ix),req,rpol,hh,nam,lat(iy,ix),lon(iy,ix)) + + if (isnan(lat(iy,ix)) .OR. isnan(lon(iy,ix))) then + lat(iy,ix) = fillv + lon(iy,ix) = fillv + cycle + end if + + call da_get_satzen(lat(iy,ix),lon(iy,ix),satellite_id,satzen(iy,ix)) + + if (isnan(satzen(iy,ix))) then + lat(iy,ix) = fillv + lon(iy,ix) = fillv + satzen(iy,ix) = fillv + cycle + end if + earthmask(iy,ix)=.true. + + if (satzen(iy,ix).gt.satzen_limit) then + cycle + end if + zenmask(iy,ix)=.true. + end do + end do + +write(stdout,fmt=*) 'TEST35' + +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif +write(stdout,fmt=*) 'TEST36' + + ierr=nf_close(ncid) + call handle_err('Error closing file',ierr) + +write(stdout,fmt=*) 'TEST37' + +end subroutine get_abil1b_grid + +subroutine get_abil1b_bt( filename, ydim, xdim, allmask, radmask, & + bt ) + implicit none + + character(*), intent(in) :: filename + integer, intent(in) :: ydim, xdim + logical, intent(in) :: allmask(ydim, xdim) + logical, intent(out) :: radmask(ydim, xdim) + real, intent(out) :: bt(ydim, xdim) + + real :: rad(ydim, xdim) + integer(kind=1) :: DQF(ydim, xdim) + integer :: ierr, ncid, varid + integer :: iy, ix + integer :: ystart, yend, xstart, xend, nykeep, nxkeep + real :: slp, itp + real :: bc1, bc2, fk1, fk2 + real, parameter :: fillv=-999.000 + + bt = fillv + radmask = .false. +! if (.true.) then + !! Attempt to save rad reading time by selecting a subset of netcdf var + ystart = ydim + yend = 1 + do iy = 1, ydim + if ( any(allmask(iy,:)) ) then + ystart = iy + exit + end if + end do + do iy = ydim, 1, -1 + if ( any(allmask(iy,:)) ) then + yend = iy + exit + end if + end do + + xstart = xdim + xend = 1 + do ix = 1, xdim + if ( any(allmask(:,ix)) ) then + xstart = ix + exit + end if + end do + do ix = xdim, 1, -1 + if ( any(allmask(:,ix)) ) then + xend = ix + exit + end if + end do + nykeep = yend - ystart + 1 + nxkeep = xend - xstart + 1 + + if (nykeep.gt.0 .and. nxkeep.gt.0) then + ierr=nf_open(trim(filename),nf_nowrite,ncid) + call handle_err('Error opening file',ierr) + + ierr=nf_inq_varid(ncid,'Rad',varid) + ierr=nf_get_vara_real(ncid,varid,(/ystart,xstart/),(/nykeep,nxkeep/), & + rad(ystart:yend,xstart:xend) ) + + ierr=nf_inq_varid(ncid,'DQF',varid) + ierr=nf_get_vara_int(ncid,varid,(/ystart,xstart/),(/nykeep,nxkeep/), & + DQF(ystart:yend,xstart:xend) ) + else + return + end if +! else +! ystart = 1 +! yend = ydim +! xstart = 1 +! xend = xdim +! +! ierr=nf_open(trim(filename),nf_nowrite,ncid) +! ierr=nf_inq_varid(ncid,'Rad',varid) +! +! ierr=nf_get_var_real(ncid,varid,rad) +! +! ierr=nf_inq_varid(ncid,'DQF',varid) +! ierr=nf_get_var_real(ncid,varid,DQF) +! end if + + ierr=nf_get_att_real(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_real(ncid,varid,'add_offset',itp) + rad=rad*slp+itp + + ierr=nf_inq_varid(ncid,'planck_bc1',varid) + ierr=nf_get_var_real(ncid,varid,bc1) + ierr=nf_inq_varid(ncid,'planck_bc2',varid) + ierr=nf_get_var_real(ncid,varid,bc2) + ierr=nf_inq_varid(ncid,'planck_fk1',varid) + ierr=nf_get_var_real(ncid,varid,fk1) + ierr=nf_inq_varid(ncid,'planck_fk2',varid) + ierr=nf_get_var_real(ncid,varid,fk2) + + do ix=xstart, xend + do iy=ystart, yend + if ( allmask(iy,ix) ) then + if ( rad(iy,ix).ge.0.0 .and. any(DQF(iy,ix).eq.(/0,1/)) ) then + bt(iy,ix)=(fk2/(alog((fk1/rad(iy,ix))+1.))-bc1)/bc2 + radmask(iy,ix) = .true. + end if + end if + end do + end do + +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif + + ierr=nf_close(ncid) + call handle_err('Error closing file',ierr) + + +end subroutine get_abil1b_bt + + +subroutine get_abil1b_latlon(yy,xx,req,rpol,hh,nam,lat,lon) +implicit none + real::yy,xx,lat,lon,lat1,lon1 + real::aa,bb,cc,rs,sx,sy,sz + real*8::req,rpol,hh,nam + real*8,parameter::pi=3.1415926535898D0 + + aa=sin(xx)**2+cos(xx)**2*(cos(yy)**2+req**2/rpol**2*sin(yy)**2) + bb=-2.D0*hh*cos(xx)*cos(yy) + cc=hh**2-req**2 + rs=(-bb-sqrt(bb**2-4.D0*aa*cc))/(2.D0*aa) + sx=rs*cos(xx)*cos(yy) + sy=-rs*sin(xx) + sz=rs*cos(xx)*sin(yy) + + lat1=atan(req**2/rpol**2*sz/sqrt((hh-sx)**2+sy**2)) + lon1=nam-atan(sy/(hh-sx)) + + lat=lat1*180.D0/pi + lon=lon1*180.D0/pi + +! print*,hh,rpol,hh +! print*,aa,bb,cc,rs +! print*,aa,bb,cc,rs,sx,sy,sz +! print*,'aaa',lat,lon +! pause +end subroutine get_abil1b_latlon + + +!subroutine j2000day2cal(j2000,yr,mt,dy,hr,mn,sc) +! ! Converts J2000 epoch day to Gregorian calender date +! ! source: David G. Simpson, NASA Goddard, Accessed April 2018 +! ! https://caps.gsfc.nasa.gov/simpson/software.html +! +! implicit none +! +! real(r_kind), intent(in) :: j2000 +! integer, intent(out) :: yr,mt,dy,hr,mn,sc +! +! real(r_kind) :: ju, j0, F +! integer :: yr0, sc0 +! INTEGER :: A, B, C, D, E, Z, ALPHA ! intermediate variables +! real(r_kind) :: dd +! real(r_kind), parameter :: jd_j2000=2451545.0 +! +! !! First convert J2000 to Julian date +! ju=j2000+jd_j2000 +! +! ju = ju + 0.5D0 +! Z = INT(ju) +! F = ju - Z +! +! !! Gregorian date test (can probably assume this is a Gregorian date) +! IF (Z .LT. 2299161) THEN +! A = Z +! ELSE +! ALPHA = INT((Z-1867216.25D0)/36524.25D0) +! A = Z + 1 + ALPHA - ALPHA/4 +! END IF +! +! B = A + 1524 +! C = INT((B-122.1D0)/365.25D0) +! D = INT(365.25D0*C) +! E = INT((B-D)/30.6001D0) +! +! IF (E .LT. 14) THEN +! mt = E - 1 +! ELSE +! mt = E - 13 +! END IF +! +! IF (mt .GT. 2) THEN +! yr = C - 4716 +! ELSE +! yr = C - 4715 +! END IF +! +! dd = B - D - INT(30.6001D0*E) + F +! +! dy = floor(dd) +! +! !! Remainder for hr, mn, sc. +! dd = dd - real(dy,8) +! +! sc0 = nint(dd*86400.) +! hr = sc0 / 3600 +! sc0 = sc0 - hr*3600 +! mn = sc0 / 60 +! sc = sc0 - mn*60 +! +!end subroutine j2000day2cal +! +!subroutine cal2j2000day(j2000,yr,mt,dy,hr,mn,sc) +! ! Converts Gregorian calender date to J2000 epoch day +! ! source: David G. Simpson, NASA Goddard, Accessed April 2018 +! ! https://caps.gsfc.nasa.gov/simpson/software.html +! ! Alternative: http://aa.usno.navy.mil/faq/docs/JD_Formula.php +! +! implicit none +! +! real(r_kind), intent(out) :: j2000 +! integer, intent(inout) :: yr,mt,dy,hr,mn,sc +! +! real(r_kind) :: ju +! INTEGER :: A, B +! real(r_kind), parameter :: jd_j2000=2451545.0 +! +! +! IF (mt .LE. 2) THEN +! yr = yr - 1 +! mt = mt + 12 +! END IF +! +! !! Gregorian date test (assuming this is a Gregorian date) +!! IF (GREGORIAN_FLAG) THEN ! Gregorian calendar +! A = yr/100 +! B = 2 - A + A/4 +!! ELSE ! Julian calendar +!! B = 0 +!! END IF +! +! ju = real( INT(365.25D0*(yr+4716)) & +! + INT(30.6001D0*(mt+1)) + B + dy,8) & +! - 1524.5D0 +! +! ju = ju + (real(hr,8) & +! + ( real(mn,8) & +! + real(sc,8) / 60.0) / 60.0 ) / 24.0 +! +! j2000 = ju-jd_j2000 +! +!end subroutine cal2j2000day + +subroutine jday2cal(jdy, yr, mt, dy) + + implicit none + + integer, intent(in) :: jdy, yr + integer, intent(out) :: mt, dy + + integer :: d_in_m(12) = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/) + integer :: imonth, tot_days + + + if ( mod(yr,4).eq.0 .and. .not.(mod(yr,100).eq.0 .and. .not.mod(yr,400).eq.0) ) d_in_m(2) = 29 + + tot_days = 0 + do imonth = 1, 12 + tot_days = tot_days + d_in_m(imonth) + if (tot_days .ge. jdy) then + mt = imonth + dy = jdy - ( tot_days - d_in_m(imonth) ) + exit + end if + end do + +end subroutine jday2cal + +subroutine da_get_cal_time(jmod,yr,mt,dy,hr,mn,sc) + ! Converts modified Julian time (in minutes) to Gregorian calender date + ! Modified from this code: David G. Simpson, NASA Goddard, Accessed April 2018 + ! https://caps.gsfc.nasa.gov/simpson/software.html + + implicit none + + real(r_kind), intent(in) :: jmod + integer, intent(out) :: yr,mt,dy,hr,mn + integer, intent(out), optional :: sc + + real(r_kind) :: ju, j0, F + integer :: yr0, sc0 + INTEGER :: A, B, C, D, E, Z, ALPHA ! intermediate variables + real(r_kind) :: dd + + ! J2000 Reference time: 2000 Jan 01 00:12:00 + real(r_kind), parameter :: jd_j2000 = 2451545.0 + + ! This MJD Reference time: 1978 Jan 01 00:00:00 (see da_get_julian_time) + real(r_kind), parameter :: jd_jmod = jd_j2000 - 8035.5 + + ! Convert to days + ju = jmod / 1440.D0 + + !! Convert reference MJD to actual Julian time + ju = ju+jd_jmod + ju = ju + 0.5D0 + Z = INT(ju) + F = ju - Z + + !! Gregorian date test (can probably assume this is a Gregorian date) + IF (Z .LT. 2299161) THEN + A = Z + ELSE + ALPHA = INT((Z-1867216.25D0)/36524.25D0) + A = Z + 1 + ALPHA - ALPHA/4 + END IF + + B = A + 1524 + C = INT((B-122.1D0)/365.25D0) + D = INT(365.25D0*C) + E = INT((B-D)/30.6001D0) + + IF (E .LT. 14) THEN + mt = E - 1 + ELSE + mt = E - 13 + END IF + + IF (mt .GT. 2) THEN + yr = C - 4716 + ELSE + yr = C - 4715 + END IF + + dd = B - D - INT(30.6001D0*E) + F + + dy = floor(dd) + + !! Remainder for hr, mn, sc. + dd = dd - real(dy,8) + + sc0 = nint(dd*86400.) + hr = sc0 / 3600 + sc0 = sc0 - hr*3600 + mn = sc0 / 60 + if (present(sc)) sc = sc0 - mn*60 + +end subroutine da_get_cal_time + +subroutine handle_err(rmarker,nf_status) + + implicit none + + integer, intent(in) :: nf_status + character*(*), intent(in) :: rmarker + if (nf_status .ne. nf_noerr) then + write(*,*) 'NetCDF error : ',rmarker + write(*,*) ' ',nf_strerror(nf_status) + stop + endif +end subroutine handle_err + diff --git a/var/da/da_radiance/da_read_obs_ncgoesimg.inc b/var/da/da_radiance/da_read_obs_ncgoesimg.inc index d5c7fa8d2e..05745c641e 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesimg.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesimg.inc @@ -134,7 +134,7 @@ subroutine da_read_obs_ncgoesimg (iv,infile) elseif(infile(6:7)=='15') then satellite_id = 15 else - write(*,*) 'goes satellite ', satellite_id, ' is not supported' + write(*,*) 'goes satellite ', satellite_id, ' is not supported for imager instrument' return endif diff --git a/var/da/da_radiance/da_setup_radiance_structures.inc b/var/da/da_radiance/da_setup_radiance_structures.inc index e74a953367..19f417eaa8 100644 --- a/var/da/da_radiance/da_setup_radiance_structures.inc +++ b/var/da/da_radiance/da_setup_radiance_structures.inc @@ -11,6 +11,7 @@ subroutine da_setup_radiance_structures( grid, ob, iv ) type (iv_type), intent(inout) :: iv ! O-B structure. character(len=200) :: filename + character(len=200) :: fpath(4) integer :: i, j, n, ios, ifgat logical :: lprinttovs @@ -219,6 +220,14 @@ subroutine da_setup_radiance_structures( grid, ob, iv ) !end if !write(unit=stdout,fmt='(a)') 'Finish reading goesimg data' end if + if (use_goesabiobs) then + write(unit=stdout,fmt='(a)') 'Reading netcdf goes ABI radiance data' + + call da_read_obs_ncgoesabi(iv, 16) + +! call da_read_obs_ncgoesabi(iv, 17) + end if + end if if ( use_filtered_rad ) then diff --git a/var/da/da_setup_structures/da_setup_obs_structures.inc b/var/da/da_setup_structures/da_setup_obs_structures.inc index 24fdeb3810..6fafe94a56 100644 --- a/var/da/da_setup_structures/da_setup_obs_structures.inc +++ b/var/da/da_setup_structures/da_setup_obs_structures.inc @@ -91,7 +91,8 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) use_hsbobs .OR. use_kma1dvar .OR. use_filtered_rad .OR. & use_ssmisobs .OR. use_hirs4obs .OR. use_mhsobs .OR. use_pseudo_rad .OR. & use_mwtsobs .OR. use_mwhsobs .OR. use_atmsobs .OR. use_simulated_rad .OR. & - use_iasiobs .OR. use_seviriobs .OR. use_amsr2obs .OR. use_goesimgobs) then + use_iasiobs .OR. use_seviriobs .OR. use_amsr2obs .OR. use_goesimgobs .OR. & + use_goesabiobs) then use_rad = .true. else use_rad = .false. @@ -281,6 +282,12 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) if ( use_amsr2obs ) then call da_message((/'Using AMSR2 radiance input in HDF5 format'/)) end if + if ( use_goesimgobs ) then + call da_message((/'Using GOES IMAGER radiance input in netcdf format'/)) + end if + if ( use_goesabiobs ) then + call da_message((/'Using GOES ABI radiance input in netcdf format'/)) + end if call da_setup_radiance_structures(grid, ob, iv) #else call da_error(__FILE__,__LINE__,(/"options to use radiance data are turned on in wrfvar4 namelist, the code needs to be compiled with CRTM or RTTOV library"/)) diff --git a/var/da/da_setup_structures/da_setup_structures.f90 b/var/da/da_setup_structures/da_setup_structures.f90 index 435416744e..a38d099c99 100644 --- a/var/da/da_setup_structures/da_setup_structures.f90 +++ b/var/da/da_setup_structures/da_setup_structures.f90 @@ -66,7 +66,7 @@ module da_setup_structures chi_u_t_factor, chi_u_ps_factor,chi_u_rh_factor, t_u_rh_factor, ps_u_rh_factor, & interpolate_stats, be_eta, thin_rainobs, fgat_rain_flags, use_iasiobs, & use_seviriobs, jds_int, jde_int, anal_type_hybrid_dual_res, use_amsr2obs, nrange, use_4denvar, & - use_goesimgobs + use_goesimgobs, use_goesabiobs use da_control, only: rden_bin, use_lsac use da_control, only: use_cv_w use da_control, only: pseudo_tpw, pseudo_ztd, pseudo_ref, pseudo_uvtpq, pseudo_elv, anal_type_qcobs diff --git a/var/da/da_tools/da_get_julian_time.inc b/var/da/da_tools/da_get_julian_time.inc index 6d718e831d..8de14fead1 100644 --- a/var/da/da_tools/da_get_julian_time.inc +++ b/var/da/da_tools/da_get_julian_time.inc @@ -2,6 +2,7 @@ subroutine da_get_julian_time(year,month,day,hour,minute,gstime) !------------------------------------------------------------------------------ ! Purpose: Calculate Julian time from year/month/day/hour/minute. + ! Reference time: 1978 Jan 01 00:00:00 !------------------------------------------------------------------------------ implicit none diff --git a/var/run/radiance_info/goes-16-abi.info b/var/run/radiance_info/goes-16-abi.info new file mode 100644 index 0000000000..6b82b5a246 --- /dev/null +++ b/var/run/radiance_info/goes-16-abi.info @@ -0,0 +1,11 @@ +sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) + 1023 7 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 8 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 9 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 10 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 11 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 12 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 13 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 14 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 15 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 16 1 -1 0 2.0000000000E+00 0.0000000000E+00 diff --git a/var/run/radiance_info/goes-17-abi.info b/var/run/radiance_info/goes-17-abi.info new file mode 100644 index 0000000000..6b82b5a246 --- /dev/null +++ b/var/run/radiance_info/goes-17-abi.info @@ -0,0 +1,11 @@ +sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) + 1023 7 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 8 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 9 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 10 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 11 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 12 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 13 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 14 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 15 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 16 1 -1 0 2.0000000000E+00 0.0000000000E+00 From e26888d1c7b99881aa3f8fa6e0f5ef52e3e5166f Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Tue, 15 May 2018 14:23:03 -0600 Subject: [PATCH 03/86] More sophisticated MPI implementation for GOES ABI reading/processing/distribution Changes to be committed: modified: var/build/depend.txt modified: var/da/da_radiance/da_radiance.f90 modified: var/da/da_radiance/da_read_obs_ncgoesabi.inc --- var/build/depend.txt | 2 +- var/da/da_radiance/da_radiance.f90 | 3 + var/da/da_radiance/da_read_obs_ncgoesabi.inc | 1542 ++++++++++++------ 3 files changed, 1026 insertions(+), 521 deletions(-) diff --git a/var/build/depend.txt b/var/build/depend.txt index e17c71e122..a7ec15d96c 100644 --- a/var/build/depend.txt +++ b/var/build/depend.txt @@ -143,7 +143,7 @@ da_pseudo.o : da_pseudo.f90 da_calculate_grady_pseudo.inc da_transform_xtoy_pseu da_qscat.o : da_qscat.f90 da_calculate_grady_qscat.inc da_transform_xtoy_qscat_adj.inc da_transform_xtoy_qscat.inc da_print_stats_qscat.inc da_oi_stats_qscat.inc da_ao_stats_qscat.inc da_get_innov_vector_qscat.inc da_check_max_iv_qscat.inc da_residual_qscat.inc da_jo_and_grady_qscat.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_rad_diags.o : da_rad_diags.f90 da_radar.o : da_radar.f90 da_write_oa_radar_ascii.inc da_max_error_qc_radar.inc da_calculate_grady_radar.inc da_radial_velocity_adj.inc da_radial_velocity_lin.inc da_radial_velocity.inc da_radar_rf.inc da_get_innov_vector_radar.inc da_check_max_iv_radar.inc da_transform_xtoy_radar_adj.inc da_transform_xtoy_radar.inc da_print_stats_radar.inc da_oi_stats_radar.inc da_residual_radar.inc da_jo_and_grady_radar.inc da_ao_stats_radar.inc da_tools_serial.o da_reporting.o da_tracing.o da_tools.o da_statistics.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o -da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_satzen.inc +da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o module_dm.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_satzen.inc da_radiance1.o : da_radiance1.f90 da_mspps_ts.inc da_mspps_emis.inc da_setup_satcv.inc da_qc_rad.inc da_print_stats_rad.inc da_oi_stats_rad.inc da_ao_stats_rad.inc da_cld_eff_radius.inc da_detsurtyp.inc da_write_oa_rad_ascii.inc da_write_iv_rad_ascii.inc da_qc_mhs.inc da_qc_ssmis.inc da_qc_hirs.inc da_qc_amsub.inc da_qc_amsua.inc da_qc_airs.inc da_cloud_detect_airs.inc da_cloud_sim.inc da_qc_seviri.inc da_qc_iasi.inc da_cloud_detect_iasi.inc da_qc_crtm.inc da_predictor_crtm.inc da_predictor_rttov.inc da_write_biasprep.inc da_biasprep.inc da_read_biascoef.inc da_biascorr.inc da_residual_rad.inc da_jo_and_grady_rad.inc gsi_constants.o da_tracing.o da_tools_serial.o da_tools.o da_statistics.o da_reporting.o da_par_util1.o da_par_util.o module_dm.o da_define_structures.o da_control.o module_radiance.o da_qc_amsr2.inc da_qc_goesimg.inc da_rain.o : da_rain.f90 da_calculate_grady_rain.inc da_get_innov_vector_rain.inc da_get_hr_rain.inc da_check_max_iv_rain.inc da_transform_xtoy_rain_adj.inc da_transform_xtoy_rain.inc da_print_stats_rain.inc da_oi_stats_rain.inc da_residual_rain.inc da_jo_and_grady_rain.inc da_ao_stats_rain.inc da_tracing.o da_tools.o da_statistics.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_recursive_filter.o : da_recursive_filter.f90 da_apply_rf_adj.inc da_apply_rf.inc da_apply_rf_1v_adj.inc da_apply_rf_1v.inc da_transform_through_rf_adj.inc da_transform_through_rf.inc da_recursive_filter_1d_adj.inc da_recursive_filter_1d.inc da_calculate_rf_factors.inc da_transform_through_rf_dual_res.inc da_transform_through_rf_adj_dual_res.inc da_perform_2drf.inc da_rf_cv3.o da_rfz_cv3.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_domain.o diff --git a/var/da/da_radiance/da_radiance.f90 b/var/da/da_radiance/da_radiance.f90 index 96957fd287..626f30e53a 100644 --- a/var/da/da_radiance/da_radiance.f90 +++ b/var/da/da_radiance/da_radiance.f90 @@ -11,6 +11,9 @@ module da_radiance #if defined(RTTOV) || defined(CRTM) use module_domain, only : xb_type, domain +#ifdef DM_PARALLEL + use module_dm, only : ntasks_x, ntasks_y +#endif use module_radiance, only : satinfo, & i_kind,r_kind, r_double, & one, zero, three,deg2rad,rad2deg, & diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 7359635a7a..836e16504a 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -2,6 +2,27 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) implicit none +! 1.0 Read locs, parse, and select NC files: identify files for channels, views, times, overlap w/ patch/domain +!---------------------------------------------------------------------------------------------------------- +! 2.0 Read (BT) NC files: grab radiance data and convert to BT (K) +!---------------------------------------------------------------------------------------------------------- +! +! JJG: NEED TO ADD A MORE COMPLETE DESCRIPTION HERE +! + + !These libraries must be linked: netcdf, mpi + + !!These externally defined variables/routines are used herein: + ! cpp: DM_PARALLEL + ! PARALLELIZATION: ntasks_x, ntasks_y, num_procs, myproc, comm, ierr, true_mpi_real + ! RADIANCE OPERATOR: rtminit_nsensor, rtminit_platform, rtminit_sensor, rtminit_satid + ! THINNING: thinning_grid + ! GENERAL OBS: num_fgat_time, time_slots + ! WRFDA types: iv_type, datalink_type, info_type, model_loc_type + ! WRFDA subs: da_get_satzen, da_llxy, da_get_unit, da_free_unit, da_get_julian_time + ! da_trace_entry, da_trace_exit + ! precisions: r_kind, i_kind + type (iv_type),intent (inout) :: iv integer, intent(in) :: satellite_id ! 16 or 17 @@ -15,28 +36,35 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) logical :: found, head_found !! ABI Fixed Grid Variables - integer :: ny, nx + integer :: ny_global, nx_global integer :: yoff_fd, xoff_fd + ! For MPI parallelization + integer :: nrad_locals(num_procs) + integer :: ny_local, ny_locals(num_procs) + integer :: nx_local, nx_locals(num_procs) + integer :: ys_local, ys_locals(num_procs) + integer :: xs_local, xs_locals(num_procs) !! Earth location info real(r_kind) :: req, rpol, pph, nam !!! real :: lat_sat, lon_sat ! Assume fixed values in da_get_satzen - real, allocatable :: lat(:,:), lon(:,:), satzen(:,:) + real, allocatable, target :: buf_real(:,:,:) + real, pointer :: lat(:,:), lon(:,:), satzen(:,:) !! Masks for data reduction - logical, allocatable :: & - earthmask(:,:), & - zenmask(:,:), & - fgatmask(:,:), & - allmask_local(:,:), & - allmask_global(:,:), & - patchmask(:,:), & - domainmask(:,:), & - radmask(:,:), & + logical, allocatable, target :: buf_logical(:,:,:) + logical, pointer :: & + earthmask(:,:) , & + zenmask(:,:) , & + domainmask(:,:) , & + patchmask(:,:) , & + allmask_patch(:,:) , & thinmask(:,:) - integer(kind=1), allocatable :: view_choice(:,:,:,:) - logical :: use_view_choice, best_view +! integer(kind=1), allocatable :: view_mask(:,:,:,:) + logical, allocatable :: view_mask(:,:,:,:,:) + + logical :: use_view_mask, best_view !! Brightness Temperature (K) real, allocatable :: bt(:,:) @@ -49,13 +77,13 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !!! print_bt = .false. !! Iterates - integer :: ichan, ifile, iview, ifgat, ipass, ioff, & - jchan, jfile, jview, & - n, i, j, ix, iy + integer :: ichan, ifile, iview, ikeep, ifgat, ipass, ioff, & + jchan, jfile, jview, jkeep, & + n, i, j, iy, ix, iyl, ixl, iproc - !! Thinning Variables, need to replace with applicable WRFDA ones - integer, parameter :: xthin=1 - integer, parameter :: ythin=1 +! !! Thinning Variables, need to replace with applicable WRFDA ones +! integer, parameter :: xthin=1 +! integer, parameter :: ythin=1 !! Satellite variables integer(i_kind),parameter :: nchan = 10 @@ -78,6 +106,23 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: yr, mt, dy, hr, mn, sc end type + type viewgrid + real, allocatable :: & + lat(:,:), lon(:,:), satzen(:,:) + logical, allocatable :: & + earthmask(:,:), zenmask(:,:), & + patchmask(:,:), domainmask(:,:) + integer, allocatable :: & + iy_global(:), ix_global(:) + end type viewgrid + + type viewlist + real :: lat, lon, satzen + integer :: iy, ix + type(viewlist), pointer :: next + integer :: i + end type viewlist + type viewinfo logical :: select integer :: nfiles @@ -89,18 +134,27 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) real*8, allocatable :: fgat_time_diff(:,:) ! seconds real*8, allocatable :: min_time_diff(:,:) ! seconds integer, allocatable :: nfiles_used(:) - integer :: ny, nx, yoff, xoff - real, allocatable :: & - lat(:,:), lon(:,:), satzen(:,:) - logical, allocatable :: & - earthmask(:,:), zenmask(:,:), & - patchmask(:,:), domainmask(:,:) + integer :: ny_global, nx_global, yoff_fd, xoff_fd + integer :: ny_local, nx_local + integer :: ys_local, xs_local + integer :: ys_patch, xs_patch + integer :: ye_patch, xe_patch + integer :: ys_patch_fd, xs_patch_fd + integer :: ye_patch_fd, xe_patch_fd + integer :: nrad_on_patch, nrad_on_domain + type(viewgrid) :: obsgrid + type(viewlist), pointer :: head + type(viewlist), pointer :: current character(len=2) :: name_short character(len=10) :: name + logical :: moving end type viewinfo type(viewinfo), target, allocatable :: view_att(:) type(viewinfo), pointer :: this_view + type(viewgrid), pointer :: this_obsgrid + type(viewlist), pointer :: this_obslist +! type(viewgrid) :: tmp_grid(num_procs) integer :: first_file, tot_files_used, npass integer :: ncid, varid @@ -162,14 +216,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) iobs = 0 ! for thinning, argument is inout -! 1.0 Read (grid), parse, and select NC files: identify files for channels, views, times, overlap w/ patch/domain -!---------------------------------------------------------------------------------------------------------- -! 2.0 Read (BT) NC files: grab radiance data and convert to BT (K) -!---------------------------------------------------------------------------------------------------------- -! -! JJG: NEED TO ADD A MORE COMPLETE DESCRIPTION HERE -! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Initialize ABI L1B reading !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -263,6 +309,11 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) view_att(3)%fpath = './goes-meso/' view_att(4)%fpath = './goes-meso/' + view_att(1)%moving = .false. + view_att(2)%moving = .false. + view_att(3)%moving = .true. + view_att(4)%moving = .true. + !! Initialize local obs structures allocate (head) nullify (head % next ) @@ -281,6 +332,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) npass = 1 if (nviews.gt.1 .and. view_att(1)%select) npass = 2 tot_files_used = 0 + use_view_mask = .false. do ipass = 1, npass write(unit=stdout,fmt=*) ' ' @@ -292,6 +344,16 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !! Loop over the available views for this instrument (ABI) do iview = 1, nviews this_view => view_att(iview) + this_obsgrid => view_att(iview)%obsgrid + + !Initialize linked list for obs in this view + if (ipass .eq. 1) then + allocate(view_att(iview)%head) + view_att(iview)%head%i = 0 + end if + ! Associate this_obslist + this_obslist => view_att(iview)%head + if ( .not.this_view%select ) cycle !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -550,131 +612,411 @@ write(stdout,fmt=*) 'TEST1' if ( ipass.eq.1 .and. sum(this_view%nfiles_used(:)).eq.0 ) then !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Get ABI metadata (first pass for FD, CONUS, MESO) - ! Only ny and nx need to be read for all views, but this is a cheap subroutine + ! Only ny_global and nx_global need to be read for all views, but this is a cheap subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! write(unit=stdout,fmt='(2A)') & - ' Reading metadata for ',trim(this_view%name) + ' Reading abi metadata for ',trim(this_view%name) call get_abil1b_metadata( & - fname, this_view%ny, this_view%nx, req, rpol, pph, nam)! , lat_sat, lon_sat ) + fname, this_view%ny_global, this_view%nx_global, req, rpol, pph, nam)! , lat_sat, lon_sat ) write(stdout,fmt=*) 'TEST2' -write(stdout,fmt=*) this_view%ny, this_view%nx, req, rpol, pph, nam +write(stdout,fmt=*) this_view%ny_global, this_view%nx_global, req, rpol, pph, nam - if ( iview.eq.1 .and. ipass.lt.npass ) then - allocate(view_choice(this_view%ny,this_view%nx,nchan,num_fgat_time)) - view_choice = 0 +#ifdef DM_PARALLEL + ! Split the global ABI grid for this view into local segments + call split_grid( this_view%ny_global, this_view%nx_global , & + this_view%ny_local, this_view%nx_local , & + this_view%ys_local, this_view%xs_local , & + (iview.eq.1) ) -write(stdout,fmt=*) size(view_choice) -write(stdout,fmt=*) sizeof(view_choice) +write(stdout,fmt=*) 'ntasks_y, ntasks_x, num_procs, myproc = ', ntasks_y, ntasks_x, num_procs, myproc - end if - end if - ny = this_view%ny - nx = this_view%nx -write(stdout,fmt=*) 'TEST3' +write(stdout,fmt=*) 'TEST3' - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! Generate grid if - !! + CONUS or FD and first matching fgat - !! + MESO and any fgat (extent changes in time) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if ( ( any(iview.eq.(/1,2/)) .and. sum(this_view%nfiles_used(:)).eq.0 ) & - .or. any(iview.eq.(/3,4/)) ) then - - if (allocated(lat)) then - deallocate(lat) - deallocate(lon) - deallocate(satzen) - deallocate(earthmask) - deallocate(zenmask) - end if +#else + ! When mpi parallelism is not available, assign global values to local variables + this_view%ny_local = this_view%ny_global + this_view%nx_local = this_view%nx_global + this_view%ys_local = 1 + this_view%xs_local = 1 +#endif - !! Allocate spatial information - allocate(lat(ny,nx)) - allocate(lon(ny,nx)) - allocate(satzen(ny,nx)) - allocate(earthmask(ny,nx)) - allocate(zenmask(ny,nx)) - allocate(patchmask(ny,nx)) - allocate(domainmask(ny,nx)) +write(stdout,fmt=*) 'ny_local, nx_local, ys_local, xs_local = ', & + this_view%ny_local, this_view%nx_local, this_view%ys_local, this_view%xs_local write(stdout,fmt=*) 'TEST4' -write(stdout,fmt=*) sizeof(lat), size(lat) -write(stdout,fmt=*) sizeof(lon), size(lon) -write(stdout,fmt=*) sizeof(satzen), size(satzen) + end if + ny_global = this_view%ny_global + nx_global = this_view%nx_global + + ! Recall local dims + ny_local = this_view%ny_local + nx_local = this_view%nx_local + ys_local = this_view%ys_local + xs_local = this_view%xs_local + +#ifdef DM_PARALLEL + call mpi_allgather(ny_local,1,mpi_integer,ny_locals,1,mpi_integer,comm,ierr) + call mpi_allgather(nx_local,1,mpi_integer,nx_locals,1,mpi_integer,comm,ierr) + call mpi_allgather(ys_local,1,mpi_integer,ys_locals,1,mpi_integer,comm,ierr) + call mpi_allgather(xs_local,1,mpi_integer,xs_locals,1,mpi_integer,comm,ierr) +#endif write(stdout,fmt=*) 'TEST5' - if ( ipass.eq.2 .and. iview .eq. 1 ) then - ! Restore FD grid from memory - lat = this_view%lat - lon = this_view%lon - satzen = this_view%satzen - earthmask = this_view%earthmask - zenmask = this_view%zenmask - patchmask = this_view%patchmask - domainmask = this_view%domainmask - - deallocate(this_view%lat) - deallocate(this_view%lon) - deallocate(this_view%satzen) - deallocate(this_view%earthmask) - deallocate(this_view%zenmask) - deallocate(this_view%patchmask) - deallocate(this_view%domainmask) - - this_view%yoff = yoff_fd - this_view%xoff = xoff_fd - else + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Generate grid locations if + !! + CONUS or FD and first matching fgat + !! + MESO and any fgat (extent changes in time) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if ( ( .not.this_view%moving .and. sum(this_view%nfiles_used(:)).eq.0 ) & + .or. this_view%moving ) then + +! if ( ipass.eq.2 .and. iview .eq. 1 ) then +! ! Restore FD attributes from memory +! this_view%yoff_fd = yoff_fd +! this_view%xoff_fd = xoff_fd +! end if + + if ( ipass.eq.1 .or. this_view%moving ) then write(stdout,fmt=*) 'TEST6' - ! Read grid from file + ! Read grid from file, convert to lat, lon, satzen write(unit=stdout,fmt='(2A)') & - ' Reading grid info for ',trim(this_view%name) + ' Reading abi grid info for ',trim(this_view%name) + + !! Allocate local spatial information for this view + if (allocated(this_obsgrid%lat)) deallocate(this_obsgrid%lat) + if (allocated(this_obsgrid%lon)) deallocate(this_obsgrid%lon) + if (allocated(this_obsgrid%satzen)) deallocate(this_obsgrid%satzen) + allocate(this_obsgrid%lat(ny_local,nx_local)) + allocate(this_obsgrid%lon(ny_local,nx_local)) + allocate(this_obsgrid%satzen(ny_local,nx_local)) + + !! Allocate local mask information for this view + if (allocated(this_obsgrid%earthmask)) deallocate(this_obsgrid%earthmask) + if (allocated(this_obsgrid%zenmask)) deallocate(this_obsgrid%zenmask) + if (allocated(this_obsgrid%domainmask)) deallocate(this_obsgrid%domainmask) + allocate(this_obsgrid%earthmask(ny_local,nx_local)) + allocate(this_obsgrid%zenmask(ny_local,nx_local)) + allocate(this_obsgrid%domainmask(ny_local,nx_local)) + +write(stdout,fmt=*) sizeof(this_obsgrid%lat), size(this_obsgrid%lat) +write(stdout,fmt=*) sizeof(this_obsgrid%lon), size(this_obsgrid%lon) +write(stdout,fmt=*) sizeof(this_obsgrid%satzen), size(this_obsgrid%satzen) + write(stdout,fmt=*) 'TEST7' - call get_abil1b_grid( fname, ny, nx, & - req, rpol, pph, nam, satellite_id, & - lat, lon, satzen, earthmask, zenmask, & - this_view%yoff, this_view%xoff ) + call get_abil1b_grid( fname, & + ny_global, nx_global, & + ny_local, nx_local, & + ys_local, xs_local, & + req, rpol, pph, nam, satellite_id, & + this_obsgrid%lat, this_obsgrid%lon, this_obsgrid%satzen, & + this_obsgrid%earthmask, & + this_obsgrid%zenmask, & + this_obsgrid%domainmask, & + this_view%yoff_fd, this_view%xoff_fd ) write(stdout,fmt=*) 'TEST8' - !! With domain/patch pruning was here, view_choice can be allocated smaller + + if ( iview.eq.1 ) then + yoff_fd = this_view%yoff_fd + xoff_fd = this_view%xoff_fd + this_view%yoff_fd = 1 + this_view%xoff_fd = 1 + else + this_view%yoff_fd = this_view%yoff_fd - yoff_fd + this_view%xoff_fd = this_view%xoff_fd - xoff_fd +! this_view%yoff_fd = this_view%yoff_fd - yoff_fd + 1 +! this_view%xoff_fd = this_view%xoff_fd - xoff_fd + 1 + end if + + !====================================================== + ! Reduce the obsgrid to vectors of lat, lon, zenith + ! for locations on this WRF patch + !====================================================== + + ! Setup patch mask for this view + allocate(this_obsgrid%patchmask(ny_global,nx_global)) + patchmask => this_obsgrid%patchmask patchmask = .false. - domainmask = .false. - do ix = 1, nx -if (mod(ix,100).eq.0) write(stdout,fmt=*) 'TEST9', ix - - do iy = 1, ny - if (earthmask(iy,ix)) then - info%lon = lon(iy,ix) ! longitude - info%lat = lat(iy,ix) ! latitude - call da_llxy (info, loc, outside, outside_all) - patchmask(iy,ix) = outside - domainmask(iy,ix) = outside_all - end if + + this_view%nrad_on_domain = 0 + nrad_locals = 0 + +write(stdout,fmt=*) 'TEST9' + + ! Destroy this_obslist if it was previously populated + if (this_obslist%i .gt. 0) then + n = this_obslist%i + this_obslist => view_att(iview)%head%next + do i = 1, n + view_att(iview)%current => this_obslist + this_obslist => this_obslist%next + + ! free current data + deallocate ( view_att(iview)%current ) end do - end do - end if + ! Reassociate this_obslist + this_obslist => view_att(iview)%head + end if + write(stdout,fmt=*) 'TEST10' + + do iproc = 0, num_procs-1 + ny_local = ny_locals(iproc+1) + nx_local = nx_locals(iproc+1) + ys_local = ys_locals(iproc+1) + xs_local = xs_locals(iproc+1) +write(stdout,fmt=*) 'TEST11', iproc - if ( iview.eq.1 ) then - yoff_fd = this_view%yoff - xoff_fd = this_view%xoff - this_view%yoff = 1 - this_view%xoff = 1 - else - this_view%yoff = this_view%yoff - yoff_fd - this_view%xoff = this_view%xoff - xoff_fd +#ifdef DM_PARALLEL + !BCAST LOCAL SEGMENTS OF EARTHMASK, ZENMASK, DOMAINMASK + allocate( buf_logical(ny_local,nx_local,3) ) + if (iproc .eq. myproc) then + buf_logical(:,:,1) = this_obsgrid%earthmask + buf_logical(:,:,2) = this_obsgrid%zenmask + buf_logical(:,:,3) = this_obsgrid%domainmask + else + buf_logical = .false. + end if +write(stdout,fmt=*) 'TEST12' + + call mpi_bcast(buf_logical, ny_local * nx_local * 3, mpi_logical, & + iproc, comm, ierr ) +write(stdout,fmt=*) 'TEST13' + + earthmask => buf_logical(:,:,1) + zenmask => buf_logical(:,:,2) + domainmask => buf_logical(:,:,3) +#else + earthmask => this_obsgrid%earthmask + zenmask => this_obsgrid%zenmask + domainmask => this_obsgrid%domainmask +#endif +write(stdout,fmt=*) 'TEST14', count(earthmask .and. domainmask .and. zenmask) + + !Ignore observations that are off-earth, off-domain, or breaking zenith limit + if (count(earthmask .and. domainmask .and. zenmask) .eq. 0) then +#ifdef DM_PARALLEL + deallocate(buf_logical) +#endif + cycle + end if +write(stdout,fmt=*) 'TEST15' + +!#ifdef DM_PARALLEL +! call mpi_barrier(comm, ierr) +!#endif + +#ifdef DM_PARALLEL + !BCAST LOCAL SEGMENTS OF LAT, LON, SATZEN + allocate( buf_real(ny_local,nx_local,3) ) + if (iproc .eq. myproc) then + buf_real(:,:,1) = this_obsgrid%lat + buf_real(:,:,2) = this_obsgrid%lon + buf_real(:,:,3) = this_obsgrid%satzen + else + buf_real = 0.0 + end if + call mpi_bcast(buf_real, ny_local * nx_local * 3, true_mpi_real, & + iproc, comm, ierr ) + lat => buf_real(:,:,1) + lon => buf_real(:,:,2) + satzen => buf_real(:,:,3) +#else + lat => this_obsgrid%lat + lon => this_obsgrid%lon + satzen => this_obsgrid%satzen +#endif +write(stdout,fmt=*) 'TEST16' + + !Populate patchmask with on/off patch test for each local set of obs + do ixl = 1, nx_local + ix = ixl + xs_local - 1 +write(stdout,fmt=*) 'TEST17', ix + + do iyl = 1, ny_local + if (earthmask(iyl,ixl) .and. domainmask(iyl,ixl) .and. zenmask(iyl,ixl)) then + iy = iyl + ys_local - 1 + + this_view%nrad_on_domain = this_view%nrad_on_domain + 1 +#ifdef DM_PARALLEL + info%lat = lat(iyl,ixl) ! latitude + info%lon = lon(iyl,ixl) ! longitude + call da_llxy (info, loc, outside) + patchmask(iy,ix) = .not.outside +#else + patchmask(iy,ix) = .true. +#endif + + + if (patchmask(iy,ix)) then + nrad_locals(iproc+1) = nrad_locals(iproc+1) + 1 +write(stdout,fmt=*) 'TEST18', iy, iproc, nrad_locals(iproc+1) + + i = this_obslist%i + allocate(this_obslist%next) + this_obslist => this_obslist%next + this_obslist%i = i + 1 + this_obslist%lat = lat(iyl,ixl) + this_obslist%lon = lon(iyl,ixl) + this_obslist%satzen = satzen(iyl,ixl) + this_obslist%ix = ix + this_obslist%iy = iy + +!Is there some way to send a message to other processors not to test this point?? +!Would also need to ensure that each processor is testing in a randomized order such that the fewest points get tested in total... +!What about round-robin testing, where each process is working on a different subsection of the grid at the same time. Then they modify a subsection of a global obs_used_mask before the next process sees that subsection... + + end if + end if + end do + end do + +write(stdout,fmt=*) 'TEST19', iproc, nrad_locals(iproc+1) + +! if (nrad_locals(iproc+1) .gt. 0) then +! ! Allocate local transition data vectors +! allocate(tmp_grid(iproc+1)%lat(nrad_locals(iproc+1),1)) +! allocate(tmp_grid(iproc+1)%lon(nrad_locals(iproc+1),1)) +! allocate(tmp_grid(iproc+1)%satzen(nrad_locals(iproc+1),1)) +! allocate(tmp_grid(iproc+1)%ix_global(nrad_locals(iproc+1))) +! allocate(tmp_grid(iproc+1)%iy_global(nrad_locals(iproc+1))) +write(stdout,fmt=*) 'TEST20' + +! ikeep = 0 +! do ixl = 1, nx_local +! ix = ixl + xs_local - 1 +! do iyl = 1, ny_local +! iy = iyl + ys_local - 1 +! if (patchmask(iy,ix)) then +! ikeep = ikeep + 1 +! tmp_grid(iproc+1)%lat(ikeep,1) = lat(iyl,ixl) ! longitude +! tmp_grid(iproc+1)%lon(ikeep,1) = lon(iyl,ixl) ! longitude +! tmp_grid(iproc+1)%satzen(ikeep,1) = satzen(iyl,ixl) ! zenith +! tmp_grid(iproc+1)%ix_global(ikeep) = ix +! tmp_grid(iproc+1)%iy_global(ikeep) = iy +! end if +! end do +! end do +! end if +#ifdef DM_PARALLEL + deallocate( buf_logical ) + deallocate( buf_real ) +#endif + nullify( earthmask ) + nullify( zenmask ) + nullify( domainmask ) + nullify( lat ) + nullify( lon ) + nullify( satzen ) + end do +write(stdout,fmt=*) 'TEST21' + + +!THESE MAY NOT BE NEEDED AGAIN + ny_local = this_view%ny_local + nx_local = this_view%nx_local + ys_local = this_view%ys_local + xs_local = this_view%xs_local +!THESE MAY NOT BE NEEDED AGAIN + + deallocate( this_obsgrid%lat ) + deallocate( this_obsgrid%lon ) + deallocate( this_obsgrid%satzen ) + deallocate( this_obsgrid%earthmask ) + deallocate( this_obsgrid%zenmask ) + deallocate( this_obsgrid%domainmask ) +write(stdout,fmt=*) 'TEST22' + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! Place retained data in single vector for each parameter +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + this_view%nrad_on_patch = sum(nrad_locals) + if ( this_view%nrad_on_patch.gt.0 ) then +! +! allocate( this_obsgrid%lat(this_view%nrad_on_patch,1) ) +! allocate( this_obsgrid%lon(this_view%nrad_on_patch,1) ) +! allocate( this_obsgrid%satzen(this_view%nrad_on_patch,1) ) +! +! if (allocated(this_obsgrid%ix_global)) deallocate(this_obsgrid%ix_global) +! if (allocated(this_obsgrid%iy_global)) deallocate(this_obsgrid%iy_global) +! allocate( this_obsgrid%ix_global(this_view%nrad_on_patch) ) +! allocate( this_obsgrid%iy_global(this_view%nrad_on_patch) ) +!write(stdout,fmt=*) 'TEST23' +! +! jkeep = 0 +! do iproc = 0, num_procs-1 +! if (nrad_locals(iproc+1) .gt. 0) then +! ikeep = jkeep + 1 +! jkeep = ikeep + nrad_locals(iproc+1) - 1 +! +! this_obsgrid%lat(ikeep:jkeep,1) = tmp_grid(iproc+1)%lat(:,1) +! this_obsgrid%lon(ikeep:jkeep,1) = tmp_grid(iproc+1)%lon(:,1) +! this_obsgrid%satzen(ikeep:jkeep,1) = tmp_grid(iproc+1)%satzen(:,1) +! this_obsgrid%ix_global(ikeep:jkeep) = tmp_grid(iproc+1)%ix_global(:) +! this_obsgrid%iy_global(ikeep:jkeep) = tmp_grid(iproc+1)%iy_global(:) +! +! deallocate(tmp_grid(iproc+1)%lat) +! deallocate(tmp_grid(iproc+1)%lon) +! deallocate(tmp_grid(iproc+1)%satzen) +! deallocate(tmp_grid(iproc+1)%ix_global) +! deallocate(tmp_grid(iproc+1)%iy_global) +! end if +! end do + + ! Determine ys & ye for this patch + this_view%ys_patch = ny_global + this_view%ye_patch = 1 + do iy = 1, ny_global + if ( any(patchmask(iy,:)) ) then + this_view%ys_patch = iy + this_view%ys_patch_fd = iy+this_view%yoff_fd-1 ! offset to FD grid + exit + end if + end do + do iy = ny_global, 1, -1 + if ( any(patchmask(iy,:)) ) then + this_view%ye_patch = iy + this_view%ye_patch_fd = iy+this_view%yoff_fd-1 ! offset to FD grid + exit + end if + end do + + ! Determine xs & xe for this patch + this_view%xs_patch = nx_global + this_view%xe_patch = 1 + do ix = 1, nx_global + if ( any(patchmask(:,ix)) ) then + this_view%xs_patch = ix + this_view%xs_patch_fd = ix+this_view%xoff_fd-1 ! offset to FD grid + exit + end if + end do + do ix = nx_global, 1, -1 + if ( any(patchmask(:,ix)) ) then + this_view%xe_patch = ix + this_view%xe_patch_fd = ix+this_view%xoff_fd-1 ! offset to FD grid + exit + end if + end do + + end if end if -write(stdout,fmt=*) 'TEST11' -!!!! print*,'yoff = ',this_view%yoff -!!!! print*,'xoff = ',this_view%xoff +write(stdout,fmt=*) 'TEST24' + + +write(stdout,fmt=*) 'TEST25' + +!!!! print*,'yoff_fd = ',this_view%yoff_fd +!!!! print*,'xoff_fd = ',this_view%xoff_fd !!!!!!! START GRID WRITE !!! if ( ipass .eq. 1 .and. print_grid .and. iview.eq.1) then !!! write(prefix,fmt='(3A)') & @@ -705,58 +1047,94 @@ write(stdout,fmt=*) 'TEST11' !!!!!!! END GRID WRITE end if -write(stdout,fmt=*) 'TEST12' + PatchMatch: if (this_view%nrad_on_patch .gt. 0) then +write(stdout,fmt=*) 'TEST26' - ! Loop over channels - ! This loop over channels could be parallelized, if needed for time savings + patchmask => this_obsgrid%patchmask - ChannelLoop: do ichan = 1, nchan + if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view%nfiles_used(:)).eq.0 ) then + allocate(view_mask(& + this_view%ys_patch:this_view%ye_patch, & + this_view%xs_patch:this_view%xe_patch, & + nchan, num_fgat_time, nviews)) - ifile = 0 - do jfile = 1, this_view%nfiles - if ( .not. this_view%file_fgat_match(jfile,ifgat) ) cycle - call get_ichan(this_view%filechan(jfile), channel_list, nchan, jchan) - if ( ichan .eq. jchan ) then - ifile = jfile - exit - end if - end do - if ( ifile .eq. 0 ) cycle - - this_view%nfiles_used(ifgat) = this_view%nfiles_used(ifgat) + 1 - - use_view_choice = ( sum(view_att(1)%nfiles_used(:)).gt.0 ) - - VIEW_SELECT: & - if ( ipass.lt.npass .and. use_view_choice ) then - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! Determine which view has the closest observed - !! time to fgat for this channel - !! Note: this only needs to be done for a single channel, - !! unless individual channel files are missing at fgat. - !! Solution where file view availability differs by channel used here. - !! (only available when FD data present for one of the fgat times) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if ( iview.eq.1 ) then - view_choice(:,:, ichan, ifgat) = 1 - else - best_view = .true. -! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations - do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap - best_view = best_view .and. & - this_view%min_time_diff(ichan, ifgat) .lt. & - view_att(jview)%min_time_diff(ichan, ifgat) - end do - if ( best_view ) & - view_choice(this_view%yoff:ny+this_view%yoff-1, & - this_view%xoff:nx+this_view%xoff-1, & - ichan, ifgat) = iview - end if + view_mask = .false. + use_view_mask = .true. + +write(stdout,fmt=*) size(view_mask) +write(stdout,fmt=*) sizeof(view_mask) + end if + +write(stdout,fmt=*) 'TEST27' + + ! Loop over channels + ! This loop over channels could be parallelized, if needed for time savings + + ChannelLoop: do ichan = 1, nchan + + ifile = 0 + do jfile = 1, this_view%nfiles + if ( .not. this_view%file_fgat_match(jfile,ifgat) ) cycle + call get_ichan(this_view%filechan(jfile), channel_list, nchan, jchan) + if ( ichan .eq. jchan ) then + ifile = jfile + exit + end if + end do + if ( ifile .eq. 0 ) cycle + + this_view%nfiles_used(ifgat) = this_view%nfiles_used(ifgat) + 1 + +! use_view_mask = ( sum(view_att(1)%nfiles_used(:)).gt.0 ) + + VIEW_SELECT: & + if ( ipass.lt.npass .and. use_view_mask ) then + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Determine which view has the closest observed + !! time to fgat for this channel + !! Note: this only needs to be done for a single channel, + !! unless individual channel files are missing at fgat. + !! Solution where file view availability differs by channel used here. + !! (only available when FD data present for one of the fgat times) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if ( iview.eq.1 ) then + view_mask(:,:, ichan, ifgat, iview) = .true. + else + best_view = .true. +! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations + do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap + best_view = best_view .and. & + this_view%min_time_diff(ichan, ifgat) .lt. & + view_att(jview)%min_time_diff(ichan, ifgat) + end do + + if ( best_view ) then +! view_mask(this_view%yoff_fd:ny_global+this_view%yoff_fd-1, & +! this_view%xoff_fd:nx_global+this_view%xoff_fd-1, & +! ichan, ifgat, iview) = .true. + + view_mask(this_view%ys_patch_fd:this_view%ye_patch_fd, & + this_view%ys_patch_fd:this_view%ye_patch_fd, & + ichan, ifgat, iview) = .true. + +! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations + do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap +! view_mask(this_view%yoff_fd:ny_global+this_view%yoff_fd-1, & +! this_view%xoff_fd:nx_global+this_view%xoff_fd-1, & +! ichan, ifgat, jview) = .false. + + view_mask(this_view%ys_patch_fd:this_view%ye_patch_fd, & + this_view%ys_patch_fd:this_view%ye_patch_fd, & + ichan, ifgat, jview) = .false. + end do + end if + + end if !!!!!!! START VIEW_CHOICE WRITE !!! if ( this_view%nfiles_used(ifgat).eq.1 .and. print_view .and. iview.eq.nviews) then !!! write(unit=stdout,fmt='(A)') & -!!! ' printing view_choice' +!!! ' printing view_mask' !!! !!! write(prefix,fmt='(5A)') & !!! 'VIEW',trim(this_view%name_short),'_', & @@ -767,81 +1145,74 @@ write(stdout,fmt=*) 'TEST12' !!! write(nxthin,fmt='(I0)') view_att(1)%nx !!! !!! do iy=1, view_att(1)%ny -!!! write(30,fmt='('//trim(nxthin)//'I3)') view_choice (iy, 1:view_att(1)%nx, ichan, ifgat) +!!! write(30,fmt='('//trim(nxthin)//'I3)') view_mask (iy, 1:view_att(1)%nx, ichan, ifgat) !!! end do !!! !!! close(30) !!! end if !!!!! END VIEW_CHOICE WRITE - else - if (inst == 0) cycle - - fname_short = trim(this_view%filename(ifile)) - fname = trim(this_view%fpath)//trim(fname_short) - - allocate(allmask_local(ny,nx)) - allocate(allmask_global(ny,nx)) - - !!Utilizing these masks to eliminate data: - !! + earthmask - !! + zenmask - !! + fgatmask [only if npass > 1] - !! + model domain mask - !! + patch mask - !! + thinning - - allmask_global = (earthmask .and. zenmask .and. domainmask) - allmask_local = (earthmask .and. zenmask .and. patchmask) - - ! Only use locations where this view is nearest to this fgat time - ! - only available when FD data present for any fgat time - if ( use_view_choice ) then - allocate(fgatmask(ny,nx)) - fgatmask = ( view_choice(this_view%yoff:ny+this_view%yoff-1, & - this_view%xoff:nx+this_view%xoff-1, & - ichan, ifgat) .eq. iview ) - - if ( count(fgatmask) .eq. 0 ) then - deallocate(fgatmask) - deallocate(allmask_local) - deallocate(allmask_global) - cycle + else + if (inst == 0) cycle + + fname_short = trim(this_view%filename(ifile)) + fname = trim(this_view%fpath)//trim(fname_short) + + + !!Utilizing these masks to eliminate data: + !! + earthmask + !! + zenmask + !! + view_mask [only if npass > 1] + !! + model domain mask + !! + patch mask + !! + thinning + + allocate(allmask_patch(ny_global,nx_global)) + allmask_patch = patchmask + + ! Only use locations where this view is nearest to this fgat time + ! - only available when FD data present for any fgat time + if ( use_view_mask ) then + if ( count(view_mask(this_view%ys_patch_fd:this_view%ye_patch_fd, & + this_view%ys_patch_fd:this_view%ye_patch_fd, & + ichan, ifgat, iview)) .eq. 0 ) then + deallocate(allmask_patch) + cycle + end if + + allmask_patch(this_view%ys_patch:this_view%ye_patch , & + this_view%ys_patch:this_view%ye_patch ) = ( & + allmask_patch(this_view%ys_patch:this_view%ye_patch , & + this_view%ys_patch:this_view%ye_patch ) & + .and. & + view_mask(this_view%ys_patch_fd:this_view%ye_patch_fd, & + this_view%ys_patch_fd:this_view%ye_patch_fd, & + ichan, ifgat, iview) ) end if - allmask_local = (allmask_local .and. fgatmask) - allmask_global = (allmask_global .and. fgatmask) - end if - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! Read radiance and convert to brightness temp. - !! once per permutation of - !! + INST VIEW (FD, CONUS, MESOx2) - !! + fgat - !! + channel/band - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - write(unit=stdout,fmt='(2A)') & - ' Reading radiances: ',trim(fname_short) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Read radiance and convert to brightness temp. + !! once per permutation of + !! + INST VIEW (FD, CONUS, MESOx2) + !! + fgat + !! + channel/band + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(unit=stdout,fmt='(2A)') & + ' Reading abi radiances: ',trim(fname_short) !!print*,this_view%fgat_time_diff(ifile,ifgat) - ! Allocate this bt - allocate(bt(ny,nx)) - allocate(radmask(ny,nx)) - -! ! This reads in bt only for the local patch, -! ! reduces read time, but would mess up global count below -! call get_abil1b_bt( fname, ny, nx, allmask_local, & -! bt ) + ! Allocate this patch bt + allocate(bt(this_view%ys_patch:this_view%ye_patch, & + this_view%xs_patch:this_view%xe_patch)) - ! This reads in bt for whole domain, - ! creates valid plocal check at end of this subroutine, - ! could read only on rootproc and distribute data, - ! or switch to round-robin reading+distribution across channels - call get_abil1b_bt( fname, ny, nx, allmask_global, radmask, & - bt ) + ! This reads in bt only for the local patch, + ! reduces read time, but would mess up global count below + call get_abil1b_bt( fname, & + ny_global, nx_global, & + this_view%ys_patch, this_view%ye_patch, & + this_view%xs_patch, this_view%xe_patch, & + allmask_patch, bt ) - allmask_local = (allmask_local .and. radmask) - allmask_global = (allmask_global .and. radmask) - deallocate(radmask) !!!!!!! START BT WRITE !!! if ( ipass .eq. npass .and. print_bt ) then @@ -862,148 +1233,161 @@ write(stdout,fmt=*) 'TEST12' !!! end if !!!!! END BT WRITE - !! Write bt, lat, lon, and satzen to datalink structures + !! Write bt, lat, lon, and satzen to datalink structures - first_chan = (this_view%nfiles_used(ifgat).eq.1) - if (first_chan) then - p_fgat => p - allocate(thinmask(ny,nx)) - thinmask = .false. - - yr = this_view%filedate(ifile)%yr - mt = this_view%filedate(ifile)%mt - dy = this_view%filedate(ifile)%dy - hr = this_view%filedate(ifile)%hr - mn = this_view%filedate(ifile)%mn - sc = this_view%filedate(ifile)%sc - else - p => p_fgat - end if + first_chan = (this_view%nfiles_used(ifgat).eq.1) + if (first_chan) then + p_fgat => p + allocate(thinmask(ny_global,nx_global)) + thinmask = .false. + + yr = this_view%filedate(ifile)%yr + mt = this_view%filedate(ifile)%mt + dy = this_view%filedate(ifile)%dy + hr = this_view%filedate(ifile)%hr + mn = this_view%filedate(ifile)%mn + sc = this_view%filedate(ifile)%sc + num_goesabi_global = num_goesabi_global + this_view%nrad_on_domain + else + p => p_fgat + end if - do iy = 1, ny - do ix = 1, nx +! lat => this_obsgrid%lat +! lon => this_obsgrid%lon +! satzen => this_obsgrid%satzen - if (.not. allmask_global(iy,ix)) cycle + this_obslist => view_att(iview)%head - if (first_chan) then - info%lon = lon(iy,ix) ! longitude - info%lat = lat(iy,ix) ! latitude - call da_llxy (info, loc, outside) + do ikeep = 1, this_view%nrad_on_patch - ptotal(ifgat) = ptotal(ifgat) + 1 - num_goesabi_global = num_goesabi_global + 1 - end if + this_obslist => this_obslist%next - if (.not. allmask_local(iy,ix)) cycle + iy = this_obslist%iy + ix = this_obslist%ix - if (first_chan) & - num_goesabi_local = num_goesabi_local + 1 +! iy = this_obsgrid%iy_global(ikeep) +! ix = this_obsgrid%ix_global(ikeep) - if (thinning) then if (first_chan) then - dlat_earth = info%lat - dlon_earth = info%lon - if (dlon_earth=r360) dlon_earth = dlon_earth-r360 - dlat_earth = dlat_earth*deg2rad - dlon_earth = dlon_earth*deg2rad - crit = 1. - call map2grids(inst,ifgat,dlat_earth,dlon_earth,crit,iobs,itx,1,itt,iout,iuse) - if (.not. iuse) then - num_goesabi_thinned=num_goesabi_thinned+1 - thinmask(iy,ix) = .true. - cycle + info%lat = this_obslist%lat ! latitude + info%lon = this_obslist%lon ! longitude + +! info%lat = lat(ikeep,1) ! latitude +! info%lon = lon(ikeep,1) ! longitude + ptotal(ifgat) = ptotal(ifgat) + 1 + end if + + if (.not. allmask_patch(iy,ix)) cycle + + if (first_chan) & + num_goesabi_local = num_goesabi_local + 1 + + if (thinning) then + if (first_chan) then + dlat_earth = info%lat + dlon_earth = info%lon + if (dlon_earth=r360) dlon_earth = dlon_earth-r360 + dlat_earth = dlat_earth*deg2rad + dlon_earth = dlon_earth*deg2rad + crit = 1. + call map2grids(inst,ifgat,dlat_earth,dlon_earth,crit,iobs,itx,1,itt,iout,iuse) + if (.not. iuse) then + num_goesabi_thinned=num_goesabi_thinned+1 + thinmask(iy,ix) = .true. + cycle + end if + else + if (thinmask(iy,ix)) cycle end if - else - if (thinmask(iy,ix)) cycle end if - end if - if (first_chan) then - num_goesabi_used = num_goesabi_used + 1 - - write(unit=info%date_char, & - fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & - yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc - info%elv = 0.0 !aquaspot%selv - allocate ( p % tb_inv (1:nchan) ) - - p%info = info - p%loc = loc - p%landsea_mask = 1 ! ??? - if (use_view_choice) then - p%scanpos = & - (iy + this_view%yoff-1 - 1) * (nscan+1) / view_att(1)%ny - ! ??? "scan" position (IS THIS CORRECT?) - else - p%scanpos = & - (iy + this_view%yoff-1 - 1) * (nscan+1) / 5423 - ! ??? "scan" position (IS THIS CORRECT?) + if (first_chan) then + num_goesabi_used = num_goesabi_used + 1 + + write(unit=info%date_char, & + fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & + yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc + info%elv = 0.0 !aquaspot%selv + allocate ( p % tb_inv (1:nchan) ) + + p%info = info + p%loc = loc + p%landsea_mask = 1 ! ??? + if (use_view_mask) then + p%scanpos = & + (iy + this_view%yoff_fd-1 - 1) * (nscan+1) / view_att(1)%ny_global + ! ??? "scan" position (IS THIS CORRECT?) + else + p%scanpos = & + (iy + this_view%yoff_fd-1 - 1) * (nscan+1) / 5423 + ! ??? "scan" position (IS THIS CORRECT?) + end if + p%satzen = this_obslist%satzen +! p%satzen = satzen(ikeep,1) + p%solzen = 0.0 + p%sensor_index = inst + p%ifgat = ifgat end if - p%satzen = satzen(iy,ix) - p%solzen = 0.0 - p%sensor_index = inst - p%ifgat = ifgat - end if + ! Transfer BT from all files + p%tb_inv(ichan) = bt(iy,ix) - ! Transfer BT from all files - p%tb_inv(ichan) = bt(iy,ix) + if (first_chan) & + allocate (p%next) ! add next data - if (first_chan) & - allocate (p%next) ! add next data + p => p%next - p => p%next + if (first_chan) & + nullify (p%next) - if (first_chan) & - nullify (p%next) - end do - end do + end do + nullify( lat ) + nullify( lon ) + nullify( satzen ) - deallocate(bt) - deallocate(allmask_local) - deallocate(allmask_global) + deallocate(bt) + deallocate(allmask_patch) - if ( use_view_choice ) & - deallocate(fgatmask) + end if VIEW_SELECT - end if VIEW_SELECT + end do ChannelLoop - end do ChannelLoop - if (this_view%nfiles_used(ifgat).ge.1) & - deallocate(thinmask) + if (this_view%nfiles_used(ifgat).gt.0) & + deallocate(thinmask) - end do ! end fgat loop + end if PatchMatch - if (sum(this_view%nfiles_used) .gt. 0) then - if (iview.eq.1) then - ! Store FD grid in memory - if(ipass.eq.1) then - allocate(this_view%lat(this_view%ny,this_view%nx)) - allocate(this_view%lon(this_view%ny,this_view%nx)) - allocate(this_view%satzen(this_view%ny,this_view%nx)) - allocate(this_view%earthmask(this_view%ny,this_view%nx)) - allocate(this_view%zenmask(this_view%ny,this_view%nx)) - allocate(this_view%patchmask(this_view%ny,this_view%nx)) - allocate(this_view%domainmask(this_view%ny,this_view%nx)) - - this_view%lat = lat - this_view%lon = lon - this_view%satzen = satzen - this_view%earthmask = earthmask - this_view%zenmask = zenmask - this_view%patchmask = patchmask - this_view%domainmask = domainmask - end if - end if +!#ifdef DM_PARALLEL +! call mpi_barrier(comm, ierr) +!#endif + end do ! end fgat loop + if (this_view%moving .or. ipass.eq.npass) then ! Deallocate static data - deallocate(lat) - deallocate(lon) - deallocate(satzen) - deallocate(earthmask) - deallocate(zenmask) +! if (allocated(this_obsgrid%lat)) deallocate(this_obsgrid%lat) +! if (allocated(this_obsgrid%lon)) deallocate(this_obsgrid%lon) +! if (allocated(this_obsgrid%satzen)) deallocate(this_obsgrid%satzen) + if (allocated(this_obsgrid%patchmask)) deallocate(this_obsgrid%patchmask) +! if (allocated(this_obsgrid%ix_global)) deallocate(this_obsgrid%ix_global) +! if (allocated(this_obsgrid%iy_global)) deallocate(this_obsgrid%iy_global) + end if + + if (ipass.eq.npass) then + if (this_obslist%i .gt. 0) then + ! Destroy this_obslist and head + n = this_obslist%i + this_obslist => view_att(iview)%head%next + do i = 1, n + view_att(iview)%current => this_obslist + this_obslist => this_obslist%next + + ! free current data + deallocate ( view_att(iview)%current ) + end do + deallocate(view_att(iview)%head) + end if end if tot_files_used = tot_files_used + sum(view_att(iview)%nfiles_used) @@ -1017,7 +1401,7 @@ write(stdout,fmt=*) 'TEST12' end if end do ! end pass loop - if (allocated(view_choice)) deallocate(view_choice) + if (allocated(view_mask)) deallocate(view_mask) do iview = 1, nviews if ( .not.view_att(iview)%select ) cycle @@ -1214,18 +1598,18 @@ subroutine get_abil1b_metadata( filename, & integer :: ierr, ncid, varid, dimid real(r_kind), parameter :: pi=3.1415926535898D0 -write(stdout,fmt=*) 'TEST13' +write(stdout,fmt=*) 'TEST28' ierr=nf_open(trim(filename),nf_nowrite,ncid) call handle_err('Error opening file',ierr) -write(stdout,fmt=*) 'TEST14' +write(stdout,fmt=*) 'TEST29' !! Determine ABI satellite parameters (optional outputs) ierr=nf_inq_dimid(ncid,'y',dimid) ierr=nf_inq_dimlen(ncid,dimid,ydim) ierr=nf_inq_dimid(ncid,'x',dimid) ierr=nf_inq_dimlen(ncid,dimid,xdim) -write(stdout,fmt=*) 'TEST15' +write(stdout,fmt=*) 'TEST30' ierr=nf_inq_varid(ncid,'goes_imager_projection',varid) ierr=nf_get_att_double(ncid,varid,'semi_major_axis',req) @@ -1233,279 +1617,269 @@ write(stdout,fmt=*) 'TEST15' ierr=nf_get_att_double(ncid,varid,'perspective_point_height',pph) ierr=nf_get_att_double(ncid,varid,'longitude_of_projection_origin',nam) nam=nam*pi/180 -write(stdout,fmt=*) 'TEST16' +write(stdout,fmt=*) 'TEST31' !!! ierr=nf_inq_varid(ncid,'nominal_satellite_subpoint_lat',varid) -!!! ierr=nf_get_var_real(ncid,varid,lat_sat) +!!! ierr=nf_get_var_double(ncid,varid,lat_sat) !!! ierr=nf_inq_varid(ncid,'nominal_satellite_subpoint_lon',varid) -!!! ierr=nf_get_var_real(ncid,varid,lon_sat) +!!! ierr=nf_get_var_double(ncid,varid,lon_sat) -#ifdef DM_PARALLEL - call mpi_barrier(comm, ierr) -#endif -write(stdout,fmt=*) 'TEST17' +!#ifdef DM_PARALLEL +! call mpi_barrier(comm, ierr) +!#endif +write(stdout,fmt=*) 'TEST32' ierr=nf_close(ncid) call handle_err('Error closing file',ierr) -write(stdout,fmt=*) 'TEST18' - +write(stdout,fmt=*) 'TEST33' end subroutine get_abil1b_metadata -subroutine get_abil1b_grid( filename, ydim, xdim, req, rpol, pph, nam, satellite_id, & - lat, lon, satzen, earthmask, zenmask, & - yoff, xoff ) + +subroutine get_abil1b_grid( filename, & + ny, nx, nyl, nxl, ys, xs, & + req, rpol, pph, nam, satellite_id, & + lat, lon, satzen, earthmask, zenmask, domainmask, & + yoff, xoff ) implicit none character(*), intent(in) :: filename - integer, intent(in) :: ydim, xdim, satellite_id + integer, intent(in) :: ny, nx, nyl, nxl, ys, xs real(r_kind), intent(in) :: req, rpol, pph, nam + integer, intent(in) :: satellite_id + !!! real, intent(in) :: lon_sat - real, intent(out) :: lat(ydim,xdim), lon(ydim,xdim), satzen(ydim,xdim) - logical, intent(out) :: earthmask(ydim, xdim), zenmask(ydim, xdim) + real, intent(out) :: lat(nyl,nxl), lon(nyl,nxl), satzen(nyl,nxl) + logical, intent(out) :: earthmask(nyl,nxl), zenmask(nyl,nxl), domainmask(nyl,nxl) integer, intent(out) :: yoff, xoff - real :: yy(ydim), xx(xdim) + type(info_type) :: info + type(model_loc_type) :: loc + logical :: outside_all, dummy_bool + + real :: yy(ny), xx(nx) integer :: ierr, ncid, varid - integer :: iy, ix + integer :: iy, ix, iyl, ixl real :: slp, itp real(r_kind) :: hh real :: alat, alon ! , alon_sat real :: theta, theta1, theta2, r1 + real, parameter :: satzen_limit=75.0 - real, parameter :: rre=6371.004*1e3 - real(r_kind), parameter :: pi=3.1415926535898D0 - real, parameter :: satzen_limit=75.0 - real, parameter :: fillv=-999.000 -write(stdout,fmt=*) 'TEST19' +write(stdout,fmt=*) 'TEST34' ierr=nf_open(trim(filename),nf_nowrite,ncid) call handle_err('Error opening file',ierr) -write(stdout,fmt=*) 'TEST20' +write(stdout,fmt=*) 'TEST35' ierr=nf_inq_varid(ncid,'y',varid) -write(stdout,fmt=*) 'TEST21' +write(stdout,fmt=*) 'TEST36' - ierr=nf_get_var_real(ncid,varid,yy) -write(stdout,fmt=*) 'TEST22' + ierr=nf_get_var_double(ncid,varid,yy) +write(stdout,fmt=*) 'TEST37' - ierr=nf_get_att_real(ncid,varid,'scale_factor',slp) - ierr=nf_get_att_real(ncid,varid,'add_offset',itp) + ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_double(ncid,varid,'add_offset',itp) yy = yy*slp+itp yoff = floor(itp/slp) -write(stdout,fmt=*) 'TEST23' +write(stdout,fmt=*) 'TEST38' ierr=nf_inq_varid(ncid,'x',varid) -write(stdout,fmt=*) 'TEST24' +write(stdout,fmt=*) 'TEST39' - ierr=nf_get_var_real(ncid,varid,xx) -write(stdout,fmt=*) 'TEST25' + ierr=nf_get_var_double(ncid,varid,xx) +write(stdout,fmt=*) 'TEST40' - ierr=nf_get_att_real(ncid,varid,'scale_factor',slp) - ierr=nf_get_att_real(ncid,varid,'add_offset',itp) + ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_double(ncid,varid,'add_offset',itp) xx = xx*slp+itp xoff = floor(itp/slp) -write(stdout,fmt=*) 'TEST26' +write(stdout,fmt=*) 'TEST41' earthmask=.false. -write(stdout,fmt=*) 'TEST27' +write(stdout,fmt=*) 'TEST42' zenmask=.false. -write(stdout,fmt=*) 'TEST28' +write(stdout,fmt=*) 'TEST43' !!! alon_sat=lon_sat*pi/180.D0 hh=pph+req -write(stdout,fmt=*) 'TEST29' +write(stdout,fmt=*) 'TEST44' write(stdout,fmt=*) hh,pph,req,rpol,nam,slp,itp,xoff,yoff -write(stdout,fmt=*) 'TEST30' +write(stdout,fmt=*) 'TEST45' - lat = fillv -write(stdout,fmt=*) 'TEST31' + lat = missing_r +write(stdout,fmt=*) 'TEST46' - lon = fillv -write(stdout,fmt=*) 'TEST32' + lon = missing_r +write(stdout,fmt=*) 'TEST47' - satzen = fillv -write(stdout,fmt=*) 'TEST33' - do ix=1,xdim -if (mod(ix,100).eq.0) write(stdout,fmt=*) 'TEST34', ix + satzen = missing_r +write(stdout,fmt=*) 'TEST48' + do ixl = 1, nxl + ix = ixl + xs - 1 +write(stdout,fmt=*) 'TEST49', ixl - do iy=1,ydim - call get_abil1b_latlon(yy(iy),xx(ix),req,rpol,hh,nam,lat(iy,ix),lon(iy,ix)) + do iyl = 1, nyl + iy = iyl + ys - 1 - if (isnan(lat(iy,ix)) .OR. isnan(lon(iy,ix))) then - lat(iy,ix) = fillv - lon(iy,ix) = fillv - cycle - end if + call get_abil1b_latlon(yy(iy),xx(ix),req,rpol,hh,nam,lat(iyl,ixl),lon(iyl,ixl)) - call da_get_satzen(lat(iy,ix),lon(iy,ix),satellite_id,satzen(iy,ix)) +! if ( isnan(lat(iyl,ixl)) .OR. isnan(lon(iyl,ixl)) ) then +! lat(iyl,ixl) = missing_r +! lon(iyl,ixl) = missing_r +! end if + if( lat(iyl,ixl).eq.missing_r .OR. lon(iyl,ixl).eq.missing_r ) cycle - if (isnan(satzen(iy,ix))) then - lat(iy,ix) = fillv - lon(iy,ix) = fillv - satzen(iy,ix) = fillv - cycle - end if - earthmask(iy,ix)=.true. + call da_get_satzen(lat(iyl,ixl),lon(iyl,ixl),satellite_id,satzen(iyl,ixl)) + +! if (isnan(satzen(iyl,ixl))) then +! lat(iyl,ixl) = missing_r +! lon(iyl,ixl) = missing_r +! satzen(iyl,ixl) = missing_r +! cycle +! end if + earthmask(iyl,ixl)=.true. - if (satzen(iy,ix).gt.satzen_limit) then + if (satzen(iyl,ixl).gt.satzen_limit) then + satzen(iyl,ixl) = missing_r cycle end if - zenmask(iy,ix)=.true. + zenmask(iyl,ixl)=.true. end do end do -write(stdout,fmt=*) 'TEST35' - -#ifdef DM_PARALLEL - call mpi_barrier(comm, ierr) -#endif -write(stdout,fmt=*) 'TEST36' +write(stdout,fmt=*) 'TEST50' ierr=nf_close(ncid) call handle_err('Error closing file',ierr) -write(stdout,fmt=*) 'TEST37' +write(stdout,fmt=*) 'TEST51' + +write(stdout,fmt=*) 'TEST52' + + !Populate domainmask with on/off domain test for local set of obs + domainmask = .false. + do ixl = 1, nxl +write(stdout,fmt=*) 'TEST53', ixl + do iyl = 1, nyl + if (earthmask(iyl,ixl)) then + info%lon = lon(iyl,ixl) ! longitude + info%lat = lat(iyl,ixl) ! latitude + call da_llxy (info, loc, dummy_bool, outside_all) + domainmask(iyl,ixl) = .not. outside_all + end if + end do + end do end subroutine get_abil1b_grid -subroutine get_abil1b_bt( filename, ydim, xdim, allmask, radmask, & - bt ) +subroutine get_abil1b_bt( filename, ny, nx, ys, ye, xs, xe, & + radmask, bt ) implicit none character(*), intent(in) :: filename - integer, intent(in) :: ydim, xdim - logical, intent(in) :: allmask(ydim, xdim) - logical, intent(out) :: radmask(ydim, xdim) - real, intent(out) :: bt(ydim, xdim) - real :: rad(ydim, xdim) - integer(kind=1) :: DQF(ydim, xdim) + !Size of full data set + integer, intent(in) :: ny, nx + + !Starting and stopping indices of this view desired (not equivalent to Full Disk indices) + integer, intent(in) :: ys, ye, xs, xe + + logical, intent(inout) :: radmask(ny, nx) + real, intent(out) :: bt(ys:ye, xs:xe) + + real :: rad(ys:ye, xs:xe) + integer(kind=1) :: DQF(ys:ye, xs:xe) integer :: ierr, ncid, varid integer :: iy, ix - integer :: ystart, yend, xstart, xend, nykeep, nxkeep + integer :: nykeep, nxkeep real :: slp, itp real :: bc1, bc2, fk1, fk2 - real, parameter :: fillv=-999.000 - - bt = fillv - radmask = .false. -! if (.true.) then - !! Attempt to save rad reading time by selecting a subset of netcdf var - ystart = ydim - yend = 1 - do iy = 1, ydim - if ( any(allmask(iy,:)) ) then - ystart = iy - exit - end if - end do - do iy = ydim, 1, -1 - if ( any(allmask(iy,:)) ) then - yend = iy - exit - end if - end do - xstart = xdim - xend = 1 - do ix = 1, xdim - if ( any(allmask(:,ix)) ) then - xstart = ix - exit - end if - end do - do ix = xdim, 1, -1 - if ( any(allmask(:,ix)) ) then - xend = ix - exit - end if - end do - nykeep = yend - ystart + 1 - nxkeep = xend - xstart + 1 + bt = missing_r - if (nykeep.gt.0 .and. nxkeep.gt.0) then - ierr=nf_open(trim(filename),nf_nowrite,ncid) - call handle_err('Error opening file',ierr) + !! Save rad reading time by selecting a subset of netcdf var + nykeep = ye - ys + 1 + nxkeep = xe - xs + 1 - ierr=nf_inq_varid(ncid,'Rad',varid) - ierr=nf_get_vara_real(ncid,varid,(/ystart,xstart/),(/nykeep,nxkeep/), & - rad(ystart:yend,xstart:xend) ) + if (nykeep.gt.0 .and. nxkeep.gt.0) then + ierr=nf_open(trim(filename),nf_nowrite,ncid) + call handle_err('Error opening file',ierr) - ierr=nf_inq_varid(ncid,'DQF',varid) - ierr=nf_get_vara_int(ncid,varid,(/ystart,xstart/),(/nykeep,nxkeep/), & - DQF(ystart:yend,xstart:xend) ) - else - return - end if -! else -! ystart = 1 -! yend = ydim -! xstart = 1 -! xend = xdim -! -! ierr=nf_open(trim(filename),nf_nowrite,ncid) -! ierr=nf_inq_varid(ncid,'Rad',varid) -! -! ierr=nf_get_var_real(ncid,varid,rad) -! -! ierr=nf_inq_varid(ncid,'DQF',varid) -! ierr=nf_get_var_real(ncid,varid,DQF) -! end if + ierr=nf_inq_varid(ncid,'Rad',varid) + ierr=nf_get_vara_double(ncid,varid,(/ys,xs/),(/nykeep,nxkeep/), & + rad(ys:ye,xs:xe) ) - ierr=nf_get_att_real(ncid,varid,'scale_factor',slp) - ierr=nf_get_att_real(ncid,varid,'add_offset',itp) + ierr=nf_inq_varid(ncid,'DQF',varid) + ierr=nf_get_vara_int(ncid,varid,(/ys,xs/),(/nykeep,nxkeep/), & + DQF(ys:ye,xs:xe) ) + else + return + end if + + ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_double(ncid,varid,'add_offset',itp) rad=rad*slp+itp ierr=nf_inq_varid(ncid,'planck_bc1',varid) - ierr=nf_get_var_real(ncid,varid,bc1) + ierr=nf_get_var_double(ncid,varid,bc1) ierr=nf_inq_varid(ncid,'planck_bc2',varid) - ierr=nf_get_var_real(ncid,varid,bc2) + ierr=nf_get_var_double(ncid,varid,bc2) ierr=nf_inq_varid(ncid,'planck_fk1',varid) - ierr=nf_get_var_real(ncid,varid,fk1) + ierr=nf_get_var_double(ncid,varid,fk1) ierr=nf_inq_varid(ncid,'planck_fk2',varid) - ierr=nf_get_var_real(ncid,varid,fk2) + ierr=nf_get_var_double(ncid,varid,fk2) - do ix=xstart, xend - do iy=ystart, yend - if ( allmask(iy,ix) ) then - if ( rad(iy,ix).ge.0.0 .and. any(DQF(iy,ix).eq.(/0,1/)) ) then + do ix=xs, xe +write(stdout,fmt=*) 'TEST54', ix + do iy=ys, ye + if ( radmask(iy,ix) ) then + if( rad(iy,ix).ge.0.0 .and. any(DQF(iy,ix).eq.(/0,1/)) ) then bt(iy,ix)=(fk2/(alog((fk1/rad(iy,ix))+1.))-bc1)/bc2 + else radmask(iy,ix) = .true. end if end if end do end do -#ifdef DM_PARALLEL - call mpi_barrier(comm, ierr) -#endif +!#ifdef DM_PARALLEL +! call mpi_barrier(comm, ierr) +!#endif ierr=nf_close(ncid) call handle_err('Error closing file',ierr) - end subroutine get_abil1b_bt subroutine get_abil1b_latlon(yy,xx,req,rpol,hh,nam,lat,lon) -implicit none - real::yy,xx,lat,lon,lat1,lon1 - real::aa,bb,cc,rs,sx,sy,sz - real*8::req,rpol,hh,nam - real*8,parameter::pi=3.1415926535898D0 + implicit none + + real, intent(in) :: yy, xx + real, intent(in) :: req, rpol, hh, nam + real, intent(inout) :: lat,lon + + real :: lat1,lon1 + real :: aa,bb,cc,rs,sx,sy,sz + real :: radicand + aa=sin(xx)**2+cos(xx)**2*(cos(yy)**2+req**2/rpol**2*sin(yy)**2) bb=-2.D0*hh*cos(xx)*cos(yy) cc=hh**2-req**2 - rs=(-bb-sqrt(bb**2-4.D0*aa*cc))/(2.D0*aa) + + radicand = bb**2 - 4.D0*aa*cc + if (radicand .lt. 0.) return + + rs=(-bb-sqrt(radicand))/(2.D0*aa) sx=rs*cos(xx)*cos(yy) sy=-rs*sin(xx) sz=rs*cos(xx)*sin(yy) @@ -1516,14 +1890,142 @@ implicit none lat=lat1*180.D0/pi lon=lon1*180.D0/pi -! print*,hh,rpol,hh -! print*,aa,bb,cc,rs -! print*,aa,bb,cc,rs,sx,sy,sz -! print*,'aaa',lat,lon -! pause end subroutine get_abil1b_latlon +subroutine split_grid( ny_global, nx_global, & + ny_local, nx_local, & + ys_local, xs_local, & + redist ) + + implicit none + + integer, intent(in) :: ny_global, nx_global + logical, intent(in) :: redist + integer, intent(out) :: ny_local, nx_local, & + ys_local, xs_local + + integer, target :: ny_grid(ntasks_y), ys_grid(ntasks_y) !, ye_grid(ntasks_y) + integer, target :: nx_grid(ntasks_x), xs_grid(ntasks_x) !, xe_grid(ntasks_x) + integer, pointer :: ngrid(:), sgrid(:) + + integer :: mm, i, j, iproc, ig, ntasks, nglobal + +write(stdout,fmt=*) 'TEST55' + + do ig = 1, 2 + if (ig.eq.1) then + ngrid => ny_grid + sgrid => ys_grid + ntasks = ntasks_y + nglobal = ny_global + else if (ig.eq.2) then + ngrid => nx_grid + sgrid => xs_grid + ntasks = ntasks_x + nglobal = nx_global + end if + + ngrid = nglobal / ntasks + mm = mod( nglobal , ntasks ) + do j = 1, ntasks + ngrid(j) = ngrid(j) + 1 + mm = mm - 1 + if (mm .eq. 0) exit + end do + + if (redist) then + !Redistribute grid from middle to edges to balance load + ! for da_llxy in get_abil1b_grid + do i = 1, 2 + if (mod(ntasks,2).eq.0) then + do j = ntasks/2, 2, -1 + mm = ngrid(j) / 6 + ngrid(j) = ngrid(j) - mm + ngrid(j-1) = ngrid(j-1) + mm + end do + do j = ntasks/2+1, ntasks-1 + mm = ngrid(j) / 6 + ngrid(j) = ngrid(j) - mm + ngrid(j+1) = ngrid(j+1) + mm + end do + else + do j = ntasks/2+1, 2, -1 + mm = ngrid(j) / 6 + mm = mm/2 + ngrid(j) = ngrid(j) - 2*mm + ngrid(j-1) = ngrid(j-1) + mm + ngrid(ntasks-j+2) = ngrid(ntasks-j+2) + mm + end do + end if + end do + end if + + sgrid(1) = 1 + do j = 1, ntasks_y +! if (j .eq. 1) egrid(1) = ngrid(1) !NOT NECESSARY + if (j .lt. ntasks) then + sgrid(j+1) = sgrid(j) + ngrid(j) +! egrid(j+1) = egrid(j) + ngrid(j+1) !NOT NECESSARY + end if + end do + end do + +! nx_grid = nx_global / ntasks_x +! mm = mod( nx_global , ntasks_x ) +! do i = 1, ntasks_x +! if (mm .gt. 0) then +! nx_grid(i) = nx_grid(i) + 1 +! mm = mm - 1 +! end if +! end do +! +! xs_grid(1) = 1 +! do i = 1, ntasks_x +! if (mm .gt. 0) then +! nx_grid(i) = nx_grid(i) + 1 +! mm = mm - 1 +! end if +! if (i .eq. 1) xe_grid(1) = nx_grid(1) !NOT NECESSARY +! if (i .lt. ntasks_x) then +! xs_grid(i+1) = xs_grid(i) + nx_grid(i) +! xe_grid(i+1) = xe_grid(i) + nx_grid(i+1) !NOT NECESSARY +! end if +! end do + +write(stdout,fmt=*) 'TEST56' + + j = myproc / ntasks_y + 1 + i = mod(myproc, ntasks_x) + 1 + ny_local = ny_grid(j) + ys_local = ys_grid(j) + nx_local = nx_grid(i) + xs_local = xs_grid(i) + +write(stdout,fmt=*) 'TEST57', myproc, j, i + +! iproc = 0 +! do j = 1, ntasks_y +! do i = 1, ntasks_x +!write(stdout,fmt=*) 'TEST58' +! if (iproc .eq. myproc) then +!write(stdout,fmt=*) 'TEST59', iproc, j, i +! +! ny_local = ny_grid(j) +! ys_local = ys_grid(j) +! +! nx_local = nx_grid(i) +! xs_local = xs_grid(i) +! +! exit +! end if +! iproc = iproc + 1 +! end do +! if (iproc .eq. myproc) exit +! end do + +end subroutine split_grid + !subroutine j2000day2cal(j2000,yr,mt,dy,hr,mn,sc) ! ! Converts J2000 epoch day to Gregorian calender date ! ! source: David G. Simpson, NASA Goddard, Accessed April 2018 From 6ad8fccf197a214bfa3ca557bcc124fc5b586118 Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Wed, 16 May 2018 20:23:41 -0600 Subject: [PATCH 04/86] Significant modifications to improve flow in GOES-ABI reading +moved obs locations for each view to this_obslist linked list +modified da_llxy to allow for determination of "outside" cheaply for large data sets and processor counts --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 1130 ++++++------------ var/da/da_tools/da_llxy.inc | 83 +- 2 files changed, 405 insertions(+), 808 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 836e16504a..4b6bd66f68 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -39,52 +39,52 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: ny_global, nx_global integer :: yoff_fd, xoff_fd ! For MPI parallelization - integer :: nrad_locals(num_procs) - integer :: ny_local, ny_locals(num_procs) - integer :: nx_local, nx_locals(num_procs) - integer :: ys_local, ys_locals(num_procs) - integer :: xs_local, xs_locals(num_procs) + integer :: nrad_mask, nrad_buf + integer :: ny_local, nx_local + integer :: ys_local, xs_local !! Earth location info + real, allocatable :: yy(:), xx(:) real(r_kind) :: req, rpol, pph, nam !!! real :: lat_sat, lon_sat ! Assume fixed values in da_get_satzen - real, allocatable, target :: buf_real(:,:,:) - real, pointer :: lat(:,:), lon(:,:), satzen(:,:) - - !! Masks for data reduction - logical, allocatable, target :: buf_logical(:,:,:) - logical, pointer :: & - earthmask(:,:) , & - zenmask(:,:) , & - domainmask(:,:) , & - patchmask(:,:) , & + real, allocatable, target :: buf_real(:,:) + integer, allocatable, target :: buf_int(:,:) + + + ! Temporary data fields for assigning radiance locations to local patches + type data_field + real, pointer :: local_r(:,:) + real, pointer :: mask_r(:) + real, pointer :: remote_r(:) + integer, pointer :: local_i(:,:) + integer, pointer :: mask_i(:) + integer, pointer :: remote_i(:) + end type data_field + + type(data_field) :: lat_f, lon_f, satzen_f, & + modj_f, modi_f, & + obsj_f, obsi_f + + ! Masks for data reduction + logical, allocatable :: & allmask_patch(:,:) , & + allmask_local(:,:) , & + earthmask(:,:), zenmask(:,:), domainmask(:,:), & thinmask(:,:) -! integer(kind=1), allocatable :: view_mask(:,:,:,:) logical, allocatable :: view_mask(:,:,:,:,:) logical :: use_view_mask, best_view - !! Brightness Temperature (K) - real, allocatable :: bt(:,:) -!!! !! Temporary, only used for data I/O -!!! character(len=100) :: prefix="" -!!! character(len=10) :: nxthin -!!! logical :: print_grid = .false., & -!!! print_view = .false., & -!!! print_bt = .false. + ! Brightness Temperature (K) + real, allocatable :: bt_patch(:,:) !! Iterates - integer :: ichan, ifile, iview, ikeep, ifgat, ipass, ioff, & - jchan, jfile, jview, jkeep, & + integer :: ichan, ifile, iview, ifgat, ipass, ioff, & + jchan, jfile, jview, & n, i, j, iy, ix, iyl, ixl, iproc -! !! Thinning Variables, need to replace with applicable WRFDA ones -! integer, parameter :: xthin=1 -! integer, parameter :: ythin=1 - !! Satellite variables integer(i_kind),parameter :: nchan = 10 integer(i_kind),parameter :: nscan = 22 @@ -104,18 +104,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) type date_type integer :: yr, mt, dy, hr, mn, sc - end type - - type viewgrid - real, allocatable :: & - lat(:,:), lon(:,:), satzen(:,:) - logical, allocatable :: & - earthmask(:,:), zenmask(:,:), & - patchmask(:,:), domainmask(:,:) - integer, allocatable :: & - iy_global(:), ix_global(:) - end type viewgrid + end type date_type + ! Linked list type for radiance location information type viewlist real :: lat, lon, satzen integer :: iy, ix @@ -142,7 +133,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: ys_patch_fd, xs_patch_fd integer :: ye_patch_fd, xe_patch_fd integer :: nrad_on_patch, nrad_on_domain - type(viewgrid) :: obsgrid + logical, allocatable :: patchmask(:,:) type(viewlist), pointer :: head type(viewlist), pointer :: current character(len=2) :: name_short @@ -152,9 +143,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) type(viewinfo), target, allocatable :: view_att(:) type(viewinfo), pointer :: this_view - type(viewgrid), pointer :: this_obsgrid type(viewlist), pointer :: this_obslist -! type(viewgrid) :: tmp_grid(num_procs) integer :: first_file, tot_files_used, npass integer :: ncid, varid @@ -164,13 +153,11 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !Could populate using .info file. Would reduce number of files to read... integer, dimension(10) :: channel_select = (/7, 8, 9, 10, 11, 12, 13, 14, 15, 16/) -!!! ! Global WRFDA obs timing info + ! Global WRFDA obs timing info character(len=19) :: fgat_times_c(num_fgat_time) real(r_kind) :: fgat_times_r(num_fgat_time) -!!! real(r_kind) :: dt_fgat(2) ! (seconds) ! Local Obs date/time variables -!!! real(r_kind) :: j2000, j2000_fgat(num_fgat_time) real(r_kind) :: obs_time integer(i_kind) :: yr, mt, dy, hr, mn, sc, jdy real(r_kind) :: timbdy(2) @@ -237,61 +224,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) write(unit=fgat_times_c(ifgat), & fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc - end do -!!! !! UPDATE THIS FOR VARIABLES AVAILABLE IN WRFDA -!!! !! Establish fgat j2000day for later comparisons -!!! fgat_time = analysis_date(1:19) -!!! read(fgat_time(1:4),fmt='(I4)') yr -!!! read(fgat_time(6:7),fmt='(I2.2)') mt -!!! read(fgat_time(9:10),fmt='(I2.2)') dy -!!! read(fgat_time(12:13),fmt='(I2.2)') hr -!!! read(fgat_time(15:16),fmt='(I2.2)') mn -!!! read(fgat_time(18:19),fmt='(I2.2)') sc -!!! call cal2j2000day(j2000_fgat(1),yr,mt,dy,hr,mn,sc) -! -!!! if ( var4d ) then -!!! dt_fgat(1) = - real(var4d_bin, 8) -!!! dt_fgat(2) = real(var4d_bin, 8) -! -!!! do ifgat = 2, num_fgat_time -!!! if (ifgat .lt. num_fgat_time) then -!!! j2000 = j2000_fgat(ifgat-1) + dt_fgat(2) / 86400.D0 -!!! call j2000day2cal(j2000,yr,mt,dy,hr,mn,sc) -!!! end if -! -!!! write(unit=fgat_times(ifgat), & -!!! fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & -!!! yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc -! -!!! call cal2j2000day(j2000_fgat(ifgat),yr,mt,dy,hr,mn,sc) -!!! end do -!!! else -!!! fgat_time = time_window_min(1:19) -!!! read(fgat_time(1:4),fmt='(I4)') yr -!!! read(fgat_time(6:7),fmt='(I2.2)') mt -!!! read(fgat_time(9:10),fmt='(I2.2)') dy -!!! read(fgat_time(12:13),fmt='(I2.2)') hr -!!! read(fgat_time(15:16),fmt='(I2.2)') mn -!!! read(fgat_time(18:19),fmt='(I2.2)') sc -!!! call cal2j2000day(j2000,yr,mt,dy,hr,mn,sc) -!!! dt_fgat(1) = (j2000 - j2000_fgat(1)) * 86400. * 2. -! -!!! fgat_time = time_window_max(1:19) -!!! read(fgat_time(1:4),fmt='(I4)') yr -!!! read(fgat_time(6:7),fmt='(I2.2)') mt -!!! read(fgat_time(9:10),fmt='(I2.2)') dy -!!! read(fgat_time(12:13),fmt='(I2.2)') hr -!!! read(fgat_time(15:16),fmt='(I2.2)') mn -!!! read(fgat_time(18:19),fmt='(I2.2)') sc -!!! call cal2j2000day(j2000,yr,mt,dy,hr,mn,sc) -!!! dt_fgat(2) = (j2000 - j2000_fgat(2)) * 86400. * 2. -! -!!! end if -!!! write(unit=stdout, fmt='(A)') 'num_fgat, j2000_fgat = ' -!!! write(unit=stdout, fmt='(F18.1)') num_fgat_time, j2000_fgat - allocate(view_att(nviews)) view_att(:)%select = .true. ! Need to set this according to namelist entries view_att(1)%name_short = 'F' @@ -344,7 +278,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !! Loop over the available views for this instrument (ABI) do iview = 1, nviews this_view => view_att(iview) - this_obsgrid => view_att(iview)%obsgrid !Initialize linked list for obs in this view if (ipass .eq. 1) then @@ -387,7 +320,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if #ifdef DM_PARALLEL call mpi_barrier(comm, ierr) -!!! call wrf_dm_bcast_integer(i_dummy, 1) call mpi_bcast ( i_dummy, 1, mpi_integer, root, comm, ierr ) this_view%nfiles = i_dummy(1) #endif @@ -410,9 +342,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) allocate(this_view%min_time_diff(nchan,num_fgat_time)) allocate(this_view%nfiles_used(num_fgat_time)) -!!! this_view%file_fgat_match = .true. this_view%file_fgat_match = .false. -!!! this_view%fgat_time_diff = max(dt_fgat(1),dt_fgat(2)) do ifgat=1,num_fgat_time this_view%fgat_time_diff(:,ifgat) = & (time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 !seconds @@ -421,8 +351,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) (time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 / 2.D0 !seconds end do -!!! this_view%min_time_diff = max(dt_fgat(1),dt_fgat(2)) / 2.D0 - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Determine which of the files will be used based on user-definitions: !! + fgat window length @@ -469,7 +397,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc call jday2cal(jdy, yr, mt, dy) -!!! call cal2j2000day(timbdy(1),yr,mt,dy,hr,mn,sc) call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(1)) !obs END time @@ -480,10 +407,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc call jday2cal(jdy, yr, mt, dy) -!!! call cal2j2000day(timbdy(2),yr,mt,dy,hr,mn,sc) call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(2)) -!!! j2000=(timbdy(1) + timbdy(2)) / 2.D0 obs_time=(timbdy(1) + timbdy(2)) / 2.D0 obs_time = obs_time + real(sc,8)/60.D0 @@ -495,9 +420,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !!! ierr=nf_close(ncid) !!! j2000=(timbdy(1) + timbdy(2)) / 2.D0 /86400.D0 - -!!! call j2000day2cal(j2000,yr,mt,dy,hr,mn,sc) - call da_get_cal_time(obs_time,yr,mt,dy,hr,mn,sc) obs_time = obs_time * 60.D0 @@ -508,32 +430,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) this_view%filedate(ifile)%mn = mn this_view%filedate(ifile)%sc = sc -!!! ! Compare this file j2000day to all fgat window j2000day's -!!! do ifgat = 1, num_fgat_time -!!! this_view%fgat_time_diff(ifile,ifgat) = 86400.D0 * (j2000 - j2000_fgat(ifgat)) -! -!!! write(unit=stdout, fmt='(F18.1)') this_view%fgat_time_diff(ifile,ifgat) -! -!!! if ( this_view%fgat_time_diff(ifile,ifgat) .lt. dt_fgat(1)/2. .or. & -!!! this_view%fgat_time_diff(ifile,ifgat) .gt. dt_fgat(2)/2. ) then -! -!!! this_view%file_fgat_match(ifile,ifgat) = .false. -!!! cycle -!!! end if -!!! call get_ichan(this_view%filechan(ifile), channel_list, nchan, ichan) -! -!!! ! Determine minimum time difference between this obs bin and available files for this view -!!! if ( abs(this_view%fgat_time_diff(ifile, ifgat)) .ge. this_view%min_time_diff(ichan, ifgat) ) then -!!! this_view%file_fgat_match(ifile,ifgat) = .false. -!!! exit -!!! else -!!! this_view%min_time_diff(ichan, ifgat) = abs(this_view%fgat_time_diff(ifile, ifgat)) -!!! end if -!!! end do - -!!! Eliminates need for j2000_fgat(ifgat), j2000day2cal, cal2j2000day, uses internal WRFDA timing subroutines + da_get_cal_time -!!! Using julian time precise to seconds due to MESO - if ( obs_time < time_slots(0) * 60.D0 .or. & obs_time >= time_slots(num_fgat_time) * 60.D0 ) then cycle @@ -585,7 +481,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) write(unit=stdout,fmt='(2A)') & ' ',fgat_times_c(ifgat) -!! if ( ipass .eq. 1 .and. (npass.gt.1 .or. count(this_view%file_fgat_match(:, ifgat)).gt.1) ) then if ( ipass .eq. 1 .and. count(this_view%file_fgat_match(:, ifgat)).gt.1 ) then ! Select a single file for this view, channel, and fgat @@ -650,22 +545,11 @@ write(stdout,fmt=*) 'ny_local, nx_local, ys_local, xs_local = ', & write(stdout,fmt=*) 'TEST4' end if + + ! Recall global dims for this_view ny_global = this_view%ny_global nx_global = this_view%nx_global - ! Recall local dims - ny_local = this_view%ny_local - nx_local = this_view%nx_local - ys_local = this_view%ys_local - xs_local = this_view%xs_local - -#ifdef DM_PARALLEL - call mpi_allgather(ny_local,1,mpi_integer,ny_locals,1,mpi_integer,comm,ierr) - call mpi_allgather(nx_local,1,mpi_integer,nx_locals,1,mpi_integer,comm,ierr) - call mpi_allgather(ys_local,1,mpi_integer,ys_locals,1,mpi_integer,comm,ierr) - call mpi_allgather(xs_local,1,mpi_integer,xs_locals,1,mpi_integer,comm,ierr) -#endif - write(stdout,fmt=*) 'TEST5' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -689,40 +573,16 @@ write(stdout,fmt=*) 'TEST6' write(unit=stdout,fmt='(2A)') & ' Reading abi grid info for ',trim(this_view%name) - !! Allocate local spatial information for this view - if (allocated(this_obsgrid%lat)) deallocate(this_obsgrid%lat) - if (allocated(this_obsgrid%lon)) deallocate(this_obsgrid%lon) - if (allocated(this_obsgrid%satzen)) deallocate(this_obsgrid%satzen) - allocate(this_obsgrid%lat(ny_local,nx_local)) - allocate(this_obsgrid%lon(ny_local,nx_local)) - allocate(this_obsgrid%satzen(ny_local,nx_local)) - - !! Allocate local mask information for this view - if (allocated(this_obsgrid%earthmask)) deallocate(this_obsgrid%earthmask) - if (allocated(this_obsgrid%zenmask)) deallocate(this_obsgrid%zenmask) - if (allocated(this_obsgrid%domainmask)) deallocate(this_obsgrid%domainmask) - allocate(this_obsgrid%earthmask(ny_local,nx_local)) - allocate(this_obsgrid%zenmask(ny_local,nx_local)) - allocate(this_obsgrid%domainmask(ny_local,nx_local)) - -write(stdout,fmt=*) sizeof(this_obsgrid%lat), size(this_obsgrid%lat) -write(stdout,fmt=*) sizeof(this_obsgrid%lon), size(this_obsgrid%lon) -write(stdout,fmt=*) sizeof(this_obsgrid%satzen), size(this_obsgrid%satzen) - -write(stdout,fmt=*) 'TEST7' - - call get_abil1b_grid( fname, & - ny_global, nx_global, & - ny_local, nx_local, & - ys_local, xs_local, & - req, rpol, pph, nam, satellite_id, & - this_obsgrid%lat, this_obsgrid%lon, this_obsgrid%satzen, & - this_obsgrid%earthmask, & - this_obsgrid%zenmask, & - this_obsgrid%domainmask, & - this_view%yoff_fd, this_view%xoff_fd ) -write(stdout,fmt=*) 'TEST8' + !================================================== + ! Establish GOES metadata for this view and ifgat + !================================================== + allocate( yy(ny_global) ) + allocate( xx(nx_global) ) + call get_abil1b_grid1( fname, & + ny_global, nx_global, & + yy, xx, & + this_view%yoff_fd, this_view%xoff_fd ) if ( iview.eq.1 ) then yoff_fd = this_view%yoff_fd @@ -736,21 +596,101 @@ write(stdout,fmt=*) 'TEST8' ! this_view%xoff_fd = this_view%xoff_fd - xoff_fd + 1 end if - !====================================================== - ! Reduce the obsgrid to vectors of lat, lon, zenith - ! for locations on this WRF patch - !====================================================== +write(stdout,fmt=*) 'TEST8' - ! Setup patch mask for this view - allocate(this_obsgrid%patchmask(ny_global,nx_global)) - patchmask => this_obsgrid%patchmask - patchmask = .false. +!Currently load balancing is a good start, but not very effective (see split_grid) +!Is there some way to subdivide the grid into smaller pieces and process in a round-robin fashion? Would need to send messages between processors to keep track of subsections that were already processed. Fields would need to be more flexible than simple 2d/1d arrays, possibly linked lists. - this_view%nrad_on_domain = 0 - nrad_locals = 0 +!This allocation and subroutine are entirely independent for specified local segments +!BEGIN PARALLEL SECTION + + !========================================== + ! Establish fields for local subset of + ! radiance locations in this view + !========================================== + ! Recall local dims for this_view + ny_local = this_view%ny_local + nx_local = this_view%nx_local + ys_local = this_view%ys_local + xs_local = this_view%xs_local + + !! Allocate local obs spatial fields for this view + allocate(lat_f%local_r(ny_local,nx_local)) + allocate(lon_f%local_r(ny_local,nx_local)) + allocate(satzen_f%local_r(ny_local,nx_local)) + allocate(obsj_f%local_i(ny_local,nx_local)) + allocate(obsi_f%local_i(ny_local,nx_local)) + + !! Allocate local mask fields for this view + allocate(earthmask(ny_local,nx_local)) + allocate(zenmask(ny_local,nx_local)) + + !! Allocate local model-specific fields + allocate(modj_f%local_i(ny_local,nx_local)) + allocate(modi_f%local_i(ny_local,nx_local)) + allocate(domainmask(ny_local,nx_local)) + + do iy = 1, ny_local + obsj_f%local_i(iy,:) = iy + end do + do ix = 1, nx_local + obsi_f%local_i(:,ix) = ix + end do + + call get_abil1b_grid2( ny_global, nx_global, ny_local, nx_local, ys_local, xs_local, & + yy, xx, req, rpol, pph, nam, satellite_id, & + lat_f%local_r, lon_f%local_r, satzen_f%local_r, & + earthmask, zenmask, & + modj_f%local_i, modi_f%local_i, domainmask) + + +write(stdout,fmt=*) 'TEST8' + + + !========================================================== + ! Reduce local locations using all available masks + !========================================================== write(stdout,fmt=*) 'TEST9' + allocate(allmask_local(ny_local,nx_local)) + allmask_local = & + (earthmask .and. zenmask .and. domainmask) + + nrad_mask = count( allmask_local ) + + allocate( lat_f%mask_r (nrad_mask) ) + allocate( lon_f%mask_r (nrad_mask) ) + allocate( satzen_f%mask_r (nrad_mask) ) + allocate( modj_f%mask_i (nrad_mask) ) + allocate( modi_f%mask_i (nrad_mask) ) + allocate( obsj_f%mask_i (nrad_mask) ) + allocate( obsi_f%mask_i (nrad_mask) ) + + lat_f%mask_r = pack( lat_f%local_r , allmask_local ) + lon_f%mask_r = pack( lon_f%local_r , allmask_local ) + satzen_f%mask_r = pack( satzen_f%local_r , allmask_local ) + modj_f%mask_i = pack( modj_f%local_i , allmask_local ) + modi_f%mask_i = pack( modi_f%local_i , allmask_local ) + obsj_f%mask_i = pack( obsj_f%local_i , allmask_local ) + obsi_f%mask_i = pack( obsi_f%local_i , allmask_local ) + + deallocate( lat_f%local_r, lon_f%local_r, satzen_f%local_r ) + deallocate( modj_f%local_i, modi_f%local_i ) + deallocate( allmask_local, earthmask, zenmask ) + deallocate( obsj_f%local_i, obsi_f%local_i, domainmask ) + +!END PARALLEL SECTION + + + deallocate( yy, xx ) + + + !======================================================= + ! Reduce all masked locations (local and remote) + ! to linked list within this WRF patch (this_obslist) + !======================================================= + ! Destroy this_obslist if it was previously populated if (this_obslist%i .gt. 0) then n = this_obslist%i @@ -766,223 +706,106 @@ write(stdout,fmt=*) 'TEST9' this_obslist => view_att(iview)%head end if + ! Setup global patch mask for this view + allocate(this_view%patchmask(ny_global,nx_global)) + this_view%patchmask = .false. + this_view%nrad_on_domain = 0 + write(stdout,fmt=*) 'TEST10' - - do iproc = 0, num_procs-1 - ny_local = ny_locals(iproc+1) - nx_local = nx_locals(iproc+1) - ys_local = ys_locals(iproc+1) - xs_local = xs_locals(iproc+1) -write(stdout,fmt=*) 'TEST11', iproc + do iproc = 0, num_procs-1 + nrad_buf = nrad_mask #ifdef DM_PARALLEL - !BCAST LOCAL SEGMENTS OF EARTHMASK, ZENMASK, DOMAINMASK - allocate( buf_logical(ny_local,nx_local,3) ) - if (iproc .eq. myproc) then - buf_logical(:,:,1) = this_obsgrid%earthmask - buf_logical(:,:,2) = this_obsgrid%zenmask - buf_logical(:,:,3) = this_obsgrid%domainmask - else - buf_logical = .false. - end if -write(stdout,fmt=*) 'TEST12' - - call mpi_bcast(buf_logical, ny_local * nx_local * 3, mpi_logical, & - iproc, comm, ierr ) -write(stdout,fmt=*) 'TEST13' - - earthmask => buf_logical(:,:,1) - zenmask => buf_logical(:,:,2) - domainmask => buf_logical(:,:,3) -#else - earthmask => this_obsgrid%earthmask - zenmask => this_obsgrid%zenmask - domainmask => this_obsgrid%domainmask + call mpi_bcast(nrad_buf, 1, mpi_integer, iproc, comm, ierr ) #endif -write(stdout,fmt=*) 'TEST14', count(earthmask .and. domainmask .and. zenmask) - - !Ignore observations that are off-earth, off-domain, or breaking zenith limit - if (count(earthmask .and. domainmask .and. zenmask) .eq. 0) then #ifdef DM_PARALLEL - deallocate(buf_logical) + call mpi_barrier(comm, ierr) #endif - cycle - end if -write(stdout,fmt=*) 'TEST15' + if (nrad_buf .eq. 0) cycle -!#ifdef DM_PARALLEL -! call mpi_barrier(comm, ierr) -!#endif +write(stdout,fmt=*) 'TEST14', nrad_buf + + !BCAST REMOTE MASKED FIELDS FOR PROCESSING + allocate( buf_real( nrad_buf, 3 ) ) + allocate( buf_int( nrad_buf, 4 ) ) -#ifdef DM_PARALLEL - !BCAST LOCAL SEGMENTS OF LAT, LON, SATZEN - allocate( buf_real(ny_local,nx_local,3) ) if (iproc .eq. myproc) then - buf_real(:,:,1) = this_obsgrid%lat - buf_real(:,:,2) = this_obsgrid%lon - buf_real(:,:,3) = this_obsgrid%satzen + buf_real(:,1) = lat_f%mask_r + buf_real(:,2) = lon_f%mask_r + buf_real(:,3) = satzen_f%mask_r + buf_int (:,1) = modj_f%mask_i + buf_int (:,2) = modi_f%mask_i + buf_int (:,3) = obsj_f%mask_i + buf_int (:,4) = obsi_f%mask_i else - buf_real = 0.0 + buf_real = missing_r + buf_int = missing end if - call mpi_bcast(buf_real, ny_local * nx_local * 3, true_mpi_real, & - iproc, comm, ierr ) - lat => buf_real(:,:,1) - lon => buf_real(:,:,2) - satzen => buf_real(:,:,3) -#else - lat => this_obsgrid%lat - lon => this_obsgrid%lon - satzen => this_obsgrid%satzen +#ifdef DM_PARALLEL + call mpi_bcast(buf_real, nrad_buf * 3, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast(buf_int, nrad_buf * 4, mpi_integer, iproc, comm, ierr ) #endif -write(stdout,fmt=*) 'TEST16' - !Populate patchmask with on/off patch test for each local set of obs - do ixl = 1, nx_local - ix = ixl + xs_local - 1 -write(stdout,fmt=*) 'TEST17', ix +write(stdout,fmt=*) 'TEST11', iproc - do iyl = 1, ny_local - if (earthmask(iyl,ixl) .and. domainmask(iyl,ixl) .and. zenmask(iyl,ixl)) then - iy = iyl + ys_local - 1 + lat_f%remote_r => buf_real(:,1) + lon_f%remote_r => buf_real(:,2) + satzen_f%remote_r => buf_real(:,3) + modj_f%remote_i => buf_int(:,1) + modi_f%remote_i => buf_int(:,2) + obsj_f%remote_i => buf_int(:,3) + obsi_f%remote_i => buf_int(:,4) - this_view%nrad_on_domain = this_view%nrad_on_domain + 1 + this_view%nrad_on_domain = this_view%nrad_on_domain + nrad_buf + do n = 1, nrad_buf #ifdef DM_PARALLEL - info%lat = lat(iyl,ixl) ! latitude - info%lon = lon(iyl,ixl) ! longitude - call da_llxy (info, loc, outside) - patchmask(iy,ix) = .not.outside -#else - patchmask(iy,ix) = .true. + loc%j = modj_f%remote_i(n) + loc%i = modi_f%remote_i(n) + call da_llxy (info, loc, outside, patch_test_only = .true.) + if (outside) cycle #endif + iy = obsj_f%remote_i(n) + ix = obsi_f%remote_i(n) + this_view%patchmask(iy,ix) = .true. + allocate(this_obslist%next) + i = this_obslist%i + this_obslist => this_obslist%next + this_obslist%i = i + 1 + this_obslist%lat = lat_f%remote_r(n) + this_obslist%lon = lon_f%remote_r(n) + this_obslist%satzen = satzen_f%remote_r(n) + this_obslist%iy = iy + this_obslist%ix = ix - if (patchmask(iy,ix)) then - nrad_locals(iproc+1) = nrad_locals(iproc+1) + 1 -write(stdout,fmt=*) 'TEST18', iy, iproc, nrad_locals(iproc+1) +write(stdout,fmt=*) 'TEST18', iy, iproc, this_obslist%i - i = this_obslist%i - allocate(this_obslist%next) - this_obslist => this_obslist%next - this_obslist%i = i + 1 - this_obslist%lat = lat(iyl,ixl) - this_obslist%lon = lon(iyl,ixl) - this_obslist%satzen = satzen(iyl,ixl) - this_obslist%ix = ix - this_obslist%iy = iy + end do -!Is there some way to send a message to other processors not to test this point?? -!Would also need to ensure that each processor is testing in a randomized order such that the fewest points get tested in total... -!What about round-robin testing, where each process is working on a different subsection of the grid at the same time. Then they modify a subsection of a global obs_used_mask before the next process sees that subsection... + deallocate( buf_real, buf_int) - end if - end if - end do - end do +write(stdout,fmt=*) 'TEST19', iproc, this_obslist%i -write(stdout,fmt=*) 'TEST19', iproc, nrad_locals(iproc+1) - -! if (nrad_locals(iproc+1) .gt. 0) then -! ! Allocate local transition data vectors -! allocate(tmp_grid(iproc+1)%lat(nrad_locals(iproc+1),1)) -! allocate(tmp_grid(iproc+1)%lon(nrad_locals(iproc+1),1)) -! allocate(tmp_grid(iproc+1)%satzen(nrad_locals(iproc+1),1)) -! allocate(tmp_grid(iproc+1)%ix_global(nrad_locals(iproc+1))) -! allocate(tmp_grid(iproc+1)%iy_global(nrad_locals(iproc+1))) -write(stdout,fmt=*) 'TEST20' - -! ikeep = 0 -! do ixl = 1, nx_local -! ix = ixl + xs_local - 1 -! do iyl = 1, ny_local -! iy = iyl + ys_local - 1 -! if (patchmask(iy,ix)) then -! ikeep = ikeep + 1 -! tmp_grid(iproc+1)%lat(ikeep,1) = lat(iyl,ixl) ! longitude -! tmp_grid(iproc+1)%lon(ikeep,1) = lon(iyl,ixl) ! longitude -! tmp_grid(iproc+1)%satzen(ikeep,1) = satzen(iyl,ixl) ! zenith -! tmp_grid(iproc+1)%ix_global(ikeep) = ix -! tmp_grid(iproc+1)%iy_global(ikeep) = iy -! end if -! end do -! end do -! end if -#ifdef DM_PARALLEL - deallocate( buf_logical ) - deallocate( buf_real ) -#endif - nullify( earthmask ) - nullify( zenmask ) - nullify( domainmask ) - nullify( lat ) - nullify( lon ) - nullify( satzen ) end do -write(stdout,fmt=*) 'TEST21' + deallocate( lat_f%mask_r, lon_f%mask_r, satzen_f%mask_r, modj_f%mask_i, modi_f%mask_i, obsj_f%mask_i, obsi_f%mask_i) + + this_view%nrad_on_patch = this_obslist%i -!THESE MAY NOT BE NEEDED AGAIN - ny_local = this_view%ny_local - nx_local = this_view%nx_local - ys_local = this_view%ys_local - xs_local = this_view%xs_local -!THESE MAY NOT BE NEEDED AGAIN - - deallocate( this_obsgrid%lat ) - deallocate( this_obsgrid%lon ) - deallocate( this_obsgrid%satzen ) - deallocate( this_obsgrid%earthmask ) - deallocate( this_obsgrid%zenmask ) - deallocate( this_obsgrid%domainmask ) -write(stdout,fmt=*) 'TEST22' - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! Place retained data in single vector for each parameter -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - this_view%nrad_on_patch = sum(nrad_locals) if ( this_view%nrad_on_patch.gt.0 ) then -! -! allocate( this_obsgrid%lat(this_view%nrad_on_patch,1) ) -! allocate( this_obsgrid%lon(this_view%nrad_on_patch,1) ) -! allocate( this_obsgrid%satzen(this_view%nrad_on_patch,1) ) -! -! if (allocated(this_obsgrid%ix_global)) deallocate(this_obsgrid%ix_global) -! if (allocated(this_obsgrid%iy_global)) deallocate(this_obsgrid%iy_global) -! allocate( this_obsgrid%ix_global(this_view%nrad_on_patch) ) -! allocate( this_obsgrid%iy_global(this_view%nrad_on_patch) ) -!write(stdout,fmt=*) 'TEST23' -! -! jkeep = 0 -! do iproc = 0, num_procs-1 -! if (nrad_locals(iproc+1) .gt. 0) then -! ikeep = jkeep + 1 -! jkeep = ikeep + nrad_locals(iproc+1) - 1 -! -! this_obsgrid%lat(ikeep:jkeep,1) = tmp_grid(iproc+1)%lat(:,1) -! this_obsgrid%lon(ikeep:jkeep,1) = tmp_grid(iproc+1)%lon(:,1) -! this_obsgrid%satzen(ikeep:jkeep,1) = tmp_grid(iproc+1)%satzen(:,1) -! this_obsgrid%ix_global(ikeep:jkeep) = tmp_grid(iproc+1)%ix_global(:) -! this_obsgrid%iy_global(ikeep:jkeep) = tmp_grid(iproc+1)%iy_global(:) -! -! deallocate(tmp_grid(iproc+1)%lat) -! deallocate(tmp_grid(iproc+1)%lon) -! deallocate(tmp_grid(iproc+1)%satzen) -! deallocate(tmp_grid(iproc+1)%ix_global) -! deallocate(tmp_grid(iproc+1)%iy_global) -! end if -! end do ! Determine ys & ye for this patch this_view%ys_patch = ny_global this_view%ye_patch = 1 do iy = 1, ny_global - if ( any(patchmask(iy,:)) ) then + if ( any(this_view%patchmask(iy,:)) ) then this_view%ys_patch = iy this_view%ys_patch_fd = iy+this_view%yoff_fd-1 ! offset to FD grid exit end if end do do iy = ny_global, 1, -1 - if ( any(patchmask(iy,:)) ) then + if ( any(this_view%patchmask(iy,:)) ) then this_view%ye_patch = iy this_view%ye_patch_fd = iy+this_view%yoff_fd-1 ! offset to FD grid exit @@ -993,14 +816,14 @@ write(stdout,fmt=*) 'TEST22' this_view%xs_patch = nx_global this_view%xe_patch = 1 do ix = 1, nx_global - if ( any(patchmask(:,ix)) ) then + if ( any(this_view%patchmask(:,ix)) ) then this_view%xs_patch = ix this_view%xs_patch_fd = ix+this_view%xoff_fd-1 ! offset to FD grid exit end if end do do ix = nx_global, 1, -1 - if ( any(patchmask(:,ix)) ) then + if ( any(this_view%patchmask(:,ix)) ) then this_view%xe_patch = ix this_view%xe_patch_fd = ix+this_view%xoff_fd-1 ! offset to FD grid exit @@ -1012,50 +835,15 @@ write(stdout,fmt=*) 'TEST22' write(stdout,fmt=*) 'TEST24' - -write(stdout,fmt=*) 'TEST25' - -!!!! print*,'yoff_fd = ',this_view%yoff_fd -!!!! print*,'xoff_fd = ',this_view%xoff_fd -!!!!!!! START GRID WRITE -!!! if ( ipass .eq. 1 .and. print_grid .and. iview.eq.1) then -!!! write(prefix,fmt='(3A)') & -!!! 'GRID_VIEW',trim(this_view%name_short),'_' -!!! if (iview .gt. 2) prefix = trim(prefix)// & -!!! fgat_times_c(ifgat)//'_' -! -!!! open(unit=31, & -!!! file=trim(prefix)//'lat.dat', & -!!! status='replace') -!!! open(unit=32, & -!!! file=trim(prefix)//'lon.dat', & -!!! status='replace') -!!! open(unit=33, & -!!! file=trim(prefix)//'satzen.dat', & -!!! status='replace') -! -!!! write(nxthin,fmt='(I0)') nx/xthin+1 -!!! do iy=1, ny, ythin -!!! write(31,fmt='('//trim(nxthin)//'F15.6)') lat (iy, 1:nx:xthin) -!!! write(32,fmt='('//trim(nxthin)//'F15.6)') lon (iy, 1:nx:xthin) -!!! write(33,fmt='('//trim(nxthin)//'F15.6)') satzen (iy, 1:nx:xthin) -!!! end do -!!! close(31) -!!! close(32) -!!! close(33) -!!! end if -!!!!!!! END GRID WRITE end if PatchMatch: if (this_view%nrad_on_patch .gt. 0) then write(stdout,fmt=*) 'TEST26' - patchmask => this_obsgrid%patchmask - if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view%nfiles_used(:)).eq.0 ) then allocate(view_mask(& - this_view%ys_patch:this_view%ye_patch, & - this_view%xs_patch:this_view%xe_patch, & + this_view%ys_patch_fd:this_view%ye_patch_fd, & + this_view%xs_patch_fd:this_view%xe_patch_fd, & nchan, num_fgat_time, nviews)) view_mask = .false. @@ -1109,9 +897,6 @@ write(stdout,fmt=*) 'TEST27' end do if ( best_view ) then -! view_mask(this_view%yoff_fd:ny_global+this_view%yoff_fd-1, & -! this_view%xoff_fd:nx_global+this_view%xoff_fd-1, & -! ichan, ifgat, iview) = .true. view_mask(this_view%ys_patch_fd:this_view%ye_patch_fd, & this_view%ys_patch_fd:this_view%ye_patch_fd, & @@ -1119,9 +904,6 @@ write(stdout,fmt=*) 'TEST27' ! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap -! view_mask(this_view%yoff_fd:ny_global+this_view%yoff_fd-1, & -! this_view%xoff_fd:nx_global+this_view%xoff_fd-1, & -! ichan, ifgat, jview) = .false. view_mask(this_view%ys_patch_fd:this_view%ye_patch_fd, & this_view%ys_patch_fd:this_view%ye_patch_fd, & @@ -1131,26 +913,6 @@ write(stdout,fmt=*) 'TEST27' end if -!!!!!!! START VIEW_CHOICE WRITE -!!! if ( this_view%nfiles_used(ifgat).eq.1 .and. print_view .and. iview.eq.nviews) then -!!! write(unit=stdout,fmt='(A)') & -!!! ' printing view_mask' -!!! -!!! write(prefix,fmt='(5A)') & -!!! 'VIEW',trim(this_view%name_short),'_', & -!!! fgat_times_c(ifgat),'_' -!!! -!!! open(unit=30,file=trim(prefix)//& -!!! 'CHOICE.dat',status='replace') -!!! write(nxthin,fmt='(I0)') view_att(1)%nx -!!! -!!! do iy=1, view_att(1)%ny -!!! write(30,fmt='('//trim(nxthin)//'I3)') view_mask (iy, 1:view_att(1)%nx, ichan, ifgat) -!!! end do -!!! -!!! close(30) -!!! end if -!!!!! END VIEW_CHOICE WRITE else if (inst == 0) cycle @@ -1167,7 +929,7 @@ write(stdout,fmt=*) 'TEST27' !! + thinning allocate(allmask_patch(ny_global,nx_global)) - allmask_patch = patchmask + allmask_patch = this_view%patchmask ! Only use locations where this view is nearest to this fgat time ! - only available when FD data present for any fgat time @@ -1199,10 +961,8 @@ write(stdout,fmt=*) 'TEST27' write(unit=stdout,fmt='(2A)') & ' Reading abi radiances: ',trim(fname_short) -!!print*,this_view%fgat_time_diff(ifile,ifgat) - ! Allocate this patch bt - allocate(bt(this_view%ys_patch:this_view%ye_patch, & + allocate(bt_patch(this_view%ys_patch:this_view%ye_patch, & this_view%xs_patch:this_view%xe_patch)) ! This reads in bt only for the local patch, @@ -1211,35 +971,14 @@ write(stdout,fmt=*) 'TEST27' ny_global, nx_global, & this_view%ys_patch, this_view%ye_patch, & this_view%xs_patch, this_view%xe_patch, & - allmask_patch, bt ) - - -!!!!!!! START BT WRITE -!!! if ( ipass .eq. npass .and. print_bt ) then -!!! write(prefix,fmt='(A,I2.2,5A)') & -!!! 'BT_C',this_view%filechan(ifile), & -!!! '_VIEW',trim(this_view%name_short),'_', & -!!! fgat_times_c(ifgat),'_' -!!! -!!! open(unit=30,file=trim(prefix)//'bt.dat',& -!!! status='replace') -!!! write(nxthin,fmt='(I0)') nx/xthin+1 -!!! -!!! do iy=1, ny, ythin -!!! write(30,fmt='('//trim(nxthin)//'F15.6)') bt(iy, 1:nx:xthin) -!!! end do -!!! -!!! close(30) -!!! end if -!!!!! END BT WRITE + allmask_patch, bt_patch ) + !! Write bt, lat, lon, and satzen to datalink structures first_chan = (this_view%nfiles_used(ifgat).eq.1) if (first_chan) then p_fgat => p - allocate(thinmask(ny_global,nx_global)) - thinmask = .false. yr = this_view%filedate(ifile)%yr mt = this_view%filedate(ifile)%mt @@ -1248,39 +987,31 @@ write(stdout,fmt=*) 'TEST27' mn = this_view%filedate(ifile)%mn sc = this_view%filedate(ifile)%sc num_goesabi_global = num_goesabi_global + this_view%nrad_on_domain + ptotal(ifgat) = ptotal(ifgat) + this_view%nrad_on_domain + + allocate(thinmask(this_view%ys_patch:this_view%ye_patch, & + this_view%xs_patch:this_view%xe_patch)) + thinmask = .false. else p => p_fgat end if -! lat => this_obsgrid%lat -! lon => this_obsgrid%lon -! satzen => this_obsgrid%satzen - this_obslist => view_att(iview)%head - do ikeep = 1, this_view%nrad_on_patch + do n = 1, this_view%nrad_on_patch this_obslist => this_obslist%next iy = this_obslist%iy ix = this_obslist%ix -! iy = this_obsgrid%iy_global(ikeep) -! ix = this_obsgrid%ix_global(ikeep) + if (.not. allmask_patch(iy,ix)) cycle if (first_chan) then info%lat = this_obslist%lat ! latitude info%lon = this_obslist%lon ! longitude - -! info%lat = lat(ikeep,1) ! latitude -! info%lon = lon(ikeep,1) ! longitude - ptotal(ifgat) = ptotal(ifgat) + 1 - end if - - if (.not. allmask_patch(iy,ix)) cycle - - if (first_chan) & num_goesabi_local = num_goesabi_local + 1 + end if if (thinning) then if (first_chan) then @@ -1324,14 +1055,13 @@ write(stdout,fmt=*) 'TEST27' ! ??? "scan" position (IS THIS CORRECT?) end if p%satzen = this_obslist%satzen -! p%satzen = satzen(ikeep,1) p%solzen = 0.0 p%sensor_index = inst p%ifgat = ifgat end if ! Transfer BT from all files - p%tb_inv(ichan) = bt(iy,ix) + p%tb_inv(ichan) = bt_patch(iy,ix) if (first_chan) & allocate (p%next) ! add next data @@ -1342,20 +1072,11 @@ write(stdout,fmt=*) 'TEST27' nullify (p%next) end do - nullify( lat ) - nullify( lon ) - nullify( satzen ) - - deallocate(bt) - deallocate(allmask_patch) - + deallocate( bt_patch, allmask_patch ) end if VIEW_SELECT - end do ChannelLoop - - if (this_view%nfiles_used(ifgat).gt.0) & - deallocate(thinmask) + if (allocated(thinmask)) deallocate(thinmask) end if PatchMatch @@ -1366,12 +1087,7 @@ write(stdout,fmt=*) 'TEST27' if (this_view%moving .or. ipass.eq.npass) then ! Deallocate static data -! if (allocated(this_obsgrid%lat)) deallocate(this_obsgrid%lat) -! if (allocated(this_obsgrid%lon)) deallocate(this_obsgrid%lon) -! if (allocated(this_obsgrid%satzen)) deallocate(this_obsgrid%satzen) - if (allocated(this_obsgrid%patchmask)) deallocate(this_obsgrid%patchmask) -! if (allocated(this_obsgrid%ix_global)) deallocate(this_obsgrid%ix_global) -! if (allocated(this_obsgrid%iy_global)) deallocate(this_obsgrid%iy_global) + if (allocated(this_view%patchmask)) deallocate(this_view%patchmask) end if if (ipass.eq.npass) then @@ -1563,6 +1279,8 @@ write(stdout,fmt=*) 'TEST27' end subroutine da_read_obs_ncgoesabi +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_ichan(channel, channel_list, nchan, ichan) !result(ichan) @@ -1573,6 +1291,8 @@ subroutine get_ichan(channel, channel_list, nchan, ichan) !result(ichan) integer, intent(out) :: ichan integer :: i + if (trace_use) call da_trace_entry("get_ichan") + ichan = 0 do i = 1, nchan if (channel .eq. channel_list(i)) then @@ -1581,9 +1301,12 @@ subroutine get_ichan(channel, channel_list, nchan, ichan) !result(ichan) end if end do -end subroutine get_ichan + if (trace_use) call da_trace_exit("get_ichan") +end subroutine get_ichan +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_abil1b_metadata( filename, & ydim, xdim, req, rpol, pph, nam) !, lat_sat, lon_sat ) @@ -1598,18 +1321,17 @@ subroutine get_abil1b_metadata( filename, & integer :: ierr, ncid, varid, dimid real(r_kind), parameter :: pi=3.1415926535898D0 -write(stdout,fmt=*) 'TEST28' + + if (trace_use) call da_trace_entry("get_abil1b_metadata") ierr=nf_open(trim(filename),nf_nowrite,ncid) call handle_err('Error opening file',ierr) -write(stdout,fmt=*) 'TEST29' !! Determine ABI satellite parameters (optional outputs) ierr=nf_inq_dimid(ncid,'y',dimid) ierr=nf_inq_dimlen(ncid,dimid,ydim) ierr=nf_inq_dimid(ncid,'x',dimid) ierr=nf_inq_dimlen(ncid,dimid,xdim) -write(stdout,fmt=*) 'TEST30' ierr=nf_inq_varid(ncid,'goes_imager_projection',varid) ierr=nf_get_att_double(ncid,varid,'semi_major_axis',req) @@ -1617,136 +1339,124 @@ write(stdout,fmt=*) 'TEST30' ierr=nf_get_att_double(ncid,varid,'perspective_point_height',pph) ierr=nf_get_att_double(ncid,varid,'longitude_of_projection_origin',nam) nam=nam*pi/180 -write(stdout,fmt=*) 'TEST31' !!! ierr=nf_inq_varid(ncid,'nominal_satellite_subpoint_lat',varid) !!! ierr=nf_get_var_double(ncid,varid,lat_sat) !!! ierr=nf_inq_varid(ncid,'nominal_satellite_subpoint_lon',varid) !!! ierr=nf_get_var_double(ncid,varid,lon_sat) -!#ifdef DM_PARALLEL -! call mpi_barrier(comm, ierr) -!#endif -write(stdout,fmt=*) 'TEST32' - ierr=nf_close(ncid) call handle_err('Error closing file',ierr) -write(stdout,fmt=*) 'TEST33' + + if (trace_use) call da_trace_exit("get_abil1b_metadata") end subroutine get_abil1b_metadata +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -subroutine get_abil1b_grid( filename, & - ny, nx, nyl, nxl, ys, xs, & - req, rpol, pph, nam, satellite_id, & - lat, lon, satzen, earthmask, zenmask, domainmask, & - yoff, xoff ) +subroutine get_abil1b_grid1( filename, & + ny, nx, & + xx, yy, & + yoff, xoff ) implicit none - character(*), intent(in) :: filename - integer, intent(in) :: ny, nx, nyl, nxl, ys, xs - real(r_kind), intent(in) :: req, rpol, pph, nam - integer, intent(in) :: satellite_id - -!!! real, intent(in) :: lon_sat - - real, intent(out) :: lat(nyl,nxl), lon(nyl,nxl), satzen(nyl,nxl) - logical, intent(out) :: earthmask(nyl,nxl), zenmask(nyl,nxl), domainmask(nyl,nxl) - integer, intent(out) :: yoff, xoff - - type(info_type) :: info - type(model_loc_type) :: loc - logical :: outside_all, dummy_bool + character(*), intent(in) :: filename + integer, intent(in) :: ny, nx + integer, intent(out) :: yy(ny), xx(nx) + integer, intent(out) :: yoff, xoff - real :: yy(ny), xx(nx) integer :: ierr, ncid, varid - integer :: iy, ix, iyl, ixl real :: slp, itp - real(r_kind) :: hh - real :: alat, alon ! , alon_sat - real :: theta, theta1, theta2, r1 - real, parameter :: satzen_limit=75.0 - -write(stdout,fmt=*) 'TEST34' + if (trace_use) call da_trace_entry("get_abil1b_grid1") ierr=nf_open(trim(filename),nf_nowrite,ncid) call handle_err('Error opening file',ierr) -write(stdout,fmt=*) 'TEST35' ierr=nf_inq_varid(ncid,'y',varid) -write(stdout,fmt=*) 'TEST36' ierr=nf_get_var_double(ncid,varid,yy) -write(stdout,fmt=*) 'TEST37' ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) ierr=nf_get_att_double(ncid,varid,'add_offset',itp) yy = yy*slp+itp yoff = floor(itp/slp) -write(stdout,fmt=*) 'TEST38' ierr=nf_inq_varid(ncid,'x',varid) -write(stdout,fmt=*) 'TEST39' ierr=nf_get_var_double(ncid,varid,xx) -write(stdout,fmt=*) 'TEST40' ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) ierr=nf_get_att_double(ncid,varid,'add_offset',itp) xx = xx*slp+itp xoff = floor(itp/slp) -write(stdout,fmt=*) 'TEST41' + ierr=nf_close(ncid) + call handle_err('Error closing file',ierr) + + if (trace_use) call da_trace_exit("get_abil1b_grid1") - earthmask=.false. -write(stdout,fmt=*) 'TEST42' +end subroutine get_abil1b_grid1 - zenmask=.false. -write(stdout,fmt=*) 'TEST43' +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! alon_sat=lon_sat*pi/180.D0 +subroutine get_abil1b_grid2( ny, nx, nyl, nxl, ys, xs, & + yy, xx, req, rpol, pph, nam, satellite_id, & + lat, lon, satzen, & + earthmask, zenmask, & + modj, modi, domainmask ) - hh=pph+req -write(stdout,fmt=*) 'TEST44' + implicit none -write(stdout,fmt=*) hh,pph,req,rpol,nam,slp,itp,xoff,yoff -write(stdout,fmt=*) 'TEST45' + integer, intent(in) :: ny, nx, nyl, nxl, ys, xs + real, intent(in) :: yy(ny), xx(nx) + real(r_kind), intent(in) :: req, rpol, pph, nam + integer, intent(in) :: satellite_id - lat = missing_r -write(stdout,fmt=*) 'TEST46' + ! GOES-ABI fields + real, intent(out) :: lat(nyl,nxl), lon(nyl,nxl), satzen(nyl,nxl) + logical, intent(out) :: earthmask(nyl,nxl), zenmask(nyl,nxl) - lon = missing_r -write(stdout,fmt=*) 'TEST47' + ! Model-specific fields + integer, optional, intent(out) :: modj(nyl,nxl), modi(nyl,nxl) + logical, optional, intent(out) :: domainmask(nyl,nxl) + ! Internal Variables + type(info_type) :: info + type(model_loc_type) :: loc + logical :: outside_all, dummy_bool + + integer :: iy, ix, iyl, ixl + real(r_kind) :: hh + real, parameter :: satzen_limit=75.0 + + if (trace_use) call da_trace_entry("get_abil1b_grid2") + + hh=pph+req + + lat = missing_r + lon = missing_r satzen = missing_r -write(stdout,fmt=*) 'TEST48' + + earthmask=.false. + zenmask=.false. + do ixl = 1, nxl ix = ixl + xs - 1 -write(stdout,fmt=*) 'TEST49', ixl - do iyl = 1, nyl iy = iyl + ys - 1 call get_abil1b_latlon(yy(iy),xx(ix),req,rpol,hh,nam,lat(iyl,ixl),lon(iyl,ixl)) -! if ( isnan(lat(iyl,ixl)) .OR. isnan(lon(iyl,ixl)) ) then -! lat(iyl,ixl) = missing_r -! lon(iyl,ixl) = missing_r -! end if if( lat(iyl,ixl).eq.missing_r .OR. lon(iyl,ixl).eq.missing_r ) cycle - call da_get_satzen(lat(iyl,ixl),lon(iyl,ixl),satellite_id,satzen(iyl,ixl)) - -! if (isnan(satzen(iyl,ixl))) then -! lat(iyl,ixl) = missing_r -! lon(iyl,ixl) = missing_r -! satzen(iyl,ixl) = missing_r -! cycle -! end if earthmask(iyl,ixl)=.true. + call da_get_satzen(lat(iyl,ixl),lon(iyl,ixl),satellite_id,satzen(iyl,ixl)) + if (satzen(iyl,ixl).gt.satzen_limit) then satzen(iyl,ixl) = missing_r cycle @@ -1755,30 +1465,33 @@ write(stdout,fmt=*) 'TEST49', ixl end do end do -write(stdout,fmt=*) 'TEST50' - - ierr=nf_close(ncid) - call handle_err('Error closing file',ierr) - -write(stdout,fmt=*) 'TEST51' + !Populate domainmask, modi, modj with model coordinate utility + if ( present(modj) .and. present(modi) .and. present(domainmask) ) then + modj = missing + modi = missing + domainmask = .false. + do ixl = 1, nxl + do iyl = 1, nyl + if (earthmask(iyl,ixl)) then + info%lon = lon(iyl,ixl) ! longitude + info%lat = lat(iyl,ixl) ! latitude + call da_llxy (info, loc, dummy_bool, outside_all) + if (.not. outside_all) then + modj(iyl,ixl) = loc%j + modi(iyl,ixl) = loc%i + domainmask(iyl,ixl) = .true. + end if + end if + end do + end do + end if -write(stdout,fmt=*) 'TEST52' + if (trace_use) call da_trace_exit("get_abil1b_grid2") - !Populate domainmask with on/off domain test for local set of obs - domainmask = .false. - do ixl = 1, nxl -write(stdout,fmt=*) 'TEST53', ixl - do iyl = 1, nyl - if (earthmask(iyl,ixl)) then - info%lon = lon(iyl,ixl) ! longitude - info%lat = lat(iyl,ixl) ! latitude - call da_llxy (info, loc, dummy_bool, outside_all) - domainmask(iyl,ixl) = .not. outside_all - end if - end do - end do +end subroutine get_abil1b_grid2 -end subroutine get_abil1b_grid +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_abil1b_bt( filename, ny, nx, ys, ye, xs, xe, & radmask, bt ) @@ -1803,6 +1516,8 @@ subroutine get_abil1b_bt( filename, ny, nx, ys, ye, xs, xe, & real :: slp, itp real :: bc1, bc2, fk1, fk2 + if (trace_use) call da_trace_entry("get_abil1b_bt") + bt = missing_r !! Save rad reading time by selecting a subset of netcdf var @@ -1838,7 +1553,6 @@ subroutine get_abil1b_bt( filename, ny, nx, ys, ye, xs, xe, & ierr=nf_get_var_double(ncid,varid,fk2) do ix=xs, xe -write(stdout,fmt=*) 'TEST54', ix do iy=ys, ye if ( radmask(iy,ix) ) then if( rad(iy,ix).ge.0.0 .and. any(DQF(iy,ix).eq.(/0,1/)) ) then @@ -1857,21 +1571,27 @@ write(stdout,fmt=*) 'TEST54', ix ierr=nf_close(ncid) call handle_err('Error closing file',ierr) + if (trace_use) call da_trace_exit("get_abil1b_bt") + end subroutine get_abil1b_bt +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_abil1b_latlon(yy,xx,req,rpol,hh,nam,lat,lon) implicit none - real, intent(in) :: yy, xx - real, intent(in) :: req, rpol, hh, nam + real, intent(in) :: yy, xx + real, intent(in) :: req, rpol, hh, nam real, intent(inout) :: lat,lon real :: lat1,lon1 real :: aa,bb,cc,rs,sx,sy,sz real :: radicand - + + if (trace_use) call da_trace_entry("get_abil1b_latlon") + aa=sin(xx)**2+cos(xx)**2*(cos(yy)**2+req**2/rpol**2*sin(yy)**2) bb=-2.D0*hh*cos(xx)*cos(yy) cc=hh**2-req**2 @@ -1890,8 +1610,12 @@ subroutine get_abil1b_latlon(yy,xx,req,rpol,hh,nam,lat,lon) lat=lat1*180.D0/pi lon=lon1*180.D0/pi + if (trace_use) call da_trace_exit("get_abil1b_latlon") + end subroutine get_abil1b_latlon +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine split_grid( ny_global, nx_global, & ny_local, nx_local, & @@ -1909,17 +1633,15 @@ subroutine split_grid( ny_global, nx_global, & integer, target :: nx_grid(ntasks_x), xs_grid(ntasks_x) !, xe_grid(ntasks_x) integer, pointer :: ngrid(:), sgrid(:) - integer :: mm, i, j, iproc, ig, ntasks, nglobal + integer :: mm, i, j, ii, iproc, igrid, ntasks, nglobal, fact -write(stdout,fmt=*) 'TEST55' - - do ig = 1, 2 - if (ig.eq.1) then + do igrid = 1, 2 + if (igrid.eq.1) then ngrid => ny_grid sgrid => ys_grid ntasks = ntasks_y nglobal = ny_global - else if (ig.eq.2) then + else if (igrid.eq.2) then ngrid => nx_grid sgrid => xs_grid ntasks = ntasks_x @@ -1935,34 +1657,35 @@ write(stdout,fmt=*) 'TEST55' end do if (redist) then - !Redistribute grid from middle to edges to balance load - ! for da_llxy in get_abil1b_grid - do i = 1, 2 - if (mod(ntasks,2).eq.0) then + fact = 4 + !Redistribute grid from middle to edges to balance load + ! of calls to da_llxy in get_abil1b_grid + do i = 1, 2 + if (mod(ntasks,2).eq.1) then + ii = ntasks/2+1 + mm = ngrid(ii) / fact + mm = mm/2 + ngrid(ii) = ngrid(ii) - 2*mm + ngrid(ii-1) = ngrid(ii-1) + mm + ngrid(ii+1) = ngrid(ii+1) + mm + else + ii = ntasks/2 + end if do j = ntasks/2, 2, -1 - mm = ngrid(j) / 6 + mm = ngrid(j) / fact ngrid(j) = ngrid(j) - mm ngrid(j-1) = ngrid(j-1) + mm end do - do j = ntasks/2+1, ntasks-1 - mm = ngrid(j) / 6 + do j = ii+1, ntasks-1 + mm = ngrid(j) / fact ngrid(j) = ngrid(j) - mm ngrid(j+1) = ngrid(j+1) + mm end do - else - do j = ntasks/2+1, 2, -1 - mm = ngrid(j) / 6 - mm = mm/2 - ngrid(j) = ngrid(j) - 2*mm - ngrid(j-1) = ngrid(j-1) + mm - ngrid(ntasks-j+2) = ngrid(ntasks-j+2) + mm - end do - end if - end do + end do end if sgrid(1) = 1 - do j = 1, ntasks_y + do j = 1, ntasks ! if (j .eq. 1) egrid(1) = ngrid(1) !NOT NECESSARY if (j .lt. ntasks) then sgrid(j+1) = sgrid(j) + ngrid(j) @@ -1971,164 +1694,20 @@ write(stdout,fmt=*) 'TEST55' end do end do -! nx_grid = nx_global / ntasks_x -! mm = mod( nx_global , ntasks_x ) -! do i = 1, ntasks_x -! if (mm .gt. 0) then -! nx_grid(i) = nx_grid(i) + 1 -! mm = mm - 1 -! end if -! end do -! -! xs_grid(1) = 1 -! do i = 1, ntasks_x -! if (mm .gt. 0) then -! nx_grid(i) = nx_grid(i) + 1 -! mm = mm - 1 -! end if -! if (i .eq. 1) xe_grid(1) = nx_grid(1) !NOT NECESSARY -! if (i .lt. ntasks_x) then -! xs_grid(i+1) = xs_grid(i) + nx_grid(i) -! xe_grid(i+1) = xe_grid(i) + nx_grid(i+1) !NOT NECESSARY -! end if -! end do - -write(stdout,fmt=*) 'TEST56' - - j = myproc / ntasks_y + 1 - i = mod(myproc, ntasks_x) + 1 + j = myproc / ntasks_x + 1 ny_local = ny_grid(j) ys_local = ys_grid(j) + + i = mod(myproc, ntasks_x) + 1 nx_local = nx_grid(i) xs_local = xs_grid(i) write(stdout,fmt=*) 'TEST57', myproc, j, i -! iproc = 0 -! do j = 1, ntasks_y -! do i = 1, ntasks_x -!write(stdout,fmt=*) 'TEST58' -! if (iproc .eq. myproc) then -!write(stdout,fmt=*) 'TEST59', iproc, j, i -! -! ny_local = ny_grid(j) -! ys_local = ys_grid(j) -! -! nx_local = nx_grid(i) -! xs_local = xs_grid(i) -! -! exit -! end if -! iproc = iproc + 1 -! end do -! if (iproc .eq. myproc) exit -! end do - end subroutine split_grid -!subroutine j2000day2cal(j2000,yr,mt,dy,hr,mn,sc) -! ! Converts J2000 epoch day to Gregorian calender date -! ! source: David G. Simpson, NASA Goddard, Accessed April 2018 -! ! https://caps.gsfc.nasa.gov/simpson/software.html -! -! implicit none -! -! real(r_kind), intent(in) :: j2000 -! integer, intent(out) :: yr,mt,dy,hr,mn,sc -! -! real(r_kind) :: ju, j0, F -! integer :: yr0, sc0 -! INTEGER :: A, B, C, D, E, Z, ALPHA ! intermediate variables -! real(r_kind) :: dd -! real(r_kind), parameter :: jd_j2000=2451545.0 -! -! !! First convert J2000 to Julian date -! ju=j2000+jd_j2000 -! -! ju = ju + 0.5D0 -! Z = INT(ju) -! F = ju - Z -! -! !! Gregorian date test (can probably assume this is a Gregorian date) -! IF (Z .LT. 2299161) THEN -! A = Z -! ELSE -! ALPHA = INT((Z-1867216.25D0)/36524.25D0) -! A = Z + 1 + ALPHA - ALPHA/4 -! END IF -! -! B = A + 1524 -! C = INT((B-122.1D0)/365.25D0) -! D = INT(365.25D0*C) -! E = INT((B-D)/30.6001D0) -! -! IF (E .LT. 14) THEN -! mt = E - 1 -! ELSE -! mt = E - 13 -! END IF -! -! IF (mt .GT. 2) THEN -! yr = C - 4716 -! ELSE -! yr = C - 4715 -! END IF -! -! dd = B - D - INT(30.6001D0*E) + F -! -! dy = floor(dd) -! -! !! Remainder for hr, mn, sc. -! dd = dd - real(dy,8) -! -! sc0 = nint(dd*86400.) -! hr = sc0 / 3600 -! sc0 = sc0 - hr*3600 -! mn = sc0 / 60 -! sc = sc0 - mn*60 -! -!end subroutine j2000day2cal -! -!subroutine cal2j2000day(j2000,yr,mt,dy,hr,mn,sc) -! ! Converts Gregorian calender date to J2000 epoch day -! ! source: David G. Simpson, NASA Goddard, Accessed April 2018 -! ! https://caps.gsfc.nasa.gov/simpson/software.html -! ! Alternative: http://aa.usno.navy.mil/faq/docs/JD_Formula.php -! -! implicit none -! -! real(r_kind), intent(out) :: j2000 -! integer, intent(inout) :: yr,mt,dy,hr,mn,sc -! -! real(r_kind) :: ju -! INTEGER :: A, B -! real(r_kind), parameter :: jd_j2000=2451545.0 -! -! -! IF (mt .LE. 2) THEN -! yr = yr - 1 -! mt = mt + 12 -! END IF -! -! !! Gregorian date test (assuming this is a Gregorian date) -!! IF (GREGORIAN_FLAG) THEN ! Gregorian calendar -! A = yr/100 -! B = 2 - A + A/4 -!! ELSE ! Julian calendar -!! B = 0 -!! END IF -! -! ju = real( INT(365.25D0*(yr+4716)) & -! + INT(30.6001D0*(mt+1)) + B + dy,8) & -! - 1524.5D0 -! -! ju = ju + (real(hr,8) & -! + ( real(mn,8) & -! + real(sc,8) / 60.0) / 60.0 ) / 24.0 -! -! j2000 = ju-jd_j2000 -! -!end subroutine cal2j2000day +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine jday2cal(jdy, yr, mt, dy) @@ -2140,7 +1719,6 @@ subroutine jday2cal(jdy, yr, mt, dy) integer :: d_in_m(12) = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/) integer :: imonth, tot_days - if ( mod(yr,4).eq.0 .and. .not.(mod(yr,100).eq.0 .and. .not.mod(yr,400).eq.0) ) d_in_m(2) = 29 tot_days = 0 @@ -2155,6 +1733,9 @@ subroutine jday2cal(jdy, yr, mt, dy) end subroutine jday2cal +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine da_get_cal_time(jmod,yr,mt,dy,hr,mn,sc) ! Converts modified Julian time (in minutes) to Gregorian calender date ! Modified from this code: David G. Simpson, NASA Goddard, Accessed April 2018 @@ -2226,6 +1807,9 @@ subroutine da_get_cal_time(jmod,yr,mt,dy,hr,mn,sc) end subroutine da_get_cal_time +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine handle_err(rmarker,nf_status) implicit none diff --git a/var/da/da_tools/da_llxy.inc b/var/da/da_tools/da_llxy.inc index 2b9f988b31..01d6ee19d6 100644 --- a/var/da/da_tools/da_llxy.inc +++ b/var/da/da_tools/da_llxy.inc @@ -1,4 +1,4 @@ -subroutine da_llxy (info, loc, outside, outside_all) +subroutine da_llxy (info, loc, outside, outside_all, patch_test_only) !----------------------------------------------------------------------- ! Purpose: TBD @@ -14,56 +14,69 @@ subroutine da_llxy (info, loc, outside, outside_all) type(model_loc_type), intent(inout) :: loc logical , intent(out) :: outside !wrt local domain logical, optional, intent(out) :: outside_all !wrt all domains + logical, optional, intent(in) :: patch_test_only + + logical :: include_xy ! too many return statments to trace ! if (trace_use_frequent) call da_trace_entry("da_llxy") + include_xy = .true. + if (present(patch_test_only)) include_xy = .not.patch_test_only + + outside = .false. - loc % x = -1.0 - loc % y = -1.0 + + if (include_xy) then + loc % x = -1.0 + loc % y = -1.0 - ! get the (x, y) coordinates - - if ( fg_format == fg_format_wrf_arw_regional ) then - call da_llxy_wrf(map_info, info%lat, info%lon, loc%x, loc%y) - else if (fg_format == fg_format_wrf_nmm_regional) then - call da_llxy_rotated_latlon(info%lat, info%lon, map_info, loc%x, loc%y) - else if (global) then - call da_llxy_global (info%lat, info%lon, loc%x, loc%y) - else - call da_llxy_default (info%lat, info%lon, loc%x, loc%y) - end if + ! get the (x, y) coordinates + + if ( fg_format == fg_format_wrf_arw_regional ) then + call da_llxy_wrf(map_info, info%lat, info%lon, loc%x, loc%y) + else if (fg_format == fg_format_wrf_nmm_regional) then + call da_llxy_rotated_latlon(info%lat, info%lon, map_info, loc%x, loc%y) + else if (global) then + call da_llxy_global (info%lat, info%lon, loc%x, loc%y) + else + call da_llxy_default (info%lat, info%lon, loc%x, loc%y) + end if #ifdef A2C - call da_togrid (loc%x, its-3, ite+3, loc%i, loc%dx, loc%dxm)! + call da_togrid (loc%x, its-3, ite+3, loc%i, loc%dx, loc%dxm)! - call da_togrid (loc%y, jts-3, jte+3, loc%j, loc%dy, loc%dym) + call da_togrid (loc%y, jts-3, jte+3, loc%j, loc%dy, loc%dym) #else - call da_togrid (loc%x, its-2, ite+2, loc%i, loc%dx, loc%dxm)! + call da_togrid (loc%x, its-2, ite+2, loc%i, loc%dx, loc%dxm)! - call da_togrid (loc%y, jts-2, jte+2, loc%j, loc%dy, loc%dym) + call da_togrid (loc%y, jts-2, jte+2, loc%j, loc%dy, loc%dym) #endif - ! refactor to remove this ugly duplication later - if (present(outside_all)) then - outside_all = .false. - ! Do not check for global options - if (.not. global) then - if ((int(loc%x) < ids) .or. (int(loc%x) >= ide) .or. & - (int(loc%y) < jds) .or. (int(loc%y) >= jde)) then - outside_all = .true. - outside = .true. - return - end if - if (def_sub_domain) then - if (x_start_sub_domain > loc%x .or. y_start_sub_domain > loc%y .or. & - x_end_sub_domain < loc%x .or. y_end_sub_domain < loc%y) then - outside_all = .true. - outside = .true. - return + ! refactor to remove this ugly duplication later + if (present(outside_all)) then + outside_all = .false. + ! Do not check for global options + if (.not. global) then + if ((int(loc%x) < ids) .or. (int(loc%x) >= ide) .or. & + (int(loc%y) < jds) .or. (int(loc%y) >= jde)) then + outside_all = .true. + outside = .true. + return + end if + if (def_sub_domain) then + if (x_start_sub_domain > loc%x .or. y_start_sub_domain > loc%y .or. & + x_end_sub_domain < loc%x .or. y_end_sub_domain < loc%y) then + outside_all = .true. + outside = .true. + return + end if end if end if end if + + else + if (present(outside_all)) outside_all = .false. end if if (fg_format == fg_format_kma_global) then From f9a1f6b17bf1f622ad7e5dd2658c1051f2c49656 Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Thu, 17 May 2018 16:38:29 -0600 Subject: [PATCH 05/86] Further advance in GOES-ABI reading of obs locations Attempting to balance load by performing round-robin calculation of lat, lon, etc. across more than num_procs tasks For example 10*num_procs tasks, each of which takes a variable amount of time. Each process will complete a different number of tasks, the result of which is assigned to a linked list member. That linked list member includes fields of lat, lon, etc. --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 869 ++++++++++--------- 1 file changed, 473 insertions(+), 396 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 4b6bd66f68..c91f9afe4a 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -39,7 +39,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: ny_global, nx_global integer :: yoff_fd, xoff_fd ! For MPI parallelization - integer :: nrad_mask, nrad_buf + integer :: nrad_buf, nfield_buf integer :: ny_local, nx_local integer :: ys_local, xs_local @@ -52,18 +52,26 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Temporary data fields for assigning radiance locations to local patches - type data_field - real, pointer :: local_r(:,:) - real, pointer :: mask_r(:) - real, pointer :: remote_r(:) - integer, pointer :: local_i(:,:) - integer, pointer :: mask_i(:) - integer, pointer :: remote_i(:) - end type data_field - - type(data_field) :: lat_f, lon_f, satzen_f, & - modj_f, modi_f, & - obsj_f, obsi_f + type field_r + real, pointer :: local(:,:) + real, pointer :: mask(:) + real, pointer :: remote(:) + end type field_r + type field_i + integer, pointer :: local(:,:) + integer, pointer :: mask(:) + integer, pointer :: remote(:) + end type field_i + type fieldlist + type(field_r) :: lat, lon, satzen + type(field_i) :: modj, modi, obsj, obsi + integer :: i, nrad_mask + type(fieldlist), pointer :: next + end type fieldlist + + type(fieldlist), pointer :: head_field, current_field, p_field + + integer :: nfield_local ! Masks for data reduction logical, allocatable :: & @@ -82,7 +90,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !! Iterates integer :: ichan, ifile, iview, ifgat, ipass, ioff, & - jchan, jfile, jview, & + jchan, jfile, jview, ifield, & n, i, j, iy, ix, iyl, ixl, iproc !! Satellite variables @@ -227,32 +235,34 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end do allocate(view_att(nviews)) - view_att(:)%select = .true. ! Need to set this according to namelist entries - view_att(1)%name_short = 'F' - view_att(2)%name_short = 'C' - view_att(3)%name_short = 'M1' - view_att(4)%name_short = 'M2' - - view_att(1)%name = 'Full Disk' - view_att(2)%name = 'CONUS' - view_att(3)%name = 'MESO1' - view_att(4)%name = 'MESO2' - - view_att(1)%fpath = './goes-fd/' - view_att(2)%fpath = './goes-conus/' - view_att(3)%fpath = './goes-meso/' - view_att(4)%fpath = './goes-meso/' - - view_att(1)%moving = .false. - view_att(2)%moving = .false. - view_att(3)%moving = .true. - view_att(4)%moving = .true. + view_att(:) % select = .true. ! Need to set this according to namelist entries + view_att(1) % name_short = 'F' + view_att(2) % name_short = 'C' + view_att(3) % name_short = 'M1' + view_att(4) % name_short = 'M2' + + view_att(1) % name = 'Full Disk' + view_att(2) % name = 'CONUS' + view_att(3) % name = 'MESO1' + view_att(4) % name = 'MESO2' + + view_att(1) % fpath = './goes-fd/' + view_att(2) % fpath = './goes-conus/' + view_att(3) % fpath = './goes-meso/' + view_att(4) % fpath = './goes-meso/' + + view_att(1) % moving = .false. + view_att(2) % moving = .false. + view_att(3) % moving = .true. + view_att(4) % moving = .true. !! Initialize local obs structures allocate (head) nullify (head % next ) p => head + nullify(p_field) + num_goesabi_local = 0 num_goesabi_global = 0 num_goesabi_used = 0 @@ -264,7 +274,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !! + 2nd pass: read radiance values and convert to BT npass = 1 - if (nviews.gt.1 .and. view_att(1)%select) npass = 2 + if (nviews.gt.1 .and. view_att(1) % select) npass = 2 tot_files_used = 0 use_view_mask = .false. @@ -281,73 +291,74 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !Initialize linked list for obs in this view if (ipass .eq. 1) then - allocate(view_att(iview)%head) - view_att(iview)%head%i = 0 + allocate(view_att(iview) % head) + view_att(iview) % head % i = 0 + nullify(view_att(iview) % head % next) end if ! Associate this_obslist - this_obslist => view_att(iview)%head + this_obslist => view_att(iview) % head - if ( .not.this_view%select ) cycle + if ( .not.this_view % select ) cycle !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Collect files available for this view !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if (ipass .eq. 1) then - write(unit=stdout,fmt='(5A)') 'Searching for GOES ', trim(this_view%name) ,' files in ', trim(this_view%fpath),'...' + write(unit=stdout,fmt='(5A)') 'Searching for GOES ', trim(this_view % name) ,' files in ', trim(this_view % fpath),'...' ! Query fpath for files that begin with INST_PREFIX, name, and for this satellite_id - fname = trim(INST_PREFIX)//trim(this_view%name_short) - list_file = 'INST'//trim(this_view%name_short) - count_file = 'num_INST'//trim(this_view%name_short) + fname = trim(INST_PREFIX)//trim(this_view % name_short) + list_file = 'INST'//trim(this_view % name_short) + count_file = 'num_INST'//trim(this_view % name_short) call da_get_unit(file_unit) if (rootproc) then write(command,fmt='(5A,I2.2,2A)')& - "find ",trim(this_view%fpath), & + "find ",trim(this_view % fpath), & " -type f -name '",trim(fname), & "*G",satellite_id, & - "*' -printf '%P\n' > ",trim(list_file) + "*' -printf ' % P\n' > ",trim(list_file) call execute_command_line (trim(command)) write(command,fmt='(4A)') "cat ",trim(list_file)," | wc -l > ",trim(count_file) call execute_command_line (trim(command)) open(unit=file_unit,file=trim(count_file)) - read(file_unit,*) this_view%nfiles + read(file_unit,*) this_view % nfiles close(file_unit) - i_dummy = this_view%nfiles + i_dummy = this_view % nfiles end if #ifdef DM_PARALLEL call mpi_barrier(comm, ierr) call mpi_bcast ( i_dummy, 1, mpi_integer, root, comm, ierr ) - this_view%nfiles = i_dummy(1) + this_view % nfiles = i_dummy(1) #endif - if (this_view%nfiles .lt. 1) then + if (this_view % nfiles .lt. 1) then if (iview .eq. 1) then npass = 1 end if - this_view%select = .false. + this_view % select = .false. cycle end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Allocate/init components for this_view !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - allocate(this_view%filename(this_view%nfiles)) - allocate(this_view%filechan(this_view%nfiles)) - allocate(this_view%filedate(this_view%nfiles)) - allocate(this_view%file_fgat_match(this_view%nfiles,num_fgat_time)) - allocate(this_view%fgat_time_diff(this_view%nfiles,num_fgat_time)) - allocate(this_view%min_time_diff(nchan,num_fgat_time)) - allocate(this_view%nfiles_used(num_fgat_time)) - - this_view%file_fgat_match = .false. + allocate(this_view % filename(this_view % nfiles)) + allocate(this_view % filechan(this_view % nfiles)) + allocate(this_view % filedate(this_view % nfiles)) + allocate(this_view % file_fgat_match(this_view % nfiles,num_fgat_time)) + allocate(this_view % fgat_time_diff(this_view % nfiles,num_fgat_time)) + allocate(this_view % min_time_diff(nchan,num_fgat_time)) + allocate(this_view % nfiles_used(num_fgat_time)) + + this_view % file_fgat_match = .false. do ifgat=1,num_fgat_time - this_view%fgat_time_diff(:,ifgat) = & + this_view % fgat_time_diff(:,ifgat) = & (time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 !seconds - this_view%min_time_diff(:,ifgat) = & + this_view % min_time_diff(:,ifgat) = & (time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 / 2.D0 !seconds end do @@ -359,32 +370,32 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Read the file names for this view open(unit=file_unit,file=trim(list_file)) - read(file_unit, fmt='(A)') (this_view%filename(ifile), ifile=1,this_view%nfiles) + read(file_unit, fmt='(A)') (this_view % filename(ifile), ifile=1,this_view % nfiles) close(file_unit) call da_free_unit(file_unit) - do ifile = 1, this_view%nfiles + do ifile = 1, this_view % nfiles ioff = 0 if (iview.eq.3 .or. iview.eq.4) ioff=1 ioff = ioff+19 - fname = trim(this_view%filename(ifile)) - read(fname(1+ioff:2+ioff),fmt='(I2.2)') this_view%filechan(ifile) + fname = trim(this_view % filename(ifile)) + read(fname(1+ioff:2+ioff),fmt='(I2.2)') this_view % filechan(ifile) !!! !! The channel could instead be read from band_id in each file, but !!! !! opening/closing files for all channels is time consuming -!!! ierr=nf_open(trim(this_view%fpath)//trim(fname),nf_nowrite,ncid) +!!! ierr=nf_open(trim(this_view % fpath)//trim(fname),nf_nowrite,ncid) !!! ierr=nf_inq_varid(ncid,'band_id',varid) -!!! ierr=nf_get_var_int(ncid,varid,this_view%filechan(ifile)) +!!! ierr=nf_get_var_int(ncid,varid,this_view % filechan(ifile)) !!! ierr=nf_close(ncid) ! Check if channel is selected - if ( .not.any(this_view%filechan(ifile) .eq. channel_select) .or. & - .not.any(this_view%filechan(ifile) .eq. channel_list) ) then + if ( .not.any(this_view % filechan(ifile) .eq. channel_select) .or. & + .not.any(this_view % filechan(ifile) .eq. channel_list) ) then !!! ierr=nf_close(ncid) -!!! this_view%file_fgat_match(ifile,:) = .false. +!!! this_view % file_fgat_match(ifile,:) = .false. cycle end if @@ -414,7 +425,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !! The time it takes to read time_bounds from each file is not insignificant. Above method is much faster. ! !! Determine central date of this file for obs binning -!!! ierr=nf_open(trim(this_view%fpath)//trim(fname),nf_nowrite,ncid) +!!! ierr=nf_open(trim(this_view % fpath)//trim(fname),nf_nowrite,ncid) !!! ierr=nf_inq_varid(ncid,'time_bounds',varid) !!! ierr=nf_get_var_double(ncid,varid,timbdy) !!! ierr=nf_close(ncid) @@ -423,12 +434,12 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) call da_get_cal_time(obs_time,yr,mt,dy,hr,mn,sc) obs_time = obs_time * 60.D0 - this_view%filedate(ifile)%yr = yr - this_view%filedate(ifile)%mt = mt - this_view%filedate(ifile)%dy = dy - this_view%filedate(ifile)%hr = hr - this_view%filedate(ifile)%mn = mn - this_view%filedate(ifile)%sc = sc + this_view % filedate(ifile) % yr = yr + this_view % filedate(ifile) % mt = mt + this_view % filedate(ifile) % dy = dy + this_view % filedate(ifile) % hr = hr + this_view % filedate(ifile) % mn = mn + this_view % filedate(ifile) % sc = sc if ( obs_time < time_slots(0) * 60.D0 .or. & obs_time >= time_slots(num_fgat_time) * 60.D0 ) then @@ -436,29 +447,29 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if do ifgat=1,num_fgat_time - this_view%file_fgat_match(ifile,ifgat) = & + this_view % file_fgat_match(ifile,ifgat) = & ( obs_time >= time_slots(ifgat-1) * 60.D0 .and. & obs_time < time_slots(ifgat) * 60.D0 ) - if (this_view%file_fgat_match(ifile,ifgat)) exit + if (this_view % file_fgat_match(ifile,ifgat)) exit end do - this_view%fgat_time_diff(ifile,ifgat) = & + this_view % fgat_time_diff(ifile,ifgat) = & abs( obs_time - fgat_times_r(ifgat) ) - call get_ichan(this_view%filechan(ifile), channel_list, nchan, ichan) - if ( abs(this_view%fgat_time_diff(ifile, ifgat)) .ge. & - this_view%min_time_diff(ichan, ifgat) ) then - this_view%file_fgat_match(ifile,ifgat) = .false. + call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) + if ( abs(this_view % fgat_time_diff(ifile, ifgat)) .ge. & + this_view % min_time_diff(ichan, ifgat) ) then + this_view % file_fgat_match(ifile,ifgat) = .false. else - this_view%min_time_diff(ichan, ifgat) = abs(this_view%fgat_time_diff(ifile, ifgat)) + this_view % min_time_diff(ichan, ifgat) = abs(this_view % fgat_time_diff(ifile, ifgat)) end if - if (count(this_view%file_fgat_match(ifile,:)) .gt. 1) then + if (count(this_view % file_fgat_match(ifile,:)) .gt. 1) then print*, 'WARNING: More than one bin was selected for ',trim(fname) - print*, 'num_bin_per_file = ',count(this_view%file_fgat_match(ifile,:)) + print*, 'num_bin_per_file = ',count(this_view % file_fgat_match(ifile,:)) print*, 'obs_time = ',obs_time print*, 'Ignoring this file for reading.' - this_view%file_fgat_match(ifile,:) = .false. + this_view % file_fgat_match(ifile,:) = .false. cycle end if end do @@ -469,10 +480,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !! Access netcdf channel/band files across all fgat windows !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - this_view%nfiles_used = 0 + this_view % nfiles_used = 0 do ifgat = 1, num_fgat_time - if (count(this_view%file_fgat_match(:, ifgat)) .lt. 1) then + if (count(this_view % file_fgat_match(:, ifgat)) .lt. 1) then cycle end if @@ -481,49 +492,49 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) write(unit=stdout,fmt='(2A)') & ' ',fgat_times_c(ifgat) - if ( ipass .eq. 1 .and. count(this_view%file_fgat_match(:, ifgat)).gt.1 ) then + if ( ipass .eq. 1 .and. count(this_view % file_fgat_match(:, ifgat)).gt.1 ) then ! Select a single file for this view, channel, and fgat - do ifile = 1, this_view%nfiles - if ( .not. this_view%file_fgat_match(ifile,ifgat) ) cycle - call get_ichan(this_view%filechan(ifile), channel_list, nchan, ichan) - if ( abs(this_view%fgat_time_diff(ifile, ifgat)) .gt. this_view%min_time_diff(ichan, ifgat) ) then - this_view%file_fgat_match(ifile,ifgat) = .false. + do ifile = 1, this_view % nfiles + if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle + call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) + if ( abs(this_view % fgat_time_diff(ifile, ifgat)) .gt. this_view % min_time_diff(ichan, ifgat) ) then + this_view % file_fgat_match(ifile,ifgat) = .false. end if end do end if - do ifile = 1, this_view%nfiles - if ( .not. this_view%file_fgat_match(ifile,ifgat) ) cycle + do ifile = 1, this_view % nfiles + if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle first_file = ifile exit end do - fname_short = trim(this_view%filename(first_file)) - fname = trim(this_view%fpath)//trim(fname_short) + fname_short = trim(this_view % filename(first_file)) + fname = trim(this_view % fpath)//trim(fname_short) write(stdout,fmt=*) 'TEST1' - if ( ipass.eq.1 .and. sum(this_view%nfiles_used(:)).eq.0 ) then + if ( ipass.eq.1 .and. sum(this_view % nfiles_used(:)).eq.0 ) then !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Get ABI metadata (first pass for FD, CONUS, MESO) ! Only ny_global and nx_global need to be read for all views, but this is a cheap subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! write(unit=stdout,fmt='(2A)') & - ' Reading abi metadata for ',trim(this_view%name) + ' Reading abi metadata for ',trim(this_view % name) call get_abil1b_metadata( & - fname, this_view%ny_global, this_view%nx_global, req, rpol, pph, nam)! , lat_sat, lon_sat ) + fname, this_view % ny_global, this_view % nx_global, req, rpol, pph, nam)! , lat_sat, lon_sat ) write(stdout,fmt=*) 'TEST2' -write(stdout,fmt=*) this_view%ny_global, this_view%nx_global, req, rpol, pph, nam +write(stdout,fmt=*) this_view % ny_global, this_view % nx_global, req, rpol, pph, nam #ifdef DM_PARALLEL ! Split the global ABI grid for this view into local segments - call split_grid( this_view%ny_global, this_view%nx_global , & - this_view%ny_local, this_view%nx_local , & - this_view%ys_local, this_view%xs_local , & + call split_grid( this_view % ny_global, this_view % nx_global , & + this_view % ny_local, this_view % nx_local , & + this_view % ys_local, this_view % xs_local , & (iview.eq.1) ) write(stdout,fmt=*) 'ntasks_y, ntasks_x, num_procs, myproc = ', ntasks_y, ntasks_x, num_procs, myproc @@ -533,22 +544,22 @@ write(stdout,fmt=*) 'TEST3' #else ! When mpi parallelism is not available, assign global values to local variables - this_view%ny_local = this_view%ny_global - this_view%nx_local = this_view%nx_global - this_view%ys_local = 1 - this_view%xs_local = 1 + this_view % ny_local = this_view % ny_global + this_view % nx_local = this_view % nx_global + this_view % ys_local = 1 + this_view % xs_local = 1 #endif write(stdout,fmt=*) 'ny_local, nx_local, ys_local, xs_local = ', & - this_view%ny_local, this_view%nx_local, this_view%ys_local, this_view%xs_local + this_view % ny_local, this_view % nx_local, this_view % ys_local, this_view % xs_local write(stdout,fmt=*) 'TEST4' end if ! Recall global dims for this_view - ny_global = this_view%ny_global - nx_global = this_view%nx_global + ny_global = this_view % ny_global + nx_global = this_view % nx_global write(stdout,fmt=*) 'TEST5' @@ -557,21 +568,21 @@ write(stdout,fmt=*) 'TEST5' !! + CONUS or FD and first matching fgat !! + MESO and any fgat (extent changes in time) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if ( ( .not.this_view%moving .and. sum(this_view%nfiles_used(:)).eq.0 ) & - .or. this_view%moving ) then + if ( ( .not.this_view % moving .and. sum(this_view % nfiles_used(:)).eq.0 ) & + .or. this_view % moving ) then ! if ( ipass.eq.2 .and. iview .eq. 1 ) then ! ! Restore FD attributes from memory -! this_view%yoff_fd = yoff_fd -! this_view%xoff_fd = xoff_fd +! this_view % yoff_fd = yoff_fd +! this_view % xoff_fd = xoff_fd ! end if - if ( ipass.eq.1 .or. this_view%moving ) then + if ( ipass.eq.1 .or. this_view % moving ) then write(stdout,fmt=*) 'TEST6' ! Read grid from file, convert to lat, lon, satzen write(unit=stdout,fmt='(2A)') & - ' Reading abi grid info for ',trim(this_view%name) + ' Reading abi grid info for ',trim(this_view % name) !================================================== @@ -582,18 +593,18 @@ write(stdout,fmt=*) 'TEST6' call get_abil1b_grid1( fname, & ny_global, nx_global, & yy, xx, & - this_view%yoff_fd, this_view%xoff_fd ) + this_view % yoff_fd, this_view % xoff_fd ) if ( iview.eq.1 ) then - yoff_fd = this_view%yoff_fd - xoff_fd = this_view%xoff_fd - this_view%yoff_fd = 1 - this_view%xoff_fd = 1 + yoff_fd = this_view % yoff_fd + xoff_fd = this_view % xoff_fd + this_view % yoff_fd = 1 + this_view % xoff_fd = 1 else - this_view%yoff_fd = this_view%yoff_fd - yoff_fd - this_view%xoff_fd = this_view%xoff_fd - xoff_fd -! this_view%yoff_fd = this_view%yoff_fd - yoff_fd + 1 -! this_view%xoff_fd = this_view%xoff_fd - xoff_fd + 1 + this_view % yoff_fd = this_view % yoff_fd - yoff_fd + this_view % xoff_fd = this_view % xoff_fd - xoff_fd +! this_view % yoff_fd = this_view % yoff_fd - yoff_fd + 1 +! this_view % xoff_fd = this_view % xoff_fd - xoff_fd + 1 end if write(stdout,fmt=*) 'TEST8' @@ -601,48 +612,79 @@ write(stdout,fmt=*) 'TEST8' !Currently load balancing is a good start, but not very effective (see split_grid) !Is there some way to subdivide the grid into smaller pieces and process in a round-robin fashion? Would need to send messages between processors to keep track of subsections that were already processed. Fields would need to be more flexible than simple 2d/1d arrays, possibly linked lists. + + allocate(head_field) + nullify (head_field % next) + p_field => head_field + p_field % i = 0 + + !=========================================================== + ! Create a linked list of fields of observation location + ! quantities in round robin fashion across processors. + ! The linked field list approach balances processor loads + ! when some locations have missing data (Full Disk). + !=========================================================== + +!SO FAR THIS IS ONLY SET UP TO RUN A SINGLE FIELD LIST MEMBER ON EACH PROCESSOR +!STILL NEED TO DEFINE NY, NX, YS, XS ACROSS MORE THAN NPROC FIELD MEMBERS +!THIS REQUIRES REDEFINING SPLIT_GRID ABOVE, THEN HANDLING THOSE DIM VARIABLES BELOW +!ALSO STILL NEED TO FIGURE OUT ROUND ROBIN TASK ASSIGNMENT + !This allocation and subroutine are entirely independent for specified local segments !BEGIN PARALLEL SECTION + allocate(p_field % next) + i = p_field % i + p_field => p_field % next + p_field % i = i + 1 + nullify (p_field % next) + !========================================== ! Establish fields for local subset of ! radiance locations in this view !========================================== + ! Recall local dims for this_view - ny_local = this_view%ny_local - nx_local = this_view%nx_local - ys_local = this_view%ys_local - xs_local = this_view%xs_local + ny_local = this_view % ny_local + nx_local = this_view % nx_local + ys_local = this_view % ys_local + xs_local = this_view % xs_local + !! Allocate local obs spatial fields for this view - allocate(lat_f%local_r(ny_local,nx_local)) - allocate(lon_f%local_r(ny_local,nx_local)) - allocate(satzen_f%local_r(ny_local,nx_local)) - allocate(obsj_f%local_i(ny_local,nx_local)) - allocate(obsi_f%local_i(ny_local,nx_local)) + allocate(p_field % lat % local(ny_local,nx_local)) + allocate(p_field % lon % local(ny_local,nx_local)) + allocate(p_field % satzen % local(ny_local,nx_local)) + allocate(p_field % obsj % local(ny_local,nx_local)) + allocate(p_field % obsi % local(ny_local,nx_local)) !! Allocate local mask fields for this view allocate(earthmask(ny_local,nx_local)) allocate(zenmask(ny_local,nx_local)) !! Allocate local model-specific fields - allocate(modj_f%local_i(ny_local,nx_local)) - allocate(modi_f%local_i(ny_local,nx_local)) + allocate(p_field % modj % local(ny_local,nx_local)) + allocate(p_field % modi % local(ny_local,nx_local)) allocate(domainmask(ny_local,nx_local)) do iy = 1, ny_local - obsj_f%local_i(iy,:) = iy + p_field % obsj % local(iy,:) = iy end do do ix = 1, nx_local - obsi_f%local_i(:,ix) = ix + p_field % obsi % local(:,ix) = ix end do - call get_abil1b_grid2( ny_global, nx_global, ny_local, nx_local, ys_local, xs_local, & + call get_abil1b_grid2( ny_global, nx_global, & + ny_local, nx_local, & + ys_local, xs_local, & yy, xx, req, rpol, pph, nam, satellite_id, & - lat_f%local_r, lon_f%local_r, satzen_f%local_r, & + p_field % lat % local, & + p_field % lon % local, & + p_field % satzen % local, & earthmask, zenmask, & - modj_f%local_i, modi_f%local_i, domainmask) - + p_field % modj % local, & + p_field % modi % local, & + domainmask ) write(stdout,fmt=*) 'TEST8' @@ -657,32 +699,31 @@ write(stdout,fmt=*) 'TEST9' allmask_local = & (earthmask .and. zenmask .and. domainmask) - nrad_mask = count( allmask_local ) - - allocate( lat_f%mask_r (nrad_mask) ) - allocate( lon_f%mask_r (nrad_mask) ) - allocate( satzen_f%mask_r (nrad_mask) ) - allocate( modj_f%mask_i (nrad_mask) ) - allocate( modi_f%mask_i (nrad_mask) ) - allocate( obsj_f%mask_i (nrad_mask) ) - allocate( obsi_f%mask_i (nrad_mask) ) - - lat_f%mask_r = pack( lat_f%local_r , allmask_local ) - lon_f%mask_r = pack( lon_f%local_r , allmask_local ) - satzen_f%mask_r = pack( satzen_f%local_r , allmask_local ) - modj_f%mask_i = pack( modj_f%local_i , allmask_local ) - modi_f%mask_i = pack( modi_f%local_i , allmask_local ) - obsj_f%mask_i = pack( obsj_f%local_i , allmask_local ) - obsi_f%mask_i = pack( obsi_f%local_i , allmask_local ) - - deallocate( lat_f%local_r, lon_f%local_r, satzen_f%local_r ) - deallocate( modj_f%local_i, modi_f%local_i ) + p_field % nrad_mask = count( allmask_local ) + + allocate( p_field % lat % mask (p_field % nrad_mask) ) + allocate( p_field % lon % mask (p_field % nrad_mask) ) + allocate( p_field % satzen % mask (p_field % nrad_mask) ) + allocate( p_field % modj % mask (p_field % nrad_mask) ) + allocate( p_field % modi % mask (p_field % nrad_mask) ) + allocate( p_field % obsj % mask (p_field % nrad_mask) ) + allocate( p_field % obsi % mask (p_field % nrad_mask) ) + + p_field % lat % mask = pack( p_field % lat % local , allmask_local ) + p_field % lon % mask = pack( p_field % lon % local , allmask_local ) + p_field % satzen % mask = pack( p_field % satzen % local , allmask_local ) + p_field % modj % mask = pack( p_field % modj % local , allmask_local ) + p_field % modi % mask = pack( p_field % modi % local , allmask_local ) + p_field % obsj % mask = pack( p_field % obsj % local , allmask_local ) + p_field % obsi % mask = pack( p_field % obsi % local , allmask_local ) + + deallocate( p_field % lat % local, p_field % lon % local, p_field % satzen % local ) + deallocate( p_field % modj % local, p_field % modi % local ) deallocate( allmask_local, earthmask, zenmask ) - deallocate( obsj_f%local_i, obsi_f%local_i, domainmask ) + deallocate( p_field % obsj % local, p_field % obsi % local, domainmask ) !END PARALLEL SECTION - deallocate( yy, xx ) @@ -690,142 +731,189 @@ write(stdout,fmt=*) 'TEST9' ! Reduce all masked locations (local and remote) ! to linked list within this WRF patch (this_obslist) !======================================================= - ! Destroy this_obslist if it was previously populated - if (this_obslist%i .gt. 0) then - n = this_obslist%i - this_obslist => view_att(iview)%head%next + if (this_obslist % i .gt. 0) then + n = this_obslist % i + this_obslist => view_att(iview) % head % next do i = 1, n - view_att(iview)%current => this_obslist - this_obslist => this_obslist%next + view_att(iview) % current => this_obslist + this_obslist => this_obslist % next ! free current data - deallocate ( view_att(iview)%current ) + deallocate ( view_att(iview) % current ) end do ! Reassociate this_obslist - this_obslist => view_att(iview)%head + this_obslist => view_att(iview) % head end if ! Setup global patch mask for this view - allocate(this_view%patchmask(ny_global,nx_global)) - this_view%patchmask = .false. - this_view%nrad_on_domain = 0 + allocate(this_view % patchmask(ny_global,nx_global)) + this_view % patchmask = .false. + this_view % nrad_on_domain = 0 write(stdout,fmt=*) 'TEST10' - do iproc = 0, num_procs-1 - nrad_buf = nrad_mask + ! Reset field pointers + nfield_local = p_field % i + p_field => head_field + current_field => head_field + + ProcLoop: do iproc = 0, num_procs-1 + nfield_buf = nfield_local #ifdef DM_PARALLEL - call mpi_bcast(nrad_buf, 1, mpi_integer, iproc, comm, ierr ) + call mpi_bcast(nfield_buf, 1, mpi_integer, iproc, comm, ierr ) #endif + + FieldLoop: do ifield = 1, nfield_buf + #ifdef DM_PARALLEL - call mpi_barrier(comm, ierr) + if (iproc .eq. myproc) then + p_field => p_field % next + nrad_buf = p_field % nrad_mask + end if + + call mpi_bcast(nrad_buf, 1, mpi_integer, iproc, comm, ierr ) #endif - if (nrad_buf .eq. 0) cycle +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif + if (nrad_buf .eq. 0) cycle write(stdout,fmt=*) 'TEST14', nrad_buf - !BCAST REMOTE MASKED FIELDS FOR PROCESSING - allocate( buf_real( nrad_buf, 3 ) ) - allocate( buf_int( nrad_buf, 4 ) ) - - if (iproc .eq. myproc) then - buf_real(:,1) = lat_f%mask_r - buf_real(:,2) = lon_f%mask_r - buf_real(:,3) = satzen_f%mask_r - buf_int (:,1) = modj_f%mask_i - buf_int (:,2) = modi_f%mask_i - buf_int (:,3) = obsj_f%mask_i - buf_int (:,4) = obsi_f%mask_i - else - buf_real = missing_r - buf_int = missing - end if + !BCAST REMOTE MASKED FIELDS TO LOCAL BUFFER + allocate( buf_real( nrad_buf, 3 ) ) + allocate( buf_int( nrad_buf, 4 ) ) + + if (iproc .eq. myproc) then + buf_real(:,1) = p_field % lat % mask + buf_real(:,2) = p_field % lon % mask + buf_real(:,3) = p_field % satzen % mask + buf_int (:,1) = p_field % modj % mask + buf_int (:,2) = p_field % modi % mask + buf_int (:,3) = p_field % obsj % mask + buf_int (:,4) = p_field % obsi % mask + else + buf_real = missing_r + buf_int = missing + end if #ifdef DM_PARALLEL - call mpi_bcast(buf_real, nrad_buf * 3, true_mpi_real, iproc, comm, ierr ) - call mpi_bcast(buf_int, nrad_buf * 4, mpi_integer, iproc, comm, ierr ) + call mpi_bcast(buf_real, nrad_buf * 3, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast(buf_int, nrad_buf * 4, mpi_integer, iproc, comm, ierr ) #endif write(stdout,fmt=*) 'TEST11', iproc - lat_f%remote_r => buf_real(:,1) - lon_f%remote_r => buf_real(:,2) - satzen_f%remote_r => buf_real(:,3) - modj_f%remote_i => buf_int(:,1) - modi_f%remote_i => buf_int(:,2) - obsj_f%remote_i => buf_int(:,3) - obsi_f%remote_i => buf_int(:,4) - - this_view%nrad_on_domain = this_view%nrad_on_domain + nrad_buf - do n = 1, nrad_buf + !PROCESS REMOTE FIELDS + current_field % lat % remote => buf_real(:,1) + current_field % lon % remote => buf_real(:,2) + current_field % satzen % remote => buf_real(:,3) + current_field % modj % remote => buf_int(:,1) + current_field % modi % remote => buf_int(:,2) + current_field % obsj % remote => buf_int(:,3) + current_field % obsi % remote => buf_int(:,4) + + this_view % nrad_on_domain = this_view % nrad_on_domain + nrad_buf + do n = 1, nrad_buf #ifdef DM_PARALLEL - loc%j = modj_f%remote_i(n) - loc%i = modi_f%remote_i(n) - call da_llxy (info, loc, outside, patch_test_only = .true.) - if (outside) cycle + loc % j = current_field % modj % remote(n) + loc % i = current_field % modi % remote(n) + call da_llxy (info, loc, outside, patch_test_only = .true.) + if (outside) cycle #endif - iy = obsj_f%remote_i(n) - ix = obsi_f%remote_i(n) - this_view%patchmask(iy,ix) = .true. - - allocate(this_obslist%next) - i = this_obslist%i - this_obslist => this_obslist%next - this_obslist%i = i + 1 - this_obslist%lat = lat_f%remote_r(n) - this_obslist%lon = lon_f%remote_r(n) - this_obslist%satzen = satzen_f%remote_r(n) - this_obslist%iy = iy - this_obslist%ix = ix - -write(stdout,fmt=*) 'TEST18', iy, iproc, this_obslist%i + iy = current_field % obsj % remote(n) + ix = current_field % obsi % remote(n) + this_view % patchmask(iy,ix) = .true. - end do + allocate(this_obslist % next) + i = this_obslist % i + this_obslist => this_obslist % next + this_obslist % i = i + 1 + this_obslist % lat = current_field % lat % remote(n) + this_obslist % lon = current_field % lon % remote(n) + this_obslist % satzen = current_field % satzen % remote(n) + this_obslist % iy = iy + this_obslist % ix = ix - deallocate( buf_real, buf_int) + nullify (this_obslist % next) -write(stdout,fmt=*) 'TEST19', iproc, this_obslist%i +write(stdout,fmt=*) 'TEST18', iy, iproc, this_obslist % i - end do + end do - deallocate( lat_f%mask_r, lon_f%mask_r, satzen_f%mask_r, modj_f%mask_i, modi_f%mask_i, obsj_f%mask_i, obsi_f%mask_i) + !FREE UP POINTERS AND BUFFERS + nullify ( current_field % lat % remote ) + nullify ( current_field % lon % remote ) + nullify ( current_field % satzen % remote ) + nullify ( current_field % modj % remote ) + nullify ( current_field % modi % remote ) + nullify ( current_field % obsj % remote ) + nullify ( current_field % obsi % remote ) + + deallocate( buf_real, buf_int) + + end do FieldLoop +write(stdout,fmt=*) 'TEST19', iproc, this_obslist % i + + end do ProcLoop + + ! Destroy the field list + n = p_field % i + p_field => head_field % next + do i = 1, n + deallocate( p_field % lat % mask, & + p_field % lon % mask, & + p_field % satzen % mask, & + p_field % modj % mask, & + p_field % modi % mask, & + p_field % obsj % mask, & + p_field % obsi % mask) + + current_field => p_field + p_field => p_field % next + + ! free current data + deallocate ( current_field ) + end do + nullify(p_field) + deallocate(head_field) - this_view%nrad_on_patch = this_obslist%i + this_view % nrad_on_patch = this_obslist % i - if ( this_view%nrad_on_patch.gt.0 ) then + if ( this_view % nrad_on_patch.gt.0 ) then ! Determine ys & ye for this patch - this_view%ys_patch = ny_global - this_view%ye_patch = 1 + this_view % ys_patch = ny_global + this_view % ye_patch = 1 do iy = 1, ny_global - if ( any(this_view%patchmask(iy,:)) ) then - this_view%ys_patch = iy - this_view%ys_patch_fd = iy+this_view%yoff_fd-1 ! offset to FD grid + if ( any(this_view % patchmask(iy,:)) ) then + this_view % ys_patch = iy + this_view % ys_patch_fd = iy+this_view % yoff_fd-1 ! offset to FD grid exit end if end do do iy = ny_global, 1, -1 - if ( any(this_view%patchmask(iy,:)) ) then - this_view%ye_patch = iy - this_view%ye_patch_fd = iy+this_view%yoff_fd-1 ! offset to FD grid + if ( any(this_view % patchmask(iy,:)) ) then + this_view % ye_patch = iy + this_view % ye_patch_fd = iy+this_view % yoff_fd-1 ! offset to FD grid exit end if end do ! Determine xs & xe for this patch - this_view%xs_patch = nx_global - this_view%xe_patch = 1 + this_view % xs_patch = nx_global + this_view % xe_patch = 1 do ix = 1, nx_global - if ( any(this_view%patchmask(:,ix)) ) then - this_view%xs_patch = ix - this_view%xs_patch_fd = ix+this_view%xoff_fd-1 ! offset to FD grid + if ( any(this_view % patchmask(:,ix)) ) then + this_view % xs_patch = ix + this_view % xs_patch_fd = ix+this_view % xoff_fd-1 ! offset to FD grid exit end if end do do ix = nx_global, 1, -1 - if ( any(this_view%patchmask(:,ix)) ) then - this_view%xe_patch = ix - this_view%xe_patch_fd = ix+this_view%xoff_fd-1 ! offset to FD grid + if ( any(this_view % patchmask(:,ix)) ) then + this_view % xe_patch = ix + this_view % xe_patch_fd = ix+this_view % xoff_fd-1 ! offset to FD grid exit end if end do @@ -837,13 +925,13 @@ write(stdout,fmt=*) 'TEST24' end if - PatchMatch: if (this_view%nrad_on_patch .gt. 0) then + PatchMatch: if (this_view % nrad_on_patch .gt. 0) then write(stdout,fmt=*) 'TEST26' - if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view%nfiles_used(:)).eq.0 ) then + if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view % nfiles_used(:)).eq.0 ) then allocate(view_mask(& - this_view%ys_patch_fd:this_view%ye_patch_fd, & - this_view%xs_patch_fd:this_view%xe_patch_fd, & + this_view % ys_patch_fd:this_view % ye_patch_fd, & + this_view % xs_patch_fd:this_view % xe_patch_fd, & nchan, num_fgat_time, nviews)) view_mask = .false. @@ -861,9 +949,9 @@ write(stdout,fmt=*) 'TEST27' ChannelLoop: do ichan = 1, nchan ifile = 0 - do jfile = 1, this_view%nfiles - if ( .not. this_view%file_fgat_match(jfile,ifgat) ) cycle - call get_ichan(this_view%filechan(jfile), channel_list, nchan, jchan) + do jfile = 1, this_view % nfiles + if ( .not. this_view % file_fgat_match(jfile,ifgat) ) cycle + call get_ichan(this_view % filechan(jfile), channel_list, nchan, jchan) if ( ichan .eq. jchan ) then ifile = jfile exit @@ -871,9 +959,9 @@ write(stdout,fmt=*) 'TEST27' end do if ( ifile .eq. 0 ) cycle - this_view%nfiles_used(ifgat) = this_view%nfiles_used(ifgat) + 1 + this_view % nfiles_used(ifgat) = this_view % nfiles_used(ifgat) + 1 -! use_view_mask = ( sum(view_att(1)%nfiles_used(:)).gt.0 ) +! use_view_mask = ( sum(view_att(1) % nfiles_used(:)).gt.0 ) VIEW_SELECT: & if ( ipass.lt.npass .and. use_view_mask ) then @@ -892,21 +980,21 @@ write(stdout,fmt=*) 'TEST27' ! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap best_view = best_view .and. & - this_view%min_time_diff(ichan, ifgat) .lt. & - view_att(jview)%min_time_diff(ichan, ifgat) + this_view % min_time_diff(ichan, ifgat) .lt. & + view_att(jview) % min_time_diff(ichan, ifgat) end do if ( best_view ) then - view_mask(this_view%ys_patch_fd:this_view%ye_patch_fd, & - this_view%ys_patch_fd:this_view%ye_patch_fd, & + view_mask(this_view % ys_patch_fd:this_view % ye_patch_fd, & + this_view % ys_patch_fd:this_view % ye_patch_fd, & ichan, ifgat, iview) = .true. ! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap - view_mask(this_view%ys_patch_fd:this_view%ye_patch_fd, & - this_view%ys_patch_fd:this_view%ye_patch_fd, & + view_mask(this_view % ys_patch_fd:this_view % ye_patch_fd, & + this_view % ys_patch_fd:this_view % ye_patch_fd, & ichan, ifgat, jview) = .false. end do end if @@ -916,8 +1004,8 @@ write(stdout,fmt=*) 'TEST27' else if (inst == 0) cycle - fname_short = trim(this_view%filename(ifile)) - fname = trim(this_view%fpath)//trim(fname_short) + fname_short = trim(this_view % filename(ifile)) + fname = trim(this_view % fpath)//trim(fname_short) !!Utilizing these masks to eliminate data: @@ -929,25 +1017,25 @@ write(stdout,fmt=*) 'TEST27' !! + thinning allocate(allmask_patch(ny_global,nx_global)) - allmask_patch = this_view%patchmask + allmask_patch = this_view % patchmask ! Only use locations where this view is nearest to this fgat time ! - only available when FD data present for any fgat time if ( use_view_mask ) then - if ( count(view_mask(this_view%ys_patch_fd:this_view%ye_patch_fd, & - this_view%ys_patch_fd:this_view%ye_patch_fd, & + if ( count(view_mask(this_view % ys_patch_fd:this_view % ye_patch_fd, & + this_view % ys_patch_fd:this_view % ye_patch_fd, & ichan, ifgat, iview)) .eq. 0 ) then deallocate(allmask_patch) cycle end if - allmask_patch(this_view%ys_patch:this_view%ye_patch , & - this_view%ys_patch:this_view%ye_patch ) = ( & - allmask_patch(this_view%ys_patch:this_view%ye_patch , & - this_view%ys_patch:this_view%ye_patch ) & + allmask_patch(this_view % ys_patch:this_view % ye_patch , & + this_view % ys_patch:this_view % ye_patch ) = ( & + allmask_patch(this_view % ys_patch:this_view % ye_patch , & + this_view % ys_patch:this_view % ye_patch ) & .and. & - view_mask(this_view%ys_patch_fd:this_view%ye_patch_fd, & - this_view%ys_patch_fd:this_view%ye_patch_fd, & + view_mask(this_view % ys_patch_fd:this_view % ye_patch_fd, & + this_view % ys_patch_fd:this_view % ye_patch_fd, & ichan, ifgat, iview) ) end if @@ -962,61 +1050,61 @@ write(stdout,fmt=*) 'TEST27' ' Reading abi radiances: ',trim(fname_short) ! Allocate this patch bt - allocate(bt_patch(this_view%ys_patch:this_view%ye_patch, & - this_view%xs_patch:this_view%xe_patch)) + allocate(bt_patch(this_view % ys_patch:this_view % ye_patch, & + this_view % xs_patch:this_view % xe_patch)) ! This reads in bt only for the local patch, ! reduces read time, but would mess up global count below call get_abil1b_bt( fname, & ny_global, nx_global, & - this_view%ys_patch, this_view%ye_patch, & - this_view%xs_patch, this_view%xe_patch, & + this_view % ys_patch, this_view % ye_patch, & + this_view % xs_patch, this_view % xe_patch, & allmask_patch, bt_patch ) !! Write bt, lat, lon, and satzen to datalink structures - first_chan = (this_view%nfiles_used(ifgat).eq.1) + first_chan = (this_view % nfiles_used(ifgat).eq.1) if (first_chan) then p_fgat => p - yr = this_view%filedate(ifile)%yr - mt = this_view%filedate(ifile)%mt - dy = this_view%filedate(ifile)%dy - hr = this_view%filedate(ifile)%hr - mn = this_view%filedate(ifile)%mn - sc = this_view%filedate(ifile)%sc - num_goesabi_global = num_goesabi_global + this_view%nrad_on_domain - ptotal(ifgat) = ptotal(ifgat) + this_view%nrad_on_domain - - allocate(thinmask(this_view%ys_patch:this_view%ye_patch, & - this_view%xs_patch:this_view%xe_patch)) + yr = this_view % filedate(ifile) % yr + mt = this_view % filedate(ifile) % mt + dy = this_view % filedate(ifile) % dy + hr = this_view % filedate(ifile) % hr + mn = this_view % filedate(ifile) % mn + sc = this_view % filedate(ifile) % sc + num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain + ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain + + allocate(thinmask(this_view % ys_patch:this_view % ye_patch, & + this_view % xs_patch:this_view % xe_patch)) thinmask = .false. else p => p_fgat end if - this_obslist => view_att(iview)%head + this_obslist => view_att(iview) % head - do n = 1, this_view%nrad_on_patch + do n = 1, this_view % nrad_on_patch - this_obslist => this_obslist%next + this_obslist => this_obslist % next - iy = this_obslist%iy - ix = this_obslist%ix + iy = this_obslist % iy + ix = this_obslist % ix if (.not. allmask_patch(iy,ix)) cycle if (first_chan) then - info%lat = this_obslist%lat ! latitude - info%lon = this_obslist%lon ! longitude + info % lat = this_obslist % lat ! latitude + info % lon = this_obslist % lon ! longitude num_goesabi_local = num_goesabi_local + 1 end if if (thinning) then if (first_chan) then - dlat_earth = info%lat - dlon_earth = info%lon + dlat_earth = info % lat + dlon_earth = info % lon if (dlon_earth=r360) dlon_earth = dlon_earth-r360 dlat_earth = dlat_earth*deg2rad @@ -1036,40 +1124,40 @@ write(stdout,fmt=*) 'TEST27' if (first_chan) then num_goesabi_used = num_goesabi_used + 1 - write(unit=info%date_char, & + write(unit=info % date_char, & fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc - info%elv = 0.0 !aquaspot%selv + info % elv = 0.0 !aquaspot % selv allocate ( p % tb_inv (1:nchan) ) - p%info = info - p%loc = loc - p%landsea_mask = 1 ! ??? + p % info = info + p % loc = loc + p % landsea_mask = 1 ! ??? if (use_view_mask) then - p%scanpos = & - (iy + this_view%yoff_fd-1 - 1) * (nscan+1) / view_att(1)%ny_global + p % scanpos = & + (iy + this_view % yoff_fd-1 - 1) * (nscan+1) / view_att(1) % ny_global ! ??? "scan" position (IS THIS CORRECT?) else - p%scanpos = & - (iy + this_view%yoff_fd-1 - 1) * (nscan+1) / 5423 + p % scanpos = & + (iy + this_view % yoff_fd-1 - 1) * (nscan+1) / 5423 ! ??? "scan" position (IS THIS CORRECT?) end if - p%satzen = this_obslist%satzen - p%solzen = 0.0 - p%sensor_index = inst - p%ifgat = ifgat + p % satzen = this_obslist % satzen + p % solzen = 0.0 + p % sensor_index = inst + p % ifgat = ifgat end if ! Transfer BT from all files - p%tb_inv(ichan) = bt_patch(iy,ix) + p % tb_inv(ichan) = bt_patch(iy,ix) if (first_chan) & - allocate (p%next) ! add next data + allocate (p % next) ! add next data - p => p%next + p => p % next if (first_chan) & - nullify (p%next) + nullify (p % next) end do deallocate( bt_patch, allmask_patch ) @@ -1085,28 +1173,28 @@ write(stdout,fmt=*) 'TEST27' !#endif end do ! end fgat loop - if (this_view%moving .or. ipass.eq.npass) then + if (this_view % moving .or. ipass.eq.npass) then ! Deallocate static data - if (allocated(this_view%patchmask)) deallocate(this_view%patchmask) + if (allocated(this_view % patchmask)) deallocate(this_view % patchmask) end if if (ipass.eq.npass) then - if (this_obslist%i .gt. 0) then + if (this_obslist % i .gt. 0) then ! Destroy this_obslist and head - n = this_obslist%i - this_obslist => view_att(iview)%head%next + n = this_obslist % i + this_obslist => view_att(iview) % head % next do i = 1, n - view_att(iview)%current => this_obslist - this_obslist => this_obslist%next + view_att(iview) % current => this_obslist + this_obslist => this_obslist % next ! free current data - deallocate ( view_att(iview)%current ) + deallocate ( view_att(iview) % current ) end do - deallocate(view_att(iview)%head) + deallocate(view_att(iview) % head) end if end if - tot_files_used = tot_files_used + sum(view_att(iview)%nfiles_used) + tot_files_used = tot_files_used + sum(view_att(iview) % nfiles_used) end do ! end view loop @@ -1120,14 +1208,14 @@ write(stdout,fmt=*) 'TEST27' if (allocated(view_mask)) deallocate(view_mask) do iview = 1, nviews - if ( .not.view_att(iview)%select ) cycle - deallocate(view_att(iview)%filename) - deallocate(view_att(iview)%filechan) - deallocate(view_att(iview)%filedate) - deallocate(view_att(iview)%file_fgat_match) - deallocate(view_att(iview)%fgat_time_diff) - deallocate(view_att(iview)%min_time_diff) - deallocate(view_att(iview)%nfiles_used) + if ( .not.view_att(iview) % select ) cycle + deallocate(view_att(iview) % filename) + deallocate(view_att(iview) % filechan) + deallocate(view_att(iview) % filedate) + deallocate(view_att(iview) % file_fgat_match) + deallocate(view_att(iview) % fgat_time_diff) + deallocate(view_att(iview) % min_time_diff) + deallocate(view_att(iview) % nfiles_used) end do deallocate(view_att) @@ -1140,7 +1228,7 @@ write(stdout,fmt=*) 'TEST27' ! Get minimum crit and associated processor index. j = 0 do ifgat = 1, num_fgat_time - j = j + thinning_grid(inst,ifgat)%itxmax + j = j + thinning_grid(inst,ifgat) % itxmax end do @@ -1148,9 +1236,9 @@ write(stdout,fmt=*) 'TEST27' allocate ( out (j) ) j = 0 do ifgat = 1, num_fgat_time - do i = 1, thinning_grid(inst,ifgat)%itxmax + do i = 1, thinning_grid(inst,ifgat) % itxmax j = j + 1 - in(j) = thinning_grid(inst,ifgat)%score_crit(i) + in(j) = thinning_grid(inst,ifgat) % score_crit(i) end do end do @@ -1160,9 +1248,9 @@ write(stdout,fmt=*) 'TEST27' j = 0 do ifgat = 1, num_fgat_time - do i = 1, thinning_grid(inst,ifgat)%itxmax + do i = 1, thinning_grid(inst,ifgat) % itxmax j = j + 1 - if ( ABS(out(j)-thinning_grid(inst,ifgat)%score_crit(i)) > 1.0D-10 ) thinning_grid(inst,ifgat)%ibest_obs(i) = 0 + if ( ABS(out(j)-thinning_grid(inst,ifgat) % score_crit(i)) > 1.0D-10 ) thinning_grid(inst,ifgat) % ibest_obs(i) = 0 end do end do deallocate( in ) @@ -1176,12 +1264,12 @@ write(stdout,fmt=*) 'TEST27' num_goesabi_used_tmp = num_goesabi_used do j = 1, num_goesabi_used_tmp - n = p%sensor_index - ifgat = p%ifgat + n = p % sensor_index + ifgat = p % ifgat found = .false. - do i = 1, thinning_grid(n,ifgat)%itxmax - if ( thinning_grid(n,ifgat)%ibest_obs(i) == j .and. thinning_grid(n,ifgat)%score_crit(i) < 9.99e6_r_kind ) then + do i = 1, thinning_grid(n,ifgat) % itxmax + if ( thinning_grid(n,ifgat) % ibest_obs(i) == j .and. thinning_grid(n,ifgat) % score_crit(i) < 9.99e6_r_kind ) then found = .true. exit end if @@ -1190,9 +1278,9 @@ write(stdout,fmt=*) 'TEST27' ! free current data if ( .not. found ) then current => p - p => p%next + p => p % next if ( head_found ) then - prev%next => p + prev % next => p else head => p prev => p @@ -1207,33 +1295,33 @@ write(stdout,fmt=*) 'TEST27' if ( found .and. head_found ) then prev => p - p => p%next + p => p % next continue end if if ( found .and. .not. head_found ) then head_found = .true. head => p prev => p - p => p%next + p => p % next end if end do end if ! End of thinning !stop - iv%total_rad_pixel = iv%total_rad_pixel + num_goesabi_used - iv%total_rad_channel = iv%total_rad_channel + num_goesabi_used*nchan + iv % total_rad_pixel = iv % total_rad_pixel + num_goesabi_used + iv % total_rad_channel = iv % total_rad_channel + num_goesabi_used*nchan - iv%info(radiance)%nlocal = iv%info(radiance)%nlocal + num_goesabi_used - iv%info(radiance)%ntotal = iv%info(radiance)%ntotal + num_goesabi_global + iv % info(radiance) % nlocal = iv % info(radiance) % nlocal + num_goesabi_used + iv % info(radiance) % ntotal = iv % info(radiance) % ntotal + num_goesabi_global do i = 1, num_fgat_time ptotal(i) = ptotal(i) + ptotal(i-1) - iv%info(radiance)%ptotal(i) = iv%info(radiance)%ptotal(i) + ptotal(i) + iv % info(radiance) % ptotal(i) = iv % info(radiance) % ptotal(i) + ptotal(i) end do - if ( iv%info(radiance)%ptotal(num_fgat_time) /= iv%info(radiance)%ntotal ) then + if ( iv % info(radiance) % ptotal(num_fgat_time) /= iv % info(radiance) % ntotal ) then write(unit=message(1),fmt='(A,I10,A,I10)') & - "Number of ntotal:",iv%info(radiance)%ntotal," is different from the sum of ptotal:", iv%info(radiance)%ptotal(num_fgat_time) + "Number of ntotal:",iv % info(radiance) % ntotal," is different from the sum of ptotal:", iv % info(radiance) % ptotal(num_fgat_time) call da_warning(__FILE__,__LINE__,message(1:1)) endif @@ -1246,11 +1334,11 @@ write(stdout,fmt=*) 'TEST27' if (num_goesabi_used > 0) then - iv%instid(inst)%num_rad = num_goesabi_used - iv%instid(inst)%info%nlocal = num_goesabi_used + iv % instid(inst) % num_rad = num_goesabi_used + iv % instid(inst) % info % nlocal = num_goesabi_used write(unit=stdout,FMT='(a,i3,2x,a,3x,i10)') & 'Allocating space for radiance innov structure', & - inst, iv%instid(inst)%rttovid_string, iv%instid(inst)%num_rad + inst, iv % instid(inst) % rttovid_string, iv % instid(inst) % num_rad call da_allocate_rad_iv (inst, nchan, iv) end if @@ -1258,10 +1346,10 @@ write(stdout,fmt=*) 'TEST27' !------------------------------------------------------------- p => head do n = 1, num_goesabi_used - i = p%sensor_index + i = p % sensor_index call da_initialize_rad_iv (i, n, iv, p) current => p - p => p%next + p => p % next ! free current data deallocate ( current % tb_inv ) @@ -1357,14 +1445,14 @@ end subroutine get_abil1b_metadata subroutine get_abil1b_grid1( filename, & ny, nx, & - xx, yy, & + yy, xx, & yoff, xoff ) implicit none character(*), intent(in) :: filename integer, intent(in) :: ny, nx - integer, intent(out) :: yy(ny), xx(nx) + real, intent(out) :: yy(ny), xx(nx) integer, intent(out) :: yoff, xoff integer :: ierr, ncid, varid @@ -1444,6 +1532,12 @@ subroutine get_abil1b_grid2( ny, nx, nyl, nxl, ys, xs, & earthmask=.false. zenmask=.false. + if ( present(modj) .and. present(modi) .and. present(domainmask) ) then + modj = missing + modi = missing + domainmask = .false. + end if + do ixl = 1, nxl ix = ixl + xs - 1 do iyl = 1, nyl @@ -1455,6 +1549,18 @@ subroutine get_abil1b_grid2( ny, nx, nyl, nxl, ys, xs, & earthmask(iyl,ixl)=.true. + !Populate domainmask, modi, modj with model coordinate utility + if ( present(modj) .and. present(modi) .and. present(domainmask) ) then + info % lon = lon(iyl,ixl) ! longitude + info % lat = lat(iyl,ixl) ! latitude + call da_llxy (info, loc, dummy_bool, outside_all) + if (.not. outside_all) then + modj(iyl,ixl) = loc % j + modi(iyl,ixl) = loc % i + domainmask(iyl,ixl) = .true. + end if + end if + call da_get_satzen(lat(iyl,ixl),lon(iyl,ixl),satellite_id,satzen(iyl,ixl)) if (satzen(iyl,ixl).gt.satzen_limit) then @@ -1465,27 +1571,6 @@ subroutine get_abil1b_grid2( ny, nx, nyl, nxl, ys, xs, & end do end do - !Populate domainmask, modi, modj with model coordinate utility - if ( present(modj) .and. present(modi) .and. present(domainmask) ) then - modj = missing - modi = missing - domainmask = .false. - do ixl = 1, nxl - do iyl = 1, nyl - if (earthmask(iyl,ixl)) then - info%lon = lon(iyl,ixl) ! longitude - info%lat = lat(iyl,ixl) ! latitude - call da_llxy (info, loc, dummy_bool, outside_all) - if (.not. outside_all) then - modj(iyl,ixl) = loc%j - modi(iyl,ixl) = loc%i - domainmask(iyl,ixl) = .true. - end if - end if - end do - end do - end if - if (trace_use) call da_trace_exit("get_abil1b_grid2") end subroutine get_abil1b_grid2 @@ -1710,17 +1795,12 @@ end subroutine split_grid !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine jday2cal(jdy, yr, mt, dy) - implicit none - integer, intent(in) :: jdy, yr integer, intent(out) :: mt, dy - integer :: d_in_m(12) = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/) integer :: imonth, tot_days - if ( mod(yr,4).eq.0 .and. .not.(mod(yr,100).eq.0 .and. .not.mod(yr,400).eq.0) ) d_in_m(2) = 29 - tot_days = 0 do imonth = 1, 12 tot_days = tot_days + d_in_m(imonth) @@ -1730,7 +1810,6 @@ subroutine jday2cal(jdy, yr, mt, dy) exit end if end do - end subroutine jday2cal !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1811,9 +1890,7 @@ end subroutine da_get_cal_time !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine handle_err(rmarker,nf_status) - implicit none - integer, intent(in) :: nf_status character*(*), intent(in) :: rmarker if (nf_status .ne. nf_noerr) then From cbb1d6a9f0fbcb11b99786aaad00c9814602a70a Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Thu, 17 May 2018 19:23:11 -0600 Subject: [PATCH 06/86] More linked list modifications. Very tricky to communicate model_loc_type across processes... --- var/da/da_radiance/da_get_satzen.inc | 4 + var/da/da_radiance/da_read_obs_ncgoesabi.inc | 684 +++++++++---------- var/da/da_tools/da_llxy.inc | 61 +- 3 files changed, 353 insertions(+), 396 deletions(-) diff --git a/var/da/da_radiance/da_get_satzen.inc b/var/da/da_radiance/da_get_satzen.inc index fef99c8bbb..2be286eb9b 100644 --- a/var/da/da_radiance/da_get_satzen.inc +++ b/var/da/da_radiance/da_get_satzen.inc @@ -54,6 +54,10 @@ subroutine da_get_satzen ( lat,lon,sate_index,theta_true ) !ZENITH, FROM SOLER et al., 1994 (spherical) (up to 1 deg difference with above code) gam = acos( cos(alat) * cos(theta) ) r_tmp = (satellite_height+earth_radius)**2 * ( 1.d0 + ( earth_radius / (satellite_height+earth_radius) )**2 - 2.d0 * (earth_radius) / (satellite_height+earth_radius) * cos(gam) ) + + theta_true = missing_r + if (r_tmp .lt. 0) return + r_tmp = sqrt(r_tmp) theta_true = asin((satellite_height+earth_radius) / r_tmp * sin(gam)) * 180.d0 / pi diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index c91f9afe4a..3769570634 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -39,7 +39,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: ny_global, nx_global integer :: yoff_fd, xoff_fd ! For MPI parallelization - integer :: nrad_buf, nfield_buf + integer :: nbuf, nrad_local integer :: ny_local, nx_local integer :: ys_local, xs_local @@ -49,35 +49,31 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !!! real :: lat_sat, lon_sat ! Assume fixed values in da_get_satzen real, allocatable, target :: buf_real(:,:) integer, allocatable, target :: buf_int(:,:) + type(model_loc_type), allocatable, target :: buf_loc(:,:) - ! Temporary data fields for assigning radiance locations to local patches type field_r - real, pointer :: local(:,:) - real, pointer :: mask(:) + real, pointer :: local(:) real, pointer :: remote(:) end type field_r type field_i - integer, pointer :: local(:,:) - integer, pointer :: mask(:) + integer, pointer :: local(:) integer, pointer :: remote(:) end type field_i - type fieldlist - type(field_r) :: lat, lon, satzen - type(field_i) :: modj, modi, obsj, obsi - integer :: i, nrad_mask - type(fieldlist), pointer :: next - end type fieldlist + type field_loc + type(model_loc_type), pointer :: local(:) + type(model_loc_type), pointer :: remote(:) + end type field_loc - type(fieldlist), pointer :: head_field, current_field, p_field - - integer :: nfield_local + type(field_r) :: lat_1d, lon_1d, satzen_1d + type(field_i) :: iy_1d, ix_1d + type(field_loc) :: loc_1d ! Masks for data reduction + logical :: earthmask, zenmask, domainmask, include_local, load_balance logical, allocatable :: & allmask_patch(:,:) , & allmask_local(:,:) , & - earthmask(:,:), zenmask(:,:), domainmask(:,:), & thinmask(:,:) logical, allocatable :: view_mask(:,:,:,:,:) @@ -90,8 +86,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !! Iterates integer :: ichan, ifile, iview, ifgat, ipass, ioff, & - jchan, jfile, jview, ifield, & - n, i, j, iy, ix, iyl, ixl, iproc + jchan, jfile, jview, icount, & + n, i, j, iy, ix, iyl, ixl, iproc, subgrid !! Satellite variables integer(i_kind),parameter :: nchan = 10 @@ -101,10 +97,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer, parameter :: channel_list(nchan) = (/7,8,9,10,11,12,13,14,15,16/) !List of all available channels integer, parameter :: nviews=4 integer(i_kind) :: inst - character(len=14), parameter :: INST_PREFIX = 'OR_ABI-L1b-Rad' - !! File reading variables character(len=1000) :: fname, fname_short, command character(len=50) :: list_file, count_file @@ -115,12 +109,13 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end type date_type ! Linked list type for radiance location information - type viewlist + type viewnode real :: lat, lon, satzen integer :: iy, ix - type(viewlist), pointer :: next + type(model_loc_type) :: loc + type(viewnode), pointer :: next integer :: i - end type viewlist + end type viewnode type viewinfo logical :: select @@ -134,16 +129,16 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) real*8, allocatable :: min_time_diff(:,:) ! seconds integer, allocatable :: nfiles_used(:) integer :: ny_global, nx_global, yoff_fd, xoff_fd - integer :: ny_local, nx_local - integer :: ys_local, xs_local + integer, allocatable :: ny_grid(:), nx_grid(:) + integer, allocatable :: ys_grid(:), xs_grid(:) integer :: ys_patch, xs_patch integer :: ye_patch, xe_patch integer :: ys_patch_fd, xs_patch_fd integer :: ye_patch_fd, xe_patch_fd integer :: nrad_on_patch, nrad_on_domain logical, allocatable :: patchmask(:,:) - type(viewlist), pointer :: head - type(viewlist), pointer :: current + type(viewnode), pointer :: head + type(viewnode), pointer :: current character(len=2) :: name_short character(len=10) :: name logical :: moving @@ -151,7 +146,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) type(viewinfo), target, allocatable :: view_att(:) type(viewinfo), pointer :: this_view - type(viewlist), pointer :: this_obslist + type(viewnode), pointer :: this_obslist integer :: first_file, tot_files_used, npass integer :: ncid, varid @@ -261,8 +256,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) nullify (head % next ) p => head - nullify(p_field) - num_goesabi_local = 0 num_goesabi_global = 0 num_goesabi_used = 0 @@ -318,7 +311,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) "find ",trim(this_view % fpath), & " -type f -name '",trim(fname), & "*G",satellite_id, & - "*' -printf ' % P\n' > ",trim(list_file) + "*' -printf '%P\n' > ",trim(list_file) call execute_command_line (trim(command)) write(command,fmt='(4A)') "cat ",trim(list_file)," | wc -l > ",trim(count_file) @@ -331,7 +324,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if #ifdef DM_PARALLEL call mpi_barrier(comm, ierr) - call mpi_bcast ( i_dummy, 1, mpi_integer, root, comm, ierr ) + call mpi_bcast ( i_dummy(1), 1, mpi_integer, root, comm, ierr ) this_view % nfiles = i_dummy(1) #endif if (this_view % nfiles .lt. 1) then @@ -379,9 +372,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ioff = 0 if (iview.eq.3 .or. iview.eq.4) ioff=1 - ioff = ioff+19 fname = trim(this_view % filename(ifile)) + read(fname(1+ioff:2+ioff),fmt='(I2.2)') this_view % filechan(ifile) !!! !! The channel could instead be read from band_id in each file, but @@ -487,28 +480,30 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) cycle end if - write(unit=stdout,fmt='(A,I0,A)') & - 'Processing GOES-',satellite_id,' ABI data for:' - write(unit=stdout,fmt='(2A)') & - ' ',fgat_times_c(ifgat) - if ( ipass .eq. 1 .and. count(this_view % file_fgat_match(:, ifgat)).gt.1 ) then - - ! Select a single file for this view, channel, and fgat + ! Select a single file for this view, channel, and fgat using min_time_diff do ifile = 1, this_view % nfiles if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) - if ( abs(this_view % fgat_time_diff(ifile, ifgat)) .gt. this_view % min_time_diff(ichan, ifgat) ) then + if ( abs(this_view % fgat_time_diff(ifile, ifgat)) .gt. & + this_view % min_time_diff(ichan, ifgat) ) then this_view % file_fgat_match(ifile,ifgat) = .false. end if end do end if + first_file = 0 do ifile = 1, this_view % nfiles if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle first_file = ifile exit end do + if (first_file .eq. 0) cycle + + write(unit=stdout,fmt='(A,I0,A)') & + 'Processing GOES-',satellite_id,' ABI data for:' + write(unit=stdout,fmt='(2A)') & + ' ',fgat_times_c(ifgat) fname_short = trim(this_view % filename(first_file)) fname = trim(this_view % fpath)//trim(fname_short) @@ -525,33 +520,41 @@ write(stdout,fmt=*) 'TEST1' ' Reading abi metadata for ',trim(this_view % name) call get_abil1b_metadata( & - fname, this_view % ny_global, this_view % nx_global, req, rpol, pph, nam)! , lat_sat, lon_sat ) + fname, this_view % ny_global, this_view % nx_global, & + req, rpol, pph, nam)! , lat_sat, lon_sat ) write(stdout,fmt=*) 'TEST2' write(stdout,fmt=*) this_view % ny_global, this_view % nx_global, req, rpol, pph, nam #ifdef DM_PARALLEL ! Split the global ABI grid for this view into local segments + allocate ( this_view % ny_grid ( num_procs ) ) + allocate ( this_view % nx_grid ( num_procs ) ) + allocate ( this_view % ys_grid ( num_procs ) ) + allocate ( this_view % xs_grid ( num_procs ) ) + call split_grid( this_view % ny_global, this_view % nx_global , & - this_view % ny_local, this_view % nx_local , & - this_view % ys_local, this_view % xs_local , & - (iview.eq.1) ) + this_view % ny_grid, this_view % nx_grid , & + this_view % ys_grid, this_view % xs_grid , & + .false. ) +!! (iview.eq.1) ) write(stdout,fmt=*) 'ntasks_y, ntasks_x, num_procs, myproc = ', ntasks_y, ntasks_x, num_procs, myproc - - write(stdout,fmt=*) 'TEST3' #else ! When mpi parallelism is not available, assign global values to local variables - this_view % ny_local = this_view % ny_global - this_view % nx_local = this_view % nx_global - this_view % ys_local = 1 - this_view % xs_local = 1 + this_view % ny_grid = this_view % ny_global + this_view % nx_grid = this_view % nx_global + this_view % ys_grid = 1 + this_view % xs_grid = 1 #endif -write(stdout,fmt=*) 'ny_local, nx_local, ys_local, xs_local = ', & - this_view % ny_local, this_view % nx_local, this_view % ys_local, this_view % xs_local +write(stdout,fmt=*) 'ny_grid, nx_grid, ys_grid, xs_grid = ' +write(stdout,fmt=*) this_view % ny_grid +write(stdout,fmt=*) this_view % nx_grid +write(stdout,fmt=*) this_view % ys_grid +write(stdout,fmt=*) this_view % xs_grid write(stdout,fmt=*) 'TEST4' @@ -607,128 +610,79 @@ write(stdout,fmt=*) 'TEST6' ! this_view % xoff_fd = this_view % xoff_fd - xoff_fd + 1 end if -write(stdout,fmt=*) 'TEST8' - -!Currently load balancing is a good start, but not very effective (see split_grid) -!Is there some way to subdivide the grid into smaller pieces and process in a round-robin fashion? Would need to send messages between processors to keep track of subsections that were already processed. Fields would need to be more flexible than simple 2d/1d arrays, possibly linked lists. - - - allocate(head_field) - nullify (head_field % next) - p_field => head_field - p_field % i = 0 +write(stdout,fmt=*) 'TEST7' !=========================================================== - ! Create a linked list of fields of observation location - ! quantities in round robin fashion across processors. - ! The linked field list approach balances processor loads - ! when some locations have missing data (Full Disk). + ! Create a local array subset of observation location + ! quantities across processors. !=========================================================== +! load_balance = iview.eq.1 +! if (load_balance) then + nrad_local = ny_global * nx_global / num_procs + 1 +! else +! nrad_local = this_view % ny_grid(iproc+1) * this_view % nx_grid(iproc+1) +! end if + allocate( lat_1d % local (nrad_local) ) + allocate( lon_1d % local (nrad_local) ) + allocate( satzen_1d % local (nrad_local) ) + allocate( loc_1d % local (nrad_local) ) + allocate( iy_1d % local (nrad_local) ) + allocate( ix_1d % local (nrad_local) ) + + n = 0 ; icount = 1 + ! This loop over subgrids and the selective logic + ! below for myproc balances the processor loads + ! when some imager subpoints are off-earth + ! (Full Disk) + do subgrid = 1, num_procs + ! Recall local dims for this_view + ny_local = this_view % ny_grid(subgrid) + nx_local = this_view % nx_grid(subgrid) + ys_local = this_view % ys_grid(subgrid) + xs_local = this_view % xs_grid(subgrid) + +write(stdout,fmt=*) 'TEST8', subgrid, n, icount +! include_local = ( subgrid-1 .eq. myproc ) + + do ixl = 1, nx_local + do iyl = 1, ny_local +! if (load_balance) & +! include_local = ( mod( n, num_procs ) .eq. myproc ) +! if ( include_local ) then + + if ( mod( n, num_procs ) .eq. myproc ) then + iy = iyl + ys_local - 1 + ix = ixl + xs_local - 1 + +!Might save some time by allocating mask arrays, and presetting all values to false instead of assigning one-by-one in grid2; would not be memory intensive + + call get_abil1b_grid2( yy(iy), xx(ix), req, rpol, pph, nam, satellite_id, & + lat_1d % local(icount), & + lon_1d % local(icount), & + satzen_1d % local(icount), & + earthmask, zenmask, & + loc_1d % local(icount), domainmask ) + + ! Advance counter for locations that pass all mask tests + if (earthmask .and. zenmask .and. domainmask) then + iy_1d % local(icount) = iy + ix_1d % local(icount) = ix + + icount = icount + 1 + end if -!SO FAR THIS IS ONLY SET UP TO RUN A SINGLE FIELD LIST MEMBER ON EACH PROCESSOR -!STILL NEED TO DEFINE NY, NX, YS, XS ACROSS MORE THAN NPROC FIELD MEMBERS -!THIS REQUIRES REDEFINING SPLIT_GRID ABOVE, THEN HANDLING THOSE DIM VARIABLES BELOW -!ALSO STILL NEED TO FIGURE OUT ROUND ROBIN TASK ASSIGNMENT - -!This allocation and subroutine are entirely independent for specified local segments -!BEGIN PARALLEL SECTION - - allocate(p_field % next) - i = p_field % i - p_field => p_field % next - p_field % i = i + 1 - nullify (p_field % next) - - !========================================== - ! Establish fields for local subset of - ! radiance locations in this view - !========================================== - - ! Recall local dims for this_view - ny_local = this_view % ny_local - nx_local = this_view % nx_local - ys_local = this_view % ys_local - xs_local = this_view % xs_local - - - !! Allocate local obs spatial fields for this view - allocate(p_field % lat % local(ny_local,nx_local)) - allocate(p_field % lon % local(ny_local,nx_local)) - allocate(p_field % satzen % local(ny_local,nx_local)) - allocate(p_field % obsj % local(ny_local,nx_local)) - allocate(p_field % obsi % local(ny_local,nx_local)) - - !! Allocate local mask fields for this view - allocate(earthmask(ny_local,nx_local)) - allocate(zenmask(ny_local,nx_local)) - - !! Allocate local model-specific fields - allocate(p_field % modj % local(ny_local,nx_local)) - allocate(p_field % modi % local(ny_local,nx_local)) - allocate(domainmask(ny_local,nx_local)) - - do iy = 1, ny_local - p_field % obsj % local(iy,:) = iy - end do - do ix = 1, nx_local - p_field % obsi % local(:,ix) = ix + end if + n = n + 1 + end do + end do end do - call get_abil1b_grid2( ny_global, nx_global, & - ny_local, nx_local, & - ys_local, xs_local, & - yy, xx, req, rpol, pph, nam, satellite_id, & - p_field % lat % local, & - p_field % lon % local, & - p_field % satzen % local, & - earthmask, zenmask, & - p_field % modj % local, & - p_field % modi % local, & - domainmask ) - -write(stdout,fmt=*) 'TEST8' - - - !========================================================== - ! Reduce local locations using all available masks - !========================================================== - -write(stdout,fmt=*) 'TEST9' - - allocate(allmask_local(ny_local,nx_local)) - allmask_local = & - (earthmask .and. zenmask .and. domainmask) - - p_field % nrad_mask = count( allmask_local ) - - allocate( p_field % lat % mask (p_field % nrad_mask) ) - allocate( p_field % lon % mask (p_field % nrad_mask) ) - allocate( p_field % satzen % mask (p_field % nrad_mask) ) - allocate( p_field % modj % mask (p_field % nrad_mask) ) - allocate( p_field % modi % mask (p_field % nrad_mask) ) - allocate( p_field % obsj % mask (p_field % nrad_mask) ) - allocate( p_field % obsi % mask (p_field % nrad_mask) ) - - p_field % lat % mask = pack( p_field % lat % local , allmask_local ) - p_field % lon % mask = pack( p_field % lon % local , allmask_local ) - p_field % satzen % mask = pack( p_field % satzen % local , allmask_local ) - p_field % modj % mask = pack( p_field % modj % local , allmask_local ) - p_field % modi % mask = pack( p_field % modi % local , allmask_local ) - p_field % obsj % mask = pack( p_field % obsj % local , allmask_local ) - p_field % obsi % mask = pack( p_field % obsi % local , allmask_local ) - - deallocate( p_field % lat % local, p_field % lon % local, p_field % satzen % local ) - deallocate( p_field % modj % local, p_field % modi % local ) - deallocate( allmask_local, earthmask, zenmask ) - deallocate( p_field % obsj % local, p_field % obsi % local, domainmask ) - -!END PARALLEL SECTION - deallocate( yy, xx ) + nrad_local = icount - 1 !======================================================= - ! Reduce all masked locations (local and remote) + ! Transfer applicable locations (local and remote) ! to linked list within this WRF patch (this_obslist) !======================================================= ! Destroy this_obslist if it was previously populated @@ -751,132 +705,131 @@ write(stdout,fmt=*) 'TEST9' this_view % patchmask = .false. this_view % nrad_on_domain = 0 -write(stdout,fmt=*) 'TEST10' +write(stdout,fmt=*) 'TEST9' - ! Reset field pointers - nfield_local = p_field % i - p_field => head_field - current_field => head_field + call mpi_allreduce(nrad_local, nbuf, 1, mpi_integer, mpi_max, comm, ierr) + + !ALLOCATE COMMUNICATION BUFFERS + allocate( buf_real( nbuf, 3 ) ) + allocate( buf_int ( nbuf, 2 ) ) + allocate( buf_loc ( nbuf, 1 ) ) ProcLoop: do iproc = 0, num_procs-1 - nfield_buf = nfield_local + nbuf = nrad_local #ifdef DM_PARALLEL - call mpi_bcast(nfield_buf, 1, mpi_integer, iproc, comm, ierr ) + call mpi_bcast(nbuf, 1, mpi_integer, iproc, comm, ierr ) #endif + if (nbuf .eq. 0) cycle + +write(stdout,fmt=*) 'TEST10', nbuf + +! !BCAST REMOTE FIELDS +! ! AND LOCF (derived type) +! ! TO LOCAL BUFFERS +! allocate( buf_real( nbuf, 3 ) ) +! allocate( buf_int ( nbuf, 2 ) ) +! allocate( buf_loc ( nbuf, 1 ) ) + + if (iproc .eq. myproc) then + buf_real(1:nbuf,1) = lat_1d % local (1:nbuf) + buf_real(1:nbuf,2) = lon_1d % local (1:nbuf) + buf_real(1:nbuf,3) = satzen_1d % local (1:nbuf) + buf_int (1:nbuf,1) = iy_1d % local (1:nbuf) + buf_int (1:nbuf,2) = ix_1d % local (1:nbuf) + buf_loc (1:nbuf,1) = loc_1d % local (1:nbuf) + else + buf_real = missing_r + buf_int = missing + buf_loc(:,1)%j = missing + buf_loc(:,1)%i = missing + buf_loc(:,1)%y = missing_r + buf_loc(:,1)%x = missing_r + end if +#ifdef DM_PARALLEL - FieldLoop: do ifield = 1, nfield_buf +write(stdout,fmt=*) 'TEST11' -#ifdef DM_PARALLEL - if (iproc .eq. myproc) then - p_field => p_field % next - nrad_buf = p_field % nrad_mask - end if + call mpi_bcast(buf_real(1:nbuf,:), nbuf * 3, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast(buf_int (1:nbuf,:), nbuf * 2, mpi_integer, iproc, comm, ierr ) - call mpi_bcast(nrad_buf, 1, mpi_integer, iproc, comm, ierr ) -#endif -#ifdef DM_PARALLEL - call mpi_barrier(comm, ierr) -#endif - if (nrad_buf .eq. 0) cycle - -write(stdout,fmt=*) 'TEST14', nrad_buf - - !BCAST REMOTE MASKED FIELDS TO LOCAL BUFFER - allocate( buf_real( nrad_buf, 3 ) ) - allocate( buf_int( nrad_buf, 4 ) ) - - if (iproc .eq. myproc) then - buf_real(:,1) = p_field % lat % mask - buf_real(:,2) = p_field % lon % mask - buf_real(:,3) = p_field % satzen % mask - buf_int (:,1) = p_field % modj % mask - buf_int (:,2) = p_field % modi % mask - buf_int (:,3) = p_field % obsj % mask - buf_int (:,4) = p_field % obsi % mask - else - buf_real = missing_r - buf_int = missing - end if -#ifdef DM_PARALLEL - call mpi_bcast(buf_real, nrad_buf * 3, true_mpi_real, iproc, comm, ierr ) - call mpi_bcast(buf_int, nrad_buf * 4, mpi_integer, iproc, comm, ierr ) +write(stdout,fmt=*) 'TEST12' + + !Only certain domain-wide components of loc previously defined in da_llxy + ! need to be communicated + ! i and j are needed for "outside" test below + call mpi_bcast( buf_loc(1:nbuf,1)%j, nbuf, mpi_integer, iproc, comm, ierr ) + call mpi_bcast( buf_loc(1:nbuf,1)%i, nbuf, mpi_integer, iproc, comm, ierr ) + +write(stdout,fmt=*) 'TEST13' + ! These are needed in the linked list for da_initialize_rad_iv + call mpi_bcast( buf_loc(1:nbuf,1)%y, nbuf, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast( buf_loc(1:nbuf,1)%x, nbuf, true_mpi_real, iproc, comm, ierr ) #endif -write(stdout,fmt=*) 'TEST11', iproc +write(stdout,fmt=*) 'TEST14', iproc - !PROCESS REMOTE FIELDS - current_field % lat % remote => buf_real(:,1) - current_field % lon % remote => buf_real(:,2) - current_field % satzen % remote => buf_real(:,3) - current_field % modj % remote => buf_int(:,1) - current_field % modi % remote => buf_int(:,2) - current_field % obsj % remote => buf_int(:,3) - current_field % obsi % remote => buf_int(:,4) + ! ASSOCIATE REMOTE POINTERS + lat_1d % remote => buf_real(1:nbuf,1) + lon_1d % remote => buf_real(1:nbuf,2) + satzen_1d % remote => buf_real(1:nbuf,3) + iy_1d % remote => buf_int (1:nbuf,1) + ix_1d % remote => buf_int (1:nbuf,2) + loc_1d % remote => buf_loc (1:nbuf,1) - this_view % nrad_on_domain = this_view % nrad_on_domain + nrad_buf - do n = 1, nrad_buf + ! PROCESS REMOTE LIST BUFFERS + this_view % nrad_on_domain = this_view % nrad_on_domain + nbuf + do n = 1, nbuf + +!Technically "outside" has already been determined for iproc, could utilize that knowledge to maintain iproc as master processor during this stage. Then it could transfer true_mpi_real quantities from buf_loc as needed by each processor. Would need to set up a query and response system somehow... + + loc = loc_1d % remote(n) #ifdef DM_PARALLEL - loc % j = current_field % modj % remote(n) - loc % i = current_field % modi % remote(n) - call da_llxy (info, loc, outside, patch_test_only = .true.) - if (outside) cycle + call da_llxy (info, loc, outside, outside_only = .true.) + if (outside) cycle #endif - iy = current_field % obsj % remote(n) - ix = current_field % obsi % remote(n) - this_view % patchmask(iy,ix) = .true. + iy = iy_1d % remote(n) + ix = ix_1d % remote(n) + this_view % patchmask(iy,ix) = .true. - allocate(this_obslist % next) - i = this_obslist % i - this_obslist => this_obslist % next - this_obslist % i = i + 1 - this_obslist % lat = current_field % lat % remote(n) - this_obslist % lon = current_field % lon % remote(n) - this_obslist % satzen = current_field % satzen % remote(n) - this_obslist % iy = iy - this_obslist % ix = ix + allocate(this_obslist % next) + i = this_obslist % i + this_obslist => this_obslist % next + this_obslist % i = i + 1 + this_obslist % lat = lat_1d % remote(n) + this_obslist % lon = lon_1d % remote(n) + this_obslist % satzen = satzen_1d % remote(n) + this_obslist % iy = iy + this_obslist % ix = ix + this_obslist % loc = loc - nullify (this_obslist % next) + nullify (this_obslist % next) -write(stdout,fmt=*) 'TEST18', iy, iproc, this_obslist % i +write(stdout,fmt=*) 'TEST15', iy, iproc, this_obslist % i - end do + end do - !FREE UP POINTERS AND BUFFERS - nullify ( current_field % lat % remote ) - nullify ( current_field % lon % remote ) - nullify ( current_field % satzen % remote ) - nullify ( current_field % modj % remote ) - nullify ( current_field % modi % remote ) - nullify ( current_field % obsj % remote ) - nullify ( current_field % obsi % remote ) + !FREE UP POINTERS AND BUFFERS + nullify ( lat_1d % remote ) + nullify ( lon_1d % remote ) + nullify ( satzen_1d % remote ) + nullify ( loc_1d % remote ) + nullify ( iy_1d % remote ) + nullify ( ix_1d % remote ) - deallocate( buf_real, buf_int) +! deallocate( buf_real, buf_int, buf_loc ) - end do FieldLoop -write(stdout,fmt=*) 'TEST19', iproc, this_obslist % i +write(stdout,fmt=*) 'TEST16', iproc, this_obslist % i end do ProcLoop - ! Destroy the field list - n = p_field % i - p_field => head_field % next - do i = 1, n - deallocate( p_field % lat % mask, & - p_field % lon % mask, & - p_field % satzen % mask, & - p_field % modj % mask, & - p_field % modi % mask, & - p_field % obsj % mask, & - p_field % obsi % mask) - - current_field => p_field - p_field => p_field % next - - ! free current data - deallocate ( current_field ) - end do - nullify(p_field) - deallocate(head_field) + deallocate( buf_real, buf_int, buf_loc ) + + deallocate( lat_1d % local ) + deallocate( lon_1d % local ) + deallocate( satzen_1d % local ) + deallocate( loc_1d % local ) + deallocate( iy_1d % local ) + deallocate( ix_1d % local ) this_view % nrad_on_patch = this_obslist % i @@ -888,14 +841,14 @@ write(stdout,fmt=*) 'TEST19', iproc, this_obslist % i do iy = 1, ny_global if ( any(this_view % patchmask(iy,:)) ) then this_view % ys_patch = iy - this_view % ys_patch_fd = iy+this_view % yoff_fd-1 ! offset to FD grid + this_view % ys_patch_fd = iy+this_view % yoff_fd ! offset to FD grid exit end if end do do iy = ny_global, 1, -1 if ( any(this_view % patchmask(iy,:)) ) then this_view % ye_patch = iy - this_view % ye_patch_fd = iy+this_view % yoff_fd-1 ! offset to FD grid + this_view % ye_patch_fd = iy+this_view % yoff_fd ! offset to FD grid exit end if end do @@ -906,27 +859,33 @@ write(stdout,fmt=*) 'TEST19', iproc, this_obslist % i do ix = 1, nx_global if ( any(this_view % patchmask(:,ix)) ) then this_view % xs_patch = ix - this_view % xs_patch_fd = ix+this_view % xoff_fd-1 ! offset to FD grid + this_view % xs_patch_fd = ix+this_view % xoff_fd ! offset to FD grid exit end if end do do ix = nx_global, 1, -1 if ( any(this_view % patchmask(:,ix)) ) then this_view % xe_patch = ix - this_view % xe_patch_fd = ix+this_view % xoff_fd-1 ! offset to FD grid + this_view % xe_patch_fd = ix+this_view % xoff_fd ! offset to FD grid exit end if end do +write(stdout,fmt=*) 'TEST17', this_view % ys_patch, this_view % ye_patch +write(stdout,fmt=*) 'TEST18', this_view % xs_patch, this_view % xe_patch +write(stdout,fmt=*) 'TEST19', this_view % ys_patch_fd, this_view % ye_patch_fd +write(stdout,fmt=*) 'TEST20', this_view % xs_patch_fd, this_view % xe_patch_fd + end if + end if -write(stdout,fmt=*) 'TEST24' +write(stdout,fmt=*) 'TEST21' end if PatchMatch: if (this_view % nrad_on_patch .gt. 0) then -write(stdout,fmt=*) 'TEST26' +write(stdout,fmt=*) 'TEST22' if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view % nfiles_used(:)).eq.0 ) then allocate(view_mask(& @@ -941,7 +900,7 @@ write(stdout,fmt=*) size(view_mask) write(stdout,fmt=*) sizeof(view_mask) end if -write(stdout,fmt=*) 'TEST27' +write(stdout,fmt=*) 'TEST23' ! Loop over channels ! This loop over channels could be parallelized, if needed for time savings @@ -1003,11 +962,9 @@ write(stdout,fmt=*) 'TEST27' else if (inst == 0) cycle - fname_short = trim(this_view % filename(ifile)) fname = trim(this_view % fpath)//trim(fname_short) - !!Utilizing these masks to eliminate data: !! + earthmask !! + zenmask @@ -1131,7 +1088,7 @@ write(stdout,fmt=*) 'TEST27' allocate ( p % tb_inv (1:nchan) ) p % info = info - p % loc = loc + p % loc = this_obslist % loc p % landsea_mask = 1 ! ??? if (use_view_mask) then p % scanpos = & @@ -1209,13 +1166,18 @@ write(stdout,fmt=*) 'TEST27' do iview = 1, nviews if ( .not.view_att(iview) % select ) cycle - deallocate(view_att(iview) % filename) - deallocate(view_att(iview) % filechan) - deallocate(view_att(iview) % filedate) - deallocate(view_att(iview) % file_fgat_match) - deallocate(view_att(iview) % fgat_time_diff) - deallocate(view_att(iview) % min_time_diff) - deallocate(view_att(iview) % nfiles_used) + this_view => view_att(iview) + deallocate ( this_view % filename ) + deallocate ( this_view % filechan ) + deallocate ( this_view % filedate ) + deallocate ( this_view % file_fgat_match ) + deallocate ( this_view % fgat_time_diff ) + deallocate ( this_view % min_time_diff ) + deallocate ( this_view % nfiles_used ) + deallocate ( this_view % ny_grid ) + deallocate ( this_view % nx_grid ) + deallocate ( this_view % ys_grid ) + deallocate ( this_view % xs_grid ) end do deallocate(view_att) @@ -1491,85 +1453,68 @@ end subroutine get_abil1b_grid1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -subroutine get_abil1b_grid2( ny, nx, nyl, nxl, ys, xs, & - yy, xx, req, rpol, pph, nam, satellite_id, & +subroutine get_abil1b_grid2( yy, xx, req, rpol, pph, nam, satellite_id, & lat, lon, satzen, & earthmask, zenmask, & - modj, modi, domainmask ) + loc, domainmask ) implicit none - integer, intent(in) :: ny, nx, nyl, nxl, ys, xs - real, intent(in) :: yy(ny), xx(nx) + real, intent(in) :: yy, xx real(r_kind), intent(in) :: req, rpol, pph, nam integer, intent(in) :: satellite_id ! GOES-ABI fields - real, intent(out) :: lat(nyl,nxl), lon(nyl,nxl), satzen(nyl,nxl) - logical, intent(out) :: earthmask(nyl,nxl), zenmask(nyl,nxl) + real, intent(out) :: lat, lon, satzen + logical, intent(out) :: earthmask, zenmask ! Model-specific fields - integer, optional, intent(out) :: modj(nyl,nxl), modi(nyl,nxl) - logical, optional, intent(out) :: domainmask(nyl,nxl) + type(model_loc_type), optional, intent(inout) :: loc + logical, optional, intent(out) :: domainmask ! Internal Variables type(info_type) :: info - type(model_loc_type) :: loc logical :: outside_all, dummy_bool - integer :: iy, ix, iyl, ixl + integer :: iy, ix real(r_kind) :: hh real, parameter :: satzen_limit=75.0 if (trace_use) call da_trace_entry("get_abil1b_grid2") - hh=pph+req - lat = missing_r lon = missing_r satzen = missing_r earthmask=.false. zenmask=.false. - - if ( present(modj) .and. present(modi) .and. present(domainmask) ) then - modj = missing - modi = missing + if ( present(domainmask) ) & domainmask = .false. - end if - do ixl = 1, nxl - ix = ixl + xs - 1 - do iyl = 1, nyl - iy = iyl + ys - 1 + hh=pph+req - call get_abil1b_latlon(yy(iy),xx(ix),req,rpol,hh,nam,lat(iyl,ixl),lon(iyl,ixl)) + call get_abil1b_latlon ( yy, xx, req, rpol, hh, nam, lat, lon ) - if( lat(iyl,ixl).eq.missing_r .OR. lon(iyl,ixl).eq.missing_r ) cycle + if( lat.eq.missing_r .OR. lon.eq.missing_r .OR. & + isnan(lat) .OR. isnan(lon) ) return - earthmask(iyl,ixl)=.true. + earthmask=.true. - !Populate domainmask, modi, modj with model coordinate utility - if ( present(modj) .and. present(modi) .and. present(domainmask) ) then - info % lon = lon(iyl,ixl) ! longitude - info % lat = lat(iyl,ixl) ! latitude - call da_llxy (info, loc, dummy_bool, outside_all) - if (.not. outside_all) then - modj(iyl,ixl) = loc % j - modi(iyl,ixl) = loc % i - domainmask(iyl,ixl) = .true. - end if - end if + call da_get_satzen(lat,lon,satellite_id,satzen) - call da_get_satzen(lat(iyl,ixl),lon(iyl,ixl),satellite_id,satzen(iyl,ixl)) - - if (satzen(iyl,ixl).gt.satzen_limit) then - satzen(iyl,ixl) = missing_r - cycle - end if - zenmask(iyl,ixl)=.true. - end do - end do + if ( isnan(satzen) .or. satzen.gt.satzen_limit ) then + satzen = missing_r + return + end if + zenmask=.true. + + !Populate domainmask, loc with model coordinate utility + if ( present(loc) .and. present(domainmask) ) then + info % lat = lat ! latitude + info % lon = lon ! longitude + call da_llxy (info, loc, dummy_bool, outside_all) + domainmask = .not.outside_all + end if if (trace_use) call da_trace_exit("get_abil1b_grid2") @@ -1703,42 +1648,42 @@ end subroutine get_abil1b_latlon !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine split_grid( ny_global, nx_global, & - ny_local, nx_local, & - ys_local, xs_local, & + ny_grid, nx_grid, & + ys_grid, xs_grid, & redist ) implicit none integer, intent(in) :: ny_global, nx_global logical, intent(in) :: redist - integer, intent(out) :: ny_local, nx_local, & - ys_local, xs_local + integer, intent(out) :: ny_grid(num_procs), nx_grid(num_procs), & + ys_grid(num_procs), xs_grid(num_procs) - integer, target :: ny_grid(ntasks_y), ys_grid(ntasks_y) !, ye_grid(ntasks_y) - integer, target :: nx_grid(ntasks_x), xs_grid(ntasks_x) !, xe_grid(ntasks_x) - integer, pointer :: ngrid(:), sgrid(:) + integer, target :: ny_vec(ntasks_y), ys_vec(ntasks_y) !, ye_vec(ntasks_y) + integer, target :: nx_vec(ntasks_x), xs_vec(ntasks_x) !, xe_vec(ntasks_x) + integer, pointer :: nvec(:), svec(:) integer :: mm, i, j, ii, iproc, igrid, ntasks, nglobal, fact do igrid = 1, 2 if (igrid.eq.1) then - ngrid => ny_grid - sgrid => ys_grid + nvec => ny_vec + svec => ys_vec ntasks = ntasks_y nglobal = ny_global else if (igrid.eq.2) then - ngrid => nx_grid - sgrid => xs_grid + nvec => nx_vec + svec => xs_vec ntasks = ntasks_x nglobal = nx_global end if - ngrid = nglobal / ntasks + nvec = nglobal / ntasks mm = mod( nglobal , ntasks ) do j = 1, ntasks - ngrid(j) = ngrid(j) + 1 + if ( mm .eq. 0 ) exit + nvec(j) = nvec(j) + 1 mm = mm - 1 - if (mm .eq. 0) exit end do if (redist) then @@ -1748,46 +1693,55 @@ subroutine split_grid( ny_global, nx_global, & do i = 1, 2 if (mod(ntasks,2).eq.1) then ii = ntasks/2+1 - mm = ngrid(ii) / fact + mm = nvec(ii) / fact mm = mm/2 - ngrid(ii) = ngrid(ii) - 2*mm - ngrid(ii-1) = ngrid(ii-1) + mm - ngrid(ii+1) = ngrid(ii+1) + mm + nvec(ii) = nvec(ii) - 2*mm + nvec(ii-1) = nvec(ii-1) + mm + nvec(ii+1) = nvec(ii+1) + mm else ii = ntasks/2 end if do j = ntasks/2, 2, -1 - mm = ngrid(j) / fact - ngrid(j) = ngrid(j) - mm - ngrid(j-1) = ngrid(j-1) + mm + mm = nvec(j) / fact + nvec(j) = nvec(j) - mm + nvec(j-1) = nvec(j-1) + mm end do do j = ii+1, ntasks-1 - mm = ngrid(j) / fact - ngrid(j) = ngrid(j) - mm - ngrid(j+1) = ngrid(j+1) + mm + mm = nvec(j) / fact + nvec(j) = nvec(j) - mm + nvec(j+1) = nvec(j+1) + mm end do end do end if - sgrid(1) = 1 + svec(1) = 1 do j = 1, ntasks -! if (j .eq. 1) egrid(1) = ngrid(1) !NOT NECESSARY +! if (j .eq. 1) evec(1) = nvec(1) !NOT NECESSARY if (j .lt. ntasks) then - sgrid(j+1) = sgrid(j) + ngrid(j) -! egrid(j+1) = egrid(j) + ngrid(j+1) !NOT NECESSARY + svec(j+1) = svec(j) + nvec(j) +! evec(j+1) = evec(j) + nvec(j+1) !NOT NECESSARY end if end do end do - j = myproc / ntasks_x + 1 - ny_local = ny_grid(j) - ys_local = ys_grid(j) - - i = mod(myproc, ntasks_x) + 1 - nx_local = nx_grid(i) - xs_local = xs_grid(i) + iproc = 0 + do j = 1, ntasks_y + do i = 1, ntasks_x + iproc = iproc + 1 + ny_grid(iproc) = ny_vec(j) + ys_grid(iproc) = ys_vec(j) + nx_grid(iproc) = nx_vec(i) + xs_grid(iproc) = xs_vec(i) + end do + end do -write(stdout,fmt=*) 'TEST57', myproc, j, i +! j = myproc / ntasks_x + 1 +! ny_local = ny_grid(j) +! ys_local = ys_grid(j) +! +! i = mod(myproc, ntasks_x) + 1 +! nx_local = nx_grid(i) +! xs_local = xs_grid(i) end subroutine split_grid diff --git a/var/da/da_tools/da_llxy.inc b/var/da/da_tools/da_llxy.inc index 01d6ee19d6..59ef70201a 100644 --- a/var/da/da_tools/da_llxy.inc +++ b/var/da/da_tools/da_llxy.inc @@ -1,4 +1,4 @@ -subroutine da_llxy (info, loc, outside, outside_all, patch_test_only) +subroutine da_llxy (info, loc, outside, outside_all, outside_only) !----------------------------------------------------------------------- ! Purpose: TBD @@ -14,20 +14,20 @@ subroutine da_llxy (info, loc, outside, outside_all, patch_test_only) type(model_loc_type), intent(inout) :: loc logical , intent(out) :: outside !wrt local domain logical, optional, intent(out) :: outside_all !wrt all domains - logical, optional, intent(in) :: patch_test_only + logical, optional, intent(in) :: outside_only - logical :: include_xy + logical :: include_xy_convert ! too many return statments to trace ! if (trace_use_frequent) call da_trace_entry("da_llxy") - include_xy = .true. - if (present(patch_test_only)) include_xy = .not.patch_test_only + include_xy_convert = .true. + if (present(outside_only)) include_xy_convert = .not.outside_only outside = .false. - if (include_xy) then + if (include_xy_convert) then loc % x = -1.0 loc % y = -1.0 @@ -42,43 +42,42 @@ subroutine da_llxy (info, loc, outside, outside_all, patch_test_only) else call da_llxy_default (info%lat, info%lon, loc%x, loc%y) end if + end if + #ifdef A2C - call da_togrid (loc%x, its-3, ite+3, loc%i, loc%dx, loc%dxm)! + call da_togrid (loc%x, its-3, ite+3, loc%i, loc%dx, loc%dxm)! - call da_togrid (loc%y, jts-3, jte+3, loc%j, loc%dy, loc%dym) + call da_togrid (loc%y, jts-3, jte+3, loc%j, loc%dy, loc%dym) #else - call da_togrid (loc%x, its-2, ite+2, loc%i, loc%dx, loc%dxm)! + call da_togrid (loc%x, its-2, ite+2, loc%i, loc%dx, loc%dxm)! - call da_togrid (loc%y, jts-2, jte+2, loc%j, loc%dy, loc%dym) + call da_togrid (loc%y, jts-2, jte+2, loc%j, loc%dy, loc%dym) #endif - ! refactor to remove this ugly duplication later - if (present(outside_all)) then - outside_all = .false. - ! Do not check for global options - if (.not. global) then - if ((int(loc%x) < ids) .or. (int(loc%x) >= ide) .or. & - (int(loc%y) < jds) .or. (int(loc%y) >= jde)) then - outside_all = .true. - outside = .true. - return - end if - if (def_sub_domain) then - if (x_start_sub_domain > loc%x .or. y_start_sub_domain > loc%y .or. & - x_end_sub_domain < loc%x .or. y_end_sub_domain < loc%y) then - outside_all = .true. - outside = .true. - return - end if + ! refactor to remove this ugly duplication later + if (present(outside_all)) then + outside_all = .false. + ! Do not check for global options + if (.not. global) then + if ((int(loc%x) < ids) .or. (int(loc%x) >= ide) .or. & + (int(loc%y) < jds) .or. (int(loc%y) >= jde)) then + outside_all = .true. + outside = .true. + return + end if + if (def_sub_domain) then + if (x_start_sub_domain > loc%x .or. y_start_sub_domain > loc%y .or. & + x_end_sub_domain < loc%x .or. y_end_sub_domain < loc%y) then + outside_all = .true. + outside = .true. + return end if end if end if - - else - if (present(outside_all)) outside_all = .false. end if + if (fg_format == fg_format_kma_global) then if ((loc%j < jts-1) .or. (loc%j > jte)) then outside = .true. From e8b1a1e7a5e62ec99d72d53525229a4196e8e1d6 Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Mon, 21 May 2018 11:29:24 -0600 Subject: [PATCH 07/86] Load balancing in loop over processors. Increases memory requirement. --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 130 ++++++++++--------- 1 file changed, 70 insertions(+), 60 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 3769570634..ae631fea05 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -39,7 +39,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: ny_global, nx_global integer :: yoff_fd, xoff_fd ! For MPI parallelization - integer :: nbuf, nrad_local + integer :: nbuf, nrad_local, buf_i, buf_f integer :: ny_local, nx_local integer :: ys_local, xs_local @@ -707,20 +707,31 @@ write(stdout,fmt=*) 'TEST8', subgrid, n, icount write(stdout,fmt=*) 'TEST9' - call mpi_allreduce(nrad_local, nbuf, 1, mpi_integer, mpi_max, comm, ierr) + call mpi_allreduce(nrad_local, nbuf, 1, mpi_integer, mpi_sum, comm, ierr) !ALLOCATE COMMUNICATION BUFFERS allocate( buf_real( nbuf, 3 ) ) allocate( buf_int ( nbuf, 2 ) ) allocate( buf_loc ( nbuf, 1 ) ) + this_view % nrad_on_domain = nbuf + +!This loop is much faster when num_procs is small (36) versus large (288) +!In addition to reducing communications, I believe the small num_procs balances the load +! in the nbuf loop by ensuring that each local data set includes locations from +! more than 1-5 processors. I thought that the load balancing above would solve that +! issue, but clearly it does not. Both the above loop and the below loop need to +! have balanced loads to perform well in large num_procs. How to balance the following loop? + + buf_f = 0 ProcLoop: do iproc = 0, num_procs-1 nbuf = nrad_local #ifdef DM_PARALLEL call mpi_bcast(nbuf, 1, mpi_integer, iproc, comm, ierr ) #endif if (nbuf .eq. 0) cycle - + buf_i = buf_f + 1 + buf_f = buf_i + nbuf - 1 write(stdout,fmt=*) 'TEST10', nbuf ! !BCAST REMOTE FIELDS @@ -731,96 +742,95 @@ write(stdout,fmt=*) 'TEST10', nbuf ! allocate( buf_loc ( nbuf, 1 ) ) if (iproc .eq. myproc) then - buf_real(1:nbuf,1) = lat_1d % local (1:nbuf) - buf_real(1:nbuf,2) = lon_1d % local (1:nbuf) - buf_real(1:nbuf,3) = satzen_1d % local (1:nbuf) - buf_int (1:nbuf,1) = iy_1d % local (1:nbuf) - buf_int (1:nbuf,2) = ix_1d % local (1:nbuf) - buf_loc (1:nbuf,1) = loc_1d % local (1:nbuf) + buf_real(buf_i:buf_f,1) = lat_1d % local (1:nbuf) + buf_real(buf_i:buf_f,2) = lon_1d % local (1:nbuf) + buf_real(buf_i:buf_f,3) = satzen_1d % local (1:nbuf) + buf_int (buf_i:buf_f,1) = iy_1d % local (1:nbuf) + buf_int (buf_i:buf_f,2) = ix_1d % local (1:nbuf) + buf_loc (buf_i:buf_f,1) = loc_1d % local (1:nbuf) else - buf_real = missing_r - buf_int = missing - buf_loc(:,1)%j = missing - buf_loc(:,1)%i = missing - buf_loc(:,1)%y = missing_r - buf_loc(:,1)%x = missing_r + buf_real(buf_i:buf_f,:) = missing_r + buf_int(buf_i:buf_f,:) = missing + buf_loc(buf_i:buf_f,1)%j = missing + buf_loc(buf_i:buf_f,1)%i = missing + buf_loc(buf_i:buf_f,1)%y = missing_r + buf_loc(buf_i:buf_f,1)%x = missing_r end if #ifdef DM_PARALLEL write(stdout,fmt=*) 'TEST11' - call mpi_bcast(buf_real(1:nbuf,:), nbuf * 3, true_mpi_real, iproc, comm, ierr ) - call mpi_bcast(buf_int (1:nbuf,:), nbuf * 2, mpi_integer, iproc, comm, ierr ) + call mpi_bcast(buf_real(buf_i:buf_f,:), nbuf * 3, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast(buf_int (buf_i:buf_f,:), nbuf * 2, mpi_integer, iproc, comm, ierr ) write(stdout,fmt=*) 'TEST12' !Only certain domain-wide components of loc previously defined in da_llxy ! need to be communicated ! i and j are needed for "outside" test below - call mpi_bcast( buf_loc(1:nbuf,1)%j, nbuf, mpi_integer, iproc, comm, ierr ) - call mpi_bcast( buf_loc(1:nbuf,1)%i, nbuf, mpi_integer, iproc, comm, ierr ) + call mpi_bcast( buf_loc(buf_i:buf_f,1)%j, nbuf, mpi_integer, iproc, comm, ierr ) + call mpi_bcast( buf_loc(buf_i:buf_f,1)%i, nbuf, mpi_integer, iproc, comm, ierr ) write(stdout,fmt=*) 'TEST13' ! These are needed in the linked list for da_initialize_rad_iv - call mpi_bcast( buf_loc(1:nbuf,1)%y, nbuf, true_mpi_real, iproc, comm, ierr ) - call mpi_bcast( buf_loc(1:nbuf,1)%x, nbuf, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast( buf_loc(buf_i:buf_f,1)%y, nbuf, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast( buf_loc(buf_i:buf_f,1)%x, nbuf, true_mpi_real, iproc, comm, ierr ) #endif - write(stdout,fmt=*) 'TEST14', iproc - ! ASSOCIATE REMOTE POINTERS - lat_1d % remote => buf_real(1:nbuf,1) - lon_1d % remote => buf_real(1:nbuf,2) - satzen_1d % remote => buf_real(1:nbuf,3) - iy_1d % remote => buf_int (1:nbuf,1) - ix_1d % remote => buf_int (1:nbuf,2) - loc_1d % remote => buf_loc (1:nbuf,1) + end do ProcLoop + - ! PROCESS REMOTE LIST BUFFERS - this_view % nrad_on_domain = this_view % nrad_on_domain + nbuf - do n = 1, nbuf + ! ASSOCIATE REMOTE POINTERS + lat_1d % remote => buf_real(:,1) + lon_1d % remote => buf_real(:,2) + satzen_1d % remote => buf_real(:,3) + iy_1d % remote => buf_int (:,1) + ix_1d % remote => buf_int (:,2) + loc_1d % remote => buf_loc (:,1) + + ! PROCESS REMOTE BUFFERS + do n = 1, this_view % nrad_on_domain !Technically "outside" has already been determined for iproc, could utilize that knowledge to maintain iproc as master processor during this stage. Then it could transfer true_mpi_real quantities from buf_loc as needed by each processor. Would need to set up a query and response system somehow... - loc = loc_1d % remote(n) + loc = loc_1d % remote(n) #ifdef DM_PARALLEL - call da_llxy (info, loc, outside, outside_only = .true.) - if (outside) cycle + call da_llxy (info, loc, outside, outside_only = .true.) + if (outside) cycle #endif - iy = iy_1d % remote(n) - ix = ix_1d % remote(n) - this_view % patchmask(iy,ix) = .true. + iy = iy_1d % remote(n) + ix = ix_1d % remote(n) + this_view % patchmask(iy,ix) = .true. - allocate(this_obslist % next) - i = this_obslist % i - this_obslist => this_obslist % next - this_obslist % i = i + 1 - this_obslist % lat = lat_1d % remote(n) - this_obslist % lon = lon_1d % remote(n) - this_obslist % satzen = satzen_1d % remote(n) - this_obslist % iy = iy - this_obslist % ix = ix - this_obslist % loc = loc + allocate(this_obslist % next) + i = this_obslist % i + this_obslist => this_obslist % next + this_obslist % i = i + 1 + this_obslist % lat = lat_1d % remote(n) + this_obslist % lon = lon_1d % remote(n) + this_obslist % satzen = satzen_1d % remote(n) + this_obslist % iy = iy + this_obslist % ix = ix + this_obslist % loc = loc - nullify (this_obslist % next) + nullify (this_obslist % next) -write(stdout,fmt=*) 'TEST15', iy, iproc, this_obslist % i +write(stdout,fmt=*) 'TEST15', iy, ix, this_obslist % i - end do + end do - !FREE UP POINTERS AND BUFFERS - nullify ( lat_1d % remote ) - nullify ( lon_1d % remote ) - nullify ( satzen_1d % remote ) - nullify ( loc_1d % remote ) - nullify ( iy_1d % remote ) - nullify ( ix_1d % remote ) + !FREE UP POINTERS AND BUFFERS + nullify ( lat_1d % remote ) + nullify ( lon_1d % remote ) + nullify ( satzen_1d % remote ) + nullify ( loc_1d % remote ) + nullify ( iy_1d % remote ) + nullify ( ix_1d % remote ) -! deallocate( buf_real, buf_int, buf_loc ) write(stdout,fmt=*) 'TEST16', iproc, this_obslist % i - end do ProcLoop deallocate( buf_real, buf_int, buf_loc ) From 344a2849df4ae18cff023def8006f82446dc0440 Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Mon, 21 May 2018 12:45:37 -0600 Subject: [PATCH 08/86] Removing patch linked list of locations in favor of a post-allocataed 1d array --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 340 ++++++++++--------- 1 file changed, 188 insertions(+), 152 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index ae631fea05..b090d4659e 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -52,26 +52,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) type(model_loc_type), allocatable, target :: buf_loc(:,:) - type field_r - real, pointer :: local(:) - real, pointer :: remote(:) - end type field_r - type field_i - integer, pointer :: local(:) - integer, pointer :: remote(:) - end type field_i - type field_loc - type(model_loc_type), pointer :: local(:) - type(model_loc_type), pointer :: remote(:) - end type field_loc - - type(field_r) :: lat_1d, lon_1d, satzen_1d - type(field_i) :: iy_1d, ix_1d - type(field_loc) :: loc_1d - ! Masks for data reduction - logical :: earthmask, zenmask, domainmask, include_local, load_balance + logical :: earthmask, zenmask, domainmask !, include_local, load_balance logical, allocatable :: & + patchmask_1d(:) , & allmask_patch(:,:) , & allmask_local(:,:) , & thinmask(:,:) @@ -108,14 +92,30 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: yr, mt, dy, hr, mn, sc end type date_type - ! Linked list type for radiance location information - type viewnode - real :: lat, lon, satzen - integer :: iy, ix - type(model_loc_type) :: loc - type(viewnode), pointer :: next - integer :: i - end type viewnode +! ! Linked list type for radiance location information +! type viewnode +! real :: lat, lon, satzen +! integer :: iy, ix +! type(model_loc_type) :: loc +! type(viewnode), pointer :: next +! integer :: i +! end type viewnode + + type field_r + real, pointer :: local(:) + real, pointer :: global(:) + real, pointer :: patch(:) + end type field_r + type field_i + integer, pointer :: local(:) + integer, pointer :: global(:) + integer, pointer :: patch(:) + end type field_i + type field_loc + type(model_loc_type), pointer :: local(:) + type(model_loc_type), pointer :: global(:) + type(model_loc_type), pointer :: patch(:) + end type field_loc type viewinfo logical :: select @@ -137,8 +137,13 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: ye_patch_fd, xe_patch_fd integer :: nrad_on_patch, nrad_on_domain logical, allocatable :: patchmask(:,:) - type(viewnode), pointer :: head - type(viewnode), pointer :: current +! type(viewnode), pointer :: head +! type(viewnode), pointer :: current + + type(field_r) :: lat_1d, lon_1d, satzen_1d + type(field_i) :: iy_1d, ix_1d + type(field_loc) :: loc_1d + character(len=2) :: name_short character(len=10) :: name logical :: moving @@ -146,7 +151,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) type(viewinfo), target, allocatable :: view_att(:) type(viewinfo), pointer :: this_view - type(viewnode), pointer :: this_obslist +! type(viewnode), pointer :: this_obslist integer :: first_file, tot_files_used, npass integer :: ncid, varid @@ -282,14 +287,14 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) do iview = 1, nviews this_view => view_att(iview) - !Initialize linked list for obs in this view - if (ipass .eq. 1) then - allocate(view_att(iview) % head) - view_att(iview) % head % i = 0 - nullify(view_att(iview) % head % next) - end if - ! Associate this_obslist - this_obslist => view_att(iview) % head +! !Initialize linked list for obs in this view +! if (ipass .eq. 1) then +! allocate(view_att(iview) % head) +! view_att(iview) % head % i = 0 +! nullify(view_att(iview) % head % next) +! end if +! ! Associate this_obslist +! this_obslist => view_att(iview) % head if ( .not.this_view % select ) cycle @@ -622,12 +627,12 @@ write(stdout,fmt=*) 'TEST7' ! else ! nrad_local = this_view % ny_grid(iproc+1) * this_view % nx_grid(iproc+1) ! end if - allocate( lat_1d % local (nrad_local) ) - allocate( lon_1d % local (nrad_local) ) - allocate( satzen_1d % local (nrad_local) ) - allocate( loc_1d % local (nrad_local) ) - allocate( iy_1d % local (nrad_local) ) - allocate( ix_1d % local (nrad_local) ) + allocate( this_view % lat_1d % local (nrad_local) ) + allocate( this_view % lon_1d % local (nrad_local) ) + allocate( this_view % satzen_1d % local (nrad_local) ) + allocate( this_view % loc_1d % local (nrad_local) ) + allocate( this_view % iy_1d % local (nrad_local) ) + allocate( this_view % ix_1d % local (nrad_local) ) n = 0 ; icount = 1 ! This loop over subgrids and the selective logic @@ -657,16 +662,16 @@ write(stdout,fmt=*) 'TEST8', subgrid, n, icount !Might save some time by allocating mask arrays, and presetting all values to false instead of assigning one-by-one in grid2; would not be memory intensive call get_abil1b_grid2( yy(iy), xx(ix), req, rpol, pph, nam, satellite_id, & - lat_1d % local(icount), & - lon_1d % local(icount), & - satzen_1d % local(icount), & + this_view % lat_1d % local(icount), & + this_view % lon_1d % local(icount), & + this_view % satzen_1d % local(icount), & earthmask, zenmask, & - loc_1d % local(icount), domainmask ) + this_view % loc_1d % local(icount), domainmask ) ! Advance counter for locations that pass all mask tests if (earthmask .and. zenmask .and. domainmask) then - iy_1d % local(icount) = iy - ix_1d % local(icount) = ix + this_view % iy_1d % local(icount) = iy + this_view % ix_1d % local(icount) = ix icount = icount + 1 end if @@ -685,20 +690,20 @@ write(stdout,fmt=*) 'TEST8', subgrid, n, icount ! Transfer applicable locations (local and remote) ! to linked list within this WRF patch (this_obslist) !======================================================= - ! Destroy this_obslist if it was previously populated - if (this_obslist % i .gt. 0) then - n = this_obslist % i - this_obslist => view_att(iview) % head % next - do i = 1, n - view_att(iview) % current => this_obslist - this_obslist => this_obslist % next - - ! free current data - deallocate ( view_att(iview) % current ) - end do - ! Reassociate this_obslist - this_obslist => view_att(iview) % head - end if +! ! Destroy this_obslist if it was previously populated +! if (this_obslist % i .gt. 0) then +! n = this_obslist % i +! this_obslist => view_att(iview) % head % next +! do i = 1, n +! view_att(iview) % current => this_obslist +! this_obslist => this_obslist % next +! +! ! free current data +! deallocate ( view_att(iview) % current ) +! end do +! ! Reassociate this_obslist +! this_obslist => view_att(iview) % head +! end if ! Setup global patch mask for this view allocate(this_view % patchmask(ny_global,nx_global)) @@ -723,6 +728,7 @@ write(stdout,fmt=*) 'TEST9' ! issue, but clearly it does not. Both the above loop and the below loop need to ! have balanced loads to perform well in large num_procs. How to balance the following loop? + ! COMMUNICATE 1D FIELDS FROM REMOTE PROCS TO LOCAL BUFFER buf_f = 0 ProcLoop: do iproc = 0, num_procs-1 nbuf = nrad_local @@ -742,12 +748,12 @@ write(stdout,fmt=*) 'TEST10', nbuf ! allocate( buf_loc ( nbuf, 1 ) ) if (iproc .eq. myproc) then - buf_real(buf_i:buf_f,1) = lat_1d % local (1:nbuf) - buf_real(buf_i:buf_f,2) = lon_1d % local (1:nbuf) - buf_real(buf_i:buf_f,3) = satzen_1d % local (1:nbuf) - buf_int (buf_i:buf_f,1) = iy_1d % local (1:nbuf) - buf_int (buf_i:buf_f,2) = ix_1d % local (1:nbuf) - buf_loc (buf_i:buf_f,1) = loc_1d % local (1:nbuf) + buf_real(buf_i:buf_f,1) = this_view % lat_1d % local (1:nbuf) + buf_real(buf_i:buf_f,2) = this_view % lon_1d % local (1:nbuf) + buf_real(buf_i:buf_f,3) = this_view % satzen_1d % local (1:nbuf) + buf_int (buf_i:buf_f,1) = this_view % iy_1d % local (1:nbuf) + buf_int (buf_i:buf_f,2) = this_view % ix_1d % local (1:nbuf) + buf_loc (buf_i:buf_f,1) = this_view % loc_1d % local (1:nbuf) else buf_real(buf_i:buf_f,:) = missing_r buf_int(buf_i:buf_f,:) = missing @@ -765,14 +771,9 @@ write(stdout,fmt=*) 'TEST11' write(stdout,fmt=*) 'TEST12' +write(stdout,fmt=*) 'TEST13' !Only certain domain-wide components of loc previously defined in da_llxy ! need to be communicated - ! i and j are needed for "outside" test below - call mpi_bcast( buf_loc(buf_i:buf_f,1)%j, nbuf, mpi_integer, iproc, comm, ierr ) - call mpi_bcast( buf_loc(buf_i:buf_f,1)%i, nbuf, mpi_integer, iproc, comm, ierr ) - -write(stdout,fmt=*) 'TEST13' - ! These are needed in the linked list for da_initialize_rad_iv call mpi_bcast( buf_loc(buf_i:buf_f,1)%y, nbuf, true_mpi_real, iproc, comm, ierr ) call mpi_bcast( buf_loc(buf_i:buf_f,1)%x, nbuf, true_mpi_real, iproc, comm, ierr ) #endif @@ -780,68 +781,94 @@ write(stdout,fmt=*) 'TEST14', iproc end do ProcLoop + ! ASSOCIATE REMOTE POINTERS WITH BUFFERS OF DOMAIN-WIDE OBS + this_view % lat_1d % global => buf_real(:,1) + this_view % lon_1d % global => buf_real(:,2) + this_view % satzen_1d % global => buf_real(:,3) + this_view % iy_1d % global => buf_int (:,1) + this_view % ix_1d % global => buf_int (:,2) + this_view % loc_1d % global => buf_loc (:,1) - ! ASSOCIATE REMOTE POINTERS - lat_1d % remote => buf_real(:,1) - lon_1d % remote => buf_real(:,2) - satzen_1d % remote => buf_real(:,3) - iy_1d % remote => buf_int (:,1) - ix_1d % remote => buf_int (:,2) - loc_1d % remote => buf_loc (:,1) + allocate ( patchmask_1d (this_view % nrad_on_domain) ) + patchmask_1d = .false. + icount = 0 - ! PROCESS REMOTE BUFFERS - do n = 1, this_view % nrad_on_domain +write(stdout,fmt=*) 'TEST15', this_view % nrad_on_domain -!Technically "outside" has already been determined for iproc, could utilize that knowledge to maintain iproc as master processor during this stage. Then it could transfer true_mpi_real quantities from buf_loc as needed by each processor. Would need to set up a query and response system somehow... - - loc = loc_1d % remote(n) + ! PROCESS LOCAL BUFFERS OF DOMAIN-WIDE OBS + do n = 1, this_view % nrad_on_domain + loc % y = this_view % loc_1d % global(n) % y + loc % x = this_view % loc_1d % global(n) % x #ifdef DM_PARALLEL call da_llxy (info, loc, outside, outside_only = .true.) if (outside) cycle #endif - iy = iy_1d % remote(n) - ix = ix_1d % remote(n) + iy = this_view % iy_1d % global(n) + ix = this_view % ix_1d % global(n) + this_view % loc_1d % global(n) = loc !Includes updates from da_llxy this_view % patchmask(iy,ix) = .true. - - allocate(this_obslist % next) - i = this_obslist % i - this_obslist => this_obslist % next - this_obslist % i = i + 1 - this_obslist % lat = lat_1d % remote(n) - this_obslist % lon = lon_1d % remote(n) - this_obslist % satzen = satzen_1d % remote(n) - this_obslist % iy = iy - this_obslist % ix = ix - this_obslist % loc = loc - - nullify (this_obslist % next) - -write(stdout,fmt=*) 'TEST15', iy, ix, this_obslist % i + patchmask_1d(n) = .true. + icount = icount + 1 + +write(stdout,fmt=*) 'TEST16', iy, ix, n, icount + +! allocate(this_obslist % next) +! i = this_obslist % i +! this_obslist => this_obslist % next +! this_obslist % i = i + 1 +! this_obslist % lat = this_view % lat_1d % global(n) +! this_obslist % lon = this_view % lon_1d % global(n) +! this_obslist % satzen = this_view % satzen_1d % global(n) +! this_obslist % iy = iy +! this_obslist % ix = ix +! this_obslist % loc = loc +! +! nullify (this_obslist % next) +! +!write(stdout,fmt=*) 'TEST17', iy, ix, n, this_obslist % i end do - !FREE UP POINTERS AND BUFFERS - nullify ( lat_1d % remote ) - nullify ( lon_1d % remote ) - nullify ( satzen_1d % remote ) - nullify ( loc_1d % remote ) - nullify ( iy_1d % remote ) - nullify ( ix_1d % remote ) - +! this_view % nrad_on_patch = this_obslist % i + this_view % nrad_on_patch = icount + +write(stdout,fmt=*) 'TEST18', this_view % nrad_on_patch + + if ( this_view % nrad_on_patch .gt. 0 ) then + allocate( this_view % lat_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % lon_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % satzen_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % iy_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % ix_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % loc_1d % patch (this_view % nrad_on_patch) ) + + this_view % lat_1d % patch = pack( this_view % lat_1d % global, patchmask_1d) + this_view % lon_1d % patch = pack( this_view % lon_1d % global, patchmask_1d) + this_view % satzen_1d % patch = pack( this_view % satzen_1d % global, patchmask_1d) + this_view % iy_1d % patch = pack( this_view % iy_1d % global, patchmask_1d) + this_view % ix_1d % patch = pack( this_view % ix_1d % global, patchmask_1d) + this_view % loc_1d % patch = pack( this_view % loc_1d % global, patchmask_1d) + end if -write(stdout,fmt=*) 'TEST16', iproc, this_obslist % i + !FREE UP POINTERS AND BUFFERS + nullify ( this_view % lat_1d % global ) + nullify ( this_view % lon_1d % global ) + nullify ( this_view % satzen_1d % global ) + nullify ( this_view % iy_1d % global ) + nullify ( this_view % ix_1d % global ) + nullify ( this_view % loc_1d % global ) +write(stdout,fmt=*) 'TEST19', this_view % nrad_on_patch deallocate( buf_real, buf_int, buf_loc ) - deallocate( lat_1d % local ) - deallocate( lon_1d % local ) - deallocate( satzen_1d % local ) - deallocate( loc_1d % local ) - deallocate( iy_1d % local ) - deallocate( ix_1d % local ) - - this_view % nrad_on_patch = this_obslist % i + deallocate ( this_view % lat_1d % local ) + deallocate ( this_view % lon_1d % local ) + deallocate ( this_view % satzen_1d % local ) + deallocate ( this_view % loc_1d % local ) + deallocate ( this_view % iy_1d % local ) + deallocate ( this_view % ix_1d % local ) + deallocate ( patchmask_1d ) if ( this_view % nrad_on_patch.gt.0 ) then @@ -881,21 +908,21 @@ write(stdout,fmt=*) 'TEST16', iproc, this_obslist % i end if end do -write(stdout,fmt=*) 'TEST17', this_view % ys_patch, this_view % ye_patch -write(stdout,fmt=*) 'TEST18', this_view % xs_patch, this_view % xe_patch -write(stdout,fmt=*) 'TEST19', this_view % ys_patch_fd, this_view % ye_patch_fd -write(stdout,fmt=*) 'TEST20', this_view % xs_patch_fd, this_view % xe_patch_fd +write(stdout,fmt=*) 'TEST20', this_view % ys_patch, this_view % ye_patch +write(stdout,fmt=*) 'TEST21', this_view % xs_patch, this_view % xe_patch +write(stdout,fmt=*) 'TEST22', this_view % ys_patch_fd, this_view % ye_patch_fd +write(stdout,fmt=*) 'TEST23', this_view % xs_patch_fd, this_view % xe_patch_fd end if end if -write(stdout,fmt=*) 'TEST21' +write(stdout,fmt=*) 'TEST24' end if PatchMatch: if (this_view % nrad_on_patch .gt. 0) then -write(stdout,fmt=*) 'TEST22' +write(stdout,fmt=*) 'TEST25' if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view % nfiles_used(:)).eq.0 ) then allocate(view_mask(& @@ -910,7 +937,7 @@ write(stdout,fmt=*) size(view_mask) write(stdout,fmt=*) sizeof(view_mask) end if -write(stdout,fmt=*) 'TEST23' +write(stdout,fmt=*) 'TEST26' ! Loop over channels ! This loop over channels could be parallelized, if needed for time savings @@ -1051,20 +1078,25 @@ write(stdout,fmt=*) 'TEST23' p => p_fgat end if - this_obslist => view_att(iview) % head +! this_obslist => view_att(iview) % head do n = 1, this_view % nrad_on_patch - this_obslist => this_obslist % next +! this_obslist => this_obslist % next - iy = this_obslist % iy - ix = this_obslist % ix +! iy = this_obslist % iy +! ix = this_obslist % ix + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) if (.not. allmask_patch(iy,ix)) cycle if (first_chan) then - info % lat = this_obslist % lat ! latitude - info % lon = this_obslist % lon ! longitude +! info % lat = this_obslist % lat ! latitude +! info % lon = this_obslist % lon ! longitude + info % lat = this_view % lat_1d % patch (n) ! latitude + info % lon = this_view % lon_1d % patch (n) ! longitude + num_goesabi_local = num_goesabi_local + 1 end if @@ -1098,7 +1130,9 @@ write(stdout,fmt=*) 'TEST23' allocate ( p % tb_inv (1:nchan) ) p % info = info - p % loc = this_obslist % loc +! p % loc = this_obslist % loc + p % loc = this_view % loc_1d % patch (n) + p % landsea_mask = 1 ! ??? if (use_view_mask) then p % scanpos = & @@ -1109,7 +1143,9 @@ write(stdout,fmt=*) 'TEST23' (iy + this_view % yoff_fd-1 - 1) * (nscan+1) / 5423 ! ??? "scan" position (IS THIS CORRECT?) end if - p % satzen = this_obslist % satzen +! p % satzen = this_obslist % satzen + p % satzen = this_view % satzen_1d % patch (n) + p % solzen = 0.0 p % sensor_index = inst p % ifgat = ifgat @@ -1145,28 +1181,28 @@ write(stdout,fmt=*) 'TEST23' if (allocated(this_view % patchmask)) deallocate(this_view % patchmask) end if - if (ipass.eq.npass) then - if (this_obslist % i .gt. 0) then - ! Destroy this_obslist and head - n = this_obslist % i - this_obslist => view_att(iview) % head % next - do i = 1, n - view_att(iview) % current => this_obslist - this_obslist => this_obslist % next - - ! free current data - deallocate ( view_att(iview) % current ) - end do - deallocate(view_att(iview) % head) - end if - end if +! if (ipass.eq.npass) then +! if (this_obslist % i .gt. 0) then +! ! Destroy this_obslist and head +! n = this_obslist % i +! this_obslist => view_att(iview) % head % next +! do i = 1, n +! view_att(iview) % current => this_obslist +! this_obslist => this_obslist % next +! +! ! free current data +! deallocate ( view_att(iview) % current ) +! end do +! deallocate(view_att(iview) % head) +! end if +! end if tot_files_used = tot_files_used + sum(view_att(iview) % nfiles_used) end do ! end view loop if (tot_files_used .lt. 1) then - write(unit=message(1),fmt='(A,I2,2A)') "No L1B data found for GOES-",satellite_id," using prefix ",INST_PREFIX + write(unit=message(1),fmt='(A,I2,2A)') "Either No L1B data found or non matching fgat windows for GOES-",satellite_id," using prefix ",INST_PREFIX call da_warning(__FILE__,__LINE__, message(1:1)) return end if From ce46bdd2f822598454d44161b48fc61fcbcb5721 Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Mon, 21 May 2018 16:59:16 -0600 Subject: [PATCH 09/86] Added vectorized versions several ABI subroutine calls +"outside" test with new da_outside subroutine to generate domainmask_1d and patchmask_1d +lat, lon calculation +zenith angle calculation Changes to be committed: modified: var/build/depend.txt new file: var/da/da_radiance/da_get_satzen_1d.inc modified: var/da/da_radiance/da_radiance.f90 modified: var/da/da_radiance/da_read_obs_ncgoesabi.inc modified: var/da/da_tools/da_llxy.inc new file: var/da/da_tools/da_outside.inc modified: var/da/da_tools/da_tools.f90 --- var/build/depend.txt | 4 +- var/da/da_radiance/da_get_satzen_1d.inc | 84 ++ var/da/da_radiance/da_radiance.f90 | 3 +- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 900 +++++++++++-------- var/da/da_tools/da_llxy.inc | 36 +- var/da/da_tools/da_outside.inc | 92 ++ var/da/da_tools/da_tools.f90 | 1 + 7 files changed, 705 insertions(+), 415 deletions(-) create mode 100644 var/da/da_radiance/da_get_satzen_1d.inc create mode 100644 var/da/da_tools/da_outside.inc diff --git a/var/build/depend.txt b/var/build/depend.txt index a7ec15d96c..4e0d1dfd60 100644 --- a/var/build/depend.txt +++ b/var/build/depend.txt @@ -143,7 +143,7 @@ da_pseudo.o : da_pseudo.f90 da_calculate_grady_pseudo.inc da_transform_xtoy_pseu da_qscat.o : da_qscat.f90 da_calculate_grady_qscat.inc da_transform_xtoy_qscat_adj.inc da_transform_xtoy_qscat.inc da_print_stats_qscat.inc da_oi_stats_qscat.inc da_ao_stats_qscat.inc da_get_innov_vector_qscat.inc da_check_max_iv_qscat.inc da_residual_qscat.inc da_jo_and_grady_qscat.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_rad_diags.o : da_rad_diags.f90 da_radar.o : da_radar.f90 da_write_oa_radar_ascii.inc da_max_error_qc_radar.inc da_calculate_grady_radar.inc da_radial_velocity_adj.inc da_radial_velocity_lin.inc da_radial_velocity.inc da_radar_rf.inc da_get_innov_vector_radar.inc da_check_max_iv_radar.inc da_transform_xtoy_radar_adj.inc da_transform_xtoy_radar.inc da_print_stats_radar.inc da_oi_stats_radar.inc da_residual_radar.inc da_jo_and_grady_radar.inc da_ao_stats_radar.inc da_tools_serial.o da_reporting.o da_tracing.o da_tools.o da_statistics.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o -da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o module_dm.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_satzen.inc +da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o module_dm.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_satzen.inc da_get_satzen_1d.inc da_radiance1.o : da_radiance1.f90 da_mspps_ts.inc da_mspps_emis.inc da_setup_satcv.inc da_qc_rad.inc da_print_stats_rad.inc da_oi_stats_rad.inc da_ao_stats_rad.inc da_cld_eff_radius.inc da_detsurtyp.inc da_write_oa_rad_ascii.inc da_write_iv_rad_ascii.inc da_qc_mhs.inc da_qc_ssmis.inc da_qc_hirs.inc da_qc_amsub.inc da_qc_amsua.inc da_qc_airs.inc da_cloud_detect_airs.inc da_cloud_sim.inc da_qc_seviri.inc da_qc_iasi.inc da_cloud_detect_iasi.inc da_qc_crtm.inc da_predictor_crtm.inc da_predictor_rttov.inc da_write_biasprep.inc da_biasprep.inc da_read_biascoef.inc da_biascorr.inc da_residual_rad.inc da_jo_and_grady_rad.inc gsi_constants.o da_tracing.o da_tools_serial.o da_tools.o da_statistics.o da_reporting.o da_par_util1.o da_par_util.o module_dm.o da_define_structures.o da_control.o module_radiance.o da_qc_amsr2.inc da_qc_goesimg.inc da_rain.o : da_rain.f90 da_calculate_grady_rain.inc da_get_innov_vector_rain.inc da_get_hr_rain.inc da_check_max_iv_rain.inc da_transform_xtoy_rain_adj.inc da_transform_xtoy_rain.inc da_print_stats_rain.inc da_oi_stats_rain.inc da_residual_rain.inc da_jo_and_grady_rain.inc da_ao_stats_rain.inc da_tracing.o da_tools.o da_statistics.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_recursive_filter.o : da_recursive_filter.f90 da_apply_rf_adj.inc da_apply_rf.inc da_apply_rf_1v_adj.inc da_apply_rf_1v.inc da_transform_through_rf_adj.inc da_transform_through_rf.inc da_recursive_filter_1d_adj.inc da_recursive_filter_1d.inc da_calculate_rf_factors.inc da_transform_through_rf_dual_res.inc da_transform_through_rf_adj_dual_res.inc da_perform_2drf.inc da_rf_cv3.o da_rfz_cv3.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_domain.o @@ -162,7 +162,7 @@ da_statistics.o : da_statistics.f90 da_print_qcstat.inc da_stats_calculate.inc d da_synop.o : da_synop.f90 da_check_buddy_synop.inc da_calculate_grady_synop.inc da_check_max_iv_synop.inc da_get_innov_vector_synop.inc da_transform_xtoy_synop_adj.inc da_transform_xtoy_synop.inc da_print_stats_synop.inc da_oi_stats_synop.inc da_residual_synop.inc da_jo_synop_uvtq.inc da_jo_and_grady_synop.inc da_ao_stats_synop.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_tamdar.o : da_tamdar.f90 da_calculate_grady_tamdar_sfc.inc da_check_max_iv_tamdar_sfc.inc da_get_innov_vector_tamdar_sfc.inc da_transform_xtoy_tamdar_sfc_adj.inc da_transform_xtoy_tamdar_sfc.inc da_print_stats_tamdar_sfc.inc da_oi_stats_tamdar_sfc.inc da_residual_tamdar_sfc.inc da_jo_tamdar_sfc_uvtq.inc da_jo_and_grady_tamdar_sfc.inc da_ao_stats_tamdar_sfc.inc da_calculate_grady_tamdar.inc da_get_innov_vector_tamdar.inc da_check_max_iv_tamdar.inc da_transform_xtoy_tamdar_adj.inc da_transform_xtoy_tamdar.inc da_print_stats_tamdar.inc da_oi_stats_tamdar.inc da_residual_tamdar.inc da_jo_tamdar_uvtq.inc da_jo_and_grady_tamdar.inc da_ao_stats_tamdar.inc da_tracing.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_test.o : da_test.f90 da_test_vxtransform.inc da_check_gradient.inc da_get_y_lhs_value.inc da_check_vtoy_adjoint.inc da_set_tst_trnsf_fld.inc da_check_psfc.inc da_check_sfc_assi.inc da_setup_testfield.inc da_check_xtoy_adjoint_buoy.inc da_check_xtoy_adjoint_profiler.inc da_check_xtoy_adjoint_ssmt2.inc da_check_xtoy_adjoint_ssmt1.inc da_check_xtoy_adjoint_qscat.inc da_check_xtoy_adjoint_pseudo.inc da_dot_cv.inc da_dot.inc da_check.inc da_check_gradient.inc da_transform_xtovp.inc da_check_xtoy_adjoint_rad.inc da_check_xtoy_adjoint_synop.inc da_check_xtoy_adjoint_tamdar_sfc.inc da_check_xtoy_adjoint_tamdar.inc da_check_xtoy_adjoint_mtgirs.inc da_check_xtoy_adjoint_sonde_sfc.inc da_check_xtoy_adjoint_sound.inc da_check_xtoy_adjoint_bogus.inc da_check_xtoy_adjoint_rain.inc da_check_xtoy_adjoint_radar.inc da_check_xtoy_adjoint_ships.inc da_check_xtoy_adjoint_polaramv.inc da_check_xtoy_adjoint_geoamv.inc da_check_xtoy_adjoint_satem.inc da_check_xtoy_adjoint_ssmi_tb.inc da_check_xtoy_adjoint_ssmi_rv.inc da_check_xtoy_adjoint_pilot.inc da_check_xtoy_adjoint_metar.inc da_check_xtoy_adjoint_gpsref.inc da_check_xtoy_adjoint_gpspw.inc da_check_xtoy_adjoint_airep.inc da_check_xtoy_adjoint.inc da_check_xtovptox_errors.inc da_check_vvtovp_adjoint.inc da_check_vp_errors.inc da_check_vptox_adjoint.inc da_check_vtox_adjoint.inc da_check_cvtovv_adjoint.inc da_check_balance.inc da_4dvar.o da_vtox_transforms.o da_wrfvar_io.o da_wrf_interfaces.o da_transfer_model.o da_tracing.o da_tools_serial.o da_statistics.o da_ssmi.o da_spectral.o da_reporting.o da_physics.o da_par_util1.o da_par_util.o da_obs.o da_minimisation.o da_ffts.o da_dynamics.o da_define_structures.o module_state_description.o module_domain.o da_control.o module_comm_dm.o module_dm.o module_configure.o da_rain.o da_check_dynamics_adjoint.inc da_check_xtoy_adjoint_gpseph.inc -da_tools.o : da_tools.f90 da_geo2msl1.inc da_msl2geo1.inc da_get_time_slots.inc da_get_julian_time.inc da_get_print_lvl.inc da_get_3d_sum.inc da_get_2d_sum.inc da_set_boundary_3d.inc da_set_boundary_xb.inc da_set_boundary_xa.inc da_ludcmp.inc da_lubksb.inc da_eof_decomposition.inc da_eof_decomposition_test.inc da_buddy_qc.inc da_unifva.inc da_togrid.inc da_togrid_new.inc da_smooth_anl.inc da_openfile.inc da_gaus_noise.inc da_set_randomcv.inc da_random_omb.inc da_max_error_qc.inc da_add_noise_new.inc da_add_noise.inc da_residual_new.inc da_residual.inc da_diff_seconds.inc da_mo_correction.inc da_intpsfc_tem.inc da_intpsfc_prs.inc da_sfcprs.inc da_obs_sfc_correction.inc da_1d_eigendecomposition.inc da_convert_zk.inc da_lc_cone.inc da_set_merc.inc da_map_set.inc da_map_init.inc da_set_ps.inc da_set_lc.inc da_xyll_ps.inc da_xyll_merc.inc da_xyll_lc.inc da_xyll_latlon.inc da_xyll_default.inc da_xyll.inc da_llxy_wrf_new.inc da_llxy_wrf.inc da_llxy_ps_new.inc da_llxy_ps.inc da_llxy_merc_new.inc da_llxy_merc.inc da_llxy_lc_new.inc da_llxy_lc.inc da_llxy_latlon_new.inc da_llxy_latlon.inc da_llxy_rotated_latlon.inc da_llxy_global_new.inc da_llxy_global.inc da_llxy_kma_global_new.inc da_llxy_kma_global.inc da_llxy_default_new.inc da_llxy_default.inc da_llxy_new.inc da_llxy.inc da_map_utils_defines.inc da_lapack.o da_reporting.o da_tracing.o da_tools_serial.o da_define_structures.o da_control.o module_domain.o module_dm.o module_bc.o da_sfc_hori_interp_weights.inc +da_tools.o : da_tools.f90 da_geo2msl1.inc da_msl2geo1.inc da_get_time_slots.inc da_get_julian_time.inc da_get_print_lvl.inc da_get_3d_sum.inc da_get_2d_sum.inc da_set_boundary_3d.inc da_set_boundary_xb.inc da_set_boundary_xa.inc da_ludcmp.inc da_lubksb.inc da_eof_decomposition.inc da_eof_decomposition_test.inc da_buddy_qc.inc da_unifva.inc da_togrid.inc da_togrid_new.inc da_smooth_anl.inc da_openfile.inc da_gaus_noise.inc da_set_randomcv.inc da_random_omb.inc da_max_error_qc.inc da_add_noise_new.inc da_add_noise.inc da_residual_new.inc da_residual.inc da_diff_seconds.inc da_mo_correction.inc da_intpsfc_tem.inc da_intpsfc_prs.inc da_sfcprs.inc da_obs_sfc_correction.inc da_1d_eigendecomposition.inc da_convert_zk.inc da_lc_cone.inc da_set_merc.inc da_map_set.inc da_map_init.inc da_set_ps.inc da_set_lc.inc da_xyll_ps.inc da_xyll_merc.inc da_xyll_lc.inc da_xyll_latlon.inc da_xyll_default.inc da_xyll.inc da_llxy_wrf_new.inc da_outside.inc da_llxy_wrf.inc da_llxy_ps_new.inc da_llxy_ps.inc da_llxy_merc_new.inc da_llxy_merc.inc da_llxy_lc_new.inc da_llxy_lc.inc da_llxy_latlon_new.inc da_llxy_latlon.inc da_llxy_rotated_latlon.inc da_llxy_global_new.inc da_llxy_global.inc da_llxy_kma_global_new.inc da_llxy_kma_global.inc da_llxy_default_new.inc da_llxy_default.inc da_llxy_new.inc da_llxy.inc da_map_utils_defines.inc da_lapack.o da_reporting.o da_tracing.o da_tools_serial.o da_define_structures.o da_control.o module_domain.o module_dm.o module_bc.o da_sfc_hori_interp_weights.inc da_tools_serial.o : da_tools_serial.f90 da_find_fft_trig_funcs.inc da_find_fft_factors.inc da_advance_time.inc da_advance_cymdh.inc da_array_print.inc da_change_date.inc da_free_unit.inc da_get_unit.inc da_reporting.o da_control.o da_tracing.o : da_tracing.f90 da_trace_report.inc da_trace_real_sort.inc da_trace_int_sort.inc da_trace_exit.inc da_trace.inc da_trace_entry.inc da_trace_init.inc da_reporting.o da_par_util1.o da_control.o da_transfer_model.o : da_transfer_model.f90 da_get_2nd_firstguess.inc da_setup_firstguess_kma.inc da_setup_firstguess_wrf_nmm_regional.inc da_setup_firstguess_wrf.inc da_setup_firstguess.inc da_transfer_xatoanalysis.inc da_transfer_wrftl_lbc_t0_adj.inc da_transfer_xatowrftl_adj_lbc.inc da_transfer_xatowrftl_adj.inc da_transfer_wrftl_lbc_t0.inc da_transfer_xatowrftl_lbc.inc da_transfer_xatowrftl.inc da_transfer_wrftltoxa_adj.inc da_transfer_wrftltoxa.inc da_transfer_xatokma.inc da_transfer_xatowrf_nmm_regional.inc da_transfer_xatowrf.inc da_transfer_kmatoxb.inc da_transfer_wrf_nmm_regional_toxb.inc da_transfer_wrftoxb.inc module_io_wrf.o module_bc.o da_4dvar.o da_vtox_transforms.o da_tracing.o da_tools.o da_ssmi.o da_setup_structures.o da_reporting.o da_physics.o da_par_util.o da_grid_definitions.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_state_description.o module_io_domain.o module_domain.o module_date_time.o module_configure.o da_radar.o diff --git a/var/da/da_radiance/da_get_satzen_1d.inc b/var/da/da_radiance/da_get_satzen_1d.inc new file mode 100644 index 0000000000..df1f6249b7 --- /dev/null +++ b/var/da/da_radiance/da_get_satzen_1d.inc @@ -0,0 +1,84 @@ +subroutine da_get_satzen_1d ( lat,lon,sate_index,theta_true ) +!------------------------------------------------- +! Purpose: calculate geostationary satellite_zenith_angle +! +! Menthod: Yang et al., 2017: Impact of assimilating GOES imager +! clear-sky radiance with a rapid refresh assimilation +! system for convection-permitting forecast over Mexico. +! J. Geophys. Res. Atmos., 122, 5472–5490 +!------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:),lon(:) + integer, intent(in) :: sate_index + real, intent(out) :: theta_true(:) + + integer :: n + real :: alon_sat + real, allocatable :: alat(:), alon(:) + real, allocatable :: theta(:), r_tmp(:), theta_tmp(:), gam(:) + + n = size(lat) + allocate( alat(n) ) + allocate( alon(n) ) + allocate( theta(n) ) + allocate( r_tmp(n) ) + allocate( theta_tmp(n) ) + allocate( gam(n) ) + + alat = lat + alon = lon + + if (sate_index .eq. 11) then + alon_sat = -135.*pi/180. + else if (sate_index .eq. 12) then + alon_sat = -60.*pi/180. + else if (sate_index .eq. 13) then + alon_sat = -75.*pi/180. + else if (sate_index .eq. 14) then + alon_sat = -105.*pi/180. + else if (sate_index .eq. 15) then + alon_sat = -135.*pi/180. + else if (sate_index .eq. 16) then +! alon_sat = -75.2*pi/180. !True Value? + alon_sat = -75.*pi/180. !Nominal Value +! else if (sate_index .eq. 17) then +! alon_sat = -137.*pi/180. + else + write(*,*)'this satellite is not included' + stop + end if + + alat = alat*pi/180. + alon = alon*pi/180. + theta = abs(alon-alon_sat) +! r_tmp = (2*earth_radius*sin(theta/2.)-earth_radius*(1-cos(alat))*sin(theta/2.))**2 & +! +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(theta/2.))**2 +! r_tmp = sqrt(r_tmp) +! theta_true = 2*asin(r_tmp/earth_radius/2.) +! theta_tmp = atan(earth_radius*sin(theta_true)/(satellite_height+earth_radius*(1-sin(theta_true)))) +! theta_true = (theta_true+theta_tmp)*180./pi + + + theta_true = missing_r + + where ( lat.ne.missing_r ) + !ZENITH, FROM SOLER et al., 1994 (spherical) (up to 1 deg difference with above code) + gam = acos( cos( alat ) * cos( theta ) ) + r_tmp = (satellite_height+earth_radius)**2 * ( 1.d0 + ( earth_radius / (satellite_height+earth_radius) )**2 - 2.d0 * (earth_radius) / (satellite_height+earth_radius) * cos( gam ) ) + end where + + where ( r_tmp.ge.0 .and. lat.ne.missing_r ) + + r_tmp = sqrt(r_tmp) + + theta_true = asin((satellite_height+earth_radius) / r_tmp * sin(gam)) * 180.d0 / pi + + end where + + deallocate( alat, alon, theta, r_tmp, theta_tmp, gam ) + + return + +end subroutine da_get_satzen_1d diff --git a/var/da/da_radiance/da_radiance.f90 b/var/da/da_radiance/da_radiance.f90 index 626f30e53a..c689e0bbce 100644 --- a/var/da/da_radiance/da_radiance.f90 +++ b/var/da/da_radiance/da_radiance.f90 @@ -91,7 +91,7 @@ module da_radiance #endif use da_statistics, only : da_stats_calculate use da_tools, only : da_residual, da_obs_sfc_correction, & - da_llxy, da_llxy_new, da_togrid_new, da_get_julian_time, da_get_time_slots, & + da_llxy, da_llxy_new, da_outside, da_togrid_new, da_get_julian_time, da_get_time_slots, & da_xyll, map_info use da_tracing, only : da_trace_entry, da_trace_exit, da_trace, & da_trace_int_sort @@ -129,6 +129,7 @@ module da_radiance #include "da_read_obs_ncgoesimg.inc" #include "da_read_obs_ncgoesabi.inc" #include "da_get_satzen.inc" +#include "da_get_satzen_1d.inc" #include "da_allocate_rad_iv.inc" #include "da_initialize_rad_iv.inc" #include "da_read_kma1dvar.inc" diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index b090d4659e..bb734e8c0e 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -39,12 +39,15 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: ny_global, nx_global integer :: yoff_fd, xoff_fd ! For MPI parallelization - integer :: nbuf, nrad_local, buf_i, buf_f + integer :: nbuf, nrad_local, nrad_mask, buf_i, buf_f integer :: ny_local, nx_local integer :: ys_local, xs_local !! Earth location info - real, allocatable :: yy(:), xx(:) + real, allocatable :: yy_abi(:), xx_abi(:) + real, allocatable :: yy_1d(:), xx_1d(:) + real, allocatable :: iy_1d(:), ix_1d(:) + real(r_kind) :: req, rpol, pph, nam !!! real :: lat_sat, lon_sat ! Assume fixed values in da_get_satzen real, allocatable, target :: buf_real(:,:) @@ -53,11 +56,15 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Masks for data reduction - logical :: earthmask, zenmask, domainmask !, include_local, load_balance +!!! logical :: include_local, load_balance + logical :: earthmask, zenmask logical, allocatable :: & + earthmask_1d(:) , & + zenmask_1d(:) , & patchmask_1d(:) , & - allmask_patch(:,:) , & - allmask_local(:,:) , & + domainmask_1d(:) , & + dummybool_2d(:,:) , & + allmask_p(:,:) , & thinmask(:,:) logical, allocatable :: view_mask(:,:,:,:,:) @@ -66,12 +73,12 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Brightness Temperature (K) - real, allocatable :: bt_patch(:,:) + real, allocatable :: bt_p(:,:) !! Iterates integer :: ichan, ifile, iview, ifgat, ipass, ioff, & jchan, jfile, jview, icount, & - n, i, j, iy, ix, iyl, ixl, iproc, subgrid + n, i, j, iy, ix, iyl, ixl, iyfd, ixfd, iproc, subgrid !! Satellite variables integer(i_kind),parameter :: nchan = 10 @@ -112,7 +119,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer, pointer :: patch(:) end type field_i type field_loc - type(model_loc_type), pointer :: local(:) + type(model_loc_type), pointer :: local(:,:) type(model_loc_type), pointer :: global(:) type(model_loc_type), pointer :: patch(:) end type field_loc @@ -131,10 +138,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: ny_global, nx_global, yoff_fd, xoff_fd integer, allocatable :: ny_grid(:), nx_grid(:) integer, allocatable :: ys_grid(:), xs_grid(:) - integer :: ys_patch, xs_patch - integer :: ye_patch, xe_patch - integer :: ys_patch_fd, xs_patch_fd - integer :: ye_patch_fd, xe_patch_fd + integer :: ys_p, xs_p + integer :: ye_p, xe_p + integer :: ys_p_fd, xs_p_fd + integer :: ye_p_fd, xe_p_fd integer :: nrad_on_patch, nrad_on_domain logical, allocatable :: patchmask(:,:) ! type(viewnode), pointer :: head @@ -151,7 +158,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) type(viewinfo), target, allocatable :: view_att(:) type(viewinfo), pointer :: this_view -! type(viewnode), pointer :: this_obslist integer :: first_file, tot_files_used, npass integer :: ncid, varid @@ -287,15 +293,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) do iview = 1, nviews this_view => view_att(iview) -! !Initialize linked list for obs in this view -! if (ipass .eq. 1) then -! allocate(view_att(iview) % head) -! view_att(iview) % head % i = 0 -! nullify(view_att(iview) % head % next) -! end if -! ! Associate this_obslist -! this_obslist => view_att(iview) % head - if ( .not.this_view % select ) cycle !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -513,7 +510,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) fname_short = trim(this_view % filename(first_file)) fname = trim(this_view % fpath)//trim(fname_short) -write(stdout,fmt=*) 'TEST1' +!write(stdout,fmt=*) 'TEST1' if ( ipass.eq.1 .and. sum(this_view % nfiles_used(:)).eq.0 ) then !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -528,8 +525,8 @@ write(stdout,fmt=*) 'TEST1' fname, this_view % ny_global, this_view % nx_global, & req, rpol, pph, nam)! , lat_sat, lon_sat ) -write(stdout,fmt=*) 'TEST2' -write(stdout,fmt=*) this_view % ny_global, this_view % nx_global, req, rpol, pph, nam +!write(stdout,fmt=*) 'TEST2' +!write(stdout,fmt=*) this_view % ny_global, this_view % nx_global, req, rpol, pph, nam #ifdef DM_PARALLEL ! Split the global ABI grid for this view into local segments @@ -539,13 +536,11 @@ write(stdout,fmt=*) this_view % ny_global, this_view % nx_global, req, rpol, pph allocate ( this_view % xs_grid ( num_procs ) ) call split_grid( this_view % ny_global, this_view % nx_global , & - this_view % ny_grid, this_view % nx_grid , & - this_view % ys_grid, this_view % xs_grid , & - .false. ) -!! (iview.eq.1) ) + this_view % ny_grid, this_view % nx_grid , & + this_view % ys_grid, this_view % xs_grid ) -write(stdout,fmt=*) 'ntasks_y, ntasks_x, num_procs, myproc = ', ntasks_y, ntasks_x, num_procs, myproc -write(stdout,fmt=*) 'TEST3' +!write(stdout,fmt=*) 'ntasks_y, ntasks_x, num_procs, myproc = ', ntasks_y, ntasks_x, num_procs, myproc +!write(stdout,fmt=*) 'TEST3' #else ! When mpi parallelism is not available, assign global values to local variables @@ -555,13 +550,13 @@ write(stdout,fmt=*) 'TEST3' this_view % xs_grid = 1 #endif -write(stdout,fmt=*) 'ny_grid, nx_grid, ys_grid, xs_grid = ' -write(stdout,fmt=*) this_view % ny_grid -write(stdout,fmt=*) this_view % nx_grid -write(stdout,fmt=*) this_view % ys_grid -write(stdout,fmt=*) this_view % xs_grid +!write(stdout,fmt=*) 'ny_grid, nx_grid, ys_grid, xs_grid = ' +!write(stdout,fmt=*) this_view % ny_grid +!write(stdout,fmt=*) this_view % nx_grid +!write(stdout,fmt=*) this_view % ys_grid +!write(stdout,fmt=*) this_view % xs_grid -write(stdout,fmt=*) 'TEST4' +!write(stdout,fmt=*) 'TEST4' end if @@ -593,14 +588,15 @@ write(stdout,fmt=*) 'TEST6' ' Reading abi grid info for ',trim(this_view % name) - !================================================== + !======================================================== ! Establish GOES metadata for this view and ifgat - !================================================== - allocate( yy(ny_global) ) - allocate( xx(nx_global) ) + ! (constant acros fgat's, except for this_view % moving) + !======================================================== + allocate( yy_abi (ny_global) ) + allocate( xx_abi (nx_global) ) call get_abil1b_grid1( fname, & ny_global, nx_global, & - yy, xx, & + yy_abi, xx_abi, & this_view % yoff_fd, this_view % xoff_fd ) if ( iview.eq.1 ) then @@ -609,10 +605,14 @@ write(stdout,fmt=*) 'TEST6' this_view % yoff_fd = 1 this_view % xoff_fd = 1 else - this_view % yoff_fd = this_view % yoff_fd - yoff_fd - this_view % xoff_fd = this_view % xoff_fd - xoff_fd -! this_view % yoff_fd = this_view % yoff_fd - yoff_fd + 1 -! this_view % xoff_fd = this_view % xoff_fd - xoff_fd + 1 +! this_view % yoff_fd = this_view % yoff_fd - yoff_fd +! this_view % xoff_fd = this_view % xoff_fd - xoff_fd + this_view % yoff_fd = this_view % yoff_fd - yoff_fd + 1 + this_view % xoff_fd = this_view % xoff_fd - xoff_fd + 1 +! if (iview .gt. 2) then +! this_view % yoff_fd = this_view % yoff_fd + 1 +! this_view % xoff_fd = this_view % xoff_fd + 1 +! end if end if write(stdout,fmt=*) 'TEST7' @@ -621,24 +621,23 @@ write(stdout,fmt=*) 'TEST7' ! Create a local array subset of observation location ! quantities across processors. !=========================================================== -! load_balance = iview.eq.1 -! if (load_balance) then +!!! load_balance = any(iview.eq.(/1,2/)) +!!! if (load_balance) then nrad_local = ny_global * nx_global / num_procs + 1 -! else -! nrad_local = this_view % ny_grid(iproc+1) * this_view % nx_grid(iproc+1) -! end if - allocate( this_view % lat_1d % local (nrad_local) ) - allocate( this_view % lon_1d % local (nrad_local) ) - allocate( this_view % satzen_1d % local (nrad_local) ) - allocate( this_view % loc_1d % local (nrad_local) ) - allocate( this_view % iy_1d % local (nrad_local) ) - allocate( this_view % ix_1d % local (nrad_local) ) +!!! else +!!! nrad_local = this_view % ny_grid(iproc+1) * this_view % nx_grid(iproc+1) +!!! end if + + allocate( yy_1d (nrad_local) ) + allocate( xx_1d (nrad_local) ) + allocate( iy_1d (nrad_local) ) + allocate( ix_1d (nrad_local) ) n = 0 ; icount = 1 ! This loop over subgrids and the selective logic ! below for myproc balances the processor loads - ! when some imager subpoints are off-earth - ! (Full Disk) + ! when some imager pixels are off-earth or outside + ! zenith-angle limits (Full Disk and CONUS) do subgrid = 1, num_procs ! Recall local dims for this_view ny_local = this_view % ny_grid(subgrid) @@ -646,35 +645,25 @@ write(stdout,fmt=*) 'TEST7' ys_local = this_view % ys_grid(subgrid) xs_local = this_view % xs_grid(subgrid) -write(stdout,fmt=*) 'TEST8', subgrid, n, icount -! include_local = ( subgrid-1 .eq. myproc ) +!!! !This version of include_local produces unbalanced loads between processors +!!! include_local = ( subgrid-1 .eq. myproc ) do ixl = 1, nx_local do iyl = 1, ny_local -! if (load_balance) & -! include_local = ( mod( n, num_procs ) .eq. myproc ) -! if ( include_local ) then +!!! !This version of include_local produces balanced loads between processors +!!! if (load_balance) & +!!! include_local = ( mod( n, num_procs ) .eq. myproc ) +!!! if ( include_local ) then if ( mod( n, num_procs ) .eq. myproc ) then iy = iyl + ys_local - 1 ix = ixl + xs_local - 1 + yy_1d(icount) = yy_abi( iy ) + xx_1d(icount) = xx_abi( ix ) + iy_1d(icount) = iy + ix_1d(icount) = ix -!Might save some time by allocating mask arrays, and presetting all values to false instead of assigning one-by-one in grid2; would not be memory intensive - - call get_abil1b_grid2( yy(iy), xx(ix), req, rpol, pph, nam, satellite_id, & - this_view % lat_1d % local(icount), & - this_view % lon_1d % local(icount), & - this_view % satzen_1d % local(icount), & - earthmask, zenmask, & - this_view % loc_1d % local(icount), domainmask ) - - ! Advance counter for locations that pass all mask tests - if (earthmask .and. zenmask .and. domainmask) then - this_view % iy_1d % local(icount) = iy - this_view % ix_1d % local(icount) = ix - - icount = icount + 1 - end if + icount = icount + 1 end if n = n + 1 @@ -682,106 +671,162 @@ write(stdout,fmt=*) 'TEST8', subgrid, n, icount end do end do - deallocate( yy, xx ) - nrad_local = icount - 1 - !======================================================= - ! Transfer applicable locations (local and remote) - ! to linked list within this WRF patch (this_obslist) - !======================================================= -! ! Destroy this_obslist if it was previously populated -! if (this_obslist % i .gt. 0) then -! n = this_obslist % i -! this_obslist => view_att(iview) % head % next -! do i = 1, n -! view_att(iview) % current => this_obslist -! this_obslist => this_obslist % next + deallocate( yy_abi, xx_abi ) + +write(stdout,fmt=*) 'TEST8' + + allocate( earthmask_1d (nrad_local) ) + allocate( zenmask_1d (nrad_local) ) + allocate( this_view % lat_1d % local (nrad_local) ) + allocate( this_view % lon_1d % local (nrad_local) ) + allocate( this_view % satzen_1d % local (nrad_local) ) + allocate( this_view % loc_1d % local (nrad_local,1) ) + allocate( this_view % iy_1d % local (nrad_local) ) + allocate( this_view % ix_1d % local (nrad_local) ) + + + ! Assign values for iy, ix, lat, lon, satzen + this_view % iy_1d % local = iy_1d (1:nrad_local) + this_view % ix_1d % local = ix_1d (1:nrad_local) + deallocate( iy_1d ) + deallocate( ix_1d ) + + call get_abil1b_grid2_1d( yy_1d(1:nrad_local), xx_1d(1:nrad_local), & + req, rpol, pph, nam, satellite_id, & + this_view % lat_1d % local, & + this_view % lon_1d % local, & + this_view % satzen_1d % local, & + earthmask_1d, zenmask_1d ) + + ! Reduce values for iy, ix, lat, lon, satzen using earth and zenith masks + nrad_mask = count ( earthmask_1d .and. zenmask_1d ) + this_view % lat_1d % local(1:nrad_mask) = & + pack(this_view % lat_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % lon_1d % local(1:nrad_mask) = & + pack(this_view % lon_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % satzen_1d % local(1:nrad_mask) = & + pack(this_view % satzen_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % iy_1d % local(1:nrad_mask) = & + pack(this_view % iy_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % ix_1d % local(1:nrad_mask) = & + pack(this_view % ix_1d % local , earthmask_1d .and. zenmask_1d ) + + nrad_local = nrad_mask + + deallocate( earthmask_1d ) + deallocate( zenmask_1d ) + +! icount = 1 +! do n = 1, nrad_local +!!Might save some time by allocating mask arrays, and changing grid2 to a vectorized subroutine +! call get_abil1b_grid2( yy_1d(n), xx_1d(n), req, rpol, pph, nam, satellite_id, & +! this_view % lat_1d % local(icount), & +! this_view % lon_1d % local(icount), & +! this_view % satzen_1d % local(icount), & +! earthmask, zenmask ) +! +! ! Advance counter for locations that pass all mask tests +! if (earthmask .and. zenmask) then +! this_view % iy_1d % local(icount) = & +! this_view % iy_1d % local(n) +! this_view % ix_1d % local(icount) = & +! this_view % ix_1d % local(n) +! +! icount = icount + 1 ! -! ! free current data -! deallocate ( view_att(iview) % current ) -! end do -! ! Reassociate this_obslist -! this_obslist => view_att(iview) % head -! end if +!write(stdout,fmt=*) 'TEST9', n, icount +! end if +! end do +! +! nrad_local = icount - 1 - ! Setup global patch mask for this view - allocate(this_view % patchmask(ny_global,nx_global)) - this_view % patchmask = .false. - this_view % nrad_on_domain = 0 + deallocate( yy_1d, xx_1d ) -write(stdout,fmt=*) 'TEST9' +write(stdout,fmt=*) 'TEST10' - call mpi_allreduce(nrad_local, nbuf, 1, mpi_integer, mpi_sum, comm, ierr) + ! Populate loc using model coordinate utility + ! (should be replaced with vectorized version, similar to da_llxy_new) + do n = 1, nrad_local + info % lat = this_view % lat_1d % local(n) ! latitude + info % lon = this_view % lon_1d % local(n) ! longitude + call da_llxy ( info, this_view % loc_1d % local(n,1), & + outside, xy_only = .true. ) + end do + +write(stdout,fmt=*) 'TEST11' + + ! Determine locations within/outside domain and populate loc%x and loc%y + allocate ( domainmask_1d (nrad_local) ) + allocate ( dummybool_2d (nrad_local,2) ) + call da_outside ( this_view % loc_1d % local(1:nrad_local,1:1), & + dummybool_2d(:,1:1), dummybool_2d(:,2:2) ) + domainmask_1d = .not.dummybool_2d(:,2) + deallocate( dummybool_2d ) + nrad_mask = count( domainmask_1d ) + +write(stdout,fmt=*) 'TEST12' !ALLOCATE COMMUNICATION BUFFERS + call mpi_allreduce( nrad_mask, nbuf, 1, mpi_integer, mpi_sum, comm, ierr ) allocate( buf_real( nbuf, 3 ) ) allocate( buf_int ( nbuf, 2 ) ) allocate( buf_loc ( nbuf, 1 ) ) this_view % nrad_on_domain = nbuf -!This loop is much faster when num_procs is small (36) versus large (288) -!In addition to reducing communications, I believe the small num_procs balances the load -! in the nbuf loop by ensuring that each local data set includes locations from -! more than 1-5 processors. I thought that the load balancing above would solve that -! issue, but clearly it does not. Both the above loop and the below loop need to -! have balanced loads to perform well in large num_procs. How to balance the following loop? ! COMMUNICATE 1D FIELDS FROM REMOTE PROCS TO LOCAL BUFFER buf_f = 0 ProcLoop: do iproc = 0, num_procs-1 - nbuf = nrad_local + nbuf = nrad_mask #ifdef DM_PARALLEL call mpi_bcast(nbuf, 1, mpi_integer, iproc, comm, ierr ) #endif if (nbuf .eq. 0) cycle buf_i = buf_f + 1 buf_f = buf_i + nbuf - 1 -write(stdout,fmt=*) 'TEST10', nbuf - -! !BCAST REMOTE FIELDS -! ! AND LOCF (derived type) -! ! TO LOCAL BUFFERS -! allocate( buf_real( nbuf, 3 ) ) -! allocate( buf_int ( nbuf, 2 ) ) -! allocate( buf_loc ( nbuf, 1 ) ) if (iproc .eq. myproc) then - buf_real(buf_i:buf_f,1) = this_view % lat_1d % local (1:nbuf) - buf_real(buf_i:buf_f,2) = this_view % lon_1d % local (1:nbuf) - buf_real(buf_i:buf_f,3) = this_view % satzen_1d % local (1:nbuf) - buf_int (buf_i:buf_f,1) = this_view % iy_1d % local (1:nbuf) - buf_int (buf_i:buf_f,2) = this_view % ix_1d % local (1:nbuf) - buf_loc (buf_i:buf_f,1) = this_view % loc_1d % local (1:nbuf) + buf_real( buf_i:buf_f, 1 ) = & + pack(this_view % lat_1d % local (1:nrad_local), domainmask_1d ) + buf_real( buf_i:buf_f, 2 ) = & + pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) + buf_real( buf_i:buf_f, 3 ) = & + pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) + buf_int ( buf_i:buf_f, 1 ) = & + pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) + buf_int ( buf_i:buf_f, 2 ) = & + pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) + buf_loc ( buf_i:buf_f, 1 ) = & + pack(this_view % loc_1d % local (1:nrad_local,1), domainmask_1d ) else buf_real(buf_i:buf_f,:) = missing_r buf_int(buf_i:buf_f,:) = missing - buf_loc(buf_i:buf_f,1)%j = missing - buf_loc(buf_i:buf_f,1)%i = missing - buf_loc(buf_i:buf_f,1)%y = missing_r - buf_loc(buf_i:buf_f,1)%x = missing_r + buf_loc(buf_i:buf_f,:)%y = missing_r + buf_loc(buf_i:buf_f,:)%x = missing_r end if #ifdef DM_PARALLEL - -write(stdout,fmt=*) 'TEST11' - call mpi_bcast(buf_real(buf_i:buf_f,:), nbuf * 3, true_mpi_real, iproc, comm, ierr ) call mpi_bcast(buf_int (buf_i:buf_f,:), nbuf * 2, mpi_integer, iproc, comm, ierr ) -write(stdout,fmt=*) 'TEST12' - -write(stdout,fmt=*) 'TEST13' - !Only certain domain-wide components of loc previously defined in da_llxy - ! need to be communicated + !Only x & y components of loc need to be communicated call mpi_bcast( buf_loc(buf_i:buf_f,1)%y, nbuf, true_mpi_real, iproc, comm, ierr ) call mpi_bcast( buf_loc(buf_i:buf_f,1)%x, nbuf, true_mpi_real, iproc, comm, ierr ) #endif -write(stdout,fmt=*) 'TEST14', iproc end do ProcLoop - ! ASSOCIATE REMOTE POINTERS WITH BUFFERS OF DOMAIN-WIDE OBS + deallocate ( this_view % lat_1d % local ) + deallocate ( this_view % lon_1d % local ) + deallocate ( this_view % satzen_1d % local ) + deallocate ( this_view % iy_1d % local ) + deallocate ( this_view % ix_1d % local ) + deallocate ( this_view % loc_1d % local ) + deallocate(domainmask_1d) + + ! ASSOCIATE REMOTE POINTERS WITH BUFFERS CONTAINING DOMAIN-WIDE OBS this_view % lat_1d % global => buf_real(:,1) this_view % lon_1d % global => buf_real(:,2) this_view % satzen_1d % global => buf_real(:,3) @@ -789,50 +834,17 @@ write(stdout,fmt=*) 'TEST14', iproc this_view % ix_1d % global => buf_int (:,2) this_view % loc_1d % global => buf_loc (:,1) - allocate ( patchmask_1d (this_view % nrad_on_domain) ) - patchmask_1d = .false. - icount = 0 - -write(stdout,fmt=*) 'TEST15', this_view % nrad_on_domain +write(stdout,fmt=*) 'TEST13', this_view % nrad_on_domain - ! PROCESS LOCAL BUFFERS OF DOMAIN-WIDE OBS - do n = 1, this_view % nrad_on_domain - loc % y = this_view % loc_1d % global(n) % y - loc % x = this_view % loc_1d % global(n) % x -#ifdef DM_PARALLEL - call da_llxy (info, loc, outside, outside_only = .true.) - if (outside) cycle -#endif - iy = this_view % iy_1d % global(n) - ix = this_view % ix_1d % global(n) - this_view % loc_1d % global(n) = loc !Includes updates from da_llxy - this_view % patchmask(iy,ix) = .true. - patchmask_1d(n) = .true. - icount = icount + 1 - -write(stdout,fmt=*) 'TEST16', iy, ix, n, icount - -! allocate(this_obslist % next) -! i = this_obslist % i -! this_obslist => this_obslist % next -! this_obslist % i = i + 1 -! this_obslist % lat = this_view % lat_1d % global(n) -! this_obslist % lon = this_view % lon_1d % global(n) -! this_obslist % satzen = this_view % satzen_1d % global(n) -! this_obslist % iy = iy -! this_obslist % ix = ix -! this_obslist % loc = loc -! -! nullify (this_obslist % next) -! -!write(stdout,fmt=*) 'TEST17', iy, ix, n, this_obslist % i - - end do - -! this_view % nrad_on_patch = this_obslist % i - this_view % nrad_on_patch = icount + ! Determine locations within/outside patch and populate remainder of buf_loc + allocate ( patchmask_1d (this_view % nrad_on_domain) ) + allocate ( dummybool_2d (this_view % nrad_on_domain,1) ) + call da_outside ( buf_loc, dummybool_2d(:,1:1) ) + patchmask_1d = .not.dummybool_2d(:,1) + deallocate(dummybool_2d) + this_view % nrad_on_patch = count(patchmask_1d) -write(stdout,fmt=*) 'TEST18', this_view % nrad_on_patch +write(stdout,fmt=*) 'TEST15', this_view % nrad_on_patch if ( this_view % nrad_on_patch .gt. 0 ) then allocate( this_view % lat_1d % patch (this_view % nrad_on_patch) ) @@ -842,12 +854,18 @@ write(stdout,fmt=*) 'TEST18', this_view % nrad_on_patch allocate( this_view % ix_1d % patch (this_view % nrad_on_patch) ) allocate( this_view % loc_1d % patch (this_view % nrad_on_patch) ) - this_view % lat_1d % patch = pack( this_view % lat_1d % global, patchmask_1d) - this_view % lon_1d % patch = pack( this_view % lon_1d % global, patchmask_1d) - this_view % satzen_1d % patch = pack( this_view % satzen_1d % global, patchmask_1d) - this_view % iy_1d % patch = pack( this_view % iy_1d % global, patchmask_1d) - this_view % ix_1d % patch = pack( this_view % ix_1d % global, patchmask_1d) - this_view % loc_1d % patch = pack( this_view % loc_1d % global, patchmask_1d) + this_view % lat_1d % patch = & + pack( this_view % lat_1d % global, patchmask_1d ) + this_view % lon_1d % patch = & + pack( this_view % lon_1d % global, patchmask_1d ) + this_view % satzen_1d % patch = & + pack( this_view % satzen_1d % global, patchmask_1d ) + this_view % iy_1d % patch = & + pack( this_view % iy_1d % global, patchmask_1d ) + this_view % ix_1d % patch = & + pack( this_view % ix_1d % global, patchmask_1d ) + this_view % loc_1d % patch = & + pack( this_view % loc_1d % global, patchmask_1d ) end if !FREE UP POINTERS AND BUFFERS @@ -857,78 +875,71 @@ write(stdout,fmt=*) 'TEST18', this_view % nrad_on_patch nullify ( this_view % iy_1d % global ) nullify ( this_view % ix_1d % global ) nullify ( this_view % loc_1d % global ) + deallocate ( buf_real, buf_int, buf_loc ) + deallocate ( patchmask_1d ) -write(stdout,fmt=*) 'TEST19', this_view % nrad_on_patch +write(stdout,fmt=*) 'TEST16', this_view % nrad_on_patch - deallocate( buf_real, buf_int, buf_loc ) - deallocate ( this_view % lat_1d % local ) - deallocate ( this_view % lon_1d % local ) - deallocate ( this_view % satzen_1d % local ) - deallocate ( this_view % loc_1d % local ) - deallocate ( this_view % iy_1d % local ) - deallocate ( this_view % ix_1d % local ) - deallocate ( patchmask_1d ) +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif + ! Determine patch extents, initialize patchmask if ( this_view % nrad_on_patch.gt.0 ) then - ! Determine ys & ye for this patch - this_view % ys_patch = ny_global - this_view % ye_patch = 1 - do iy = 1, ny_global - if ( any(this_view % patchmask(iy,:)) ) then - this_view % ys_patch = iy - this_view % ys_patch_fd = iy+this_view % yoff_fd ! offset to FD grid - exit - end if - end do - do iy = ny_global, 1, -1 - if ( any(this_view % patchmask(iy,:)) ) then - this_view % ye_patch = iy - this_view % ye_patch_fd = iy+this_view % yoff_fd ! offset to FD grid - exit - end if - end do + ! Determine ys, ye, xs, xe for this patch and for Full Disk offset grid + this_view % ys_p = minval(this_view % iy_1d % patch) + this_view % ye_p = maxval(this_view % iy_1d % patch) + this_view % xs_p = minval(this_view % ix_1d % patch) + this_view % xe_p = maxval(this_view % ix_1d % patch) + this_view % ys_p_fd = this_view % ys_p + this_view % yoff_fd - 1 + this_view % ye_p_fd = this_view % ye_p + this_view % yoff_fd - 1 + this_view % xs_p_fd = this_view % xs_p + this_view % xoff_fd - 1 + this_view % xe_p_fd = this_view % xe_p + this_view % xoff_fd - 1 + +write(stdout,fmt=*) 'TEST17', this_view % ys_p, this_view % ye_p +write(stdout,fmt=*) 'TEST18', this_view % ys_p_fd, this_view % ye_p_fd +write(stdout,fmt=*) 'TEST19', view_att(1) % ys_p, view_att(1) % ye_p + +write(stdout,fmt=*) 'TEST21', this_view % xs_p, this_view % xe_p +write(stdout,fmt=*) 'TEST22', this_view % xs_p_fd, this_view % xe_p_fd +write(stdout,fmt=*) 'TEST23', view_att(1) % xs_p, view_att(1) % xe_p + +write(stdout,fmt=*) 'TEST25', this_view % yoff_fd, this_view % xoff_fd +write(stdout,fmt=*) 'TEST26', view_att(1) % yoff_fd, view_att(1) % xoff_fd + +write(stdout,fmt=*) 'TEST27', this_view % ny_global, this_view % nx_global +write(stdout,fmt=*) 'TEST28', view_att(1) % ny_global, view_att(1) % nx_global - ! Determine xs & xe for this patch - this_view % xs_patch = nx_global - this_view % xe_patch = 1 - do ix = 1, nx_global - if ( any(this_view % patchmask(:,ix)) ) then - this_view % xs_patch = ix - this_view % xs_patch_fd = ix+this_view % xoff_fd ! offset to FD grid - exit - end if - end do - do ix = nx_global, 1, -1 - if ( any(this_view % patchmask(:,ix)) ) then - this_view % xe_patch = ix - this_view % xe_patch_fd = ix+this_view % xoff_fd ! offset to FD grid - exit - end if - end do -write(stdout,fmt=*) 'TEST20', this_view % ys_patch, this_view % ye_patch -write(stdout,fmt=*) 'TEST21', this_view % xs_patch, this_view % xe_patch -write(stdout,fmt=*) 'TEST22', this_view % ys_patch_fd, this_view % ye_patch_fd -write(stdout,fmt=*) 'TEST23', this_view % xs_patch_fd, this_view % xe_patch_fd + ! Setup patch mask for this view + allocate(this_view % patchmask( & + this_view % ys_p-1:this_view % ye_p+1, & + this_view % xs_p-1:this_view % xe_p+1 )) + this_view % patchmask = .false. + do n = 1, this_view % nrad_on_patch + this_view % patchmask ( this_view % iy_1d % patch (n) & + , this_view % ix_1d % patch (n) & + ) = .true. + end do end if end if -write(stdout,fmt=*) 'TEST24' +write(stdout,fmt=*) 'TEST29' end if PatchMatch: if (this_view % nrad_on_patch .gt. 0) then -write(stdout,fmt=*) 'TEST25' +write(stdout,fmt=*) 'TEST30' if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view % nfiles_used(:)).eq.0 ) then allocate(view_mask(& - this_view % ys_patch_fd:this_view % ye_patch_fd, & - this_view % xs_patch_fd:this_view % xe_patch_fd, & - nchan, num_fgat_time, nviews)) + this_view % ys_p_fd-1:this_view % ye_p_fd+1, & + this_view % xs_p_fd-1:this_view % xe_p_fd+1, & + nviews, nchan, num_fgat_time)) view_mask = .false. use_view_mask = .true. @@ -937,13 +948,15 @@ write(stdout,fmt=*) size(view_mask) write(stdout,fmt=*) sizeof(view_mask) end if -write(stdout,fmt=*) 'TEST26' +write(stdout,fmt=*) 'TEST31' ! Loop over channels ! This loop over channels could be parallelized, if needed for time savings ChannelLoop: do ichan = 1, nchan +write(stdout,fmt=*) 'TEST32', ichan, ifgat + ifile = 0 do jfile = 1, this_view % nfiles if ( .not. this_view % file_fgat_match(jfile,ifgat) ) cycle @@ -970,8 +983,14 @@ write(stdout,fmt=*) 'TEST26' !! (only available when FD data present for one of the fgat times) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if ( iview.eq.1 ) then - view_mask(:,:, ichan, ifgat, iview) = .true. + do n = 1, this_view % nrad_on_patch + iyfd = this_view % iy_1d % patch (n) + this_view % yoff_fd-1 + ixfd = this_view % ix_1d % patch (n) + this_view % xoff_fd-1 + view_mask( iyfd, ixfd, iview, ichan, ifgat) = .true. + end do else + +!OLD CODE best_view = .true. ! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap @@ -981,18 +1000,30 @@ write(stdout,fmt=*) 'TEST26' end do if ( best_view ) then + do n = 1, this_view % nrad_on_patch + iyfd = this_view % iy_1d % patch (n) + this_view % yoff_fd-1 + ixfd = this_view % ix_1d % patch (n) + this_view % xoff_fd-1 + view_mask( iyfd, ixfd, iview, ichan, ifgat) = .true. - view_mask(this_view % ys_patch_fd:this_view % ye_patch_fd, & - this_view % ys_patch_fd:this_view % ye_patch_fd, & - ichan, ifgat, iview) = .true. - -! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations - do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap + !This assumes MESO1 and MESO2 do not overlap + view_mask( iyfd, ixfd, 1:min(iview-1,2), ichan, ifgat) = .false. - view_mask(this_view % ys_patch_fd:this_view % ye_patch_fd, & - this_view % ys_patch_fd:this_view % ye_patch_fd, & - ichan, ifgat, jview) = .false. +! !This assumes MESO1 and MESO2 are in identical locations +! view_mask( iyfd, ixfd, 1:iview-1, ichan, ifgat) = .false. end do + +!OLD CODE +! view_mask(this_view % ys_p_fd-1:this_view % ye_p_fd+1, & +! this_view % ys_p_fd-1:this_view % ye_p_fd+1, & +! iview, ichan, ifgat) = .true. +! +!! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations +!! do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap +! +! view_mask(this_view % ys_p_fd-1:this_view % ye_p_fd+1, & +! this_view % ys_p_fd-1:this_view % ye_p_fd+1, & +! iview, ichan, ifgat) = .false. +! end do end if end if @@ -1010,27 +1041,30 @@ write(stdout,fmt=*) 'TEST26' !! + patch mask !! + thinning - allocate(allmask_patch(ny_global,nx_global)) - allmask_patch = this_view % patchmask + allocate(allmask_p( & + this_view % ys_p-1:this_view % ye_p+1, & + this_view % xs_p-1:this_view % xe_p+1 )) + + allmask_p = this_view % patchmask ! Only use locations where this view is nearest to this fgat time ! - only available when FD data present for any fgat time if ( use_view_mask ) then - if ( count(view_mask(this_view % ys_patch_fd:this_view % ye_patch_fd, & - this_view % ys_patch_fd:this_view % ye_patch_fd, & - ichan, ifgat, iview)) .eq. 0 ) then - deallocate(allmask_patch) + if ( count( view_mask ( this_view % ys_p_fd-1:this_view % ye_p_fd+1, & + this_view % xs_p_fd-1:this_view % xe_p_fd+1, & + iview, ichan, ifgat ) ) .eq. 0 ) then + deallocate(allmask_p) cycle end if - - allmask_patch(this_view % ys_patch:this_view % ye_patch , & - this_view % ys_patch:this_view % ye_patch ) = ( & - allmask_patch(this_view % ys_patch:this_view % ye_patch , & - this_view % ys_patch:this_view % ye_patch ) & - .and. & - view_mask(this_view % ys_patch_fd:this_view % ye_patch_fd, & - this_view % ys_patch_fd:this_view % ye_patch_fd, & - ichan, ifgat, iview) ) + do n = 1, this_view % nrad_on_patch + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + iyfd = iy + this_view % yoff_fd-1 + ixfd = ix + this_view % xoff_fd-1 + + allmask_p( iy, ix ) = & + ( allmask_p( iy, ix ) .and. view_mask( iyfd, ixfd, iview, ichan, ifgat) ) + end do end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1044,16 +1078,15 @@ write(stdout,fmt=*) 'TEST26' ' Reading abi radiances: ',trim(fname_short) ! Allocate this patch bt - allocate(bt_patch(this_view % ys_patch:this_view % ye_patch, & - this_view % xs_patch:this_view % xe_patch)) + allocate( bt_p ( this_view % ys_p:this_view % ye_p, & + this_view % xs_p:this_view % xe_p ) ) ! This reads in bt only for the local patch, ! reduces read time, but would mess up global count below call get_abil1b_bt( fname, & - ny_global, nx_global, & - this_view % ys_patch, this_view % ye_patch, & - this_view % xs_patch, this_view % xe_patch, & - allmask_patch, bt_patch ) + this_view % ys_p, this_view % ye_p, & + this_view % xs_p, this_view % xe_p, & + allmask_p, bt_p ) !! Write bt, lat, lon, and satzen to datalink structures @@ -1071,29 +1104,20 @@ write(stdout,fmt=*) 'TEST26' num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain - allocate(thinmask(this_view % ys_patch:this_view % ye_patch, & - this_view % xs_patch:this_view % xe_patch)) + allocate(thinmask(this_view % ys_p:this_view % ye_p, & + this_view % xs_p:this_view % xe_p)) thinmask = .false. else p => p_fgat end if -! this_obslist => view_att(iview) % head - do n = 1, this_view % nrad_on_patch - -! this_obslist => this_obslist % next - -! iy = this_obslist % iy -! ix = this_obslist % ix iy = this_view % iy_1d % patch (n) ix = this_view % ix_1d % patch (n) - if (.not. allmask_patch(iy,ix)) cycle + if (.not. allmask_p( iy, ix )) cycle if (first_chan) then -! info % lat = this_obslist % lat ! latitude -! info % lon = this_obslist % lon ! longitude info % lat = this_view % lat_1d % patch (n) ! latitude info % lon = this_view % lon_1d % patch (n) ! longitude @@ -1112,11 +1136,11 @@ write(stdout,fmt=*) 'TEST26' call map2grids(inst,ifgat,dlat_earth,dlon_earth,crit,iobs,itx,1,itt,iout,iuse) if (.not. iuse) then num_goesabi_thinned=num_goesabi_thinned+1 - thinmask(iy,ix) = .true. + thinmask( iy, ix ) = .true. cycle end if else - if (thinmask(iy,ix)) cycle + if (thinmask( iy, ix )) cycle end if end if @@ -1130,20 +1154,18 @@ write(stdout,fmt=*) 'TEST26' allocate ( p % tb_inv (1:nchan) ) p % info = info -! p % loc = this_obslist % loc p % loc = this_view % loc_1d % patch (n) p % landsea_mask = 1 ! ??? if (use_view_mask) then p % scanpos = & - (iy + this_view % yoff_fd-1 - 1) * (nscan+1) / view_att(1) % ny_global + ( iy + this_view % yoff_fd-1 - 1) * (nscan+1) / view_att(1) % ny_global ! ??? "scan" position (IS THIS CORRECT?) else p % scanpos = & - (iy + this_view % yoff_fd-1 - 1) * (nscan+1) / 5423 + ( iy + this_view % yoff_fd-1 - 1) * (nscan+1) / 5424 ! ??? "scan" position (IS THIS CORRECT?) end if -! p % satzen = this_obslist % satzen p % satzen = this_view % satzen_1d % patch (n) p % solzen = 0.0 @@ -1152,7 +1174,7 @@ write(stdout,fmt=*) 'TEST26' end if ! Transfer BT from all files - p % tb_inv(ichan) = bt_patch(iy,ix) + p % tb_inv(ichan) = bt_p( iy, ix ) if (first_chan) & allocate (p % next) ! add next data @@ -1163,7 +1185,7 @@ write(stdout,fmt=*) 'TEST26' nullify (p % next) end do - deallocate( bt_patch, allmask_patch ) + deallocate( bt_p, allmask_p ) end if VIEW_SELECT end do ChannelLoop @@ -1171,31 +1193,23 @@ write(stdout,fmt=*) 'TEST26' end if PatchMatch -!#ifdef DM_PARALLEL -! call mpi_barrier(comm, ierr) -!#endif +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif end do ! end fgat loop if (this_view % moving .or. ipass.eq.npass) then ! Deallocate static data if (allocated(this_view % patchmask)) deallocate(this_view % patchmask) - end if -! if (ipass.eq.npass) then -! if (this_obslist % i .gt. 0) then -! ! Destroy this_obslist and head -! n = this_obslist % i -! this_obslist => view_att(iview) % head % next -! do i = 1, n -! view_att(iview) % current => this_obslist -! this_obslist => this_obslist % next -! -! ! free current data -! deallocate ( view_att(iview) % current ) -! end do -! deallocate(view_att(iview) % head) -! end if -! end if + deallocate ( this_view % lat_1d % patch ) + deallocate ( this_view % lon_1d % patch ) + deallocate ( this_view % satzen_1d % patch ) + deallocate ( this_view % iy_1d % patch ) + deallocate ( this_view % ix_1d % patch ) + deallocate ( this_view % loc_1d % patch ) + deallocate ( this_view % patchmask ) + end if tot_files_used = tot_files_used + sum(view_att(iview) % nfiles_used) @@ -1453,14 +1467,14 @@ end subroutine get_abil1b_metadata subroutine get_abil1b_grid1( filename, & ny, nx, & - yy, xx, & + yy_abi, xx_abi, & yoff, xoff ) implicit none character(*), intent(in) :: filename integer, intent(in) :: ny, nx - real, intent(out) :: yy(ny), xx(nx) + real, intent(out) :: yy_abi(ny), xx_abi(nx) integer, intent(out) :: yoff, xoff integer :: ierr, ncid, varid @@ -1473,20 +1487,20 @@ subroutine get_abil1b_grid1( filename, & ierr=nf_inq_varid(ncid,'y',varid) - ierr=nf_get_var_double(ncid,varid,yy) + ierr=nf_get_var_double(ncid,varid,yy_abi) ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) ierr=nf_get_att_double(ncid,varid,'add_offset',itp) - yy = yy*slp+itp + yy_abi = yy_abi*slp+itp yoff = floor(itp/slp) ierr=nf_inq_varid(ncid,'x',varid) - ierr=nf_get_var_double(ncid,varid,xx) + ierr=nf_get_var_double(ncid,varid,xx_abi) ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) ierr=nf_get_att_double(ncid,varid,'add_offset',itp) - xx = xx*slp+itp + xx_abi = xx_abi*slp+itp xoff = floor(itp/slp) ierr=nf_close(ncid) @@ -1499,14 +1513,77 @@ end subroutine get_abil1b_grid1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -subroutine get_abil1b_grid2( yy, xx, req, rpol, pph, nam, satellite_id, & +subroutine get_abil1b_grid2_1d( yy_abi, xx_abi, req, rpol, pph, nam, satellite_id, & lat, lon, satzen, & - earthmask, zenmask, & - loc, domainmask ) + earthmask, zenmask ) implicit none - real, intent(in) :: yy, xx + real, intent(in) :: yy_abi(:), xx_abi(:) + real(r_kind), intent(in) :: req, rpol, pph, nam + integer, intent(in) :: satellite_id + + ! GOES-ABI fields + real, intent(out) :: lat(:), lon(:), satzen(:) + logical, intent(out) :: earthmask(:), zenmask(:) + + ! Internal Variables + type(info_type) :: info + logical :: outside_all, dummy_bool + + integer :: iy, ix, n + real(r_kind) :: hh + real, parameter :: satzen_limit=75.0 + + if (trace_use) call da_trace_entry("get_abil1b_grid2_1d") + + lat = missing_r + lon = missing_r + satzen = missing_r + earthmask=.true. + zenmask=.true. + + hh=pph+req + + call get_abil1b_latlon_1d ( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) + +! do n = lbound(yy_abi,1), ubound(yy_abi,1) +! call get_abil1b_latlon ( yy_abi(n), xx_abi(n), lat(n), lon(n), req, rpol, hh, nam ) +! end do + + where( lat.eq.missing_r .OR. lon.eq.missing_r .OR. & + isnan(lat) .OR. isnan(lon) ) + earthmask = .false. + lat = missing_r + lon = missing_r + end where + + call da_get_satzen_1d( lat, lon, satellite_id, satzen ) + +! do n = lbound(yy_abi,1), ubound(yy_abi,1) +! if ( earthmask(n) ) & +! call da_get_satzen( lat(n), lon(n), satellite_id, satzen(n) ) +! end do + + where ( isnan(satzen) .or. satzen.gt.satzen_limit ) + satzen = missing_r + zenmask = .false. + end where + + if (trace_use) call da_trace_exit("get_abil1b_grid2_1d") + +end subroutine get_abil1b_grid2_1d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_grid2( yy_abi, xx_abi, req, rpol, pph, nam, satellite_id, & + lat, lon, satzen, & + earthmask, zenmask ) + + implicit none + + real, intent(in) :: yy_abi, xx_abi real(r_kind), intent(in) :: req, rpol, pph, nam integer, intent(in) :: satellite_id @@ -1514,10 +1591,6 @@ subroutine get_abil1b_grid2( yy, xx, req, rpol, pph, nam, satellite_id, & real, intent(out) :: lat, lon, satzen logical, intent(out) :: earthmask, zenmask - ! Model-specific fields - type(model_loc_type), optional, intent(inout) :: loc - logical, optional, intent(out) :: domainmask - ! Internal Variables type(info_type) :: info logical :: outside_all, dummy_bool @@ -1534,12 +1607,10 @@ subroutine get_abil1b_grid2( yy, xx, req, rpol, pph, nam, satellite_id, & earthmask=.false. zenmask=.false. - if ( present(domainmask) ) & - domainmask = .false. hh=pph+req - call get_abil1b_latlon ( yy, xx, req, rpol, hh, nam, lat, lon ) + call get_abil1b_latlon ( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) if( lat.eq.missing_r .OR. lon.eq.missing_r .OR. & isnan(lat) .OR. isnan(lon) ) return @@ -1554,14 +1625,6 @@ subroutine get_abil1b_grid2( yy, xx, req, rpol, pph, nam, satellite_id, & end if zenmask=.true. - !Populate domainmask, loc with model coordinate utility - if ( present(loc) .and. present(domainmask) ) then - info % lat = lat ! latitude - info % lon = lon ! longitude - call da_llxy (info, loc, dummy_bool, outside_all) - domainmask = .not.outside_all - end if - if (trace_use) call da_trace_exit("get_abil1b_grid2") end subroutine get_abil1b_grid2 @@ -1569,20 +1632,18 @@ end subroutine get_abil1b_grid2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -subroutine get_abil1b_bt( filename, ny, nx, ys, ye, xs, xe, & - radmask, bt ) +subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt ) implicit none character(*), intent(in) :: filename !Size of full data set - integer, intent(in) :: ny, nx !Starting and stopping indices of this view desired (not equivalent to Full Disk indices) integer, intent(in) :: ys, ye, xs, xe - logical, intent(inout) :: radmask(ny, nx) - real, intent(out) :: bt(ys:ye, xs:xe) + logical, intent(inout) :: radmask( ys:ye, xs:xe ) + real, intent(out) :: bt( ys:ye, xs:xe ) real :: rad(ys:ye, xs:xe) integer(kind=1) :: DQF(ys:ye, xs:xe) @@ -1605,11 +1666,11 @@ subroutine get_abil1b_bt( filename, ny, nx, ys, ye, xs, xe, & call handle_err('Error opening file',ierr) ierr=nf_inq_varid(ncid,'Rad',varid) - ierr=nf_get_vara_double(ncid,varid,(/ys,xs/),(/nykeep,nxkeep/), & + ierr=nf_get_vara_double ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), & rad(ys:ye,xs:xe) ) ierr=nf_inq_varid(ncid,'DQF',varid) - ierr=nf_get_vara_int(ncid,varid,(/ys,xs/),(/nykeep,nxkeep/), & + ierr=nf_get_vara_int1 ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), & DQF(ys:ye,xs:xe) ) else return @@ -1630,11 +1691,11 @@ subroutine get_abil1b_bt( filename, ny, nx, ys, ye, xs, xe, & do ix=xs, xe do iy=ys, ye - if ( radmask(iy,ix) ) then - if( rad(iy,ix).ge.0.0 .and. any(DQF(iy,ix).eq.(/0,1/)) ) then - bt(iy,ix)=(fk2/(alog((fk1/rad(iy,ix))+1.))-bc1)/bc2 + if ( radmask( iy, ix ) ) then + if( rad( iy, ix ).ge.0.0 .and. any(DQF( iy, ix ).eq.(/0,1/)) ) then + bt( iy, ix )=(fk2/(alog((fk1/rad( iy, ix ))+1.))-bc1)/bc2 else - radmask(iy,ix) = .true. + radmask( iy, ix ) = .true. end if end if end do @@ -1654,11 +1715,69 @@ end subroutine get_abil1b_bt !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -subroutine get_abil1b_latlon(yy,xx,req,rpol,hh,nam,lat,lon) +subroutine get_abil1b_latlon_1d( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) implicit none - real, intent(in) :: yy, xx + real, intent(in) :: yy_abi(:), xx_abi(:) + real, intent(in) :: req, rpol, hh, nam + real, intent(inout) :: lat(:), lon(:) + + real, allocatable :: lat1(:), lon1(:) + real, allocatable :: aa(:), bb(:), cc(:), rs(:), sx(:), sy(:), sz(:) + real, allocatable :: radicand(:) + integer :: n + + if (trace_use) call da_trace_entry("get_abil1b_latlon_1d") + + n = size(yy_abi) + + allocate ( lat1( n ) ) + allocate ( lon1( n ) ) + allocate ( aa( n ) ) + allocate ( bb( n ) ) + allocate ( cc( n ) ) + allocate ( rs( n ) ) + allocate ( sx( n ) ) + allocate ( sy( n ) ) + allocate ( sz( n ) ) + allocate ( radicand( n ) ) + + aa = sin( xx_abi )**2 + cos( xx_abi )**2 * ( cos( yy_abi )**2 + req**2/rpol**2 * sin( yy_abi )**2 ) + + bb = -2.D0 * hh * cos( xx_abi ) * cos( yy_abi ) + + cc = hh**2-req**2 + + radicand = bb ** 2 - 4.D0 * aa * cc + + where ( radicand .ge. 0. ) + rs = ( -bb - sqrt( radicand ) ) / ( 2.D0 * aa ) + sx = rs * cos( xx_abi ) * cos( yy_abi ) + sy = -rs * sin( xx_abi ) + sz = rs * cos( xx_abi ) * sin( yy_abi ) + + lat1 = atan( req**2 / rpol**2 * sz / sqrt( ( hh - sx )**2 + sy**2) ) + lon1 = nam - atan( sy / ( hh - sx ) ) + + lat = lat1 * 180.D0/pi + lon = lon1 * 180.D0/pi + end where + + deallocate ( lat1, lon1, aa, bb, cc, rs, sx, sy, sz, radicand ) + + if (trace_use) call da_trace_exit("get_abil1b_latlon_1d") + +end subroutine get_abil1b_latlon_1d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_latlon( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) + + implicit none + + real, intent(in) :: yy_abi, xx_abi real, intent(in) :: req, rpol, hh, nam real, intent(inout) :: lat,lon @@ -1668,23 +1787,23 @@ subroutine get_abil1b_latlon(yy,xx,req,rpol,hh,nam,lat,lon) if (trace_use) call da_trace_entry("get_abil1b_latlon") - aa=sin(xx)**2+cos(xx)**2*(cos(yy)**2+req**2/rpol**2*sin(yy)**2) - bb=-2.D0*hh*cos(xx)*cos(yy) - cc=hh**2-req**2 + aa = sin( xx_abi )**2 + cos( xx_abi )**2 * ( cos( yy_abi )**2 + req**2/rpol**2 * sin( yy_abi )**2) + bb = -2.D0*hh * cos( xx_abi ) * cos( yy_abi ) + cc = hh**2 - req**2 - radicand = bb**2 - 4.D0*aa*cc + radicand = bb **2 - 4.D0 * aa * cc if (radicand .lt. 0.) return - rs=(-bb-sqrt(radicand))/(2.D0*aa) - sx=rs*cos(xx)*cos(yy) - sy=-rs*sin(xx) - sz=rs*cos(xx)*sin(yy) + rs = ( -bb - sqrt( radicand ) )/(2.D0 * aa) + sx = rs * cos( xx_abi ) * cos( yy_abi ) + sy = -rs * sin( xx_abi ) + sz = rs * cos( xx_abi ) * sin( yy_abi ) - lat1=atan(req**2/rpol**2*sz/sqrt((hh-sx)**2+sy**2)) - lon1=nam-atan(sy/(hh-sx)) + lat1 = atan( req**2/rpol**2 * sz / sqrt( ( hh - sx )**2 + sy**2) ) + lon1 = nam-atan( sy / ( hh - sx ) ) - lat=lat1*180.D0/pi - lon=lon1*180.D0/pi + lat = lat1 * 180.D0/pi + lon = lon1 * 180.D0/pi if (trace_use) call da_trace_exit("get_abil1b_latlon") @@ -1695,13 +1814,11 @@ end subroutine get_abil1b_latlon subroutine split_grid( ny_global, nx_global, & ny_grid, nx_grid, & - ys_grid, xs_grid, & - redist ) + ys_grid, xs_grid ) implicit none integer, intent(in) :: ny_global, nx_global - logical, intent(in) :: redist integer, intent(out) :: ny_grid(num_procs), nx_grid(num_procs), & ys_grid(num_procs), xs_grid(num_procs) @@ -1732,33 +1849,34 @@ subroutine split_grid( ny_global, nx_global, & mm = mm - 1 end do - if (redist) then - fact = 4 - !Redistribute grid from middle to edges to balance load - ! of calls to da_llxy in get_abil1b_grid - do i = 1, 2 - if (mod(ntasks,2).eq.1) then - ii = ntasks/2+1 - mm = nvec(ii) / fact - mm = mm/2 - nvec(ii) = nvec(ii) - 2*mm - nvec(ii-1) = nvec(ii-1) + mm - nvec(ii+1) = nvec(ii+1) + mm - else - ii = ntasks/2 - end if - do j = ntasks/2, 2, -1 - mm = nvec(j) / fact - nvec(j) = nvec(j) - mm - nvec(j-1) = nvec(j-1) + mm - end do - do j = ii+1, ntasks-1 - mm = nvec(j) / fact - nvec(j) = nvec(j) - mm - nvec(j+1) = nvec(j+1) + mm - end do - end do - end if +! Depracated +! if (redist) then +! fact = 4 +! !Redistribute grid from middle to edges to balance load +! ! of calls to da_llxy in get_abil1b_grid +! do i = 1, 2 +! if (mod(ntasks,2).eq.1) then +! ii = ntasks/2+1 +! mm = nvec(ii) / fact +! mm = mm/2 +! nvec(ii) = nvec(ii) - 2*mm +! nvec(ii-1) = nvec(ii-1) + mm +! nvec(ii+1) = nvec(ii+1) + mm +! else +! ii = ntasks/2 +! end if +! do j = ntasks/2, 2, -1 +! mm = nvec(j) / fact +! nvec(j) = nvec(j) - mm +! nvec(j-1) = nvec(j-1) + mm +! end do +! do j = ii+1, ntasks-1 +! mm = nvec(j) / fact +! nvec(j) = nvec(j) - mm +! nvec(j+1) = nvec(j+1) + mm +! end do +! end do +! end if svec(1) = 1 do j = 1, ntasks diff --git a/var/da/da_tools/da_llxy.inc b/var/da/da_tools/da_llxy.inc index 59ef70201a..2784b72eee 100644 --- a/var/da/da_tools/da_llxy.inc +++ b/var/da/da_tools/da_llxy.inc @@ -1,4 +1,4 @@ -subroutine da_llxy (info, loc, outside, outside_all, outside_only) +subroutine da_llxy (info, loc, outside, outside_all, xy_only) !----------------------------------------------------------------------- ! Purpose: TBD @@ -14,36 +14,30 @@ subroutine da_llxy (info, loc, outside, outside_all, outside_only) type(model_loc_type), intent(inout) :: loc logical , intent(out) :: outside !wrt local domain logical, optional, intent(out) :: outside_all !wrt all domains - logical, optional, intent(in) :: outside_only - - logical :: include_xy_convert + logical, optional, intent(in) :: xy_only ! too many return statments to trace ! if (trace_use_frequent) call da_trace_entry("da_llxy") - include_xy_convert = .true. - if (present(outside_only)) include_xy_convert = .not.outside_only - outside = .false. - if (include_xy_convert) then - loc % x = -1.0 - loc % y = -1.0 + loc % x = -1.0 + loc % y = -1.0 - ! get the (x, y) coordinates - - if ( fg_format == fg_format_wrf_arw_regional ) then - call da_llxy_wrf(map_info, info%lat, info%lon, loc%x, loc%y) - else if (fg_format == fg_format_wrf_nmm_regional) then - call da_llxy_rotated_latlon(info%lat, info%lon, map_info, loc%x, loc%y) - else if (global) then - call da_llxy_global (info%lat, info%lon, loc%x, loc%y) - else - call da_llxy_default (info%lat, info%lon, loc%x, loc%y) - end if + ! get the (x, y) coordinates + + if ( fg_format == fg_format_wrf_arw_regional ) then + call da_llxy_wrf(map_info, info%lat, info%lon, loc%x, loc%y) + else if (fg_format == fg_format_wrf_nmm_regional) then + call da_llxy_rotated_latlon(info%lat, info%lon, map_info, loc%x, loc%y) + else if (global) then + call da_llxy_global (info%lat, info%lon, loc%x, loc%y) + else + call da_llxy_default (info%lat, info%lon, loc%x, loc%y) end if + if ( xy_only ) return #ifdef A2C call da_togrid (loc%x, its-3, ite+3, loc%i, loc%dx, loc%dxm)! diff --git a/var/da/da_tools/da_outside.inc b/var/da/da_tools/da_outside.inc new file mode 100644 index 0000000000..a85ef3a253 --- /dev/null +++ b/var/da/da_tools/da_outside.inc @@ -0,0 +1,92 @@ +subroutine da_outside (locs, outside, outside_all) + + !----------------------------------------------------------------------- + ! Purpose: TBD + !----------------------------------------------------------------------- + + ! Vectorized determination of whether locs are on this domain/patch, copied from da_llxy_new + + implicit none + + type(model_loc_type), intent(inout) :: locs(:,:) + logical, intent(inout) :: outside(:,:) ! wrt local domain + logical, optional, intent(out) :: outside_all(:,:) ! wrt all domains + + if (trace_use) call da_trace_entry("da_outside") + + outside(:,:) = .false. + +#ifdef A2C + call da_togrid_new (locs(:,:)%x, its-3, ite+3, locs(:,:)%i, locs(:,:)%dx, locs(:,:)%dxm)! + + call da_togrid_new (locs(:,:)%y, jts-3, jte+3, locs(:,:)%j, locs(:,:)%dy, locs(:,:)%dym) +#else + call da_togrid_new (locs(:,:)%x, its-2, ite+2, locs(:,:)%i, locs(:,:)%dx, locs(:,:)%dxm)! + + call da_togrid_new (locs(:,:)%y, jts-2, jte+2, locs(:,:)%j, locs(:,:)%dy, locs(:,:)%dym) +#endif + + ! refactor to remove this ugly duplication later + if (present(outside_all)) then + outside_all(:,:) = .false. + ! Do not check for global options + if (.not. global) then + where ((int(locs(:,:)%x) < ids) .or. (int(locs(:,:)%x) >= ide) .or. & + (int(locs(:,:)%y) < jds) .or. (int(locs(:,:)%y) >= jde)) + outside_all(:,:) = .true. + outside(:,:) = .true. + end where + if (def_sub_domain) then + where (x_start_sub_domain > locs(:,:)%x .or. y_start_sub_domain > locs(:,:)%y .or. & + x_end_sub_domain < locs(:,:)%x .or. y_end_sub_domain < locs(:,:)%y) + outside_all(:,:) = .true. + outside(:,:) = .true. + end where + end if + end if + end if + + if (fg_format == fg_format_kma_global) then + where ((locs(:,:)%j < jts-1) .or. (locs(:,:)%j > jte)) + outside(:,:) = .true. + end where + + where (locs(:,:)%j == jde) + locs(:,:)%j = locs(:,:)%j - 1 + locs(:,:)%dy = 1.0 + locs(:,:)%dym = 0.0 + end where + + return + end if + + ! Check for edge of domain: + + where ((locs(:,:)%i < ids) .or. (locs(:,:)%i >= ide) .or. & + (locs(:,:)%j < jds) .or. (locs(:,:)%j >= jde)) + outside = .true. + end where + + ! FIX? hack +#ifdef A2C + where ((locs(:,:)%i < its-2) .or. (locs(:,:)%i > ite) .or. & + (locs(:,:)%j < jts-2) .or. (locs(:,:)%j > jte)) +#else + where ((locs(:,:)%i < its-1) .or. (locs(:,:)%i > ite) .or. & + (locs(:,:)%j < jts-1) .or. (locs(:,:)%j > jte)) +#endif + outside(:,:) = .true. + end where + + if (def_sub_domain) then + where (x_start_sub_domain > locs(:,:)%x .or. y_start_sub_domain > locs(:,:)%y .or. & + x_end_sub_domain < locs(:,:)%x .or. y_end_sub_domain < locs(:,:)%y) + outside(:,:) = .true. + end where + end if + + if (trace_use) call da_trace_exit("da_outside") + +end subroutine da_outside + + diff --git a/var/da/da_tools/da_tools.f90 b/var/da/da_tools/da_tools.f90 index ced8aa918b..15d6f4a5d8 100644 --- a/var/da/da_tools/da_tools.f90 +++ b/var/da/da_tools/da_tools.f90 @@ -48,6 +48,7 @@ module da_tools #include "da_llxy.inc" #include "da_llxy_new.inc" +#include "da_outside.inc" #include "da_llxy_default.inc" #include "da_llxy_default_new.inc" #include "da_llxy_kma_global.inc" From 65765decadfaa8b5cfafaa9d3c25be25baac4b60 Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Wed, 23 May 2018 16:40:51 -0600 Subject: [PATCH 10/86] Added more vectorized code for speedup + ll to xy conversion in da_llxy_1d + rad to bt conversion in get_abil1b_bt + replaced loop over mpi_bcast with single mpi_allgatherv Also many code cleanups to remove old implementations Changes to be committed: modified: ../build/depend.txt modified: da_radiance/da_radiance.f90 modified: da_radiance/da_read_obs_ncgoesabi.inc new file: da_tools/da_llxy_1d.inc new file: da_tools/da_llxy_default_1d.inc new file: da_tools/da_llxy_global_1d.inc new file: da_tools/da_llxy_kma_global_1d.inc new file: da_tools/da_llxy_latlon_1d.inc new file: da_tools/da_llxy_lc_1d.inc new file: da_tools/da_llxy_merc_1d.inc new file: da_tools/da_llxy_ps_1d.inc new file: da_tools/da_llxy_rotated_latlon_1d.inc new file: da_tools/da_llxy_wrf_1d.inc new file: da_tools/da_togrid_1d.inc modified: da_tools/da_tools.f90 --- var/build/depend.txt | 2 +- var/da/da_radiance/da_radiance.f90 | 4 +- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 879 +++++++++--------- var/da/da_tools/da_llxy.inc | 7 +- var/da/da_tools/da_llxy_1d.inc | 115 +++ var/da/da_tools/da_llxy_default_1d.inc | 114 +++ var/da/da_tools/da_llxy_global_1d.inc | 35 + var/da/da_tools/da_llxy_kma_global_1d.inc | 36 + var/da/da_tools/da_llxy_latlon_1d.inc | 56 ++ var/da/da_tools/da_llxy_lc_1d.inc | 64 ++ var/da/da_tools/da_llxy_merc_1d.inc | 35 + var/da/da_tools/da_llxy_ps_1d.inc | 50 + var/da/da_tools/da_llxy_rotated_latlon_1d.inc | 60 ++ var/da/da_tools/da_llxy_wrf_1d.inc | 51 + var/da/da_tools/da_outside.inc | 92 -- var/da/da_tools/da_togrid_1d.inc | 44 + var/da/da_tools/da_tools.f90 | 16 +- 17 files changed, 1139 insertions(+), 521 deletions(-) create mode 100644 var/da/da_tools/da_llxy_1d.inc create mode 100644 var/da/da_tools/da_llxy_default_1d.inc create mode 100644 var/da/da_tools/da_llxy_global_1d.inc create mode 100644 var/da/da_tools/da_llxy_kma_global_1d.inc create mode 100644 var/da/da_tools/da_llxy_latlon_1d.inc create mode 100644 var/da/da_tools/da_llxy_lc_1d.inc create mode 100644 var/da/da_tools/da_llxy_merc_1d.inc create mode 100644 var/da/da_tools/da_llxy_ps_1d.inc create mode 100644 var/da/da_tools/da_llxy_rotated_latlon_1d.inc create mode 100644 var/da/da_tools/da_llxy_wrf_1d.inc delete mode 100644 var/da/da_tools/da_outside.inc create mode 100644 var/da/da_tools/da_togrid_1d.inc diff --git a/var/build/depend.txt b/var/build/depend.txt index 4e0d1dfd60..b075b045ad 100644 --- a/var/build/depend.txt +++ b/var/build/depend.txt @@ -162,7 +162,7 @@ da_statistics.o : da_statistics.f90 da_print_qcstat.inc da_stats_calculate.inc d da_synop.o : da_synop.f90 da_check_buddy_synop.inc da_calculate_grady_synop.inc da_check_max_iv_synop.inc da_get_innov_vector_synop.inc da_transform_xtoy_synop_adj.inc da_transform_xtoy_synop.inc da_print_stats_synop.inc da_oi_stats_synop.inc da_residual_synop.inc da_jo_synop_uvtq.inc da_jo_and_grady_synop.inc da_ao_stats_synop.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_tamdar.o : da_tamdar.f90 da_calculate_grady_tamdar_sfc.inc da_check_max_iv_tamdar_sfc.inc da_get_innov_vector_tamdar_sfc.inc da_transform_xtoy_tamdar_sfc_adj.inc da_transform_xtoy_tamdar_sfc.inc da_print_stats_tamdar_sfc.inc da_oi_stats_tamdar_sfc.inc da_residual_tamdar_sfc.inc da_jo_tamdar_sfc_uvtq.inc da_jo_and_grady_tamdar_sfc.inc da_ao_stats_tamdar_sfc.inc da_calculate_grady_tamdar.inc da_get_innov_vector_tamdar.inc da_check_max_iv_tamdar.inc da_transform_xtoy_tamdar_adj.inc da_transform_xtoy_tamdar.inc da_print_stats_tamdar.inc da_oi_stats_tamdar.inc da_residual_tamdar.inc da_jo_tamdar_uvtq.inc da_jo_and_grady_tamdar.inc da_ao_stats_tamdar.inc da_tracing.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_test.o : da_test.f90 da_test_vxtransform.inc da_check_gradient.inc da_get_y_lhs_value.inc da_check_vtoy_adjoint.inc da_set_tst_trnsf_fld.inc da_check_psfc.inc da_check_sfc_assi.inc da_setup_testfield.inc da_check_xtoy_adjoint_buoy.inc da_check_xtoy_adjoint_profiler.inc da_check_xtoy_adjoint_ssmt2.inc da_check_xtoy_adjoint_ssmt1.inc da_check_xtoy_adjoint_qscat.inc da_check_xtoy_adjoint_pseudo.inc da_dot_cv.inc da_dot.inc da_check.inc da_check_gradient.inc da_transform_xtovp.inc da_check_xtoy_adjoint_rad.inc da_check_xtoy_adjoint_synop.inc da_check_xtoy_adjoint_tamdar_sfc.inc da_check_xtoy_adjoint_tamdar.inc da_check_xtoy_adjoint_mtgirs.inc da_check_xtoy_adjoint_sonde_sfc.inc da_check_xtoy_adjoint_sound.inc da_check_xtoy_adjoint_bogus.inc da_check_xtoy_adjoint_rain.inc da_check_xtoy_adjoint_radar.inc da_check_xtoy_adjoint_ships.inc da_check_xtoy_adjoint_polaramv.inc da_check_xtoy_adjoint_geoamv.inc da_check_xtoy_adjoint_satem.inc da_check_xtoy_adjoint_ssmi_tb.inc da_check_xtoy_adjoint_ssmi_rv.inc da_check_xtoy_adjoint_pilot.inc da_check_xtoy_adjoint_metar.inc da_check_xtoy_adjoint_gpsref.inc da_check_xtoy_adjoint_gpspw.inc da_check_xtoy_adjoint_airep.inc da_check_xtoy_adjoint.inc da_check_xtovptox_errors.inc da_check_vvtovp_adjoint.inc da_check_vp_errors.inc da_check_vptox_adjoint.inc da_check_vtox_adjoint.inc da_check_cvtovv_adjoint.inc da_check_balance.inc da_4dvar.o da_vtox_transforms.o da_wrfvar_io.o da_wrf_interfaces.o da_transfer_model.o da_tracing.o da_tools_serial.o da_statistics.o da_ssmi.o da_spectral.o da_reporting.o da_physics.o da_par_util1.o da_par_util.o da_obs.o da_minimisation.o da_ffts.o da_dynamics.o da_define_structures.o module_state_description.o module_domain.o da_control.o module_comm_dm.o module_dm.o module_configure.o da_rain.o da_check_dynamics_adjoint.inc da_check_xtoy_adjoint_gpseph.inc -da_tools.o : da_tools.f90 da_geo2msl1.inc da_msl2geo1.inc da_get_time_slots.inc da_get_julian_time.inc da_get_print_lvl.inc da_get_3d_sum.inc da_get_2d_sum.inc da_set_boundary_3d.inc da_set_boundary_xb.inc da_set_boundary_xa.inc da_ludcmp.inc da_lubksb.inc da_eof_decomposition.inc da_eof_decomposition_test.inc da_buddy_qc.inc da_unifva.inc da_togrid.inc da_togrid_new.inc da_smooth_anl.inc da_openfile.inc da_gaus_noise.inc da_set_randomcv.inc da_random_omb.inc da_max_error_qc.inc da_add_noise_new.inc da_add_noise.inc da_residual_new.inc da_residual.inc da_diff_seconds.inc da_mo_correction.inc da_intpsfc_tem.inc da_intpsfc_prs.inc da_sfcprs.inc da_obs_sfc_correction.inc da_1d_eigendecomposition.inc da_convert_zk.inc da_lc_cone.inc da_set_merc.inc da_map_set.inc da_map_init.inc da_set_ps.inc da_set_lc.inc da_xyll_ps.inc da_xyll_merc.inc da_xyll_lc.inc da_xyll_latlon.inc da_xyll_default.inc da_xyll.inc da_llxy_wrf_new.inc da_outside.inc da_llxy_wrf.inc da_llxy_ps_new.inc da_llxy_ps.inc da_llxy_merc_new.inc da_llxy_merc.inc da_llxy_lc_new.inc da_llxy_lc.inc da_llxy_latlon_new.inc da_llxy_latlon.inc da_llxy_rotated_latlon.inc da_llxy_global_new.inc da_llxy_global.inc da_llxy_kma_global_new.inc da_llxy_kma_global.inc da_llxy_default_new.inc da_llxy_default.inc da_llxy_new.inc da_llxy.inc da_map_utils_defines.inc da_lapack.o da_reporting.o da_tracing.o da_tools_serial.o da_define_structures.o da_control.o module_domain.o module_dm.o module_bc.o da_sfc_hori_interp_weights.inc +da_tools.o : da_tools.f90 da_geo2msl1.inc da_msl2geo1.inc da_get_time_slots.inc da_get_julian_time.inc da_get_print_lvl.inc da_get_3d_sum.inc da_get_2d_sum.inc da_set_boundary_3d.inc da_set_boundary_xb.inc da_set_boundary_xa.inc da_ludcmp.inc da_lubksb.inc da_eof_decomposition.inc da_eof_decomposition_test.inc da_buddy_qc.inc da_unifva.inc da_togrid.inc da_togrid_new.inc da_smooth_anl.inc da_openfile.inc da_gaus_noise.inc da_set_randomcv.inc da_random_omb.inc da_max_error_qc.inc da_add_noise_new.inc da_add_noise.inc da_residual_new.inc da_residual.inc da_diff_seconds.inc da_mo_correction.inc da_intpsfc_tem.inc da_intpsfc_prs.inc da_sfcprs.inc da_obs_sfc_correction.inc da_1d_eigendecomposition.inc da_convert_zk.inc da_lc_cone.inc da_set_merc.inc da_map_set.inc da_map_init.inc da_set_ps.inc da_set_lc.inc da_xyll_ps.inc da_xyll_merc.inc da_xyll_lc.inc da_xyll_latlon.inc da_xyll_default.inc da_xyll.inc da_llxy_wrf_new.inc da_llxy_wrf.inc da_llxy_ps_new.inc da_llxy_ps.inc da_llxy_merc_new.inc da_llxy_merc.inc da_llxy_lc_new.inc da_llxy_lc.inc da_llxy_latlon_new.inc da_llxy_latlon.inc da_llxy_rotated_latlon.inc da_llxy_global_new.inc da_llxy_global.inc da_llxy_kma_global_new.inc da_llxy_kma_global.inc da_llxy_default_new.inc da_llxy_default.inc da_llxy_new.inc da_llxy.inc da_llxy_1d.inc da_llxy_default_1d.inc da_llxy_kma_global_1d.inc da_llxy_global_1d.inc da_llxy_rotated_latlon_1d.inc da_llxy_latlon_1d.inc da_llxy_lc_1d.inc da_llxy_merc_1d.inc da_llxy_ps_1d.inc da_llxy_wrf_1d.inc da_map_utils_defines.inc da_lapack.o da_reporting.o da_tracing.o da_tools_serial.o da_define_structures.o da_control.o module_domain.o module_dm.o module_bc.o da_sfc_hori_interp_weights.inc da_tools_serial.o : da_tools_serial.f90 da_find_fft_trig_funcs.inc da_find_fft_factors.inc da_advance_time.inc da_advance_cymdh.inc da_array_print.inc da_change_date.inc da_free_unit.inc da_get_unit.inc da_reporting.o da_control.o da_tracing.o : da_tracing.f90 da_trace_report.inc da_trace_real_sort.inc da_trace_int_sort.inc da_trace_exit.inc da_trace.inc da_trace_entry.inc da_trace_init.inc da_reporting.o da_par_util1.o da_control.o da_transfer_model.o : da_transfer_model.f90 da_get_2nd_firstguess.inc da_setup_firstguess_kma.inc da_setup_firstguess_wrf_nmm_regional.inc da_setup_firstguess_wrf.inc da_setup_firstguess.inc da_transfer_xatoanalysis.inc da_transfer_wrftl_lbc_t0_adj.inc da_transfer_xatowrftl_adj_lbc.inc da_transfer_xatowrftl_adj.inc da_transfer_wrftl_lbc_t0.inc da_transfer_xatowrftl_lbc.inc da_transfer_xatowrftl.inc da_transfer_wrftltoxa_adj.inc da_transfer_wrftltoxa.inc da_transfer_xatokma.inc da_transfer_xatowrf_nmm_regional.inc da_transfer_xatowrf.inc da_transfer_kmatoxb.inc da_transfer_wrf_nmm_regional_toxb.inc da_transfer_wrftoxb.inc module_io_wrf.o module_bc.o da_4dvar.o da_vtox_transforms.o da_tracing.o da_tools.o da_ssmi.o da_setup_structures.o da_reporting.o da_physics.o da_par_util.o da_grid_definitions.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_state_description.o module_io_domain.o module_domain.o module_date_time.o module_configure.o da_radar.o diff --git a/var/da/da_radiance/da_radiance.f90 b/var/da/da_radiance/da_radiance.f90 index c689e0bbce..33c4090b42 100644 --- a/var/da/da_radiance/da_radiance.f90 +++ b/var/da/da_radiance/da_radiance.f90 @@ -91,8 +91,8 @@ module da_radiance #endif use da_statistics, only : da_stats_calculate use da_tools, only : da_residual, da_obs_sfc_correction, & - da_llxy, da_llxy_new, da_outside, da_togrid_new, da_get_julian_time, da_get_time_slots, & - da_xyll, map_info + da_llxy, da_llxy_new, da_togrid_new, da_get_julian_time, da_get_time_slots, & + da_xyll, map_info, da_llxy_1d use da_tracing, only : da_trace_entry, da_trace_exit, da_trace, & da_trace_int_sort use da_varbc, only : da_varbc_direct,da_varbc_coldstart,da_varbc_precond, & diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index bb734e8c0e..38932dee4b 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -40,6 +40,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: yoff_fd, xoff_fd ! For MPI parallelization integer :: nbuf, nrad_local, nrad_mask, buf_i, buf_f + integer, allocatable :: nbufs(:), displs(:) integer :: ny_local, nx_local integer :: ys_local, xs_local @@ -52,8 +53,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !!! real :: lat_sat, lon_sat ! Assume fixed values in da_get_satzen real, allocatable, target :: buf_real(:,:) integer, allocatable, target :: buf_int(:,:) - type(model_loc_type), allocatable, target :: buf_loc(:,:) - + type(model_loc_type), allocatable, target :: buf_loc(:) + type(info_type), allocatable :: info_1d(:) ! Masks for data reduction !!! logical :: include_local, load_balance @@ -61,8 +62,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) logical, allocatable :: & earthmask_1d(:) , & zenmask_1d(:) , & - patchmask_1d(:) , & domainmask_1d(:) , & + patchmask_1d(:) , & dummybool_2d(:,:) , & allmask_p(:,:) , & thinmask(:,:) @@ -110,17 +111,17 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) type field_r real, pointer :: local(:) - real, pointer :: global(:) + real, pointer :: domain(:) real, pointer :: patch(:) end type field_r type field_i integer, pointer :: local(:) - integer, pointer :: global(:) + integer, pointer :: domain(:) integer, pointer :: patch(:) end type field_i type field_loc - type(model_loc_type), pointer :: local(:,:) - type(model_loc_type), pointer :: global(:) + type(model_loc_type), pointer :: local(:) + type(model_loc_type), pointer :: domain(:) type(model_loc_type), pointer :: patch(:) end type field_loc @@ -314,9 +315,11 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) " -type f -name '",trim(fname), & "*G",satellite_id, & "*' -printf '%P\n' > ",trim(list_file) + write(stdout,*) trim(command) call execute_command_line (trim(command)) write(command,fmt='(4A)') "cat ",trim(list_file)," | wc -l > ",trim(count_file) + write(stdout,*) trim(command) call execute_command_line (trim(command)) open(unit=file_unit,file=trim(count_file)) @@ -504,30 +507,25 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) write(unit=stdout,fmt='(A,I0,A)') & 'Processing GOES-',satellite_id,' ABI data for:' - write(unit=stdout,fmt='(2A)') & - ' ',fgat_times_c(ifgat) + write(unit=stdout,fmt='(4A)') & + ' ',trim(this_view % name)," ; ",fgat_times_c(ifgat) fname_short = trim(this_view % filename(first_file)) fname = trim(this_view % fpath)//trim(fname_short) -!write(stdout,fmt=*) 'TEST1' - if ( ipass.eq.1 .and. sum(this_view % nfiles_used(:)).eq.0 ) then !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Get ABI metadata (first pass for FD, CONUS, MESO) ! Only ny_global and nx_global need to be read for all views, but this is a cheap subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - write(unit=stdout,fmt='(2A)') & - ' Reading abi metadata for ',trim(this_view % name) + write(unit=stdout,fmt='(A)') & + ' Reading abi metadata...' call get_abil1b_metadata( & fname, this_view % ny_global, this_view % nx_global, & req, rpol, pph, nam)! , lat_sat, lon_sat ) -!write(stdout,fmt=*) 'TEST2' -!write(stdout,fmt=*) this_view % ny_global, this_view % nx_global, req, rpol, pph, nam - #ifdef DM_PARALLEL ! Split the global ABI grid for this view into local segments allocate ( this_view % ny_grid ( num_procs ) ) @@ -539,9 +537,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) this_view % ny_grid, this_view % nx_grid , & this_view % ys_grid, this_view % xs_grid ) -!write(stdout,fmt=*) 'ntasks_y, ntasks_x, num_procs, myproc = ', ntasks_y, ntasks_x, num_procs, myproc -!write(stdout,fmt=*) 'TEST3' - #else ! When mpi parallelism is not available, assign global values to local variables this_view % ny_grid = this_view % ny_global @@ -550,413 +545,446 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) this_view % xs_grid = 1 #endif -!write(stdout,fmt=*) 'ny_grid, nx_grid, ys_grid, xs_grid = ' -!write(stdout,fmt=*) this_view % ny_grid -!write(stdout,fmt=*) this_view % nx_grid -!write(stdout,fmt=*) this_view % ys_grid -!write(stdout,fmt=*) this_view % xs_grid - -!write(stdout,fmt=*) 'TEST4' - end if ! Recall global dims for this_view ny_global = this_view % ny_global nx_global = this_view % nx_global -write(stdout,fmt=*) 'TEST5' - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Generate grid locations if !! + CONUS or FD and first matching fgat !! + MESO and any fgat (extent changes in time) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if ( ( .not.this_view % moving .and. sum(this_view % nfiles_used(:)).eq.0 ) & + DoGridGen: if ( ( ipass.eq.1 .and. sum(this_view % nfiles_used(:)).eq.0 ) & .or. this_view % moving ) then -! if ( ipass.eq.2 .and. iview .eq. 1 ) then -! ! Restore FD attributes from memory -! this_view % yoff_fd = yoff_fd -! this_view % xoff_fd = xoff_fd -! end if - - if ( ipass.eq.1 .or. this_view % moving ) then -write(stdout,fmt=*) 'TEST6' - - ! Read grid from file, convert to lat, lon, satzen - write(unit=stdout,fmt='(2A)') & - ' Reading abi grid info for ',trim(this_view % name) - - - !======================================================== - ! Establish GOES metadata for this view and ifgat - ! (constant acros fgat's, except for this_view % moving) - !======================================================== - allocate( yy_abi (ny_global) ) - allocate( xx_abi (nx_global) ) - call get_abil1b_grid1( fname, & - ny_global, nx_global, & - yy_abi, xx_abi, & - this_view % yoff_fd, this_view % xoff_fd ) - - if ( iview.eq.1 ) then - yoff_fd = this_view % yoff_fd - xoff_fd = this_view % xoff_fd - this_view % yoff_fd = 1 - this_view % xoff_fd = 1 - else -! this_view % yoff_fd = this_view % yoff_fd - yoff_fd -! this_view % xoff_fd = this_view % xoff_fd - xoff_fd - this_view % yoff_fd = this_view % yoff_fd - yoff_fd + 1 - this_view % xoff_fd = this_view % xoff_fd - xoff_fd + 1 -! if (iview .gt. 2) then -! this_view % yoff_fd = this_view % yoff_fd + 1 -! this_view % xoff_fd = this_view % xoff_fd + 1 -! end if - end if - -write(stdout,fmt=*) 'TEST7' + ! Read grid from file, convert to lat, lon, satzen + write(unit=stdout,fmt='(2A)') & + ' Reading/calculating abi grid info...' + + !======================================================== + ! Establish GOES metadata for this view and ifgat + ! (constant acros fgat's, except for this_view % moving) + !======================================================== + allocate( yy_abi (ny_global) ) + allocate( xx_abi (nx_global) ) + call get_abil1b_grid1( fname, & + ny_global, nx_global, & + yy_abi, xx_abi, & + this_view % yoff_fd, this_view % xoff_fd ) + + if ( iview.eq.1 ) then + yoff_fd = this_view % yoff_fd + xoff_fd = this_view % xoff_fd + this_view % yoff_fd = 1 + this_view % xoff_fd = 1 + else + this_view % yoff_fd = this_view % yoff_fd - yoff_fd + 1 + this_view % xoff_fd = this_view % xoff_fd - xoff_fd + 1 + end if - !=========================================================== - ! Create a local array subset of observation location - ! quantities across processors. - !=========================================================== + !=========================================================== + ! Create a local array subset of observation location + ! quantities across processors. + !=========================================================== !!! load_balance = any(iview.eq.(/1,2/)) !!! if (load_balance) then - nrad_local = ny_global * nx_global / num_procs + 1 + nrad_local = ny_global * nx_global / num_procs + 1 !!! else !!! nrad_local = this_view % ny_grid(iproc+1) * this_view % nx_grid(iproc+1) !!! end if - allocate( yy_1d (nrad_local) ) - allocate( xx_1d (nrad_local) ) - allocate( iy_1d (nrad_local) ) - allocate( ix_1d (nrad_local) ) - - n = 0 ; icount = 1 - ! This loop over subgrids and the selective logic - ! below for myproc balances the processor loads - ! when some imager pixels are off-earth or outside - ! zenith-angle limits (Full Disk and CONUS) - do subgrid = 1, num_procs - ! Recall local dims for this_view - ny_local = this_view % ny_grid(subgrid) - nx_local = this_view % nx_grid(subgrid) - ys_local = this_view % ys_grid(subgrid) - xs_local = this_view % xs_grid(subgrid) + allocate( yy_1d (nrad_local) ) + allocate( xx_1d (nrad_local) ) + allocate( iy_1d (nrad_local) ) + allocate( ix_1d (nrad_local) ) + + n = 0 ; icount = 1 + ! This loop over subgrids and the selective logic + ! below for myproc balances the processor loads + ! when some imager pixels are off-earth or outside + ! zenith-angle limits (Full Disk and CONUS) + do subgrid = 1, num_procs + ! Recall local dims for this_view + ny_local = this_view % ny_grid(subgrid) + nx_local = this_view % nx_grid(subgrid) + ys_local = this_view % ys_grid(subgrid) + xs_local = this_view % xs_grid(subgrid) !!! !This version of include_local produces unbalanced loads between processors !!! include_local = ( subgrid-1 .eq. myproc ) - do ixl = 1, nx_local - do iyl = 1, ny_local + do ixl = 1, nx_local + do iyl = 1, ny_local !!! !This version of include_local produces balanced loads between processors !!! if (load_balance) & !!! include_local = ( mod( n, num_procs ) .eq. myproc ) !!! if ( include_local ) then - if ( mod( n, num_procs ) .eq. myproc ) then - iy = iyl + ys_local - 1 - ix = ixl + xs_local - 1 - yy_1d(icount) = yy_abi( iy ) - xx_1d(icount) = xx_abi( ix ) - iy_1d(icount) = iy - ix_1d(icount) = ix + if ( mod( n, num_procs ) .eq. myproc ) then + iy = iyl + ys_local - 1 + ix = ixl + xs_local - 1 + yy_1d(icount) = yy_abi( iy ) + xx_1d(icount) = xx_abi( ix ) + iy_1d(icount) = iy + ix_1d(icount) = ix - icount = icount + 1 + icount = icount + 1 - end if - n = n + 1 - end do + end if + n = n + 1 end do end do + end do - nrad_local = icount - 1 - - deallocate( yy_abi, xx_abi ) - -write(stdout,fmt=*) 'TEST8' - - allocate( earthmask_1d (nrad_local) ) - allocate( zenmask_1d (nrad_local) ) - allocate( this_view % lat_1d % local (nrad_local) ) - allocate( this_view % lon_1d % local (nrad_local) ) - allocate( this_view % satzen_1d % local (nrad_local) ) - allocate( this_view % loc_1d % local (nrad_local,1) ) - allocate( this_view % iy_1d % local (nrad_local) ) - allocate( this_view % ix_1d % local (nrad_local) ) - - - ! Assign values for iy, ix, lat, lon, satzen - this_view % iy_1d % local = iy_1d (1:nrad_local) - this_view % ix_1d % local = ix_1d (1:nrad_local) - deallocate( iy_1d ) - deallocate( ix_1d ) - - call get_abil1b_grid2_1d( yy_1d(1:nrad_local), xx_1d(1:nrad_local), & - req, rpol, pph, nam, satellite_id, & - this_view % lat_1d % local, & - this_view % lon_1d % local, & - this_view % satzen_1d % local, & - earthmask_1d, zenmask_1d ) - - ! Reduce values for iy, ix, lat, lon, satzen using earth and zenith masks - nrad_mask = count ( earthmask_1d .and. zenmask_1d ) - this_view % lat_1d % local(1:nrad_mask) = & - pack(this_view % lat_1d % local , earthmask_1d .and. zenmask_1d ) - this_view % lon_1d % local(1:nrad_mask) = & - pack(this_view % lon_1d % local , earthmask_1d .and. zenmask_1d ) - this_view % satzen_1d % local(1:nrad_mask) = & - pack(this_view % satzen_1d % local , earthmask_1d .and. zenmask_1d ) - this_view % iy_1d % local(1:nrad_mask) = & - pack(this_view % iy_1d % local , earthmask_1d .and. zenmask_1d ) - this_view % ix_1d % local(1:nrad_mask) = & - pack(this_view % ix_1d % local , earthmask_1d .and. zenmask_1d ) - - nrad_local = nrad_mask - - deallocate( earthmask_1d ) - deallocate( zenmask_1d ) - -! icount = 1 -! do n = 1, nrad_local -!!Might save some time by allocating mask arrays, and changing grid2 to a vectorized subroutine -! call get_abil1b_grid2( yy_1d(n), xx_1d(n), req, rpol, pph, nam, satellite_id, & -! this_view % lat_1d % local(icount), & -! this_view % lon_1d % local(icount), & -! this_view % satzen_1d % local(icount), & -! earthmask, zenmask ) + nrad_local = icount - 1 + + deallocate( yy_abi, xx_abi ) + + allocate( earthmask_1d (nrad_local) ) + allocate( zenmask_1d (nrad_local) ) + allocate( this_view % lat_1d % local (nrad_local) ) + allocate( this_view % lon_1d % local (nrad_local) ) + allocate( this_view % satzen_1d % local (nrad_local) ) + allocate( this_view % iy_1d % local (nrad_local) ) + allocate( this_view % ix_1d % local (nrad_local) ) + + ! Assign values for iy, ix, lat, lon, satzen + this_view % iy_1d % local = iy_1d (1:nrad_local) + this_view % ix_1d % local = ix_1d (1:nrad_local) + deallocate( iy_1d ) + deallocate( ix_1d ) + + call get_abil1b_grid2_1d( yy_1d(1:nrad_local), xx_1d(1:nrad_local), & + req, rpol, pph, nam, satellite_id, & + this_view % lat_1d % local, & + this_view % lon_1d % local, & + this_view % satzen_1d % local, & + earthmask_1d, zenmask_1d ) + + ! Reduce values for iy, ix, lat, lon, satzen using earth and zenith masks + nrad_mask = count ( earthmask_1d .and. zenmask_1d ) + this_view % lat_1d % local(1:nrad_mask) = & + pack(this_view % lat_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % lon_1d % local(1:nrad_mask) = & + pack(this_view % lon_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % satzen_1d % local(1:nrad_mask) = & + pack(this_view % satzen_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % iy_1d % local(1:nrad_mask) = & + pack(this_view % iy_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % ix_1d % local(1:nrad_mask) = & + pack(this_view % ix_1d % local , earthmask_1d .and. zenmask_1d ) + + nrad_local = nrad_mask + + deallocate( earthmask_1d ) + deallocate( zenmask_1d ) + deallocate( yy_1d, xx_1d ) + + ! Populate loc x, y and determine in/outside domain + allocate ( this_view % loc_1d % local (nrad_local) ) + allocate ( domainmask_1d (nrad_local) ) + allocate ( dummybool_2d (nrad_local,2) ) + allocate ( info_1d (nrad_local) ) + info_1d (:) % lat = this_view % lat_1d % local ( 1:nrad_local ) + info_1d (:) % lon = this_view % lon_1d % local ( 1:nrad_local ) + call da_llxy_1d ( info_1d, this_view % loc_1d % local(:), & + dummybool_2d(:,1), dummybool_2d(:,2) ) + domainmask_1d = .not.dummybool_2d(:,2) + deallocate( dummybool_2d ) + deallocate( info_1d ) + nrad_mask = count( domainmask_1d ) + + + ! COMMUNICATE 1D FIELDS FROM REMOTE PROCS TO LOCAL BUFFER + ! Note: these comms are a minor bottleneck, which will be + ! more noticeable for 4D-Var when MESO1/2 is processed + ! at multiple fgat's + ! Potential Solutions + ! SOLUTION 1: mpi_allgatherv (let's mpi figure out the most efficient way to distribute the data to all processes) + ! SOLUTION 2: round-robin mpi_bcast (may be less resource intensive with smaller communication chunks) + +! ! BEGIN SOLUTION 1 +!! !PACK UP DOMAIN DATA FROM THIS PROCESSOR +!! this_view % lat_1d % local (1:nrad_mask) = & +!! pack(this_view % lat_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % lon_1d % local (1:nrad_mask) = & +!! pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % satzen_1d % local (1:nrad_mask) = & +!! pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % iy_1d % local (1:nrad_mask) = & +!! pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % ix_1d % local (1:nrad_mask) = & +!! pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % loc_1d % local (1:nrad_mask) % y = & +!! pack(this_view % loc_1d % local (1:nrad_local) % y, domainmask_1d ) +!! this_view % loc_1d % local (1:nrad_mask) % x = & +!! pack(this_view % loc_1d % local (1:nrad_local) % x, domainmask_1d ) +! +! !ALLOCATE COMMUNICATION BUFFERS +! allocate ( nbufs ( num_procs ) ) +! allocate ( displs ( num_procs ) ) +!#ifdef DM_PARALLEL +! call mpi_allgather ( nrad_mask, 1, mpi_integer, nbufs, 1, mpi_integer, comm, ierr ) +!#else +! nbufs = nrad_mask +!#endif ! -! ! Advance counter for locations that pass all mask tests -! if (earthmask .and. zenmask) then -! this_view % iy_1d % local(icount) = & -! this_view % iy_1d % local(n) -! this_view % ix_1d % local(icount) = & -! this_view % ix_1d % local(n) +! displs = 0 +! do iproc = 1, num_procs - 1 +! displs(iproc+1) = displs(iproc) + nbufs(iproc) +! end do ! -! icount = icount + 1 +! this_view % nrad_on_domain = sum( nbufs ) ! -!write(stdout,fmt=*) 'TEST9', n, icount -! end if -! end do +! allocate( buf_real( this_view % nrad_on_domain, 3 ) ) +! allocate( buf_int ( this_view % nrad_on_domain, 2 ) ) +! allocate( buf_loc ( this_view % nrad_on_domain ) ) ! -! nrad_local = icount - 1 - - deallocate( yy_1d, xx_1d ) - -write(stdout,fmt=*) 'TEST10' - - ! Populate loc using model coordinate utility - ! (should be replaced with vectorized version, similar to da_llxy_new) - do n = 1, nrad_local - info % lat = this_view % lat_1d % local(n) ! latitude - info % lon = this_view % lon_1d % local(n) ! longitude - call da_llxy ( info, this_view % loc_1d % local(n,1), & - outside, xy_only = .true. ) - end do - -write(stdout,fmt=*) 'TEST11' - - ! Determine locations within/outside domain and populate loc%x and loc%y - allocate ( domainmask_1d (nrad_local) ) - allocate ( dummybool_2d (nrad_local,2) ) - call da_outside ( this_view % loc_1d % local(1:nrad_local,1:1), & - dummybool_2d(:,1:1), dummybool_2d(:,2:2) ) - domainmask_1d = .not.dummybool_2d(:,2) - deallocate( dummybool_2d ) - nrad_mask = count( domainmask_1d ) - -write(stdout,fmt=*) 'TEST12' - - !ALLOCATE COMMUNICATION BUFFERS - call mpi_allreduce( nrad_mask, nbuf, 1, mpi_integer, mpi_sum, comm, ierr ) - allocate( buf_real( nbuf, 3 ) ) - allocate( buf_int ( nbuf, 2 ) ) - allocate( buf_loc ( nbuf, 1 ) ) +! buf_real = missing_r +! buf_int = missing +! buf_loc%y = missing_r +! buf_loc%x = missing_r +! +! !PACK UP DOMAIN DATA FROM THIS PROCESSOR +! buf_i = displs(iproc+1) + 1 +! buf_f = buf_i + nrad_mask - 1 +! buf_real( buf_i:buf_f, 1 ) = & +! pack(this_view % lat_1d % local (1:nrad_local), domainmask_1d ) +! buf_real( buf_i:buf_f, 2 ) = & +! pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) +! buf_real( buf_i:buf_f, 3 ) = & +! pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) +! buf_int ( buf_i:buf_f, 1 ) = & +! pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) +! buf_int ( buf_i:buf_f, 2 ) = & +! pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) +! buf_loc ( buf_i:buf_f ) % y = & +! pack(this_view % loc_1d % local (1:nrad_local) % y, domainmask_1d ) +! buf_loc ( buf_i:buf_f ) % x = & +! pack(this_view % loc_1d % local (1:nrad_local) % x, domainmask_1d ) +! +!#ifdef DM_PARALLEL +! !PERFORM COMMS +! +! ! NOTE: MPI_IN_PLACE can only be used when comm is an intracommunicator +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,1), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,2), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,3), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, mpi_integer, buf_int(:,1), nbufs, displs, mpi_integer, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, mpi_integer, buf_int(:,2), nbufs, displs, mpi_integer, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_loc(:)%y, nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_loc(:)%x, nbufs, displs, true_mpi_real, comm, ierr ) +! +!! call mpi_allgatherv ( & +!! this_view % lat_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,1), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % lon_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,2), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % satzen_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,3), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % iy_1d % local (1:nrad_mask), nrad_mask, mpi_integer, & +!! buf_int(:,1), nbufs, displs, mpi_integer, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % ix_1d % local (1:nrad_mask), nrad_mask, mpi_integer, & +!! buf_int(:,2), nbufs, displs, mpi_integer, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % loc_1d % local (1:nrad_mask) % y, nrad_mask, true_mpi_real, & +!! buf_loc(:)%y, nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % loc_1d % local (1:nrad_mask) % x, nrad_mask, true_mpi_real, & +!! buf_loc(:)%x, nbufs, displs, true_mpi_real, comm, ierr ) +!!#else +!! buf_real( :, 1 ) = this_view % lat_1d % local (1:nrad_mask) +!! buf_real( :, 2 ) = this_view % lon_1d % local (1:nrad_mask) +!! buf_real( :, 3 ) = this_view % satzen_1d % local (1:nrad_mask) +!! buf_int ( :, 1 ) = this_view % iy_1d % local (1:nrad_mask) +!! buf_int ( :, 2 ) = this_view % ix_1d % local (1:nrad_mask) +!! buf_loc ( : ) % y = this_view % loc_1d % local (1:nrad_mask) % y +!! buf_loc ( : ) % x = this_view % loc_1d % local (1:nrad_mask) % x +!#endif +! deallocate ( nbufs, displs ) +! ! END SOLUTION 1 - this_view % nrad_on_domain = nbuf + ! BEGIN SOLUTION 2 + !ALLOCATE COMMUNICATION BUFFERS + call mpi_allreduce( nrad_mask, nbuf, 1, mpi_integer, mpi_sum, comm, ierr ) + allocate( buf_real( nbuf, 3 ) ) + allocate( buf_int ( nbuf, 2 ) ) + allocate( buf_loc ( nbuf ) ) + this_view % nrad_on_domain = nbuf - ! COMMUNICATE 1D FIELDS FROM REMOTE PROCS TO LOCAL BUFFER - buf_f = 0 - ProcLoop: do iproc = 0, num_procs-1 - nbuf = nrad_mask + buf_f = 0 + ProcLoop: do iproc = 0, num_procs-1 + nbuf = nrad_mask #ifdef DM_PARALLEL - call mpi_bcast(nbuf, 1, mpi_integer, iproc, comm, ierr ) + call mpi_bcast(nbuf, 1, mpi_integer, iproc, comm, ierr ) #endif - if (nbuf .eq. 0) cycle - buf_i = buf_f + 1 - buf_f = buf_i + nbuf - 1 - - if (iproc .eq. myproc) then - buf_real( buf_i:buf_f, 1 ) = & - pack(this_view % lat_1d % local (1:nrad_local), domainmask_1d ) - buf_real( buf_i:buf_f, 2 ) = & - pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) - buf_real( buf_i:buf_f, 3 ) = & - pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) - buf_int ( buf_i:buf_f, 1 ) = & - pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) - buf_int ( buf_i:buf_f, 2 ) = & - pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) - buf_loc ( buf_i:buf_f, 1 ) = & - pack(this_view % loc_1d % local (1:nrad_local,1), domainmask_1d ) - else - buf_real(buf_i:buf_f,:) = missing_r - buf_int(buf_i:buf_f,:) = missing - buf_loc(buf_i:buf_f,:)%y = missing_r - buf_loc(buf_i:buf_f,:)%x = missing_r - end if + if (nbuf .eq. 0) cycle + buf_i = buf_f + 1 + buf_f = buf_i + nbuf - 1 + + if (iproc .eq. myproc) then + !PACK UP DATA FROM THIS PROCESSOR + buf_real( buf_i:buf_f, 1 ) = & + pack(this_view % lat_1d % local (1:nrad_local), domainmask_1d ) + buf_real( buf_i:buf_f, 2 ) = & + pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) + buf_real( buf_i:buf_f, 3 ) = & + pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) + buf_int ( buf_i:buf_f, 1 ) = & + pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) + buf_int ( buf_i:buf_f, 2 ) = & + pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) + buf_loc ( buf_i:buf_f ) % y = & + pack(this_view % loc_1d % local (1:nrad_local) % y, domainmask_1d ) + buf_loc ( buf_i:buf_f ) % x = & + pack(this_view % loc_1d % local (1:nrad_local) % x, domainmask_1d ) + else + buf_real(buf_i:buf_f,:) = missing_r + buf_int(buf_i:buf_f,:) = missing + buf_loc(buf_i:buf_f)%y = missing_r + buf_loc(buf_i:buf_f)%x = missing_r + end if #ifdef DM_PARALLEL - call mpi_bcast(buf_real(buf_i:buf_f,:), nbuf * 3, true_mpi_real, iproc, comm, ierr ) - call mpi_bcast(buf_int (buf_i:buf_f,:), nbuf * 2, mpi_integer, iproc, comm, ierr ) + !PERFORM COMMS + call mpi_bcast(buf_real(buf_i:buf_f,:), nbuf * 3, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast(buf_int (buf_i:buf_f,:), nbuf * 2, mpi_integer, iproc, comm, ierr ) - !Only x & y components of loc need to be communicated - call mpi_bcast( buf_loc(buf_i:buf_f,1)%y, nbuf, true_mpi_real, iproc, comm, ierr ) - call mpi_bcast( buf_loc(buf_i:buf_f,1)%x, nbuf, true_mpi_real, iproc, comm, ierr ) + !Only x & y components of loc need to be communicated + call mpi_bcast( buf_loc(buf_i:buf_f)%y, nbuf, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast( buf_loc(buf_i:buf_f)%x, nbuf, true_mpi_real, iproc, comm, ierr ) #endif - end do ProcLoop - - deallocate ( this_view % lat_1d % local ) - deallocate ( this_view % lon_1d % local ) - deallocate ( this_view % satzen_1d % local ) - deallocate ( this_view % iy_1d % local ) - deallocate ( this_view % ix_1d % local ) - deallocate ( this_view % loc_1d % local ) - deallocate(domainmask_1d) - - ! ASSOCIATE REMOTE POINTERS WITH BUFFERS CONTAINING DOMAIN-WIDE OBS - this_view % lat_1d % global => buf_real(:,1) - this_view % lon_1d % global => buf_real(:,2) - this_view % satzen_1d % global => buf_real(:,3) - this_view % iy_1d % global => buf_int (:,1) - this_view % ix_1d % global => buf_int (:,2) - this_view % loc_1d % global => buf_loc (:,1) - -write(stdout,fmt=*) 'TEST13', this_view % nrad_on_domain - - ! Determine locations within/outside patch and populate remainder of buf_loc - allocate ( patchmask_1d (this_view % nrad_on_domain) ) - allocate ( dummybool_2d (this_view % nrad_on_domain,1) ) - call da_outside ( buf_loc, dummybool_2d(:,1:1) ) - patchmask_1d = .not.dummybool_2d(:,1) - deallocate(dummybool_2d) - this_view % nrad_on_patch = count(patchmask_1d) - -write(stdout,fmt=*) 'TEST15', this_view % nrad_on_patch - - if ( this_view % nrad_on_patch .gt. 0 ) then - allocate( this_view % lat_1d % patch (this_view % nrad_on_patch) ) - allocate( this_view % lon_1d % patch (this_view % nrad_on_patch) ) - allocate( this_view % satzen_1d % patch (this_view % nrad_on_patch) ) - allocate( this_view % iy_1d % patch (this_view % nrad_on_patch) ) - allocate( this_view % ix_1d % patch (this_view % nrad_on_patch) ) - allocate( this_view % loc_1d % patch (this_view % nrad_on_patch) ) - - this_view % lat_1d % patch = & - pack( this_view % lat_1d % global, patchmask_1d ) - this_view % lon_1d % patch = & - pack( this_view % lon_1d % global, patchmask_1d ) - this_view % satzen_1d % patch = & - pack( this_view % satzen_1d % global, patchmask_1d ) - this_view % iy_1d % patch = & - pack( this_view % iy_1d % global, patchmask_1d ) - this_view % ix_1d % patch = & - pack( this_view % ix_1d % global, patchmask_1d ) - this_view % loc_1d % patch = & - pack( this_view % loc_1d % global, patchmask_1d ) + end do ProcLoop + ! END SOLUTION 2 + + deallocate ( this_view % lat_1d % local ) + deallocate ( this_view % lon_1d % local ) + deallocate ( this_view % satzen_1d % local ) + deallocate ( this_view % iy_1d % local ) + deallocate ( this_view % ix_1d % local ) + deallocate ( this_view % loc_1d % local ) + deallocate ( domainmask_1d ) + + ! ASSOCIATE REMOTE POINTERS WITH BUFFERS CONTAINING DOMAIN-WIDE OBS + this_view % lat_1d % domain => buf_real(:,1) + this_view % lon_1d % domain => buf_real(:,2) + this_view % satzen_1d % domain => buf_real(:,3) + this_view % iy_1d % domain => buf_int (:,1) + this_view % ix_1d % domain => buf_int (:,2) + this_view % loc_1d % domain => buf_loc (:) + +write(stdout,fmt=*) 'Total locations within domain: ', this_view % nrad_on_domain + + ! Populate remainder of loc and determine in/outside patch + allocate ( patchmask_1d (this_view % nrad_on_domain) ) + allocate ( dummybool_2d (this_view % nrad_on_domain,1) ) +! patchmask_1d = .false. + call da_llxy_1d ( locs = buf_loc, outside = dummybool_2d(:,1), do_xy = .false. ) + patchmask_1d = .not.dummybool_2d(:,1) + deallocate( dummybool_2d ) + this_view % nrad_on_patch = count(patchmask_1d) + +write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_on_patch + + if ( this_view % nrad_on_patch .gt. 0 ) then + if ( allocated ( this_view % patchmask ) ) then + deallocate ( this_view % patchmask ) + deallocate ( this_view % lat_1d % patch ) + deallocate ( this_view % lon_1d % patch ) + deallocate ( this_view % satzen_1d % patch ) + deallocate ( this_view % iy_1d % patch ) + deallocate ( this_view % ix_1d % patch ) + deallocate ( this_view % loc_1d % patch ) end if + allocate( this_view % lat_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % lon_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % satzen_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % iy_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % ix_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % loc_1d % patch (this_view % nrad_on_patch) ) + + this_view % lat_1d % patch = & + pack( this_view % lat_1d % domain, patchmask_1d ) + this_view % lon_1d % patch = & + pack( this_view % lon_1d % domain, patchmask_1d ) + this_view % satzen_1d % patch = & + pack( this_view % satzen_1d % domain, patchmask_1d ) + this_view % iy_1d % patch = & + pack( this_view % iy_1d % domain, patchmask_1d ) + this_view % ix_1d % patch = & + pack( this_view % ix_1d % domain, patchmask_1d ) + this_view % loc_1d % patch = & + pack( this_view % loc_1d % domain, patchmask_1d ) + + ! Determine ys, ye, xs, xe for this patch and for Full Disk offset grid + this_view % ys_p = minval(this_view % iy_1d % patch) + this_view % ye_p = maxval(this_view % iy_1d % patch) + this_view % xs_p = minval(this_view % ix_1d % patch) + this_view % xe_p = maxval(this_view % ix_1d % patch) + this_view % ys_p_fd = this_view % ys_p + this_view % yoff_fd - 1 + this_view % ye_p_fd = this_view % ye_p + this_view % yoff_fd - 1 + this_view % xs_p_fd = this_view % xs_p + this_view % xoff_fd - 1 + this_view % xe_p_fd = this_view % xe_p + this_view % xoff_fd - 1 + + ! Setup patch mask for this view + allocate(this_view % patchmask( & + this_view % ys_p:this_view % ye_p, & + this_view % xs_p:this_view % xe_p )) + + this_view % patchmask = .false. + do n = 1, this_view % nrad_on_patch + this_view % patchmask ( this_view % iy_1d % patch (n) & + , this_view % ix_1d % patch (n) & + ) = .true. + end do + end if - !FREE UP POINTERS AND BUFFERS - nullify ( this_view % lat_1d % global ) - nullify ( this_view % lon_1d % global ) - nullify ( this_view % satzen_1d % global ) - nullify ( this_view % iy_1d % global ) - nullify ( this_view % ix_1d % global ) - nullify ( this_view % loc_1d % global ) - deallocate ( buf_real, buf_int, buf_loc ) - deallocate ( patchmask_1d ) - -write(stdout,fmt=*) 'TEST16', this_view % nrad_on_patch - + !FREE UP POINTERS AND BUFFERS + nullify ( this_view % lat_1d % domain ) + nullify ( this_view % lon_1d % domain ) + nullify ( this_view % satzen_1d % domain ) + nullify ( this_view % iy_1d % domain ) + nullify ( this_view % ix_1d % domain ) + nullify ( this_view % loc_1d % domain ) + deallocate ( buf_real, buf_int, buf_loc ) + deallocate ( patchmask_1d ) #ifdef DM_PARALLEL - call mpi_barrier(comm, ierr) + call mpi_barrier(comm, ierr) #endif + end if DoGridGen - ! Determine patch extents, initialize patchmask - if ( this_view % nrad_on_patch.gt.0 ) then - - ! Determine ys, ye, xs, xe for this patch and for Full Disk offset grid - this_view % ys_p = minval(this_view % iy_1d % patch) - this_view % ye_p = maxval(this_view % iy_1d % patch) - this_view % xs_p = minval(this_view % ix_1d % patch) - this_view % xe_p = maxval(this_view % ix_1d % patch) - this_view % ys_p_fd = this_view % ys_p + this_view % yoff_fd - 1 - this_view % ye_p_fd = this_view % ye_p + this_view % yoff_fd - 1 - this_view % xs_p_fd = this_view % xs_p + this_view % xoff_fd - 1 - this_view % xe_p_fd = this_view % xe_p + this_view % xoff_fd - 1 - -write(stdout,fmt=*) 'TEST17', this_view % ys_p, this_view % ye_p -write(stdout,fmt=*) 'TEST18', this_view % ys_p_fd, this_view % ye_p_fd -write(stdout,fmt=*) 'TEST19', view_att(1) % ys_p, view_att(1) % ye_p - -write(stdout,fmt=*) 'TEST21', this_view % xs_p, this_view % xe_p -write(stdout,fmt=*) 'TEST22', this_view % xs_p_fd, this_view % xe_p_fd -write(stdout,fmt=*) 'TEST23', view_att(1) % xs_p, view_att(1) % xe_p - -write(stdout,fmt=*) 'TEST25', this_view % yoff_fd, this_view % xoff_fd -write(stdout,fmt=*) 'TEST26', view_att(1) % yoff_fd, view_att(1) % xoff_fd - -write(stdout,fmt=*) 'TEST27', this_view % ny_global, this_view % nx_global -write(stdout,fmt=*) 'TEST28', view_att(1) % ny_global, view_att(1) % nx_global - - - ! Setup patch mask for this view - allocate(this_view % patchmask( & - this_view % ys_p-1:this_view % ye_p+1, & - this_view % xs_p-1:this_view % xe_p+1 )) - - this_view % patchmask = .false. - do n = 1, this_view % nrad_on_patch - this_view % patchmask ( this_view % iy_1d % patch (n) & - , this_view % ix_1d % patch (n) & - ) = .true. - end do - end if - - end if - -write(stdout,fmt=*) 'TEST29' - - end if + num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain + ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain PatchMatch: if (this_view % nrad_on_patch .gt. 0) then -write(stdout,fmt=*) 'TEST30' - if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view % nfiles_used(:)).eq.0 ) then allocate(view_mask(& - this_view % ys_p_fd-1:this_view % ye_p_fd+1, & - this_view % xs_p_fd-1:this_view % xe_p_fd+1, & + this_view % ys_p_fd-2:this_view % ye_p_fd+2, & + this_view % xs_p_fd-2:this_view % xe_p_fd+2, & nviews, nchan, num_fgat_time)) view_mask = .false. use_view_mask = .true. - -write(stdout,fmt=*) size(view_mask) -write(stdout,fmt=*) sizeof(view_mask) end if -write(stdout,fmt=*) 'TEST31' - - ! Loop over channels - ! This loop over channels could be parallelized, if needed for time savings + ! Loop over channels; each process reads radiance data only for its subdomain ChannelLoop: do ichan = 1, nchan - -write(stdout,fmt=*) 'TEST32', ichan, ifgat - ifile = 0 do jfile = 1, this_view % nfiles if ( .not. this_view % file_fgat_match(jfile,ifgat) ) cycle @@ -1013,15 +1041,15 @@ write(stdout,fmt=*) 'TEST32', ichan, ifgat end do !OLD CODE -! view_mask(this_view % ys_p_fd-1:this_view % ye_p_fd+1, & -! this_view % ys_p_fd-1:this_view % ye_p_fd+1, & +! view_mask(this_view % ys_p_fd:this_view % ye_p_fd, & +! this_view % ys_p_fd:this_view % ye_p_fd, & ! iview, ichan, ifgat) = .true. ! !! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations !! do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap ! -! view_mask(this_view % ys_p_fd-1:this_view % ye_p_fd+1, & -! this_view % ys_p_fd-1:this_view % ye_p_fd+1, & +! view_mask(this_view % ys_p_fd:this_view % ye_p_fd, & +! this_view % ys_p_fd:this_view % ye_p_fd, & ! iview, ichan, ifgat) = .false. ! end do end if @@ -1042,16 +1070,16 @@ write(stdout,fmt=*) 'TEST32', ichan, ifgat !! + thinning allocate(allmask_p( & - this_view % ys_p-1:this_view % ye_p+1, & - this_view % xs_p-1:this_view % xe_p+1 )) + this_view % ys_p:this_view % ye_p, & + this_view % xs_p:this_view % xe_p )) allmask_p = this_view % patchmask ! Only use locations where this view is nearest to this fgat time ! - only available when FD data present for any fgat time if ( use_view_mask ) then - if ( count( view_mask ( this_view % ys_p_fd-1:this_view % ye_p_fd+1, & - this_view % xs_p_fd-1:this_view % xe_p_fd+1, & + if ( count( view_mask ( this_view % ys_p_fd:this_view % ye_p_fd, & + this_view % xs_p_fd:this_view % xe_p_fd, & iview, ichan, ifgat ) ) .eq. 0 ) then deallocate(allmask_p) cycle @@ -1074,15 +1102,14 @@ write(stdout,fmt=*) 'TEST32', ichan, ifgat !! + fgat !! + channel/band !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - write(unit=stdout,fmt='(2A)') & - ' Reading abi radiances: ',trim(fname_short) + write(unit=stdout,fmt='(A,I4)') & + ' Reading abi radiances for band ',ichan ! Allocate this patch bt allocate( bt_p ( this_view % ys_p:this_view % ye_p, & this_view % xs_p:this_view % xe_p ) ) - ! This reads in bt only for the local patch, - ! reduces read time, but would mess up global count below + ! This reads in bt only for the local patch call get_abil1b_bt( fname, & this_view % ys_p, this_view % ye_p, & this_view % xs_p, this_view % xe_p, & @@ -1101,8 +1128,6 @@ write(stdout,fmt=*) 'TEST32', ichan, ifgat hr = this_view % filedate(ifile) % hr mn = this_view % filedate(ifile) % mn sc = this_view % filedate(ifile) % sc - num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain - ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain allocate(thinmask(this_view % ys_p:this_view % ye_p, & this_view % xs_p:this_view % xe_p)) @@ -1198,28 +1223,21 @@ write(stdout,fmt=*) 'TEST32', ichan, ifgat #endif end do ! end fgat loop - if (this_view % moving .or. ipass.eq.npass) then - ! Deallocate static data - if (allocated(this_view % patchmask)) deallocate(this_view % patchmask) - + if ( (this_view % moving .or. ipass.eq.npass) .and. this_view%nrad_on_patch.gt.0 ) then + ! Deallocate location info + deallocate ( this_view % patchmask ) deallocate ( this_view % lat_1d % patch ) deallocate ( this_view % lon_1d % patch ) deallocate ( this_view % satzen_1d % patch ) deallocate ( this_view % iy_1d % patch ) deallocate ( this_view % ix_1d % patch ) deallocate ( this_view % loc_1d % patch ) - deallocate ( this_view % patchmask ) end if tot_files_used = tot_files_used + sum(view_att(iview) % nfiles_used) end do ! end view loop - if (tot_files_used .lt. 1) then - write(unit=message(1),fmt='(A,I2,2A)') "Either No L1B data found or non matching fgat windows for GOES-",satellite_id," using prefix ",INST_PREFIX - call da_warning(__FILE__,__LINE__, message(1:1)) - return - end if end do ! end pass loop if (allocated(view_mask)) deallocate(view_mask) @@ -1241,6 +1259,20 @@ write(stdout,fmt=*) 'TEST32', ichan, ifgat end do deallocate(view_att) + if (tot_files_used .lt. 1) then +!! write(unit=message(1),fmt='(A,I2,3A)') "Either no L1B data found or no matching fgat windows for GOES-",satellite_id," ABI using prefix ",INST_PREFIX, "for this process rank. This subdomain may have an unacceptable zenith angle or fall entirely outside the GOES viewing extent." + write(unit=message(1),fmt=*) "Either no L1B data found or no matching fgat windows for GOES-",satellite_id," ABI using prefix ",INST_PREFIX, "for this process rank. This subdomain may have an unacceptable zenith angle or fall entirely outside the GOES viewing extent." + +! write(unit=message(1),fmt='(A)') "Either no L1B data found or no matching" +! write(unit=message(2),fmt='(A,I2,A)') "fgat windows for GOES-",satellite_id," ABI using" +! write(unit=message(3),fmt='(3A)') "prefix ",INST_PREFIX, "for this process rank." +! write(unit=message(4),fmt='(A)') "This subdomain may have an unacceptable zenith " +! write(unit=message(5),fmt='(A)') "angle or fall entirely outside the GOES viewing" +! write(unit=message(6),fmt='(A)') "extent." + + call da_warning(__FILE__,__LINE__, message(1:1)) + end if + !------------------------------------------------------ ! NOTE: Remainder of this subroutine copied from da_read_obs_ncgoesimg.inc @@ -1646,7 +1678,7 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt ) real, intent(out) :: bt( ys:ye, xs:xe ) real :: rad(ys:ye, xs:xe) - integer(kind=1) :: DQF(ys:ye, xs:xe) + integer :: DQF(ys:ye, xs:xe) integer :: ierr, ncid, varid integer :: iy, ix integer :: nykeep, nxkeep @@ -1656,50 +1688,61 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt ) if (trace_use) call da_trace_entry("get_abil1b_bt") bt = missing_r + rad = missing_r !! Save rad reading time by selecting a subset of netcdf var nykeep = ye - ys + 1 nxkeep = xe - xs + 1 - if (nykeep.gt.0 .and. nxkeep.gt.0) then - ierr=nf_open(trim(filename),nf_nowrite,ncid) - call handle_err('Error opening file',ierr) - - ierr=nf_inq_varid(ncid,'Rad',varid) - ierr=nf_get_vara_double ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), & - rad(ys:ye,xs:xe) ) - - ierr=nf_inq_varid(ncid,'DQF',varid) - ierr=nf_get_vara_int1 ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), & - DQF(ys:ye,xs:xe) ) - else + if (nykeep.le.0 .or. nxkeep.le.0) then + radmask = .false. return end if + ierr=nf_open(trim(filename),nf_nowrite,ncid) + + call handle_err('Error opening file',ierr) + + ierr=nf_inq_varid( ncid, 'Rad', varid ) + ierr=nf_get_vara_double ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), rad ) +! rad(ys:ye,xs:xe) ) ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) ierr=nf_get_att_double(ncid,varid,'add_offset',itp) rad=rad*slp+itp - ierr=nf_inq_varid(ncid,'planck_bc1',varid) - ierr=nf_get_var_double(ncid,varid,bc1) - ierr=nf_inq_varid(ncid,'planck_bc2',varid) - ierr=nf_get_var_double(ncid,varid,bc2) - ierr=nf_inq_varid(ncid,'planck_fk1',varid) - ierr=nf_get_var_double(ncid,varid,fk1) - ierr=nf_inq_varid(ncid,'planck_fk2',varid) - ierr=nf_get_var_double(ncid,varid,fk2) - - do ix=xs, xe - do iy=ys, ye - if ( radmask( iy, ix ) ) then - if( rad( iy, ix ).ge.0.0 .and. any(DQF( iy, ix ).eq.(/0,1/)) ) then - bt( iy, ix )=(fk2/(alog((fk1/rad( iy, ix ))+1.))-bc1)/bc2 - else - radmask( iy, ix ) = .true. - end if - end if - end do - end do + ierr=nf_inq_varid ( ncid, 'DQF', varid ) + ierr=nf_get_vara_int ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), DQF ) +! DQF(ys:ye,xs:xe) ) + + ierr=nf_inq_varid( ncid, 'planck_bc1', varid ) + ierr=nf_get_var_double( ncid, varid, bc1 ) + ierr=nf_inq_varid( ncid, 'planck_bc2', varid ) + ierr=nf_get_var_double( ncid, varid, bc2 ) + ierr=nf_inq_varid( ncid, 'planck_fk1', varid ) + ierr=nf_get_var_double( ncid, varid, fk1 ) + ierr=nf_inq_varid( ncid, 'planck_fk2', varid ) + ierr=nf_get_var_double( ncid, varid, fk2 ) + +! radmask = ( radmask .and. (DQF.eq.0 .or. DQF.eq.1) .and. rad.ge.0.0 ) + + radmask = ( radmask .and. (DQF.eq.0 .or. DQF.eq.1) ) + radmask = ( radmask .and. rad.ge.0.0 ) + + where ( radmask ) + bt = ( fk2 / ( alog(( fk1 / rad ) + 1.0) ) - bc1 ) / bc2 + end where + +! do ix = xs, xe +! do iy = ys, ye +! if ( radmask( iy, ix ) ) then +! if( rad( iy, ix ).ge.0.0 .and. any(DQF( iy, ix ).eq.(/0,1/)) ) then +! bt( iy, ix ) = ( fk2 / ( alog( ( fk1 / rad( iy, ix )) + 1. ) ) - bc1 ) / bc2 +! else +! radmask( iy, ix ) = .false. +! end if +! end if +! end do +! end do !#ifdef DM_PARALLEL ! call mpi_barrier(comm, ierr) diff --git a/var/da/da_tools/da_llxy.inc b/var/da/da_tools/da_llxy.inc index 2784b72eee..6519ec74c8 100644 --- a/var/da/da_tools/da_llxy.inc +++ b/var/da/da_tools/da_llxy.inc @@ -1,4 +1,4 @@ -subroutine da_llxy (info, loc, outside, outside_all, xy_only) +subroutine da_llxy (info, loc, outside, outside_all) !----------------------------------------------------------------------- ! Purpose: TBD @@ -14,14 +14,11 @@ subroutine da_llxy (info, loc, outside, outside_all, xy_only) type(model_loc_type), intent(inout) :: loc logical , intent(out) :: outside !wrt local domain logical, optional, intent(out) :: outside_all !wrt all domains - logical, optional, intent(in) :: xy_only ! too many return statments to trace ! if (trace_use_frequent) call da_trace_entry("da_llxy") - outside = .false. - loc % x = -1.0 loc % y = -1.0 @@ -37,8 +34,6 @@ subroutine da_llxy (info, loc, outside, outside_all, xy_only) call da_llxy_default (info%lat, info%lon, loc%x, loc%y) end if - if ( xy_only ) return - #ifdef A2C call da_togrid (loc%x, its-3, ite+3, loc%i, loc%dx, loc%dxm)! diff --git a/var/da/da_tools/da_llxy_1d.inc b/var/da/da_tools/da_llxy_1d.inc new file mode 100644 index 0000000000..06f42d115d --- /dev/null +++ b/var/da/da_tools/da_llxy_1d.inc @@ -0,0 +1,115 @@ +subroutine da_llxy_1d ( infos, locs, outside, outside_all, do_xy, do_outside) + + !----------------------------------------------------------------------- + ! Purpose: TBD + ! Updated for Analysis on Arakawa-C grid + ! Author: Syed RH Rizvi, MMM/ESSL/NCAR, Date: 10/22/2008 + !----------------------------------------------------------------------- + + ! This routine converts (lat, lon) into (x,y) coordinates + + implicit none + + type(info_type), optional, intent(in) :: infos(:) + type(model_loc_type), intent(inout) :: locs(:) + logical , intent(out) :: outside(:) !wrt local domain + logical, optional, intent(out) :: outside_all(:) !wrt all domains + logical, optional, intent(in) :: do_xy, do_outside + logical :: do_xy_, do_outside_ + + if (trace_use) call da_trace_entry("da_llxy_1d") + + outside = .false. + + do_xy_ = .true. + if ( present(do_xy) ) do_xy_ = do_xy + if ( do_xy_ ) then + if (present(infos)) then + locs(:) % x = -1.0 + locs(:) % y = -1.0 + + ! get the (x, y) coordinates + if ( fg_format == fg_format_wrf_arw_regional ) then + call da_llxy_wrf_1d(map_info, infos(:)%lat, infos(:)%lon, locs(:)%x, locs(:)%y) + else if (fg_format == fg_format_wrf_nmm_regional) then + call da_llxy_rotated_latlon_1d(infos(:)%lat, infos(:)%lon, map_info, locs(:)%x, locs(:)%y) + else if (global) then + call da_llxy_global_1d (infos(:)%lat, infos(:)%lon, locs(:)%x, locs(:)%y) + else + call da_llxy_default_1d (infos(:)%lat, infos(:)%lon, locs(:)%x, locs(:)%y) + end if + else + message(1)='da_llxy_1d requires infos in order to determine x & y' + call da_error(__FILE__,__LINE__,message(1:1)) + end if + end if + +#ifdef A2C + call da_togrid_1d (locs(:)%x, its-3, ite+3, locs(:)%i, locs(:)%dx, locs(:)%dxm)! + + call da_togrid_1d (locs(:)%y, jts-3, jte+3, locs(:)%j, locs(:)%dy, locs(:)%dym) +#else + call da_togrid_1d (locs(:)%x, its-2, ite+2, locs(:)%i, locs(:)%dx, locs(:)%dxm)! + + call da_togrid_1d (locs(:)%y, jts-2, jte+2, locs(:)%j, locs(:)%dy, locs(:)%dym) +#endif + +! do_outside_ = .true. +! if ( present(do_outside) ) do_outside_ = do_outside +! if ( .not.do_outside_ ) return + + ! refactor to remove this ugly duplication later + if (present(outside_all)) then + outside_all(:) = .false. + ! Do not check for global options + if (.not. global) then + outside_all = outside_all .or. & + (int(locs(:)%x) < ids) .or. (int(locs(:)%x) >= ide) .or. & + (int(locs(:)%y) < jds) .or. (int(locs(:)%y) >= jde) + outside = outside .or. outside_all + if (def_sub_domain) then + outside_all = outside_all .or. & + x_start_sub_domain > locs(:)%x .or. y_start_sub_domain > locs(:)%y .or. & + x_end_sub_domain < locs(:)%x .or. y_end_sub_domain < locs(:)%y + outside = outside .or. outside_all + end if + end if + end if + + if (fg_format == fg_format_kma_global) then + outside = outside .or. & + (locs(:)%j < jts-1) .or. (locs(:)%j > jte) + + where (locs(:)%j == jde) + locs%j = locs%j - 1 + locs%dy = 1.0 + locs%dym = 0.0 + end where + + return + end if + + ! Check for edge of domain: + outside = outside .or. & + (locs(:)%i < ids) .or. (locs(:)%i >= ide) .or. & + (locs(:)%j < jds) .or. (locs(:)%j >= jde) + + ! FIX? hack + outside = outside .or. & +#ifdef A2C + (locs(:)%i < its-2) .or. (locs(:)%i > ite) .or. & + (locs(:)%j < jts-2) .or. (locs(:)%j > jte) +#else + (locs(:)%i < its-1) .or. (locs(:)%i > ite) .or. & + (locs(:)%j < jts-1) .or. (locs(:)%j > jte) +#endif + + if (def_sub_domain) then + outside = outside .or. & + x_start_sub_domain > locs(:)%x .or. y_start_sub_domain > locs(:)%y .or. & + x_end_sub_domain < locs(:)%x .or. y_end_sub_domain < locs(:)%y + end if + + if (trace_use) call da_trace_exit("da_llxy_1d") + +end subroutine da_llxy_1d diff --git a/var/da/da_tools/da_llxy_default_1d.inc b/var/da/da_tools/da_llxy_default_1d.inc new file mode 100644 index 0000000000..011a9d8b74 --- /dev/null +++ b/var/da/da_tools/da_llxy_default_1d.inc @@ -0,0 +1,114 @@ +subroutine da_llxy_default_1d (xlati,xloni,x,y) + + !---------------------------------------------------------------------------- + ! Purpose: calculates the (x,y) location (dot) in the mesoscale grids + ! ------- from latitudes and longitudes + ! + ! for global domain co-ordinates + ! + ! input: + ! ----- + ! xlat: latitudes + ! xlon: longitudes + ! + ! output: + ! ----- + ! x: the coordinate in x (i)-direction. + ! y: the coordinate in y (j)-direction. + ! + !---------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: xlati(:), xloni(:) + real, intent(out) :: x(:), y(:) + + real, allocatable :: dxlon(:) + real, allocatable :: xlat(:), xlon(:) + real, allocatable :: xx(:), yy(:), cell(:), psx(:), r(:), flp(:) + real :: xc, yc + real :: psi0 + real :: centri, centrj + real :: ratio + real :: bb + real, parameter :: conv = 180.0 / pi + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_default_1d") + + n = size(xlati) + allocate ( dxlon(n), xlat(n), xlon(n), xx(n), yy(n), cell(n), psx(n), r(n), flp(n) ) + + xlon = xloni + xlat = xlati + + where (xlat .lt. -89.95) xlat = -89.95 + where (xlat .gt. +89.95) xlat = +89.95 + + dxlon = xlon - xlonc + where (dxlon > 180) dxlon = dxlon - 360.0 + where (dxlon < -180) dxlon = dxlon + 360.0 + + if (map_projection == 3) then + xc = 0.0 + yc = YCNTR + + cell = cos(xlat/conv)/(1.0+sin(xlat/conv)) + yy = -c2*alog(cell) + xx = c2*dxlon/conv + else + psi0 = (pole - phic)/conv + xc = 0.0 + + ! calculate x,y coords. relative to pole + + flp = cone_factor*dxlon/conv + + psx = (pole - xlat)/conv + + if (map_projection == 2) then + ! Polar stereographics: + bb = 2.0*(cos(psi1/2.0)**2) + yc = -earth_radius*bb*tan(psi0/2.0) + r = -earth_radius*bb*tan(psx/2.0) + else + ! Lambert conformal: + bb = -earth_radius/cone_factor*sin(psi1) + yc = bb*(tan(psi0/2.0)/tan(psi1/2.0))**cone_factor + r = bb*(tan(psx /2.0)/tan(psi1/2.0))**cone_factor + end if + + if (phic < 0.0) then + xx = r*sin(flp) + yy = r*cos(flp) + else + xx = -r*sin(flp) + yy = r*cos(flp) + end if + end if + + ! transform (1,1) to the origin + ! the location of the center in the coarse domain + + centri = real (coarse_ix + 1)/2.0 + centrj = real (coarse_jy + 1)/2.0 + + ! the (x,y) coordinates in the coarse domain + + x = (xx - xc)/coarse_ds + centri + y = (yy - yc)/coarse_ds + centrj + + ratio = coarse_ds / dsm + + ! only add 0.5 so that x/y is relative to first cross points: + + x = (x - start_x) * ratio + 0.5 + y = (y - start_y) * ratio + 0.5 + + deallocate ( dxlon, xlat, xlon, xx, yy, cell, psx, r, flp ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_default_1d") + +end subroutine da_llxy_default_1d + + diff --git a/var/da/da_tools/da_llxy_global_1d.inc b/var/da/da_tools/da_llxy_global_1d.inc new file mode 100644 index 0000000000..9565be5cf5 --- /dev/null +++ b/var/da/da_tools/da_llxy_global_1d.inc @@ -0,0 +1,35 @@ +subroutine da_llxy_global_1d(lat,lon,x,y) + + !---------------------------------------------------------------------------- + ! Purpose: calculates the(x,y) location(dot) in the global grids + ! from latitudes and longitudes + !---------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:), lon(:) + real, intent(out) :: x(:), y(:) + + real, allocatable :: xlat(:), xlon(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_global_1d") + + n = size(lat) + allocate ( xlat(n), xlon(n) ) + + xlat = lat - start_lat + xlon = lon - start_lon + where (xlat < 0.0) xlat = xlat + 180.0 + where (xlon < 0.0) xlon = xlon + 360.0 + + x = start_x + xlon/delt_lon + y = start_y + xlat/delt_lat + if(fg_format == fg_format_wrf_arw_global) & + where (lat.le.start_lat) y = 1.0 + + deallocate ( xlat, xlon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_global_1d") + +end subroutine da_llxy_global_1d diff --git a/var/da/da_tools/da_llxy_kma_global_1d.inc b/var/da/da_tools/da_llxy_kma_global_1d.inc new file mode 100644 index 0000000000..cac3245601 --- /dev/null +++ b/var/da/da_tools/da_llxy_kma_global_1d.inc @@ -0,0 +1,36 @@ +subroutine da_llxy_kma_global_1d(lat,lon,x,y) + + !---------------------------------------------------------------------------- + ! Purpose: calculates the(x,y) location(dot) in the global grids + ! from latitudes and longitudes + !---------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:), lon(:) + real, intent(out) :: x(:), y(:) + + real, allocatable :: xlat(:), xlon(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_kma_global_1d") + + n = size(lat) + allocate ( xlat(n), xlon(n) ) + + xlat = lat - start_lat + xlon = lon - start_lon + + where (xlat < 0.0) xlat = xlat + 180.0 + where (xlon < 0.0) xlon = xlon + 360.0 + + x = start_x + xlon/delt_lon + y = start_y + xlat/delt_lat + + deallocate ( xlat, xlon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_kma_global_1d") + +end subroutine da_llxy_kma_global_1d + + diff --git a/var/da/da_tools/da_llxy_latlon_1d.inc b/var/da/da_tools/da_llxy_latlon_1d.inc new file mode 100644 index 0000000000..0b9e869ed9 --- /dev/null +++ b/var/da/da_tools/da_llxy_latlon_1d.inc @@ -0,0 +1,56 @@ +subroutine da_llxy_latlon_1d(lat, lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Compute the x/y location of a lat/lon on a LATLON + ! (cylindrical equidistant) grid. + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info), intent(in) :: proj + real, intent(out) :: x(:) + real, intent(out) :: y(:) + + real, allocatable :: deltalat(:) + real, allocatable :: deltalon(:) + real, allocatable :: lon360(:) + real :: latinc + real :: loninc + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_latlon_1d") + + n = size(lat) + allocate ( deltalat(n), deltalon(n), lon360(n) ) + + ! To account for issues around the dateline, convert the incoming + ! longitudes to be 0->360.0 + where (lon < 0) + lon360 = lon + 360.0 + elsewhere + lon360 = lon + end where + + deltalat = lat - proj%lat1 + deltalon = lon360 - proj%lon1 + + !For cylindrical equidistant, dx == dy + loninc = proj%dx*360.0/(2.0*EARTH_RADIUS_M*PI) + latinc = proj%dx*360.0/(2.0*EARTH_RADIUS_M*PI) + + ! Compute x/y + x = deltalon/loninc + y = deltalat/latinc + + x = x + proj%knowni + y = y + proj%knownj + + deallocate ( deltalat, deltalon, lon360 ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_latlon_1d") + +end subroutine da_llxy_latlon_1d + + diff --git a/var/da/da_tools/da_llxy_lc_1d.inc b/var/da/da_tools/da_llxy_lc_1d.inc new file mode 100644 index 0000000000..b56e07b789 --- /dev/null +++ b/var/da/da_tools/da_llxy_lc_1d.inc @@ -0,0 +1,64 @@ +subroutine da_llxy_lc_1d(lat, lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: compute the geographical latitude and longitude values + ! to the cartesian x/y on a Lambert Conformal projection. + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) ! Latitude (-90->90 deg N) + real, intent(in) :: lon(:) ! Longitude (-180->180 E) + type(proj_info),intent(in) :: proj ! Projection info structure + + real, intent(out) :: x(:) ! Cartesian X coordinate + real, intent(out) :: y(:) ! Cartesian Y coordinate + + real, allocatable :: arg(:) + real, allocatable :: deltalon(:) + real :: tl1r + real, allocatable :: rm(:) + real :: ctl1r + integer :: n + + if (trace_use_dull) call da_trace_entry("da_llxy_lc_1d") + + n = size(lat) + allocate ( arg(n), deltalon(n), rm(n) ) + + ! Compute deltalon between known longitude and standard lon and ensure + ! it is not in the cut zone + deltalon = lon - proj%stdlon + where (deltalon > +180.0) deltalon = deltalon - 360.0 + where (deltalon < -180.0) deltalon = deltalon + 360.0 + + ! Convert truelat1 to radian and compute COS for later use + tl1r = proj%truelat1 * rad_per_deg + ctl1r = COS(tl1r) + + ! Radius to desired point + rm = proj%rebydx * ctl1r/proj%cone * & + (TAN((90.0*proj%hemi-lat)*rad_per_deg/2.0) / & + TAN((90.0*proj%hemi-proj%truelat1)*rad_per_deg/2.0))**proj%cone + + arg = proj%cone*(deltalon*rad_per_deg) + x = proj%polei + proj%hemi * rm * Sin(arg) + y = proj%polej - rm * COS(arg) + + ! Finally, if we are in the southern hemisphere, flip the i/j + ! values to a coordinate system where (1,1) is the SW corner + ! (what we assume) which is different than the original NCEP + ! algorithms which used the NE corner as the origin in the + ! southern hemisphere (left-hand vs. right-hand coordinate?) + if (proj%hemi == -1.0) then + x = 2.0 - x + y = 2.0 - y + end if + + deallocate ( arg, deltalon, rm ) + + if (trace_use_dull) call da_trace_exit("da_llxy_lc_1d") + +end subroutine da_llxy_lc_1d + + diff --git a/var/da/da_tools/da_llxy_merc_1d.inc b/var/da/da_tools/da_llxy_merc_1d.inc new file mode 100644 index 0000000000..ef39acf721 --- /dev/null +++ b/var/da/da_tools/da_llxy_merc_1d.inc @@ -0,0 +1,35 @@ +subroutine da_llxy_merc_1d(lat, lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Compute x,y coordinate from lat lon for mercator projection + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info),intent(in) :: proj + real,intent(out) :: x(:) + real,intent(out) :: y(:) + real, allocatable :: deltalon(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_merc_1d") + + n = size(lat) + allocate ( deltalon(n) ) + + deltalon = lon - proj%lon1 + where (deltalon < -180.0) deltalon = deltalon + 360.0 + where (deltalon > 180.0) deltalon = deltalon - 360.0 + x = 1.0 + (deltalon/(proj%dlon*deg_per_rad)) + y = 1.0 + (ALOG(TAN(0.5*((lat + 90.0) * rad_per_deg)))) / & + proj%dlon - proj%rsw + + deallocate ( deltalon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_merc_1d") + +end subroutine da_llxy_merc_1d + + diff --git a/var/da/da_tools/da_llxy_ps_1d.inc b/var/da/da_tools/da_llxy_ps_1d.inc new file mode 100644 index 0000000000..3c39cfb9fb --- /dev/null +++ b/var/da/da_tools/da_llxy_ps_1d.inc @@ -0,0 +1,50 @@ +subroutine da_llxy_ps_1d(lat,lon,proj,x,y) + + !----------------------------------------------------------------------- + ! Purpose: Given latitude (-90 to 90), longitude (-180 to 180), and the + ! standard polar-stereographic projection information via the + ! public proj structure, this routine returns the x/y indices which + ! if within the domain range from 1->nx and 1->ny, respectively. + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info),intent(in) :: proj + + real, intent(out) :: x(:) !(x-index) + real, intent(out) :: y(:) !(y-index) + + real :: reflon + real :: scale_top + real, allocatable :: ala(:) + real, allocatable :: alo(:) + real, allocatable :: rm(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_ps_1d") + + reflon = proj%stdlon + 90.0 + + ! Compute numerator term of map scale factor + + scale_top = 1.0 + proj%hemi * Sin(proj%truelat1 * rad_per_deg) + + ! Find radius to desired point + n = size(lat) + allocate ( ala(n), alo(n), rm(n) ) + + ala = lat * rad_per_deg + rm = proj%rebydx * COS(ala) * scale_top/(1.0 + proj%hemi *Sin(ala)) + alo = (lon - reflon) * rad_per_deg + x = proj%polei + rm * COS(alo) + y = proj%polej + proj%hemi * rm * Sin(alo) + + deallocate ( ala, alo, rm ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_ps_1d") + +end subroutine da_llxy_ps_1d + + diff --git a/var/da/da_tools/da_llxy_rotated_latlon_1d.inc b/var/da/da_tools/da_llxy_rotated_latlon_1d.inc new file mode 100644 index 0000000000..bc802c4da8 --- /dev/null +++ b/var/da/da_tools/da_llxy_rotated_latlon_1d.inc @@ -0,0 +1,60 @@ +subroutine da_llxy_rotated_latlon_1d(lat,lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Compute the x/y location of a lat/lon on a rotated LATLON grid. + ! Author : Syed RH Rizvi, MMM/NCAR + ! 06/01/2008 + !--------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info), intent(in) :: proj + real, intent(out) :: x(:) + real, intent(out) :: y(:) + + real, allocatable :: rot_lat(:), rot_lon(:), deltalat(:), deltalon(:), lon360(:) + real, allocatable :: xlat(:), xlon(:) + real :: cen_lat, cen_lon, latinc, loninc + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_rotated_latlon_1d") + + n = size(lat) + allocate ( rot_lat(n), rot_lon(n), deltalat(n), deltalon(n), lon360(n), xlat(n), xlon(n) ) + + ! To account for issues around the dateline, convert the incoming + ! longitudes to be 0->360.0 + where (lon < 0) + lon360 = lon + 360.0 + elsewhere + lon360 = lon + end where + + xlat = deg_to_rad*lat + xlon = deg_to_rad*lon360 + cen_lat = deg_to_rad*proj%lat1 + cen_lon = deg_to_rad*proj%lon1 + if (cen_lon < 0.) cen_lon = cen_lon + 360. + + latinc = proj%latinc + loninc = proj%loninc + + rot_lon = rad_to_deg*atan( cos(xlat) * sin(xlon-cen_lon)/ & + (cos(cen_lat)*cos(xlat)*cos(xlon-cen_lon) + sin(cen_lat)*sin(xlat))) + rot_lat = rad_to_deg*asin( cos(cen_lat)*sin(xlat) - sin(cen_lat)*cos(xlat)*cos(xlon-cen_lon)) + + + deltalat = rot_lat + deltalon = rot_lon + + ! Compute x/y + x = proj%knowni + deltalon/loninc + 1.0 + y = proj%knownj + deltalat/latinc + 1.0 + + deallocate ( rot_lat, rot_lon, deltalat, deltalon, lon360, xlat, xlon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_rotated_latlon_1d") + +end subroutine da_llxy_rotated_latlon_1d diff --git a/var/da/da_tools/da_llxy_wrf_1d.inc b/var/da/da_tools/da_llxy_wrf_1d.inc new file mode 100644 index 0000000000..4a46d9b34c --- /dev/null +++ b/var/da/da_tools/da_llxy_wrf_1d.inc @@ -0,0 +1,51 @@ +subroutine da_llxy_wrf_1d(proj, lat, lon, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Converts input lat/lon values to the cartesian (x, y) value + ! for the given projection. + !----------------------------------------------------------------------- + + implicit none + + type(proj_info), intent(in) :: proj + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + real, intent(out) :: x(:) + real, intent(out) :: y(:) + + if (trace_use_frequent) call da_trace_entry("da_llxy_wrf_1d") + + if (.NOT.proj%init) then + call da_error(__FILE__,__LINE__, & + (/"You have not called map_set for this projection!"/)) + end if + + select case(proj%code) + + case(PROJ_LATLON) + call da_llxy_latlon_1d(lat,lon,proj,x,y) + + case(PROJ_MERC) + call da_llxy_merc_1d(lat,lon,proj,x,y) + x = x + proj%knowni - 1.0 + y = y + proj%knownj - 1.0 + + case(PROJ_PS) + call da_llxy_ps_1d(lat,lon,proj,x,y) + + case(PROJ_LC) + call da_llxy_lc_1d(lat,lon,proj,x,y) + x = x + proj%knowni - 1.0 + y = y + proj%knownj - 1.0 + + case default + write(unit=message(1),fmt='(A,I2)') & + 'Unrecognized map projection code: ', proj%code + call da_error(__FILE__,__LINE__,message(1:1)) + end select + + if (trace_use_frequent) call da_trace_exit("da_llxy_wrf_1d") + +end subroutine da_llxy_wrf_1d + + diff --git a/var/da/da_tools/da_outside.inc b/var/da/da_tools/da_outside.inc deleted file mode 100644 index a85ef3a253..0000000000 --- a/var/da/da_tools/da_outside.inc +++ /dev/null @@ -1,92 +0,0 @@ -subroutine da_outside (locs, outside, outside_all) - - !----------------------------------------------------------------------- - ! Purpose: TBD - !----------------------------------------------------------------------- - - ! Vectorized determination of whether locs are on this domain/patch, copied from da_llxy_new - - implicit none - - type(model_loc_type), intent(inout) :: locs(:,:) - logical, intent(inout) :: outside(:,:) ! wrt local domain - logical, optional, intent(out) :: outside_all(:,:) ! wrt all domains - - if (trace_use) call da_trace_entry("da_outside") - - outside(:,:) = .false. - -#ifdef A2C - call da_togrid_new (locs(:,:)%x, its-3, ite+3, locs(:,:)%i, locs(:,:)%dx, locs(:,:)%dxm)! - - call da_togrid_new (locs(:,:)%y, jts-3, jte+3, locs(:,:)%j, locs(:,:)%dy, locs(:,:)%dym) -#else - call da_togrid_new (locs(:,:)%x, its-2, ite+2, locs(:,:)%i, locs(:,:)%dx, locs(:,:)%dxm)! - - call da_togrid_new (locs(:,:)%y, jts-2, jte+2, locs(:,:)%j, locs(:,:)%dy, locs(:,:)%dym) -#endif - - ! refactor to remove this ugly duplication later - if (present(outside_all)) then - outside_all(:,:) = .false. - ! Do not check for global options - if (.not. global) then - where ((int(locs(:,:)%x) < ids) .or. (int(locs(:,:)%x) >= ide) .or. & - (int(locs(:,:)%y) < jds) .or. (int(locs(:,:)%y) >= jde)) - outside_all(:,:) = .true. - outside(:,:) = .true. - end where - if (def_sub_domain) then - where (x_start_sub_domain > locs(:,:)%x .or. y_start_sub_domain > locs(:,:)%y .or. & - x_end_sub_domain < locs(:,:)%x .or. y_end_sub_domain < locs(:,:)%y) - outside_all(:,:) = .true. - outside(:,:) = .true. - end where - end if - end if - end if - - if (fg_format == fg_format_kma_global) then - where ((locs(:,:)%j < jts-1) .or. (locs(:,:)%j > jte)) - outside(:,:) = .true. - end where - - where (locs(:,:)%j == jde) - locs(:,:)%j = locs(:,:)%j - 1 - locs(:,:)%dy = 1.0 - locs(:,:)%dym = 0.0 - end where - - return - end if - - ! Check for edge of domain: - - where ((locs(:,:)%i < ids) .or. (locs(:,:)%i >= ide) .or. & - (locs(:,:)%j < jds) .or. (locs(:,:)%j >= jde)) - outside = .true. - end where - - ! FIX? hack -#ifdef A2C - where ((locs(:,:)%i < its-2) .or. (locs(:,:)%i > ite) .or. & - (locs(:,:)%j < jts-2) .or. (locs(:,:)%j > jte)) -#else - where ((locs(:,:)%i < its-1) .or. (locs(:,:)%i > ite) .or. & - (locs(:,:)%j < jts-1) .or. (locs(:,:)%j > jte)) -#endif - outside(:,:) = .true. - end where - - if (def_sub_domain) then - where (x_start_sub_domain > locs(:,:)%x .or. y_start_sub_domain > locs(:,:)%y .or. & - x_end_sub_domain < locs(:,:)%x .or. y_end_sub_domain < locs(:,:)%y) - outside(:,:) = .true. - end where - end if - - if (trace_use) call da_trace_exit("da_outside") - -end subroutine da_outside - - diff --git a/var/da/da_tools/da_togrid_1d.inc b/var/da/da_tools/da_togrid_1d.inc new file mode 100644 index 0000000000..262a446e7f --- /dev/null +++ b/var/da/da_tools/da_togrid_1d.inc @@ -0,0 +1,44 @@ +subroutine da_togrid_1d (x, ib, ie, i, dx, dxm) + + !----------------------------------------------------------------------- + ! Purpose: Transfer obs. x to grid i and calculate its + ! distance to grid i and i+1 + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: x(:) + integer, intent(in) :: ib, ie + real, intent(out) :: dx(:), dxm(:) + integer, intent(out) :: i(:) + + if (trace_use) call da_trace_entry("da_togrid_1d") + +! where (x(:) > 0.0) +! i = int (x) +! +! where(i(:) < ib) i = ib +! where(i(:) >= ie) i = ie-1 +! +! dx = x - real(i) +! dxm = 1.0 - dx +! elsewhere +! i = 0 +! dx = 0.0 +! dxm = 0.0 +! end where + + i = int (x) + where (i(:) < ib) + i = ib + elsewhere (i(:) >= ie) + i = ie - 1 + end where + dx = x - real(i) + dxm = 1.0 - dx + + if (trace_use) call da_trace_exit("da_togrid_1d") + +end subroutine da_togrid_1d + + diff --git a/var/da/da_tools/da_tools.f90 b/var/da/da_tools/da_tools.f90 index 15d6f4a5d8..e5b00ae9db 100644 --- a/var/da/da_tools/da_tools.f90 +++ b/var/da/da_tools/da_tools.f90 @@ -48,7 +48,6 @@ module da_tools #include "da_llxy.inc" #include "da_llxy_new.inc" -#include "da_outside.inc" #include "da_llxy_default.inc" #include "da_llxy_default_new.inc" #include "da_llxy_kma_global.inc" @@ -66,6 +65,18 @@ module da_tools #include "da_llxy_ps_new.inc" #include "da_llxy_wrf.inc" #include "da_llxy_wrf_new.inc" + +#include "da_llxy_1d.inc" +#include "da_llxy_default_1d.inc" +#include "da_llxy_kma_global_1d.inc" +#include "da_llxy_global_1d.inc" +#include "da_llxy_rotated_latlon_1d.inc" +#include "da_llxy_latlon_1d.inc" +#include "da_llxy_lc_1d.inc" +#include "da_llxy_merc_1d.inc" +#include "da_llxy_ps_1d.inc" +#include "da_llxy_wrf_1d.inc" + #include "da_xyll.inc" #include "da_xyll_default.inc" #include "da_xyll_latlon.inc" @@ -97,8 +108,9 @@ module da_tools #include "da_gaus_noise.inc" #include "da_openfile.inc" #include "da_smooth_anl.inc" -#include "da_togrid_new.inc" #include "da_togrid.inc" +#include "da_togrid_new.inc" +#include "da_togrid_1d.inc" #include "da_unifva.inc" #include "da_buddy_qc.inc" From 4da22edbef9e16f375c215c978b4534473ec1c3c Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Mon, 11 Jun 2018 12:50:28 -0600 Subject: [PATCH 11/86] Added more accurate total obs counts for GOES-ABI on all processors modified: da_radiance/da_read_obs_ncgoesabi.inc --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 67 ++++++++------------ 1 file changed, 28 insertions(+), 39 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 38932dee4b..72aed9d23d 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -315,11 +315,11 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) " -type f -name '",trim(fname), & "*G",satellite_id, & "*' -printf '%P\n' > ",trim(list_file) - write(stdout,*) trim(command) +write(stdout,*) trim(command) call execute_command_line (trim(command)) write(command,fmt='(4A)') "cat ",trim(list_file)," | wc -l > ",trim(count_file) - write(stdout,*) trim(command) +write(stdout,*) trim(command) call execute_command_line (trim(command)) open(unit=file_unit,file=trim(count_file)) @@ -968,21 +968,37 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ #endif end if DoGridGen - num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain - ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain - - PatchMatch: if (this_view % nrad_on_patch .gt. 0) then - if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view % nfiles_used(:)).eq.0 ) then + if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view % nfiles_used(:)).eq.0 ) then + if (this_view % nrad_on_patch .gt. 0) then allocate(view_mask(& this_view % ys_p_fd-2:this_view % ye_p_fd+2, & this_view % xs_p_fd-2:this_view % xe_p_fd+2, & nviews, nchan, num_fgat_time)) - view_mask = .false. - use_view_mask = .true. end if + use_view_mask = .true. + end if + if ( ipass.lt.npass .or. .not.use_view_mask ) then + num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain + ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain + end if + if ( use_view_mask .and. ipass.lt.npass .and. iview .gt. 1 ) then + best_view = .true. +! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations + do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap + best_view = best_view .and. & + this_view % min_time_diff(ichan, ifgat) .lt. & + view_att(jview) % min_time_diff(ichan, ifgat) + end do + if (best_view) then + num_goesabi_global = num_goesabi_global - this_view % nrad_on_domain + ptotal(ifgat) = ptotal(ifgat) - this_view % nrad_on_domain + end if + end if + + PatchMatch: if (this_view % nrad_on_patch .gt. 0) then ! Loop over channels; each process reads radiance data only for its subdomain ChannelLoop: do ichan = 1, nchan ifile = 0 @@ -998,8 +1014,6 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ this_view % nfiles_used(ifgat) = this_view % nfiles_used(ifgat) + 1 -! use_view_mask = ( sum(view_att(1) % nfiles_used(:)).gt.0 ) - VIEW_SELECT: & if ( ipass.lt.npass .and. use_view_mask ) then !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1016,17 +1030,7 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ ixfd = this_view % ix_1d % patch (n) + this_view % xoff_fd-1 view_mask( iyfd, ixfd, iview, ichan, ifgat) = .true. end do - else - -!OLD CODE - best_view = .true. -! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations - do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap - best_view = best_view .and. & - this_view % min_time_diff(ichan, ifgat) .lt. & - view_att(jview) % min_time_diff(ichan, ifgat) - end do - + else if ( best_view ) then do n = 1, this_view % nrad_on_patch iyfd = this_view % iy_1d % patch (n) + this_view % yoff_fd-1 @@ -1039,23 +1043,8 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ ! !This assumes MESO1 and MESO2 are in identical locations ! view_mask( iyfd, ixfd, 1:iview-1, ichan, ifgat) = .false. end do - -!OLD CODE -! view_mask(this_view % ys_p_fd:this_view % ye_p_fd, & -! this_view % ys_p_fd:this_view % ye_p_fd, & -! iview, ichan, ifgat) = .true. -! -!! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations -!! do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap -! -! view_mask(this_view % ys_p_fd:this_view % ye_p_fd, & -! this_view % ys_p_fd:this_view % ye_p_fd, & -! iview, ichan, ifgat) = .false. -! end do end if - end if - else if (inst == 0) cycle fname_short = trim(this_view % filename(ifile)) @@ -1260,12 +1249,12 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ deallocate(view_att) if (tot_files_used .lt. 1) then -!! write(unit=message(1),fmt='(A,I2,3A)') "Either no L1B data found or no matching fgat windows for GOES-",satellite_id," ABI using prefix ",INST_PREFIX, "for this process rank. This subdomain may have an unacceptable zenith angle or fall entirely outside the GOES viewing extent." +!! write(unit=message(1),fmt='(A,I2,3A)') "Either no L1B data found or no matching fgat windows for GOES-",satellite_id," ABI using prefix ",INST_PREFIX, " for this process rank. This subdomain may have an unacceptable zenith angle or fall entirely outside the GOES viewing extent." write(unit=message(1),fmt=*) "Either no L1B data found or no matching fgat windows for GOES-",satellite_id," ABI using prefix ",INST_PREFIX, "for this process rank. This subdomain may have an unacceptable zenith angle or fall entirely outside the GOES viewing extent." ! write(unit=message(1),fmt='(A)') "Either no L1B data found or no matching" ! write(unit=message(2),fmt='(A,I2,A)') "fgat windows for GOES-",satellite_id," ABI using" -! write(unit=message(3),fmt='(3A)') "prefix ",INST_PREFIX, "for this process rank." +! write(unit=message(3),fmt='(3A)') "prefix ",INST_PREFIX, " for this process rank." ! write(unit=message(4),fmt='(A)') "This subdomain may have an unacceptable zenith " ! write(unit=message(5),fmt='(A)') "angle or fall entirely outside the GOES viewing" ! write(unit=message(6),fmt='(A)') "extent." From 97e91bfb3e6f62e5f10200a52470d30ec9ac0459 Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Thu, 21 Jun 2018 13:39:11 -0600 Subject: [PATCH 12/86] Minor fixes for serial compile Changes to be committed: modified: da_radiance/da_read_obs_ncgoesabi.inc --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 72aed9d23d..1f34b4c11c 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -535,8 +535,7 @@ write(stdout,*) trim(command) call split_grid( this_view % ny_global, this_view % nx_global , & this_view % ny_grid, this_view % nx_grid , & - this_view % ys_grid, this_view % xs_grid ) - + this_view % ys_grid, this_view % xs_grid ) #else ! When mpi parallelism is not available, assign global values to local variables this_view % ny_grid = this_view % ny_global @@ -819,7 +818,11 @@ write(stdout,*) trim(command) ! BEGIN SOLUTION 2 !ALLOCATE COMMUNICATION BUFFERS +#ifdef DM_PARALLEL call mpi_allreduce( nrad_mask, nbuf, 1, mpi_integer, mpi_sum, comm, ierr ) +#else + nbuf = nrad_mask +#endif allocate( buf_real( nbuf, 3 ) ) allocate( buf_int ( nbuf, 2 ) ) allocate( buf_loc ( nbuf ) ) @@ -1844,10 +1847,10 @@ end subroutine get_abil1b_latlon !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#ifdef DM_PARALLEL subroutine split_grid( ny_global, nx_global, & ny_grid, nx_grid, & ys_grid, xs_grid ) - implicit none integer, intent(in) :: ny_global, nx_global @@ -1940,6 +1943,7 @@ subroutine split_grid( ny_global, nx_global, & ! xs_local = xs_grid(i) end subroutine split_grid +#endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From cba75d608bd938ba3ba4333796ac149f42dd77c1 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Fri, 3 Aug 2018 17:05:10 -0600 Subject: [PATCH 13/86] Added Zhuge and Zou cloud detection option for GOES ABI Still required - test compilation - debug runtime errors - test correct functionality for 10 different cloud detection criteria Changes to be committed: modified: Registry/registry.var modified: var/build/depend.txt modified: var/da/da_control/da_control.f90 modified: var/da/da_define_structures/da_define_structures.f90 modified: var/da/da_physics/da_physics.f90 new file: var/da/da_physics/da_trop_wmo.inc modified: var/da/da_radiance/da_allocate_rad_iv.inc modified: var/da/da_radiance/da_crtm.f90 modified: var/da/da_radiance/da_deallocate_radiance.inc modified: var/da/da_radiance/da_get_innov_vector_crtm.inc modified: var/da/da_radiance/da_get_innov_vector_rttov.inc new file: var/da/da_radiance/da_get_sat_angles.inc new file: var/da/da_radiance/da_get_sat_angles_1d.inc deleted: var/da/da_radiance/da_get_satzen.inc deleted: var/da/da_radiance/da_get_satzen_1d.inc new file: var/da/da_radiance/da_get_solar_angles.inc new file: var/da/da_radiance/da_get_solar_angles_1d.inc modified: var/da/da_radiance/da_initialize_rad_iv.inc modified: var/da/da_radiance/da_qc_goesabi.inc modified: var/da/da_radiance/da_radiance.f90 modified: var/da/da_radiance/da_radiance1.f90 modified: var/da/da_radiance/da_read_obs_ncgoesabi.inc modified: var/da/da_radiance/da_read_obs_ncgoesimg.inc modified: var/da/da_radiance/da_rttov.f90 --- Registry/registry.var | 5 +- var/build/depend.txt | 8 +- var/da/da_control/da_control.f90 | 2 +- .../da_define_structures.f90 | 7 + var/da/da_physics/da_physics.f90 | 1 + var/da/da_physics/da_trop_wmo.inc | 114 +++ var/da/da_radiance/da_allocate_rad_iv.inc | 2 + var/da/da_radiance/da_crtm.f90 | 3 +- var/da/da_radiance/da_deallocate_radiance.inc | 10 +- .../da_radiance/da_get_innov_vector_crtm.inc | 37 +- .../da_radiance/da_get_innov_vector_rttov.inc | 34 +- var/da/da_radiance/da_get_sat_angles.inc | 100 ++ var/da/da_radiance/da_get_sat_angles_1d.inc | 133 +++ var/da/da_radiance/da_get_satzen.inc | 66 -- var/da/da_radiance/da_get_satzen_1d.inc | 84 -- var/da/da_radiance/da_get_solar_angles.inc | 193 ++++ var/da/da_radiance/da_get_solar_angles_1d.inc | 228 +++++ var/da/da_radiance/da_initialize_rad_iv.inc | 14 + var/da/da_radiance/da_qc_goesabi.inc | 826 ++++++++++++++-- var/da/da_radiance/da_radiance.f90 | 8 +- var/da/da_radiance/da_radiance1.f90 | 12 +- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 891 +++++++++++++----- var/da/da_radiance/da_read_obs_ncgoesimg.inc | 2 +- var/da/da_radiance/da_rttov.f90 | 6 +- 24 files changed, 2279 insertions(+), 507 deletions(-) create mode 100644 var/da/da_physics/da_trop_wmo.inc create mode 100644 var/da/da_radiance/da_get_sat_angles.inc create mode 100644 var/da/da_radiance/da_get_sat_angles_1d.inc delete mode 100644 var/da/da_radiance/da_get_satzen.inc delete mode 100644 var/da/da_radiance/da_get_satzen_1d.inc create mode 100644 var/da/da_radiance/da_get_solar_angles.inc create mode 100644 var/da/da_radiance/da_get_solar_angles_1d.inc diff --git a/Registry/registry.var b/Registry/registry.var index 661eb19c30..dc72bc024f 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -434,8 +434,9 @@ rconfig logical freeze_varbc namelist,wrfvar14 1 .false. - "fr rconfig real varbc_factor namelist,wrfvar14 1 1.0 - "varbc_factor" "" "" rconfig integer varbc_nbgerr namelist,wrfvar14 1 5000 - "varbc_nbgerr" "" "" rconfig integer varbc_nobsmin namelist,wrfvar14 1 10 - "varbc_nobsmin" "" "" -rconfig logical use_clddet_mmr namelist,wrfvar14 1 .false. - "use_clddet_mmr" "" "" -rconfig logical use_clddet_ecmwf namelist,wrfvar14 1 .false. - "use_clddet_ecmwf" "" "" +rconfig logical use_clddet_mmr namelist,wrfvar14 1 .false. - "use_clddet_mmr" "" "" +rconfig logical use_clddet_ecmwf namelist,wrfvar14 1 .false. - "use_clddet_ecmwf" "" "" +rconfig logical use_clddet_zz namelist,wrfvar14 1 .false. - "use_clddet_zz" "" "" rconfig logical airs_warmest_fov namelist,wrfvar14 1 .false. - "airs_warmest_fov" "" "" rconfig logical use_satcv namelist,wrfvar14 2 .false. - "use_satcv" "" "" rconfig logical use_blacklist_rad namelist,wrfvar14 1 .true. - "use_blacklist_rad" "" "" diff --git a/var/build/depend.txt b/var/build/depend.txt index b075b045ad..481caec783 100644 --- a/var/build/depend.txt +++ b/var/build/depend.txt @@ -110,7 +110,7 @@ da_blas.o : da_blas.f90 dgemv.inc dgemm.inc xerbla.inc lsame.inc dswap.inc dtrmm da_bogus.o : da_bogus.f90 da_calculate_grady_bogus.inc da_get_innov_vector_bogus.inc da_check_max_iv_bogus.inc da_transform_xtoy_bogus_adj.inc da_transform_xtoy_bogus.inc da_print_stats_bogus.inc da_oi_stats_bogus.inc da_residual_bogus.inc da_jo_and_grady_bogus.inc da_ao_stats_bogus.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_buoy.o : da_buoy.f90 da_calculate_grady_buoy.inc da_get_innov_vector_buoy.inc da_check_max_iv_buoy.inc da_transform_xtoy_buoy_adj.inc da_transform_xtoy_buoy.inc da_print_stats_buoy.inc da_oi_stats_buoy.inc da_residual_buoy.inc da_jo_and_grady_buoy.inc da_ao_stats_buoy.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_control.o : da_control.f90 module_driver_constants.o -da_crtm.o : da_crtm.f90 da_det_crtm_climat.inc da_crtm_sensor_descriptor.inc da_crtm_init.inc da_crtm_ad.inc da_crtm_direct.inc da_crtm_k.inc da_crtm_tl.inc da_get_innov_vector_crtm.inc da_transform_xtoy_crtm_adj.inc da_transform_xtoy_crtm.inc da_tracing.o da_tools.o da_tools_serial.o da_reporting.o da_radiance1.o module_dm.o da_interpolation.o da_control.o module_radiance.o da_define_structures.o module_domain.o +da_crtm.o : da_crtm.f90 da_det_crtm_climat.inc da_crtm_sensor_descriptor.inc da_crtm_init.inc da_crtm_ad.inc da_crtm_direct.inc da_crtm_k.inc da_crtm_tl.inc da_get_innov_vector_crtm.inc da_transform_xtoy_crtm_adj.inc da_transform_xtoy_crtm.inc da_tracing.o da_tools.o da_tools_serial.o da_reporting.o da_radiance1.o module_dm.o da_interpolation.o da_control.o module_radiance.o da_define_structures.o module_domain.o da_physics.o da_define_structures.o : da_define_structures.f90 da_gauss_noise.inc da_random_seed.inc da_initialize_cv.inc da_zero_vp_type.inc da_zero_y.inc da_zero_x.inc da_deallocate_y.inc da_deallocate_observations.inc da_deallocate_background_errors.inc da_allocate_y.inc da_allocate_observations.inc da_allocate_background_errors.inc da_wavelet.o da_reporting.o da_tools_serial.o da_tracing.o da_control.o module_domain.o da_allocate_y_rain.inc da_allocate_y_radar.inc da_allocate_observations_rain.inc da_allocate_obs_info.inc da_dynamics.o : da_dynamics.f90 da_wz_base.inc da_uv_to_vorticity.inc da_w_adjustment_adj.inc da_w_adjustment_lin.inc da_uv_to_divergence_adj.inc da_uv_to_divergence.inc da_psichi_to_uv_adj.inc da_psichi_to_uv.inc da_hydrostaticp_to_rho_lin.inc da_hydrostaticp_to_rho_adj.inc da_balance_geoterm_lin.inc da_balance_geoterm_adj.inc da_balance_equation_lin.inc da_balance_equation_adj.inc da_balance_cycloterm_lin.inc da_balance_cycloterm_adj.inc da_balance_cycloterm.inc da_wpec_constraint.inc da_wpec_constraint_adj.inc da_wpec_constraint_cycloterm.inc da_wpec_constraint_geoterm.inc da_wpec_constraint_lin.inc da_tools.o da_tracing.o da_ffts.o da_reporting.o da_define_structures.o module_comm_dm.o module_dm.o module_domain.o da_control.o da_divergence_constraint.inc da_divergence_constraint_adj.inc da_etkf.o : da_etkf.f90 da_solve_etkf.inc da_matmultiover.inc da_matmulti.inc da_innerprod.inc da_lapack.o da_gen_be.o da_control.o @@ -135,7 +135,7 @@ da_obs.o : da_obs.f90 da_grid_definitions.o da_set_obs_missing.inc da_obs_sensit da_obs_io.o : da_obs_io.f90 da_grid_definitions.o da_final_write_modified_filtered_obs.inc da_final_write_filtered_obs.inc da_write_noise_to_ob.inc da_read_omb_tmp.inc da_read_rand_unit.inc da_read_y_unit.inc da_final_write_y.inc da_final_write_obs.inc da_read_obs_bufrgpsro.inc da_read_obs_bufr.inc da_write_y.inc da_write_modified_filtered_obs.inc da_write_filtered_obs.inc da_write_obs_etkf.inc da_search_obs.inc da_read_iv_for_multi_inc.inc da_write_iv_for_multi_inc.inc da_write_obs.inc da_use_obs_errfac.inc da_read_errfac.inc da_read_obs_rain.inc da_scan_obs_rain.inc da_scan_obs_radar.inc da_read_obs_radar.inc da_scan_obs_ascii.inc da_read_obs_ascii.inc da_par_util.o gsi_thinning.o module_radiance.o da_tracing.o da_tools_serial.o da_tools.o da_reporting.o da_physics.o da_par_util1.o da_obs.o da_grid_definitions.o da_define_structures.o da_control.o module_domain.o da_read_lsac_util.inc da_read_obs_lsac.inc da_scan_obs_lsac.inc da_netcdf_interface.o da_gpseph.o da_read_obs_bufrgpsro_eph.inc da_par_util.o : da_par_util.f90 da_proc_maxmin_combine.inc da_proc_stats_combine.inc da_system.inc da_y_facade_to_global.inc da_generic_boilerplate.inc da_deallocate_global_synop.inc da_deallocate_global_sound.inc da_deallocate_global_sonde_sfc.inc da_generic_methods.inc da_patch_to_global_3d.inc da_patch_to_global_dual_res.inc da_patch_to_global_2d.inc da_cv_to_global.inc da_transpose_y2x_v2.inc da_transpose_x2y_v2.inc da_transpose_z2y.inc da_transpose_y2z.inc da_transpose_x2z.inc da_transpose_z2x.inc da_transpose_y2x.inc da_transpose_x2y.inc da_unpack_count_obs.inc da_pack_count_obs.inc da_copy_tile_dims.inc da_copy_dims.inc da_alloc_and_copy_be_arrays.inc da_vv_to_cv.inc da_cv_to_vv.inc da_generic_typedefs.inc da_wrf_interfaces.o da_tracing.o da_reporting.o da_define_structures.o da_par_util1.o module_dm.o module_domain.o da_control.o da_par_util1.o : da_par_util1.f90 da_proc_sum_real.inc da_proc_sum_ints.inc da_proc_sum_int.inc da_control.o -da_physics.o : da_physics.f90 da_uv_to_sd_lin.inc da_uv_to_sd_adj.inc da_integrat_dz.inc da_wdt.inc da_filter_adj.inc da_filter.inc da_evapo_lin.inc da_condens_lin.inc da_condens_adj.inc da_moist_phys_lin.inc da_moist_phys_adj.inc da_sfc_pre_adj.inc da_sfc_pre_lin.inc da_sfc_pre.inc da_transform_xtowtq_adj.inc da_transform_xtowtq.inc da_transform_xtopsfc_adj.inc da_transform_xtopsfc.inc da_sfc_wtq_adj.inc da_sfc_wtq_lin.inc da_sfc_wtq.inc da_julian_day.inc da_roughness_from_lanu.inc da_get_q_error.inc da_check_rh_simple.inc da_check_rh.inc da_transform_xtogpsref_lin.inc da_transform_xtogpsref_adj.inc da_transform_xtogpsref.inc da_transform_xtotpw_adj.inc da_transform_xtotpw.inc da_transform_xtoztd_adj.inc da_transform_xtoztd_lin.inc da_transform_xtoztd.inc da_tv_profile_tl.inc da_thickness_tl.inc da_find_layer_adj.inc da_thickness.inc da_tv_profile_adj.inc da_find_layer.inc da_thickness_adj.inc da_find_layer_tl.inc da_tv_profile.inc da_tpq_to_slp_adj.inc da_tpq_to_slp_lin.inc da_wrf_tpq_2_slp.inc da_tpq_to_slp.inc da_trh_to_td.inc da_tp_to_qs_lin1.inc da_tp_to_qs_lin.inc da_tp_to_qs_adj1.inc da_tp_to_qs_adj.inc da_tp_to_qs1.inc da_tp_to_qs.inc da_tprh_to_q_lin1.inc da_tprh_to_q_lin.inc da_tprh_to_q_adj1.inc da_tprh_to_q_adj.inc da_tpq_to_rh_lin1.inc da_tpq_to_rh_lin.inc da_tpq_to_rh.inc da_pt_to_rho_lin.inc da_pt_to_rho_adj.inc da_uvprho_to_w_adj.inc da_uvprho_to_w_lin.inc da_prho_to_t_lin.inc da_prho_to_t_adj.inc da_wrf_interfaces.o da_reporting.o da_dynamics.o da_interpolation.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_grid_definitions.o da_gpseph.o +da_physics.o : da_physics.f90 da_uv_to_sd_lin.inc da_uv_to_sd_adj.inc da_integrat_dz.inc da_wdt.inc da_filter_adj.inc da_filter.inc da_evapo_lin.inc da_condens_lin.inc da_condens_adj.inc da_moist_phys_lin.inc da_moist_phys_adj.inc da_sfc_pre_adj.inc da_sfc_pre_lin.inc da_sfc_pre.inc da_transform_xtowtq_adj.inc da_transform_xtowtq.inc da_transform_xtopsfc_adj.inc da_transform_xtopsfc.inc da_sfc_wtq_adj.inc da_sfc_wtq_lin.inc da_sfc_wtq.inc da_julian_day.inc da_roughness_from_lanu.inc da_get_q_error.inc da_check_rh_simple.inc da_check_rh.inc da_transform_xtogpsref_lin.inc da_transform_xtogpsref_adj.inc da_transform_xtogpsref.inc da_transform_xtotpw_adj.inc da_transform_xtotpw.inc da_transform_xtoztd_adj.inc da_transform_xtoztd_lin.inc da_transform_xtoztd.inc da_tv_profile_tl.inc da_thickness_tl.inc da_find_layer_adj.inc da_thickness.inc da_tv_profile_adj.inc da_find_layer.inc da_thickness_adj.inc da_find_layer_tl.inc da_tv_profile.inc da_tpq_to_slp_adj.inc da_tpq_to_slp_lin.inc da_wrf_tpq_2_slp.inc da_tpq_to_slp.inc da_trh_to_td.inc da_tp_to_qs_lin1.inc da_tp_to_qs_lin.inc da_tp_to_qs_adj1.inc da_tp_to_qs_adj.inc da_tp_to_qs1.inc da_tp_to_qs.inc da_tprh_to_q_lin1.inc da_tprh_to_q_lin.inc da_tprh_to_q_adj1.inc da_tprh_to_q_adj.inc da_tpq_to_rh_lin1.inc da_tpq_to_rh_lin.inc da_tpq_to_rh.inc da_pt_to_rho_lin.inc da_pt_to_rho_adj.inc da_uvprho_to_w_adj.inc da_uvprho_to_w_lin.inc da_prho_to_t_lin.inc da_prho_to_t_adj.inc da_trop_wmo.inc da_wrf_interfaces.o da_reporting.o da_dynamics.o da_interpolation.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_grid_definitions.o da_gpseph.o da_pilot.o : da_pilot.f90 da_calculate_grady_pilot.inc da_get_innov_vector_pilot.inc da_check_max_iv_pilot.inc da_transform_xtoy_pilot_adj.inc da_transform_xtoy_pilot.inc da_print_stats_pilot.inc da_oi_stats_pilot.inc da_residual_pilot.inc da_jo_and_grady_pilot.inc da_ao_stats_pilot.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_polaramv.o : da_polaramv.f90 da_calculate_grady_polaramv.inc da_get_innov_vector_polaramv.inc da_check_max_iv_polaramv.inc da_transform_xtoy_polaramv_adj.inc da_transform_xtoy_polaramv.inc da_print_stats_polaramv.inc da_oi_stats_polaramv.inc da_residual_polaramv.inc da_jo_and_grady_polaramv.inc da_ao_stats_polaramv.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_profiler.o : da_profiler.f90 da_calculate_grady_profiler.inc da_get_innov_vector_profiler.inc da_check_max_iv_profiler.inc da_transform_xtoy_profiler_adj.inc da_transform_xtoy_profiler.inc da_print_stats_profiler.inc da_oi_stats_profiler.inc da_residual_profiler.inc da_jo_and_grady_profiler.inc da_ao_stats_profiler.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o @@ -143,7 +143,7 @@ da_pseudo.o : da_pseudo.f90 da_calculate_grady_pseudo.inc da_transform_xtoy_pseu da_qscat.o : da_qscat.f90 da_calculate_grady_qscat.inc da_transform_xtoy_qscat_adj.inc da_transform_xtoy_qscat.inc da_print_stats_qscat.inc da_oi_stats_qscat.inc da_ao_stats_qscat.inc da_get_innov_vector_qscat.inc da_check_max_iv_qscat.inc da_residual_qscat.inc da_jo_and_grady_qscat.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_rad_diags.o : da_rad_diags.f90 da_radar.o : da_radar.f90 da_write_oa_radar_ascii.inc da_max_error_qc_radar.inc da_calculate_grady_radar.inc da_radial_velocity_adj.inc da_radial_velocity_lin.inc da_radial_velocity.inc da_radar_rf.inc da_get_innov_vector_radar.inc da_check_max_iv_radar.inc da_transform_xtoy_radar_adj.inc da_transform_xtoy_radar.inc da_print_stats_radar.inc da_oi_stats_radar.inc da_residual_radar.inc da_jo_and_grady_radar.inc da_ao_stats_radar.inc da_tools_serial.o da_reporting.o da_tracing.o da_tools.o da_statistics.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o -da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o module_dm.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_satzen.inc da_get_satzen_1d.inc +da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o module_dm.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_sat_angles.inc da_get_sat_angles_1d.inc da_get_solar_angles.inc da_get_solar_angles_1d.inc da_radiance1.o : da_radiance1.f90 da_mspps_ts.inc da_mspps_emis.inc da_setup_satcv.inc da_qc_rad.inc da_print_stats_rad.inc da_oi_stats_rad.inc da_ao_stats_rad.inc da_cld_eff_radius.inc da_detsurtyp.inc da_write_oa_rad_ascii.inc da_write_iv_rad_ascii.inc da_qc_mhs.inc da_qc_ssmis.inc da_qc_hirs.inc da_qc_amsub.inc da_qc_amsua.inc da_qc_airs.inc da_cloud_detect_airs.inc da_cloud_sim.inc da_qc_seviri.inc da_qc_iasi.inc da_cloud_detect_iasi.inc da_qc_crtm.inc da_predictor_crtm.inc da_predictor_rttov.inc da_write_biasprep.inc da_biasprep.inc da_read_biascoef.inc da_biascorr.inc da_residual_rad.inc da_jo_and_grady_rad.inc gsi_constants.o da_tracing.o da_tools_serial.o da_tools.o da_statistics.o da_reporting.o da_par_util1.o da_par_util.o module_dm.o da_define_structures.o da_control.o module_radiance.o da_qc_amsr2.inc da_qc_goesimg.inc da_rain.o : da_rain.f90 da_calculate_grady_rain.inc da_get_innov_vector_rain.inc da_get_hr_rain.inc da_check_max_iv_rain.inc da_transform_xtoy_rain_adj.inc da_transform_xtoy_rain.inc da_print_stats_rain.inc da_oi_stats_rain.inc da_residual_rain.inc da_jo_and_grady_rain.inc da_ao_stats_rain.inc da_tracing.o da_tools.o da_statistics.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_recursive_filter.o : da_recursive_filter.f90 da_apply_rf_adj.inc da_apply_rf.inc da_apply_rf_1v_adj.inc da_apply_rf_1v.inc da_transform_through_rf_adj.inc da_transform_through_rf.inc da_recursive_filter_1d_adj.inc da_recursive_filter_1d.inc da_calculate_rf_factors.inc da_transform_through_rf_dual_res.inc da_transform_through_rf_adj_dual_res.inc da_perform_2drf.inc da_rf_cv3.o da_rfz_cv3.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_domain.o @@ -151,7 +151,7 @@ da_reporting.o : da_reporting.f90 da_message2.inc da_message.inc da_warning.inc da_rf_cv3.o : da_rf_cv3.f90 da_mat_cv3.o da_rfz_cv3.o : da_rfz_cv3.f90 da_rsl_interfaces.o : da_rsl_interfaces.f90 -da_rttov.o : da_rttov.f90 da_rttov_ad.inc da_rttov_tl.inc da_rttov_direct.inc da_rttov_init.inc da_transform_xtoy_rttov_adj.inc da_transform_xtoy_rttov.inc da_get_innov_vector_rttov.inc da_rttov_k.inc da_wrf_interfaces.o da_tracing.o da_tools.o da_radiance1.o da_par_util.o da_tools_serial.o da_interpolation.o da_control.o module_radiance.o da_reporting.o module_domain.o da_define_structures.o +da_rttov.o : da_rttov.f90 da_rttov_ad.inc da_rttov_tl.inc da_rttov_direct.inc da_rttov_init.inc da_transform_xtoy_rttov_adj.inc da_transform_xtoy_rttov.inc da_get_innov_vector_rttov.inc da_rttov_k.inc da_wrf_interfaces.o da_tracing.o da_tools.o da_radiance1.o da_par_util.o da_tools_serial.o da_interpolation.o da_control.o module_radiance.o da_reporting.o module_domain.o da_define_structures.o da_physics.o da_satem.o : da_satem.f90 da_calculate_grady_satem.inc da_get_innov_vector_satem.inc da_check_max_iv_satem.inc da_transform_xtoy_satem_adj.inc da_transform_xtoy_satem.inc da_print_stats_satem.inc da_oi_stats_satem.inc da_residual_satem.inc da_jo_and_grady_satem.inc da_ao_stats_satem.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_par_util1.o da_par_util.o da_define_structures.o da_control.o module_domain.o da_setup_structures.o : da_setup_structures.f90 da_truncate_spectra.inc da_get_bins_info.inc da_write_kma_increments.inc da_write_increments_for_wrf_nmm_regional.inc da_write_increments.inc da_qfrmrh.inc da_cumulus.inc da_lcl.inc da_cloud_model.inc da_setup_runconstants.inc da_setup_obs_interp_wts.inc da_setup_obs_structures_madis.inc da_setup_obs_structures_bufr.inc da_setup_obs_structures_ascii.inc da_setup_obs_structures_rain.inc da_setup_obs_structures_radar.inc da_setup_obs_structures.inc da_setup_flow_predictors.inc da_setup_flow_predictors_para_read_opt1.inc da_chgvres.inc da_setup_cv.inc da_setup_be_nmm_regional.inc da_setup_be_regional.inc da_setup_be_ncep_gfs.inc da_setup_be_global.inc da_setup_background_errors.inc da_scale_background_errors.inc da_scale_background_errors_cv3.inc da_rescale_background_errors.inc da_interpolate_regcoeff.inc da_get_vertical_truncation.inc gsi_thinning.o module_radiance.o da_rf_cv3.o da_rfz_cv3.o da_vtox_transforms.o da_tracing.o da_tools.o da_tools_serial.o da_ssmi.o da_spectral.o da_recursive_filter.o da_reporting.o da_radiance.o da_par_util.o da_par_util1.o da_obs_io.o da_obs.o da_control.o da_wrf_interfaces.o da_define_structures.o module_domain.o da_wavelet.o da_chg_be_Vres.inc da_gen_eigen.inc da_eigen_to_covmatrix.inc da_setup_pseudo_obs.inc da_ships.o : da_ships.f90 da_calculate_grady_ships.inc da_get_innov_vector_ships.inc da_check_max_iv_ships.inc da_transform_xtoy_ships_adj.inc da_transform_xtoy_ships.inc da_print_stats_ships.inc da_oi_stats_ships.inc da_residual_ships.inc da_jo_and_grady_ships.inc da_ao_stats_ships.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o diff --git a/var/da/da_control/da_control.f90 b/var/da/da_control/da_control.f90 index 6f31cb9d0b..9d7869e4c3 100644 --- a/var/da/da_control/da_control.f90 +++ b/var/da/da_control/da_control.f90 @@ -51,7 +51,7 @@ module da_control real, parameter :: gravity = 9.81 ! m/s - value used in WRF. ! real, parameter :: earth_radius = 6378.15 real, parameter :: earth_radius = 6370.0 ! Be consistant with WRF - real, parameter :: satellite_height = 35800.0 ! used by da_get_satzen + real, parameter :: satellite_height = 35800.0 ! used by da_get_sat_angles ! real, parameter :: earth_omega = 2.0*pi/86400.0 ! Omega real, parameter :: earth_omega = 0.000072921 ! Omega 7.2921*10**-5 diff --git a/var/da/da_define_structures/da_define_structures.f90 b/var/da/da_define_structures/da_define_structures.f90 index 794d0b89b5..6cf085b001 100644 --- a/var/da/da_define_structures/da_define_structures.f90 +++ b/var/da/da_define_structures/da_define_structures.f90 @@ -489,6 +489,11 @@ module da_define_structures real, pointer :: vtox(:,:) end type cv_index_type + type cld_qc_type + real :: RTCT, RFMFT, RFMFT_ij(2), TEMPIR, RTCT_terr + real, allocatable :: CIRH2O(:,:,:) + end type cld_qc_type + type instid_type ! Instrument triplet, follow the convension of RTTOV integer :: platform_id, satellite_id, sensor_id @@ -519,6 +524,7 @@ module da_define_structures real, pointer :: satazi(:) real, pointer :: solzen(:) real, pointer :: solazi(:) + real, pointer :: tropt(:) real, pointer :: t(:,:) real, pointer :: q(:,:) real, pointer :: mr(:,:) @@ -594,6 +600,7 @@ module da_define_structures real, pointer :: ice_coverage(:) real, pointer :: snow_coverage(:) integer, pointer :: crtm_climat(:) ! CRTM only + type (cld_qc_type), pointer :: cld_qc(:) type (varbc_info_type) :: varbc_info type (varbc_type),pointer :: varbc(:) diff --git a/var/da/da_physics/da_physics.f90 b/var/da/da_physics/da_physics.f90 index b5bd689bab..f26300f83b 100644 --- a/var/da/da_physics/da_physics.f90 +++ b/var/da/da_physics/da_physics.f90 @@ -107,6 +107,7 @@ module da_physics #include "da_integrat_dz.inc" #include "da_uv_to_sd_lin.inc" #include "da_uv_to_sd_adj.inc" +#include "da_trop_wmo.inc" end module da_physics diff --git a/var/da/da_physics/da_trop_wmo.inc b/var/da/da_physics/da_trop_wmo.inc new file mode 100644 index 0000000000..912311b6e5 --- /dev/null +++ b/var/da/da_physics/da_trop_wmo.inc @@ -0,0 +1,114 @@ +subroutine da_trop_wmo (t, z, p, nlev, tropt, tropp, tropk) + + !---------------------------------------------------------------------------- + ! * Computes tropopause T, P, and/or level based on code from Cameron Homeyer + ! and WMO definition + ! + ! * WMO tropopause definition: + ! The boundary between the troposphere and the stratosphere, where an + ! abrupt change in lapse rate usually occurs. It is defined as the lowest + ! level at which the lapse rate decreases to 2 °C/km or less, provided + ! that the average lapse rate between this level and all higher levels + ! within 2 km does not exceed 2 °C/km. + !---------------------------------------------------------------------------- + + implicit none + + ! Assumed shape inputs for single column (size=nlev) + ! ordered from bottom to top of model + real, intent(in) :: t(:) ! Temperature, K. (3D) + +!JJG: "z" is supposed to be height, not geopotential height. Does it matter? + real, intent(in) :: z(:) ! Geopotential height above m.s.l., m. + real, intent(in) :: p(:) ! Pressure, mb. + real, optional, intent(out) :: tropt ! Tropopause temperature, K. + real, optional, intent(out) :: tropp ! Tropopause pressure, mb. + integer, optional, intent(out) :: tropk + integer, intent(in) :: nlev + + real :: dtdz + integer :: dtdztest(nlev), ztest(nlev) + integer :: i, j, k, kk, ktrop + +! real, parameter :: tropz_min = 5000.0 +! real, parameter :: tropz_max = 19000.0 + + if (.not.present(tropt) .and. & + .not.present(tropp) .and. & + .not.present(tropk)) return + + if (present(tropt)) tropt = missing_r + if (present(tropp)) tropp = missing_r + + !Loop over levels to find tropopause (single column) + ktrop = nlev-1 + trop_loop: do k = 1, nlev-1 + if ( p(k) .le. 500.0 ) then + ! Compute lapse rate (-dT/dz) + dtdz = ( t(k+1) - t(k) ) / & + ( z(k) - z(k+1) ) + else + ! Set lapse rate for p > 500 hPa + dtdz = 999.9 + endif + !Check if local lapse rate <= 2 K/km + if (dtdz .le. 0.002) then + ! Initialize lapse rate and altitude test arrays + dtdztest = 0 + ztest = 0 + + ! Compute average lapse rate across levels above current candidate + do kk = k+1, nlev-1 + dtdz = ( t(kk+1) - t(k) ) / & + ( z(k) - z(kk+1) ) + + !If avg. lapse rate <= 2 K/km and z <= trop + 2 km, set pass flag + if ( ( dtdz .le. 0.002 ) .and. & + ( (z(k) - z(kk)) .le. 2000. ) ) THEN + dtdztest(kk) = 1 + endif + + ! If z <= trop + 2 km, set pass flag + IF ( (z(k) - z(kk)) .le. 2000.0 ) THEN + ztest(kk) = 1 + endif + enddo !kk loop + + IF (SUM(dtdztest) .eq. SUM(ztest)) THEN + ! If qualified as tropopause, set altitude index and return value + ktrop = k + exit trop_loop + ENDIF + ENDIF + end do trop_loop + +! ! Filter ktrop using tpause height thresholds +! ztest = 0 +! if ( z(ktrop) .gt. tropz_max ) then +! where ( z.le.tropz_max ) +! ztest = 1 +! end where +! do k = nlev, 1, -1 +! if (ztest(k) .eq. 1) then +! ktrop = k +! exit +! end if +! end do +! else if ( z(ktrop) .lt. tropz_min ) then +! where ( z.ge.tropz_min ) +! ztest = 1 +! end where +! do k = 1, nlev +! if (ztest(k) .eq. 1) then +! ktrop = k +! exit +! end if +! end do +! end if + + if (present(tropt)) tropt = t(ktrop) + if (present(tropp)) tropp = p(ktrop) + if (present(tropk)) tropk = ktrop + +end subroutine da_trop_wmo + diff --git a/var/da/da_radiance/da_allocate_rad_iv.inc b/var/da/da_radiance/da_allocate_rad_iv.inc index c4f5b61b81..8c7ae62665 100644 --- a/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/var/da/da_radiance/da_allocate_rad_iv.inc @@ -101,7 +101,9 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate (iv%instid(i)%satazi(iv%instid(i)%num_rad)) allocate (iv%instid(i)%solzen(iv%instid(i)%num_rad)) allocate (iv%instid(i)%solazi(iv%instid(i)%num_rad)) + allocate (iv%instid(i)%tropt(iv%instid(i)%num_rad)) allocate (iv%instid(i)%gamma_jacobian(nchan,iv%instid(i)%num_rad)) + if ( use_clddet_zz ) allocate (iv%instid(i)%cld_qc(iv%instid(i)%num_rad)) if ( use_rttov_kmatrix .or. use_crtm_kmatrix ) then allocate(iv%instid(i)%ts_jacobian(nchan,iv%instid(i)%num_rad)) allocate(iv%instid(i)%ps_jacobian(nchan,iv%instid(i)%num_rad)) diff --git a/var/da/da_radiance/da_crtm.f90 b/var/da/da_radiance/da_crtm.f90 index e73a1d548d..6e35c46fe3 100644 --- a/var/da/da_radiance/da_crtm.f90 +++ b/var/da/da_radiance/da_crtm.f90 @@ -36,11 +36,12 @@ module da_crtm use_crtm_kmatrix, use_varbc, freeze_varbc, use_pseudo_rad, & use_antcorr, time_slots, use_satcv, use_simulated_rad, simulated_rad_io, & simulated_rad_ngrid, interp_option, use_mspps_emis, use_mspps_ts, calc_weightfunc, & - use_clddet_ecmwf,its,ite,jts,jte, & + use_clddet_ecmwf, use_clddet_zz, its,ite,jts,jte, & crtm_coef_path, crtm_irwater_coef, crtm_mwwater_coef, crtm_irland_coef, crtm_visland_coef, & cloud_cv_options use da_interpolation, only : da_interp_lin_2d_partial,da_interp_lin_2d_adj_partial, & da_interp_2d_partial + use da_physics, only: da_trop_wmo use module_dm, only : wrf_dm_sum_real, wrf_dm_sum_reals use da_radiance1, only : da_biasprep,da_detsurtyp,da_biascorr, & da_biasprep,da_cld_eff_radius, da_mspps_emis, da_mspps_ts diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index 38a7d3c0a7..8858680666 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -124,7 +124,15 @@ deallocate (iv%instid(i)%satazi) deallocate (iv%instid(i)%solzen) deallocate (iv%instid(i)%solazi) - deallocate (iv%instid(i)%gamma_jacobian) + deallocate (iv%instid(i)%tropt) + if ( use_clddet_zz ) then + do n = 1,iv%instid(i)%num_rad + if ( allocated (iv%instid(i)%cld_qc(n)%CIRH2O) ) & + deallocate (iv%instid(i)%cld_qc(n)%CIRH2O) + end do + deallocate (iv%instid(i)%cld_qc) + deallocate (iv%instid(i)%gamma_jacobian) + end if if (ANY(use_satcv)) then if (use_satcv(2)) then diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index 403337a44a..ad83747172 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -91,9 +91,15 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) real, allocatable :: hessian(:,:) real*8, allocatable :: eignvec(:,:), eignval(:) real :: rad_clr, rad_ovc_ilev, rad_ovc_jlev - + integer :: Band_Size(5), Bands(AIRS_Max_Channels,5) - + + !For Zhuge and Zou cloud detection + real, allocatable :: geoht_full(:,:,:) + real :: geoht_pixel(kts:min(kte,kme-1)) + real :: tt_pixel(kts:min(kte,kme-1)) + real :: pp_pixel(kts:min(kte,kme-1)) + Band_Size(1:5) = (/86, 0, 0, 16, 0 /) Bands(:,:) = 0 Bands(1:Band_Size(1),1) = & @@ -196,6 +202,18 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) wrf_to_crtm_mw = igbp_to_crtm_mw end if + if ( use_clddet_zz ) then + allocate ( geoht_full(ims:ime,jms:jme,kms:kme-1) ) + do k = kms, kme-1 + do j = jms, jme + do i = ims, ime + geoht_full(i,j,k) = 0.5 * ( grid%ph_2(i,j,k) + grid%phb(i,j,k) + & + grid%ph_2(i,j,k+1) + grid%phb(i,j,k+1) ) / gravity + end do + end do + end do + end if + !------------------------------------------------------ ! [1.0] calculate the background bright temperature !------------------------------------------------------- @@ -417,6 +435,16 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) end if end do + if (use_clddet_zz) then + ! Find tropopause temperature for Zhuge and Zou Cloud Detection + do k = kts, min(kte,kme-1) + tt_pixel(k) = Atmosphere(1)%Temperature(kte-k+1) + pp_pixel(k) = Atmosphere(1)%Pressure(kte-k+1) + call da_interp_2d_partial ( geoht_full(:,:,k), iv%instid(inst)%info, k, n, n, geoht_pixel(k) ) + end do + call da_trop_wmo ( tt_pixel, geoht_pixel, pp_pixel, (min(kte,kme-1)-kts+1), tropt = iv%instid(inst)%tropt(n) ) + end if + call da_interp_2d_partial (grid%xb%u10, iv%instid(inst)%info, 1, n, n, model_u10(n:n)) call da_interp_2d_partial (grid%xb%v10, iv%instid(inst)%info, 1, n, n, model_v10(n:n)) call da_interp_2d_partial (grid%xb%psfc, iv%instid(inst)%info, 1, n, n, model_psfc(n:n)) @@ -489,7 +517,8 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) ! CRTM GeometryInfo Structure GeometryInfo(1)%Sensor_Zenith_Angle=iv%instid(inst)%satzen(n) - GeometryInfo(1)%Source_Zenith_Angle=iv%instid(inst)%solzen(n) + if (.not. use_clddet_zz) & + GeometryInfo(1)%Source_Zenith_Angle=iv%instid(inst)%solzen(n) GeometryInfo(1)%iFOV=iv%instid(inst)%scanpos(n) ! GeometryInfo(1)%Satellite_Height=830.0 ! GeometryInfo(1)%Sensor_Scan_Angle= @@ -921,6 +950,8 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) deallocate (wrf_to_crtm_mw) + if ( use_clddet_zz ) deallocate ( geoht_full ) + call CRTM_Atmosphere_Destroy (Atmosphere) IF ( CRTM_Atmosphere_Associated( Atmosphere(1) ) ) & call da_error(__FILE__,__LINE__, & 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 d18f57fb16..b610cd9b72 100644 --- a/var/da/da_radiance/da_get_innov_vector_rttov.inc +++ b/var/da/da_radiance/da_get_innov_vector_rttov.inc @@ -49,12 +49,30 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) real, allocatable :: em_mspps(:) ! emissivity caluclated using MSPPS algorithm real :: ts_mspps ! surface temperature calcualted using MSPPS algorithm + !For Zhuge and Zou cloud detection + real, allocatable :: geoht_full(:,:,:) + real :: geoht_pixel(kts:min(kte,kme-1)) + real :: tt_pixel(kts:min(kte,kme-1)) + real :: pp_pixel(kts:min(kte,kme-1)) + if (trace_use) call da_trace_entry("da_get_innov_vector_rttov") !------------------------------------------------------ ! [1.0] calculate the background bright temperature !------------------------------------------------------- + if ( use_clddet_zz ) then + allocate ( geoht_full(ims:ime,jms:jme,kms:kme-1) ) + do k = kms, kme-1 + do j = jms, jme + do i = ims, ime + geoht_full(i,j,k) = 0.5 * ( grid%ph_2(i,j,k) + grid%phb(i,j,k) + & + grid%ph_2(i,j,k+1) + grid%phb(i,j,k+1) ) / gravity + end do + end do + end do + end if + do inst = 1, iv%num_inst ! loop for sensor if ( iv%instid(inst)%num_rad < 1 ) cycle nlevels = iv%instid(inst)%nlevels @@ -99,7 +117,6 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) call da_interp_lin_3d (grid%xb%t, iv%instid(inst)%info, iv%instid(inst)%t (:,n1:n2)) call da_interp_lin_3d (grid%xb%q, iv%instid(inst)%info, iv%instid(inst)%mr(:,n1:n2)) - do n= n1,n2 do k=1, nlevels if (iv%instid(inst)%info%zk(k,n) <= 0.0) then @@ -132,6 +149,19 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) iv%instid(inst)%surftype(n) = 0 end if + if (use_clddet_zz) then + ! Find tropopause temperature for Zhuge and Zou Cloud Detection + do k = kts, min(kte,kme-1) + call da_interp_2d_partial ( grid%xb%t(:,:,k), iv%instid(inst)%info, k, n, n, tt_pixel(k) ) + call da_interp_2d_partial ( grid%xb%p(:,:,k), iv%instid(inst)%info, k, n, n, pp_pixel(k) ) + call da_interp_2d_partial ( geoht_full(:,:,k), iv%instid(inst)%info, k, n, n, geoht_pixel(k) ) + +! call da_interp_lin_2d ( grid%xb%t(:,:,k), iv%instid(inst)%info, k, n, n, tt_pixel(k) ) +! call da_interp_lin_2d ( grid%xb%p(:,:,k), iv%instid(inst)%info, k, n, n, pp_pixel(k) ) +! call da_interp_lin_2d ( geoht_full(:,:,k), iv%instid(inst)%info, k, n, n, geoht_pixel(k) ) + end do + call da_trop_wmo ( tt_pixel, geoht_pixel, pp_pixel, (min(kte,kme-1)-kts+1), tropt = iv%instid(inst)%tropt(n) ) + end if end do call da_interp_lin_2d (grid%xb % u10, iv%instid(inst)%info, 1, iv%instid(inst)%u10(n1:n2)) @@ -381,6 +411,8 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) end do ! end loop for sensor + if ( use_clddet_zz ) deallocate ( geoht_full ) + if (trace_use) call da_trace_exit("da_get_innov_vector_rttov") #else call da_error(__FILE__,__LINE__, & diff --git a/var/da/da_radiance/da_get_sat_angles.inc b/var/da/da_radiance/da_get_sat_angles.inc new file mode 100644 index 0000000000..440d13e8f3 --- /dev/null +++ b/var/da/da_radiance/da_get_sat_angles.inc @@ -0,0 +1,100 @@ +subroutine da_get_sat_angles ( lat, lon, sate_index, satzen, satazi ) +!------------------------------------------------- +! Purpose: calculate geostationary satellite_zenith_angle +! +! Menthod: Yang et al., 2017: Impact of assimilating GOES imager +! clear-sky radiance with a rapid refresh assimilation +! system for convection-permitting forecast over Mexico. +! J. Geophys. Res. Atmos., 122, 5472–5490 +!------------------------------------------------- + + implicit none + + real, intent(in) :: lat,lon + integer, intent(in) :: sate_index + real, intent(out) :: satzen + real, optional, intent(out) :: satazi + + real(r_double) :: alat, alon, alon_sat + real(r_double) :: theta, r_tmp, theta_tmp, gam, beta + + satzen = missing_r + if ( present( satazi ) ) satazi = missing_r + + if ( lat .ge. 90. .or. & + lat .le. -90. .or. & + lon .gt. 180. .or. & + lon .lt. -180. ) then + return + end if + + if (sate_index .eq. 11) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 12) then + alon_sat = -60. * deg2rad + else if (sate_index .eq. 13) then + alon_sat = -75. * deg2rad + else if (sate_index .eq. 14) then + alon_sat = -105. * deg2rad + else if (sate_index .eq. 15) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 16) then +! alon_sat = -75.2 * deg2rad !True Value? + alon_sat = -75. * deg2rad !Nominal Value +! else if (sate_index .eq. 17) then +! alon_sat = -137. * deg2rad + else + write(*,*)'this satellite is not included' + stop + end if + + alat = lat * deg2rad + alon = lon * deg2rad + theta = alon-alon_sat + + ! Yang et al., 2017 + + ! zenith +! r_tmp = (2*earth_radius*sin(abs(theta)/2.)-earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 & +! +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 +! r_tmp = sqrt(r_tmp) +! satzen = 2*asin(r_tmp/earth_radius/2.) +! theta_tmp = atan(earth_radius*sin(satzen)/(satellite_height+earth_radius*(1-sin(satzen)))) +! satzen = (satzen+theta_tmp) / deg2rad !to degrees + + + ! Soler et al., Determination of Look Angles to Geostationary Communication Satellites, + ! Journal of Surveying Engineering, Vol. 120, No. 3, August, 1994. + ! follows spherical earth approximation + + ! zenith (up to 1 deg difference with code from Yang et al., 2017) + gam = acos( cos( alat ) * cos( abs( theta ) ) ) + r_tmp = ( satellite_height+earth_radius )**2 * & + ( 1.d0 + ( earth_radius / ( satellite_height+earth_radius ) )**2 - & + 2.d0 * ( earth_radius ) / ( satellite_height+earth_radius ) * cos(gam) ) + + if (r_tmp .lt. 0) return + + r_tmp = sqrt(r_tmp) + satzen = asin((satellite_height+earth_radius) / r_tmp * sin(gam)) / deg2rad !to degrees + + + ! azimuth + if ( present(satazi) ) then + beta = tan(alat) / tan(gam) + if (beta.gt.1.D0 .and. beta.lt.1.00000001D0) beta = 1.0D0 + beta = acos( beta ) / deg2rad !to degrees + + if ( lat.lt.0. .and. theta.le.0. ) & + satazi = beta + if ( lat.ge.0. .and. theta.le.0. ) & + satazi = 180.d0 - beta + if ( lat.ge.0. .and. theta.gt.0. ) & + satazi = 180.d0 + beta + if ( lat.lt.0. .and. theta.gt.0. ) & + satazi = 360.d0 - beta + end if + + return + +end subroutine da_get_sat_angles diff --git a/var/da/da_radiance/da_get_sat_angles_1d.inc b/var/da/da_radiance/da_get_sat_angles_1d.inc new file mode 100644 index 0000000000..a7d4e4385c --- /dev/null +++ b/var/da/da_radiance/da_get_sat_angles_1d.inc @@ -0,0 +1,133 @@ +subroutine da_get_sat_angles_1d ( lat, lon, sate_index, satzen, satazi ) +!------------------------------------------------- +! Purpose: calculate geostationary satellite_zenith_angle +! +! Method: Yang et al., 2017: Impact of assimilating GOES imager +! clear-sky radiance with a rapid refresh assimilation +! system for convection-permitting forecast over Mexico. +! J. Geophys. Res. Atmos., 122, 5472–5490 +!------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:),lon(:) + integer, intent(in) :: sate_index + real, intent(out) :: satzen(:) + real, optional, intent(out) :: satazi(:) + + integer :: n + real(r_double) :: alon_sat + real(r_double), allocatable :: alat(:), alon(:) + real(r_double), allocatable :: theta(:), r_tmp(:), theta_tmp(:), gam(:) + real(r_double), allocatable :: beta(:) + logical, allocatable :: valid_loc(:) + + satzen = missing_r + if (present(satazi)) satazi = missing_r + + n = size(lat) + if (n.le.0) return + + allocate( alat(n) ) + allocate( alon(n) ) + allocate( theta(n) ) + allocate( r_tmp(n) ) + allocate( theta_tmp(n) ) + allocate( gam(n) ) + allocate( valid_loc(n) ) + + !Define valid locations for vectorized operations + valid_loc = ( lat .lt. 90. .and. & + lat .gt. -90. .and. & + lon .le. 180. .and. & + lon .ge. -180. ) + + if (sate_index .eq. 11) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 12) then + alon_sat = -60. * deg2rad + else if (sate_index .eq. 13) then + alon_sat = -75. * deg2rad + else if (sate_index .eq. 14) then + alon_sat = -105. * deg2rad + else if (sate_index .eq. 15) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 16) then +! alon_sat = -75.2 * deg2rad !True Value? + alon_sat = -75. * deg2rad !Nominal Value +! else if (sate_index .eq. 17) then +! alon_sat = -137. * deg2rad + else + write(*,*)'this satellite is not included' + stop + end if + + where ( valid_loc ) + alat = lat * deg2rad + alon = lon * deg2rad + theta = alon - alon_sat + elsewhere + alat = missing_r + alon = missing_r + theta = missing_r + gam = missing_r + r_tmp = missing_r + end where + + ! Yang et al., 2017 + ! zenith +! r_tmp = (2*earth_radius*sin(abs(theta)/2.)-earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 & +! +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 +! r_tmp = sqrt(r_tmp) +! satzen = 2*asin(r_tmp/earth_radius/2.) +! theta_tmp = atan(earth_radius*sin(satzen)/(satellite_height+earth_radius*(1-sin(satzen)))) +! satzen = (satzen+theta_tmp) / deg2rad !to degrees + + + ! Soler et al., Determination of Look Angles to Geostationary Communication Satellites, + ! Journal of Surveying Engineering, Vol. 120, No. 3, August, 1994. + ! follows spherical earth approximation + + ! zenith (up to 1 deg difference with code from Yang et al., 2017) + where ( valid_loc ) + gam = acos( cos( alat ) * cos( abs( theta ) ) ) + r_tmp = ( satellite_height+earth_radius )**2 * & + ( 1.d0 + ( earth_radius / ( satellite_height+earth_radius ) )**2 - & + 2.d0 * ( earth_radius ) / ( satellite_height+earth_radius ) * cos( gam ) ) + end where + + valid_loc = (valid_loc .and. r_tmp.ge.0) + + where ( valid_loc ) + r_tmp = sqrt(r_tmp) + satzen = asin((satellite_height+earth_radius) / r_tmp * sin(gam)) / deg2rad !to degrees + end where + + + ! azimuth + if ( present(satazi) ) then + allocate( beta(n) ) + beta = missing_r + where ( valid_loc ) & + beta = tan(alat) / tan(gam) + where ( beta.gt.1._r_double .and. & + beta.lt.1.00000001_r_double .and. valid_loc ) & + beta = 1.0_r_double + where ( valid_loc ) & + beta = acos( beta ) / deg2rad !to degrees + where ( lat.lt.0. .and. theta.le.0. .and. valid_loc ) & + satazi = beta + where ( lat.ge.0. .and. theta.le.0. .and. valid_loc ) & + satazi = 180.d0 - beta + where ( lat.ge.0. .and. theta.gt.0. .and. valid_loc ) & + satazi = 180.d0 + beta + where ( lat.lt.0. .and. theta.gt.0. .and. valid_loc ) & + satazi = 360.d0 - beta + deallocate( beta ) + end if + + deallocate( alat, alon, theta, r_tmp, theta_tmp, gam, valid_loc ) + + return + +end subroutine da_get_sat_angles_1d diff --git a/var/da/da_radiance/da_get_satzen.inc b/var/da/da_radiance/da_get_satzen.inc deleted file mode 100644 index 2be286eb9b..0000000000 --- a/var/da/da_radiance/da_get_satzen.inc +++ /dev/null @@ -1,66 +0,0 @@ -subroutine da_get_satzen ( lat,lon,sate_index,theta_true ) -!------------------------------------------------- -! Purpose: calculate geostationary satellite_zenith_angle -! -! Menthod: Yang et al., 2017: Impact of assimilating GOES imager -! clear-sky radiance with a rapid refresh assimilation -! system for convection-permitting forecast over Mexico. -! J. Geophys. Res. Atmos., 122, 5472–5490 -!------------------------------------------------- - - implicit none - - real, intent(in) :: lat,lon - integer, intent(in) :: sate_index - real, intent(out) :: theta_true - - real :: alat, alon, alon_sat - real :: theta, r_tmp, theta_tmp, gam - - alat = lat - alon = lon - - if (sate_index .eq. 11) then - alon_sat = -135.*pi/180. - else if (sate_index .eq. 12) then - alon_sat = -60.*pi/180. - else if (sate_index .eq. 13) then - alon_sat = -75.*pi/180. - else if (sate_index .eq. 14) then - alon_sat = -105.*pi/180. - else if (sate_index .eq. 15) then - alon_sat = -135.*pi/180. - else if (sate_index .eq. 16) then -! alon_sat = -75.2*pi/180. !True Value? - alon_sat = -75.*pi/180. !Nominal Value -! else if (sate_index .eq. 17) then -! alon_sat = -137.*pi/180. - else - write(*,*)'this satellite is not included' - stop - end if - - alat = alat*pi/180. - alon = alon*pi/180. - theta = abs(alon-alon_sat) -! r_tmp = (2*earth_radius*sin(theta/2.)-earth_radius*(1-cos(alat))*sin(theta/2.))**2 & -! +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(theta/2.))**2 -! r_tmp = sqrt(r_tmp) -! theta_true = 2*asin(r_tmp/earth_radius/2.) -! theta_tmp = atan(earth_radius*sin(theta_true)/(satellite_height+earth_radius*(1-sin(theta_true)))) -! theta_true = (theta_true+theta_tmp)*180./pi - - - !ZENITH, FROM SOLER et al., 1994 (spherical) (up to 1 deg difference with above code) - gam = acos( cos(alat) * cos(theta) ) - r_tmp = (satellite_height+earth_radius)**2 * ( 1.d0 + ( earth_radius / (satellite_height+earth_radius) )**2 - 2.d0 * (earth_radius) / (satellite_height+earth_radius) * cos(gam) ) - - theta_true = missing_r - if (r_tmp .lt. 0) return - - r_tmp = sqrt(r_tmp) - theta_true = asin((satellite_height+earth_radius) / r_tmp * sin(gam)) * 180.d0 / pi - - return - -end subroutine da_get_satzen diff --git a/var/da/da_radiance/da_get_satzen_1d.inc b/var/da/da_radiance/da_get_satzen_1d.inc deleted file mode 100644 index df1f6249b7..0000000000 --- a/var/da/da_radiance/da_get_satzen_1d.inc +++ /dev/null @@ -1,84 +0,0 @@ -subroutine da_get_satzen_1d ( lat,lon,sate_index,theta_true ) -!------------------------------------------------- -! Purpose: calculate geostationary satellite_zenith_angle -! -! Menthod: Yang et al., 2017: Impact of assimilating GOES imager -! clear-sky radiance with a rapid refresh assimilation -! system for convection-permitting forecast over Mexico. -! J. Geophys. Res. Atmos., 122, 5472–5490 -!------------------------------------------------- - - implicit none - - real, intent(in) :: lat(:),lon(:) - integer, intent(in) :: sate_index - real, intent(out) :: theta_true(:) - - integer :: n - real :: alon_sat - real, allocatable :: alat(:), alon(:) - real, allocatable :: theta(:), r_tmp(:), theta_tmp(:), gam(:) - - n = size(lat) - allocate( alat(n) ) - allocate( alon(n) ) - allocate( theta(n) ) - allocate( r_tmp(n) ) - allocate( theta_tmp(n) ) - allocate( gam(n) ) - - alat = lat - alon = lon - - if (sate_index .eq. 11) then - alon_sat = -135.*pi/180. - else if (sate_index .eq. 12) then - alon_sat = -60.*pi/180. - else if (sate_index .eq. 13) then - alon_sat = -75.*pi/180. - else if (sate_index .eq. 14) then - alon_sat = -105.*pi/180. - else if (sate_index .eq. 15) then - alon_sat = -135.*pi/180. - else if (sate_index .eq. 16) then -! alon_sat = -75.2*pi/180. !True Value? - alon_sat = -75.*pi/180. !Nominal Value -! else if (sate_index .eq. 17) then -! alon_sat = -137.*pi/180. - else - write(*,*)'this satellite is not included' - stop - end if - - alat = alat*pi/180. - alon = alon*pi/180. - theta = abs(alon-alon_sat) -! r_tmp = (2*earth_radius*sin(theta/2.)-earth_radius*(1-cos(alat))*sin(theta/2.))**2 & -! +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(theta/2.))**2 -! r_tmp = sqrt(r_tmp) -! theta_true = 2*asin(r_tmp/earth_radius/2.) -! theta_tmp = atan(earth_radius*sin(theta_true)/(satellite_height+earth_radius*(1-sin(theta_true)))) -! theta_true = (theta_true+theta_tmp)*180./pi - - - theta_true = missing_r - - where ( lat.ne.missing_r ) - !ZENITH, FROM SOLER et al., 1994 (spherical) (up to 1 deg difference with above code) - gam = acos( cos( alat ) * cos( theta ) ) - r_tmp = (satellite_height+earth_radius)**2 * ( 1.d0 + ( earth_radius / (satellite_height+earth_radius) )**2 - 2.d0 * (earth_radius) / (satellite_height+earth_radius) * cos( gam ) ) - end where - - where ( r_tmp.ge.0 .and. lat.ne.missing_r ) - - r_tmp = sqrt(r_tmp) - - theta_true = asin((satellite_height+earth_radius) / r_tmp * sin(gam)) * 180.d0 / pi - - end where - - deallocate( alat, alon, theta, r_tmp, theta_tmp, gam ) - - return - -end subroutine da_get_satzen_1d diff --git a/var/da/da_radiance/da_get_solar_angles.inc b/var/da/da_radiance/da_get_solar_angles.inc new file mode 100644 index 0000000000..b91f13cf79 --- /dev/null +++ b/var/da/da_radiance/da_get_solar_angles.inc @@ -0,0 +1,193 @@ +subroutine da_get_solar_angles( yr, mt, dy, hr, mn, sc, & + lat, lon, solzen, solazi ) + !--------------------------------------------------------------------------------+ + ! This subroutine calculates the local azimuth and zenith angles of the sun at | + ! a specific location and time using an approximation to equations used | + ! to generate tables in The Astronomical Almanac. | + ! Refraction correction is added so sun position is apparent one. | + ! | + ! Michalsky, Joseph J., The Astronomical Almanac's algorithm for approximate | + ! solar position (1950-2050), Solar Energy, Vol. 40, No. 3, pp227-235, 1988. | + ! | + ! AND | + ! | + ! U.S. Gov't Printing Office, Washington,D.C. (1985). | + ! | + ! Provides solar zenith and azimuth angles with errors within ±0.01 deg. | + ! for the time period 1950-2050. | + ! | + ! INPUT parameters | + ! yr, mt, dy, hr, mn, sc = integer date/time quantities | + ! lat = latitude in degrees (north is positive) | + ! lon = longitude in degrees (east is positive) | + ! | + ! OUTPUT parameters | + ! solazi = sun azimuth angle (measured east from north, 0 to 360 degs) | + ! solzen = sun elevation angle (degs) | + ! | + ! Converted from F77 to F90 by Juan Pablo Justiniano | + ! (https://github.com/jpjustiniano/Subroutines) | + ! | + ! For more accurate algorithms (±0.0003 deg.) across longer periods of time, | + ! refer to the National Renewable Energy Laboratory (NREL) Solar Postion | + ! Algorithm (SPA), available in C, Matlab, and Python: | + ! - https://rredc.nrel.gov/solar/codesandalgorithms/spa | + ! - https://www.mathworks.com/matlabcentral/fileexchange/59903-nrel-s-solar-position-algorithm-spa | + ! - https://sunpy.org | + !--------------------------------------------------------------------------------+ + + implicit none + + integer, intent(in) :: yr, mt, dy, hr, mn, sc + real, intent(in) :: lat + real, intent(in) :: lon + real, intent(out) :: solazi + real, intent(out) :: solzen + + real(r_double) :: latrad + real(r_double) :: delta, ju, jmod, time, gmst, lmst + real(r_double) :: mnlon, mnanom, eclon, oblqec + real(r_double) :: num, den, ra, dec, ha + real(r_double) :: elev, elc, refrac + + ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:12:00 (see da_get_julian_time) + real(r_double), parameter :: jd_jmod = 43510.0 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + +! ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:00:00 (see da_get_julian_time) +! real(r_double), parameter :: jd_jmod = 43509.5 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + + if ( lat .gt. 90. .or. & + lat .lt. -90. .or. & + lon .gt. 180. .or. & + lon .lt. -180. ) then + solzen = missing_r + solazi = missing_r + return + end if + + call da_get_julian_time( yr, mt, dy, hr, mn, jmod ) + ju = jmod / 1440.0 + real(sc,r_double) / 86400.0 + jd_jmod + + ! Calculate ecliptic coordinates (depends on time [days] since noon 1 Jan, 2000) + ! 51545.0 + 2.4e6 = noon 1 Jan, 2000 + time = ju - 51545.0 + + ! Force mean longitude between 0 and 360 degs + mnlon = 280.460 + 0.9856474 * time + mnlon = mod( mnlon, 360. ) + if ( mnlon.lt.0. ) mnlon = mnlon + 360. + + ! Mean anomaly in radians between 0 and 2*pi + mnanom = 357.528 + 0.9856003 * time + mnanom = mod( mnanom, 360. ) + if ( mnanom.lt.0. ) mnanom = mnanom + 360. + mnanom = mnanom * deg2rad + + ! Compute the ecliptic longitude and obliquity of ecliptic in radians + eclon = mnlon + 1.915*sin( mnanom ) + 0.020*sin( 2.*mnanom ) + eclon = mod( eclon, 360. ) + + if ( eclon.lt.0. ) eclon = eclon + 360. + + oblqec = 23.439 - 0.0000004*time + eclon = eclon * deg2rad + oblqec = oblqec * deg2rad + + ! Calculate right ascension and force between 0 and 2*pi + num = cos( oblqec ) * sin( eclon ) + den = cos( eclon ) + ra = atan( num/den ) + if ( den.lt.0 ) then + ra = ra + PI + elseif ( num.lt.0 ) then + ra = ra + 2.0*PI + endif + + ! Calculate declination in radians + dec = asin( sin( oblqec ) * sin( eclon ) ) + + ! Calculate Greenwich mean sidereal time in hours +! gmst = 6.697375 + 0.0657098242*time + real(hr,r_double) + real(mn,r_double) / 60. + real(sc,r_double) / 3600. + gmst = 6.697375 + 0.0657098242*time + real(hr * 3600 + mn * 60 + sc, r_double) / 3600. + + ! Hour not changed to sidereal time since 'time' includes the fractional day + gmst = mod( gmst, 24. ) + if ( gmst.lt.0. ) gmst = gmst + 24. + + ! Calculate local mean sidereal time in radians + lmst = gmst + lon / 15. + lmst = mod( lmst, 24. ) + if ( lmst.lt.0. ) lmst = lmst + 24. + lmst = lmst * 15. * deg2rad + + + ! Calculate hour angle in radians between -pi and pi + ha = lmst - ra + if ( ha .lt. -PI ) ha = ha + 2.0*PI + if ( ha .gt. PI ) ha = ha - 2.0*PI + + ! Change latitude to radians + latrad = lat * deg2rad + + ! From this point on: + ! mnlon in degs, gmst in hours, ju in days minus 2.4e6; + ! mnanom, eclon, oblqec, ra, lmst, and ha in radians + + ! Calculate elevation and azimuth + elev = asin( sin( dec ) * sin( latrad ) + cos( dec ) * cos( latrad ) * cos( ha ) ) + solazi = asin( -cos( dec ) * sin( ha ) / cos( elev ) ) + +!JJG: From J.P. Justiniano (not in Michalsky, causes differences with NREL SPA) +!! This puts azimuth between 0 and 2*pi radians +! if ( sin(dec) - sin(elev) * sin(latrad) .ge. 0. ) then +! if ( sin(solazi) .lt. 0. ) solazi = solazi + 2.0*PI +! else +! solazi = PI - solazi +! endif + + ! When solazi=90 degs, elev == elcritical = asin( sin(dec) / sin(latrad) ) + elc = asin( sin( dec ) / sin( latrad ) ) + if ( elev.ge.elc ) solazi = PI - solazi + if ( elev.le.elc .and. ha.gt.0. ) solazi = 2.0*PI + solazi + + ! Convert az to degs before returning + solazi = solazi / deg2rad + + ! Calculate refraction correction for US stan. atmosphere + ! (need to have elev in degs before calculating correction) + elev = elev / deg2rad + + !JJG: Added these bounds + !Keep elevation between -90. to +90. + if ( elev.lt.-90. ) & + elev = - (180. + elev) + if ( elev.gt.90. ) & + elev = 180. - elev + + +! ! Michalsky (1988) +! if ( elev.gt. - 0.56 ) then +! refrac = 3.51579 * ( 0.1594 + 0.0196*elev + 0.00002*elev**2 ) / & +! ( 1. + 0.505*elev + 0.0845*elev**2 ) +! else +! refrac = 0.56 +! endif + + !J.P. Justiniano (not in Michalsky, more accurate than above?) + if ( elev.ge.19.225 ) then + refrac = 0.00452 * 3.51823 / tan( elev*deg2rad ) + else if ( elev.gt.-0.766 .and. elev.lt.19.225 ) then + refrac = 3.51579 * ( 0.1594 + 0.0196 * elev + 0.00002*elev**2 ) / & + ( 1. + 0.505*elev + 0.0845*elev**2 ) + else + refrac = 0.0 + end if + + ! note that 3.51579=1013.25 mb/288.2 C + + elev = elev + refrac + + ! Convert elevation to topocentric zenith + solzen = 90.0 - elev + +end subroutine da_get_solar_angles diff --git a/var/da/da_radiance/da_get_solar_angles_1d.inc b/var/da/da_radiance/da_get_solar_angles_1d.inc new file mode 100644 index 0000000000..44547e191e --- /dev/null +++ b/var/da/da_radiance/da_get_solar_angles_1d.inc @@ -0,0 +1,228 @@ +subroutine da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & + lat, lon, solzen, solazi ) + !--------------------------------------------------------------------------------+ + ! This subroutine calculates the local azimuth and zenith angles of the sun at | + ! a specific location and time using an approximation to equations used | + ! to generate tables in The Astronomical Almanac. | + ! Refraction correction is added so sun position is apparent one. | + ! | + ! Michalsky, Joseph J., The Astronomical Almanac's algorithm for approximate | + ! solar position (1950-2050), Solar Energy, Vol. 40, No. 3, pp227-235, 1988. | + ! | + ! AND | + ! | + ! U.S. Gov't Printing Office, Washington,D.C. (1985). | + ! | + ! Provides solar zenith and azimuth angles with errors within ±0.01 deg. | + ! for the time period 1950-2050. | + ! | + ! INPUT parameters | + ! yr, mt, dy, hr, mn, sc = integer date/time quantities | + ! lat = latitude in degrees (north is positive) | + ! lon = longitude in degrees (east is positive) | + ! | + ! OUTPUT parameters | + ! solazi = sun azimuth angle (measured east from north, 0 to 360 degs) | + ! solzen = sun elevation angle (degs) | + ! | + ! Converted from F77 to F90 by Juan Pablo Justiniano | + ! (https://github.com/jpjustiniano/Subroutines) | + ! | + ! For more accurate algorithms (±0.0003 deg.) across longer periods of time, | + ! refer to the National Renewable Energy Laboratory (NREL) Solar Postion | + ! Algorithm (SPA), available in C, Matlab, and Python: | + ! - https://rredc.nrel.gov/solar/codesandalgorithms/spa | + ! - https://www.mathworks.com/matlabcentral/fileexchange/59903-nrel-s-solar-position-algorithm-spa | + ! - https://sunpy.org | + !--------------------------------------------------------------------------------+ + + implicit none + + integer, intent(in) :: yr, mt, dy, hr, mn, sc + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + real, intent(out) :: solazi(:) + real, intent(out) :: solzen(:) + + real(r_double), allocatable :: latrad(:) + real(r_double) :: delta, ju, jmod, time, gmst + + real(r_double), allocatable :: lmst(:), ha(:) + real(r_double) :: mnlon, mnanom, eclon, oblqec + real(r_double) :: num, den, ra, dec + real(r_double), allocatable :: elev(:), elc(:), refrac(:) + logical, allocatable :: valid_loc(:) + + ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:12:00 (see da_get_julian_time) + real(r_kind), parameter :: jd_jmod = 43510.0 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + +! ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:00:00 (see da_get_julian_time) +! real(r_kind), parameter :: jd_jmod = 43509.5 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + + + integer :: n + + n = size(lat) + allocate( latrad(n) ) + allocate( lmst(n) ) + allocate( ha(n) ) + allocate( elev(n) ) + allocate( refrac(n) ) + allocate( valid_loc(n) ) + + call da_get_julian_time( yr, mt, dy, hr, mn, jmod ) + ju = jmod / 1440.0 + real(sc,r_double) / 86400.0 + jd_jmod + + ! Calculate ecliptic coordinates (depends on time [days] since noon 1 Jan, 2000) + ! 51545.0 + 2.4e6 = noon 1 Jan, 2000 + time = ju - 51545.0 + + ! Force mean longitude between 0 and 360 degs + mnlon = 280.460 + 0.9856474 * time + mnlon = mod( mnlon, 360. ) + if( mnlon.lt.0. ) mnlon = mnlon + 360. + + ! Mean anomaly in radians between 0 and 2*pi + mnanom = 357.528 + 0.9856003 * time + mnanom = mod( mnanom, 360. ) + if( mnanom.lt.0. ) mnanom = mnanom + 360. + mnanom = mnanom * deg2rad + + ! Compute the ecliptic longitude and obliquity of ecliptic in radians + eclon = mnlon + 1.915*sin( mnanom ) + 0.020*sin( 2.*mnanom ) + eclon = mod( eclon, 360. ) + + if ( eclon.lt.0. ) eclon = eclon + 360. + + oblqec = 23.439 - 0.0000004*time + eclon = eclon * deg2rad + oblqec = oblqec * deg2rad + + ! Calculate right ascension and force between 0 and 2*pi + num = cos( oblqec ) * sin( eclon ) + den = cos( eclon ) + ra = atan( num/den ) + if ( den.lt.0 ) then + ra = ra + PI + elseif ( num.lt.0 ) then + ra = ra + 2.0*PI + endif + + ! Calculate declination in radians + dec = asin( sin( oblqec ) * sin( eclon ) ) + + ! Calculate Greenwich mean sidereal time in hours +! gmst = 6.697375 + 0.0657098242*time + real(hr,r_kind) + real(mn,r_kind) / 60. + real(sc,r_kind) / 3600. + gmst = 6.697375 + 0.0657098242*time + real(hr * 3600 + mn * 60 + sc, r_kind) / 3600. + + ! Hour not changed to sidereal time since 'time' includes the fractional day + gmst = mod( gmst, 24. ) + if( gmst.lt.0. ) gmst = gmst + 24. + + !Define valid locations for vectorized operations + valid_loc = ( lat .le. 90. .and. & + lat .ge. -90. .and. & + lon .le. 180. .and. & + lon .ge. -180. ) + + ! Calculate local mean sidereal time in radians + where ( valid_loc ) + lmst = gmst + lon / 15. + lmst = mod( lmst, 24. ) + end where + where ( lmst.lt.0. .and. valid_loc ) + lmst = lmst + 24. + end where + where ( valid_loc ) + lmst = lmst * 15. * deg2rad + end where + + + ! Calculate hour angle in radians between -pi and pi + where ( valid_loc ) + ha = lmst - ra + end where + where ( ha .lt. -PI .and. valid_loc ) ha = ha + 2.0*PI + where ( ha .gt. PI .and. valid_loc ) ha = ha - 2.0*PI + + ! Change latitude to radians + where ( valid_loc ) + latrad = lat * deg2rad + end where + + ! From this point on: + ! mnlon in degs, gmst in hours, jd in days if 2.4e6 added; + ! mnanom, eclon, oblqec, ra, lmst, and ha in radians + + ! Calculate elevation and azimuth + solazi = missing_r + where ( valid_loc ) + elev = asin( sin( dec ) * sin( latrad ) + cos( dec ) * cos( latrad ) * cos( ha ) ) + solazi = asin( -cos( dec ) * sin( ha ) / cos( elev ) ) + end where + +!JJG: From J.P. Justiniano (not in Michalsky, causes differences with NREL SPA) +!! This puts azimuth between 0 and 2*pi radians +! where ( sin(dec) - sin(elev) * sin(latrad) .ge. 0. ) then +! where ( sin(solazi) .lt. 0. ) solazi = solazi + 2.0*PI +! elsewhere +! solazi = PI - solazi +! endif + + ! When solazi=90 degs, elev == elcritical = asin( sin(dec) / sin(latrad) ) + where ( valid_loc ) + elc = asin( sin( dec ) / sin( latrad ) ) + end where + where ( elev.ge.elc .and. valid_loc ) solazi = PI - solazi + where ( elev.le.elc .and. ha.gt.0. .and. valid_loc ) solazi = 2.0*PI + solazi + + ! Convert azimuth and elevation to degs before returning + where ( valid_loc ) + solazi = solazi / deg2rad + elev = elev / deg2rad + end where + + ! Calculate refraction correction for US stan. atmosphere + ! (need to have elev in degs) + +! ! Michalsky (1988) +! where ( elev.gt. - 0.56 ) +! refrac = 3.51579 * ( 0.1594 + 0.0196*elev + 0.00002*elev**2 ) / & +! ( 1. + 0.505*elev + 0.0845*elev**2 ) +! elsewhere +! refrac = 0.56 +! end where + + !J.P. Justiniano (not in Michalsky, more accurate than above?) + where ( elev.ge.19.225 ) + refrac = 0.00452 * 3.51823 / tan( elev*deg2rad ) + elsewhere ( elev.gt.-0.766 .and. elev.lt.19.225 ) + refrac = 3.51579 * ( 0.1594 + 0.0196 * elev + 0.00002*elev**2 ) / & + ( 1. + 0.505*elev + 0.0845*elev**2 ) + elsewhere + refrac = 0.0 + end where + ! note that 3.51579=1013.25 mb/288.2 C + + + solzen = missing_r + where ( valid_loc ) + elev = elev + refrac + end where + + !JJG: Added these bounds + !Keep elevation between -90. to +90. + where ( valid_loc .and. elev.lt.-90.) & + elev = - (180. + elev) + where ( valid_loc .and. elev.gt.90.) & + elev = 180. - elev + + where ( valid_loc ) + ! Convert elevation to topocentric zenith + solzen = 90.0 - elev + end where + + + deallocate( latrad, lmst, ha, elev, refrac, valid_loc ) + +end subroutine da_get_solar_angles_1d diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index c2414a0dc6..f9076475f6 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -97,6 +97,20 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%solzen(n) = p%solzen iv%instid(i)%solazi(n) = p%solazi ! iv%instid(i)%solazi(n) = 0.0 + iv%instid(i)%tropt(n) = 0.0 + if ( use_clddet_zz ) then + if ( associated ( p % cld_qc ) ) then + iv%instid(i)%cld_qc(n)%RTCT = p % cld_qc % RTCT + iv%instid(i)%cld_qc(n)%RTCT_terr = p % cld_qc % RTCT_terr + iv%instid(i)%cld_qc(n)%RFMFT = p % cld_qc % RFMFT + iv%instid(i)%cld_qc(n)%TEMPIR = p % cld_qc % TEMPIR + if ( allocated ( p % cld_qc % CIRH2O ) .and. & + size(p % cld_qc % CIRH2O).eq.1) then + allocate ( iv%instid(i)%cld_qc(n)%CIRH2O(1,1,1) ) + iv%instid(i)%cld_qc(n)%CIRH2O = p % cld_qc % CIRH2O + end if + end if + end if if ( rtm_option == rtm_option_rttov ) then iv%instid(i)%surftype(n) = 0 diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 08f7b4baac..a325baf831 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -1,14 +1,8 @@ -subroutine da_qc_goesabi(it, i, nchan, ob, iv) +subroutine da_qc_goesabi (it, i, nchan, ob, iv) !--------------------------------------------------------------------------- - ! Purpose: perform quality control for GOES-abi radiance data. - ! - ! - !Modeled after da_qc_goesimg.inc, still need to update for ABI - ! Method: Yang et al., 2017: Impact of assimilating GOES imager - ! clear-sky radiance with a rapid refresh assimilation - ! system for convection-permitting forecast over Mexico. - ! J. Geophys. Res. Atmos., 122, 5472–5490 + ! Purpose: perform quality control for abi data. + ! To be developed: built in cloud_detection method !--------------------------------------------------------------------------- implicit none @@ -19,158 +13,716 @@ subroutine da_qc_goesabi(it, i, nchan, ob, iv) type (y_type), intent(in) :: ob ! Observation structure. type (iv_type), intent(inout) :: iv ! O-B structure. - ! local variables - logical :: lmix,lcould_read - real :: satzen - integer :: n,k,isflg,ios,fgat_rad_unit,sensor_id - integer :: scanpos + logical :: lmix, cloud_detection + integer :: n,k,isflg,ios,fgat_rad_unit integer :: ngood(nchan),nrej(nchan),nrej_omb_abs(nchan), & - nrej_omb_std(nchan), & - nrej_clw,nrej_eccloud, num_proc_domain, nrej_mixsurface - - real :: inv_grosscheck + nrej_omb_std(nchan),nrej_eccloud(nchan), & + nrej_clw(nchan),num_proc_domain, & + nrej_mixsurface,nrej_land + + ! isflg: SEA(0),ICE(1),LAND(2),SNOW(3),MSEA(4),MICE(5),MLND(6),MSNO(7) + integer, parameter :: sea_flag = 0 + integer, parameter :: ice_flag = 1 + integer, parameter :: land_flag = 2 + integer, parameter :: snow_flag = 3 + integer, parameter :: msea_flag = 4 + integer, parameter :: mice_flag = 5 + integer, parameter :: mland_flag = 6 + integer, parameter :: msnow_flag = 7 + +! ------- + real :: inv_grosscheck character(len=30) :: filename + real :: c37_mean + + !! Additional variables used by Zhuge and Zou(2017) + integer :: nrej_rtct(nchan), nrej_etrop(nchan), nrej_pfmft(nchan), & + nrej_nfmft(nchan), nrej_rfmft(nchan), & + nrej_cirh2o(nchan), nrej_emiss4(nchan), & + nrej_ulst(nchan), nrej_tempir(nchan), nrej_notc(nchan) + logical :: reject_zz, print_zz + integer*2 :: clddet_zz_tests(10) + real :: eps_zz_ocean, eps_zz_land, eps_zz_snow + real, pointer :: crit_zz + character(len=10) :: crit_name + + real, target :: rtct, etrop, pfmft, nfmft, rfmft, cirh2o, emiss4, ulst, tempir, notc + real :: rad_O14, rad_M14, rad_tropt + real :: rad_o_ch7, rad_b_ch7, rad_o_ch14, rad_b_ch14 + real :: Relaz, Glintzen, tb_temp1 + real :: wave_num(10) + real :: plbc1(10), plbc2(10) + real :: plfk1(10), plfk2(10) + + real, pointer :: tb_ob(:,:), tb_xb(:,:), tb_inv(:,:) + + ! note: these values are constant across channels + real(8), parameter :: C1=1.19104276e-5 ! = 2 * h * c**2 mWm-2sr-1(cm-1)-4 + real(8), parameter :: C2=1.43877516 ! = h * c / b = 1.43877 K(cm-1)-1 + ! h = Planck's constant + ! b = Boltzmann constant + ! c = velocity of light + + + if (trace_use) call da_trace_entry("da_qc_goesabi") + + + ! These values can change as SRF (spectral response function) is updated + ! It is recommended to acquire these from L1B files, not copy them from GOES R PUG L1b Vol. 3 + wave_num(1:10) = (/2570.373,1620.528,1443.554,1363.228,1184.220, & + 1040.891, 968.001, 894.000, 815.294, 753.790/) + plbc1(1:10) = (/0.43361, 1.55228, 0.34427, 0.05651, 0.18733, & + 0.09102, 0.07550, 0.22516, 0.21702, 0.06266/) + plbc2(1:10) = (/0.99939, 0.99667, 0.99918, 0.99986, 0.99948, & + 0.99971, 0.99975, 0.99920, 0.99916, 0.99974/) + + plfk1 = C1 * wave_num**3 + plfk2 = C2 * wave_num - if (trace_use_dull) call da_trace_entry("da_qc_goesabi.inc") ngood(:) = 0 nrej(:) = 0 - nrej(:) = 0 nrej_omb_abs(:) = 0 nrej_omb_std(:) = 0 - nrej_clw = 0 - nrej_eccloud = 0 + nrej_eccloud(:) = 0 + nrej_clw(:) = 0 nrej_mixsurface = 0 + nrej_land = 0 num_proc_domain = 0 - sensor_id = 22 - - do n= iv%instid(i)%info%n1,iv%instid(i)%info%n2 + nrej_rtct = 0 + nrej_etrop = 0 + nrej_pfmft = 0 + nrej_nfmft = 0 + nrej_rfmft = 0 + nrej_cirh2o = 0 + nrej_emiss4 = 0 + nrej_ulst = 0 + nrej_tempir = 0 + nrej_notc = 0 + + tb_ob => ob%instid(i)%tb + tb_xb => iv%instid(i)%tb_xb + tb_inv => iv%instid(i)%tb_inv + + PixelQCLoop: do n= iv%instid(i)%info%n1,iv%instid(i)%info%n2 if (iv%instid(i)%info%proc_domain(1,n)) & - num_proc_domain = num_proc_domain + 1 + num_proc_domain = num_proc_domain + 1 + if ( crtm_cloud ) then + ! calculate c37_mean + c37_mean = 1.0 - (tb_ob(11,n) - tb_ob(12,n) + & + tb_xb(11,n) - tb_xb(12,n)) / & + (2.0 * (iv%instid(i)%tb_xb_clr(11,n) - iv%instid(i)%tb_xb_clr(12,n))) + end if ! 0.0 initialise QC by flags assuming good obs - !--------------------------------------------- + !----------------------------------------------------------------- iv%instid(i)%tb_qc(:,n) = qc_good - ! a. reject all channels over mixture surface type - !------------------------------------------------------ + ! 1.0 reject all channels over mixture surface type + !------------------------------------------------------ isflg = iv%instid(i)%isflg(n) - lmix = (isflg==4) .or. (isflg==5) .or. (isflg==6) .or. (isflg==7) + lmix = (isflg==msea_flag) .or. & + (isflg==mland_flag) .or. & + (isflg==msnow_flag) .or. & + (isflg==mice_flag) + if (lmix) then iv%instid(i)%tb_qc(:,n) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & nrej_mixsurface = nrej_mixsurface + 1 end if - if (isflg > 0) then ! if not over water - do k = 1, nchan ! IR window channel only used over water - if ( k .ne. 2 ) then - if (only_sea_rad) iv%instid(i)%tb_qc(k,n) = qc_bad + if ( isflg .ne. sea_flag ) then + do k = 1, nchan + if ( all(k .ne. (/ 2, 3, 4 /)) .and. only_sea_rad ) then + iv%instid(i)%tb_qc(k,n) = qc_bad + nrej_land = nrej_land + 1 end if - end do - end if + end do + end if + + ! 2.0 check iuse + !----------------------------------------------------------------- + do k = 1, nchan + if (satinfo(i)%iuse(k) .eq. -1) & + iv%instid(i)%tb_qc(k,n) = qc_bad + end do - ! b. cloud detection - !----------------------------------------------------------- - if (.not.crtm_cloud) then + ! 3.0 check cloud + !----------------------------------------------------------------- + if (.not. crtm_cloud ) then + +! do k = 1, nchan + if (iv%instid(i)%clwp(n) >= 0.2) then iv%instid(i)%tb_qc(:,n) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_clw = nrej_clw + 1 + nrej_clw(:) = nrej_clw(:) + 1 end if -!!! NEED TO REDEFINE THESE FOR GOES-ABI CHANNELS (ichan=1-10 => band=7-16) -! if (iv%instid(i)%landsea_mask(n) == 0 ) then -! if (iv%instid(i)%tb_xb(3,n)-ob%instid(i)%tb(3,n)>3.5) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_eccloud = nrej_eccloud + 1 -! end if + cloud_detection=.false. + if (cloud_detection) then + if (iv%instid(i)%landsea_mask(n) == 0 ) then + if ( ( tb_xb(3,n) - tb_ob(3,n) ) > 3.5) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_eccloud(:) = nrej_eccloud(:) + 1 + end if + else + if ( ( tb_xb(3,n) - tb_ob(3,n) ) > 2.5) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_eccloud(:) = nrej_eccloud(:) + 1 + end if + end if ! else -! if (iv%instid(i)%tb_xb(3,n)-ob%instid(i)%tb(3,n)>2.5) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_eccloud = nrej_eccloud + 1 +! if (iv%instid(i)%cloudflag(n) <= 0) then ! only use abs clear pixel, read clm by Zhuge and Zou(2017) +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_eccloud(:) = nrej_eccloud(:) + 1 ! end if -! end if - + end if + +! end do end if - ! c. check innovation - !----------------------------------------------------------- - do k = 1, nchan + clddet_zz: if ( use_clddet_zz .and. all(tb_inv((/1,8,9/),n).gt.missing_r) ) then + !!========================================================================== + !!========================================================================== + !! + !! 4.0 Zhuge X. and Zou X. JAMC, 2016. [ABI Cloud Mask Algorithm] + !! + !!========================================================================== + !!========================================================================== + + print_zz = iv%instid(i)%info%proc_domain(1,n) + clddet_zz_tests = 0 + + if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG1: ', n, & + tb_inv(:,n) + if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG2: ', n, & + tb_xb(:,n) + if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG3: ', n, & + tb_ob(:,n) + + if (print_zz) write(*,'(A,3I8)') 'PIXEL_DEBUG4: n, n1, n2 = ', & + n, iv%instid(i)%info%n1, iv%instid(i)%info%n2 + if (print_zz) write(*,'(A)') 'PIXEL_DEBUG5: n, lat, lon, satzen, satazi, solzen, solazi, tropt, terrain, date = ' + if (print_zz) write(*,'(A,I8,8F12.4,A)') 'PIXEL_DEBUG6: ', n, & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + iv%instid(i)%satzen(n), iv%instid(i)%satazi(n), & + iv%instid(i)%solzen(n), iv%instid(i)%solazi(n), & + iv%instid(i)%tropt(n), iv%instid(i)%cld_qc(n)%RTCT_terr, & + iv%instid(i)%info%date_char(n) + + + !-------------------------------------------------------------------------- + ! 4.1 Relative Thermal Contrast Test + ! (Zhuge and Zou, 2016, JAMC; TEST1) + ! e_rtct = 3.2(Ocean), 4.1(land) + !-------------------------------------------------------------------------- + eps_zz_ocean = 3.2 + eps_zz_land = 4.1 +! eps_zz_snow = 1.e10 + crit_name = "rtct" + + rtct = iv%instid(i)%cld_qc(n)%RTCT + reject_zz = .false. + if (.not. rtct.eq.missing_r) then + crit_zz => rtct + if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land +! if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice + if (reject_zz) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_rtct(:) = nrej_rtct(:) + 1 - ! c.1. check absolute value of innovation - !------------------------------------------------ - if (.not.crtm_cloud) then - inv_grosscheck = 15.0 - if (use_satcv(2)) inv_grosscheck = 100.0 - if (abs(iv%instid(i)%tb_inv(k,n)) > inv_grosscheck) then - iv%instid(i)%tb_qc(k,n) = qc_bad + if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) + end if + end if + + if (reject_zz) clddet_zz_tests(1) = 1 + + !-------------------------------------------------------------------------- + ! 4.2 Cloud check: step 1 + ! Emissivity at Tropopause Test (ETROP) + ! (Zhuge and Zou, 2016, JAMC; TEST2) + ! e_etrop = 0.1(Ocean), 0.3(land), 0.4(snow) + ! Q: need tropopause temperature + ! select iv%instid(i)%isflg(n) + !-------------------------------------------------------------------------- + eps_zz_ocean = 0.1 + eps_zz_land = 0.3 + eps_zz_snow = 0.4 + crit_name = "etrop" + if ( tb_xb(8,n) .gt. 0. .and. & + iv%instid(i)%tropt(n) .gt. 0. ) then + tb_temp1 = tb_ob(8,n) + rad_O14 = plfk1(8) / & + ( exp( plfk2(8) / (plbc1(8) + plbc2(8) * tb_temp1 ) ) -1 ) + tb_temp1 = tb_xb(8,n) + rad_M14 = plfk1(8) / & + ( exp( plfk2(8) / (plbc1(8) + plbc2(8) * tb_temp1) ) -1 ) + tb_temp1 = iv%instid(i)%tropt(n) + rad_tropt = plfk1(8) / & + ( exp( plfk2(8) / (plbc1(8) + plbc2(8) * tb_temp1) ) -1 ) + etrop = (rad_O14 - rad_M14) / (rad_tropt - rad_M14) + else + etrop = missing_r + end if + reject_zz = .false. + crit_zz => etrop + if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land + if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice + if (reject_zz) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_etrop(:) = nrej_etrop(:) + 1 + + if (print_zz) write(*,"(A,F14.6,A,I4,4D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n),tb_xb(8,n),tb_ob(8,n) + end if + + if (reject_zz) clddet_zz_tests(2) = 1 + + !-------------------------------------------------------------------------- + ! 4.3 Cloud check: step 2 + ! Positive Fourteen Minus Fifteen Test + ! (Zhuge and Zou, 2016, JAMC; TEST3) + ! e_pfmft = 0.8(Ocean), 2.5(land), 1.0(snow) + !-------------------------------------------------------------------------- + eps_zz_ocean = 0.8 + eps_zz_land = 2.5 + eps_zz_snow = 1.0 + crit_name = "pfmft" + +!JJG: Why does this logical test not use tb_ob(8,n)? Something to do with VarBC... + + pfmft = missing_r + if ( (tb_inv(8,n) + tb_xb(8,n)) >270. .and. & + tb_xb(8,n) >270.) then + if (tb_ob(8,n) .gt. 0. .and. tb_ob(9,n) .gt. 0.) then +! using ob with VarBC +! pfmft = (tb_inv(8,n) + tb_xb(8,n) - & +! tb_inv(9,n) + tb_xb(9,n)) - & +! (tb_xb(8,n) - tb_xb(9,n))* & +! (tb_inv(8,n) + tb_xb(8,n) - 260.)/ & +! (tb_xb(8,n) - 260.) +! using ob without VarBC + pfmft = (tb_ob(8,n) - tb_ob(9,n)) - & + (tb_xb(8,n) - tb_xb(9,n)) * & + (tb_ob(8,n) - 260.) / (tb_xb(8,n) - 260.) + end if +!JJG: Changed the following to else (should be .or. instead of .and.) +! end if +! +! if ( (tb_inv(8,n) + tb_xb(8,n)) < 270. .and. & +! tb_xb(8,n) < 270.) then + + else + if (tb_ob(8,n) .gt. 0. .and. tb_ob(9,n) .gt. 0.) then +! ------------------------------- +! using ob with VarBC +! pfmft = (tb_inv(8,n) + tb_xb(8,n) - & +! (tb_inv(9,n) + tb_xb(9,n)) ) +! using ob without VarBC + pfmft = ( tb_ob(8,n) - tb_ob(9,n) ) +! ------------------------------- + end if + end if + + reject_zz = .false. + crit_zz => pfmft + if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land + if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice + if (reject_zz) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_pfmft(:) = nrej_pfmft(:) + 1 + + if (print_zz) write(*,"(A,F14.6,A,I4,4D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n),tb_xb(8,n),tb_ob(8,n) + end if + + if (reject_zz) clddet_zz_tests(3) = 1 + + !-------------------------------------------------------------------------- + ! 4.4 Negative Fourteen Minus Fifteen Test + ! (Zhuge and Zou, 2016, JAMC; TEST4) + ! e_nfmft = 1.0(Ocean), 2.0(land), 5.0(snow) + !-------------------------------------------------------------------------- + eps_zz_ocean = 1.0 + eps_zz_land = 2.0 + eps_zz_snow = 5.0 + crit_name = "nfmft" + + if (tb_ob(8,n) .gt. 0. .and. tb_ob(9,n) .gt. 0.) then + nfmft=tb_inv(9,n) - tb_inv(8,n) + else + nfmft = missing_r + end if + + reject_zz = .false. + crit_zz => nfmft + if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land + if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice + if (reject_zz) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_nfmft(:) = nrej_nfmft(:) + 1 + + if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) + end if + if (reject_zz) clddet_zz_tests(4) = 1 + + + !-------------------------------------------------------------------------- + ! 4.5 Relative Fourteen Minus Fifteen Test + ! (Zhuge and Zou, 2016, JAMC; TEST5) + ! e_rfmft = 0.7(Ocean), 1.0(land) + !-------------------------------------------------------------------------- + eps_zz_ocean = 0.7 + eps_zz_land = 1.0 +! eps_zz_snow = 1.e10 + crit_name = "rfmft" + + rfmft = iv%instid(i)%cld_qc(n)%RFMFT + reject_zz = .false. + if (.not. rfmft.eq.missing_r) then + crit_zz => rfmft + if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land +! if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice + if (reject_zz) then + iv%instid(i)%tb_qc(:,n) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_omb_abs(k) = nrej_omb_abs(k) + 1 + nrej_rfmft(:) = nrej_rfmft(:) + 1 + + if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) end if end if + if (reject_zz) clddet_zz_tests(5) = 1 + - ! c.2. check relative value of innovation - ! and assign of the observation error (standard deviation) - !------------------------------------------------------------------------ - if (use_error_factor_rad) then ! if use error tuning factor - iv%instid(i)%tb_error(k,n) = & - satinfo(i)%error(k)*satinfo(i)%error_factor(k) + !-------------------------------------------------------------------------- + ! 4.6 Cirrus Water Vapor Test + ! (Zhuge and Zou, 2016, JAMC; TEST6) + ! e_cirh2o = 0.7(Ocean), 0.7(land), 0.7(snow) + !-------------------------------------------------------------------------- + eps_zz_ocean = 0.7 + eps_zz_land = 0.7 + eps_zz_snow = 0.7 + crit_name = "cirh2o" + + if (allocated(iv%instid(i)%cld_qc(n)%CIRH2O)) then + cirh2o = iv%instid(i)%cld_qc(n)%CIRH2O(1,1,1) else - iv%instid(i)%tb_error(k,n) = satinfo(i)%error(k) + cirh2o = missing_r end if + reject_zz = .false. + if (.not. cirh2o.eq.missing_r) then + crit_zz => cirh2o + if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land + if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice + if (reject_zz) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_cirh2o(:) = nrej_cirh2o(:) + 1 - if (abs(iv%instid(i)%tb_inv(k,n)) > 3.0*iv%instid(i)%tb_error(k,n)) then - iv%instid(i)%tb_qc(k,n) = qc_bad + if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) + end if + end if + if (reject_zz) clddet_zz_tests(6) = 1 + + + !-------------------------------------------------------------------------- + ! 4.7 Modified 4um Emissivity Test + ! (Zhuge and Zou, 2016, JAMC; TEST7, New/Mod TEST1) + ! e_emiss4 = 0.1(Ocean), 0.2(land), 0.3(snow) for daytime, 2.86(Ocean) for night + ! e_modemiss4 = 0.26-3*1.04(Ocean) for sun-glint area + !-------------------------------------------------------------------------- + eps_zz_ocean = 0.1 + + ! Modified EMISS4 from Zhuge and Zou + eps_zz_land = 0.2 + + ! Default value from ABI CM algorithm + eps_zz_land = 0.46 + + eps_zz_snow = 0.3 + crit_name = "emiss4" + + if (tb_ob(1,n) .gt. 0. .and. tb_ob(8,n) .gt. 0.) then + tb_temp1 = tb_ob(1,n) + rad_o_ch7 = plfk1(1) / & + ( exp( plfk2(1) / ( plbc1(1) + plbc2(1) * tb_temp1 ) ) - 1. ) + + tb_temp1 = tb_xb(1,n) + rad_b_ch7 = plfk1(1) / & + ( exp( plfk2(1) / ( plbc1(1) + plbc2(1) * tb_temp1 ) ) - 1. ) + + tb_temp1 = tb_ob(8,n) + rad_o_ch14 = plfk1(1) / & + ( exp( plfk2(1) / ( plbc1(1) + plbc2(1) * tb_temp1 ) ) - 1. ) + + tb_temp1 = tb_xb(8,n) + rad_b_ch14 = plfk1(1) / & + ( exp( plfk2(1) / ( plbc1(1) + plbc2(1) * tb_temp1 ) ) - 1. ) +! --------------------------------------- + emiss4 = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14)/ & + (rad_b_ch7 / rad_b_ch14) + else + emiss4 = missing_r + end if + +!JJG: Need to check over this code to ensure relative azimuth is calculated correctly + ! Modify EMISS for sun glint area may be not work, because we are at north land + ! - compute relative azimuth + Relaz = RELATIVE_AZIMUTH(iv%instid(i)%solazi(n),iv%instid(i)%satazi(n)) + +!JJG: At least the use of solzen, satze, Relaz appears to be correct for Glintzen calculation + ! - compute glint angle + Glintzen = GLINT_ANGLE(iv%instid(i)%solzen(n),iv%instid(i)%satzen(n),Relaz ) + if (print_zz) write(*,"(A)") "PIXEL_DEBUG7: lat, lon, Relaz, Glintzen = " + if (print_zz) write(*,"(A,4D12.4)") "PIXEL_DEBUG8: ", & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n), Relaz, Glintzen + + reject_zz = .false. + crit_zz => emiss4 + if ( Glintzen.lt.40.0 .and. isflg==sea_flag) then +! if ( isflg==sea_flag .and. tb_inv(1,n) < -2.86 ) reject_zz = .true. + eps_zz_ocean = 2.86 + emiss4 = - tb_inv(1,n) ! (B_ch7 - O_ch7) + if ( crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + else + if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land + if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice + end if + if (reject_zz) then + iv%instid(i)%tb_qc(:,n) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_omb_std(k) = nrej_omb_std(k) + 1 + nrej_emiss4(:) = nrej_emiss4(:) + 1 + + if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) + end if + if (reject_zz) clddet_zz_tests(7) = 1 + + + !-------------------------------------------------------------------------- + ! 4.8 Uniform low stratus Test + ! (Zhuge and Zou, 2016, JAMC; TEST8) + ! e_ulst = 0.05(Ocean), 0.1(land), 0.12(snow) for night, no day time test + !-------------------------------------------------------------------------- + eps_zz_ocean = 0.05 + eps_zz_land = 0.1 + eps_zz_snow = 0.12 + crit_name = "ulst" + + if (tb_ob(1,n) .gt. 0. .and. tb_ob(8,n) .gt. 0.) then + ulst = rad_b_ch7/rad_b_ch14 - rad_o_ch7/rad_o_ch14 + else + ulst = missing_r + end if +!JJG: Changed this to solzen instead of solazi for night/day test + reject_zz = .false. + if ( iv%instid(i)%solzen(n) >= 85.0 .and. ulst.gt.missing_r ) then ! night Time + crit_zz => ulst + if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land + if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice + if (reject_zz) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_ulst(:) = nrej_ulst(:) + 1 + + if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) + end if + end if + if (reject_zz) clddet_zz_tests(8) = 1 + + + !-------------------------------------------------------------------------- + ! 4.9 Temporal Infrared Test + ! (Zhuge and Zou, 2016, JAMC; TEST9) + ! e_tempir = 2.0(Ocean), 2.0(land), 2.0(snow) + !-------------------------------------------------------------------------- + eps_zz_ocean = 2.0 + eps_zz_land = 2.0 + eps_zz_snow = 2.0 + crit_name = "tempir" + + tempir = iv%instid(i)%cld_qc(n)%TEMPIR + reject_zz = .false. + if (.not. tempir.eq.missing_r) then + crit_zz => tempir + if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land + if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice + if (reject_zz) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_tempir(:) = nrej_tempir(:) + 1 + + if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) + end if + end if + if (reject_zz) clddet_zz_tests(9) = 1 + + + !-------------------------------------------------------------------------- + ! 4.10 N-OTC Test + ! (Zhuge and Zou, 2016, JAMC; New/Mod TEST3) + ! e_notc = 15.(Ocean), 21.(land), 10.(snow) for day + ! e_notc = 11.(Ocean), 15.(land), 4.5(snow) for night + !-------------------------------------------------------------------------- +!JJG: Changed this to solzen instead of solazi for night/day test + if ( iv%instid(i)%solzen(n) < 85.0 ) then ! day Time + eps_zz_ocean = 15. + eps_zz_land = 21. + eps_zz_snow = 10. + else + eps_zz_ocean = 11. + eps_zz_land = 25. + eps_zz_snow = 4.5 end if + crit_name = "notc" + + if (tb_ob(1,n) .gt. 0. .and. tb_ob(9,n) .gt. 0.) then +! using ob with VarBC +! notc = tb_inv(1,n) + tb_xb(1,n) - & +! (tb_inv(9,n) + tb_xb(9,n)) +! using ob without VarBC + notc = tb_ob(1,n) - tb_ob(9,n) + else + notc = missing_r + end if + + reject_zz = .false. + crit_zz => notc + if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land + if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice + if (reject_zz) then + iv%instid(i)%tb_qc(:,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_notc(:) = nrej_notc(:) + 1 - end do ! chan + if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) + end if + if (reject_zz) clddet_zz_tests(10) = 1 + + if (print_zz) write(*,'(A,I8,10I4)') 'PIXEL_DEBUG9: ', n, & + clddet_zz_tests + + end if clddet_zz + + ! --------------------------- + ! 5.0 assigning obs errors + if (.not. crtm_cloud ) then + do k = 1, nchan + if (use_error_factor_rad) then + iv%instid(i)%tb_error(k,n) = & + satinfo(i)%error_std(k) * satinfo(i)%error_factor(k) + else + iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) + end if + end do ! nchan + else !crtm_cloud + ! symmetric error model, Geer and Bauer (2011) + do k = 1, nchan + if (c37_mean.lt.0.05) then + iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) + else if (c37_mean.ge.0.05.and.c37_mean.lt.0.5) then + iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) + & + (c37_mean - 0.05) * (satinfo(i)%error_cld(k) - satinfo(i)%error_std(k)) / (0.5 - 0.05) + else + iv%instid(i)%tb_error(k,n)= satinfo(i)%error_cld(k) + end if + end do ! nchan + end if + ! 5.1 check innovation + !----------------------------------------------------------------- + if (.not. crtm_cloud ) then + ! absolute departure check + do k = 1, nchan + inv_grosscheck = 15.0 + if (use_satcv(2)) inv_grosscheck = 100.0 + if (abs(tb_inv(k,n)) > inv_grosscheck) then + iv%instid(i)%tb_qc(k,n) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_omb_abs(k) = nrej_omb_abs(k) + 1 + end if + end do ! nchan + end if - ! 2. Check iuse from information file (channel selection) - !----------------------------------------------------------- do k = 1, nchan - if (satinfo(i)%iuse(k) .eq. -1) & + ! relative departure check + if (abs(tb_inv(k,n)) > 3.0 * iv%instid(i)%tb_error(k,n)) then iv%instid(i)%tb_qc(k,n) = qc_bad - end do + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_omb_std(k) = nrej_omb_std(k) + 1 + end if - ! 3. Final QC decision - !--------------------------------------------- - do k = 1, nchan - if (iv%instid(i)%tb_qc(k,n) == qc_bad) then ! bad obs + ! final QC decsion + if (iv%instid(i)%tb_qc(k,n) == qc_bad) then iv%instid(i)%tb_error(k,n) = 500.0 if (iv%instid(i)%info%proc_domain(1,n)) & - nrej(k) = nrej(k) + 1 - else ! good obs + nrej(k) = nrej(k) + 1 + else if (iv%instid(i)%info%proc_domain(1,n)) & - ngood(k) = ngood(k) + 1 + ngood(k) = ngood(k) + 1 end if - end do ! chan - end do ! end loop pixel + end do ! nchan + end do PixelQCLoop + ! Do inter-processor communication to gather statistics. call da_proc_sum_int (num_proc_domain) call da_proc_sum_int (nrej_mixsurface) - call da_proc_sum_int (nrej_clw) - call da_proc_sum_int (nrej_eccloud) - call da_proc_sum_ints (nrej_omb_abs(:)) - call da_proc_sum_ints (nrej_omb_std(:)) - call da_proc_sum_ints (nrej(:)) - call da_proc_sum_ints (ngood(:)) + call da_proc_sum_int (nrej_land) + call da_proc_sum_ints (nrej_eccloud) + + call da_proc_sum_ints (nrej_rtct ) + call da_proc_sum_ints (nrej_etrop ) + call da_proc_sum_ints (nrej_pfmft ) + call da_proc_sum_ints (nrej_nfmft ) + call da_proc_sum_ints (nrej_rfmft ) + call da_proc_sum_ints (nrej_cirh2o ) + call da_proc_sum_ints (nrej_emiss4 ) + call da_proc_sum_ints (nrej_ulst ) + call da_proc_sum_ints (nrej_tempir ) + call da_proc_sum_ints (nrej_notc ) + + call da_proc_sum_ints (nrej_omb_abs) + call da_proc_sum_ints (nrej_omb_std) + call da_proc_sum_ints (nrej_clw) + call da_proc_sum_ints (nrej) + call da_proc_sum_ints (ngood) if (rootproc) then if (num_fgat_time > 1) then write(filename,'(i2.2,a,i2.2)') it,'_qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time else - write(filename,'(i2.2,a)') it, '_qcstat_'//trim(iv%instid(i)%rttovid_string) + write(filename,'(i2.2,a)') it,'_qcstat_'//trim(iv%instid(i)%rttovid_string) end if call da_get_unit(fgat_rad_unit) @@ -181,10 +733,35 @@ subroutine da_qc_goesabi(it, i, nchan, ob, iv) end if write(fgat_rad_unit, fmt='(/a/)') ' Quality Control Statistics for '//iv%instid(i)%rttovid_string - write(fgat_rad_unit,'(a20,i7)') ' num_proc_domain = ', num_proc_domain + if(num_proc_domain > 0) write(fgat_rad_unit,'(a20,i7)') ' num_proc_domain = ', num_proc_domain write(fgat_rad_unit,'(a20,i7)') ' nrej_mixsurface = ', nrej_mixsurface - write(fgat_rad_unit,'(a20,i7)') ' nrej_clw = ', nrej_clw - write(fgat_rad_unit,'(a20,i7)') ' nrej_eccloud = ', nrej_eccloud + write(fgat_rad_unit,'(a20,i7)') ' nrej_land = ', nrej_land + write(fgat_rad_unit,'(a20)') ' nrej_eccloud(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_eccloud(:) + write(fgat_rad_unit,'(a20)') ' nrej_clw(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_clw(:) + + write(fgat_rad_unit,'(a20)') ' nrej_rtct(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_rtct(:) + write(fgat_rad_unit,'(a20)') ' nrej_etrop(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_etrop(:) + write(fgat_rad_unit,'(a20)') ' nrej_pfmft(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_pfmft(:) + write(fgat_rad_unit,'(a20)') ' nrej_nfmft(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_nfmft(:) + write(fgat_rad_unit,'(a20)') ' nrej_rfmft(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_rfmft(:) + write(fgat_rad_unit,'(a20)') ' nrej_cirh2o(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_cirh2o(:) + write(fgat_rad_unit,'(a20)') ' nrej_emiss4(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_emiss4(:) + write(fgat_rad_unit,'(a20)') ' nrej_ulst(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_ulst(:) + write(fgat_rad_unit,'(a20)') ' nrej_tempir(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_tempir(:) + write(fgat_rad_unit,'(a20)') ' nrej_notc(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_notc(:) + write(fgat_rad_unit,'(a20)') ' nrej_omb_abs(:) = ' write(fgat_rad_unit,'(10i7)') nrej_omb_abs(:) write(fgat_rad_unit,'(a20)') ' nrej_omb_std(:) = ' @@ -197,7 +774,58 @@ subroutine da_qc_goesabi(it, i, nchan, ob, iv) close(fgat_rad_unit) call da_free_unit(fgat_rad_unit) end if - if (trace_use_dull) call da_trace_exit("da_qc_goesabi.inc") + + if (trace_use) call da_trace_exit("da_qc_goesabi") end subroutine da_qc_goesabi + + +function relative_azimuth ( sol_az ,sen_az ) + + implicit none + + real :: sol_az + real :: sen_az + real :: relative_azimuth + +!JJG: why all the corrections? abs? 360-rel_az? 180-rel_az? + + relative_azimuth = abs(sol_az - sen_az) + if (relative_azimuth > 180.0) then + relative_azimuth = 360.0 - relative_azimuth + endif + relative_azimuth = 180.0 - relative_azimuth + +end function relative_azimuth + + +function glint_angle ( sol_zen , sat_zen , rel_az ) + !------------------------------------------------------------------------------------ + ! Glint angle (the angle difference between direct "specular" reflection off + ! the surface and actual reflection toward the satellite.) + !------------------------------------------------------------------------------------ + + implicit none + + real :: sol_zen + real :: sat_zen + real :: rel_az + real :: glint_angle + + glint_angle = cos(sol_zen * deg2rad) * cos(sat_zen * deg2rad) + & + sin(sol_zen * deg2rad) * sin(sat_zen * deg2rad) * cos(rel_az * deg2rad) + glint_angle = max(-1.0 , min( glint_angle ,1.0 )) + glint_angle = acos(glint_angle) / deg2rad + +end function glint_angle + + + + + + + + + + diff --git a/var/da/da_radiance/da_radiance.f90 b/var/da/da_radiance/da_radiance.f90 index 33c4090b42..6346033641 100644 --- a/var/da/da_radiance/da_radiance.f90 +++ b/var/da/da_radiance/da_radiance.f90 @@ -62,7 +62,7 @@ module da_radiance airs_warmest_fov, time_slots, interp_option, ids, ide, jds, jde, & ips, ipe, jps, jpe, simulated_rad_ngrid, obs_qc_pointer, use_blacklist_rad, use_satcv, & use_goesimgobs, use_goesabiobs, pi, earth_radius, satellite_height, & - var4d, var4d_bin + var4d, var4d_bin, use_clddet_zz #ifdef CRTM use da_crtm, only : da_crtm_init, da_get_innov_vector_crtm @@ -128,8 +128,10 @@ module da_radiance #include "da_read_obs_hdf5amsr2.inc" #include "da_read_obs_ncgoesimg.inc" #include "da_read_obs_ncgoesabi.inc" -#include "da_get_satzen.inc" -#include "da_get_satzen_1d.inc" +#include "da_get_sat_angles.inc" +#include "da_get_sat_angles_1d.inc" +#include "da_get_solar_angles.inc" +#include "da_get_solar_angles_1d.inc" #include "da_allocate_rad_iv.inc" #include "da_initialize_rad_iv.inc" #include "da_read_kma1dvar.inc" diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index 73a09ce08b..fb8fbb0d28 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -9,9 +9,11 @@ module da_radiance1 #ifdef CRTM use module_radiance, only : CRTM_Planck_Radiance, CRTM_Planck_Temperature #endif + use module_radiance, only : & #ifdef RTTOV - use module_radiance, only : coefs + coefs, & #endif + deg2rad use da_control, only : trace_use,missing_r, rootproc, & stdout,myproc,qc_good,num_fgat_time,qc_bad, & @@ -20,11 +22,11 @@ module da_radiance1 rtm_option_rttov,rtm_option_crtm, radiance, only_sea_rad, & global, gas_constant, gravity, monitor_on,kts,kte,use_rttov_kmatrix, & use_pseudo_rad, pi, t_triple, crtm_cloud, DT_cloud_model,write_jacobian, & - use_crtm_kmatrix,use_clddet_mmr, use_satcv, cv_size_domain, & + use_crtm_kmatrix,use_clddet_mmr, use_clddet_zz, use_satcv, cv_size_domain, & cv_size_domain_js, calc_weightfunc, use_clddet_ecmwf, deg_to_rad, rad_to_deg use da_define_structures, only : info_type,model_loc_type,maxmin_type, & iv_type, y_type, jo_type,bad_data_type,bad_data_type,number_type, & - be_type + be_type, cld_qc_type use module_dm, only : wrf_dm_sum_real, wrf_dm_sum_integer use da_par_util, only : da_proc_stats_combine use da_par_util1, only : da_proc_sum_int,da_proc_sum_ints @@ -41,12 +43,12 @@ module da_radiance1 #endif implicit none - + type datalink_type type (info_type) :: info type (model_loc_type) :: loc - + type (cld_qc_type), pointer :: cld_qc => null() integer :: ifgat, landsea_mask, rain_flag integer :: scanline, scanpos real :: satzen, satazi, solzen, solazi ! satellite and solar angles diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 1f34b4c11c..d012de1d4d 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -19,9 +19,11 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! THINNING: thinning_grid ! GENERAL OBS: num_fgat_time, time_slots ! WRFDA types: iv_type, datalink_type, info_type, model_loc_type - ! WRFDA subs: da_get_satzen, da_llxy, da_get_unit, da_free_unit, da_get_julian_time - ! da_trace_entry, da_trace_exit - ! precisions: r_kind, i_kind + ! WRFDA subs: da_llxy, da_get_julian_time, + ! da_get_unit, da_free_unit, + ! da_get_sat_angles(_1d), da_get_solar_angles(_1d) + ! da_trace_entry, da_trace_exit, + ! precisions: r_double, i_kind type (iv_type),intent (inout) :: iv integer, intent(in) :: satellite_id ! 16 or 17 @@ -30,7 +32,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) type(info_type) :: info type(model_loc_type) :: loc integer(i_kind), allocatable :: ptotal(:) - real(r_kind) :: crit + real(r_double) :: crit integer(i_kind) :: iout, iobs, i_dummy(1) logical :: outside, outside_all, iuse, first_chan logical :: found, head_found @@ -42,20 +44,34 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: nbuf, nrad_local, nrad_mask, buf_i, buf_f integer, allocatable :: nbufs(:), displs(:) integer :: ny_local, nx_local - integer :: ys_local, xs_local !! Earth location info real, allocatable :: yy_abi(:), xx_abi(:) real, allocatable :: yy_1d(:), xx_1d(:) real, allocatable :: iy_1d(:), ix_1d(:) + real, allocatable :: solzen_1d(:), solazi_1d(:) - real(r_kind) :: req, rpol, pph, nam -!!! real :: lat_sat, lon_sat ! Assume fixed values in da_get_satzen + real(r_double) :: req, rpol, pph, nam +!!! real :: lat_sat, lon_sat ! Assume fixed values in da_get_sat_angles real, allocatable, target :: buf_real(:,:) integer, allocatable, target :: buf_int(:,:) type(model_loc_type), allocatable, target :: buf_loc(:) type(info_type), allocatable :: info_1d(:) + + !Cloud QC variables + integer :: tbuf, nkeep, ikeep + integer :: cld_qc_buffer ! Must be ≥ 0 + real :: mean10, mean14, sigma10, sigma14, pearson, temp_max + real, allocatable :: tb_10(:), tb_14(:) + logical :: cldqc + character(18), parameter :: terr_fname = 'OR_ABI-TERR_G16.nc' + + integer :: TEMPIR_ifile + real :: TEMPIR_min_time_diff, TEMPIR_time_abs_diff + real, parameter :: TEMPIR_delay_minutes = 15.0 + + ! Masks for data reduction !!! logical :: include_local, load_balance logical :: earthmask, zenmask @@ -66,6 +82,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) patchmask_1d(:) , & dummybool_2d(:,:) , & allmask_p(:,:) , & + readmask_p(:,:) , & thinmask(:,:) logical, allocatable :: view_mask(:,:,:,:,:) @@ -74,12 +91,12 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Brightness Temperature (K) - real, allocatable :: bt_p(:,:) + real, allocatable :: bt_p(:,:,:), terrain_hgt(:,:) !! Iterates integer :: ichan, ifile, iview, ifgat, ipass, ioff, & jchan, jfile, jview, icount, & - n, i, j, iy, ix, iyl, ixl, iyfd, ixfd, iproc, subgrid + n, i, j, iy, ix, jy, jx, iyl, ixl, iyfd, ixfd, iproc, subgrid !! Satellite variables integer(i_kind),parameter :: nchan = 10 @@ -97,12 +114,13 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: file_unit type date_type - integer :: yr, mt, dy, hr, mn, sc + integer :: yr, mt, dy, hr, mn, sc, jdy + real(r_double) :: obs_time end type date_type ! ! Linked list type for radiance location information ! type viewnode -! real :: lat, lon, satzen +! real :: lat, lon, satzen, satazi ! integer :: iy, ix ! type(model_loc_type) :: loc ! type(viewnode), pointer :: next @@ -133,10 +151,12 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer, allocatable :: filechan(:) type(date_type), allocatable :: filedate(:) logical, allocatable :: file_fgat_match(:,:) - real*8, allocatable :: fgat_time_diff(:,:) ! seconds + real*8, allocatable :: fgat_time_abs_diff(:,:) ! seconds real*8, allocatable :: min_time_diff(:,:) ! seconds integer, allocatable :: nfiles_used(:) integer :: ny_global, nx_global, yoff_fd, xoff_fd + integer :: ys_local, xs_local + integer :: ye_local, xe_local integer, allocatable :: ny_grid(:), nx_grid(:) integer, allocatable :: ys_grid(:), xs_grid(:) integer :: ys_p, xs_p @@ -144,11 +164,12 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: ys_p_fd, xs_p_fd integer :: ye_p_fd, xe_p_fd integer :: nrad_on_patch, nrad_on_domain - logical, allocatable :: patchmask(:,:) + integer :: nrad_on_patch_cldqc, nrad_on_domain_cldqc + logical, allocatable :: patchmask(:,:,:) ! type(viewnode), pointer :: head ! type(viewnode), pointer :: current - type(field_r) :: lat_1d, lon_1d, satzen_1d + type(field_r) :: lat_1d, lon_1d, satzen_1d, satazi_1d type(field_i) :: iy_1d, ix_1d type(field_loc) :: loc_1d @@ -170,16 +191,16 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Global WRFDA obs timing info character(len=19) :: fgat_times_c(num_fgat_time) - real(r_kind) :: fgat_times_r(num_fgat_time) + real(r_double) :: fgat_times_r(num_fgat_time) ! Local Obs date/time variables - real(r_kind) :: obs_time + real(r_double) :: obs_time integer(i_kind) :: yr, mt, dy, hr, mn, sc, jdy - real(r_kind) :: timbdy(2) + real(r_double) :: timbdy(2) ! Other work variables - real(r_kind) :: dlon_earth,dlat_earth,dlon_earth_deg,dlat_earth_deg - real(r_kind) :: ngoes + real(r_double) :: dlon_earth,dlat_earth,dlon_earth_deg,dlat_earth_deg + real(r_double) :: ngoes integer(i_kind) :: num_goesabi_local, num_goesabi_global, num_goesabi_used, & num_goesabi_used_tmp, num_goesabi_thinned integer(i_kind) :: itx, itt @@ -242,7 +263,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end do allocate(view_att(nviews)) - view_att(:) % select = .true. ! Need to set this according to namelist entries + ! (default) All views are used (algorithm figures out which views have files present) + ! Could set this according to namelist entries + view_att(:) % select = .true. view_att(1) % name_short = 'F' view_att(2) % name_short = 'C' view_att(3) % name_short = 'M1' @@ -258,11 +281,18 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) view_att(3) % fpath = './goes-meso/' view_att(4) % fpath = './goes-meso/' + ! (default) Full Disk and CONUS are fixed while MESO 1 & 2 can move within an assimilation window view_att(1) % moving = .false. view_att(2) % moving = .false. view_att(3) % moving = .true. view_att(4) % moving = .true. +! ! Full Disk, CONUS, and MESO 1 & 2 are fixed within an assimilation window (e.g., 3D-Var) +! view_att(1) % moving = .false. +! view_att(2) % moving = .false. +! view_att(3) % moving = .false. +! view_att(4) % moving = .false. + !! Initialize local obs structures allocate (head) nullify (head % next ) @@ -273,10 +303,21 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) num_goesabi_used = 0 num_goesabi_thinned = 0 + if ( use_clddet_zz ) then + cld_qc_buffer = 10 + else + cld_qc_buffer = 0 + end if - !! Take 2 passes over the data: - !! + 1st pass: determine which views should be used for each fgat and each channel across observed domain - !! + 2nd pass: read radiance values and convert to BT + !! If Full Disk is selected, take 2 passes over the data: + !! + 1st pass: (A) Determine portions of each view corresponding to this patch + !! for each fgat and each channel across observed domain + !! (B) Eliminate portions of broader views (Full Disk and CONUS) that + !! can be replaced by narrower views (CONUS and MESO) with times + !! closer to fgat time + !! + 2nd pass: read radiance values, convert to BT, calculate quantities for online cloud detection QC + !! + !! Otherwise only take one pass, and duplicated data cannot be removed from CONUS/MESO npass = 1 if (nviews.gt.1 .and. view_att(1) % select) npass = 2 @@ -347,17 +388,17 @@ write(stdout,*) trim(command) allocate(this_view % filechan(this_view % nfiles)) allocate(this_view % filedate(this_view % nfiles)) allocate(this_view % file_fgat_match(this_view % nfiles,num_fgat_time)) - allocate(this_view % fgat_time_diff(this_view % nfiles,num_fgat_time)) + allocate(this_view % fgat_time_abs_diff(this_view % nfiles,num_fgat_time)) allocate(this_view % min_time_diff(nchan,num_fgat_time)) allocate(this_view % nfiles_used(num_fgat_time)) this_view % file_fgat_match = .false. do ifgat=1,num_fgat_time - this_view % fgat_time_diff(:,ifgat) = & - (time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 !seconds + this_view % fgat_time_abs_diff(:,ifgat) = & + abs(time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 !seconds this_view % min_time_diff(:,ifgat) = & - (time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 / 2.D0 !seconds + abs(time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 / 2.D0 !seconds end do !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -438,6 +479,8 @@ write(stdout,*) trim(command) this_view % filedate(ifile) % hr = hr this_view % filedate(ifile) % mn = mn this_view % filedate(ifile) % sc = sc + this_view % filedate(ifile) % jdy = jdy + this_view % filedate(ifile) % obs_time = obs_time if ( obs_time < time_slots(0) * 60.D0 .or. & obs_time >= time_slots(num_fgat_time) * 60.D0 ) then @@ -451,15 +494,15 @@ write(stdout,*) trim(command) if (this_view % file_fgat_match(ifile,ifgat)) exit end do - this_view % fgat_time_diff(ifile,ifgat) = & + this_view % fgat_time_abs_diff(ifile,ifgat) = & abs( obs_time - fgat_times_r(ifgat) ) call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) - if ( abs(this_view % fgat_time_diff(ifile, ifgat)) .ge. & + if ( this_view % fgat_time_abs_diff(ifile, ifgat) .ge. & this_view % min_time_diff(ichan, ifgat) ) then this_view % file_fgat_match(ifile,ifgat) = .false. else - this_view % min_time_diff(ichan, ifgat) = abs(this_view % fgat_time_diff(ifile, ifgat)) + this_view % min_time_diff(ichan, ifgat) = this_view % fgat_time_abs_diff(ifile, ifgat) end if if (count(this_view % file_fgat_match(ifile,:)) .gt. 1) then @@ -490,7 +533,7 @@ write(stdout,*) trim(command) do ifile = 1, this_view % nfiles if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) - if ( abs(this_view % fgat_time_diff(ifile, ifgat)) .gt. & + if ( this_view % fgat_time_abs_diff(ifile, ifgat) .gt. & this_view % min_time_diff(ichan, ifgat) ) then this_view % file_fgat_match(ifile,ifgat) = .false. end if @@ -505,10 +548,22 @@ write(stdout,*) trim(command) end do if (first_file .eq. 0) cycle - write(unit=stdout,fmt='(A,I0,A)') & - 'Processing GOES-',satellite_id,' ABI data for:' - write(unit=stdout,fmt='(4A)') & - ' ',trim(this_view % name)," ; ",fgat_times_c(ifgat) + if ( sum(this_view % nfiles_used(:)).eq.0) & + write(unit=stdout,fmt='(A,I0,2A)') & + 'Processing GOES-',satellite_id,' ABI data for view: ', trim(this_view % name) + write(unit=stdout,fmt=*) '' + write(unit=stdout,fmt='(2A)') & + ' fgat time: ',fgat_times_c(ifgat) + + yr = this_view % filedate(first_file) % yr + mt = this_view % filedate(first_file) % mt + dy = this_view % filedate(first_file) % dy + hr = this_view % filedate(first_file) % hr + mn = this_view % filedate(first_file) % mn + sc = this_view % filedate(first_file) % sc + write(unit=stdout, & + fmt='(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & + ' data time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc fname_short = trim(this_view % filename(first_file)) fname = trim(this_view % fpath)//trim(fname_short) @@ -543,7 +598,6 @@ write(stdout,*) trim(command) this_view % ys_grid = 1 this_view % xs_grid = 1 #endif - end if ! Recall global dims for this_view @@ -555,12 +609,12 @@ write(stdout,*) trim(command) !! + CONUS or FD and first matching fgat !! + MESO and any fgat (extent changes in time) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - DoGridGen: if ( ( ipass.eq.1 .and. sum(this_view % nfiles_used(:)).eq.0 ) & - .or. this_view % moving ) then + DoGridGen: if ( this_view % moving .or. & + ( ipass.eq.1 .and. sum(this_view % nfiles_used(:)).eq.0 ) ) then - ! Read grid from file, convert to lat, lon, satzen + ! Read grid from file, convert to lat, lon, satzen, satazi write(unit=stdout,fmt='(2A)') & - ' Reading/calculating abi grid info...' + ' Establishing abi grid info...' !======================================================== ! Establish GOES metadata for this view and ifgat @@ -589,7 +643,8 @@ write(stdout,*) trim(command) !=========================================================== !!! load_balance = any(iview.eq.(/1,2/)) !!! if (load_balance) then - nrad_local = ny_global * nx_global / num_procs + 1 +! nrad_local = ny_global * nx_global / num_procs + 1 + nrad_local = ny_global * nx_global / (num_procs-1) !!! else !!! nrad_local = this_view % ny_grid(iproc+1) * this_view % nx_grid(iproc+1) !!! end if @@ -599,7 +654,7 @@ write(stdout,*) trim(command) allocate( iy_1d (nrad_local) ) allocate( ix_1d (nrad_local) ) - n = 0 ; icount = 1 + n = 0 ; icount = 0 ! This loop over subgrids and the selective logic ! below for myproc balances the processor loads ! when some imager pixels are off-earth or outside @@ -608,8 +663,8 @@ write(stdout,*) trim(command) ! Recall local dims for this_view ny_local = this_view % ny_grid(subgrid) nx_local = this_view % nx_grid(subgrid) - ys_local = this_view % ys_grid(subgrid) - xs_local = this_view % xs_grid(subgrid) + this_view % ys_local = this_view % ys_grid(subgrid) + this_view % xs_local = this_view % xs_grid(subgrid) !!! !This version of include_local produces unbalanced loads between processors !!! include_local = ( subgrid-1 .eq. myproc ) @@ -622,47 +677,53 @@ write(stdout,*) trim(command) !!! if ( include_local ) then if ( mod( n, num_procs ) .eq. myproc ) then - iy = iyl + ys_local - 1 - ix = ixl + xs_local - 1 - yy_1d(icount) = yy_abi( iy ) - xx_1d(icount) = xx_abi( ix ) - iy_1d(icount) = iy - ix_1d(icount) = ix - icount = icount + 1 + iy = iyl + this_view % ys_local - 1 + ix = ixl + this_view % xs_local - 1 + yy_1d ( icount ) = yy_abi( iy ) + xx_1d ( icount ) = xx_abi( ix ) + iy_1d ( icount ) = iy + ix_1d ( icount ) = ix end if n = n + 1 end do end do end do - nrad_local = icount - 1 + nrad_local = icount deallocate( yy_abi, xx_abi ) - allocate( earthmask_1d (nrad_local) ) - allocate( zenmask_1d (nrad_local) ) - allocate( this_view % lat_1d % local (nrad_local) ) - allocate( this_view % lon_1d % local (nrad_local) ) - allocate( this_view % satzen_1d % local (nrad_local) ) - allocate( this_view % iy_1d % local (nrad_local) ) - allocate( this_view % ix_1d % local (nrad_local) ) + allocate( earthmask_1d (1:nrad_local) ) + allocate( zenmask_1d (1:nrad_local) ) + allocate( this_view % lat_1d % local (1:nrad_local) ) + allocate( this_view % lon_1d % local (1:nrad_local) ) + allocate( this_view % satzen_1d % local (1:nrad_local) ) + allocate( this_view % satazi_1d % local (1:nrad_local) ) + allocate( this_view % iy_1d % local (1:nrad_local) ) + allocate( this_view % ix_1d % local (1:nrad_local) ) - ! Assign values for iy, ix, lat, lon, satzen + ! Assign values for iy, ix, lat, lon, satzen, satazi this_view % iy_1d % local = iy_1d (1:nrad_local) this_view % ix_1d % local = ix_1d (1:nrad_local) deallocate( iy_1d ) deallocate( ix_1d ) - call get_abil1b_grid2_1d( yy_1d(1:nrad_local), xx_1d(1:nrad_local), & - req, rpol, pph, nam, satellite_id, & - this_view % lat_1d % local, & - this_view % lon_1d % local, & - this_view % satzen_1d % local, & - earthmask_1d, zenmask_1d ) + write(unit=stdout,fmt='(3A,I0)') & + ' ',trim(this_view % name),' locations processed on this core: ', nrad_local + + if (nrad_local .gt. 0) & + call get_abil1b_grid2_1d( yy_1d(1:nrad_local), xx_1d(1:nrad_local), & + req, rpol, pph, nam, satellite_id, & + this_view % lat_1d % local, & + this_view % lon_1d % local, & + this_view % satzen_1d % local, & + this_view % satazi_1d % local, & + earthmask_1d, zenmask_1d ) - ! Reduce values for iy, ix, lat, lon, satzen using earth and zenith masks + ! Reduce values for iy, ix, lat, lon, satzen, satazi + ! using earth and zenith masks nrad_mask = count ( earthmask_1d .and. zenmask_1d ) this_view % lat_1d % local(1:nrad_mask) = & pack(this_view % lat_1d % local , earthmask_1d .and. zenmask_1d ) @@ -670,6 +731,8 @@ write(stdout,*) trim(command) pack(this_view % lon_1d % local , earthmask_1d .and. zenmask_1d ) this_view % satzen_1d % local(1:nrad_mask) = & pack(this_view % satzen_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % satazi_1d % local(1:nrad_mask) = & + pack(this_view % satazi_1d % local , earthmask_1d .and. zenmask_1d ) this_view % iy_1d % local(1:nrad_mask) = & pack(this_view % iy_1d % local , earthmask_1d .and. zenmask_1d ) this_view % ix_1d % local(1:nrad_mask) = & @@ -695,7 +758,9 @@ write(stdout,*) trim(command) deallocate( info_1d ) nrad_mask = count( domainmask_1d ) - +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif ! COMMUNICATE 1D FIELDS FROM REMOTE PROCS TO LOCAL BUFFER ! Note: these comms are a minor bottleneck, which will be ! more noticeable for 4D-Var when MESO1/2 is processed @@ -712,6 +777,8 @@ write(stdout,*) trim(command) !! pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) !! this_view % satzen_1d % local (1:nrad_mask) = & !! pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % satazi_1d % local (1:nrad_mask) = & +!! pack(this_view % satazi_1d % local (1:nrad_local), domainmask_1d ) !! this_view % iy_1d % local (1:nrad_mask) = & !! pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) !! this_view % ix_1d % local (1:nrad_mask) = & @@ -737,7 +804,7 @@ write(stdout,*) trim(command) ! ! this_view % nrad_on_domain = sum( nbufs ) ! -! allocate( buf_real( this_view % nrad_on_domain, 3 ) ) +! allocate( buf_real( this_view % nrad_on_domain, 4 ) ) ! allocate( buf_int ( this_view % nrad_on_domain, 2 ) ) ! allocate( buf_loc ( this_view % nrad_on_domain ) ) ! @@ -755,6 +822,8 @@ write(stdout,*) trim(command) ! pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) ! buf_real( buf_i:buf_f, 3 ) = & ! pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) +! buf_real( buf_i:buf_f, 4 ) = & +! pack(this_view % satazi_1d % local (1:nrad_local), domainmask_1d ) ! buf_int ( buf_i:buf_f, 1 ) = & ! pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) ! buf_int ( buf_i:buf_f, 2 ) = & @@ -775,6 +844,8 @@ write(stdout,*) trim(command) ! call mpi_allgatherv ( & ! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,3), nbufs, displs, true_mpi_real, comm, ierr ) ! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,4), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & ! MPI_IN_PLACE, 0, mpi_integer, buf_int(:,1), nbufs, displs, mpi_integer, comm, ierr ) ! call mpi_allgatherv ( & ! MPI_IN_PLACE, 0, mpi_integer, buf_int(:,2), nbufs, displs, mpi_integer, comm, ierr ) @@ -793,6 +864,9 @@ write(stdout,*) trim(command) !! this_view % satzen_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & !! buf_real(:,3), nbufs, displs, true_mpi_real, comm, ierr ) !! call mpi_allgatherv ( & +!! this_view % satazi_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,4), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & !! this_view % iy_1d % local (1:nrad_mask), nrad_mask, mpi_integer, & !! buf_int(:,1), nbufs, displs, mpi_integer, comm, ierr ) !! call mpi_allgatherv ( & @@ -808,6 +882,7 @@ write(stdout,*) trim(command) !! buf_real( :, 1 ) = this_view % lat_1d % local (1:nrad_mask) !! buf_real( :, 2 ) = this_view % lon_1d % local (1:nrad_mask) !! buf_real( :, 3 ) = this_view % satzen_1d % local (1:nrad_mask) +!! buf_real( :, 4 ) = this_view % satazi_1d % local (1:nrad_mask) !! buf_int ( :, 1 ) = this_view % iy_1d % local (1:nrad_mask) !! buf_int ( :, 2 ) = this_view % ix_1d % local (1:nrad_mask) !! buf_loc ( : ) % y = this_view % loc_1d % local (1:nrad_mask) % y @@ -823,7 +898,7 @@ write(stdout,*) trim(command) #else nbuf = nrad_mask #endif - allocate( buf_real( nbuf, 3 ) ) + allocate( buf_real( nbuf, 4 ) ) allocate( buf_int ( nbuf, 2 ) ) allocate( buf_loc ( nbuf ) ) @@ -847,6 +922,8 @@ write(stdout,*) trim(command) pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) buf_real( buf_i:buf_f, 3 ) = & pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) + buf_real( buf_i:buf_f, 4 ) = & + pack(this_view % satazi_1d % local (1:nrad_local), domainmask_1d ) buf_int ( buf_i:buf_f, 1 ) = & pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) buf_int ( buf_i:buf_f, 2 ) = & @@ -863,7 +940,7 @@ write(stdout,*) trim(command) end if #ifdef DM_PARALLEL !PERFORM COMMS - call mpi_bcast(buf_real(buf_i:buf_f,:), nbuf * 3, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast(buf_real(buf_i:buf_f,:), nbuf * 4, true_mpi_real, iproc, comm, ierr ) call mpi_bcast(buf_int (buf_i:buf_f,:), nbuf * 2, mpi_integer, iproc, comm, ierr ) !Only x & y components of loc need to be communicated @@ -877,6 +954,7 @@ write(stdout,*) trim(command) deallocate ( this_view % lat_1d % local ) deallocate ( this_view % lon_1d % local ) deallocate ( this_view % satzen_1d % local ) + deallocate ( this_view % satazi_1d % local ) deallocate ( this_view % iy_1d % local ) deallocate ( this_view % ix_1d % local ) deallocate ( this_view % loc_1d % local ) @@ -886,11 +964,12 @@ write(stdout,*) trim(command) this_view % lat_1d % domain => buf_real(:,1) this_view % lon_1d % domain => buf_real(:,2) this_view % satzen_1d % domain => buf_real(:,3) + this_view % satazi_1d % domain => buf_real(:,4) this_view % iy_1d % domain => buf_int (:,1) this_view % ix_1d % domain => buf_int (:,2) this_view % loc_1d % domain => buf_loc (:) - -write(stdout,fmt=*) 'Total locations within domain: ', this_view % nrad_on_domain + write(unit=stdout,fmt='(3A,I0)') & + ' ',trim(this_view % name),' locations within domain: ', this_view % nrad_on_domain ! Populate remainder of loc and determine in/outside patch allocate ( patchmask_1d (this_view % nrad_on_domain) ) @@ -900,8 +979,8 @@ write(stdout,fmt=*) 'Total locations within domain: ', this_view % nrad_on_domai patchmask_1d = .not.dummybool_2d(:,1) deallocate( dummybool_2d ) this_view % nrad_on_patch = count(patchmask_1d) - -write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_on_patch + write(unit=stdout,fmt='(3A,I0)') & + ' ',trim(this_view % name),' locations within this subdomain: ', this_view % nrad_on_patch if ( this_view % nrad_on_patch .gt. 0 ) then if ( allocated ( this_view % patchmask ) ) then @@ -909,6 +988,7 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ deallocate ( this_view % lat_1d % patch ) deallocate ( this_view % lon_1d % patch ) deallocate ( this_view % satzen_1d % patch ) + deallocate ( this_view % satazi_1d % patch ) deallocate ( this_view % iy_1d % patch ) deallocate ( this_view % ix_1d % patch ) deallocate ( this_view % loc_1d % patch ) @@ -916,6 +996,7 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ allocate( this_view % lat_1d % patch (this_view % nrad_on_patch) ) allocate( this_view % lon_1d % patch (this_view % nrad_on_patch) ) allocate( this_view % satzen_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % satazi_1d % patch (this_view % nrad_on_patch) ) allocate( this_view % iy_1d % patch (this_view % nrad_on_patch) ) allocate( this_view % ix_1d % patch (this_view % nrad_on_patch) ) allocate( this_view % loc_1d % patch (this_view % nrad_on_patch) ) @@ -926,6 +1007,8 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ pack( this_view % lon_1d % domain, patchmask_1d ) this_view % satzen_1d % patch = & pack( this_view % satzen_1d % domain, patchmask_1d ) + this_view % satazi_1d % patch = & + pack( this_view % satazi_1d % domain, patchmask_1d ) this_view % iy_1d % patch = & pack( this_view % iy_1d % domain, patchmask_1d ) this_view % ix_1d % patch = & @@ -933,7 +1016,7 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ this_view % loc_1d % patch = & pack( this_view % loc_1d % domain, patchmask_1d ) - ! Determine ys, ye, xs, xe for this patch and for Full Disk offset grid + ! Determine grid extents for this patch on this_view and on Full Disk this_view % ys_p = minval(this_view % iy_1d % patch) this_view % ye_p = maxval(this_view % iy_1d % patch) this_view % xs_p = minval(this_view % ix_1d % patch) @@ -943,23 +1026,55 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ this_view % xs_p_fd = this_view % xs_p + this_view % xoff_fd - 1 this_view % xe_p_fd = this_view % xe_p + this_view % xoff_fd - 1 - ! Setup patch mask for this view - allocate(this_view % patchmask( & - this_view % ys_p:this_view % ye_p, & - this_view % xs_p:this_view % xe_p )) + write(stdout,*) 'ABI grid extents for this view:' + write(stdout,'(A,4I10)') 'ys_p, ye_p, xs_p, xe_p ',this_view % ys_p, this_view % ye_p, this_view % xs_p, this_view % xe_p + write(stdout,*) 'ABI grid extents for Full Disk:' + write(stdout,'(A,4I10)') 'ys_p_fd, ye_p_fd, xs_p_fd, xe_p_fd',this_view % ys_p_fd, this_view % ye_p_fd, this_view % xs_p_fd, this_view % xe_p_fd + + ! Setup ZZ clddet extents + this_view % ys_local = max(this_view % ys_p - cld_qc_buffer, 1) + this_view % ye_local = min(this_view % ye_p + cld_qc_buffer, ny_global) + this_view % xs_local = max(this_view % xs_p - cld_qc_buffer, 1) + this_view % xe_local = min(this_view % xe_p + cld_qc_buffer, nx_global) + + ! Setup patch mask for this view, including ZZ clddet buffer + allocate( this_view % patchmask( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) ) this_view % patchmask = .false. do n = 1, this_view % nrad_on_patch - this_view % patchmask ( this_view % iy_1d % patch (n) & - , this_view % ix_1d % patch (n) & - ) = .true. + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + + cldqc = .true. + do jy = iy - cld_qc_buffer, iy + cld_qc_buffer + do jx = ix - cld_qc_buffer, ix + cld_qc_buffer + if ( & + jy.ge.1 .and. jy.le.ny_global & + .and. jx.ge.1 .and. jx.le.nx_global & + ) then + this_view % patchmask ( jy, jx, 2 ) = .true. + else + cldqc = .false. + end if + end do + end do + this_view % patchmask ( iy, ix, 1 ) = cldqc end do + this_view % nrad_on_patch_cldqc = count( this_view % patchmask (:,:,1) ) + else + this_view % nrad_on_patch_cldqc = 0 end if + write(unit=stdout,fmt='(3A,I0)') & + ' ',trim(this_view % name),' locations within this subdomain eligible for ZZ clddet: ', this_view % nrad_on_patch_cldqc + !FREE UP POINTERS AND BUFFERS nullify ( this_view % lat_1d % domain ) nullify ( this_view % lon_1d % domain ) nullify ( this_view % satzen_1d % domain ) + nullify ( this_view % satazi_1d % domain ) nullify ( this_view % iy_1d % domain ) nullify ( this_view % ix_1d % domain ) nullify ( this_view % loc_1d % domain ) @@ -967,41 +1082,33 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ deallocate ( patchmask_1d ) #ifdef DM_PARALLEL + call mpi_allreduce( this_view % nrad_on_patch_cldqc, & + this_view % nrad_on_domain_cldqc, & + 1, mpi_integer, mpi_sum, comm, ierr ) call mpi_barrier(comm, ierr) +#else + this_view % nrad_on_domain_cldqc = this_view % nrad_on_patch_cldqc #endif end if DoGridGen if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view % nfiles_used(:)).eq.0 ) then - if (this_view % nrad_on_patch .gt. 0) then - allocate(view_mask(& + if (this_view % nrad_on_patch_cldqc .gt. 0) then + allocate( view_mask( & this_view % ys_p_fd-2:this_view % ye_p_fd+2, & this_view % xs_p_fd-2:this_view % xe_p_fd+2, & - nviews, nchan, num_fgat_time)) + nviews, nchan, num_fgat_time ) ) view_mask = .false. end if use_view_mask = .true. end if - if ( ipass.lt.npass .or. .not.use_view_mask ) then - num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain - ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain - end if - if ( use_view_mask .and. ipass.lt.npass .and. iview .gt. 1 ) then - best_view = .true. -! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations - do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap - best_view = best_view .and. & - this_view % min_time_diff(ichan, ifgat) .lt. & - view_att(jview) % min_time_diff(ichan, ifgat) - end do - if (best_view) then - num_goesabi_global = num_goesabi_global - this_view % nrad_on_domain - ptotal(ifgat) = ptotal(ifgat) - this_view % nrad_on_domain - end if + if ( (ipass.lt.npass .and. iview.eq.1) .or. .not.use_view_mask ) then + num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain_cldqc + ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain_cldqc end if + PatchMatch: if (this_view % nrad_on_patch_cldqc .gt. 0) then - PatchMatch: if (this_view % nrad_on_patch .gt. 0) then ! Loop over channels; each process reads radiance data only for its subdomain ChannelLoop: do ichan = 1, nchan ifile = 0 @@ -1029,30 +1136,43 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if ( iview.eq.1 ) then do n = 1, this_view % nrad_on_patch - iyfd = this_view % iy_1d % patch (n) + this_view % yoff_fd-1 - ixfd = this_view % ix_1d % patch (n) + this_view % xoff_fd-1 - view_mask( iyfd, ixfd, iview, ichan, ifgat) = .true. + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + iyfd = iy + this_view % yoff_fd-1 + ixfd = ix + this_view % xoff_fd-1 + view_mask( iyfd, ixfd, iview, ichan, ifgat) = & + this_view % patchmask ( iy, ix, 1 ) end do - else + else + best_view = .true. +! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations + do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap + best_view = best_view .and. & + this_view % min_time_diff(ichan, ifgat) .lt. & + view_att(jview) % min_time_diff(ichan, ifgat) + end do if ( best_view ) then do n = 1, this_view % nrad_on_patch - iyfd = this_view % iy_1d % patch (n) + this_view % yoff_fd-1 - ixfd = this_view % ix_1d % patch (n) + this_view % xoff_fd-1 - view_mask( iyfd, ixfd, iview, ichan, ifgat) = .true. + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + if ( this_view % patchmask ( iy, ix, 1 ) ) then + iyfd = iy + this_view % yoff_fd-1 + ixfd = ix + this_view % xoff_fd-1 - !This assumes MESO1 and MESO2 do not overlap - view_mask( iyfd, ixfd, 1:min(iview-1,2), ichan, ifgat) = .false. + view_mask( iyfd, ixfd, iview, ichan, ifgat) = .true. -! !This assumes MESO1 and MESO2 are in identical locations -! view_mask( iyfd, ixfd, 1:iview-1, ichan, ifgat) = .false. + !This assumes MESO1 and MESO2 do not overlap + view_mask( iyfd, ixfd, 1:min(iview-1,2), ichan, ifgat) = .false. + +! !This assumes MESO1 and MESO2 are in identical locations +! view_mask( iyfd, ixfd, 1:iview-1, ichan, ifgat) = .false. + end if end do end if end if + else if (inst == 0) cycle - fname_short = trim(this_view % filename(ifile)) - fname = trim(this_view % fpath)//trim(fname_short) - !!Utilizing these masks to eliminate data: !! + earthmask !! + zenmask @@ -1061,11 +1181,19 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ !! + patch mask !! + thinning - allocate(allmask_p( & - this_view % ys_p:this_view % ye_p, & - this_view % xs_p:this_view % xe_p )) + allocate( allmask_p( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local ) ) + allmask_p = this_view % patchmask ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 1 ) - allmask_p = this_view % patchmask + allocate( readmask_p( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local ) ) + readmask_p = this_view % patchmask ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) ! Only use locations where this view is nearest to this fgat time ! - only available when FD data present for any fgat time @@ -1073,7 +1201,11 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ if ( count( view_mask ( this_view % ys_p_fd:this_view % ye_p_fd, & this_view % xs_p_fd:this_view % xe_p_fd, & iview, ichan, ifgat ) ) .eq. 0 ) then - deallocate(allmask_p) + deallocate(allmask_p, readmask_p) + + write(unit=stdout,fmt='(3A,I0)') & + ' ZERO pixels selected for ',trim(this_view % name),' on band ', channel_list(ichan) + this_view % nfiles_used(ifgat) = this_view % nfiles_used(ifgat) - 1 cycle end if do n = 1, this_view % nrad_on_patch @@ -1084,6 +1216,9 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ allmask_p( iy, ix ) = & ( allmask_p( iy, ix ) .and. view_mask( iyfd, ixfd, iview, ichan, ifgat) ) + + readmask_p( iy, ix ) = & + ( readmask_p( iy, ix ) .and. view_mask( iyfd, ixfd, iview, ichan, ifgat) ) end do end if @@ -1094,22 +1229,72 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ !! + fgat !! + channel/band !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - write(unit=stdout,fmt='(A,I4)') & - ' Reading abi radiances for band ',ichan + write(unit=stdout,fmt='(A,I0)') & + ' Reading abi radiances for band ',channel_list(ichan) + + TEMPIR_ifile = -1 + if ( use_clddet_zz .and. channel_list(ichan).eq.14 ) then + ! Require earlier file to be withn 1/2 of TEMPIR_delay_minutes + TEMPIR_min_time_diff = 0.5 * TEMPIR_delay_minutes + do jfile = 1, this_view % nfiles + if ( this_view % filechan(jfile) .ne. channel_list(ichan) ) cycle + + obs_time = this_view % filedate(jfile) % obs_time - ! Allocate this patch bt - allocate( bt_p ( this_view % ys_p:this_view % ye_p, & - this_view % xs_p:this_view % xe_p ) ) + TEMPIR_time_abs_diff = & + abs( this_view % filedate(jfile) % obs_time / 60.D0 - & + (this_view % filedate(ifile) % obs_time / 60.D0 - TEMPIR_delay_minutes) ) - ! This reads in bt only for the local patch + if ( TEMPIR_time_abs_diff .lt. TEMPIR_min_time_diff ) TEMPIR_ifile = jfile + end do + end if + + ! Allocate and read bt for this patch and current time + if ( TEMPIR_ifile.gt.0 ) then + allocate( bt_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) ) + else + allocate( bt_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 1 ) ) + end if + + fname_short = trim(this_view % filename(ifile)) + fname = trim(this_view % fpath)//trim(fname_short) call get_abil1b_bt( fname, & - this_view % ys_p, this_view % ye_p, & - this_view % xs_p, this_view % xe_p, & - allmask_p, bt_p ) + this_view % ys_local, this_view % ye_local, & + this_view % xs_local, this_view % xe_local, & + readmask_p, bt_p(:,:,1) ) + + allmask_p = (allmask_p .and. readmask_p) + + if ( TEMPIR_ifile.gt.0 ) then + fname_short = trim(this_view % filename(TEMPIR_ifile)) + fname = trim(this_view % fpath)//trim(fname_short) + call get_abil1b_bt( fname, & + this_view % ys_local, this_view % ye_local, & + this_view % xs_local, this_view % xe_local, & + readmask_p, bt_p(:,:,2) ) + end if + if ( use_clddet_zz .and. channel_list(ichan).eq.14 .and. cld_qc_buffer.ge.1) then + ! Allocate terrain_hgt using local indices for this view + allocate( terrain_hgt ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local ) ) - !! Write bt, lat, lon, and satzen to datalink structures + ! Read terrain file using Full Disk global indices + call get_abil1b_terr( terr_fname, & + this_view % ys_local + this_view % yoff_fd - 1, & + this_view % ye_local + this_view % yoff_fd - 1, & + this_view % xs_local + this_view % xoff_fd - 1, & + this_view % xe_local + this_view % xoff_fd - 1, & + terrain_hgt ) + + end if + !! Write bt, lat, lon, satzen, satazi, solzen, solazi to datalink structures first_chan = (this_view % nfiles_used(ifgat).eq.1) if (first_chan) then p_fgat => p @@ -1121,6 +1306,15 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ mn = this_view % filedate(ifile) % mn sc = this_view % filedate(ifile) % sc + if ( use_clddet_zz ) then + allocate( solzen_1d (this_view % nrad_on_patch) ) + allocate( solazi_1d (this_view % nrad_on_patch) ) + + call da_get_solar_angles_1d ( yr, mt, dy, hr, mn, sc, & + this_view % lat_1d % patch, this_view % lon_1d % patch, & + solzen_1d, solazi_1d ) + end if + allocate(thinmask(this_view % ys_p:this_view % ye_p, & this_view % xs_p:this_view % xe_p)) thinmask = .false. @@ -1147,8 +1341,8 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ dlon_earth = info % lon if (dlon_earth=r360) dlon_earth = dlon_earth-r360 - dlat_earth = dlat_earth*deg2rad - dlon_earth = dlon_earth*deg2rad + dlat_earth = dlat_earth * deg2rad + dlon_earth = dlon_earth * deg2rad crit = 1. call map2grids(inst,ifgat,dlat_earth,dlon_earth,crit,iobs,itx,1,itt,iout,iuse) if (.not. iuse) then @@ -1177,21 +1371,166 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ if (use_view_mask) then p % scanpos = & ( iy + this_view % yoff_fd-1 - 1) * (nscan+1) / view_att(1) % ny_global - ! ??? "scan" position (IS THIS CORRECT?) + ! ??? "scan" position (IS THIS CORRECT? NECESSARY? iFOV?) else p % scanpos = & ( iy + this_view % yoff_fd-1 - 1) * (nscan+1) / 5424 - ! ??? "scan" position (IS THIS CORRECT?) + ! ??? "scan" position (IS THIS CORRECT? NECESSARY? iFOV?) end if p % satzen = this_view % satzen_1d % patch (n) - - p % solzen = 0.0 + p % satazi = this_view % satazi_1d % patch (n) + if ( use_clddet_zz ) then + p % solzen = solzen_1d (n) + p % solazi = solazi_1d (n) + else + p % solzen = missing_r + p % solazi = missing_r + end if p % sensor_index = inst p % ifgat = ifgat end if ! Transfer BT from all files - p % tb_inv(ichan) = bt_p( iy, ix ) + p % tb_inv(ichan) = bt_p( iy, ix, 1 ) + + ! Extract values from cloud QC buffer + if (.not. associated(p % cld_qc)) allocate( p % cld_qc) + + tbuf = 1 + if (cld_qc_buffer.ge.tbuf) then + ! Values for RTCT cloud QC + ! - channel 14 and sigma_z (std. dev. of terrain height in km) + ! w/ landmask and lapse rate of 7 K km^-1 + if (channel_list(ichan).eq.14) then + if ( allocated(terrain_hgt) ) then + temp_max = 0. + do jy = iy-tbuf, iy+tbuf + do jx = ix-tbuf, ix+tbuf + if ( bt_p( jy, jx, 1) .gt. 0. ) & + temp_max = max(temp_max,bt_p( jy, jx, 1 ) ) + end do + end do + + ! Determine sigma_z of terrain height across these pixels + nkeep = count ( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r ) + allocate( tb_14 ( nkeep ) ) + tb_14 = pack( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ), & + terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r) + mean14 = sum( tb_14 ) / real(nkeep,r_double) + sigma14 = sqrt( sum( (tb_14 - mean14)**2 ) / real(nkeep,r_double) ) + deallocate( tb_14 ) + + ! Store RTCT and diagnostic terrain height + p % cld_qc % RTCT = temp_max - p % tb_inv(ichan) - & + 3.0_r_double * 0.007_r_double * sigma14 + p % cld_qc % RTCT_terr = terrain_hgt( iy, ix ) + else + p % cld_qc % RTCT = missing_r + p % cld_qc % RTCT_terr = missing_r + end if + end if + else + if (channel_list(ichan).eq.14) then + p % cld_qc % RTCT = missing_r + p % cld_qc % RTCT_terr = missing_r + end if + end if + + ! Values for RFMFT cloud QC + ! - channels 14 and 15 + tbuf = 10 + if (cld_qc_buffer.ge.tbuf) then + if (channel_list(ichan).eq.14) then + !Determine Neighboring Warm Center (NWC) for this pixel + temp_max = 0. + do jy = iy-tbuf, iy+tbuf + do jx = ix-tbuf, ix+tbuf + if ( bt_p( jy, jx, 1 ) .gt. missing_r ) then + if ( bt_p( jy, jx, 1 ) .gt. temp_max ) then + temp_max = bt_p( jy, jx, 1 ) + p % cld_qc % RFMFT_ij(1) = jy + p % cld_qc % RFMFT_ij(2) = jx + end if + end if + end do + end do + p % cld_qc % RFMFT = & + p % tb_inv(ichan) - temp_max + end if + if (channel_list(ichan).eq.15) then + temp_max = bt_p ( p % cld_qc % RFMFT_ij(1), & + p % cld_qc % RFMFT_ij(2), 1 ) + p % cld_qc % RFMFT = abs( p % cld_qc % RFMFT + & + temp_max - p % tb_inv(ichan) ) + end if + else + if (channel_list(ichan).eq.15) then + p % cld_qc % RFMFT = missing_r + p % cld_qc % RFMFT_ij = -1 + end if + end if + + ! Values for CIRH2O cloud QC + ! - channels 10 and 14 for Pearson correlation coefficient of CIRH2O test + tbuf = 2 + if (cld_qc_buffer.ge.tbuf) then + if (channel_list(ichan).eq.10) then + allocate( p % cld_qc % CIRH2O ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 2 ) ) + p % cld_qc % CIRH2O(:,:,1) = bt_p( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) + end if + if (channel_list(ichan).eq.14) then + p % cld_qc % CIRH2O(:,:,2) = bt_p( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) + nkeep = 0 + do jy = iy-tbuf, iy+tbuf + do jx = ix-tbuf, ix+tbuf + if ( all(p % cld_qc % CIRH2O( jy, jx, : ) .gt. missing_r) ) nkeep = nkeep + 1 + end do + end do + allocate( tb_10 ( nkeep ) ) + allocate( tb_14 ( nkeep ) ) + ikeep = 0 + do jy = iy-tbuf, iy+tbuf + do jx = ix-tbuf, ix+tbuf + if ( all(p % cld_qc % CIRH2O( jy, jx, : ) .gt. missing_r) ) then + ikeep = ikeep + 1 + tb_10(ikeep) = p % cld_qc % CIRH2O( jy, jx, 1 ) + tb_14(ikeep) = p % cld_qc % CIRH2O( jy, jx, 2 ) + end if + end do + end do + mean10 = sum( tb_10 ) / real(nkeep,r_double) + mean14 = sum( tb_14 ) / real(nkeep,r_double) + sigma10 = sqrt( sum( (tb_10 - mean10)**2 ) / real(nkeep,r_double) ) + sigma14 = sqrt( sum( (tb_14 - mean14)**2 ) / real(nkeep,r_double) ) + pearson = sum((tb_10 - mean10) * (tb_14 - mean14)) / real(nkeep,r_double) / & + ( sigma10 * sigma14 ) + deallocate( tb_10 ) + deallocate( tb_14 ) + deallocate( p % cld_qc % CIRH2O ) + allocate( p % cld_qc % CIRH2O (1,1,1) ) + p % cld_qc % CIRH2O (1,1,1) = pearson + end if + else + if (channel_list(ichan).eq.14) then + allocate( p % cld_qc % CIRH2O (1,1,1)) + p % cld_qc % CIRH2O = missing_r + end if + end if + + ! Values for TEMPIR cloud QC + ! - channel 14 + if ( use_clddet_zz ) then + if ( TEMPIR_ifile.gt.0 ) then + if ( bt_p( iy, ix, 2 ) .lt. 330. ) then + p % cld_qc % TEMPIR = bt_p( iy, ix, 2 ) - bt_p( iy, ix, 1 ) + else + p % cld_qc % TEMPIR = missing_r + end if + end if + else + if (channel_list(ichan).eq.14) & + p % cld_qc % TEMPIR = missing_r + end if if (first_chan) & allocate (p % next) ! add next data @@ -1202,17 +1541,20 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ nullify (p % next) end do - deallocate( bt_p, allmask_p ) + deallocate( bt_p, allmask_p, readmask_p) end if VIEW_SELECT end do ChannelLoop - if (allocated(thinmask)) deallocate(thinmask) - + if ( allocated(thinmask) ) deallocate ( thinmask ) + if ( allocated(solzen_1d) ) deallocate ( solzen_1d ) + if ( allocated(solazi_1d) ) deallocate ( solazi_1d ) + if ( allocated(terrain_hgt) ) deallocate ( terrain_hgt ) end if PatchMatch #ifdef DM_PARALLEL call mpi_barrier(comm, ierr) #endif + end do ! end fgat loop if ( (this_view % moving .or. ipass.eq.npass) .and. this_view%nrad_on_patch.gt.0 ) then @@ -1221,18 +1563,19 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ deallocate ( this_view % lat_1d % patch ) deallocate ( this_view % lon_1d % patch ) deallocate ( this_view % satzen_1d % patch ) + deallocate ( this_view % satazi_1d % patch ) deallocate ( this_view % iy_1d % patch ) deallocate ( this_view % ix_1d % patch ) deallocate ( this_view % loc_1d % patch ) end if - tot_files_used = tot_files_used + sum(view_att(iview) % nfiles_used) + if (ipass .eq. 2) tot_files_used = tot_files_used + sum(view_att(iview) % nfiles_used) end do ! end view loop end do ! end pass loop - if (allocated(view_mask)) deallocate(view_mask) + if ( allocated(view_mask) ) deallocate(view_mask) do iview = 1, nviews if ( .not.view_att(iview) % select ) cycle @@ -1241,7 +1584,7 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ deallocate ( this_view % filechan ) deallocate ( this_view % filedate ) deallocate ( this_view % file_fgat_match ) - deallocate ( this_view % fgat_time_diff ) + deallocate ( this_view % fgat_time_abs_diff ) deallocate ( this_view % min_time_diff ) deallocate ( this_view % nfiles_used ) deallocate ( this_view % ny_grid ) @@ -1315,7 +1658,7 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ found = .false. do i = 1, thinning_grid(n,ifgat) % itxmax - if ( thinning_grid(n,ifgat) % ibest_obs(i) == j .and. thinning_grid(n,ifgat) % score_crit(i) < 9.99e6_r_kind ) then + if ( thinning_grid(n,ifgat) % ibest_obs(i) == j .and. thinning_grid(n,ifgat) % score_crit(i) < 9.99e6_r_double ) then found = .true. exit end if @@ -1333,6 +1676,10 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ end if deallocate ( current % tb_inv ) ! deallocate ( current % cloud_flag ) + if (associated(current % cld_qc)) then + if (allocated(current % cld_qc % CIRH2O)) deallocate(current % cld_qc % CIRH2O) + deallocate(current % cld_qc) + end if deallocate ( current ) num_goesabi_thinned = num_goesabi_thinned + 1 num_goesabi_used = num_goesabi_used - 1 @@ -1400,6 +1747,10 @@ write(stdout,fmt=*) 'Total locations within this subdomain: ', this_view % nrad_ ! free current data deallocate ( current % tb_inv ) !!! deallocate ( current % cloud_flag ) + if (associated(current % cld_qc)) then + if (allocated(current % cld_qc % CIRH2O)) deallocate(current % cld_qc % CIRH2O) + deallocate(current % cld_qc) + end if deallocate ( current ) end do deallocate ( p ) @@ -1447,14 +1798,12 @@ subroutine get_abil1b_metadata( filename, & implicit none - character(*), intent(in) :: filename - - integer, intent(out) :: ydim, xdim - real(r_kind), intent(out) :: req, rpol, pph, nam + character(*), intent(in) :: filename + integer, intent(out) :: ydim, xdim + real(r_double), intent(out) :: req, rpol, pph, nam !!! real, intent(out) :: lat_sat, lon_sat integer :: ierr, ncid, varid, dimid - real(r_kind), parameter :: pi=3.1415926535898D0 if (trace_use) call da_trace_entry("get_abil1b_metadata") @@ -1472,7 +1821,7 @@ subroutine get_abil1b_metadata( filename, & ierr=nf_get_att_double(ncid,varid,'semi_minor_axis',rpol) ierr=nf_get_att_double(ncid,varid,'perspective_point_height',pph) ierr=nf_get_att_double(ncid,varid,'longitude_of_projection_origin',nam) - nam=nam*pi/180 + nam = nam * deg2rad !!! ierr=nf_inq_varid(ncid,'nominal_satellite_subpoint_lat',varid) !!! ierr=nf_get_var_double(ncid,varid,lat_sat) @@ -1538,17 +1887,18 @@ end subroutine get_abil1b_grid1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_abil1b_grid2_1d( yy_abi, xx_abi, req, rpol, pph, nam, satellite_id, & - lat, lon, satzen, & + lat, lon, satzen, satazi, & earthmask, zenmask ) implicit none real, intent(in) :: yy_abi(:), xx_abi(:) - real(r_kind), intent(in) :: req, rpol, pph, nam + real(r_double), intent(in) :: req, rpol, pph, nam integer, intent(in) :: satellite_id ! GOES-ABI fields - real, intent(out) :: lat(:), lon(:), satzen(:) + real, intent(out) :: lat(:), lon(:) + real, intent(out) :: satzen(:), satazi(:) logical, intent(out) :: earthmask(:), zenmask(:) ! Internal Variables @@ -1556,7 +1906,7 @@ subroutine get_abil1b_grid2_1d( yy_abi, xx_abi, req, rpol, pph, nam, satellite_i logical :: outside_all, dummy_bool integer :: iy, ix, n - real(r_kind) :: hh + real(r_double) :: hh real, parameter :: satzen_limit=75.0 if (trace_use) call da_trace_entry("get_abil1b_grid2_1d") @@ -1564,6 +1914,7 @@ subroutine get_abil1b_grid2_1d( yy_abi, xx_abi, req, rpol, pph, nam, satellite_i lat = missing_r lon = missing_r satzen = missing_r + satazi = missing_r earthmask=.true. zenmask=.true. @@ -1571,9 +1922,11 @@ subroutine get_abil1b_grid2_1d( yy_abi, xx_abi, req, rpol, pph, nam, satellite_i call get_abil1b_latlon_1d ( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) +!!!JJGDEBUG ! do n = lbound(yy_abi,1), ubound(yy_abi,1) ! call get_abil1b_latlon ( yy_abi(n), xx_abi(n), lat(n), lon(n), req, rpol, hh, nam ) ! end do +!!!JJGDEBUG where( lat.eq.missing_r .OR. lon.eq.missing_r .OR. & isnan(lat) .OR. isnan(lon) ) @@ -1582,14 +1935,18 @@ subroutine get_abil1b_grid2_1d( yy_abi, xx_abi, req, rpol, pph, nam, satellite_i lon = missing_r end where - call da_get_satzen_1d( lat, lon, satellite_id, satzen ) + call da_get_sat_angles_1d( lat, lon, satellite_id, satzen, satazi ) +!!!JJGDEBUG ! do n = lbound(yy_abi,1), ubound(yy_abi,1) -! if ( earthmask(n) ) & -! call da_get_satzen( lat(n), lon(n), satellite_id, satzen(n) ) +! if ( earthmask(n) ) then +! call da_get_sat_angles( lat(n), lon(n), satellite_id, satzen(n), satazi(n) ) +! +! end if ! end do +!!!JJGDEBUG - where ( isnan(satzen) .or. satzen.gt.satzen_limit ) + where ( isnan(satzen) .or. satzen.gt.satzen_limit .or. satzen.eq.missing_r ) satzen = missing_r zenmask = .false. end where @@ -1601,57 +1958,60 @@ end subroutine get_abil1b_grid2_1d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -subroutine get_abil1b_grid2( yy_abi, xx_abi, req, rpol, pph, nam, satellite_id, & - lat, lon, satzen, & - earthmask, zenmask ) - - implicit none - - real, intent(in) :: yy_abi, xx_abi - real(r_kind), intent(in) :: req, rpol, pph, nam - integer, intent(in) :: satellite_id - - ! GOES-ABI fields - real, intent(out) :: lat, lon, satzen - logical, intent(out) :: earthmask, zenmask - - ! Internal Variables - type(info_type) :: info - logical :: outside_all, dummy_bool - - integer :: iy, ix - real(r_kind) :: hh - real, parameter :: satzen_limit=75.0 - - if (trace_use) call da_trace_entry("get_abil1b_grid2") - - lat = missing_r - lon = missing_r - satzen = missing_r - - earthmask=.false. - zenmask=.false. - - hh=pph+req - - call get_abil1b_latlon ( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) - - if( lat.eq.missing_r .OR. lon.eq.missing_r .OR. & - isnan(lat) .OR. isnan(lon) ) return - - earthmask=.true. - - call da_get_satzen(lat,lon,satellite_id,satzen) - - if ( isnan(satzen) .or. satzen.gt.satzen_limit ) then - satzen = missing_r - return - end if - zenmask=.true. - - if (trace_use) call da_trace_exit("get_abil1b_grid2") - -end subroutine get_abil1b_grid2 +!subroutine get_abil1b_grid2( yy_abi, xx_abi, req, rpol, pph, nam, satellite_id, & +! lat, lon, satzen, satazi, & +! earthmask, zenmask ) +! +! implicit none +! +! real, intent(in) :: yy_abi, xx_abi +! real(r_double), intent(in) :: req, rpol, pph, nam +! integer, intent(in) :: satellite_id +! +! ! GOES-ABI fields +! real, intent(out) :: lat, lon +! real, intent(out) :: satzen, satazi +! logical, intent(out) :: earthmask, zenmask +! +! ! Internal Variables +! type(info_type) :: info +! logical :: outside_all, dummy_bool +! +! integer :: iy, ix +! real(r_double) :: hh +! real, parameter :: satzen_limit=75.0 +! +! if (trace_use) call da_trace_entry("get_abil1b_grid2") +! +! lat = missing_r +! lon = missing_r +! satzen = missing_r +! satazi = missing_r +! earthmask=.false. +! zenmask=.false. +! +! hh=pph+req +! +! call get_abil1b_latlon ( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) +! +! if( lat.eq.missing_r .OR. lon.eq.missing_r .OR. & +! isnan(lat) .OR. isnan(lon) ) return +! +! earthmask=.true. +! +! call da_get_sat_angles(lat, lon, satellite_id, satzen, satazi) +!! call da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & +!! lat, lon, solzen, solazi ) +! +! if ( isnan(satzen) .or. satzen.gt.satzen_limit ) then +! satzen = missing_r +! return +! end if +! zenmask=.true. +! +! if (trace_use) call da_trace_exit("get_abil1b_grid2") +! +!end subroutine get_abil1b_grid2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1669,8 +2029,11 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt ) logical, intent(inout) :: radmask( ys:ye, xs:xe ) real, intent(out) :: bt( ys:ye, xs:xe ) - real :: rad(ys:ye, xs:xe) - integer :: DQF(ys:ye, xs:xe) +! real :: rad(ys:ye, xs:xe) +! integer :: DQF(ys:ye, xs:xe) + real :: rad(xs:xe, ys:ye) + integer :: DQF(xs:xe, ys:ye) + integer :: ierr, ncid, varid integer :: iy, ix integer :: nykeep, nxkeep @@ -1696,14 +2059,17 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt ) call handle_err('Error opening file',ierr) ierr=nf_inq_varid( ncid, 'Rad', varid ) - ierr=nf_get_vara_double ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), rad ) + ierr=nf_get_vara_double ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), rad ) +! ierr=nf_get_vara_double ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), rad ) ! rad(ys:ye,xs:xe) ) ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) ierr=nf_get_att_double(ncid,varid,'add_offset',itp) rad=rad*slp+itp ierr=nf_inq_varid ( ncid, 'DQF', varid ) - ierr=nf_get_vara_int ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), DQF ) + ierr=nf_get_vara_int ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), DQF ) +! ierr=nf_get_vara_int ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), DQF ) + ! DQF(ys:ye,xs:xe) ) ierr=nf_inq_varid( ncid, 'planck_bc1', varid ) @@ -1715,20 +2081,28 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt ) ierr=nf_inq_varid( ncid, 'planck_fk2', varid ) ierr=nf_get_var_double( ncid, varid, fk2 ) -! radmask = ( radmask .and. (DQF.eq.0 .or. DQF.eq.1) .and. rad.ge.0.0 ) +! radmask = ( radmask .and. (transpose(DQF).eq.0 .or. transpose(DQF).eq.1) & +! .and. transpose(rad).ge.0.0 ) - radmask = ( radmask .and. (DQF.eq.0 .or. DQF.eq.1) ) - radmask = ( radmask .and. rad.ge.0.0 ) + radmask = ( radmask .and. (transpose(DQF).eq.0 .or. transpose(DQF).eq.1) ) + radmask = ( radmask .and. transpose(rad).ge.0.0 ) + +!! radmask = ( radmask .and. (DQF.eq.0 .or. DQF.eq.1) & +!! .and. rad.ge.0.0 ) +! +! radmask = ( radmask .and. (DQF.eq.0 .or. DQF.eq.1) ) +! radmask = ( radmask .and. rad.ge.0.0 ) where ( radmask ) - bt = ( fk2 / ( alog(( fk1 / rad ) + 1.0) ) - bc1 ) / bc2 +! bt = ( fk2 / ( log(( fk1 / rad ) + 1.0) ) - bc1 ) / bc2 + bt = ( fk2 / ( log(( fk1 / transpose(rad) ) + 1.0) ) - bc1 ) / bc2 end where ! do ix = xs, xe ! do iy = ys, ye ! if ( radmask( iy, ix ) ) then ! if( rad( iy, ix ).ge.0.0 .and. any(DQF( iy, ix ).eq.(/0,1/)) ) then -! bt( iy, ix ) = ( fk2 / ( alog( ( fk1 / rad( iy, ix )) + 1. ) ) - bc1 ) / bc2 +! bt( iy, ix ) = ( fk2 / ( log( ( fk1 / rad( iy, ix )) + 1. ) ) - bc1 ) / bc2 ! else ! radmask( iy, ix ) = .false. ! end if @@ -1750,6 +2124,59 @@ end subroutine get_abil1b_bt !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +subroutine get_abil1b_terr( filename, ys, ye, xs, xe, terr ) + implicit none + + character(*), intent(in) :: filename + + !Size of full data set + + !Starting and stopping indices of this view desired (not equivalent to Full Disk indices) + integer, intent(in) :: ys, ye, xs, xe + real, intent(out) :: terr( ys:ye, xs:xe ) ! unit = meters + + real :: terr_trans( xs:xe, ys:ye ) ! unit = meters + integer :: ncid, varid + integer :: nykeep, nxkeep + real :: terr_miss + + if (trace_use) call da_trace_entry("get_abil1b_terr") + + terr = missing_r + + !! Save rad reading time by selecting a subset of netcdf var + nykeep = ye - ys + 1 + nxkeep = xe - xs + 1 + + if (nykeep.le.0 .or. nxkeep.le.0) then + return + end if + + call handle_err ( 'Error opening file', & + nf_open(trim(filename),nf_nowrite,ncid) ) + call handle_err ( 'Error getting terr ID', & + nf_inq_varid( ncid, 'terr', varid ) ) + call handle_err ( 'Error reading terrain height', & + nf_get_vara_double ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), terr_trans ) ) +! nf_get_vara_double ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), terr ) ) + terr = transpose(terr_trans) + + call handle_err ( 'Error with _FillValue', & + nf_get_att_double(ncid, varid, '_FillValue', terr_miss) ) + + where ( terr .le. terr_miss ) & + terr = missing_r + + call handle_err('Error closing file', & + nf_close(ncid) ) + + if (trace_use) call da_trace_exit("get_abil1b_terr") + +end subroutine get_abil1b_terr + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_abil1b_latlon_1d( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) implicit none @@ -1795,8 +2222,8 @@ subroutine get_abil1b_latlon_1d( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) lat1 = atan( req**2 / rpol**2 * sz / sqrt( ( hh - sx )**2 + sy**2) ) lon1 = nam - atan( sy / ( hh - sx ) ) - lat = lat1 * 180.D0/pi - lon = lon1 * 180.D0/pi + lat = lat1 / deg2rad + lon = lon1 / deg2rad end where deallocate ( lat1, lon1, aa, bb, cc, rs, sx, sy, sz, radicand ) @@ -1837,8 +2264,8 @@ subroutine get_abil1b_latlon( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) lat1 = atan( req**2/rpol**2 * sz / sqrt( ( hh - sx )**2 + sy**2) ) lon1 = nam-atan( sy / ( hh - sx ) ) - lat = lat1 * 180.D0/pi - lon = lon1 * 180.D0/pi + lat = lat1 / deg2rad + lon = lon1 / deg2rad if (trace_use) call da_trace_exit("get_abil1b_latlon") @@ -1976,27 +2403,23 @@ subroutine da_get_cal_time(jmod,yr,mt,dy,hr,mn,sc) implicit none - real(r_kind), intent(in) :: jmod - integer, intent(out) :: yr,mt,dy,hr,mn + real(r_double), intent(in) :: jmod + integer, intent(out) :: yr,mt,dy,hr,mn integer, intent(out), optional :: sc - real(r_kind) :: ju, j0, F + real(r_double) :: ju, j0, F integer :: yr0, sc0 INTEGER :: A, B, C, D, E, Z, ALPHA ! intermediate variables - real(r_kind) :: dd - - ! J2000 Reference time: 2000 Jan 01 00:12:00 - real(r_kind), parameter :: jd_j2000 = 2451545.0 + real(r_double) :: dd - ! This MJD Reference time: 1978 Jan 01 00:00:00 (see da_get_julian_time) - real(r_kind), parameter :: jd_jmod = jd_j2000 - 8035.5 + ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:12:00 (see da_get_julian_time) + real(r_double), parameter :: jd_jmod = 2443510.0 ! Convert to days ju = jmod / 1440.D0 !! Convert reference MJD to actual Julian time ju = ju+jd_jmod - ju = ju + 0.5D0 Z = INT(ju) F = ju - Z diff --git a/var/da/da_radiance/da_read_obs_ncgoesimg.inc b/var/da/da_radiance/da_read_obs_ncgoesimg.inc index 05745c641e..b69fac96a6 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesimg.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesimg.inc @@ -305,7 +305,7 @@ subroutine da_read_obs_ncgoesimg (iv,infile) sat_zen=missing_r do jj=1,dims(2) do ii=1,dims(1) - call da_get_satzen(lat(ii,jj),lon(ii,jj),satellite_id,sat_zen(ii,jj)) + call da_get_sat_angles(lat(ii,jj),lon(ii,jj),satellite_id,sat_zen(ii,jj)) if(sat_zen(ii,jj) > 75.0) sat_zen(ii,jj)=missing_r end do end do diff --git a/var/da/da_radiance/da_rttov.f90 b/var/da/da_radiance/da_rttov.f90 index 9150a87a4e..774f144bb0 100644 --- a/var/da/da_radiance/da_rttov.f90 +++ b/var/da/da_radiance/da_rttov.f90 @@ -31,9 +31,11 @@ module da_rttov num_fgat_time,stdout,trace_use, use_error_factor_rad, & qc_good, qc_bad,myproc,biascorr, global,ims,ime,jms,jme, & use_clddet_mmr, time_slots, rttov_emis_atlas_ir, rttov_emis_atlas_mw, & - use_mspps_emis, use_mspps_ts + use_mspps_emis, use_mspps_ts, use_clddet_zz use da_interpolation, only : da_to_zk_new, & - da_interp_lin_2d, da_interp_lin_3d, da_interp_lin_3d_adj, da_interp_lin_2d_adj + da_interp_lin_2d, da_interp_lin_3d, da_interp_lin_3d_adj, da_interp_lin_2d_adj, & + da_interp_2d_partial + use da_physics, only: da_trop_wmo use da_tools_serial, only : da_get_unit, da_free_unit #ifdef DM_PARALLEL use da_par_util, only : true_mpi_real From cec7099c5a57f02070789e07f5d4954c17382af7 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 22 Aug 2018 16:29:10 -0600 Subject: [PATCH 14/86] Added qualifying limits for three Zhuge and Zou cloud detection tests from the GOES ABI Cloud Mask that were not described in the journal article. Also cleaned up the QC test code. Changes to be committed: modified: da_define_structures/da_define_structures.f90 modified: da_radiance/da_deallocate_radiance.inc modified: da_radiance/da_initialize_rad_iv.inc modified: da_radiance/da_qc_goesabi.inc modified: da_radiance/da_read_obs_ncgoesabi.inc --- .../da_define_structures.f90 | 3 +- var/da/da_radiance/da_allocate_rad_iv.inc | 9 +- var/da/da_radiance/da_deallocate_radiance.inc | 2 + var/da/da_radiance/da_initialize_rad_iv.inc | 4 +- var/da/da_radiance/da_qc_goesabi.inc | 677 ++++++++++++------ var/da/da_radiance/da_read_obs_ncgoesabi.inc | 151 ++-- 6 files changed, 549 insertions(+), 297 deletions(-) diff --git a/var/da/da_define_structures/da_define_structures.f90 b/var/da/da_define_structures/da_define_structures.f90 index 6cf085b001..d56dab2c77 100644 --- a/var/da/da_define_structures/da_define_structures.f90 +++ b/var/da/da_define_structures/da_define_structures.f90 @@ -490,7 +490,8 @@ module da_define_structures end type cv_index_type type cld_qc_type - real :: RTCT, RFMFT, RFMFT_ij(2), TEMPIR, RTCT_terr + real :: RTCT, RFMFT, RFMFT_ij(2), TEMPIR, terr_hgt + real, allocatable :: tb_stddev_3x3(:) real, allocatable :: CIRH2O(:,:,:) end type cld_qc_type diff --git a/var/da/da_radiance/da_allocate_rad_iv.inc b/var/da/da_radiance/da_allocate_rad_iv.inc index 8c7ae62665..a22cb72040 100644 --- a/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/var/da/da_radiance/da_allocate_rad_iv.inc @@ -11,6 +11,8 @@ subroutine da_allocate_rad_iv (i, nchan, iv) integer , intent (in) :: i, nchan type (iv_type) , intent (inout) :: iv + integer :: n + call da_trace_entry("da_allocate_rad_iv") allocate (iv%instid(i)%info%date_char(iv%instid(i)%num_rad)) @@ -103,7 +105,12 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate (iv%instid(i)%solazi(iv%instid(i)%num_rad)) allocate (iv%instid(i)%tropt(iv%instid(i)%num_rad)) allocate (iv%instid(i)%gamma_jacobian(nchan,iv%instid(i)%num_rad)) - if ( use_clddet_zz ) allocate (iv%instid(i)%cld_qc(iv%instid(i)%num_rad)) + if ( use_clddet_zz ) then + allocate (iv%instid(i)%cld_qc(iv%instid(i)%num_rad)) + do n = 1, iv%instid(i)%num_rad + allocate (iv%instid(i)%cld_qc(n)%tb_stddev_3x3(nchan)) + end do + end if if ( use_rttov_kmatrix .or. use_crtm_kmatrix ) then allocate(iv%instid(i)%ts_jacobian(nchan,iv%instid(i)%num_rad)) allocate(iv%instid(i)%ps_jacobian(nchan,iv%instid(i)%num_rad)) diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index 8858680666..a1f4f3d1ef 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -127,6 +127,8 @@ deallocate (iv%instid(i)%tropt) if ( use_clddet_zz ) then do n = 1,iv%instid(i)%num_rad + if ( allocated (iv%instid(i)%cld_qc(n)%tb_stddev_3x3) ) & + deallocate (iv%instid(i)%cld_qc(n)%tb_stddev_3x3) if ( allocated (iv%instid(i)%cld_qc(n)%CIRH2O) ) & deallocate (iv%instid(i)%cld_qc(n)%CIRH2O) end do diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index f9076475f6..7651eee7c3 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -101,9 +101,11 @@ subroutine da_initialize_rad_iv (i, n, iv, p) if ( use_clddet_zz ) then if ( associated ( p % cld_qc ) ) then iv%instid(i)%cld_qc(n)%RTCT = p % cld_qc % RTCT - iv%instid(i)%cld_qc(n)%RTCT_terr = p % cld_qc % RTCT_terr iv%instid(i)%cld_qc(n)%RFMFT = p % cld_qc % RFMFT iv%instid(i)%cld_qc(n)%TEMPIR = p % cld_qc % TEMPIR + if ( allocated ( p % cld_qc % tb_stddev_3x3 ) ) & + iv%instid(i)%cld_qc(n)%tb_stddev_3x3(:) = p % cld_qc % tb_stddev_3x3(:) + iv%instid(i)%cld_qc(n)%terr_hgt = p % cld_qc % terr_hgt if ( allocated ( p % cld_qc % CIRH2O ) .and. & size(p % cld_qc % CIRH2O).eq.1) then allocate ( iv%instid(i)%cld_qc(n)%CIRH2O(1,1,1) ) diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index a325baf831..806b180abe 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -38,14 +38,16 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) real :: c37_mean !! Additional variables used by Zhuge and Zou(2017) - integer :: nrej_rtct(nchan), nrej_etrop(nchan), nrej_pfmft(nchan), & + integer, target :: nrej_rtct(nchan), nrej_etrop(nchan), nrej_pfmft(nchan), & nrej_nfmft(nchan), nrej_rfmft(nchan), & nrej_cirh2o(nchan), nrej_emiss4(nchan), & nrej_ulst(nchan), nrej_tempir(nchan), nrej_notc(nchan) - logical :: reject_zz, print_zz - integer*2 :: clddet_zz_tests(10) - real :: eps_zz_ocean, eps_zz_land, eps_zz_snow + logical :: reject_zz, print_zz + integer*2 :: clddet_zz_tests(10) + real :: eps_zz_ocean, eps_zz_land, eps_zz_snow + logical :: qualifier_ocean, qualifier_land, qualifier_snow real, pointer :: crit_zz + integer, pointer :: nrej_zz(:) character(len=10) :: crit_name real, target :: rtct, etrop, pfmft, nfmft, rfmft, cirh2o, emiss4, ulst, tempir, notc @@ -55,16 +57,26 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) real :: wave_num(10) real :: plbc1(10), plbc2(10) real :: plfk1(10), plfk2(10) + integer, parameter :: num_zz_tests = 10 + real :: zz_thresh(num_zz_tests+2,4) + real :: zz_qual(4) + integer :: zz_index(num_zz_tests) + integer :: zz_isflgs(4) + real, pointer :: tb_ob(:,:), tb_xb(:,:), tb_inv(:,:) ! note: these values are constant across channels - real(8), parameter :: C1=1.19104276e-5 ! = 2 * h * c**2 mWm-2sr-1(cm-1)-4 - real(8), parameter :: C2=1.43877516 ! = h * c / b = 1.43877 K(cm-1)-1 + real, parameter :: C1=1.19104276e-5 ! = 2 * h * c**2 mWm-2sr-1(cm-1)-4 + real, parameter :: C2=1.43877516 ! = h * c / b = 1.43877 K(cm-1)-1 ! h = Planck's constant ! b = Boltzmann constant ! c = velocity of light + integer, parameter :: ch7 = 1 + integer, parameter :: ch10 = 4 + integer, parameter :: ch14 = 8 + integer, parameter :: ch15 = 9 if (trace_use) call da_trace_entry("da_qc_goesabi") @@ -81,6 +93,22 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) plfk1 = C1 * wave_num**3 plfk2 = C2 * wave_num + zz_thresh = transpose( reshape( (/ & + 3.2, 4.1, huge(C1), huge(C1) & + , 0.1, 0.3, 0.4, 0.4 & + , 0.8, 2.5, 1.0, 1.0 & + , 1.0, 2.0, 5.0, 5.0 & + , 0.7, 1.0, huge(C1), huge(C1) & + , 0.7, 0.7, 0.7, 0.7 & + , 0.1, 0.2, 0.3, 0.3 & + , 2.86, huge(C1), huge(C1), huge(C1) & + , 0.05, 0.1, 0.12, 0.12 & + , 15., 21., 10., 10. & + , 11., 15., 4.5, 4.5 & + , 2.0, 2.0, 2.0, 2.0 & + /), (/ size(zz_thresh, 2), size(zz_thresh, 1) /)) ) + zz_index = (/1, 2, 3, 4, 5, 6, 7, 9, 10, 12/) + zz_isflgs = (/sea_flag, land_flag, snow_flag, ice_flag/) ngood(:) = 0 nrej(:) = 0 @@ -216,7 +244,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & iv%instid(i)%satzen(n), iv%instid(i)%satazi(n), & iv%instid(i)%solzen(n), iv%instid(i)%solazi(n), & - iv%instid(i)%tropt(n), iv%instid(i)%cld_qc(n)%RTCT_terr, & + iv%instid(i)%tropt(n), iv%instid(i)%cld_qc(n)%terr_hgt, & iv%instid(i)%info%date_char(n) @@ -227,25 +255,38 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !-------------------------------------------------------------------------- eps_zz_ocean = 3.2 eps_zz_land = 4.1 -! eps_zz_snow = 1.e10 + eps_zz_snow = huge(eps_zz_snow) +! qualifier_ocean = .true. +! qualifier_land = .true. + qualifier_snow = .false. + crit_name = "rtct" rtct = iv%instid(i)%cld_qc(n)%RTCT - reject_zz = .false. - if (.not. rtct.eq.missing_r) then - crit_zz => rtct - if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean - if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land -! if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice - if (reject_zz) then - iv%instid(i)%tb_qc(:,n) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_rtct(:) = nrej_rtct(:) + 1 - - if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) - end if - end if + + crit_zz => rtct + nrej_zz => nrej_rtct + + call evaluate_clddet_test ( & + crit_name, crit_zz, isflg, & + eps_zz_ocean, eps_zz_land, eps_zz_snow, & + iv%instid(i)%info%proc_domain(1,n), & + reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + .true., .true., qualifier_snow ) + +! reject_zz = crit_zz .gt. missing_r .AND. & +! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean +! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land +! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice +! if (reject_zz) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_zz(:) = nrej_zz(:) + 1 +! +! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & +! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) +! end if if (reject_zz) clddet_zz_tests(1) = 1 @@ -260,35 +301,51 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) eps_zz_ocean = 0.1 eps_zz_land = 0.3 eps_zz_snow = 0.4 +! qualifier_ocean = .true. +! qualifier_land = .true. +! qualifier_snow = .true. + crit_name = "etrop" - if ( tb_xb(8,n) .gt. 0. .and. & + + if ( tb_xb(ch14,n) .gt. 0. .and. & iv%instid(i)%tropt(n) .gt. 0. ) then - tb_temp1 = tb_ob(8,n) - rad_O14 = plfk1(8) / & - ( exp( plfk2(8) / (plbc1(8) + plbc2(8) * tb_temp1 ) ) -1 ) - tb_temp1 = tb_xb(8,n) - rad_M14 = plfk1(8) / & - ( exp( plfk2(8) / (plbc1(8) + plbc2(8) * tb_temp1) ) -1 ) + tb_temp1 = tb_ob(ch14,n) + rad_O14 = plfk1(ch14) / & + ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_temp1 ) ) -1 ) + tb_temp1 = tb_xb(ch14,n) + rad_M14 = plfk1(ch14) / & + ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_temp1) ) -1 ) tb_temp1 = iv%instid(i)%tropt(n) - rad_tropt = plfk1(8) / & - ( exp( plfk2(8) / (plbc1(8) + plbc2(8) * tb_temp1) ) -1 ) + rad_tropt = plfk1(ch14) / & + ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_temp1) ) -1 ) etrop = (rad_O14 - rad_M14) / (rad_tropt - rad_M14) else etrop = missing_r end if - reject_zz = .false. - crit_zz => etrop - if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean - if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land - if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice - if (reject_zz) then - iv%instid(i)%tb_qc(:,n) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_etrop(:) = nrej_etrop(:) + 1 - if (print_zz) write(*,"(A,F14.6,A,I4,4D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n),tb_xb(8,n),tb_ob(8,n) - end if + crit_zz => etrop + nrej_zz => nrej_etrop + + call evaluate_clddet_test ( & + crit_name, crit_zz, isflg, & + eps_zz_ocean, eps_zz_land, eps_zz_snow, & + iv%instid(i)%info%proc_domain(1,n), & + reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + .true., .true., .true. ) + +! reject_zz = crit_zz .gt. missing_r .AND. & +! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean +! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land +! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice +! if (reject_zz) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_zz(:) = nrej_zz(:) + 1 +! +! if (print_zz) write(*,"(A,F14.6,A,I4,4D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & +! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n),tb_xb(ch14,n),tb_ob(ch14,n) +! end if if (reject_zz) clddet_zz_tests(2) = 1 @@ -301,56 +358,60 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) eps_zz_ocean = 0.8 eps_zz_land = 2.5 eps_zz_snow = 1.0 - crit_name = "pfmft" +! qualifier_ocean = .true. +! qualifier_land = .true. +! qualifier_snow = .true. -!JJG: Why does this logical test not use tb_ob(8,n)? Something to do with VarBC... + crit_name = "pfmft" pfmft = missing_r - if ( (tb_inv(8,n) + tb_xb(8,n)) >270. .and. & - tb_xb(8,n) >270.) then - if (tb_ob(8,n) .gt. 0. .and. tb_ob(9,n) .gt. 0.) then -! using ob with VarBC -! pfmft = (tb_inv(8,n) + tb_xb(8,n) - & -! tb_inv(9,n) + tb_xb(9,n)) - & -! (tb_xb(8,n) - tb_xb(9,n))* & -! (tb_inv(8,n) + tb_xb(8,n) - 260.)/ & -! (tb_xb(8,n) - 260.) -! using ob without VarBC - pfmft = (tb_ob(8,n) - tb_ob(9,n)) - & - (tb_xb(8,n) - tb_xb(9,n)) * & - (tb_ob(8,n) - 260.) / (tb_xb(8,n) - 260.) - end if -!JJG: Changed the following to else (should be .or. instead of .and.) -! end if -! -! if ( (tb_inv(8,n) + tb_xb(8,n)) < 270. .and. & -! tb_xb(8,n) < 270.) then - - else - if (tb_ob(8,n) .gt. 0. .and. tb_ob(9,n) .gt. 0.) then + if ( (tb_inv(ch14,n) + tb_xb(ch14,n)).le.310. .and. & + iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch14).ge.0.3 .and. & + tb_ob(ch14,n).gt.0. .and. tb_ob(ch15,n).gt.0. ) & + pfmft = ( tb_ob(ch14,n) - tb_ob(ch15,n) ) +! above using ob without VarBC ! ------------------------------- -! using ob with VarBC -! pfmft = (tb_inv(8,n) + tb_xb(8,n) - & -! (tb_inv(9,n) + tb_xb(9,n)) ) -! using ob without VarBC - pfmft = ( tb_ob(8,n) - tb_ob(9,n) ) +! pfmft = (tb_inv(ch14,n) + tb_xb(ch14,n) - & +! (tb_inv(ch15,n) + tb_xb(ch15,n)) ) +! above using ob with VarBC ! ------------------------------- - end if - end if - reject_zz = .false. - crit_zz => pfmft - if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean - if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land - if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice - if (reject_zz) then - iv%instid(i)%tb_qc(:,n) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_pfmft(:) = nrej_pfmft(:) + 1 +!JJG: Why does this logical test not use tb_ob(ch14,n)? Something to do with VarBC... + if ( pfmft.gt.missing_r .and. & + (tb_inv(ch14,n) + tb_xb(ch14,n)).gt.270. .and. & + tb_xb(ch14,n).gt.270. .and. & + tb_xb(ch14,n).ge.tb_xb(ch15,n) ) & + pfmft = pfmft - & + (tb_xb(ch14,n) - tb_xb(ch15,n)) * & + (tb_ob(ch14,n) - 260.) / (tb_xb(ch14,n) - 260.) +! above 1 line using ob without VarBC +! (tb_inv(ch14,n) + tb_xb(ch14,n) - 260.)/ & +! (tb_xb(ch14,n) - 260.) +! above 2 lines using ob with VarBC - if (print_zz) write(*,"(A,F14.6,A,I4,4D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n),tb_xb(8,n),tb_ob(8,n) - end if + crit_zz => pfmft + nrej_zz => nrej_pfmft + + call evaluate_clddet_test ( & + crit_name, crit_zz, isflg, & + eps_zz_ocean, eps_zz_land, eps_zz_snow, & + iv%instid(i)%info%proc_domain(1,n), & + reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + .true., .true., .true. ) + +! reject_zz = crit_zz .gt. missing_r .AND. & +! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean +! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land +! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice +! if (reject_zz) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_zz(:) = nrej_zz(:) + 1 +! +! if (print_zz) write(*,"(A,F14.6,A,I4,4D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & +! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n),tb_xb(ch14,n),tb_ob(ch14,n) +! end if if (reject_zz) clddet_zz_tests(3) = 1 @@ -362,27 +423,42 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) eps_zz_ocean = 1.0 eps_zz_land = 2.0 eps_zz_snow = 5.0 +! qualifier_ocean = .true. +! qualifier_land = .true. +! qualifier_snow = .true. + crit_name = "nfmft" - if (tb_ob(8,n) .gt. 0. .and. tb_ob(9,n) .gt. 0.) then - nfmft=tb_inv(9,n) - tb_inv(8,n) + if (tb_ob(ch14,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) then + nfmft=tb_inv(ch15,n) - tb_inv(ch14,n) else nfmft = missing_r end if - reject_zz = .false. crit_zz => nfmft - if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean - if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land - if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice - if (reject_zz) then - iv%instid(i)%tb_qc(:,n) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_nfmft(:) = nrej_nfmft(:) + 1 + nrej_zz => nrej_nfmft + + call evaluate_clddet_test ( & + crit_name, crit_zz, isflg, & + eps_zz_ocean, eps_zz_land, eps_zz_snow, & + iv%instid(i)%info%proc_domain(1,n), & + reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + .true., .true., .true. ) + +! reject_zz = crit_zz .gt. missing_r .AND. & +! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean +! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land +! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice +! if (reject_zz) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_zz(:) = nrej_zz(:) + 1 +! +! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & +! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) +! end if - if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) - end if if (reject_zz) clddet_zz_tests(4) = 1 @@ -393,25 +469,39 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !-------------------------------------------------------------------------- eps_zz_ocean = 0.7 eps_zz_land = 1.0 -! eps_zz_snow = 1.e10 + eps_zz_snow = huge(eps_zz_snow) + qualifier_ocean = ( tb_ob(ch14,n) - tb_ob(ch15,n) ).lt.1.0 + qualifier_land = ( tb_ob(ch14,n) - tb_ob(ch15,n) ).lt.1.0 .and. tb_ob(ch14,n).le.300. + qualifier_snow = .false. + crit_name = "rfmft" rfmft = iv%instid(i)%cld_qc(n)%RFMFT - reject_zz = .false. - if (.not. rfmft.eq.missing_r) then - crit_zz => rfmft - if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean - if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land -! if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice - if (reject_zz) then - iv%instid(i)%tb_qc(:,n) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_rfmft(:) = nrej_rfmft(:) + 1 - - if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) - end if - end if + + crit_zz => rfmft + nrej_zz => nrej_rfmft + + call evaluate_clddet_test ( & + crit_name, crit_zz, isflg, & + eps_zz_ocean, eps_zz_land, eps_zz_snow, & + iv%instid(i)%info%proc_domain(1,n), & + reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + qualifier_ocean, qualifier_land, qualifier_snow ) + +! reject_zz = crit_zz .gt. missing_r .AND. & +! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean +! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land +! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice +! if (reject_zz) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_zz(:) = nrej_zz(:) + 1 +! +! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & +! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) +! end if + if (reject_zz) clddet_zz_tests(5) = 1 @@ -423,28 +513,45 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) eps_zz_ocean = 0.7 eps_zz_land = 0.7 eps_zz_snow = 0.7 +! qualifier_ocean = .true. +! qualifier_land = .true. +! qualifier_snow = .true. + crit_name = "cirh2o" - if (allocated(iv%instid(i)%cld_qc(n)%CIRH2O)) then + if ( iv%instid(i)%cld_qc(n)%terr_hgt .le. 2000. .and. & + iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch10) .gt. 0.5 .and. & + iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch14) .gt. 0.5 .and. & + allocated(iv%instid(i)%cld_qc(n)%CIRH2O) ) then cirh2o = iv%instid(i)%cld_qc(n)%CIRH2O(1,1,1) else cirh2o = missing_r end if - reject_zz = .false. - if (.not. cirh2o.eq.missing_r) then - crit_zz => cirh2o - if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean - if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land - if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice - if (reject_zz) then - iv%instid(i)%tb_qc(:,n) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_cirh2o(:) = nrej_cirh2o(:) + 1 - - if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) - end if - end if + + crit_zz => cirh2o + nrej_zz => nrej_cirh2o + + call evaluate_clddet_test ( & + crit_name, crit_zz, isflg, & + eps_zz_ocean, eps_zz_land, eps_zz_snow, & + iv%instid(i)%info%proc_domain(1,n), & + reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + .true., .true., .true. ) + +! reject_zz = crit_zz .gt. missing_r .AND. & +! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean +! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land +! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice +! if (reject_zz) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_zz(:) = nrej_zz(:) + 1 +! +! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & +! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) +! end if + if (reject_zz) clddet_zz_tests(6) = 1 @@ -454,40 +561,12 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! e_emiss4 = 0.1(Ocean), 0.2(land), 0.3(snow) for daytime, 2.86(Ocean) for night ! e_modemiss4 = 0.26-3*1.04(Ocean) for sun-glint area !-------------------------------------------------------------------------- - eps_zz_ocean = 0.1 - - ! Modified EMISS4 from Zhuge and Zou - eps_zz_land = 0.2 - - ! Default value from ABI CM algorithm - eps_zz_land = 0.46 +! qualifier_ocean = .true. +! qualifier_land = .true. +! qualifier_snow = .true. - eps_zz_snow = 0.3 crit_name = "emiss4" - if (tb_ob(1,n) .gt. 0. .and. tb_ob(8,n) .gt. 0.) then - tb_temp1 = tb_ob(1,n) - rad_o_ch7 = plfk1(1) / & - ( exp( plfk2(1) / ( plbc1(1) + plbc2(1) * tb_temp1 ) ) - 1. ) - - tb_temp1 = tb_xb(1,n) - rad_b_ch7 = plfk1(1) / & - ( exp( plfk2(1) / ( plbc1(1) + plbc2(1) * tb_temp1 ) ) - 1. ) - - tb_temp1 = tb_ob(8,n) - rad_o_ch14 = plfk1(1) / & - ( exp( plfk2(1) / ( plbc1(1) + plbc2(1) * tb_temp1 ) ) - 1. ) - - tb_temp1 = tb_xb(8,n) - rad_b_ch14 = plfk1(1) / & - ( exp( plfk2(1) / ( plbc1(1) + plbc2(1) * tb_temp1 ) ) - 1. ) -! --------------------------------------- - emiss4 = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14)/ & - (rad_b_ch7 / rad_b_ch14) - else - emiss4 = missing_r - end if - !JJG: Need to check over this code to ensure relative azimuth is calculated correctly ! Modify EMISS for sun glint area may be not work, because we are at north land ! - compute relative azimuth @@ -500,26 +579,68 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if (print_zz) write(*,"(A,4D12.4)") "PIXEL_DEBUG8: ", & iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n), Relaz, Glintzen - reject_zz = .false. - crit_zz => emiss4 if ( Glintzen.lt.40.0 .and. isflg==sea_flag) then -! if ( isflg==sea_flag .and. tb_inv(1,n) < -2.86 ) reject_zz = .true. +! if ( isflg==sea_flag .and. tb_inv(ch7,n) < -2.86 ) reject_zz = .true. eps_zz_ocean = 2.86 - emiss4 = - tb_inv(1,n) ! (B_ch7 - O_ch7) - if ( crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean + eps_zz_land = huge(eps_zz_land) + eps_zz_snow = huge(eps_zz_snow) + emiss4 = - tb_inv(ch7,n) ! (B_ch7 - O_ch7) else - if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean - if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land - if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice - end if - if (reject_zz) then - iv%instid(i)%tb_qc(:,n) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_emiss4(:) = nrej_emiss4(:) + 1 - - if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) + eps_zz_ocean = 0.1 + +! ! Modified EMISS4 from Zhuge and Zou +! eps_zz_land = 0.2 + + ! Default value from ABI CM algorithm + eps_zz_land = 0.46 + + eps_zz_snow = 0.3 + + if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) then + tb_temp1 = tb_ob(ch7,n) + rad_o_ch7 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) + tb_temp1 = tb_xb(ch7,n) + rad_b_ch7 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) + tb_temp1 = tb_ob(ch14,n) + rad_o_ch14 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) + tb_temp1 = tb_xb(ch14,n) + rad_b_ch14 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) +! --------------------------------------- + emiss4 = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14)/ & + (rad_b_ch7 / rad_b_ch14) + else + emiss4 = missing_r + end if end if + + crit_zz => emiss4 + nrej_zz => nrej_emiss4 + + call evaluate_clddet_test ( & + crit_name, crit_zz, isflg, & + eps_zz_ocean, eps_zz_land, eps_zz_snow, & + iv%instid(i)%info%proc_domain(1,n), & + reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + .true., .true., .true. ) + +! reject_zz = crit_zz .gt. missing_r .AND. & +! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean +! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land +! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice +! if (reject_zz) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_zz(:) = nrej_zz(:) + 1 +! +! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & +! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) +! end if + if (reject_zz) clddet_zz_tests(7) = 1 @@ -531,29 +652,43 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) eps_zz_ocean = 0.05 eps_zz_land = 0.1 eps_zz_snow = 0.12 +!JJG: Changed this to solzen instead of solazi for night/day test + qualifier_ocean = iv%instid(i)%solzen(n) >= 85.0 + qualifier_land = iv%instid(i)%solzen(n) >= 85.0 + qualifier_snow = iv%instid(i)%solzen(n) >= 85.0 + crit_name = "ulst" - if (tb_ob(1,n) .gt. 0. .and. tb_ob(8,n) .gt. 0.) then + if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) then ulst = rad_b_ch7/rad_b_ch14 - rad_o_ch7/rad_o_ch14 else ulst = missing_r - end if -!JJG: Changed this to solzen instead of solazi for night/day test - reject_zz = .false. - if ( iv%instid(i)%solzen(n) >= 85.0 .and. ulst.gt.missing_r ) then ! night Time - crit_zz => ulst - if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean - if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land - if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice - if (reject_zz) then - iv%instid(i)%tb_qc(:,n) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_ulst(:) = nrej_ulst(:) + 1 - - if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) - end if - end if + end if + + crit_zz => ulst + nrej_zz => nrej_ulst + + call evaluate_clddet_test ( & + crit_name, crit_zz, isflg, & + eps_zz_ocean, eps_zz_land, eps_zz_snow, & + iv%instid(i)%info%proc_domain(1,n), & + reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + qualifier_ocean, qualifier_land, qualifier_snow ) + +! reject_zz = crit_zz .gt. missing_r .AND. & +! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean +! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land +! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice +! if (reject_zz) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_zz(:) = nrej_zz(:) + 1 +! +! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & +! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) +! end if + if (reject_zz) clddet_zz_tests(8) = 1 @@ -565,24 +700,39 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) eps_zz_ocean = 2.0 eps_zz_land = 2.0 eps_zz_snow = 2.0 +! qualifier_ocean = .true. +! qualifier_land = .true. +! qualifier_snow = .true. + crit_name = "tempir" tempir = iv%instid(i)%cld_qc(n)%TEMPIR - reject_zz = .false. - if (.not. tempir.eq.missing_r) then - crit_zz => tempir - if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean - if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land - if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice - if (reject_zz) then - iv%instid(i)%tb_qc(:,n) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_tempir(:) = nrej_tempir(:) + 1 - - if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) - end if - end if + + crit_zz => tempir + nrej_zz => nrej_tempir + + call evaluate_clddet_test ( & + crit_name, crit_zz, isflg, & + eps_zz_ocean, eps_zz_land, eps_zz_snow, & + iv%instid(i)%info%proc_domain(1,n), & + reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + .true., .true., .true. ) + +! reject_zz = crit_zz .gt. missing_r .AND. & +! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean +! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land +! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice +! +! if (reject_zz) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_zz(:) = nrej_zz(:) + 1 +! +! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & +! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) +! end if + if (reject_zz) clddet_zz_tests(9) = 1 @@ -602,36 +752,54 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) eps_zz_land = 25. eps_zz_snow = 4.5 end if +! qualifier_ocean = .true. +! qualifier_land = .true. +! qualifier_snow = .true. + crit_name = "notc" - if (tb_ob(1,n) .gt. 0. .and. tb_ob(9,n) .gt. 0.) then + if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) then ! using ob with VarBC -! notc = tb_inv(1,n) + tb_xb(1,n) - & -! (tb_inv(9,n) + tb_xb(9,n)) +! notc = tb_inv(ch7,n) + tb_xb(ch7,n) - & +! (tb_inv(ch15,n) + tb_xb(ch15,n)) ! using ob without VarBC - notc = tb_ob(1,n) - tb_ob(9,n) + notc = tb_ob(ch7,n) - tb_ob(ch15,n) else notc = missing_r - end if + end if - reject_zz = .false. crit_zz => notc - if ( isflg==sea_flag .and. crit_zz > eps_zz_ocean ) reject_zz = .true. ! Ocean - if ( isflg==land_flag .and. crit_zz > eps_zz_land ) reject_zz = .true. ! land - if ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow ) reject_zz = .true. ! snow and ice - if (reject_zz) then - iv%instid(i)%tb_qc(:,n) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_notc(:) = nrej_notc(:) + 1 + nrej_zz => nrej_notc + + call evaluate_clddet_test ( & + crit_name, crit_zz, isflg, & + eps_zz_ocean, eps_zz_land, eps_zz_snow, & + iv%instid(i)%info%proc_domain(1,n), & + reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + .true., .true., .true. ) + +! reject_zz = crit_zz .gt. missing_r .AND. & +! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean +! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land +! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice +! if (reject_zz) then +! iv%instid(i)%tb_qc(:,n) = qc_bad +! if (iv%instid(i)%info%proc_domain(1,n)) & +! nrej_zz(:) = nrej_zz(:) + 1 +! +! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & +! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) +! end if - if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) - end if if (reject_zz) clddet_zz_tests(10) = 1 + + if (print_zz) write(*,'(A,I8,10I4)') 'PIXEL_DEBUG9: ', n, & clddet_zz_tests + end if clddet_zz ! --------------------------- @@ -820,12 +988,59 @@ function glint_angle ( sol_zen , sat_zen , rel_az ) end function glint_angle +subroutine evaluate_clddet_test ( crit_name, crit_zz, isflg, eps_o, eps_l, eps_s, & + on_proc, reject_zz , tb_qc, nrej, & + lat, lon, q_ocean, q_land, q_snow) + character(*), intent(in) :: crit_name + integer, intent(in) :: isflg + logical, intent(in) :: on_proc + real, intent(in) :: crit_zz, eps_o, eps_l, eps_s, lat, lon + logical, intent(in) :: q_ocean, q_land, q_snow +! logical, intent(in), optional :: q_ocean, q_land, q_snow + logical, intent(out) :: reject_zz + integer, intent(inout) :: tb_qc(:), nrej(:) + integer, parameter :: sea_flag = 0 + integer, parameter :: ice_flag = 1 + integer, parameter :: land_flag = 2 + integer, parameter :: snow_flag = 3 + integer, parameter :: msea_flag = 4 + integer, parameter :: mice_flag = 5 + integer, parameter :: mland_flag = 6 + integer, parameter :: msnow_flag = 7 +! logical :: q_o, q_l, q_s +! +! if (present(q_o)) then +! q_o = q_ocean +! else +! q_o = .true. +! end if +! if (present(q_l)) then +! q_l = q_land +! else +! q_l = .true. +! end if +! if (present(q_s)) then +! q_s = q_snow +! else +! q_s = .true. +! end if + + reject_zz = crit_zz .gt. missing_r .AND. & + ( ( isflg==sea_flag .and. crit_zz > eps_o .and. q_ocean ) & ! Ocean + .OR. ( isflg==land_flag .and. crit_zz > eps_l .and. q_land ) & ! land + .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_s .and. q_snow ) ) ! snow and ice + + if (reject_zz) then + tb_qc(:) = qc_bad + if (on_proc) then + nrej(:) = nrej(:) + 1 + write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, lat,lon + end if + end if - - - +end subroutine evaluate_clddet_test diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index d012de1d4d..5c8d1e466e 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -59,19 +59,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) type(info_type), allocatable :: info_1d(:) - !Cloud QC variables - integer :: tbuf, nkeep, ikeep - integer :: cld_qc_buffer ! Must be ≥ 0 - real :: mean10, mean14, sigma10, sigma14, pearson, temp_max - real, allocatable :: tb_10(:), tb_14(:) - logical :: cldqc - character(18), parameter :: terr_fname = 'OR_ABI-TERR_G16.nc' - - integer :: TEMPIR_ifile - real :: TEMPIR_min_time_diff, TEMPIR_time_abs_diff - real, parameter :: TEMPIR_delay_minutes = 15.0 - - ! Masks for data reduction !!! logical :: include_local, load_balance logical :: earthmask, zenmask @@ -206,6 +193,19 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer(i_kind) :: itx, itt real, allocatable :: in(:), out(:) + !Cloud QC variables + integer :: tbuf, nkeep, ikeep + integer :: cld_qc_buffer ! Must be ≥ 0 + real :: mu10, mu14, sigma10, sigma14, pearson, temp_max + real :: mu, sigma + real, allocatable :: tb_temp(:,:) + logical :: cldqc + character(18), parameter :: terr_fname = 'OR_ABI-TERR_G16.nc' + + integer :: TEMPIR_ifile + real :: TEMPIR_min_time_diff, TEMPIR_time_abs_diff + real, parameter :: TEMPIR_delay_minutes = 15.0 + if (trace_use) call da_trace_entry("da_read_obs_ncgoesabi") ! determine if satellite_id is supported @@ -1278,6 +1278,8 @@ write(stdout,*) trim(command) readmask_p, bt_p(:,:,2) ) end if + first_chan = (this_view % nfiles_used(ifgat).eq.1) + if ( use_clddet_zz .and. channel_list(ichan).eq.14 .and. cld_qc_buffer.ge.1) then ! Allocate terrain_hgt using local indices for this view allocate( terrain_hgt ( & @@ -1295,7 +1297,6 @@ write(stdout,*) trim(command) end if !! Write bt, lat, lon, satzen, satazi, solzen, solazi to datalink structures - first_chan = (this_view % nfiles_used(ifgat).eq.1) if (first_chan) then p_fgat => p @@ -1394,45 +1395,65 @@ write(stdout,*) trim(command) p % tb_inv(ichan) = bt_p( iy, ix, 1 ) ! Extract values from cloud QC buffer - if (.not. associated(p % cld_qc)) allocate( p % cld_qc) + if (.not. associated(p % cld_qc)) then + allocate( p % cld_qc ) + allocate( p % cld_qc % tb_stddev_3x3(nchan) ) + end if tbuf = 1 if (cld_qc_buffer.ge.tbuf) then - ! Values for RTCT cloud QC - ! - channel 14 and sigma_z (std. dev. of terrain height in km) - ! w/ landmask and lapse rate of 7 K km^-1 + + nkeep = count ( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r ) + allocate( tb_temp ( nkeep, 1 ) ) + tb_temp(:,1) = pack( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ), & + bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r) + mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) + deallocate( tb_temp ) + + p % cld_qc % tb_stddev_3x3(ichan) = sigma + if (channel_list(ichan).eq.14) then - if ( allocated(terrain_hgt) ) then - temp_max = 0. - do jy = iy-tbuf, iy+tbuf - do jx = ix-tbuf, ix+tbuf - if ( bt_p( jy, jx, 1) .gt. 0. ) & - temp_max = max(temp_max,bt_p( jy, jx, 1 ) ) - end do - end do - ! Determine sigma_z of terrain height across these pixels - nkeep = count ( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r ) - allocate( tb_14 ( nkeep ) ) - tb_14 = pack( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ), & - terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r) - mean14 = sum( tb_14 ) / real(nkeep,r_double) - sigma14 = sqrt( sum( (tb_14 - mean14)**2 ) / real(nkeep,r_double) ) - deallocate( tb_14 ) - - ! Store RTCT and diagnostic terrain height - p % cld_qc % RTCT = temp_max - p % tb_inv(ichan) - & - 3.0_r_double * 0.007_r_double * sigma14 - p % cld_qc % RTCT_terr = terrain_hgt( iy, ix ) - else - p % cld_qc % RTCT = missing_r - p % cld_qc % RTCT_terr = missing_r - end if + if ( allocated(terrain_hgt) ) then + ! Determine sigma_z of terrain height across these pixels + nkeep = count ( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r ) + allocate( tb_temp ( nkeep, 1 ) ) + tb_temp(:,1) = pack( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ), & + terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r) + mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) + deallocate( tb_temp ) + + p % cld_qc % terr_hgt = terrain_hgt( iy, ix ) + + ! Values for RTCT cloud QC + ! - channel 14 and sigma_z (std. dev. of terrain height in km) + ! w/ landmask and lapse rate of 7 K km^-1 + + temp_max = 0. + do jy = iy-tbuf, iy+tbuf + do jx = ix-tbuf, ix+tbuf + if ( bt_p( jy, jx, 1) .gt. 0. ) & + temp_max = max(temp_max,bt_p( jy, jx, 1 ) ) + end do + end do + + ! Store RTCT and diagnostic terrain height + p % cld_qc % RTCT = temp_max - p % tb_inv(ichan) - & + 3.0_r_double * 0.007_r_double * sigma + + else + p % cld_qc % RTCT = missing_r + p % cld_qc % terr_hgt = missing_r + end if + end if else + p % cld_qc % tb_stddev_3x3(ichan) = missing_r if (channel_list(ichan).eq.14) then p % cld_qc % RTCT = missing_r - p % cld_qc % RTCT_terr = missing_r + p % cld_qc % terr_hgt = missing_r end if end if @@ -1486,26 +1507,26 @@ write(stdout,*) trim(command) if ( all(p % cld_qc % CIRH2O( jy, jx, : ) .gt. missing_r) ) nkeep = nkeep + 1 end do end do - allocate( tb_10 ( nkeep ) ) - allocate( tb_14 ( nkeep ) ) + allocate( tb_temp ( nkeep, 2 ) ) ikeep = 0 do jy = iy-tbuf, iy+tbuf do jx = ix-tbuf, ix+tbuf if ( all(p % cld_qc % CIRH2O( jy, jx, : ) .gt. missing_r) ) then ikeep = ikeep + 1 - tb_10(ikeep) = p % cld_qc % CIRH2O( jy, jx, 1 ) - tb_14(ikeep) = p % cld_qc % CIRH2O( jy, jx, 2 ) + tb_temp(ikeep,1) = p % cld_qc % CIRH2O( jy, jx, 1 ) + tb_temp(ikeep,2) = p % cld_qc % CIRH2O( jy, jx, 2 ) end if end do end do - mean10 = sum( tb_10 ) / real(nkeep,r_double) - mean14 = sum( tb_14 ) / real(nkeep,r_double) - sigma10 = sqrt( sum( (tb_10 - mean10)**2 ) / real(nkeep,r_double) ) - sigma14 = sqrt( sum( (tb_14 - mean14)**2 ) / real(nkeep,r_double) ) - pearson = sum((tb_10 - mean10) * (tb_14 - mean14)) / real(nkeep,r_double) / & - ( sigma10 * sigma14 ) - deallocate( tb_10 ) - deallocate( tb_14 ) + mu10 = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma10 = sqrt( sum( (tb_temp(:,1) - mu10)**2 ) & + / real(nkeep,r_double) ) + mu14 = sum( tb_temp(:,2) ) / real(nkeep,r_double) + sigma14 = sqrt( sum( (tb_temp(:,2) - mu14)**2 ) / & + real(nkeep,r_double) ) + pearson = sum((tb_temp(:,1) - mu10) * (tb_temp(:,2) - mu14)) / & + real(nkeep,r_double) / ( sigma10 * sigma14 ) + deallocate( tb_temp ) deallocate( p % cld_qc % CIRH2O ) allocate( p % cld_qc % CIRH2O (1,1,1) ) p % cld_qc % CIRH2O (1,1,1) = pearson @@ -1542,13 +1563,13 @@ write(stdout,*) trim(command) end do deallocate( bt_p, allmask_p, readmask_p) + if ( allocated(terrain_hgt) ) deallocate ( terrain_hgt ) end if VIEW_SELECT end do ChannelLoop if ( allocated(thinmask) ) deallocate ( thinmask ) if ( allocated(solzen_1d) ) deallocate ( solzen_1d ) if ( allocated(solazi_1d) ) deallocate ( solazi_1d ) - if ( allocated(terrain_hgt) ) deallocate ( terrain_hgt ) end if PatchMatch #ifdef DM_PARALLEL @@ -1676,9 +1697,11 @@ write(stdout,*) trim(command) end if deallocate ( current % tb_inv ) ! deallocate ( current % cloud_flag ) - if (associated(current % cld_qc)) then - if (allocated(current % cld_qc % CIRH2O)) deallocate(current % cld_qc % CIRH2O) - deallocate(current % cld_qc) + if ( associated(current % cld_qc ) ) then + if ( allocated ( current % cld_qc % CIRH2O ) ) & + deallocate ( current % cld_qc % CIRH2O ) + deallocate ( current % cld_qc % tb_stddev_3x3 ) + deallocate ( current % cld_qc ) end if deallocate ( current ) num_goesabi_thinned = num_goesabi_thinned + 1 @@ -1747,9 +1770,11 @@ write(stdout,*) trim(command) ! free current data deallocate ( current % tb_inv ) !!! deallocate ( current % cloud_flag ) - if (associated(current % cld_qc)) then - if (allocated(current % cld_qc % CIRH2O)) deallocate(current % cld_qc % CIRH2O) - deallocate(current % cld_qc) + if ( associated ( current % cld_qc ) ) then + if ( allocated ( current % cld_qc % CIRH2O ) ) & + deallocate ( current % cld_qc % CIRH2O ) + deallocate ( current % cld_qc % tb_stddev_3x3 ) + deallocate ( current % cld_qc ) end if deallocate ( current ) end do From 775c01e113b05d0dce4ecd3db096718faa8e103f Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Thu, 23 Aug 2018 15:19:50 -0600 Subject: [PATCH 15/86] Significant reorganization of abi qc subroutine. plus fixes for a) solzen in crtm operator b) i,j,dx,dy,dxm,dym for loc in ABI reading routine Changes to be committed: modified: da_radiance/da_get_innov_vector_crtm.inc modified: da_radiance/da_qc_goesabi.inc modified: da_radiance/da_read_obs_ncgoesabi.inc --- .../da_radiance/da_get_innov_vector_crtm.inc | 3 +- var/da/da_radiance/da_qc_goesabi.inc | 854 +++++------------- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 38 +- 3 files changed, 258 insertions(+), 637 deletions(-) diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index ad83747172..5c319d9722 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -517,8 +517,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) ! CRTM GeometryInfo Structure GeometryInfo(1)%Sensor_Zenith_Angle=iv%instid(inst)%satzen(n) - if (.not. use_clddet_zz) & - GeometryInfo(1)%Source_Zenith_Angle=iv%instid(inst)%solzen(n) + GeometryInfo(1)%Source_Zenith_Angle=iv%instid(inst)%solzen(n) GeometryInfo(1)%iFOV=iv%instid(inst)%scanpos(n) ! GeometryInfo(1)%Satellite_Height=830.0 ! GeometryInfo(1)%Sensor_Scan_Angle= diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 806b180abe..de9ab8cdca 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -38,19 +38,10 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) real :: c37_mean !! Additional variables used by Zhuge and Zou(2017) - integer, target :: nrej_rtct(nchan), nrej_etrop(nchan), nrej_pfmft(nchan), & - nrej_nfmft(nchan), nrej_rfmft(nchan), & - nrej_cirh2o(nchan), nrej_emiss4(nchan), & - nrej_ulst(nchan), nrej_tempir(nchan), nrej_notc(nchan) + integer :: itest logical :: reject_zz, print_zz - integer*2 :: clddet_zz_tests(10) - real :: eps_zz_ocean, eps_zz_land, eps_zz_snow - logical :: qualifier_ocean, qualifier_land, qualifier_snow - real, pointer :: crit_zz - integer, pointer :: nrej_zz(:) - character(len=10) :: crit_name - - real, target :: rtct, etrop, pfmft, nfmft, rfmft, cirh2o, emiss4, ulst, tempir, notc + real :: crit_zz + real :: rad_O14, rad_M14, rad_tropt real :: rad_o_ch7, rad_b_ch7, rad_o_ch14, rad_b_ch14 real :: Relaz, Glintzen, tb_temp1 @@ -58,11 +49,14 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) real :: plbc1(10), plbc2(10) real :: plfk1(10), plfk2(10) integer, parameter :: num_zz_tests = 10 - real :: zz_thresh(num_zz_tests+2,4) - real :: zz_qual(4) - integer :: zz_index(num_zz_tests) - integer :: zz_isflgs(4) - + integer, parameter :: num_zz_cats = 4 + real :: eps_zz(num_zz_tests+2,num_zz_cats) + integer :: index_zz(num_zz_tests), offset_zz + integer :: isflgs_zz(num_zz_cats) + logical :: qual_zz(num_zz_cats) + character(len=10) :: crit_names_zz(num_zz_tests) + integer :: nrej_zz(nchan,num_zz_tests) + integer*2 :: clddet_zz_tests(num_zz_tests) real, pointer :: tb_ob(:,:), tb_xb(:,:), tb_inv(:,:) @@ -93,22 +87,36 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) plfk1 = C1 * wave_num**3 plfk2 = C2 * wave_num - zz_thresh = transpose( reshape( (/ & + crit_names_zz(1) = "rtct" + crit_names_zz(2) = "etrop" + crit_names_zz(3) = "pfmft" + crit_names_zz(4) = "nfmft" + crit_names_zz(5) = "rfmft" + crit_names_zz(6) = "cirh2o" + crit_names_zz(7) = "emiss4" + crit_names_zz(8) = "ulst" + crit_names_zz(9) = "notc" + crit_names_zz(10) = "tempir" + + !! Table 4 from Zhuge X. and Zou X. JAMC, 2016. [modified from ABI Cloud Mask Algorithm] + !ocean land snow ice (assume same as snow) + eps_zz = transpose( reshape( (/ & 3.2, 4.1, huge(C1), huge(C1) & , 0.1, 0.3, 0.4, 0.4 & , 0.8, 2.5, 1.0, 1.0 & , 1.0, 2.0, 5.0, 5.0 & , 0.7, 1.0, huge(C1), huge(C1) & , 0.7, 0.7, 0.7, 0.7 & - , 0.1, 0.2, 0.3, 0.3 & + , 0.1, 0.46, 0.3, 0.3 & ! Land values: 0.46 in ABI CM; 0.2 in ZZ16 , 2.86, huge(C1), huge(C1), huge(C1) & , 0.05, 0.1, 0.12, 0.12 & , 15., 21., 10., 10. & , 11., 15., 4.5, 4.5 & , 2.0, 2.0, 2.0, 2.0 & - /), (/ size(zz_thresh, 2), size(zz_thresh, 1) /)) ) - zz_index = (/1, 2, 3, 4, 5, 6, 7, 9, 10, 12/) - zz_isflgs = (/sea_flag, land_flag, snow_flag, ice_flag/) + /), (/ size(eps_zz, 2), size(eps_zz, 1) /)) ) + index_zz = (/1, 2, 3, 4, 5, 6, 7, 9, 10, 12/) + isflgs_zz = (/sea_flag, land_flag, snow_flag, ice_flag/) + ngood(:) = 0 nrej(:) = 0 @@ -120,16 +128,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) nrej_land = 0 num_proc_domain = 0 - nrej_rtct = 0 - nrej_etrop = 0 - nrej_pfmft = 0 - nrej_nfmft = 0 - nrej_rfmft = 0 - nrej_cirh2o = 0 - nrej_emiss4 = 0 - nrej_ulst = 0 - nrej_tempir = 0 - nrej_notc = 0 + nrej_zz = 0 tb_ob => ob%instid(i)%tb tb_xb => iv%instid(i)%tb_xb @@ -227,9 +226,9 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !!========================================================================== !!========================================================================== - print_zz = iv%instid(i)%info%proc_domain(1,n) - clddet_zz_tests = 0 - +!JJGDEBUG +! print_zz = iv%instid(i)%info%proc_domain(1,n) + print_zz = .true. if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG1: ', n, & tb_inv(:,n) if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG2: ', n, & @@ -246,69 +245,11 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) iv%instid(i)%solzen(n), iv%instid(i)%solazi(n), & iv%instid(i)%tropt(n), iv%instid(i)%cld_qc(n)%terr_hgt, & iv%instid(i)%info%date_char(n) +!JJGDEBUG + clddet_zz_tests = 0 - !-------------------------------------------------------------------------- - ! 4.1 Relative Thermal Contrast Test - ! (Zhuge and Zou, 2016, JAMC; TEST1) - ! e_rtct = 3.2(Ocean), 4.1(land) - !-------------------------------------------------------------------------- - eps_zz_ocean = 3.2 - eps_zz_land = 4.1 - eps_zz_snow = huge(eps_zz_snow) -! qualifier_ocean = .true. -! qualifier_land = .true. - qualifier_snow = .false. - - crit_name = "rtct" - - rtct = iv%instid(i)%cld_qc(n)%RTCT - - crit_zz => rtct - nrej_zz => nrej_rtct - - call evaluate_clddet_test ( & - crit_name, crit_zz, isflg, & - eps_zz_ocean, eps_zz_land, eps_zz_snow, & - iv%instid(i)%info%proc_domain(1,n), & - reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - .true., .true., qualifier_snow ) - -! reject_zz = crit_zz .gt. missing_r .AND. & -! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean -! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land -! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice -! if (reject_zz) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_zz(:) = nrej_zz(:) + 1 -! -! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & -! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) -! end if - - if (reject_zz) clddet_zz_tests(1) = 1 - - !-------------------------------------------------------------------------- - ! 4.2 Cloud check: step 1 - ! Emissivity at Tropopause Test (ETROP) - ! (Zhuge and Zou, 2016, JAMC; TEST2) - ! e_etrop = 0.1(Ocean), 0.3(land), 0.4(snow) - ! Q: need tropopause temperature - ! select iv%instid(i)%isflg(n) - !-------------------------------------------------------------------------- - eps_zz_ocean = 0.1 - eps_zz_land = 0.3 - eps_zz_snow = 0.4 -! qualifier_ocean = .true. -! qualifier_land = .true. -! qualifier_snow = .true. - - crit_name = "etrop" - - if ( tb_xb(ch14,n) .gt. 0. .and. & - iv%instid(i)%tropt(n) .gt. 0. ) then + if ( tb_xb(ch14,n) .gt. 0. .and. iv%instid(i)%tropt(n) .gt. 0. ) then tb_temp1 = tb_ob(ch14,n) rad_O14 = plfk1(ch14) / & ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_temp1 ) ) -1 ) @@ -318,488 +259,190 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) tb_temp1 = iv%instid(i)%tropt(n) rad_tropt = plfk1(ch14) / & ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_temp1) ) -1 ) - etrop = (rad_O14 - rad_M14) / (rad_tropt - rad_M14) - else - etrop = missing_r + else + rad_O14 = missing_r + rad_M14 = missing_r + rad_tropt = missing_r + end if + + if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) then + tb_temp1 = tb_ob(ch7,n) + rad_o_ch7 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) + tb_temp1 = tb_xb(ch7,n) + rad_b_ch7 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) + tb_temp1 = tb_ob(ch14,n) + rad_o_ch14 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) + tb_temp1 = tb_xb(ch14,n) + rad_b_ch14 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) + else + rad_o_ch7 = missing_r + rad_b_ch7 = missing_r + rad_o_ch14 = missing_r + rad_b_ch14 = missing_r end if - crit_zz => etrop - nrej_zz => nrej_etrop - - call evaluate_clddet_test ( & - crit_name, crit_zz, isflg, & - eps_zz_ocean, eps_zz_land, eps_zz_snow, & - iv%instid(i)%info%proc_domain(1,n), & - reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - .true., .true., .true. ) - -! reject_zz = crit_zz .gt. missing_r .AND. & -! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean -! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land -! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice -! if (reject_zz) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_zz(:) = nrej_zz(:) + 1 -! -! if (print_zz) write(*,"(A,F14.6,A,I4,4D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & -! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n),tb_xb(ch14,n),tb_ob(ch14,n) -! end if - - if (reject_zz) clddet_zz_tests(2) = 1 - - !-------------------------------------------------------------------------- - ! 4.3 Cloud check: step 2 - ! Positive Fourteen Minus Fifteen Test - ! (Zhuge and Zou, 2016, JAMC; TEST3) - ! e_pfmft = 0.8(Ocean), 2.5(land), 1.0(snow) - !-------------------------------------------------------------------------- - eps_zz_ocean = 0.8 - eps_zz_land = 2.5 - eps_zz_snow = 1.0 -! qualifier_ocean = .true. -! qualifier_land = .true. -! qualifier_snow = .true. - - crit_name = "pfmft" - - pfmft = missing_r - if ( (tb_inv(ch14,n) + tb_xb(ch14,n)).le.310. .and. & - iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch14).ge.0.3 .and. & - tb_ob(ch14,n).gt.0. .and. tb_ob(ch15,n).gt.0. ) & - pfmft = ( tb_ob(ch14,n) - tb_ob(ch15,n) ) + do itest = 1, num_zz_tests + qual_zz = .true. + offset_zz = 0 + crit_zz = missing_r + + select case (itest) + case (1) + !-------------------------------------------------------------------------- + ! 4.1 Relative Thermal Contrast Test + ! (Zhuge and Zou, 2016, JAMC; TEST1) + !-------------------------------------------------------------------------- + crit_zz = iv%instid(i)%cld_qc(n)%RTCT + qual_zz(3:4) = .false. + + case (2) + !-------------------------------------------------------------------------- + ! 4.2 Cloud check: step 1 + ! Emissivity at Tropopause Test (ETROP) + ! (Zhuge and Zou, 2016, JAMC; TEST2) + !-------------------------------------------------------------------------- + if ( tb_xb(ch14,n) .gt. 0. .and. iv%instid(i)%tropt(n) .gt. 0. ) & + crit_zz = (rad_O14 - rad_M14) / (rad_tropt - rad_M14) + + case (3) + !-------------------------------------------------------------------------- + ! 4.3 Cloud check: step 2 + ! Positive Fourteen Minus Fifteen Test + ! (Zhuge and Zou, 2016, JAMC; TEST3) + !-------------------------------------------------------------------------- + qual_zz = tb_xb(ch14,n).ge.tb_xb(ch15,n) + + if ( (tb_inv(ch14,n) + tb_xb(ch14,n)).le.310. .and. & + iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch14).ge.0.3 .and. & + tb_ob(ch14,n).gt.0. .and. tb_ob(ch15,n).gt.0. ) & + crit_zz = ( tb_ob(ch14,n) - tb_ob(ch15,n) ) ! above using ob without VarBC ! ------------------------------- -! pfmft = (tb_inv(ch14,n) + tb_xb(ch14,n) - & -! (tb_inv(ch15,n) + tb_xb(ch15,n)) ) +! crit_zz = (tb_inv(ch14,n) + tb_xb(ch14,n) - & +! (tb_inv(ch15,n) + tb_xb(ch15,n)) ) ! above using ob with VarBC ! ------------------------------- !JJG: Why does this logical test not use tb_ob(ch14,n)? Something to do with VarBC... - if ( pfmft.gt.missing_r .and. & - (tb_inv(ch14,n) + tb_xb(ch14,n)).gt.270. .and. & - tb_xb(ch14,n).gt.270. .and. & - tb_xb(ch14,n).ge.tb_xb(ch15,n) ) & - pfmft = pfmft - & - (tb_xb(ch14,n) - tb_xb(ch15,n)) * & - (tb_ob(ch14,n) - 260.) / (tb_xb(ch14,n) - 260.) + if ( crit_zz.gt.missing_r .and. & + (tb_inv(ch14,n) + tb_xb(ch14,n)).gt.270. .and. & + tb_xb(ch14,n).gt.270. ) & + crit_zz = crit_zz - & + (tb_xb(ch14,n) - tb_xb(ch15,n)) * & + (tb_ob(ch14,n) - 260.) / (tb_xb(ch14,n) - 260.) ! above 1 line using ob without VarBC -! (tb_inv(ch14,n) + tb_xb(ch14,n) - 260.)/ & -! (tb_xb(ch14,n) - 260.) +! (tb_inv(ch14,n) + tb_xb(ch14,n) - 260.)/ & +! (tb_xb(ch14,n) - 260.) ! above 2 lines using ob with VarBC - crit_zz => pfmft - nrej_zz => nrej_pfmft - - call evaluate_clddet_test ( & - crit_name, crit_zz, isflg, & - eps_zz_ocean, eps_zz_land, eps_zz_snow, & - iv%instid(i)%info%proc_domain(1,n), & - reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - .true., .true., .true. ) - -! reject_zz = crit_zz .gt. missing_r .AND. & -! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean -! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land -! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice -! if (reject_zz) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_zz(:) = nrej_zz(:) + 1 -! -! if (print_zz) write(*,"(A,F14.6,A,I4,4D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & -! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n),tb_xb(ch14,n),tb_ob(ch14,n) -! end if - - if (reject_zz) clddet_zz_tests(3) = 1 - - !-------------------------------------------------------------------------- - ! 4.4 Negative Fourteen Minus Fifteen Test - ! (Zhuge and Zou, 2016, JAMC; TEST4) - ! e_nfmft = 1.0(Ocean), 2.0(land), 5.0(snow) - !-------------------------------------------------------------------------- - eps_zz_ocean = 1.0 - eps_zz_land = 2.0 - eps_zz_snow = 5.0 -! qualifier_ocean = .true. -! qualifier_land = .true. -! qualifier_snow = .true. - - crit_name = "nfmft" - - if (tb_ob(ch14,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) then - nfmft=tb_inv(ch15,n) - tb_inv(ch14,n) - else - nfmft = missing_r - end if - - crit_zz => nfmft - nrej_zz => nrej_nfmft - - call evaluate_clddet_test ( & - crit_name, crit_zz, isflg, & - eps_zz_ocean, eps_zz_land, eps_zz_snow, & - iv%instid(i)%info%proc_domain(1,n), & - reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - .true., .true., .true. ) - -! reject_zz = crit_zz .gt. missing_r .AND. & -! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean -! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land -! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice -! if (reject_zz) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_zz(:) = nrej_zz(:) + 1 -! -! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & -! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) -! end if - - if (reject_zz) clddet_zz_tests(4) = 1 - - - !-------------------------------------------------------------------------- - ! 4.5 Relative Fourteen Minus Fifteen Test - ! (Zhuge and Zou, 2016, JAMC; TEST5) - ! e_rfmft = 0.7(Ocean), 1.0(land) - !-------------------------------------------------------------------------- - eps_zz_ocean = 0.7 - eps_zz_land = 1.0 - eps_zz_snow = huge(eps_zz_snow) - qualifier_ocean = ( tb_ob(ch14,n) - tb_ob(ch15,n) ).lt.1.0 - qualifier_land = ( tb_ob(ch14,n) - tb_ob(ch15,n) ).lt.1.0 .and. tb_ob(ch14,n).le.300. - qualifier_snow = .false. - - crit_name = "rfmft" - - rfmft = iv%instid(i)%cld_qc(n)%RFMFT - - crit_zz => rfmft - nrej_zz => nrej_rfmft - - call evaluate_clddet_test ( & - crit_name, crit_zz, isflg, & - eps_zz_ocean, eps_zz_land, eps_zz_snow, & - iv%instid(i)%info%proc_domain(1,n), & - reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - qualifier_ocean, qualifier_land, qualifier_snow ) - -! reject_zz = crit_zz .gt. missing_r .AND. & -! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean -! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land -! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice -! if (reject_zz) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_zz(:) = nrej_zz(:) + 1 -! -! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & -! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) -! end if - - if (reject_zz) clddet_zz_tests(5) = 1 - - - !-------------------------------------------------------------------------- - ! 4.6 Cirrus Water Vapor Test - ! (Zhuge and Zou, 2016, JAMC; TEST6) - ! e_cirh2o = 0.7(Ocean), 0.7(land), 0.7(snow) - !-------------------------------------------------------------------------- - eps_zz_ocean = 0.7 - eps_zz_land = 0.7 - eps_zz_snow = 0.7 -! qualifier_ocean = .true. -! qualifier_land = .true. -! qualifier_snow = .true. - - crit_name = "cirh2o" - - if ( iv%instid(i)%cld_qc(n)%terr_hgt .le. 2000. .and. & - iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch10) .gt. 0.5 .and. & - iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch14) .gt. 0.5 .and. & - allocated(iv%instid(i)%cld_qc(n)%CIRH2O) ) then - cirh2o = iv%instid(i)%cld_qc(n)%CIRH2O(1,1,1) - else - cirh2o = missing_r - end if - - crit_zz => cirh2o - nrej_zz => nrej_cirh2o - - call evaluate_clddet_test ( & - crit_name, crit_zz, isflg, & - eps_zz_ocean, eps_zz_land, eps_zz_snow, & - iv%instid(i)%info%proc_domain(1,n), & - reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - .true., .true., .true. ) - -! reject_zz = crit_zz .gt. missing_r .AND. & -! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean -! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land -! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice -! if (reject_zz) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_zz(:) = nrej_zz(:) + 1 -! -! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & -! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) -! end if - - if (reject_zz) clddet_zz_tests(6) = 1 - - - !-------------------------------------------------------------------------- - ! 4.7 Modified 4um Emissivity Test - ! (Zhuge and Zou, 2016, JAMC; TEST7, New/Mod TEST1) - ! e_emiss4 = 0.1(Ocean), 0.2(land), 0.3(snow) for daytime, 2.86(Ocean) for night - ! e_modemiss4 = 0.26-3*1.04(Ocean) for sun-glint area - !-------------------------------------------------------------------------- -! qualifier_ocean = .true. -! qualifier_land = .true. -! qualifier_snow = .true. - - crit_name = "emiss4" - + case (4) + !-------------------------------------------------------------------------- + ! 4.4 Negative Fourteen Minus Fifteen Test + ! (Zhuge and Zou, 2016, JAMC; TEST4) + !-------------------------------------------------------------------------- + if (tb_ob(ch14,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) & + crit_zz = tb_inv(ch15,n) - tb_inv(ch14,n) + + case (5) + !-------------------------------------------------------------------------- + ! 4.5 Relative Fourteen Minus Fifteen Test + ! (Zhuge and Zou, 2016, JAMC; TEST5) + !-------------------------------------------------------------------------- + crit_zz = iv%instid(i)%cld_qc(n)%RFMFT + qual_zz = ( tb_ob(ch14,n) - tb_ob(ch15,n) ) .lt. 1.0 + qual_zz(2) = qual_zz(2) .and. tb_ob(ch14,n) .le. 300. + qual_zz(3:4) = .false. + + case (6) + !-------------------------------------------------------------------------- + ! 4.6 Cirrus Water Vapor Test + ! (Zhuge and Zou, 2016, JAMC; TEST6) + !-------------------------------------------------------------------------- + if ( iv%instid(i)%cld_qc(n)%terr_hgt .le. 2000. .and. & + iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch10) .gt. 0.5 .and. & + iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch14) .gt. 0.5 .and. & + allocated(iv%instid(i)%cld_qc(n)%CIRH2O) ) & + crit_zz = iv%instid(i)%cld_qc(n)%CIRH2O(1,1,1) + + case (7) + !-------------------------------------------------------------------------- + ! 4.7 Modified 4um Emissivity Test + ! (Zhuge and Zou, 2016, JAMC; TEST7, New/Mod TEST1) + !-------------------------------------------------------------------------- !JJG: Need to check over this code to ensure relative azimuth is calculated correctly - ! Modify EMISS for sun glint area may be not work, because we are at north land - ! - compute relative azimuth - Relaz = RELATIVE_AZIMUTH(iv%instid(i)%solazi(n),iv%instid(i)%satazi(n)) + ! Modify EMISS for sun glint area may be not work, because we are at north land + ! - compute relative azimuth + Relaz = RELATIVE_AZIMUTH(iv%instid(i)%solazi(n),iv%instid(i)%satazi(n)) !JJG: At least the use of solzen, satze, Relaz appears to be correct for Glintzen calculation - ! - compute glint angle - Glintzen = GLINT_ANGLE(iv%instid(i)%solzen(n),iv%instid(i)%satzen(n),Relaz ) - if (print_zz) write(*,"(A)") "PIXEL_DEBUG7: lat, lon, Relaz, Glintzen = " - if (print_zz) write(*,"(A,4D12.4)") "PIXEL_DEBUG8: ", & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n), Relaz, Glintzen - - if ( Glintzen.lt.40.0 .and. isflg==sea_flag) then -! if ( isflg==sea_flag .and. tb_inv(ch7,n) < -2.86 ) reject_zz = .true. - eps_zz_ocean = 2.86 - eps_zz_land = huge(eps_zz_land) - eps_zz_snow = huge(eps_zz_snow) - emiss4 = - tb_inv(ch7,n) ! (B_ch7 - O_ch7) - else - eps_zz_ocean = 0.1 - -! ! Modified EMISS4 from Zhuge and Zou -! eps_zz_land = 0.2 - - ! Default value from ABI CM algorithm - eps_zz_land = 0.46 - - eps_zz_snow = 0.3 - - if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) then - tb_temp1 = tb_ob(ch7,n) - rad_o_ch7 = plfk1(ch7) / & - ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) - tb_temp1 = tb_xb(ch7,n) - rad_b_ch7 = plfk1(ch7) / & - ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) - tb_temp1 = tb_ob(ch14,n) - rad_o_ch14 = plfk1(ch7) / & - ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) - tb_temp1 = tb_xb(ch14,n) - rad_b_ch14 = plfk1(ch7) / & - ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) -! --------------------------------------- - emiss4 = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14)/ & - (rad_b_ch7 / rad_b_ch14) - else - emiss4 = missing_r - end if - end if - - crit_zz => emiss4 - nrej_zz => nrej_emiss4 - - call evaluate_clddet_test ( & - crit_name, crit_zz, isflg, & - eps_zz_ocean, eps_zz_land, eps_zz_snow, & - iv%instid(i)%info%proc_domain(1,n), & - reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - .true., .true., .true. ) - -! reject_zz = crit_zz .gt. missing_r .AND. & -! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean -! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land -! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice -! if (reject_zz) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_zz(:) = nrej_zz(:) + 1 -! -! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & -! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) -! end if - - if (reject_zz) clddet_zz_tests(7) = 1 - - - !-------------------------------------------------------------------------- - ! 4.8 Uniform low stratus Test - ! (Zhuge and Zou, 2016, JAMC; TEST8) - ! e_ulst = 0.05(Ocean), 0.1(land), 0.12(snow) for night, no day time test - !-------------------------------------------------------------------------- - eps_zz_ocean = 0.05 - eps_zz_land = 0.1 - eps_zz_snow = 0.12 + ! - compute glint angle + Glintzen = GLINT_ANGLE(iv%instid(i)%solzen(n),iv%instid(i)%satzen(n),Relaz ) + if (print_zz) write(*,"(A)") "PIXEL_DEBUG7: lat, lon, Relaz, Glintzen = " + if (print_zz) write(*,"(A,4D12.4)") "PIXEL_DEBUG8: ", & + iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n), Relaz, Glintzen + + if ( Glintzen.lt.40.0 .and. isflg==sea_flag) then + crit_zz = - tb_inv(ch7,n) ! (B_ch7 - O_ch7) + offset_zz = 1 + else + if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) & + crit_zz = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14)/ & + (rad_b_ch7 / rad_b_ch14) + end if + + case (8) + !-------------------------------------------------------------------------- + ! 4.8 Uniform low stratus Test + ! (Zhuge and Zou, 2016, JAMC; TEST8) + !-------------------------------------------------------------------------- !JJG: Changed this to solzen instead of solazi for night/day test - qualifier_ocean = iv%instid(i)%solzen(n) >= 85.0 - qualifier_land = iv%instid(i)%solzen(n) >= 85.0 - qualifier_snow = iv%instid(i)%solzen(n) >= 85.0 - - crit_name = "ulst" - - if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) then - ulst = rad_b_ch7/rad_b_ch14 - rad_o_ch7/rad_o_ch14 - else - ulst = missing_r - end if - - crit_zz => ulst - nrej_zz => nrej_ulst - - call evaluate_clddet_test ( & - crit_name, crit_zz, isflg, & - eps_zz_ocean, eps_zz_land, eps_zz_snow, & - iv%instid(i)%info%proc_domain(1,n), & - reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - qualifier_ocean, qualifier_land, qualifier_snow ) - -! reject_zz = crit_zz .gt. missing_r .AND. & -! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean -! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land -! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice -! if (reject_zz) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_zz(:) = nrej_zz(:) + 1 -! -! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & -! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) -! end if - - if (reject_zz) clddet_zz_tests(8) = 1 - - - !-------------------------------------------------------------------------- - ! 4.9 Temporal Infrared Test - ! (Zhuge and Zou, 2016, JAMC; TEST9) - ! e_tempir = 2.0(Ocean), 2.0(land), 2.0(snow) - !-------------------------------------------------------------------------- - eps_zz_ocean = 2.0 - eps_zz_land = 2.0 - eps_zz_snow = 2.0 -! qualifier_ocean = .true. -! qualifier_land = .true. -! qualifier_snow = .true. - - crit_name = "tempir" - - tempir = iv%instid(i)%cld_qc(n)%TEMPIR - - crit_zz => tempir - nrej_zz => nrej_tempir - - call evaluate_clddet_test ( & - crit_name, crit_zz, isflg, & - eps_zz_ocean, eps_zz_land, eps_zz_snow, & - iv%instid(i)%info%proc_domain(1,n), & - reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - .true., .true., .true. ) - -! reject_zz = crit_zz .gt. missing_r .AND. & -! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean -! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land -! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice -! -! if (reject_zz) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_zz(:) = nrej_zz(:) + 1 -! -! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & -! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) -! end if - - if (reject_zz) clddet_zz_tests(9) = 1 - - - !-------------------------------------------------------------------------- - ! 4.10 N-OTC Test - ! (Zhuge and Zou, 2016, JAMC; New/Mod TEST3) - ! e_notc = 15.(Ocean), 21.(land), 10.(snow) for day - ! e_notc = 11.(Ocean), 15.(land), 4.5(snow) for night - !-------------------------------------------------------------------------- + qual_zz = iv%instid(i)%solzen(n) >= 85.0 + if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) & + crit_zz = rad_b_ch7/rad_b_ch14 - rad_o_ch7/rad_o_ch14 + + case (9) + !-------------------------------------------------------------------------- + ! 4.9 N-OTC Test + ! (Zhuge and Zou, 2016, JAMC; New/Mod TEST3) + !-------------------------------------------------------------------------- !JJG: Changed this to solzen instead of solazi for night/day test - if ( iv%instid(i)%solzen(n) < 85.0 ) then ! day Time - eps_zz_ocean = 15. - eps_zz_land = 21. - eps_zz_snow = 10. - else - eps_zz_ocean = 11. - eps_zz_land = 25. - eps_zz_snow = 4.5 - end if -! qualifier_ocean = .true. -! qualifier_land = .true. -! qualifier_snow = .true. - - crit_name = "notc" - - if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) then -! using ob with VarBC -! notc = tb_inv(ch7,n) + tb_xb(ch7,n) - & -! (tb_inv(ch15,n) + tb_xb(ch15,n)) -! using ob without VarBC - notc = tb_ob(ch7,n) - tb_ob(ch15,n) - else - notc = missing_r - end if - - crit_zz => notc - nrej_zz => nrej_notc - - call evaluate_clddet_test ( & - crit_name, crit_zz, isflg, & - eps_zz_ocean, eps_zz_land, eps_zz_snow, & - iv%instid(i)%info%proc_domain(1,n), & - reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:), & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - .true., .true., .true. ) - -! reject_zz = crit_zz .gt. missing_r .AND. & -! ( ( isflg==sea_flag .and. crit_zz > eps_zz_ocean .and. qualifier_ocean ) & ! Ocean -! .OR. ( isflg==land_flag .and. crit_zz > eps_zz_land .and. qualifier_land ) & ! land -! .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_zz_snow .and. qualifier_snow ) ) ! snow and ice -! if (reject_zz) then -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_zz(:) = nrej_zz(:) + 1 -! -! if (print_zz) write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, & -! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n) -! end if - - if (reject_zz) clddet_zz_tests(10) = 1 - - - - if (print_zz) write(*,'(A,I8,10I4)') 'PIXEL_DEBUG9: ', n, & - clddet_zz_tests - + if ( iv%instid(i)%solzen(n) .ge. 85.0 ) & + offset_zz = 1 ! night time + + if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) & + crit_zz = tb_ob(ch7,n) - tb_ob(ch15,n) +! above using ob without VarBC +! crit_zz = tb_inv(ch7,n) + tb_xb(ch7,n) - & +! (tb_inv(ch15,n) + tb_xb(ch15,n)) +! above using ob with VarBC + case (10) + !-------------------------------------------------------------------------- + ! 4.10 Temporal Infrared Test + ! (Zhuge and Zou, 2016, JAMC; TEST9) + !-------------------------------------------------------------------------- + crit_zz = iv%instid(i)%cld_qc(n)%TEMPIR + + case default + cycle + end select + + call evaluate_clddet_test ( crit_names_zz(itest), & + isflg, isflgs_zz, crit_zz, eps_zz(index_zz(itest)+offset_zz,:), qual_zz, & + iv%instid(i)%info%proc_domain(1,n), & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:,itest)) + + if (reject_zz) clddet_zz_tests(itest) = 1 + end do + +!JJGDEBUG + if (print_zz) write(*,'(A,I8,10I4)') 'PIXEL_DEBUG9: ', n, clddet_zz_tests +!JJGDEBUG end if clddet_zz ! --------------------------- @@ -869,16 +512,9 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) call da_proc_sum_int (nrej_land) call da_proc_sum_ints (nrej_eccloud) - call da_proc_sum_ints (nrej_rtct ) - call da_proc_sum_ints (nrej_etrop ) - call da_proc_sum_ints (nrej_pfmft ) - call da_proc_sum_ints (nrej_nfmft ) - call da_proc_sum_ints (nrej_rfmft ) - call da_proc_sum_ints (nrej_cirh2o ) - call da_proc_sum_ints (nrej_emiss4 ) - call da_proc_sum_ints (nrej_ulst ) - call da_proc_sum_ints (nrej_tempir ) - call da_proc_sum_ints (nrej_notc ) + do itest = 1, num_zz_tests + call da_proc_sum_ints (nrej_zz(:,itest)) + end do call da_proc_sum_ints (nrej_omb_abs) call da_proc_sum_ints (nrej_omb_std) @@ -909,26 +545,10 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) write(fgat_rad_unit,'(a20)') ' nrej_clw(:) = ' write(fgat_rad_unit,'(10i7)') nrej_clw(:) - write(fgat_rad_unit,'(a20)') ' nrej_rtct(:) = ' - write(fgat_rad_unit,'(10i7)') nrej_rtct(:) - write(fgat_rad_unit,'(a20)') ' nrej_etrop(:) = ' - write(fgat_rad_unit,'(10i7)') nrej_etrop(:) - write(fgat_rad_unit,'(a20)') ' nrej_pfmft(:) = ' - write(fgat_rad_unit,'(10i7)') nrej_pfmft(:) - write(fgat_rad_unit,'(a20)') ' nrej_nfmft(:) = ' - write(fgat_rad_unit,'(10i7)') nrej_nfmft(:) - write(fgat_rad_unit,'(a20)') ' nrej_rfmft(:) = ' - write(fgat_rad_unit,'(10i7)') nrej_rfmft(:) - write(fgat_rad_unit,'(a20)') ' nrej_cirh2o(:) = ' - write(fgat_rad_unit,'(10i7)') nrej_cirh2o(:) - write(fgat_rad_unit,'(a20)') ' nrej_emiss4(:) = ' - write(fgat_rad_unit,'(10i7)') nrej_emiss4(:) - write(fgat_rad_unit,'(a20)') ' nrej_ulst(:) = ' - write(fgat_rad_unit,'(10i7)') nrej_ulst(:) - write(fgat_rad_unit,'(a20)') ' nrej_tempir(:) = ' - write(fgat_rad_unit,'(10i7)') nrej_tempir(:) - write(fgat_rad_unit,'(a20)') ' nrej_notc(:) = ' - write(fgat_rad_unit,'(10i7)') nrej_notc(:) + do itest = 1, num_zz_tests + write(fgat_rad_unit,'(3A)') ' nrej_',trim(crit_names_zz(itest)),'(:) = ' + write(fgat_rad_unit,'(10i8)') nrej_zz(:,itest) + end do write(fgat_rad_unit,'(a20)') ' nrej_omb_abs(:) = ' write(fgat_rad_unit,'(10i7)') nrej_omb_abs(:) @@ -988,51 +608,21 @@ function glint_angle ( sol_zen , sat_zen , rel_az ) end function glint_angle -subroutine evaluate_clddet_test ( crit_name, crit_zz, isflg, eps_o, eps_l, eps_s, & - on_proc, reject_zz , tb_qc, nrej, & - lat, lon, q_ocean, q_land, q_snow) +subroutine evaluate_clddet_test ( crit_name, & + isflg, isflgs, crit_zz, eps, q, & + on_proc, lat, lon, & + reject_zz , tb_qc, nrej ) character(*), intent(in) :: crit_name - integer, intent(in) :: isflg + integer, intent(in) :: isflg, isflgs(:) logical, intent(in) :: on_proc - real, intent(in) :: crit_zz, eps_o, eps_l, eps_s, lat, lon - logical, intent(in) :: q_ocean, q_land, q_snow -! logical, intent(in), optional :: q_ocean, q_land, q_snow - - logical, intent(out) :: reject_zz - integer, intent(inout) :: tb_qc(:), nrej(:) - - integer, parameter :: sea_flag = 0 - integer, parameter :: ice_flag = 1 - integer, parameter :: land_flag = 2 - integer, parameter :: snow_flag = 3 - integer, parameter :: msea_flag = 4 - integer, parameter :: mice_flag = 5 - integer, parameter :: mland_flag = 6 - integer, parameter :: msnow_flag = 7 + real, intent(in) :: crit_zz, eps(:), lat, lon + logical, intent(in) :: q(:) + logical, intent(out) :: reject_zz + integer, intent(inout) :: tb_qc(:), nrej(:) -! logical :: q_o, q_l, q_s -! -! if (present(q_o)) then -! q_o = q_ocean -! else -! q_o = .true. -! end if -! if (present(q_l)) then -! q_l = q_land -! else -! q_l = .true. -! end if -! if (present(q_s)) then -! q_s = q_snow -! else -! q_s = .true. -! end if - - reject_zz = crit_zz .gt. missing_r .AND. & - ( ( isflg==sea_flag .and. crit_zz > eps_o .and. q_ocean ) & ! Ocean - .OR. ( isflg==land_flag .and. crit_zz > eps_l .and. q_land ) & ! land - .OR. ( any(isflg==(/snow_flag,ice_flag/)) .and. crit_zz > eps_s .and. q_snow ) ) ! snow and ice + reject_zz = .false. + reject_zz = crit_zz.gt.missing_r .and. any( isflg.eq.isflgs .and. crit_zz.gt.eps .and. q ) if (reject_zz) then tb_qc(:) = qc_bad diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 5c8d1e466e..ad64e17bbf 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -928,15 +928,38 @@ write(stdout,*) trim(command) pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) buf_int ( buf_i:buf_f, 2 ) = & pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) + buf_loc ( buf_i:buf_f ) % y = & pack(this_view % loc_1d % local (1:nrad_local) % y, domainmask_1d ) buf_loc ( buf_i:buf_f ) % x = & pack(this_view % loc_1d % local (1:nrad_local) % x, domainmask_1d ) +!!!! +! buf_loc ( buf_i:buf_f ) % j = & +! pack(this_view % loc_1d % local (1:nrad_local) % j, domainmask_1d ) +! buf_loc ( buf_i:buf_f ) % i = & +! pack(this_view % loc_1d % local (1:nrad_local) % i, domainmask_1d ) +! buf_loc ( buf_i:buf_f ) % dy = & +! pack(this_view % loc_1d % local (1:nrad_local) % dy, domainmask_1d ) +! buf_loc ( buf_i:buf_f ) % dx = & +! pack(this_view % loc_1d % local (1:nrad_local) % dx, domainmask_1d ) +! buf_loc ( buf_i:buf_f ) % dym = & +! pack(this_view % loc_1d % local (1:nrad_local) % dym, domainmask_1d ) +! buf_loc ( buf_i:buf_f ) % dxm = & +! pack(this_view % loc_1d % local (1:nrad_local) % dxm, domainmask_1d ) +!!!! else buf_real(buf_i:buf_f,:) = missing_r buf_int(buf_i:buf_f,:) = missing - buf_loc(buf_i:buf_f)%y = missing_r - buf_loc(buf_i:buf_f)%x = missing_r +!!!! +! buf_loc(buf_i:buf_f)%y = missing_r +! buf_loc(buf_i:buf_f)%x = missing_r +! buf_loc(buf_i:buf_f)%j = missing +! buf_loc(buf_i:buf_f)%i = missing +! buf_loc(buf_i:buf_f)%dy = missing_r +! buf_loc(buf_i:buf_f)%dx = missing_r +! buf_loc(buf_i:buf_f)%dym = missing_r +! buf_loc(buf_i:buf_f)%dxm = missing_r +!!!! end if #ifdef DM_PARALLEL !PERFORM COMMS @@ -946,8 +969,15 @@ write(stdout,*) trim(command) !Only x & y components of loc need to be communicated call mpi_bcast( buf_loc(buf_i:buf_f)%y, nbuf, true_mpi_real, iproc, comm, ierr ) call mpi_bcast( buf_loc(buf_i:buf_f)%x, nbuf, true_mpi_real, iproc, comm, ierr ) +!!!! +! call mpi_bcast( buf_loc(buf_i:buf_f)%j, nbuf, mpi_integer, iproc, comm, ierr ) +! call mpi_bcast( buf_loc(buf_i:buf_f)%i, nbuf, mpi_integer, iproc, comm, ierr ) +! call mpi_bcast( buf_loc(buf_i:buf_f)%dy, nbuf, true_mpi_real, iproc, comm, ierr ) +! call mpi_bcast( buf_loc(buf_i:buf_f)%dx, nbuf, true_mpi_real, iproc, comm, ierr ) +! call mpi_bcast( buf_loc(buf_i:buf_f)%dym, nbuf, true_mpi_real, iproc, comm, ierr ) +! call mpi_bcast( buf_loc(buf_i:buf_f)%dxm, nbuf, true_mpi_real, iproc, comm, ierr ) +!!!! #endif - end do ProcLoop ! END SOLUTION 2 @@ -1364,6 +1394,7 @@ write(stdout,*) trim(command) yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc info % elv = 0.0 !aquaspot % selv allocate ( p % tb_inv (1:nchan) ) + p % tb_inv = missing_r p % info = info p % loc = this_view % loc_1d % patch (n) @@ -1426,6 +1457,7 @@ write(stdout,*) trim(command) deallocate( tb_temp ) p % cld_qc % terr_hgt = terrain_hgt( iy, ix ) + p % info % elv = p % cld_qc % terr_hgt ! Values for RTCT cloud QC ! - channel 14 and sigma_z (std. dev. of terrain height in km) From 492f770d395f9ce35fbae5a8cc2e459aa0e60c75 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Tue, 28 Aug 2018 13:11:08 -0600 Subject: [PATCH 16/86] CRTM debugging Changes to be committed: modified: da_radiance/da_read_obs_ncgoesabi.inc --- .../da_radiance/da_get_innov_vector_crtm.inc | 2 +- var/da/da_radiance/da_qc_goesabi.inc | 16 ++++++++++ var/da/da_radiance/da_read_obs_ncgoesabi.inc | 32 +++++++++++++++---- 3 files changed, 42 insertions(+), 8 deletions(-) diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index 5c319d9722..a635dec5f8 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -99,7 +99,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) real :: geoht_pixel(kts:min(kte,kme-1)) real :: tt_pixel(kts:min(kte,kme-1)) real :: pp_pixel(kts:min(kte,kme-1)) - + Band_Size(1:5) = (/86, 0, 0, 16, 0 /) Bands(:,:) = 0 Bands(1:Band_Size(1),1) = & diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index de9ab8cdca..2fee19093e 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -72,6 +72,8 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) integer, parameter :: ch14 = 8 integer, parameter :: ch15 = 9 + character(len=3) :: nlayc + if (trace_use) call da_trace_entry("da_qc_goesabi") @@ -245,6 +247,20 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) iv%instid(i)%solzen(n), iv%instid(i)%solazi(n), & iv%instid(i)%tropt(n), iv%instid(i)%cld_qc(n)%terr_hgt, & iv%instid(i)%info%date_char(n) + + +! write(nlayc,'(I0)') (kte - kts)+1 +! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG10: ', n, iv%instid(i)%pm(1:(kte - kts)+1,n) +! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG11: ', n, iv%instid(i)%tm(1:(kte - kts)+1,n) +! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG12: ', n, iv%instid(i)%qm(1:(kte - kts)+1,n) +! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'I10)') 'PIXEL_DEBUG13: ', n, iv%instid(i)%info%i (kts:kte,n) +! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'I10)') 'PIXEL_DEBUG14: ', n, iv%instid(i)%info%j (kts:kte,n) +! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG15: ', n, iv%instid(i)%info%dx (kts:kte,n) +! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG16: ', n, iv%instid(i)%info%dy (kts:kte,n) +! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG17: ', n, iv%instid(i)%info%dxm(kts:kte,n) +! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG18: ', n, iv%instid(i)%info%dym(kts:kte,n) + + !JJGDEBUG clddet_zz_tests = 0 diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index ad64e17bbf..bbc562da14 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -1295,7 +1295,7 @@ write(stdout,*) trim(command) call get_abil1b_bt( fname, & this_view % ys_local, this_view % ye_local, & this_view % xs_local, this_view % xe_local, & - readmask_p, bt_p(:,:,1) ) + readmask_p, bt_p(:,:,1), inst, ichan ) allmask_p = (allmask_p .and. readmask_p) @@ -1305,7 +1305,7 @@ write(stdout,*) trim(command) call get_abil1b_bt( fname, & this_view % ys_local, this_view % ye_local, & this_view % xs_local, this_view % xe_local, & - readmask_p, bt_p(:,:,2) ) + readmask_p, bt_p(:,:,2), inst, ichan ) end if first_chan = (this_view % nfiles_used(ifgat).eq.1) @@ -2073,7 +2073,7 @@ end subroutine get_abil1b_grid2_1d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt ) +subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt, inst, ichan ) implicit none character(*), intent(in) :: filename @@ -2082,6 +2082,7 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt ) !Starting and stopping indices of this view desired (not equivalent to Full Disk indices) integer, intent(in) :: ys, ye, xs, xe + integer, intent(in) :: inst, ichan logical, intent(inout) :: radmask( ys:ye, xs:xe ) real, intent(out) :: bt( ys:ye, xs:xe ) @@ -2150,10 +2151,27 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt ) ! radmask = ( radmask .and. (DQF.eq.0 .or. DQF.eq.1) ) ! radmask = ( radmask .and. rad.ge.0.0 ) - where ( radmask ) -! bt = ( fk2 / ( log(( fk1 / rad ) + 1.0) ) - bc1 ) / bc2 - bt = ( fk2 / ( log(( fk1 / transpose(rad) ) + 1.0) ) - bc1 ) / bc2 - end where +!!!JJGDEBUG +! if (rtm_option == rtm_option_crtm) then +! do ix = xs, xe +! do iy = ys, ye +! if ( radmask( iy, ix ) ) then +!! call CRTM_Planck_Temperature(inst, ichan, rad( iy, ix ), bt( iy, ix )) +! call CRTM_Planck_Temperature(inst, ichan, rad( ix, iy ), bt( iy, ix )) +! end if +! end do +! end do +! else +!!!JJGDEBUG + + where ( radmask ) +! bt = ( fk2 / ( log(( fk1 / rad ) + 1.0) ) - bc1 ) / bc2 + bt = ( fk2 / ( log(( fk1 / transpose(rad) ) + 1.0) ) - bc1 ) / bc2 + end where + +!!!JJGDEBUG +! end if +!!!JJGDEBUG ! do ix = xs, xe ! do iy = ys, ye From a53e27a9188b0c343b9a7dc17d3cab0912ab2153 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 29 Aug 2018 12:13:16 -0600 Subject: [PATCH 17/86] Modifying channel numbers in goes abi info files for RTTOV Changes to be committed: modified: goes-16-abi.info modified: goes-17-abi.info --- var/run/radiance_info/goes-16-abi.info | 18 +++++++++--------- var/run/radiance_info/goes-17-abi.info | 18 +++++++++--------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/var/run/radiance_info/goes-16-abi.info b/var/run/radiance_info/goes-16-abi.info index 6b82b5a246..61e86f0977 100644 --- a/var/run/radiance_info/goes-16-abi.info +++ b/var/run/radiance_info/goes-16-abi.info @@ -1,11 +1,11 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) + 1023 1 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 2 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 3 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 4 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 5 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 6 1 -1 0 2.0000000000E+00 0.0000000000E+00 1023 7 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 8 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 9 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 10 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 11 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 12 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 13 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 14 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 15 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 16 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 8 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 9 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 10 1 -1 0 2.0000000000E+00 0.0000000000E+00 diff --git a/var/run/radiance_info/goes-17-abi.info b/var/run/radiance_info/goes-17-abi.info index 6b82b5a246..61e86f0977 100644 --- a/var/run/radiance_info/goes-17-abi.info +++ b/var/run/radiance_info/goes-17-abi.info @@ -1,11 +1,11 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) + 1023 1 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 2 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 3 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 4 1 1 0 2.0000000000E+00 0.0000000000E+00 + 1023 5 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 6 1 -1 0 2.0000000000E+00 0.0000000000E+00 1023 7 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 8 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 9 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 10 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 11 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 12 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 13 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 14 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 15 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 16 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 8 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 9 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 10 1 -1 0 2.0000000000E+00 0.0000000000E+00 From a61792d09e84275f084b2621ed7a05a6fe40aad9 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 5 Sep 2018 12:08:32 -0600 Subject: [PATCH 18/86] Clean up qc for goesabi Changes to be committed: modified: da_radiance/da_qc_goesabi.inc --- var/da/da_radiance/da_qc_goesabi.inc | 91 ++++++++++------------------ 1 file changed, 31 insertions(+), 60 deletions(-) diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 2fee19093e..bf3e4d468f 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -72,8 +72,6 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) integer, parameter :: ch14 = 8 integer, parameter :: ch15 = 9 - character(len=3) :: nlayc - if (trace_use) call da_trace_entry("da_qc_goesabi") @@ -184,9 +182,6 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! 3.0 check cloud !----------------------------------------------------------------- if (.not. crtm_cloud ) then - -! do k = 1, nchan - if (iv%instid(i)%clwp(n) >= 0.2) then iv%instid(i)%tb_qc(:,n) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & @@ -208,15 +203,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) nrej_eccloud(:) = nrej_eccloud(:) + 1 end if end if -! else -! if (iv%instid(i)%cloudflag(n) <= 0) then ! only use abs clear pixel, read clm by Zhuge and Zou(2017) -! iv%instid(i)%tb_qc(:,n) = qc_bad -! if (iv%instid(i)%info%proc_domain(1,n)) & -! nrej_eccloud(:) = nrej_eccloud(:) + 1 -! end if end if - -! end do end if clddet_zz: if ( use_clddet_zz .and. all(tb_inv((/1,8,9/),n).gt.missing_r) ) then @@ -228,40 +215,26 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !!========================================================================== !!========================================================================== -!JJGDEBUG -! print_zz = iv%instid(i)%info%proc_domain(1,n) - print_zz = .true. - if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG1: ', n, & - tb_inv(:,n) - if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG2: ', n, & - tb_xb(:,n) - if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG3: ', n, & - tb_ob(:,n) - - if (print_zz) write(*,'(A,3I8)') 'PIXEL_DEBUG4: n, n1, n2 = ', & - n, iv%instid(i)%info%n1, iv%instid(i)%info%n2 - if (print_zz) write(*,'(A)') 'PIXEL_DEBUG5: n, lat, lon, satzen, satazi, solzen, solazi, tropt, terrain, date = ' - if (print_zz) write(*,'(A,I8,8F12.4,A)') 'PIXEL_DEBUG6: ', n, & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - iv%instid(i)%satzen(n), iv%instid(i)%satazi(n), & - iv%instid(i)%solzen(n), iv%instid(i)%solazi(n), & - iv%instid(i)%tropt(n), iv%instid(i)%cld_qc(n)%terr_hgt, & - iv%instid(i)%info%date_char(n) - - -! write(nlayc,'(I0)') (kte - kts)+1 -! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG10: ', n, iv%instid(i)%pm(1:(kte - kts)+1,n) -! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG11: ', n, iv%instid(i)%tm(1:(kte - kts)+1,n) -! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG12: ', n, iv%instid(i)%qm(1:(kte - kts)+1,n) -! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'I10)') 'PIXEL_DEBUG13: ', n, iv%instid(i)%info%i (kts:kte,n) -! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'I10)') 'PIXEL_DEBUG14: ', n, iv%instid(i)%info%j (kts:kte,n) -! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG15: ', n, iv%instid(i)%info%dx (kts:kte,n) -! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG16: ', n, iv%instid(i)%info%dy (kts:kte,n) -! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG17: ', n, iv%instid(i)%info%dxm(kts:kte,n) -! if (print_zz) write(*,'(A,I8,'//trim(nlayc)//'D21.12)') 'PIXEL_DEBUG18: ', n, iv%instid(i)%info%dym(kts:kte,n) - - -!JJGDEBUG +!!JJGDEBUG +!! print_zz = iv%instid(i)%info%proc_domain(1,n) +! print_zz = .true. +! if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG1: ', n, & +! tb_inv(:,n) +! if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG2: ', n, & +! tb_xb(:,n) +! if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG3: ', n, & +! tb_ob(:,n) +! +! if (print_zz) write(*,'(A,3I8)') 'PIXEL_DEBUG4: n, n1, n2 = ', & +! n, iv%instid(i)%info%n1, iv%instid(i)%info%n2 +! if (print_zz) write(*,'(A)') 'PIXEL_DEBUG5: n, lat, lon, satzen, satazi, solzen, solazi, tropt, terrain, date = ' +! if (print_zz) write(*,'(A,I8,8F12.4,A)') 'PIXEL_DEBUG6: ', n, & +! iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & +! iv%instid(i)%satzen(n), iv%instid(i)%satazi(n), & +! iv%instid(i)%solzen(n), iv%instid(i)%solazi(n), & +! iv%instid(i)%tropt(n), iv%instid(i)%cld_qc(n)%terr_hgt, & +! iv%instid(i)%info%date_char(n) +!!JJGDEBUG clddet_zz_tests = 0 @@ -389,17 +362,17 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! 4.7 Modified 4um Emissivity Test ! (Zhuge and Zou, 2016, JAMC; TEST7, New/Mod TEST1) !-------------------------------------------------------------------------- -!JJG: Need to check over this code to ensure relative azimuth is calculated correctly ! Modify EMISS for sun glint area may be not work, because we are at north land ! - compute relative azimuth Relaz = RELATIVE_AZIMUTH(iv%instid(i)%solazi(n),iv%instid(i)%satazi(n)) -!JJG: At least the use of solzen, satze, Relaz appears to be correct for Glintzen calculation ! - compute glint angle Glintzen = GLINT_ANGLE(iv%instid(i)%solzen(n),iv%instid(i)%satzen(n),Relaz ) - if (print_zz) write(*,"(A)") "PIXEL_DEBUG7: lat, lon, Relaz, Glintzen = " - if (print_zz) write(*,"(A,4D12.4)") "PIXEL_DEBUG8: ", & - iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n), Relaz, Glintzen +!!JJGDEBUG +! if (print_zz) write(*,"(A)") "PIXEL_DEBUG7: lat, lon, Relaz, Glintzen = " +! if (print_zz) write(*,"(A,4D12.4)") "PIXEL_DEBUG8: ", & +! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n), Relaz, Glintzen +!!JJGDEBUG if ( Glintzen.lt.40.0 .and. isflg==sea_flag) then crit_zz = - tb_inv(ch7,n) ! (B_ch7 - O_ch7) @@ -456,9 +429,9 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if (reject_zz) clddet_zz_tests(itest) = 1 end do -!JJGDEBUG - if (print_zz) write(*,'(A,I8,10I4)') 'PIXEL_DEBUG9: ', n, clddet_zz_tests -!JJGDEBUG +!!JJGDEBUG +! if (print_zz) write(*,'(A,I8,10I4)') 'PIXEL_DEBUG9: ', n, clddet_zz_tests +!!JJGDEBUG end if clddet_zz ! --------------------------- @@ -593,8 +566,6 @@ function relative_azimuth ( sol_az ,sen_az ) real :: sen_az real :: relative_azimuth -!JJG: why all the corrections? abs? 360-rel_az? 180-rel_az? - relative_azimuth = abs(sol_az - sen_az) if (relative_azimuth > 180.0) then relative_azimuth = 360.0 - relative_azimuth @@ -625,7 +596,7 @@ function glint_angle ( sol_zen , sat_zen , rel_az ) end function glint_angle subroutine evaluate_clddet_test ( crit_name, & - isflg, isflgs, crit_zz, eps, q, & + isflg, isflgs, crit_zz, eps, extra_qual, & on_proc, lat, lon, & reject_zz , tb_qc, nrej ) @@ -633,12 +604,12 @@ subroutine evaluate_clddet_test ( crit_name, & integer, intent(in) :: isflg, isflgs(:) logical, intent(in) :: on_proc real, intent(in) :: crit_zz, eps(:), lat, lon - logical, intent(in) :: q(:) + logical, intent(in) :: extra_qual(:) logical, intent(out) :: reject_zz integer, intent(inout) :: tb_qc(:), nrej(:) reject_zz = .false. - reject_zz = crit_zz.gt.missing_r .and. any( isflg.eq.isflgs .and. crit_zz.gt.eps .and. q ) + reject_zz = crit_zz.gt.missing_r .and. any( isflg.eq.isflgs .and. crit_zz.gt.eps .and. extra_qual ) if (reject_zz) then tb_qc(:) = qc_bad From 7d8dd00a8c1440ae37e85d68c7910644f694d5ca Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 5 Sep 2018 16:55:39 -0600 Subject: [PATCH 19/86] First steps toward cloudy radiance handling for GOES-ABI Changes to be committed: modified: Registry/registry.var modified: var/da/da_define_structures/da_define_structures.f90 modified: var/da/da_monitor/da_rad_diags.f90 modified: var/da/da_radiance/da_allocate_rad_iv.inc modified: var/da/da_radiance/da_crtm.f90 modified: var/da/da_radiance/da_deallocate_radiance.inc modified: var/da/da_radiance/da_get_innov_vector_crtm.inc modified: var/da/da_radiance/da_qc_amsr2.inc modified: var/da/da_radiance/da_qc_goesabi.inc modified: var/da/da_radiance/da_radiance1.f90 modified: var/da/da_radiance/da_radiance_init.inc modified: var/da/da_radiance/da_write_iv_rad_ascii.inc modified: var/da/da_radiance/da_write_oa_rad_ascii.inc modified: var/da/da_radiance/module_radiance.f90 modified: var/run/radiance_info/gcom-w-1-amsr2.info modified: var/run/radiance_info/goes-16-abi.info --- Registry/registry.var | 1 + .../da_define_structures.f90 | 1 + var/da/da_monitor/da_rad_diags.f90 | 37 +- var/da/da_radiance/da_allocate_rad_iv.inc | 3 + var/da/da_radiance/da_crtm.f90 | 2 +- var/da/da_radiance/da_deallocate_radiance.inc | 9 +- .../da_radiance/da_get_innov_vector_crtm.inc | 10 +- var/da/da_radiance/da_qc_amsr2.inc | 6 +- var/da/da_radiance/da_qc_goesabi.inc | 467 ++++++++++-------- var/da/da_radiance/da_radiance1.f90 | 3 +- var/da/da_radiance/da_radiance_init.inc | 19 +- var/da/da_radiance/da_write_iv_rad_ascii.inc | 9 +- var/da/da_radiance/da_write_oa_rad_ascii.inc | 9 +- var/da/da_radiance/module_radiance.f90 | 3 +- var/run/radiance_info/gcom-w-1-amsr2.info | 28 +- var/run/radiance_info/goes-16-abi.info | 20 +- 16 files changed, 379 insertions(+), 248 deletions(-) diff --git a/Registry/registry.var b/Registry/registry.var index dc72bc024f..2476fb8ae1 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -416,6 +416,7 @@ rconfig integer rtm_option namelist,wrfvar14 1 1 - "rt rconfig logical use_crtm_kmatrix namelist,wrfvar14 1 .true. - "use_crtm_kmatrix" "" "" rconfig logical use_rttov_kmatrix namelist,wrfvar14 1 .false. - "use_rttov_kmatrix" "" "" rconfig logical crtm_cloud namelist,wrfvar14 1 .false. - "crtm_cloud" "" "" +rconfig logical calc_ir_btlim namelist,wrfvar14 1 .true. - "calc_ir_btlim" "" "" rconfig logical only_sea_rad namelist,wrfvar14 1 .false. - "only_sea_rad" "" "" rconfig logical use_pseudo_rad namelist,wrfvar14 1 .false. - "use_pseudo_rad" "" "" rconfig integer pseudo_rad_platid namelist,wrfvar14 1 1 - "pseudo_rad_platid" "" "" diff --git a/var/da/da_define_structures/da_define_structures.f90 b/var/da/da_define_structures/da_define_structures.f90 index d56dab2c77..8d41075e66 100644 --- a/var/da/da_define_structures/da_define_structures.f90 +++ b/var/da/da_define_structures/da_define_structures.f90 @@ -521,6 +521,7 @@ module da_define_structures integer, pointer :: scanline(:) integer, pointer :: cloud_flag(:,:) integer, pointer :: rain_flag(:) + real, pointer :: ca_mean(:,:) real, pointer :: satzen(:) real, pointer :: satazi(:) real, pointer :: solzen(:) diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index 2f8ebdff7d..96a0fa3c51 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -42,7 +42,7 @@ program da_rad_diags integer :: ncid, dimid, varid integer, dimension(3) :: ishape, istart, icount ! - logical :: amsr2 + logical :: amsr2, abi logical :: isfile, prf_found, jac_found integer, parameter :: datelen1 = 10 integer, parameter :: datelen2 = 19 @@ -62,6 +62,7 @@ program da_rad_diags real*4, dimension(:), allocatable :: smois, tslb, snowh, vegfra, clwp integer, dimension(:,:), allocatable :: tb_qc real*4, dimension(:,:), allocatable :: tb_obs, tb_bak, tb_inv, tb_oma, tb_err, ems, ems_jac + real*4, dimension(:,:), allocatable :: ca_mean, tb_bak_clr real*4, dimension(:,:), allocatable :: prf_pfull, prf_phalf, prf_t, prf_q, prf_water real*4, dimension(:,:), allocatable :: prf_ice, prf_rain, prf_snow, prf_grau, prf_hail real*4, dimension(:,:), allocatable :: prf_water_reff, prf_ice_reff, prf_rain_reff @@ -135,6 +136,7 @@ program da_rad_diags write(0,*) trim(instid(iinst)) amsr2 = index(instid(iinst),'amsr2') > 0 + abi = index(instid(iinst),'abi') > 0 nerr = 0 total_npixel = 0 @@ -251,7 +253,11 @@ program da_rad_diags allocate ( tb_inv(1:nchan,1:total_npixel) ) allocate ( tb_oma(1:nchan,1:total_npixel) ) allocate ( tb_err(1:nchan,1:total_npixel) ) - allocate ( tb_qc(1:nchan,1:total_npixel) ) + allocate ( tb_qc(1:nchan,1:total_npixel) ) + if ( abi ) then + allocate ( ca_mean(1:nchan,1:total_npixel) ) + allocate ( tb_bak_clr(1:nchan,1:total_npixel) ) + end if allocate ( ems(1:nchan,1:total_npixel) ) if ( jac_found ) then allocate ( ems_jac(1:nchan,1:total_npixel) ) @@ -320,6 +326,11 @@ program da_rad_diags tb_inv = missing_r tb_oma = missing_r tb_err = missing_r + if ( abi ) then + ca_mean = missing_r + tb_bak_clr = missing_r + end if + ncname = 'diags_'//trim(instid(iinst))//"_"//datestr1(itime)//'.nc' ios = NF_CREATE(trim(ncname), NF_CLOBBER, ncid) ! NF_CLOBBER specifies the default behavior of ! overwritting any existing dataset with the @@ -370,6 +381,12 @@ program da_rad_diags read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! QC read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_qc(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf + if ( abi ) then ! read ca_mean, tb_bak_clr + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CA + read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) ca_mean(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! BGCLR + read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_bak_clr(:,ipixel) + end if if ( buf(1:4) == "INFO" ) then backspace(iunit(iproc)) cycle npixel_loop @@ -496,6 +513,12 @@ program da_rad_diags end if ios = NF_DEF_VAR(ncid, 'tb_err', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_DEF_VAR(ncid, 'tb_qc', NF_INT, 2, ishape(1:2), varid) + if ( abi ) then + ios = NF_DEF_VAR(ncid, 'ca_mean', NF_FLOAT, 2, ishape(1:2), varid) + ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) + ios = NF_DEF_VAR(ncid, 'tb_bak_clr', NF_FLOAT, 2, ishape(1:2), varid) + ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) + end if ! ! define 2-D array with dimensions nlev * total_npixel ! @@ -633,6 +656,12 @@ program da_rad_diags ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_err) ios = NF_INQ_VARID (ncid, 'tb_qc', varid) ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), tb_qc) + if ( abi ) then + ios = NF_INQ_VARID (ncid, 'ca_mean', varid) + ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), ca_mean) + ios = NF_INQ_VARID (ncid, 'tb_bak_clr', varid) + ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_bak_clr) + end if ! ! output 2-D array with dimensions nlev * total_npixel ! @@ -837,6 +866,10 @@ program da_rad_diags deallocate ( tb_obs ) deallocate ( tb_bak ) deallocate ( tb_inv ) + if ( abi ) then + deallocate ( ca_mean ) + deallocate ( tb_bak_clr ) + end if deallocate ( tb_oma ) deallocate ( ems ) if ( jac_found ) deallocate ( ems_jac ) diff --git a/var/da/da_radiance/da_allocate_rad_iv.inc b/var/da/da_radiance/da_allocate_rad_iv.inc index a22cb72040..3ace9cd2cc 100644 --- a/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/var/da/da_radiance/da_allocate_rad_iv.inc @@ -80,6 +80,9 @@ subroutine da_allocate_rad_iv (i, nchan, iv) if ( index(iv%instid(i)%rttovid_string, 'amsr2') > 0 ) then allocate (iv%instid(i)%clw(iv%instid(i)%num_rad)) end if + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + allocate (iv%instid(i)%ca_mean(nchan,iv%instid(i)%num_rad)) + end if allocate (iv%instid(i)%ps(iv%instid(i)%num_rad)) allocate (iv%instid(i)%tb_xb(nchan,iv%instid(i)%num_rad)) if ( crtm_cloud ) then diff --git a/var/da/da_radiance/da_crtm.f90 b/var/da/da_radiance/da_crtm.f90 index 6e35c46fe3..5c70d9c058 100644 --- a/var/da/da_radiance/da_crtm.f90 +++ b/var/da/da_radiance/da_crtm.f90 @@ -38,7 +38,7 @@ module da_crtm simulated_rad_ngrid, interp_option, use_mspps_emis, use_mspps_ts, calc_weightfunc, & use_clddet_ecmwf, use_clddet_zz, its,ite,jts,jte, & crtm_coef_path, crtm_irwater_coef, crtm_mwwater_coef, crtm_irland_coef, crtm_visland_coef, & - cloud_cv_options + cloud_cv_options, calc_ir_btlim use da_interpolation, only : da_interp_lin_2d_partial,da_interp_lin_2d_adj_partial, & da_interp_2d_partial use da_physics, only: da_trop_wmo diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index a1f4f3d1ef..c972c725a9 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -21,7 +21,8 @@ deallocate (satinfo(i) % ichan) deallocate (satinfo(i) % iuse) deallocate (satinfo(i) % error) - deallocate (satinfo(i) % error_cld) + deallocate (satinfo(i) % error_cld_y) + deallocate (satinfo(i) % error_cld_x) deallocate (satinfo(i) % polar) deallocate (satinfo(i) % scanbias) @@ -98,9 +99,13 @@ deallocate (iv%instid(i)%vegfra) deallocate (iv%instid(i)%vegtyp) deallocate (iv%instid(i)%clwp) - if ( index(iv%instid(i)%rttovid_string,'amsr2') > 0 ) then + if ( index(iv%instid(i)%rttovid_string, 'amsr2') > 0 ) then deallocate (iv%instid(i)%clw) end if + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + deallocate (iv%instid(i)%ca_mean) + end if + deallocate (iv%instid(i)%ps) deallocate (iv%instid(i)%tb_xb) if ( crtm_cloud ) then diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index a635dec5f8..435c7cef26 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -244,10 +244,14 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) end if calc_tb_clr = .false. - if ( crtm_cloud .and. & - trim( crtm_sensor_name(rtminit_sensor(inst))) == 'amsr2' ) then + if ( crtm_cloud .and. ( & + trim( crtm_sensor_name(rtminit_sensor(inst))) == 'amsr2' + .OR. trim( crtm_sensor_name(rtminit_sensor(inst))) == 'abi' + ) ) then +! .OR. ( trim( crtm_sensor_name(rtminit_sensor(inst))) == 'abi' .and. calc_ir_btlim ) & + !Tb_clear_sky is only needed for symmetric obs error model - !symmetric obs error model only implemented for amsr2 for now + !symmetric obs error model only implemented for amsr2 & abi for now calc_tb_clr = .true. end if diff --git a/var/da/da_radiance/da_qc_amsr2.inc b/var/da/da_radiance/da_qc_amsr2.inc index fb05e52a12..89f39f2f81 100644 --- a/var/da/da_radiance/da_qc_amsr2.inc +++ b/var/da/da_radiance/da_qc_amsr2.inc @@ -120,11 +120,11 @@ subroutine da_qc_amsr2 (it, i, nchan, ob, iv) do k = 1, nchan if (c37_mean.lt.0.05) then iv%instid(i)%tb_error(k,n)= satinfo(i)%error_std(k) - else if (c37_mean.ge.0.05.and.c37_mean.lt.0.5) then + else if (c37_mean.ge.0.05.and.c37_mean.lt.satinfo(i)%error_cld_x(k)) then iv%instid(i)%tb_error(k,n)= satinfo(i)%error_std(k)+ & - (c37_mean-0.05)*(satinfo(i)%error_cld(k)-satinfo(i)%error_std(k))/(0.5-0.05) + (c37_mean-0.05)*(satinfo(i)%error_cld_y(k)-satinfo(i)%error_std(k))/(satinfo(i)%error_cld_x(k)-0.05) else - iv%instid(i)%tb_error(k,n)= satinfo(i)%error_cld(k) + iv%instid(i)%tb_error(k,n)= satinfo(i)%error_cld_y(k) end if end do ! nchan diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index bf3e4d468f..7418d6ddfc 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -34,31 +34,39 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! ------- real :: inv_grosscheck - character(len=30) :: filename - real :: c37_mean + character(len=30) :: filename - !! Additional variables used by Zhuge and Zou(2017) + logical :: print_cld_debug + + !! Additional variables used by Harnish, Weissmann, & Perianez (2016) + real :: BTlim(nchan) + real, allocatable :: cld_impact(:,:) + real, parameter :: camin = 0.0 + + !! Additional variables used by Zhuge and Zou (2017) integer :: itest - logical :: reject_zz, print_zz - real :: crit_zz - - real :: rad_O14, rad_M14, rad_tropt - real :: rad_o_ch7, rad_b_ch7, rad_o_ch14, rad_b_ch14 - real :: Relaz, Glintzen, tb_temp1 - real :: wave_num(10) - real :: plbc1(10), plbc2(10) - real :: plfk1(10), plfk2(10) - integer, parameter :: num_zz_tests = 10 - integer, parameter :: num_zz_cats = 4 - real :: eps_zz(num_zz_tests+2,num_zz_cats) - integer :: index_zz(num_zz_tests), offset_zz - integer :: isflgs_zz(num_zz_cats) - logical :: qual_zz(num_zz_cats) - character(len=10) :: crit_names_zz(num_zz_tests) - integer :: nrej_zz(nchan,num_zz_tests) - integer*2 :: clddet_zz_tests(num_zz_tests) - - real, pointer :: tb_ob(:,:), tb_xb(:,:), tb_inv(:,:) + logical :: reject_clddet + real :: crit_clddet + real :: rad_O14, rad_M14, rad_tropt + real :: rad_o_ch7, rad_b_ch7, rad_o_ch14, rad_b_ch14 + real :: Relaz, Glintzen, tb_temp1 + real :: wave_num(10) + real :: plbc1(10), plbc2(10) + real :: plfk1(10), plfk2(10) + integer, parameter :: num_clddet_tests = 10 + integer, parameter :: num_clddet_cats = 4 + real :: eps_clddet(num_clddet_tests+2,num_clddet_cats) + integer :: index_clddet(num_clddet_tests), offset_clddet + integer :: isflgs_clddet(num_clddet_cats) + logical :: qual_clddet(num_clddet_cats) + character(len=10) :: crit_names_clddet(num_clddet_tests) + integer :: nrej_clddet(nchan,num_clddet_tests) + integer*2 :: clddet_tests(num_clddet_tests) + + real, pointer :: tb_ob(:,:), tb_xb(:,:), tb_inv(:,:), tb_xb_clr(:,:), ca_mean(:,:) + integer :: tb_qc(nchan), tb_qc_clddet(nchan) + + real :: big_num ! note: these values are constant across channels real, parameter :: C1=1.19104276e-5 ! = 2 * h * c**2 mWm-2sr-1(cm-1)-4 @@ -77,45 +85,46 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! These values can change as SRF (spectral response function) is updated ! It is recommended to acquire these from L1B files, not copy them from GOES R PUG L1b Vol. 3 - wave_num(1:10) = (/2570.373,1620.528,1443.554,1363.228,1184.220, & - 1040.891, 968.001, 894.000, 815.294, 753.790/) - plbc1(1:10) = (/0.43361, 1.55228, 0.34427, 0.05651, 0.18733, & + wave_num(1:10) = (/2570.373, 1620.528, 1443.554, 1363.228, 1184.220, & + 1040.891, 968.001, 894.000, 815.294, 753.790/) + plbc1(1:10) = (/0.43361, 1.55228, 0.34427, 0.05651, 0.18733, & 0.09102, 0.07550, 0.22516, 0.21702, 0.06266/) - plbc2(1:10) = (/0.99939, 0.99667, 0.99918, 0.99986, 0.99948, & + plbc2(1:10) = (/0.99939, 0.99667, 0.99918, 0.99986, 0.99948, & 0.99971, 0.99975, 0.99920, 0.99916, 0.99974/) plfk1 = C1 * wave_num**3 plfk2 = C2 * wave_num - crit_names_zz(1) = "rtct" - crit_names_zz(2) = "etrop" - crit_names_zz(3) = "pfmft" - crit_names_zz(4) = "nfmft" - crit_names_zz(5) = "rfmft" - crit_names_zz(6) = "cirh2o" - crit_names_zz(7) = "emiss4" - crit_names_zz(8) = "ulst" - crit_names_zz(9) = "notc" - crit_names_zz(10) = "tempir" - + crit_names_clddet(1) = "rtct" + crit_names_clddet(2) = "etrop" + crit_names_clddet(3) = "pfmft" + crit_names_clddet(4) = "nfmft" + crit_names_clddet(5) = "rfmft" + crit_names_clddet(6) = "cirh2o" + crit_names_clddet(7) = "emiss4" + crit_names_clddet(8) = "ulst" + crit_names_clddet(9) = "notc" + crit_names_clddet(10) = "tempir" + + big_num = huge(big_num) !! Table 4 from Zhuge X. and Zou X. JAMC, 2016. [modified from ABI Cloud Mask Algorithm] !ocean land snow ice (assume same as snow) - eps_zz = transpose( reshape( (/ & - 3.2, 4.1, huge(C1), huge(C1) & - , 0.1, 0.3, 0.4, 0.4 & - , 0.8, 2.5, 1.0, 1.0 & - , 1.0, 2.0, 5.0, 5.0 & - , 0.7, 1.0, huge(C1), huge(C1) & - , 0.7, 0.7, 0.7, 0.7 & - , 0.1, 0.46, 0.3, 0.3 & ! Land values: 0.46 in ABI CM; 0.2 in ZZ16 - , 2.86, huge(C1), huge(C1), huge(C1) & - , 0.05, 0.1, 0.12, 0.12 & - , 15., 21., 10., 10. & - , 11., 15., 4.5, 4.5 & - , 2.0, 2.0, 2.0, 2.0 & - /), (/ size(eps_zz, 2), size(eps_zz, 1) /)) ) - index_zz = (/1, 2, 3, 4, 5, 6, 7, 9, 10, 12/) - isflgs_zz = (/sea_flag, land_flag, snow_flag, ice_flag/) + eps_clddet = transpose( reshape( (/ & + 3.2, 4.1, big_num, big_num & + , 0.1, 0.3, 0.4, 0.4 & + , 0.8, 2.5, 1.0, 1.0 & + , 1.0, 2.0, 5.0, 5.0 & + , 0.7, 1.0, big_num, big_num & + , 0.7, 0.7, 0.7, 0.7 & + , 0.1, 0.46, 0.3, 0.3 & ! Land values: 0.46 in ABI CM; 0.2 in ZZ16 + , 2.86, big_num, big_num, big_num & + , 0.05, 0.1, 0.12, 0.12 & + , 15., 21., 10., 10. & + , 11., 15., 4.5, 4.5 & + , 2.0, 2.0, 2.0, 2.0 & + /), (/ size(eps_clddet, 2), size(eps_clddet, 1) /)) ) + index_clddet = (/1, 2, 3, 4, 5, 6, 7, 9, 10, 12/) + isflgs_clddet = (/sea_flag, land_flag, snow_flag, ice_flag/) ngood(:) = 0 @@ -128,28 +137,63 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) nrej_land = 0 num_proc_domain = 0 - nrej_zz = 0 + nrej_clddet = 0 tb_ob => ob%instid(i)%tb tb_xb => iv%instid(i)%tb_xb tb_inv => iv%instid(i)%tb_inv + ca_mean => iv%instid(i)%ca_mean + ca_mean = missing_r + + print_cld_debug = .true. + + if ( crtm_cloud ) then + tb_xb_clr => iv%instid(i)%tb_xb_clr + +! if (calc_ir_btlim) then + allocate ( cld_impact (iv%instid(i)%info%n1:iv%instid(i)%info%n2, 1:2) ) + do k = 1, nchan + do n= iv%instid(i)%info%n1,iv%instid(i)%info%n2 + cld_impact(n,1) = tb_xb(k,n) + cld_impact(n,2) = tb_xb_clr(k,n) - tb_xb(k,n) +!JJGDEBUG + if (print_cld_debug) write(*,'(A,2I8,2F12.4)') 'PIXEL_DEBUG97: ', n, k, & + cld_impact(n,1:2) +!JJGDEBUG + + end do + + ! JJG: This is a very rough estimate of BTlim for now + where ( cld_impact(n,2) .ge. 0.1 ) + cld_impact(n,1) = missing_r + end where + BTlim(k) = minval(cld_impact(:,1), cld_impact(:,1).gt.missing_r) + + !Alternatively could sort cld_impact by clr-cld difference, then + ! find median tb_xb at difference of 0.1 (how??) + +!JJGDEBUG + if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG98: ', k, & + BTlim(k) +!JJGDEBUG + + end do + deallocate ( cld_impact ) +! else +! BTlim = 240. +! end if + end if PixelQCLoop: do n= iv%instid(i)%info%n1,iv%instid(i)%info%n2 + if (iv%instid(i)%info%proc_domain(1,n)) & num_proc_domain = num_proc_domain + 1 - if ( crtm_cloud ) then - ! calculate c37_mean - c37_mean = 1.0 - (tb_ob(11,n) - tb_ob(12,n) + & - tb_xb(11,n) - tb_xb(12,n)) / & - (2.0 * (iv%instid(i)%tb_xb_clr(11,n) - iv%instid(i)%tb_xb_clr(12,n))) - end if - ! 0.0 initialise QC by flags assuming good obs !----------------------------------------------------------------- - iv%instid(i)%tb_qc(:,n) = qc_good + tb_qc = qc_good - ! 1.0 reject all channels over mixture surface type + ! 1.0 reject all channels over mixed surface type !------------------------------------------------------ isflg = iv%instid(i)%isflg(n) lmix = (isflg==msea_flag) .or. & @@ -158,15 +202,15 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) (isflg==mice_flag) if (lmix) then - iv%instid(i)%tb_qc(:,n) = qc_bad + tb_qc = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & nrej_mixsurface = nrej_mixsurface + 1 end if if ( isflg .ne. sea_flag ) then - do k = 1, nchan + do k = 1, nchan if ( all(k .ne. (/ 2, 3, 4 /)) .and. only_sea_rad ) then - iv%instid(i)%tb_qc(k,n) = qc_bad + tb_qc(k) = qc_bad nrej_land = nrej_land + 1 end if end do @@ -176,14 +220,14 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !----------------------------------------------------------------- do k = 1, nchan if (satinfo(i)%iuse(k) .eq. -1) & - iv%instid(i)%tb_qc(k,n) = qc_bad + tb_qc(k) = qc_bad end do ! 3.0 check cloud !----------------------------------------------------------------- if (.not. crtm_cloud ) then if (iv%instid(i)%clwp(n) >= 0.2) then - iv%instid(i)%tb_qc(:,n) = qc_bad + tb_qc = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & nrej_clw(:) = nrej_clw(:) + 1 end if @@ -192,13 +236,13 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if (cloud_detection) then if (iv%instid(i)%landsea_mask(n) == 0 ) then if ( ( tb_xb(3,n) - tb_ob(3,n) ) > 3.5) then - iv%instid(i)%tb_qc(:,n) = qc_bad + tb_qc = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & nrej_eccloud(:) = nrej_eccloud(:) + 1 end if else if ( ( tb_xb(3,n) - tb_ob(3,n) ) > 2.5) then - iv%instid(i)%tb_qc(:,n) = qc_bad + tb_qc = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & nrej_eccloud(:) = nrej_eccloud(:) + 1 end if @@ -206,37 +250,42 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) end if end if - clddet_zz: if ( use_clddet_zz .and. all(tb_inv((/1,8,9/),n).gt.missing_r) ) then - !!========================================================================== - !!========================================================================== + abi_clddet: if ( use_clddet_zz .and. all(tb_inv((/1,8,9/),n).gt.missing_r) ) then + !!=============================================================================== + !!=============================================================================== !! - !! 4.0 Zhuge X. and Zou X. JAMC, 2016. [ABI Cloud Mask Algorithm] + !! 4.0 ABI IR-only Cloud Mask Algorithm, combines: + !! (*) Heidinger A. and Straka W., ABI Cloud Mask, version 3.0, 11 JUN, 2013. + !! (*) Zhuge X. and Zou X. JAMC, 2016. !! - !!========================================================================== - !!========================================================================== - -!!JJGDEBUG -!! print_zz = iv%instid(i)%info%proc_domain(1,n) -! print_zz = .true. -! if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG1: ', n, & -! tb_inv(:,n) -! if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG2: ', n, & -! tb_xb(:,n) -! if (print_zz) write(*,'(A,I8,10F12.4)') 'PIXEL_DEBUG3: ', n, & -! tb_ob(:,n) -! -! if (print_zz) write(*,'(A,3I8)') 'PIXEL_DEBUG4: n, n1, n2 = ', & + !!=============================================================================== + !!=============================================================================== + +!JJGDEBUG +! print_cld_debug = iv%instid(i)%info%proc_domain(1,n) + if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG1: ', n, & + tb_inv(:,n) + if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG2: ', n, & + tb_xb(:,n) + if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG3: ', n, & + tb_ob(:,n) + if (crtm_cloud ) then + if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG2: ', n, & + tb_xb_clr(:,n) + end if + +! if (print_cld_debug) write(*,'(A,3I8)') 'PIXEL_DEBUG4: n, n1, n2 = ', & ! n, iv%instid(i)%info%n1, iv%instid(i)%info%n2 -! if (print_zz) write(*,'(A)') 'PIXEL_DEBUG5: n, lat, lon, satzen, satazi, solzen, solazi, tropt, terrain, date = ' -! if (print_zz) write(*,'(A,I8,8F12.4,A)') 'PIXEL_DEBUG6: ', n, & -! iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & -! iv%instid(i)%satzen(n), iv%instid(i)%satazi(n), & -! iv%instid(i)%solzen(n), iv%instid(i)%solazi(n), & -! iv%instid(i)%tropt(n), iv%instid(i)%cld_qc(n)%terr_hgt, & -! iv%instid(i)%info%date_char(n) -!!JJGDEBUG +! if (print_cld_debug) write(*,'(A)') 'PIXEL_DEBUG5: n, lat, lon, satzen, satazi, solzen, solazi, tropt, terrain, date = ' + if (print_cld_debug) write(*,'(A,I8,8F12.4,A)') 'PIXEL_DEBUG6: ', n, & + iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & + iv%instid(i)%satzen(n), iv%instid(i)%satazi(n), & + iv%instid(i)%solzen(n), iv%instid(i)%solazi(n), & + iv%instid(i)%tropt(n), iv%instid(i)%cld_qc(n)%terr_hgt, & + iv%instid(i)%info%date_char(n) +!JJGDEBUG - clddet_zz_tests = 0 + clddet_tests = 0 if ( tb_xb(ch14,n) .gt. 0. .and. iv%instid(i)%tropt(n) .gt. 0. ) then tb_temp1 = tb_ob(ch14,n) @@ -274,53 +323,53 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) rad_b_ch14 = missing_r end if - do itest = 1, num_zz_tests - qual_zz = .true. - offset_zz = 0 - crit_zz = missing_r + tb_qc_clddet = tb_qc + + do itest = 1, num_clddet_tests + qual_clddet = .true. + offset_clddet = 0 + crit_clddet = missing_r select case (itest) case (1) !-------------------------------------------------------------------------- - ! 4.1 Relative Thermal Contrast Test - ! (Zhuge and Zou, 2016, JAMC; TEST1) + ! 4.1 Relative Thermal Contrast Test (RTCT) !-------------------------------------------------------------------------- - crit_zz = iv%instid(i)%cld_qc(n)%RTCT - qual_zz(3:4) = .false. + crit_clddet = iv%instid(i)%cld_qc(n)%RTCT + qual_clddet(3:4) = .false. case (2) !-------------------------------------------------------------------------- ! 4.2 Cloud check: step 1 ! Emissivity at Tropopause Test (ETROP) - ! (Zhuge and Zou, 2016, JAMC; TEST2) !-------------------------------------------------------------------------- if ( tb_xb(ch14,n) .gt. 0. .and. iv%instid(i)%tropt(n) .gt. 0. ) & - crit_zz = (rad_O14 - rad_M14) / (rad_tropt - rad_M14) + crit_clddet = (rad_O14 - rad_M14) / (rad_tropt - rad_M14) case (3) !-------------------------------------------------------------------------- ! 4.3 Cloud check: step 2 - ! Positive Fourteen Minus Fifteen Test - ! (Zhuge and Zou, 2016, JAMC; TEST3) + ! Positive Fourteen Minus Fifteen Test (PFMFT) !-------------------------------------------------------------------------- - qual_zz = tb_xb(ch14,n).ge.tb_xb(ch15,n) + ! See ABI Cloud Mask Description for qual_clddet + qual_clddet = (tb_xb(ch14,n).ge.tb_xb(ch15,n)) if ( (tb_inv(ch14,n) + tb_xb(ch14,n)).le.310. .and. & iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch14).ge.0.3 .and. & tb_ob(ch14,n).gt.0. .and. tb_ob(ch15,n).gt.0. ) & - crit_zz = ( tb_ob(ch14,n) - tb_ob(ch15,n) ) + crit_clddet = ( tb_ob(ch14,n) - tb_ob(ch15,n) ) ! above using ob without VarBC ! ------------------------------- -! crit_zz = (tb_inv(ch14,n) + tb_xb(ch14,n) - & +! crit_clddet = (tb_inv(ch14,n) + tb_xb(ch14,n) - & ! (tb_inv(ch15,n) + tb_xb(ch15,n)) ) ! above using ob with VarBC ! ------------------------------- !JJG: Why does this logical test not use tb_ob(ch14,n)? Something to do with VarBC... - if ( crit_zz.gt.missing_r .and. & + if ( crit_clddet.gt.missing_r .and. & (tb_inv(ch14,n) + tb_xb(ch14,n)).gt.270. .and. & tb_xb(ch14,n).gt.270. ) & - crit_zz = crit_zz - & + crit_clddet = crit_clddet - & (tb_xb(ch14,n) - tb_xb(ch15,n)) * & (tb_ob(ch14,n) - 260.) / (tb_xb(ch14,n) - 260.) ! above 1 line using ob without VarBC @@ -330,37 +379,37 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) case (4) !-------------------------------------------------------------------------- - ! 4.4 Negative Fourteen Minus Fifteen Test - ! (Zhuge and Zou, 2016, JAMC; TEST4) + ! 4.4 Negative Fourteen Minus Fifteen Test (NFMFT) !-------------------------------------------------------------------------- if (tb_ob(ch14,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) & - crit_zz = tb_inv(ch15,n) - tb_inv(ch14,n) + crit_clddet = tb_inv(ch15,n) - tb_inv(ch14,n) case (5) !-------------------------------------------------------------------------- - ! 4.5 Relative Fourteen Minus Fifteen Test - ! (Zhuge and Zou, 2016, JAMC; TEST5) + ! 4.5 Relative Fourteen Minus Fifteen Test (RFMFT) !-------------------------------------------------------------------------- - crit_zz = iv%instid(i)%cld_qc(n)%RFMFT - qual_zz = ( tb_ob(ch14,n) - tb_ob(ch15,n) ) .lt. 1.0 - qual_zz(2) = qual_zz(2) .and. tb_ob(ch14,n) .le. 300. - qual_zz(3:4) = .false. + ! See ABI Cloud Mask Description for qual_clddet + qual_clddet = ( tb_ob(ch14,n) - tb_ob(ch15,n) ) .lt. 1.0 + qual_clddet(2) = qual_clddet(2) .and. tb_ob(ch14,n) .le. 300. + qual_clddet(3:4) = .false. + + crit_clddet = iv%instid(i)%cld_qc(n)%RFMFT case (6) !-------------------------------------------------------------------------- - ! 4.6 Cirrus Water Vapor Test - ! (Zhuge and Zou, 2016, JAMC; TEST6) + ! 4.6 Cirrus Water Vapor Test (CIRH2O) !-------------------------------------------------------------------------- - if ( iv%instid(i)%cld_qc(n)%terr_hgt .le. 2000. .and. & - iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch10) .gt. 0.5 .and. & - iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch14) .gt. 0.5 .and. & - allocated(iv%instid(i)%cld_qc(n)%CIRH2O) ) & - crit_zz = iv%instid(i)%cld_qc(n)%CIRH2O(1,1,1) + ! See ABI Cloud Mask Description for qual_clddet + qual_clddet = & + iv%instid(i)%cld_qc(n)%terr_hgt .le. 2000. & + .and. iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch10) .gt. 0.5 & + .and. iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch14) .gt. 0.5 + if ( allocated(iv%instid(i)%cld_qc(n)%CIRH2O) ) & + crit_clddet = iv%instid(i)%cld_qc(n)%CIRH2O(1,1,1) case (7) !-------------------------------------------------------------------------- - ! 4.7 Modified 4um Emissivity Test - ! (Zhuge and Zou, 2016, JAMC; TEST7, New/Mod TEST1) + ! 4.7 Modified 4um Emissivity Test (M-4EMISS) !-------------------------------------------------------------------------- ! Modify EMISS for sun glint area may be not work, because we are at north land ! - compute relative azimuth @@ -368,71 +417,76 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! - compute glint angle Glintzen = GLINT_ANGLE(iv%instid(i)%solzen(n),iv%instid(i)%satzen(n),Relaz ) -!!JJGDEBUG -! if (print_zz) write(*,"(A)") "PIXEL_DEBUG7: lat, lon, Relaz, Glintzen = " -! if (print_zz) write(*,"(A,4D12.4)") "PIXEL_DEBUG8: ", & -! iv%instid(i)%info%lat(1,n),iv%instid(i)%info%lon(1,n), Relaz, Glintzen -!!JJGDEBUG if ( Glintzen.lt.40.0 .and. isflg==sea_flag) then - crit_zz = - tb_inv(ch7,n) ! (B_ch7 - O_ch7) - offset_zz = 1 + crit_clddet = - tb_inv(ch7,n) ! (B_ch7 - O_ch7) + offset_clddet = 1 else if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) & - crit_zz = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14)/ & + crit_clddet = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14)/ & (rad_b_ch7 / rad_b_ch14) end if case (8) !-------------------------------------------------------------------------- - ! 4.8 Uniform low stratus Test - ! (Zhuge and Zou, 2016, JAMC; TEST8) + ! 4.8 Uniform low stratus Test (ULST) !-------------------------------------------------------------------------- -!JJG: Changed this to solzen instead of solazi for night/day test - qual_zz = iv%instid(i)%solzen(n) >= 85.0 +!JJG, AHI error: Changed this to solzen instead of solazi for night/day test + qual_clddet = iv%instid(i)%solzen(n) >= 85.0 if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) & - crit_zz = rad_b_ch7/rad_b_ch14 - rad_o_ch7/rad_o_ch14 + crit_clddet = rad_b_ch7/rad_b_ch14 - rad_o_ch7/rad_o_ch14 case (9) !-------------------------------------------------------------------------- - ! 4.9 N-OTC Test - ! (Zhuge and Zou, 2016, JAMC; New/Mod TEST3) + ! 4.9 New Optically Thin Cloud Test (N-OTC) !-------------------------------------------------------------------------- -!JJG: Changed this to solzen instead of solazi for night/day test +!JJG, AHI error: Changed this to solzen instead of solazi for night/day test if ( iv%instid(i)%solzen(n) .ge. 85.0 ) & - offset_zz = 1 ! night time + offset_clddet = 1 ! night time if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) & - crit_zz = tb_ob(ch7,n) - tb_ob(ch15,n) + crit_clddet = tb_ob(ch7,n) - tb_ob(ch15,n) ! above using ob without VarBC -! crit_zz = tb_inv(ch7,n) + tb_xb(ch7,n) - & +! crit_clddet = tb_inv(ch7,n) + tb_xb(ch7,n) - & ! (tb_inv(ch15,n) + tb_xb(ch15,n)) ! above using ob with VarBC case (10) !-------------------------------------------------------------------------- - ! 4.10 Temporal Infrared Test - ! (Zhuge and Zou, 2016, JAMC; TEST9) + ! 4.10 Temporal Infrared Test (TEMPIR) !-------------------------------------------------------------------------- - crit_zz = iv%instid(i)%cld_qc(n)%TEMPIR + crit_clddet = iv%instid(i)%cld_qc(n)%TEMPIR case default cycle end select - call evaluate_clddet_test ( crit_names_zz(itest), & - isflg, isflgs_zz, crit_zz, eps_zz(index_zz(itest)+offset_zz,:), qual_zz, & - iv%instid(i)%info%proc_domain(1,n), & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - reject_zz , iv%instid(i)%tb_qc(:,n), nrej_zz(:,itest)) +! call evaluate_clddet_test ( & +! isflg, isflgs_clddet, crit_clddet, eps_clddet(index_clddet(itest)+offset_clddet,:), qual_clddet, & +! iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & +! reject_clddet ) + + reject_clddet = crit_clddet.gt.missing_r .and. & + any( isflg.eq.isflgs_clddet .and. & + crit_clddet.gt.eps_clddet(index_clddet(itest)+offset_clddet,:) .and. & + qual_clddet ) + + if (reject_clddet) then + tb_qc_clddet = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) then + nrej_clddet(:,itest) = nrej_clddet(:,itest) + 1 + write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_clddet, " isflg", isflg, lat,lon + end if - if (reject_zz) clddet_zz_tests(itest) = 1 + clddet_tests(itest) = 1 + end if end do + if (.not. crtm_cloud ) tb_qc = tb_qc_clddet -!!JJGDEBUG -! if (print_zz) write(*,'(A,I8,10I4)') 'PIXEL_DEBUG9: ', n, clddet_zz_tests -!!JJGDEBUG - end if clddet_zz +!JJGDEBUG + if (print_cld_debug) write(*,'(A,I8,10I4)') 'PIXEL_DEBUG9: ', n, clddet_tests +!JJGDEBUG + end if abi_clddet ! --------------------------- ! 5.0 assigning obs errors @@ -446,15 +500,35 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) end if end do ! nchan else !crtm_cloud - ! symmetric error model, Geer and Bauer (2011) + ! calculate ca_mean do k = 1, nchan - if (c37_mean.lt.0.05) then +! ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & +! max( 0., BTlim(k) - tb_ob(k,n) ) ) +! above using ob without VarBC +! ------------------------------- + + ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & + max( 0., BTlim(k) - (tb_inv(k,n) + tb_xb(k,n)) ) ) +! above using ob with VarBC +! ------------------------------- + +!JJGDEBUG + if (print_cld_debug) write(*,'(A,2I8,2F12.4)') 'PIXEL_DEBUG99: ', n, k, & + ca_mean(k,n) +!JJGDEBUG + + end do + + ! symmetric error model, Harnish, Weissmann, & Perianez (2016) + do k = 1, nchan + if ( ca_mean(k,n) .lt. camin ) then iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) - else if (c37_mean.ge.0.05.and.c37_mean.lt.0.5) then + else if ( ca_mean(k,n) .lt. satinfo(i)%error_cld_x(k) ) then iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) + & - (c37_mean - 0.05) * (satinfo(i)%error_cld(k) - satinfo(i)%error_std(k)) / (0.5 - 0.05) + ( satinfo(i)%error_cld_y(k) - satinfo(i)%error_std(k) ) * & + ( ca_mean(k,n) - camin ) / ( satinfo(i)%error_cld_x(k) - camin ) else - iv%instid(i)%tb_error(k,n)= satinfo(i)%error_cld(k) + iv%instid(i)%tb_error(k,n) = satinfo(i)%error_cld_y(k) end if end do ! nchan end if @@ -467,13 +541,15 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) inv_grosscheck = 15.0 if (use_satcv(2)) inv_grosscheck = 100.0 if (abs(tb_inv(k,n)) > inv_grosscheck) then - iv%instid(i)%tb_qc(k,n) = qc_bad + tb_qc(k) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & nrej_omb_abs(k) = nrej_omb_abs(k) + 1 end if end do ! nchan end if + iv%instid(i)%tb_qc(:,n) = tb_qc + do k = 1, nchan ! relative departure check if (abs(tb_inv(k,n)) > 3.0 * iv%instid(i)%tb_error(k,n)) then @@ -492,7 +568,6 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ngood(k) = ngood(k) + 1 end if end do ! nchan - end do PixelQCLoop ! Do inter-processor communication to gather statistics. @@ -501,8 +576,8 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) call da_proc_sum_int (nrej_land) call da_proc_sum_ints (nrej_eccloud) - do itest = 1, num_zz_tests - call da_proc_sum_ints (nrej_zz(:,itest)) + do itest = 1, num_clddet_tests + call da_proc_sum_ints (nrej_clddet(:,itest)) end do call da_proc_sum_ints (nrej_omb_abs) @@ -534,9 +609,9 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) write(fgat_rad_unit,'(a20)') ' nrej_clw(:) = ' write(fgat_rad_unit,'(10i7)') nrej_clw(:) - do itest = 1, num_zz_tests - write(fgat_rad_unit,'(3A)') ' nrej_',trim(crit_names_zz(itest)),'(:) = ' - write(fgat_rad_unit,'(10i8)') nrej_zz(:,itest) + do itest = 1, num_clddet_tests + write(fgat_rad_unit,'(3A)') ' nrej_',trim(crit_names_clddet(itest)),'(:) = ' + write(fgat_rad_unit,'(10i8)') nrej_clddet(:,itest) end do write(fgat_rad_unit,'(a20)') ' nrej_omb_abs(:) = ' @@ -595,29 +670,17 @@ function glint_angle ( sol_zen , sat_zen , rel_az ) end function glint_angle -subroutine evaluate_clddet_test ( crit_name, & - isflg, isflgs, crit_zz, eps, extra_qual, & - on_proc, lat, lon, & - reject_zz , tb_qc, nrej ) - - character(*), intent(in) :: crit_name - integer, intent(in) :: isflg, isflgs(:) - logical, intent(in) :: on_proc - real, intent(in) :: crit_zz, eps(:), lat, lon - logical, intent(in) :: extra_qual(:) - logical, intent(out) :: reject_zz - integer, intent(inout) :: tb_qc(:), nrej(:) - - reject_zz = .false. - reject_zz = crit_zz.gt.missing_r .and. any( isflg.eq.isflgs .and. crit_zz.gt.eps .and. extra_qual ) - - if (reject_zz) then - tb_qc(:) = qc_bad - if (on_proc) then - nrej(:) = nrej(:) + 1 - write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_zz, " isflg", isflg, lat,lon - end if - end if - -end subroutine evaluate_clddet_test +!subroutine evaluate_clddet_test ( isflg, isflgs, crit_clddet, eps, extra_qual, & +! lat, lon, & +! reject_clddet ) +! +! integer, intent(in) :: isflg, isflgs(:) +! real, intent(in) :: crit_clddet, eps(:), lat, lon +! logical, intent(in) :: extra_qual(:) +! logical, intent(out) :: reject_clddet +! +! reject_clddet = .false. +! reject_clddet = crit_clddet.gt.missing_r .and. any( isflg.eq.isflgs .and. crit_clddet.gt.eps .and. extra_qual ) +! +!end subroutine evaluate_clddet_test diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index fb8fbb0d28..ecf35d12b4 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -23,7 +23,8 @@ module da_radiance1 global, gas_constant, gravity, monitor_on,kts,kte,use_rttov_kmatrix, & use_pseudo_rad, pi, t_triple, crtm_cloud, DT_cloud_model,write_jacobian, & use_crtm_kmatrix,use_clddet_mmr, use_clddet_zz, use_satcv, cv_size_domain, & - cv_size_domain_js, calc_weightfunc, use_clddet_ecmwf, deg_to_rad, rad_to_deg + cv_size_domain_js, calc_weightfunc, use_clddet_ecmwf, deg_to_rad, rad_to_deg, & + calc_ir_btlim use da_define_structures, only : info_type,model_loc_type,maxmin_type, & iv_type, y_type, jo_type,bad_data_type,bad_data_type,number_type, & be_type, cld_qc_type diff --git a/var/da/da_radiance/da_radiance_init.inc b/var/da/da_radiance/da_radiance_init.inc index 4522b0d528..3cd0063c31 100644 --- a/var/da/da_radiance/da_radiance_init.inc +++ b/var/da/da_radiance/da_radiance_init.inc @@ -34,7 +34,7 @@ subroutine da_radiance_init(iv,ob) integer :: iunit character(len=filename_len) :: filename character(len=20) :: cdum - real :: error_cld + real :: error_cld_y, error_cld_x ! local variables for tuning error factor !---------------------------------------- @@ -173,10 +173,12 @@ subroutine da_radiance_init(iv,ob) allocate ( satinfo(n) % ichan(nchanl(n)) ) allocate ( satinfo(n) % iuse (nchanl(n)) ) allocate ( satinfo(n) % error(nchanl(n)) ) - allocate ( satinfo(n) % error_cld(nchanl(n)) ) + allocate ( satinfo(n) % error_cld_y(nchanl(n)) ) + allocate ( satinfo(n) % error_cld_x(nchanl(n)) ) allocate ( satinfo(n) % polar(nchanl(n)) ) - satinfo(n) % error_cld(:) = 500.0 !initialize + satinfo(n) % error_cld_y(:) = 500.0 !initialize + satinfo(n) % error_cld_x(:) = 5.0 !initialize read(iunit,*) do j = 1, nchanl(n) @@ -202,10 +204,13 @@ subroutine da_radiance_init(iv,ob) idum, & satinfo(n)%error(j), & satinfo(n)%polar(j), & - error_cld - if ( error_cld > 0.0 ) then - satinfo(n)%error_cld(j) = error_cld - end if + error_cld_y, & + error_cld_x + if ( error_cld_y > 0.0 ) & + satinfo(n)%error_cld_y(j) = error_cld_y + if ( error_cld_x > 0.0 ) & + satinfo(n)%error_cld_x(j) = error_cld_x + end if iv%instid(n)%ichan(j) = satinfo(n)%ichan(j) ob%instid(n)%ichan(j) = satinfo(n)%ichan(j) diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index 4c14d51466..6bc82d16b7 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -18,7 +18,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) character(len=filename_len) :: filename character(len=7) :: surftype integer :: ndomain - logical :: amsr2 + logical :: amsr2, abi real, allocatable :: dtransmt(:,:), transmt_jac(:,:), transmt(:,:), lod(:,:), lod_jac(:,:) @@ -49,6 +49,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) end if amsr2 = index(iv%instid(i)%rttovid_string,'amsr2') > 0 + abi = index(instid(iinst),'abi') > 0 write(unit=filename, fmt='(i2.2,a,i4.4)') it,'_inv_'//trim(iv%instid(i)%rttovid_string)//'.', myproc @@ -147,6 +148,12 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=innov_rad_unit,fmt='(a)') 'QC : ' write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) + if ( abi ) then ! write out ca_mean, tb_xb_clr + write(unit=innov_rad_unit,fmt='(a)') 'CA : ' + write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%ca_mean(:,n) + write(unit=innov_rad_unit,fmt='(a)') 'BGCLR: ' + write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb_clr(:,n) + end if if (write_profile) then nlevelss = iv%instid(i)%nlevels diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index 8f6d5f1bfc..64cb13fbad 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -19,7 +19,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) character(len=filename_len) :: filename character(len=7) :: surftype integer :: ndomain - logical :: amsr2 + logical :: amsr2, abi if (trace_use) call da_trace_entry("da_write_oa_rad_ascii") @@ -40,6 +40,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) if (ndomain < 1) cycle amsr2 = index(iv%instid(i)%rttovid_string,'amsr2') > 0 + abi = index(instid(iinst),'abi') > 0 write(unit=filename, fmt='(i2.2,a,i4.4)') it,'_oma_'//trim(iv%instid(i)%rttovid_string)//'.', myproc @@ -136,6 +137,12 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=oma_rad_unit,fmt='(a)') 'QC : ' write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) + if ( abi ) then ! write out ca_mean, tb_xb_clr + write(unit=oma_rad_unit,fmt='(a)') 'CA : ' + write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%ca_mean(:,n) + write(unit=oma_rad_unit,fmt='(a)') 'BGCLR: ' + write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb_clr(:,n) + end if if (write_profile) then nlevelss = iv%instid(i)%nlevels diff --git a/var/da/da_radiance/module_radiance.f90 b/var/da/da_radiance/module_radiance.f90 index 1195814228..061bb53769 100644 --- a/var/da/da_radiance/module_radiance.f90 +++ b/var/da/da_radiance/module_radiance.f90 @@ -152,7 +152,8 @@ module module_radiance integer, pointer :: ichan(:) ! channel index integer, pointer :: iuse (:) ! usage flag (-1: not use) from radiance info file real , pointer :: error(:) ! error Standard Deviation from radiance info file - real , pointer :: error_cld(:) ! error Standard Deviation for cloudy radiance from radiance info file + real , pointer :: error_cld_y(:) ! error Standard Deviation for cloudy radiance from radiance info file + real , pointer :: error_cld_x(:) ! error Standard Deviation for cloudy radiance from radiance info file real , pointer :: polar(:) ! polarisation (0:ver; 1:hori) from radiance info file real , pointer :: error_factor(:) ! error tuning factor ! from error tuning file ! new air mass bias correction coefs. diff --git a/var/run/radiance_info/gcom-w-1-amsr2.info b/var/run/radiance_info/gcom-w-1-amsr2.info index 0948930bea..72e9a2d6d6 100644 --- a/var/run/radiance_info/gcom-w-1-amsr2.info +++ b/var/run/radiance_info/gcom-w-1-amsr2.info @@ -1,15 +1,15 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) - 478 1 1 -1 0 0.7260000000E+00 0.0000000000E+00 10.14561 - 478 2 1 -1 0 0.9560000000E+00 1.0000000000E+00 18.24548 - 478 3 1 -1 0 0.7750000000E+00 0.0000000000E+00 11.14696 - 478 4 1 -1 0 0.9910000000E+00 1.0000000000E+00 20.18668 - 478 5 1 1 0 0.8660000000E+00 0.0000000000E+00 21.93555 - 478 6 1 1 0 1.1290000000E+00 1.0000000000E+00 40.92418 - 478 7 1 1 0 1.2270000000E+00 0.0000000000E+00 28.30175 - 478 8 1 1 0 1.7470000000E+00 1.0000000000E+00 57.58830 - 478 9 1 1 0 1.6000000000E+00 0.0000000000E+00 12.69287 - 478 10 1 1 0 2.6790000000E+00 1.0000000000E+00 27.33099 - 478 11 1 1 0 1.1790000000E+00 0.0000000000E+00 23.24269 - 478 12 1 1 0 2.2680000000E+00 1.0000000000E+00 53.35099 - 478 13 1 -1 0 2.1310000000E+00 0.0000000000E+00 36.07700 - 478 14 1 -1 0 4.0750000000E+00 1.0000000000E+00 33.61592 + 478 1 1 -1 0 0.7260000000E+00 0.0000000000E+00 10.14561 0.500000 + 478 2 1 -1 0 0.9560000000E+00 1.0000000000E+00 18.24548 0.500000 + 478 3 1 -1 0 0.7750000000E+00 0.0000000000E+00 11.14696 0.500000 + 478 4 1 -1 0 0.9910000000E+00 1.0000000000E+00 20.18668 0.500000 + 478 5 1 1 0 0.8660000000E+00 0.0000000000E+00 21.93555 0.500000 + 478 6 1 1 0 1.1290000000E+00 1.0000000000E+00 40.92418 0.500000 + 478 7 1 1 0 1.2270000000E+00 0.0000000000E+00 28.30175 0.500000 + 478 8 1 1 0 1.7470000000E+00 1.0000000000E+00 57.58830 0.500000 + 478 9 1 1 0 1.6000000000E+00 0.0000000000E+00 12.69287 0.500000 + 478 10 1 1 0 2.6790000000E+00 1.0000000000E+00 27.33099 0.500000 + 478 11 1 1 0 1.1790000000E+00 0.0000000000E+00 23.24269 0.500000 + 478 12 1 1 0 2.2680000000E+00 1.0000000000E+00 53.35099 0.500000 + 478 13 1 -1 0 2.1310000000E+00 0.0000000000E+00 36.07700 0.500000 + 478 14 1 -1 0 4.0750000000E+00 1.0000000000E+00 33.61592 0.500000 diff --git a/var/run/radiance_info/goes-16-abi.info b/var/run/radiance_info/goes-16-abi.info index 61e86f0977..7b618d380b 100644 --- a/var/run/radiance_info/goes-16-abi.info +++ b/var/run/radiance_info/goes-16-abi.info @@ -1,11 +1,11 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) - 1023 1 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 2 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 3 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 4 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 5 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 6 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 7 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 8 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 9 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 10 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 1 1 -1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 2 1 1 0 2.0000000000E+00 0.0000000000E+00 10.00000 9.00000 + 1023 3 1 1 0 2.0000000000E+00 0.0000000000E+00 16.00000 15.00000 + 1023 4 1 1 0 2.0000000000E+00 0.0000000000E+00 21.00000 19.00000 + 1023 5 1 -1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 6 1 -1 0 2.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 7 1 -1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 8 1 -1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 9 1 -1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 10 1 -1 0 2.0000000000E+00 0.0000000000E+00 30.00000 8.00000 From c5ee3fcdb191ab2eda358dfa18c8f3323aae176b Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Mon, 1 Oct 2018 15:07:12 -0600 Subject: [PATCH 20/86] Bug fixes for cloudy radiances from GOESABI Changes to be committed: modified: da_radiance/da_get_innov_vector_crtm.inc modified: da_radiance/da_qc_goesabi.inc modified: da_radiance/da_radiance_init.inc modified: da_radiance/da_write_iv_rad_ascii.inc modified: da_radiance/da_write_oa_rad_ascii.inc --- .../da_radiance/da_get_innov_vector_crtm.inc | 4 +-- var/da/da_radiance/da_qc_goesabi.inc | 27 +++++++++---------- var/da/da_radiance/da_radiance_init.inc | 2 +- var/da/da_radiance/da_write_iv_rad_ascii.inc | 2 +- var/da/da_radiance/da_write_oa_rad_ascii.inc | 2 +- 5 files changed, 17 insertions(+), 20 deletions(-) diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index 435c7cef26..dab1b51615 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -245,8 +245,8 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) calc_tb_clr = .false. if ( crtm_cloud .and. ( & - trim( crtm_sensor_name(rtminit_sensor(inst))) == 'amsr2' - .OR. trim( crtm_sensor_name(rtminit_sensor(inst))) == 'abi' + trim( crtm_sensor_name(rtminit_sensor(inst))) == 'amsr2' & + .OR. trim( crtm_sensor_name(rtminit_sensor(inst))) == 'abi' & ) ) then ! .OR. ( trim( crtm_sensor_name(rtminit_sensor(inst))) == 'abi' .and. calc_ir_btlim ) & diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 7418d6ddfc..789f805ebd 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -157,15 +157,15 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) cld_impact(n,1) = tb_xb(k,n) cld_impact(n,2) = tb_xb_clr(k,n) - tb_xb(k,n) !JJGDEBUG - if (print_cld_debug) write(*,'(A,2I8,2F12.4)') 'PIXEL_DEBUG97: ', n, k, & + if (print_cld_debug) write(*,'(A,2I8,2F12.4)') 'PIXEL_DEBUG91: ', n, k, & cld_impact(n,1:2) !JJGDEBUG end do ! JJG: This is a very rough estimate of BTlim for now - where ( cld_impact(n,2) .ge. 0.1 ) - cld_impact(n,1) = missing_r + where ( cld_impact(:,2) .ge. 0.1 ) + cld_impact(:,1) = missing_r end where BTlim(k) = minval(cld_impact(:,1), cld_impact(:,1).gt.missing_r) @@ -173,7 +173,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! find median tb_xb at difference of 0.1 (how??) !JJGDEBUG - if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG98: ', k, & + if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG92: ', k, & BTlim(k) !JJGDEBUG @@ -263,21 +263,18 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !JJGDEBUG ! print_cld_debug = iv%instid(i)%info%proc_domain(1,n) - if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG1: ', n, & + if (print_cld_debug) write(*,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG1: ', n, & tb_inv(:,n) - if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG2: ', n, & + if (print_cld_debug) write(*,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG2: ', n, & tb_xb(:,n) - if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG3: ', n, & + if (print_cld_debug) write(*,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG3: ', n, & tb_ob(:,n) if (crtm_cloud ) then - if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG2: ', n, & + if (print_cld_debug) write(*,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG4: ', n, & tb_xb_clr(:,n) end if -! if (print_cld_debug) write(*,'(A,3I8)') 'PIXEL_DEBUG4: n, n1, n2 = ', & -! n, iv%instid(i)%info%n1, iv%instid(i)%info%n2 -! if (print_cld_debug) write(*,'(A)') 'PIXEL_DEBUG5: n, lat, lon, satzen, satazi, solzen, solazi, tropt, terrain, date = ' - if (print_cld_debug) write(*,'(A,I8,8F12.4,A)') 'PIXEL_DEBUG6: ', n, & + if (print_cld_debug) write(*,'(A,I8,8F12.4,A)') 'PIXEL_DEBUG5: ', n, & iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & iv%instid(i)%satzen(n), iv%instid(i)%satazi(n), & iv%instid(i)%solzen(n), iv%instid(i)%solazi(n), & @@ -475,7 +472,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) tb_qc_clddet = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) then nrej_clddet(:,itest) = nrej_clddet(:,itest) + 1 - write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_name), crit_clddet, " isflg", isflg, lat,lon + write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_names_clddet(itest)), crit_clddet, " isflg", isflg, iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n) end if clddet_tests(itest) = 1 @@ -484,7 +481,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if (.not. crtm_cloud ) tb_qc = tb_qc_clddet !JJGDEBUG - if (print_cld_debug) write(*,'(A,I8,10I4)') 'PIXEL_DEBUG9: ', n, clddet_tests + if (print_cld_debug) write(*,'(A,I8,*(2x,I1:))') 'PIXEL_DEBUG6: ', n, clddet_tests !JJGDEBUG end if abi_clddet @@ -513,7 +510,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! ------------------------------- !JJGDEBUG - if (print_cld_debug) write(*,'(A,2I8,2F12.4)') 'PIXEL_DEBUG99: ', n, k, & + if (print_cld_debug) write(*,'(A,2I8,2F12.4)') 'PIXEL_DEBUG93: ', n, k, & ca_mean(k,n) !JJGDEBUG diff --git a/var/da/da_radiance/da_radiance_init.inc b/var/da/da_radiance/da_radiance_init.inc index 3cd0063c31..51c17e5e79 100644 --- a/var/da/da_radiance/da_radiance_init.inc +++ b/var/da/da_radiance/da_radiance_init.inc @@ -196,7 +196,7 @@ subroutine da_radiance_init(iv,ob) if ( len_trim(cdum) > 0 .and. index(cdum,'-') == 0 ) then ! read the line again to get error_cld when it is available backspace(iunit) - read(iunit,'(1x,5i5,2e18.10,f10.5)') & + read(iunit,'(1x,5i5,2e18.10,2f10.5)') & wmo_sensor_id, & satinfo(n)%ichan(j), & sensor_type, & diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index 6bc82d16b7..34d68f33b1 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -49,7 +49,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) end if amsr2 = index(iv%instid(i)%rttovid_string,'amsr2') > 0 - abi = index(instid(iinst),'abi') > 0 + abi = index(iv%instid(i)%rttovid_string,'abi') > 0 write(unit=filename, fmt='(i2.2,a,i4.4)') it,'_inv_'//trim(iv%instid(i)%rttovid_string)//'.', myproc diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index 64cb13fbad..8eaa35f351 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -40,7 +40,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) if (ndomain < 1) cycle amsr2 = index(iv%instid(i)%rttovid_string,'amsr2') > 0 - abi = index(instid(iinst),'abi') > 0 + abi = index(iv%instid(i)%rttovid_string,'abi') > 0 write(unit=filename, fmt='(i2.2,a,i4.4)') it,'_oma_'//trim(iv%instid(i)%rttovid_string)//'.', myproc From c4814748ae94c7050fc8fab503334809bc5601f0 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 3 Oct 2018 14:01:48 -0600 Subject: [PATCH 21/86] Fix for GOES meta/grid initialization with multiple fgat times This fix ensures that the metadata and grid for CONUS and Full Disk are only allocated and calculated once. Otherwise a run-time error occurs in 4D HofX. --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 92 +++++++------------- 1 file changed, 30 insertions(+), 62 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index bbc562da14..a14c90b708 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -60,7 +60,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Masks for data reduction -!!! logical :: include_local, load_balance logical :: earthmask, zenmask logical, allocatable :: & earthmask_1d(:) , & @@ -141,6 +140,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) real*8, allocatable :: fgat_time_abs_diff(:,:) ! seconds real*8, allocatable :: min_time_diff(:,:) ! seconds integer, allocatable :: nfiles_used(:) + logical :: meta_initialized = .false. + logical :: grid_initialized = .false. integer :: ny_global, nx_global, yoff_fd, xoff_fd integer :: ys_local, xs_local integer :: ye_local, xe_local @@ -568,7 +569,7 @@ write(stdout,*) trim(command) fname_short = trim(this_view % filename(first_file)) fname = trim(this_view % fpath)//trim(fname_short) - if ( ipass.eq.1 .and. sum(this_view % nfiles_used(:)).eq.0 ) then + if ( .not.this_view % meta_initialized ) then !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Get ABI metadata (first pass for FD, CONUS, MESO) ! Only ny_global and nx_global need to be read for all views, but this is a cheap subroutine @@ -577,6 +578,8 @@ write(stdout,*) trim(command) write(unit=stdout,fmt='(A)') & ' Reading abi metadata...' + this_view % meta_initialized = .true. + call get_abil1b_metadata( & fname, this_view % ny_global, this_view % nx_global, & req, rpol, pph, nam)! , lat_sat, lon_sat ) @@ -609,13 +612,14 @@ write(stdout,*) trim(command) !! + CONUS or FD and first matching fgat !! + MESO and any fgat (extent changes in time) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - DoGridGen: if ( this_view % moving .or. & - ( ipass.eq.1 .and. sum(this_view % nfiles_used(:)).eq.0 ) ) then + DoGridGen: if ( this_view % moving .or. .not.this_view % grid_initialized ) then ! Read grid from file, convert to lat, lon, satzen, satazi write(unit=stdout,fmt='(2A)') & ' Establishing abi grid info...' + this_view % grid_initialized = .true. + !======================================================== ! Establish GOES metadata for this view and ifgat ! (constant acros fgat's, except for this_view % moving) @@ -641,20 +645,15 @@ write(stdout,*) trim(command) ! Create a local array subset of observation location ! quantities across processors. !=========================================================== -!!! load_balance = any(iview.eq.(/1,2/)) -!!! if (load_balance) then -! nrad_local = ny_global * nx_global / num_procs + 1 - nrad_local = ny_global * nx_global / (num_procs-1) -!!! else -!!! nrad_local = this_view % ny_grid(iproc+1) * this_view % nx_grid(iproc+1) -!!! end if - + nrad_local = ny_global * nx_global / (num_procs-1) allocate( yy_1d (nrad_local) ) allocate( xx_1d (nrad_local) ) allocate( iy_1d (nrad_local) ) allocate( ix_1d (nrad_local) ) n = 0 ; icount = 0 + +!JJG: Not convinced that these subgrids are needed. Might be able to loop over global X/Y instead. This solution may be overly complex. mod test for load balancing is still needed! ! This loop over subgrids and the selective logic ! below for myproc balances the processor loads ! when some imager pixels are off-earth or outside @@ -666,16 +665,9 @@ write(stdout,*) trim(command) this_view % ys_local = this_view % ys_grid(subgrid) this_view % xs_local = this_view % xs_grid(subgrid) -!!! !This version of include_local produces unbalanced loads between processors -!!! include_local = ( subgrid-1 .eq. myproc ) - do ixl = 1, nx_local do iyl = 1, ny_local -!!! !This version of include_local produces balanced loads between processors -!!! if (load_balance) & -!!! include_local = ( mod( n, num_procs ) .eq. myproc ) -!!! if ( include_local ) then - + !This mod test produces balanced loads between processors if ( mod( n, num_procs ) .eq. myproc ) then icount = icount + 1 @@ -691,6 +683,21 @@ write(stdout,*) trim(command) end do end do +! !This may work as a simplified replacement for the code above, not sure if loads will be balanced +! do ix = 1, nx_global +! do iy = 1, ny_global +! !This mod test produces balanced loads between processors +! if ( mod( n, num_procs ) .eq. myproc ) then +! icount = icount + 1 +! yy_1d ( icount ) = yy_abi( iy ) +! xx_1d ( icount ) = xx_abi( ix ) +! iy_1d ( icount ) = iy +! ix_1d ( icount ) = ix +! end if +! n = n + 1 +! end do +! end do + nrad_local = icount deallocate( yy_abi, xx_abi ) @@ -1228,9 +1235,9 @@ write(stdout,*) trim(command) ! Only use locations where this view is nearest to this fgat time ! - only available when FD data present for any fgat time if ( use_view_mask ) then - if ( count( view_mask ( this_view % ys_p_fd:this_view % ye_p_fd, & - this_view % xs_p_fd:this_view % xe_p_fd, & - iview, ichan, ifgat ) ) .eq. 0 ) then + if ( .not.any( view_mask ( this_view % ys_p_fd:this_view % ye_p_fd, & + this_view % xs_p_fd:this_view % xe_p_fd, & + iview, ichan, ifgat ) ) ) then deallocate(allmask_p, readmask_p) write(unit=stdout,fmt='(3A,I0)') & @@ -2386,41 +2393,10 @@ subroutine split_grid( ny_global, nx_global, & mm = mm - 1 end do -! Depracated -! if (redist) then -! fact = 4 -! !Redistribute grid from middle to edges to balance load -! ! of calls to da_llxy in get_abil1b_grid -! do i = 1, 2 -! if (mod(ntasks,2).eq.1) then -! ii = ntasks/2+1 -! mm = nvec(ii) / fact -! mm = mm/2 -! nvec(ii) = nvec(ii) - 2*mm -! nvec(ii-1) = nvec(ii-1) + mm -! nvec(ii+1) = nvec(ii+1) + mm -! else -! ii = ntasks/2 -! end if -! do j = ntasks/2, 2, -1 -! mm = nvec(j) / fact -! nvec(j) = nvec(j) - mm -! nvec(j-1) = nvec(j-1) + mm -! end do -! do j = ii+1, ntasks-1 -! mm = nvec(j) / fact -! nvec(j) = nvec(j) - mm -! nvec(j+1) = nvec(j+1) + mm -! end do -! end do -! end if - svec(1) = 1 do j = 1, ntasks -! if (j .eq. 1) evec(1) = nvec(1) !NOT NECESSARY if (j .lt. ntasks) then svec(j+1) = svec(j) + nvec(j) -! evec(j+1) = evec(j) + nvec(j+1) !NOT NECESSARY end if end do end do @@ -2436,14 +2412,6 @@ subroutine split_grid( ny_global, nx_global, & end do end do -! j = myproc / ntasks_x + 1 -! ny_local = ny_grid(j) -! ys_local = ys_grid(j) -! -! i = mod(myproc, ntasks_x) + 1 -! nx_local = nx_grid(i) -! xs_local = xs_grid(i) - end subroutine split_grid #endif From 401260c38b659edd7f3f0a1f48afa0bb809079d9 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 3 Oct 2018 18:23:14 -0600 Subject: [PATCH 22/86] Fix for GOES file counting Changes to be committed: modified: da_radiance/da_read_obs_ncgoesabi.inc --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 33 +++++++++++++++----- 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index a14c90b708..5020ce208b 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -81,7 +81,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !! Iterates integer :: ichan, ifile, iview, ifgat, ipass, ioff, & - jchan, jfile, jview, icount, & + jchan, jfile, jview, icount, io_stat, & n, i, j, iy, ix, jy, jx, iyl, ixl, iyfd, ixfd, iproc, subgrid !! Satellite variables @@ -277,7 +277,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) view_att(3) % name = 'MESO1' view_att(4) % name = 'MESO2' - view_att(1) % fpath = './goes-fd/' + view_att(1) % fpath = './goes-fdisk/' view_att(2) % fpath = './goes-conus/' view_att(3) % fpath = './goes-meso/' view_att(4) % fpath = './goes-meso/' @@ -360,13 +360,30 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) write(stdout,*) trim(command) call execute_command_line (trim(command)) - write(command,fmt='(4A)') "cat ",trim(list_file)," | wc -l > ",trim(count_file) -write(stdout,*) trim(command) - call execute_command_line (trim(command)) - - open(unit=file_unit,file=trim(count_file)) - read(file_unit,*) this_view % nfiles + icount = 0 + io_stat = -1 + do while (io_stat .ne. 0) + open(unit=file_unit,file=trim(list_file), iostat = io_stat) + icount = icount + 1 + if (icount .gt. 1000) exit + end do + this_view % nfiles = 0 + do + read(file_unit, fmt=*, iostat = io_stat) +! if ( io_stat .lt. 0 ) exit +! if ( io_stat .gt. 0 ) do something else + if ( io_stat .ne. 0 ) exit + this_view % nfiles = this_view % nfiles + 1 + end do close(file_unit) + +! write(command,fmt='(4A)') "cat ",trim(list_file)," | wc -l > ",trim(count_file) +!write(stdout,*) trim(command) +! call execute_command_line (trim(command)) +! +! open(unit=file_unit,file=trim(count_file)) +! read(file_unit,*) this_view % nfiles +! close(file_unit) i_dummy = this_view % nfiles end if #ifdef DM_PARALLEL From 914e61036a798a62170570defeada2189d84b418 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Fri, 5 Oct 2018 15:08:36 -0600 Subject: [PATCH 23/86] Added GOES-16 to VARBC.in and turned on all channels in goes-16-abi.info --- var/run/VARBC.in | 21 ++++++++++++++++++++- var/run/radiance_info/goes-16-abi.info | 14 +++++++------- 2 files changed, 27 insertions(+), 8 deletions(-) diff --git a/var/run/VARBC.in b/var/run/VARBC.in index 04012015dd..9a23a7076d 100644 --- a/var/run/VARBC.in +++ b/var/run/VARBC.in @@ -1,5 +1,5 @@ VARBC version 1.0 - Number of instruments: - 37 + 38 ------------------------------------------------ Platform_id Sat_id Sensor_id Nchanl Npredmax ------------------------------------------------ @@ -2184,3 +2184,22 @@ 2 3 1 1 1 1 1 -1 -1 -1 3.628 -0.025 0.107 0.022 0.238 3 4 1 1 1 1 1 -1 -1 -1 -0.443 0.329 -0.067 -0.454 0.448 4 6 1 1 1 1 1 -1 -1 -1 -0.605 0.202 -0.073 -0.160 0.511 + ------------------------------------------------ + Platform_id Sat_id Sensor_id Nchanl Npredmax + ------------------------------------------------ + 4 16 44 10 8 + -----> Bias predictor statistics: Mean & Std & Nbgerr + 1.0 9530.5 8287.5 297.4 41.0 41.4 1748.5 75128.1 + 0.0 141.9 183.8 5.4 9.8 5.7 473.1 29900.1 + 10000 10000 10000 10000 10000 10000 10000 10000 + -----> Chanl_id Chanl_nb Pred_use(-1/0/1) Param + 1 1 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 2 2 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 3 3 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 4 4 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 5 5 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 6 6 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 7 7 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 8 8 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 9 9 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 10 10 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 diff --git a/var/run/radiance_info/goes-16-abi.info b/var/run/radiance_info/goes-16-abi.info index 7b618d380b..d8592695b5 100644 --- a/var/run/radiance_info/goes-16-abi.info +++ b/var/run/radiance_info/goes-16-abi.info @@ -1,11 +1,11 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) - 1023 1 1 -1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 1 1 1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 1023 2 1 1 0 2.0000000000E+00 0.0000000000E+00 10.00000 9.00000 1023 3 1 1 0 2.0000000000E+00 0.0000000000E+00 16.00000 15.00000 1023 4 1 1 0 2.0000000000E+00 0.0000000000E+00 21.00000 19.00000 - 1023 5 1 -1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 6 1 -1 0 2.0000000000E+00 0.0000000000E+00 30.00000 8.00000 - 1023 7 1 -1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 8 1 -1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 9 1 -1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 10 1 -1 0 2.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 5 1 1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 6 1 1 0 2.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 7 1 1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 8 1 1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 9 1 1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 10 1 1 0 2.0000000000E+00 0.0000000000E+00 30.00000 8.00000 From 162c2917fa3e942cc26a06b626d7349c34c62ce4 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Tue, 9 Oct 2018 15:54:57 -0600 Subject: [PATCH 24/86] Bug fix for GOES ABI readmask to make generalizable to cases when DQF differs between channels --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 25 ++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 5020ce208b..c85f44832f 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -1293,13 +1293,14 @@ write(stdout,*) trim(command) do jfile = 1, this_view % nfiles if ( this_view % filechan(jfile) .ne. channel_list(ichan) ) cycle - obs_time = this_view % filedate(jfile) % obs_time - TEMPIR_time_abs_diff = & abs( this_view % filedate(jfile) % obs_time / 60.D0 - & (this_view % filedate(ifile) % obs_time / 60.D0 - TEMPIR_delay_minutes) ) - if ( TEMPIR_time_abs_diff .lt. TEMPIR_min_time_diff ) TEMPIR_ifile = jfile + if ( TEMPIR_time_abs_diff .lt. TEMPIR_min_time_diff ) then + TEMPIR_ifile = jfile + TEMPIR_min_time_diff = TEMPIR_time_abs_diff + end if end do end if @@ -1321,7 +1322,13 @@ write(stdout,*) trim(command) this_view % xs_local, this_view % xe_local, & readmask_p, bt_p(:,:,1), inst, ichan ) - allmask_p = (allmask_p .and. readmask_p) + !JJG: It is possible for readmask_p to differ across channels. + ! readmask_p needs to be incorporated, but presently causes error between channel reading + ! when lining up channels to identical members of linked p list. + ! Fixing this will require moving away from linked list including the readmask_p quality + ! flag in the datalink_type. + ! Presently readmask_p is used internally within get_abil1b_bt to set bt_p=missing_r (works fine) + !allmask_p = (allmask_p .and. readmask_p) if ( TEMPIR_ifile.gt.0 ) then fname_short = trim(this_view % filename(TEMPIR_ifile)) @@ -1330,6 +1337,16 @@ write(stdout,*) trim(command) this_view % ys_local, this_view % ye_local, & this_view % xs_local, this_view % xe_local, & readmask_p, bt_p(:,:,2), inst, ichan ) + + yr = this_view % filedate(TEMPIR_ifile) % yr + mt = this_view % filedate(TEMPIR_ifile) % mt + dy = this_view % filedate(TEMPIR_ifile) % dy + hr = this_view % filedate(TEMPIR_ifile) % hr + mn = this_view % filedate(TEMPIR_ifile) % mn + sc = this_view % filedate(TEMPIR_ifile) % sc + write(unit=stdout, & + fmt='(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & + ' TEMPIR time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc end if first_chan = (this_view % nfiles_used(ifgat).eq.1) From d29a128c22f3bf3cca04c36a0de47ea454ded42c Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Tue, 9 Oct 2018 16:52:20 -0600 Subject: [PATCH 25/86] Bugfixes for GOES ABI: 1) QC for missing_r values of bt_p 2) find both link and file types for ABI nc files in any directory with goes-${view}* prefix 3) fix TEMPIR minimum time diff update 4) Handle case when no GOES ABI views have data for any FGAT times 5) Handle case when < 10 channels have low data quality flag (some channels good, some bad) 6) OMB and OMA reading/writing logic for ABI cloudy radiances 7) Set initial goes-16 and goes-17 variances to large values in order to calculate statistics on larger data set 8) Temporary ca_mean and BTlim calculation for gathering cloudy radiance statistics --- var/da/da_monitor/da_rad_diags.f90 | 8 +- var/da/da_radiance/da_qc_goesabi.inc | 141 ++++++++--- var/da/da_radiance/da_radiance1.f90 | 14 +- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 235 +++++++++++-------- var/da/da_radiance/da_write_iv_rad_ascii.inc | 2 +- var/da/da_radiance/da_write_oa_rad_ascii.inc | 2 +- var/run/radiance_info/goes-16-abi.info | 20 +- var/run/radiance_info/goes-17-abi.info | 20 +- 8 files changed, 286 insertions(+), 156 deletions(-) diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index 96a0fa3c51..7235562f17 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -380,12 +380,12 @@ program da_rad_diags read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_err(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! QC read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_qc(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf - if ( abi ) then ! read ca_mean, tb_bak_clr - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CA + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CA or INFO or level + if ( abi .and. buf(1:2) == "CA" ) then ! read ca_mean, tb_bak_clr for abi read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) ca_mean(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! BGCLR + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! BGCLR read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_bak_clr(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! INFO or level end if if ( buf(1:4) == "INFO" ) then backspace(iunit(iproc)) diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 789f805ebd..3d96ed6ac1 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -39,8 +39,9 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) logical :: print_cld_debug !! Additional variables used by Harnish, Weissmann, & Perianez (2016) - real :: BTlim(nchan) - real, allocatable :: cld_impact(:,:) + real :: BTlim(nchan), BTlim_temp + real, allocatable :: cld_impact(:,:), cld_impact_global(:,:), weights_global(:) + integer :: buf_i, buf_f, nbuf, nlocal, nglobal, iproc real, parameter :: camin = 0.0 !! Additional variables used by Zhuge and Zou (2017) @@ -82,6 +83,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if (trace_use) call da_trace_entry("da_qc_goesabi") +!! if (iv%instid(i)%num_rad .le. 0) return ! These values can change as SRF (spectral response function) is updated ! It is recommended to acquire these from L1B files, not copy them from GOES R PUG L1b Vol. 3 @@ -142,8 +144,6 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) tb_ob => ob%instid(i)%tb tb_xb => iv%instid(i)%tb_xb tb_inv => iv%instid(i)%tb_inv - ca_mean => iv%instid(i)%ca_mean - ca_mean = missing_r print_cld_debug = .true. @@ -152,33 +152,98 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! if (calc_ir_btlim) then allocate ( cld_impact (iv%instid(i)%info%n1:iv%instid(i)%info%n2, 1:2) ) + cld_impact = missing_r + BTlim = missing_r + nlocal = iv%instid(i)%info%n2 - iv%instid(i)%info%n1 + 1 +#ifdef DM_PARALLEL + call mpi_allreduce( nlocal, nglobal, 1, mpi_integer, mpi_sum, comm, ierr ) +#else + nglobal = nlocal +#endif + allocate(cld_impact_global(nglobal, 1:2)) + allocate(weights_global(nglobal)) + do k = 1, nchan do n= iv%instid(i)%info%n1,iv%instid(i)%info%n2 - cld_impact(n,1) = tb_xb(k,n) - cld_impact(n,2) = tb_xb_clr(k,n) - tb_xb(k,n) + if ( .true. & + .and. tb_inv( k, n ) .gt. missing_r & + .and. tb_ob( k, n ) .gt. 0. & + .and. tb_xb( k, n ) .gt. 0. & + ) then + + cld_impact(n,1) = tb_xb(k,n) + cld_impact(n,2) = tb_xb_clr(k,n) - tb_xb(k,n) !JJGDEBUG - if (print_cld_debug) write(*,'(A,2I8,2F12.4)') 'PIXEL_DEBUG91: ', n, k, & - cld_impact(n,1:2) + if (print_cld_debug) write(stdout,'(A,2I8,2F16.8,6(2x,A))') 'PIXEL_DEBUG91: ', n, k, & + cld_impact(n,1:2), & + iv%instid(i)%info%date_char(n)(1:4), & + iv%instid(i)%info%date_char(n)(6:7), & + iv%instid(i)%info%date_char(n)(9:10), & + iv%instid(i)%info%date_char(n)(12:13), & + iv%instid(i)%info%date_char(n)(15:16), & + iv%instid(i)%info%date_char(n)(18:19) +! iv%instid(i)%info%date_char(n) + !JJGDEBUG + end if end do + buf_f = 0 + ProcLoop: do iproc = 0, num_procs-1 + nbuf = nlocal +#ifdef DM_PARALLEL + call mpi_bcast(nbuf, 1, mpi_integer, iproc, comm, ierr ) +#endif + if (nbuf .eq. 0) cycle + buf_i = buf_f + 1 + buf_f = buf_i + nbuf - 1 + + if (iproc .eq. myproc) then + cld_impact_global(buf_i:buf_f,:) = cld_impact(:,:) + else + cld_impact_global(buf_i:buf_f,:) = missing_r + end if + call mpi_bcast(cld_impact_global(buf_i:buf_f,:), nbuf * 2, true_mpi_real, iproc, comm, ierr ) + end do ProcLoop + + ! JJG: This is a very rough estimate of BTlim for now - where ( cld_impact(:,2) .ge. 0.1 ) - cld_impact(:,1) = missing_r +! where ( cld_impact_global(:,2) .ge. 0.1 ) !Really need to do this offline with stats from multiple days... + where ( cld_impact_global(:,2) .le. 0.00001 .or. cld_impact_global(:,2) .ge. 0.2 ) + cld_impact_global(:,1) = missing_r end where - BTlim(k) = minval(cld_impact(:,1), cld_impact(:,1).gt.missing_r) + +! BTlim_temp = sum(cld_impact_global(:,1), cld_impact_global(:,1).gt.missing_r) / & +! count(cld_impact_global(:,1).gt.missing_r) + + where ( cld_impact_global(:,1).gt.missing_r ) + weights_global = 1. - abs(cld_impact_global(:,2) - 0.1) + elsewhere + weights_global = missing_r + end where + BTlim_temp = sum(cld_impact_global(:,1) * weights_global, cld_impact_global(:,1).gt.missing_r) / & + sum(weights_global, cld_impact_global(:,1).gt.missing_r) + +! BTlim_temp = minval(cld_impact_global(:,1), cld_impact_global(:,1).gt.missing_r) + if ( BTlim_temp.eq.BTlim_temp ) then + if ( BTlim_temp .gt. 0 ) BTlim(k) = BTlim_temp + end if +!Really need to do this offline with stats from multiple days...BTlim will be a lookup table across channels. !Alternatively could sort cld_impact by clr-cld difference, then ! find median tb_xb at difference of 0.1 (how??) !JJGDEBUG - if (print_cld_debug) write(*,'(A,I8,F12.4)') 'PIXEL_DEBUG92: ', k, & + if (print_cld_debug) write(stdout,'(A,I8,F12.4)') 'PIXEL_DEBUG92: ', k, & BTlim(k) !JJGDEBUG end do deallocate ( cld_impact ) + deallocate ( cld_impact_global ) + deallocate ( weights_global ) + ! else ! BTlim = 240. ! end if @@ -250,7 +315,11 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) end if end if - abi_clddet: if ( use_clddet_zz .and. all(tb_inv((/1,8,9/),n).gt.missing_r) ) then + abi_clddet: if ( use_clddet_zz & + .and. all(tb_inv( (/ch7,ch14,ch15/), n ) .gt. missing_r) & + .and. all(tb_ob( (/ch7,ch14,ch15/), n ) .gt. missing_r) & + .and. all(tb_xb( (/ch7,ch14,ch15/), n ) .gt. missing_r) & + ) then !!=============================================================================== !!=============================================================================== !! @@ -263,18 +332,18 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !JJGDEBUG ! print_cld_debug = iv%instid(i)%info%proc_domain(1,n) - if (print_cld_debug) write(*,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG1: ', n, & + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG1: ', n, & tb_inv(:,n) - if (print_cld_debug) write(*,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG2: ', n, & + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG2: ', n, & tb_xb(:,n) - if (print_cld_debug) write(*,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG3: ', n, & + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG3: ', n, & tb_ob(:,n) if (crtm_cloud ) then - if (print_cld_debug) write(*,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG4: ', n, & + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG4: ', n, & tb_xb_clr(:,n) end if - if (print_cld_debug) write(*,'(A,I8,8F12.4,A)') 'PIXEL_DEBUG5: ', n, & + if (print_cld_debug) write(stdout,'(A,I8,8F12.4,2x,A)') 'PIXEL_DEBUG5: ', n, & iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & iv%instid(i)%satzen(n), iv%instid(i)%satazi(n), & iv%instid(i)%solzen(n), iv%instid(i)%solazi(n), & @@ -442,11 +511,14 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) offset_clddet = 1 ! night time if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) & +! using ob without VarBC +! ------------------------------- crit_clddet = tb_ob(ch7,n) - tb_ob(ch15,n) -! above using ob without VarBC + +! using ob with VarBC +! ------------------------------- ! crit_clddet = tb_inv(ch7,n) + tb_xb(ch7,n) - & ! (tb_inv(ch15,n) + tb_xb(ch15,n)) -! above using ob with VarBC case (10) !-------------------------------------------------------------------------- @@ -472,7 +544,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) tb_qc_clddet = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) then nrej_clddet(:,itest) = nrej_clddet(:,itest) + 1 - write(*,"(A,F14.6,A,I4,2D12.4)") trim(crit_names_clddet(itest)), crit_clddet, " isflg", isflg, iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n) + write(stdout,"(A,F14.6,A,I4,2D12.4)") trim(crit_names_clddet(itest)), crit_clddet, " isflg", isflg, iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n) end if clddet_tests(itest) = 1 @@ -481,7 +553,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if (.not. crtm_cloud ) tb_qc = tb_qc_clddet !JJGDEBUG - if (print_cld_debug) write(*,'(A,I8,*(2x,I1:))') 'PIXEL_DEBUG6: ', n, clddet_tests + if (print_cld_debug) write(stdout,'(A,I8,*(2x,I1:))') 'PIXEL_DEBUG6: ', n, clddet_tests !JJGDEBUG end if abi_clddet @@ -498,19 +570,28 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) end do ! nchan else !crtm_cloud ! calculate ca_mean + ca_mean => iv%instid(i)%ca_mean + ca_mean = missing_r do k = 1, nchan -! ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & -! max( 0., BTlim(k) - tb_ob(k,n) ) ) -! above using ob without VarBC + if ( .true. & + .and. tb_inv( k, n ) .gt. missing_r & + .and. tb_ob( k, n ) .gt. 0. & + .and. tb_xb( k, n ) .gt. 0. & + .and. BTlim(k) .gt. 0. & + ) then + +! using ob without VarBC ! ------------------------------- +! ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & +! max( 0., BTlim(k) - tb_ob(k,n) ) ) - ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & - max( 0., BTlim(k) - (tb_inv(k,n) + tb_xb(k,n)) ) ) ! above using ob with VarBC ! ------------------------------- - + ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & + max( 0., BTlim(k) - (tb_inv(k,n) + tb_xb(k,n)) ) ) + end if !JJGDEBUG - if (print_cld_debug) write(*,'(A,2I8,2F12.4)') 'PIXEL_DEBUG93: ', n, k, & + if (print_cld_debug) write(stdout,'(A,2I8,2F16.8)') 'PIXEL_DEBUG93: ', n, k, & ca_mean(k,n) !JJGDEBUG @@ -518,7 +599,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! symmetric error model, Harnish, Weissmann, & Perianez (2016) do k = 1, nchan - if ( ca_mean(k,n) .lt. camin ) then + if ( ca_mean(k,n).lt.camin .and. ca_mean(k,n).gt.missing_r ) then iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) else if ( ca_mean(k,n) .lt. satinfo(i)%error_cld_x(k) ) then iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) + & diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index ecf35d12b4..a8989f074c 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -24,12 +24,16 @@ module da_radiance1 use_pseudo_rad, pi, t_triple, crtm_cloud, DT_cloud_model,write_jacobian, & use_crtm_kmatrix,use_clddet_mmr, use_clddet_zz, use_satcv, cv_size_domain, & cv_size_domain_js, calc_weightfunc, use_clddet_ecmwf, deg_to_rad, rad_to_deg, & - calc_ir_btlim + calc_ir_btlim, comm, ierr use da_define_structures, only : info_type,model_loc_type,maxmin_type, & iv_type, y_type, jo_type,bad_data_type,bad_data_type,number_type, & be_type, cld_qc_type use module_dm, only : wrf_dm_sum_real, wrf_dm_sum_integer - use da_par_util, only : da_proc_stats_combine +#ifdef DM_PARALLEL + use da_par_util, only : da_proc_stats_combine, true_mpi_real +#else + use da_par_util, only : da_proc_stats_combine +#endif use da_par_util1, only : da_proc_sum_int,da_proc_sum_ints use da_reporting, only : da_error, message use da_statistics, only : da_stats_calculate @@ -44,7 +48,11 @@ module da_radiance1 #endif implicit none - + +#ifdef DM_PARALLEL + include 'mpif.h' +#endif + type datalink_type type (info_type) :: info diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index c85f44832f..735482c430 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -90,13 +90,15 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer, parameter :: platform_id = 4 ! GOES series integer, parameter :: sensor_id = 44 ! ABI integer, parameter :: channel_list(nchan) = (/7,8,9,10,11,12,13,14,15,16/) !List of all available channels +! integer, parameter :: channel_index(channel_list(1):channel_list(nchan)) = (/1,2,3,4,5,6,7,8,9,10/) !List of all available channels + integer, parameter :: nviews=4 integer(i_kind) :: inst character(len=14), parameter :: INST_PREFIX = 'OR_ABI-L1b-Rad' !! File reading variables - character(len=1000) :: fname, fname_short, command - character(len=50) :: list_file, count_file + character(len=1000) :: fname, command !, fname_short + character(len=50) :: list_file integer :: file_unit type date_type @@ -175,7 +177,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !! WRFDA channel and satellite_id select !! These should be inputs to the subroutine or global variables in WRFDA !Could populate using .info file. Would reduce number of files to read... - integer, dimension(10) :: channel_select = (/7, 8, 9, 10, 11, 12, 13, 14, 15, 16/) +! integer, dimension(10) :: channel_select = (/7, 8, 9, 10, 11, 12, 13, 14, 15, 16/) ! Global WRFDA obs timing info character(len=19) :: fgat_times_c(num_fgat_time) @@ -277,10 +279,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) view_att(3) % name = 'MESO1' view_att(4) % name = 'MESO2' - view_att(1) % fpath = './goes-fdisk/' - view_att(2) % fpath = './goes-conus/' - view_att(3) % fpath = './goes-meso/' - view_att(4) % fpath = './goes-meso/' + view_att(1) % fpath = "./goes-fdisk*/" + view_att(2) % fpath = "./goes-conus*/" + view_att(3) % fpath = "./goes-meso*/" + view_att(4) % fpath = "./goes-meso*/" ! (default) Full Disk and CONUS are fixed while MESO 1 & 2 can move within an assimilation window view_att(1) % moving = .false. @@ -346,19 +348,20 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Query fpath for files that begin with INST_PREFIX, name, and for this satellite_id fname = trim(INST_PREFIX)//trim(this_view % name_short) - list_file = 'INST'//trim(this_view % name_short) - count_file = 'num_INST'//trim(this_view % name_short) + list_file = 'INST'//trim(this_view % name_short) call da_get_unit(file_unit) if (rootproc) then write(command,fmt='(5A,I2.2,2A)')& "find ",trim(this_view % fpath), & - " -type f -name '",trim(fname), & + " \( -type l -o -type f \) -name '",trim(fname), & "*G",satellite_id, & "*' -printf '%P\n' > ",trim(list_file) -write(stdout,*) trim(command) - call execute_command_line (trim(command)) +! "*' > ",trim(list_file) + +write(stdout,fmt='(A)') adjustl(trim(command)) + call execute_command_line (adjustl(trim(command))) icount = 0 io_stat = -1 @@ -370,20 +373,11 @@ write(stdout,*) trim(command) this_view % nfiles = 0 do read(file_unit, fmt=*, iostat = io_stat) -! if ( io_stat .lt. 0 ) exit -! if ( io_stat .gt. 0 ) do something else if ( io_stat .ne. 0 ) exit this_view % nfiles = this_view % nfiles + 1 end do close(file_unit) -! write(command,fmt='(4A)') "cat ",trim(list_file)," | wc -l > ",trim(count_file) -!write(stdout,*) trim(command) -! call execute_command_line (trim(command)) -! -! open(unit=file_unit,file=trim(count_file)) -! read(file_unit,*) this_view % nfiles -! close(file_unit) i_dummy = this_view % nfiles end if #ifdef DM_PARALLEL @@ -434,11 +428,17 @@ write(stdout,*) trim(command) do ifile = 1, this_view % nfiles + + !Grab the filename (without path) using INST_PREFIX + fname = trim(this_view % filename(ifile)) + ioff = index(fname, trim(INST_PREFIX)) +!! this_view % filepath(ifile) = fname(1:ioff-1) + fname = trim(fname(ioff:len(adjustl(trim(fname))))) +!! this_view % filename(ifile) = trim(fname) + ioff = 0 if (iview.eq.3 .or. iview.eq.4) ioff=1 ioff = ioff+19 - fname = trim(this_view % filename(ifile)) - read(fname(1+ioff:2+ioff),fmt='(I2.2)') this_view % filechan(ifile) !!! !! The channel could instead be read from band_id in each file, but @@ -449,10 +449,9 @@ write(stdout,*) trim(command) !!! ierr=nf_close(ncid) ! Check if channel is selected - if ( .not.any(this_view % filechan(ifile) .eq. channel_select) .or. & - .not.any(this_view % filechan(ifile) .eq. channel_list) ) then +! if ( .not.any(this_view % filechan(ifile) .eq. channel_select) .or. & + if ( .not.any(this_view % filechan(ifile) .eq. channel_list) ) then !!! ierr=nf_close(ncid) -!!! this_view % file_fgat_match(ifile,:) = .false. cycle end if @@ -464,9 +463,13 @@ write(stdout,*) trim(command) read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc + obs_time = real(sc,8)/60.D0 / 2.D0 + call jday2cal(jdy, yr, mt, dy) call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(1)) + this_view % filedate(ifile) % jdy = jdy + !obs END time ioff = ioff + 16 read(fname(1+ioff:4+ioff),fmt='(I4.4)') yr @@ -474,11 +477,12 @@ write(stdout,*) trim(command) read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc + obs_time = obs_time + real(sc,8)/60.D0 / 2.D0 + call jday2cal(jdy, yr, mt, dy) call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(2)) - obs_time=(timbdy(1) + timbdy(2)) / 2.D0 - obs_time = obs_time + real(sc,8)/60.D0 + obs_time = obs_time + (timbdy(1) + timbdy(2)) / 2.D0 !! The time it takes to read time_bounds from each file is not insignificant. Above method is much faster. ! !! Determine central date of this file for obs binning @@ -497,9 +501,10 @@ write(stdout,*) trim(command) this_view % filedate(ifile) % hr = hr this_view % filedate(ifile) % mn = mn this_view % filedate(ifile) % sc = sc - this_view % filedate(ifile) % jdy = jdy this_view % filedate(ifile) % obs_time = obs_time + +!JJG: Note that this test being limited by time_slots prevents the use of data before/after the first/last time of the window even if the observations outside the window were recorded at times nearer to those bounds than data contained within the window. if ( obs_time < time_slots(0) * 60.D0 .or. & obs_time >= time_slots(num_fgat_time) * 60.D0 ) then cycle @@ -541,9 +546,9 @@ write(stdout,*) trim(command) this_view % nfiles_used = 0 - do ifgat = 1, num_fgat_time + fgat_loop: do ifgat = 1, num_fgat_time if (count(this_view % file_fgat_match(:, ifgat)) .lt. 1) then - cycle + cycle fgat_loop end if if ( ipass .eq. 1 .and. count(this_view % file_fgat_match(:, ifgat)).gt.1 ) then @@ -564,7 +569,7 @@ write(stdout,*) trim(command) first_file = ifile exit end do - if (first_file .eq. 0) cycle + if (first_file .eq. 0) cycle fgat_loop if ( sum(this_view % nfiles_used(:)).eq.0) & write(unit=stdout,fmt='(A,I0,2A)') & @@ -583,8 +588,8 @@ write(stdout,*) trim(command) fmt='(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & ' data time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc - fname_short = trim(this_view % filename(first_file)) - fname = trim(this_view % fpath)//trim(fname_short) + fname = trim(this_view % filename(first_file)) +! fname = trim(this_view % fpath)//trim(fname_short) if ( .not.this_view % meta_initialized ) then !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1289,19 +1294,46 @@ write(stdout,*) trim(command) TEMPIR_ifile = -1 if ( use_clddet_zz .and. channel_list(ichan).eq.14 ) then ! Require earlier file to be withn 1/2 of TEMPIR_delay_minutes - TEMPIR_min_time_diff = 0.5 * TEMPIR_delay_minutes + TEMPIR_min_time_diff = TEMPIR_delay_minutes +!write(unit=stdout,fmt='(A,F14.2)') & +! ' ref_time (min): ', this_view % filedate(ifile) % obs_time / 60.D0 - TEMPIR_delay_minutes do jfile = 1, this_view % nfiles - if ( this_view % filechan(jfile) .ne. channel_list(ichan) ) cycle + if ( this_view % filechan(jfile) .ne. channel_list(ichan) .or. & + jfile .eq. ifile ) cycle TEMPIR_time_abs_diff = & abs( this_view % filedate(jfile) % obs_time / 60.D0 - & (this_view % filedate(ifile) % obs_time / 60.D0 - TEMPIR_delay_minutes) ) +! yr = this_view % filedate(jfile) % yr +! mt = this_view % filedate(jfile) % mt +! dy = this_view % filedate(jfile) % dy +! hr = this_view % filedate(jfile) % hr +! mn = this_view % filedate(jfile) % mn +! sc = this_view % filedate(jfile) % sc +! write(unit=stdout, & +! fmt='(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & +! ' this_time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc +! +!write(unit=stdout,fmt='(A,F14.2)') & +! ' this_time (min): ', this_view % filedate(jfile) % obs_time / 60.D0 +! +! write(unit=stdout,fmt='(A,F7.2,A)') & +! ' TEMPIR: time difference - ',TEMPIR_time_abs_diff,' minutes' + if ( TEMPIR_time_abs_diff .lt. TEMPIR_min_time_diff ) then TEMPIR_ifile = jfile TEMPIR_min_time_diff = TEMPIR_time_abs_diff end if end do + if ( TEMPIR_min_time_diff .gt. 0.5 * TEMPIR_delay_minutes ) then + write(unit=stdout,fmt='(A,F7.2,A)') & + ' TEMPIR: minimum time difference is too large - ',TEMPIR_min_time_diff,' minutes' + TEMPIR_ifile = -1 + else + write(unit=stdout,fmt='(A,F7.2,A)') & + ' TEMPIR: minimum time difference is accetable - ',TEMPIR_min_time_diff,' minutes' + end if end if ! Allocate and read bt for this patch and current time @@ -1315,8 +1347,8 @@ write(stdout,*) trim(command) this_view % xs_local:this_view % xe_local, 1 ) ) end if - fname_short = trim(this_view % filename(ifile)) - fname = trim(this_view % fpath)//trim(fname_short) + fname = trim(this_view % filename(ifile)) +! fname = trim(this_view % fpath)//trim(fname_short) call get_abil1b_bt( fname, & this_view % ys_local, this_view % ye_local, & this_view % xs_local, this_view % xe_local, & @@ -1331,8 +1363,8 @@ write(stdout,*) trim(command) !allmask_p = (allmask_p .and. readmask_p) if ( TEMPIR_ifile.gt.0 ) then - fname_short = trim(this_view % filename(TEMPIR_ifile)) - fname = trim(this_view % fpath)//trim(fname_short) + fname = trim(this_view % filename(TEMPIR_ifile)) +! fname = trim(this_view % fpath)//trim(fname_short) call get_abil1b_bt( fname, & this_view % ys_local, this_view % ye_local, & this_view % xs_local, this_view % xe_local, & @@ -1463,59 +1495,71 @@ write(stdout,*) trim(command) p % ifgat = ifgat end if - ! Transfer BT from all files + ! Exctract this BT value for each channel p % tb_inv(ichan) = bt_p( iy, ix, 1 ) - ! Extract values from cloud QC buffer + + ! Preprocessing for Cloud Mask (da_qc_goesabi.inc) including + ! extracting Tb values from cloud QC buffer if (.not. associated(p % cld_qc)) then allocate( p % cld_qc ) allocate( p % cld_qc % tb_stddev_3x3(nchan) ) end if tbuf = 1 - if (cld_qc_buffer.ge.tbuf) then + if (cld_qc_buffer.ge.tbuf .and. p % tb_inv(ichan).gt.missing_r) then nkeep = count ( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r ) - allocate( tb_temp ( nkeep, 1 ) ) - tb_temp(:,1) = pack( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ), & - bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r) - mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) - sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) - deallocate( tb_temp ) - - p % cld_qc % tb_stddev_3x3(ichan) = sigma + if (nkeep .gt. 0) then + allocate( tb_temp ( nkeep, 1 ) ) + tb_temp(:,1) = pack( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ), & + bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r) + mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) + deallocate( tb_temp ) + p % cld_qc % tb_stddev_3x3(ichan) = sigma + else + p % cld_qc % tb_stddev_3x3(ichan) = missing_r + end if if (channel_list(ichan).eq.14) then if ( allocated(terrain_hgt) ) then ! Determine sigma_z of terrain height across these pixels - nkeep = count ( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r ) - allocate( tb_temp ( nkeep, 1 ) ) - tb_temp(:,1) = pack( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ), & - terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r) - mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) - sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) - deallocate( tb_temp ) - p % cld_qc % terr_hgt = terrain_hgt( iy, ix ) p % info % elv = p % cld_qc % terr_hgt - ! Values for RTCT cloud QC - ! - channel 14 and sigma_z (std. dev. of terrain height in km) - ! w/ landmask and lapse rate of 7 K km^-1 - - temp_max = 0. - do jy = iy-tbuf, iy+tbuf - do jx = ix-tbuf, ix+tbuf - if ( bt_p( jy, jx, 1) .gt. 0. ) & - temp_max = max(temp_max,bt_p( jy, jx, 1 ) ) - end do - end do - - ! Store RTCT and diagnostic terrain height - p % cld_qc % RTCT = temp_max - p % tb_inv(ichan) - & - 3.0_r_double * 0.007_r_double * sigma - + nkeep = count ( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r ) + if (nkeep .gt. 0) then + allocate( tb_temp ( nkeep, 1 ) ) + tb_temp(:,1) = pack( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ), & + terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r) + mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) + deallocate( tb_temp ) + + ! Values for RTCT cloud QC + ! - channel 14 and sigma_z (std. dev. of terrain height in km) + ! w/ landmask and lapse rate of 7 K km^-1 + + temp_max = 0. + do jy = iy-tbuf, iy+tbuf + do jx = ix-tbuf, ix+tbuf + if ( bt_p( jy, jx, 1) .gt. 0. ) & + temp_max = max(temp_max,bt_p( jy, jx, 1 ) ) + end do + end do + + if (temp_max .gt. missing_r) then + ! Store RTCT + p % cld_qc % RTCT = temp_max - p % tb_inv(ichan) - & + 3.0_r_double * 0.007_r_double * sigma + else + p % cld_qc % RTCT = missing_r + end if + else + p % cld_qc % RTCT = missing_r + end if else p % cld_qc % RTCT = missing_r p % cld_qc % terr_hgt = missing_r @@ -1533,7 +1577,7 @@ write(stdout,*) trim(command) ! Values for RFMFT cloud QC ! - channels 14 and 15 tbuf = 10 - if (cld_qc_buffer.ge.tbuf) then + if (cld_qc_buffer.ge.tbuf .and. p % tb_inv(ichan).gt.missing_r) then if (channel_list(ichan).eq.14) then !Determine Neighboring Warm Center (NWC) for this pixel temp_max = 0. @@ -1551,28 +1595,28 @@ write(stdout,*) trim(command) p % cld_qc % RFMFT = & p % tb_inv(ichan) - temp_max end if - if (channel_list(ichan).eq.15) then + if (channel_list(ichan).eq.15 .and. all(p % cld_qc % RFMFT_ij.gt.0)) then temp_max = bt_p ( p % cld_qc % RFMFT_ij(1), & p % cld_qc % RFMFT_ij(2), 1 ) p % cld_qc % RFMFT = abs( p % cld_qc % RFMFT + & temp_max - p % tb_inv(ichan) ) end if else - if (channel_list(ichan).eq.15) then - p % cld_qc % RFMFT = missing_r - p % cld_qc % RFMFT_ij = -1 + if ( any( channel_list(ichan).eq.(/14,15/) ) ) then + p % cld_qc % RFMFT = missing_r + p % cld_qc % RFMFT_ij = -1 end if end if ! Values for CIRH2O cloud QC ! - channels 10 and 14 for Pearson correlation coefficient of CIRH2O test tbuf = 2 - if (cld_qc_buffer.ge.tbuf) then + if (cld_qc_buffer.ge.tbuf .and. p % tb_inv(ichan).gt.missing_r) then if (channel_list(ichan).eq.10) then allocate( p % cld_qc % CIRH2O ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 2 ) ) p % cld_qc % CIRH2O(:,:,1) = bt_p( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) end if - if (channel_list(ichan).eq.14) then + if (channel_list(ichan).eq.14 .and. size(p % cld_qc % CIRH2O).gt.1) then p % cld_qc % CIRH2O(:,:,2) = bt_p( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) nkeep = 0 do jy = iy-tbuf, iy+tbuf @@ -1605,7 +1649,8 @@ write(stdout,*) trim(command) p % cld_qc % CIRH2O (1,1,1) = pearson end if else - if (channel_list(ichan).eq.14) then + if ( any( channel_list(ichan).eq.(/10,14/) ) ) then + if ( allocated( p % cld_qc % CIRH2O ) ) deallocate( p % cld_qc % CIRH2O) allocate( p % cld_qc % CIRH2O (1,1,1)) p % cld_qc % CIRH2O = missing_r end if @@ -1613,17 +1658,13 @@ write(stdout,*) trim(command) ! Values for TEMPIR cloud QC ! - channel 14 - if ( use_clddet_zz ) then - if ( TEMPIR_ifile.gt.0 ) then - if ( bt_p( iy, ix, 2 ) .lt. 330. ) then + if ( use_clddet_zz .and. (channel_list(ichan).eq.14) ) then + p % cld_qc % TEMPIR = missing_r + if ( TEMPIR_ifile.gt.0 .and. & + p % tb_inv(ichan).gt.missing_r ) then + if ( bt_p( iy, ix, 2 ).lt.330. ) & p % cld_qc % TEMPIR = bt_p( iy, ix, 2 ) - bt_p( iy, ix, 1 ) - else - p % cld_qc % TEMPIR = missing_r - end if end if - else - if (channel_list(ichan).eq.14) & - p % cld_qc % TEMPIR = missing_r end if if (first_chan) & @@ -1649,7 +1690,7 @@ write(stdout,*) trim(command) call mpi_barrier(comm, ierr) #endif - end do ! end fgat loop + end do fgat_loop ! end fgat loop if ( (this_view % moving .or. ipass.eq.npass) .and. this_view%nrad_on_patch.gt.0 ) then ! Deallocate location info @@ -1681,10 +1722,10 @@ write(stdout,*) trim(command) deallocate ( this_view % fgat_time_abs_diff ) deallocate ( this_view % min_time_diff ) deallocate ( this_view % nfiles_used ) - deallocate ( this_view % ny_grid ) - deallocate ( this_view % nx_grid ) - deallocate ( this_view % ys_grid ) - deallocate ( this_view % xs_grid ) + if ( allocated( this_view % ny_grid ) ) deallocate ( this_view % ny_grid ) + if ( allocated( this_view % nx_grid ) ) deallocate ( this_view % nx_grid ) + if ( allocated( this_view % ys_grid ) ) deallocate ( this_view % ys_grid ) + if ( allocated( this_view % xs_grid ) ) deallocate ( this_view % xs_grid ) end do deallocate(view_att) diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index 34d68f33b1..30a80b0bc1 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -148,7 +148,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=innov_rad_unit,fmt='(a)') 'QC : ' write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) - if ( abi ) then ! write out ca_mean, tb_xb_clr + if ( abi .and. crtm_cloud ) then ! write out ca_mean, tb_xb_clr write(unit=innov_rad_unit,fmt='(a)') 'CA : ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%ca_mean(:,n) write(unit=innov_rad_unit,fmt='(a)') 'BGCLR: ' diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index 8eaa35f351..191d62d72f 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -137,7 +137,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=oma_rad_unit,fmt='(a)') 'QC : ' write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) - if ( abi ) then ! write out ca_mean, tb_xb_clr + if ( abi .and. crtm_cloud ) then ! write out ca_mean, tb_xb_clr write(unit=oma_rad_unit,fmt='(a)') 'CA : ' write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%ca_mean(:,n) write(unit=oma_rad_unit,fmt='(a)') 'BGCLR: ' diff --git a/var/run/radiance_info/goes-16-abi.info b/var/run/radiance_info/goes-16-abi.info index d8592695b5..ad646d9ce6 100644 --- a/var/run/radiance_info/goes-16-abi.info +++ b/var/run/radiance_info/goes-16-abi.info @@ -1,11 +1,11 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) - 1023 1 1 1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 2 1 1 0 2.0000000000E+00 0.0000000000E+00 10.00000 9.00000 - 1023 3 1 1 0 2.0000000000E+00 0.0000000000E+00 16.00000 15.00000 - 1023 4 1 1 0 2.0000000000E+00 0.0000000000E+00 21.00000 19.00000 - 1023 5 1 1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 6 1 1 0 2.0000000000E+00 0.0000000000E+00 30.00000 8.00000 - 1023 7 1 1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 8 1 1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 9 1 1 0 2.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 10 1 1 0 2.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 1 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 2 1 1 0 5.0000000000E+00 0.0000000000E+00 10.00000 9.00000 + 1023 3 1 1 0 5.0000000000E+00 0.0000000000E+00 16.00000 15.00000 + 1023 4 1 1 0 5.0000000000E+00 0.0000000000E+00 21.00000 19.00000 + 1023 5 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 6 1 1 0 10.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 7 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 8 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 9 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 10 1 1 0 5.0000000000E+00 0.0000000000E+00 30.00000 8.00000 diff --git a/var/run/radiance_info/goes-17-abi.info b/var/run/radiance_info/goes-17-abi.info index 61e86f0977..ad646d9ce6 100644 --- a/var/run/radiance_info/goes-17-abi.info +++ b/var/run/radiance_info/goes-17-abi.info @@ -1,11 +1,11 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) - 1023 1 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 2 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 3 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 4 1 1 0 2.0000000000E+00 0.0000000000E+00 - 1023 5 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 6 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 7 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 8 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 9 1 -1 0 2.0000000000E+00 0.0000000000E+00 - 1023 10 1 -1 0 2.0000000000E+00 0.0000000000E+00 + 1023 1 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 2 1 1 0 5.0000000000E+00 0.0000000000E+00 10.00000 9.00000 + 1023 3 1 1 0 5.0000000000E+00 0.0000000000E+00 16.00000 15.00000 + 1023 4 1 1 0 5.0000000000E+00 0.0000000000E+00 21.00000 19.00000 + 1023 5 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 6 1 1 0 10.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 7 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 8 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 9 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 10 1 1 0 5.0000000000E+00 0.0000000000E+00 30.00000 8.00000 From 116cccd5929f6599d5903d24c2d30727ef7d2fc8 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Fri, 12 Oct 2018 16:44:59 -0600 Subject: [PATCH 26/86] Bug fix on find for files of GOESABI --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 735482c430..03868db544 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -357,8 +357,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) "find ",trim(this_view % fpath), & " \( -type l -o -type f \) -name '",trim(fname), & "*G",satellite_id, & - "*' -printf '%P\n' > ",trim(list_file) -! "*' > ",trim(list_file) + "*' > ",trim(list_file) +! "*' -printf '%P\n' > ",trim(list_file) write(stdout,fmt='(A)') adjustl(trim(command)) call execute_command_line (adjustl(trim(command))) From 4b6d3b48b75db7e4acac78a30cf017474cade8fe Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Tue, 30 Oct 2018 11:35:58 -0600 Subject: [PATCH 27/86] Corrected initial values for mean and std of VARBC parameters of G16 --- var/run/VARBC.in | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/var/run/VARBC.in b/var/run/VARBC.in index 9a23a7076d..79972afdab 100644 --- a/var/run/VARBC.in +++ b/var/run/VARBC.in @@ -2189,17 +2189,17 @@ ------------------------------------------------ 4 16 44 10 8 -----> Bias predictor statistics: Mean & Std & Nbgerr - 1.0 9530.5 8287.5 297.4 41.0 41.4 1748.5 75128.1 - 0.0 141.9 183.8 5.4 9.8 5.7 473.1 29900.1 + 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 + 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 10000 10000 10000 10000 10000 10000 10000 10000 -----> Chanl_id Chanl_nb Pred_use(-1/0/1) Param 1 1 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 2 2 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 3 3 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 4 4 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 5 5 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 6 6 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 7 7 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 8 8 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 9 9 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 10 10 1 1 1 1 1 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 2 2 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 3 3 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 4 4 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 5 5 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 6 6 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 7 7 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 8 8 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 9 9 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 10 10 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 From 6a715de3894ff25ac067f34508026df63b62e446 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Thu, 8 Nov 2018 13:57:43 -0700 Subject: [PATCH 28/86] Add 1D domain check to reduce time for processing prepbufr files in in da_read_obs_bufr In my experience, this modification reduced the time to process a single BUFR file from 13 minutes to less than 20 seconds. There is some memory overhead, but it does not appear to be a limiting factor even with 36 processors per node. Additional distribution of work could be accomplished if there prove to be memory limits, which is given as a NOTE in da_read_obs_bufr.inc. Changes to be committed: modified: da_obs_io/da_obs_io.f90 modified: da_obs_io/da_read_obs_bufr.inc modified: da_tools/da_llxy_1d.inc --- var/da/da_obs_io/da_obs_io.f90 | 2 +- var/da/da_obs_io/da_read_obs_bufr.inc | 181 ++++++++++++++++++++++---- var/da/da_tools/da_llxy_1d.inc | 4 +- 3 files changed, 160 insertions(+), 27 deletions(-) diff --git a/var/da/da_obs_io/da_obs_io.f90 b/var/da/da_obs_io/da_obs_io.f90 index b12f5aed36..66e3f3bf4a 100644 --- a/var/da/da_obs_io/da_obs_io.f90 +++ b/var/da/da_obs_io/da_obs_io.f90 @@ -43,7 +43,7 @@ module da_obs_io use da_par_util1, only : da_proc_sum_int use da_physics, only : da_tp_to_qs use da_reporting, only : da_warning, message, da_error - use da_tools, only : da_llxy, da_get_julian_time, da_geo2msl1, da_msl2geo1 + use da_tools, only : da_llxy, da_llxy_1d, da_get_julian_time, da_geo2msl1, da_msl2geo1 use da_tools_serial, only : da_free_unit, da_get_unit, da_advance_time use da_tracing, only : da_trace_entry, da_trace_exit diff --git a/var/da/da_obs_io/da_read_obs_bufr.inc b/var/da/da_obs_io/da_read_obs_bufr.inc index f7b1539c15..1916d5a316 100644 --- a/var/da/da_obs_io/da_read_obs_bufr.inc +++ b/var/da/da_obs_io/da_read_obs_bufr.inc @@ -94,6 +94,11 @@ subroutine da_read_obs_bufr (iv) type(datalink_BUFR),pointer :: head=>null(), plink=>null() + integer :: num_subset, isubset + type (info_type), allocatable :: info_1d(:) + type (model_loc_type), allocatable :: loc_1d(:) + logical, allocatable :: outside_1d(:), outside_all_1d(:) + if (trace_use) call da_trace_entry("da_read_obs_bufr") ! 0.0 Initialize variables @@ -199,6 +204,130 @@ bufrfile: do ibufr=1,numbufr cycle bufrfile end if end if + + hdstr='SID XOB YOB DHR TYP ELV T29' + obstr='POB QOB TOB ZOB UOB VOB PWO CAT' ! observation + qmstr='PQM QQM TQM ZQM WQM NUL PWQ NUL' ! quality marker + oestr='POE QOE TOE NUL WOE NUL PWE NUL' ! observation error + pcstr='PPC QPC TPC ZPC WPC NUL PWP NUL' ! program code + +! 2.1 read data +! Initialize outside_all_1d array for all subsets simultaneously (vectorizes up llxy call) +!-------------------------------------------------------------- + call openbf(iunit,'IN',iunit) + call datelen(10) + + call readns(iunit,subset,idate,iret) ! read in the next subset + if ( iret /= 0 ) then + write(unit=message(1),fmt='(A,I5,A)') & + "Error",iret," reading PREPBUFR obs file "//trim(filename) + call da_warning(__FILE__,__LINE__,message(1:1)) + call closbf(iunit) + if (trace_use) call da_trace_exit("da_read_obs_bufr") + return + end if + !rewind(iunit) + + write(unit=message(1),fmt='(a,i10)') 'BUFR file date is: ', idate +! write(unit=message(2),fmt='(a)') 'Step 1: Parsing file for num_subsets' +! call da_message(message(1:2)) + + num_subset = 0 + subsets0: do + num_subset = num_subset + 1 !increment num_subset for every call to readns + + call readns(iunit,subset,idate,iret) ! read in the next subset + if ( iret /= 0 ) then + write(unit=message(1),fmt='(A,I3,A,I3)') & + "return code from readns",iret, & + "reach the end of PREPBUFR obs unit",iunit + !call da_warning(__FILE__,__LINE__,message(1:1)) + exit subsets0 + end if + end do subsets0 + call closbf(iunit) + close(iunit) + +! write(unit=message(1),fmt='(a,I10)') 'Step 2: Parsing subsets for lat, lon; num_subset = ', num_subset +! call da_message(message(1:1)) + + open(unit = iunit, FILE = trim(filename), & + iostat = iost, form = 'unformatted', STATUS = 'OLD') + call openbf(iunit,'IN',iunit) + call datelen(10) + + call readns(iunit,subset,idate,iret) ! read in the next subset + if ( iret /= 0 ) then + write(unit=message(1),fmt='(A,I5,A)') & + "Error",iret," reading PREPBUFR obs file "//trim(filename) + call da_warning(__FILE__,__LINE__,message(1:1)) + call closbf(iunit) + if (trace_use) call da_trace_exit("da_read_obs_bufr") + return + end if + !rewind(iunit) + + isubset = 0 + + allocate ( info_1d (num_subset) ) + allocate ( loc_1d (num_subset) ) + allocate ( outside_1d (num_subset) ) + allocate ( outside_all_1d (num_subset) ) + + subsets: do + isubset = isubset + 1 !increment isubset for every call to readns + + call ufbint(iunit,hdr,7,1,iret2,hdstr) + + r8sid = hdr(1) + info_1d (isubset) % id(1:5) = csid(1:5) + info_1d (isubset) % id(6:40) = ' ' + info_1d (isubset) % lon = hdr(2) + info_1d (isubset) % lat = hdr(3) + + call readns(iunit,subset,idate,iret) ! read in the next subset + if ( iret /= 0 ) then + write(unit=message(1),fmt='(A,I3,A,I3)') & + "return code from readns",iret, & + "reach the end of PREPBUFR obs unit",iunit + !call da_warning(__FILE__,__LINE__,message(1:1)) + exit subsets + end if + end do subsets + + ! blacklisted stations should be handled through an external table. + ! For now, temporary fix is implemented here for known incorrect + ! station info in NCEP PREPBUFR file + where ( (info_1d % id(1:4)) == 'BGQQ' ) + info_1d % lon = -69.21 + info_1d % lat = 77.46 + end where + where ( (info_1d % id(1:4)) == 'UWKE' ) + info_1d % lon = 52.09 + info_1d % lat = 55.56 + end where + + ! Put a check on Lon and Lat + where ( info_1d (:) % lon >= 180.0 ) info_1d (:) % lon = info_1d (:) % lon - 360.0 + where ( info_1d (:) % lat < -89.95 ) info_1d (:) % lat = -89.95 + where ( info_1d (:) % lat > 89.95 ) info_1d (:) % lat = 89.95 + + +! write(unit=message(1),fmt='(a)') 'Step 3: Determining outside_1d, outside_all_1d' +! call da_message(message(1:1)) + + !JJG, NOTE: This llxy work/memory could also be divided amongst processors by assigning a subgroup of the subsets to each process. + ! Ultimately all subsets that are .not.outside_all need to have outside_1d and loc_1d values populated on + ! all processors. This procedure is shown in da_read_obs_ncgoesabi with two calls to da_llxy_1d and + ! communications in between those two calls. + + call da_llxy_1d (info_1d, loc_1d, outside_1d, outside_all_1d) + + call closbf(iunit) + close(iunit) + open(unit = iunit, FILE = trim(filename), & + iostat = iost, form = 'unformatted', STATUS = 'OLD') + ! open observation error table if provided. call da_get_unit(junit) open (unit=junit, file='obs_errtable', form='formatted', status='old', & @@ -223,11 +352,8 @@ bufrfile: do ibufr=1,numbufr end do read_loop end if - hdstr='SID XOB YOB DHR TYP ELV T29' - obstr='POB QOB TOB ZOB UOB VOB PWO CAT' ! observation - qmstr='PQM QQM TQM ZQM WQM NUL PWQ NUL' ! quality marker - oestr='POE QOE TOE NUL WOE NUL PWE NUL' ! observation error - pcstr='PPC QPC TPC ZPC WPC NUL PWP NUL' ! program code +! write(unit=message(1),fmt='(a)') 'Step 4: Reading domain-specific data' +! call da_message(message(1:1)) call openbf(iunit,'IN',iunit) call datelen(10) @@ -243,11 +369,7 @@ bufrfile: do ibufr=1,numbufr end if !rewind(iunit) - write(unit=message(1),fmt='(a,i10)') 'BUFR file date is: ', idate - call da_message(message(1:1)) - - -! 2.0 read data +! 2.1 read data ! scan reports first !-------------------------------------------------------------- @@ -255,10 +377,14 @@ bufrfile: do ibufr=1,numbufr end_of_file = .false. outside_all = .false. outside_time = .false. + isubset = 1 + reports: do while ( .not. end_of_file ) if ( match .or. outside_all .or. outside_time ) then call readns(iunit,subset,idate,iret) ! read in the next subset + isubset = isubset + 1 !increment isubset for every call to readns + if ( iret /= 0 ) then write(unit=message(1),fmt='(A,I3,A,I3)') & "return code from readns",iret, & @@ -270,6 +396,17 @@ bufrfile: do ibufr=1,numbufr num_report = num_report+1 + outside_all = outside_all_1d(isubset) + if (outside_all) then + num_outside_all = num_outside_all + 1 + if ( print_detail_obs ) then + write(unit=stderr,fmt='(a,1x,a,2(1x,f8.3),a)') & + platform%info%name(1:8),platform%info%id(1:5), & + platform%info%lat, platform%info%lon, ' -> outside_domain' + end if + cycle reports + end if + call ufbint(iunit,hdr,7,1,iret2,hdstr) call ufbint(iunit,pmo,2,1,nlevels,'PMO PMQ') call ufbint(iunit,qms,8,255,nlevels,qmstr) @@ -315,17 +452,9 @@ bufrfile: do ibufr=1,numbufr if (num_report < report_start) cycle reports if (num_report > report_end) exit reports - call da_llxy (platform%info, platform%loc,outside, outside_all) - - if (outside_all) then - num_outside_all = num_outside_all + 1 - if ( print_detail_obs ) then - write(unit=stderr,fmt='(a,1x,a,2(1x,f8.3),a)') & - platform%info%name(1:8),platform%info%id(1:5), & - platform%info%lat, platform%info%lon, ' -> outside_domain' - end if - cycle reports - end if + outside = outside_1d(isubset) + platform%loc = loc_1d(isubset) + !platform%info = info_1d(isubset) ! check date write(cdate,'(i10)') idate @@ -396,6 +525,7 @@ bufrfile: do ibufr=1,numbufr if ( iret /= 0 ) then end_of_file = .true. else + isubset = isubset + 1 !increment isubset for every call to readns match_check: do call ufbint(iunit,hdr2,7,1,iret2,hdstr) ! check if this subset and the previous one are matching mass and wind @@ -1149,6 +1279,11 @@ if ( use_errtable ) then call da_free_unit(junit) end if + deallocate ( outside_1d ) + deallocate ( outside_all_1d ) + deallocate ( info_1d ) + deallocate ( loc_1d ) + end do bufrfile @@ -1157,7 +1292,6 @@ end do bufrfile !-------------------------------------------------------------- if (num_fgat_time > 1 ) then - do kk=1,num_fgat_time if ( thin_conv ) then do n = 1, num_ob_indexes @@ -1181,7 +1315,6 @@ end do bufrfile if (dlon_earth >= 360.0) dlon_earth = dlon_earth - 360.0 dlat_earth = dlat_earth * deg2rad dlon_earth = dlon_earth * deg2rad - call da_llxy (plink%platform_BUFR%info, plink%platform_BUFR%loc,outside, outside_all) ! Loop over duplicating obs for global ndup = 1 @@ -1578,7 +1711,7 @@ end if if (dlon_earth >= 360.0) dlon_earth = dlon_earth - 360.0 dlat_earth = dlat_earth * deg2rad dlon_earth = dlon_earth * deg2rad - call da_llxy (plink%platform_BUFR%info, plink%platform_BUFR%loc,outside, outside_all) + ndup = 1 if (global .and. & (plink%platform_BUFR%loc%i < ids .or. plink%platform_BUFR%loc%i >= ide)) ndup= 2 diff --git a/var/da/da_tools/da_llxy_1d.inc b/var/da/da_tools/da_llxy_1d.inc index 06f42d115d..0752830bc3 100644 --- a/var/da/da_tools/da_llxy_1d.inc +++ b/var/da/da_tools/da_llxy_1d.inc @@ -2,8 +2,8 @@ subroutine da_llxy_1d ( infos, locs, outside, outside_all, do_xy, do_outside) !----------------------------------------------------------------------- ! Purpose: TBD - ! Updated for Analysis on Arakawa-C grid - ! Author: Syed RH Rizvi, MMM/ESSL/NCAR, Date: 10/22/2008 + ! Author: JJ Guerrette, MMM/NCAR, Date: 05/23/2018 + ! Modified from da_llxy, including child subroutines !----------------------------------------------------------------------- ! This routine converts (lat, lon) into (x,y) coordinates From 548ee4ad1ef70a5cddc1c36242e36c557cd2899f Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Mon, 19 Nov 2018 16:42:50 -0700 Subject: [PATCH 29/86] Bug fixing and cleanup for llxy_1d in da_read_obs_bufr.inc --- var/da/da_obs_io/da_read_obs_bufr.inc | 159 ++++++++++---------------- 1 file changed, 62 insertions(+), 97 deletions(-) diff --git a/var/da/da_obs_io/da_read_obs_bufr.inc b/var/da/da_obs_io/da_read_obs_bufr.inc index 1916d5a316..8dcfb59c85 100644 --- a/var/da/da_obs_io/da_read_obs_bufr.inc +++ b/var/da/da_obs_io/da_read_obs_bufr.inc @@ -89,12 +89,13 @@ subroutine da_read_obs_bufr (iv) integer :: nlevels_BUFR integer :: kx_BUFR real :: pco_BUFR(8,255) + logical :: outside type(datalink_BUFR), pointer :: next end type datalink_BUFR type(datalink_BUFR),pointer :: head=>null(), plink=>null() - integer :: num_subset, isubset + integer :: isubset type (info_type), allocatable :: info_1d(:) type (model_loc_type), allocatable :: loc_1d(:) logical, allocatable :: outside_1d(:), outside_all_1d(:) @@ -211,9 +212,11 @@ bufrfile: do ibufr=1,numbufr oestr='POE QOE TOE NUL WOE NUL PWE NUL' ! observation error pcstr='PPC QPC TPC ZPC WPC NUL PWP NUL' ! program code -! 2.1 read data -! Initialize outside_all_1d array for all subsets simultaneously (vectorizes up llxy call) -!-------------------------------------------------------------- + +! 2.1.1 Initialize 1d arrays (loc, outside, outside_all) from da_llxy_1d +! (single vectorized call is much faster than >10^5 calls to subroutine) +!------------------------------------------------------------------------- + call openbf(iunit,'IN',iunit) call datelen(10) @@ -229,27 +232,27 @@ bufrfile: do ibufr=1,numbufr !rewind(iunit) write(unit=message(1),fmt='(a,i10)') 'BUFR file date is: ', idate -! write(unit=message(2),fmt='(a)') 'Step 1: Parsing file for num_subsets' -! call da_message(message(1:2)) - num_subset = 0 - subsets0: do - num_subset = num_subset + 1 !increment num_subset for every call to readns +! 2.1.1 Parse file for number of subsets +!-------------------------------------------------------------- + + isubset = 0 + do while (iret == 0) + isubset = isubset + 1 !increment isubset for every call to readns call readns(iunit,subset,idate,iret) ! read in the next subset - if ( iret /= 0 ) then - write(unit=message(1),fmt='(A,I3,A,I3)') & - "return code from readns",iret, & - "reach the end of PREPBUFR obs unit",iunit - !call da_warning(__FILE__,__LINE__,message(1:1)) - exit subsets0 - end if - end do subsets0 + end do call closbf(iunit) close(iunit) -! write(unit=message(1),fmt='(a,I10)') 'Step 2: Parsing subsets for lat, lon; num_subset = ', num_subset -! call da_message(message(1:1)) + allocate ( info_1d (isubset) ) + allocate ( loc_1d (isubset) ) + allocate ( outside_1d (isubset) ) + allocate ( outside_all_1d (isubset) ) + + +! 2.2.1 Parse subsets for lat, lon + other info variables +!-------------------------------------------------------------- open(unit = iunit, FILE = trim(filename), & iostat = iost, form = 'unformatted', STATUS = 'OLD') @@ -268,41 +271,36 @@ bufrfile: do ibufr=1,numbufr !rewind(iunit) isubset = 0 - - allocate ( info_1d (num_subset) ) - allocate ( loc_1d (num_subset) ) - allocate ( outside_1d (num_subset) ) - allocate ( outside_all_1d (num_subset) ) - - subsets: do + do while (iret == 0 ) isubset = isubset + 1 !increment isubset for every call to readns call ufbint(iunit,hdr,7,1,iret2,hdstr) r8sid = hdr(1) + info_1d (isubset) % name(1:8) = subset + info_1d (isubset) % name(9:40) = ' ' info_1d (isubset) % id(1:5) = csid(1:5) info_1d (isubset) % id(6:40) = ' ' + info_1d (isubset) % dhr = hdr(4) ! difference in hour + info_1d (isubset) % elv = hdr(6) info_1d (isubset) % lon = hdr(2) info_1d (isubset) % lat = hdr(3) call readns(iunit,subset,idate,iret) ! read in the next subset - if ( iret /= 0 ) then - write(unit=message(1),fmt='(A,I3,A,I3)') & - "return code from readns",iret, & - "reach the end of PREPBUFR obs unit",iunit - !call da_warning(__FILE__,__LINE__,message(1:1)) - exit subsets - end if - end do subsets + end do + call closbf(iunit) + close(iunit) ! blacklisted stations should be handled through an external table. ! For now, temporary fix is implemented here for known incorrect ! station info in NCEP PREPBUFR file where ( (info_1d % id(1:4)) == 'BGQQ' ) + info_1d % elv = 19 info_1d % lon = -69.21 info_1d % lat = 77.46 end where where ( (info_1d % id(1:4)) == 'UWKE' ) + info_1d % elv = 194 info_1d % lon = 52.09 info_1d % lat = 55.56 end where @@ -313,20 +311,35 @@ bufrfile: do ibufr=1,numbufr where ( info_1d (:) % lat > 89.95 ) info_1d (:) % lat = 89.95 -! write(unit=message(1),fmt='(a)') 'Step 3: Determining outside_1d, outside_all_1d' -! call da_message(message(1:1)) +! 2.1.3 Determine loc_1d, outside_1d, outside_all_1d +!-------------------------------------------------------------- !JJG, NOTE: This llxy work/memory could also be divided amongst processors by assigning a subgroup of the subsets to each process. ! Ultimately all subsets that are .not.outside_all need to have outside_1d and loc_1d values populated on - ! all processors. This procedure is shown in da_read_obs_ncgoesabi with two calls to da_llxy_1d and + ! each processor. This procedure is shown in da_read_obs_ncgoesabi with two calls to da_llxy_1d and ! communications in between those two calls. call da_llxy_1d (info_1d, loc_1d, outside_1d, outside_all_1d) - call closbf(iunit) - close(iunit) + +! 2.2 Read domain-specific data +!-------------------------------------------------------------- + open(unit = iunit, FILE = trim(filename), & iostat = iost, form = 'unformatted', STATUS = 'OLD') + call openbf(iunit,'IN',iunit) + call datelen(10) + + call readns(iunit,subset,idate,iret) ! read in the next subset + if ( iret /= 0 ) then + write(unit=message(1),fmt='(A,I5,A)') & + "Error",iret," reading PREPBUFR obs file "//trim(filename) + call da_warning(__FILE__,__LINE__,message(1:1)) + call closbf(iunit) + if (trace_use) call da_trace_exit("da_read_obs_bufr") + return + end if + !rewind(iunit) ! open observation error table if provided. call da_get_unit(junit) @@ -351,27 +364,6 @@ bufrfile: do ibufr=1,numbufr end do end do read_loop end if - -! write(unit=message(1),fmt='(a)') 'Step 4: Reading domain-specific data' -! call da_message(message(1:1)) - - call openbf(iunit,'IN',iunit) - call datelen(10) - - call readns(iunit,subset,idate,iret) ! read in the next subset - if ( iret /= 0 ) then - write(unit=message(1),fmt='(A,I5,A)') & - "Error",iret," reading PREPBUFR obs file "//trim(filename) - call da_warning(__FILE__,__LINE__,message(1:1)) - call closbf(iunit) - if (trace_use) call da_trace_exit("da_read_obs_bufr") - return - end if - !rewind(iunit) - -! 2.1 read data -! scan reports first -!-------------------------------------------------------------- match = .false. end_of_file = .false. @@ -383,8 +375,6 @@ bufrfile: do ibufr=1,numbufr if ( match .or. outside_all .or. outside_time ) then call readns(iunit,subset,idate,iret) ! read in the next subset - isubset = isubset + 1 !increment isubset for every call to readns - if ( iret /= 0 ) then write(unit=message(1),fmt='(A,I3,A,I3)') & "return code from readns",iret, & @@ -392,10 +382,14 @@ bufrfile: do ibufr=1,numbufr !call da_warning(__FILE__,__LINE__,message(1:1)) exit reports end if + + isubset = isubset + 1 !increment isubset for every call to readns end if num_report = num_report+1 + platform % info = info_1d(isubset) + outside_all = outside_all_1d(isubset) if (outside_all) then num_outside_all = num_outside_all + 1 @@ -415,46 +409,13 @@ bufrfile: do ibufr=1,numbufr call ufbint(iunit,obs,8,255,nlevels,obstr) r8sid = hdr(1) - platform % info % name(1:8) = subset - platform % info % name(9:40) = ' ' - platform % info % id(1:5) = csid(1:5) - platform % info % id(6:40) = ' ' - platform % info % dhr = hdr(4) ! difference in hour - platform % info % elv = hdr(6) - platform % info % lon = hdr(2) - platform % info % lat = hdr(3) - - ! blacklisted stations should be handled through an external table. - ! For now, temporary fix is implemented here for known incorrect - ! station info in NCEP PREPBUFR file - if ( trim(platform%info%id) == 'BGQQ' ) then - platform%info%elv = 19 - platform%info%lon = -69.21 - platform%info%lat = 77.46 - end if - if ( trim(platform%info%id) == 'UWKE' ) then - platform%info%elv = 194 - platform%info%lon = 52.09 - platform%info%lat = 55.56 - end if - - ! Put a check on Lon and Lat - if ( platform%info%lon >= 180.0 ) platform%info%lon = platform%info%lon - 360.0 - ! Fix funny wind direction at Poles - !if (platform%info%lat < -89.9999 .or. platform%info%lat > 89.9999) then - ! platform%info%lon = 0.0 - !end if - platform%info%lat = max(platform%info%lat, -89.95) - platform%info%lat = min(platform%info%lat, 89.95) ! Restrict to a range of reports, useful for debugging - if (num_report < report_start) cycle reports if (num_report > report_end) exit reports outside = outside_1d(isubset) platform%loc = loc_1d(isubset) - !platform%info = info_1d(isubset) ! check date write(cdate,'(i10)') idate @@ -967,6 +928,7 @@ bufrfile: do ibufr=1,numbufr plink%kx_BUFR=kx plink%t29_BUFR=t29 plink%pco_BUFR=pco + plink%outside = outside num_p=num_p+1 @@ -1266,7 +1228,8 @@ bufrfile: do ibufr=1,numbufr plink%kx_BUFR=kx plink%t29_BUFR=t29 plink%pco_BUFR=pco - + plink%outside = outside + num_p=num_p+1 end do dup_loop end if !3dvar and 4dvar @@ -1292,6 +1255,7 @@ end do bufrfile !-------------------------------------------------------------- if (num_fgat_time > 1 ) then + do kk=1,num_fgat_time if ( thin_conv ) then do n = 1, num_ob_indexes @@ -1315,6 +1279,7 @@ end do bufrfile if (dlon_earth >= 360.0) dlon_earth = dlon_earth - 360.0 dlat_earth = dlat_earth * deg2rad dlon_earth = dlon_earth * deg2rad + outside = plink%outside ! Loop over duplicating obs for global ndup = 1 @@ -1711,7 +1676,7 @@ end if if (dlon_earth >= 360.0) dlon_earth = dlon_earth - 360.0 dlat_earth = dlat_earth * deg2rad dlon_earth = dlon_earth * deg2rad - + outside = plink%outside ndup = 1 if (global .and. & (plink%platform_BUFR%loc%i < ids .or. plink%platform_BUFR%loc%i >= ide)) ndup= 2 From 1fed12efd12771d3400d333db0081df2a1512576 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 21 Nov 2018 11:14:15 -0700 Subject: [PATCH 30/86] Turn off ABI cloud debug printing modified: da_radiance/da_qc_goesabi.inc --- var/da/da_radiance/da_qc_goesabi.inc | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 3d96ed6ac1..24e3929f4d 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -145,7 +145,9 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) tb_xb => iv%instid(i)%tb_xb tb_inv => iv%instid(i)%tb_inv - print_cld_debug = .true. +! print_cld_debug = .true. + print_cld_debug = .false. + if ( crtm_cloud ) then tb_xb_clr => iv%instid(i)%tb_xb_clr From ba426cdfc2ba4318c481d508a79e51992d0fdf7a Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 21 Nov 2018 13:20:33 -0700 Subject: [PATCH 31/86] Cleanup of da_read_obs_bufr.inc --- var/da/da_obs_io/da_read_obs_bufr.inc | 281 +++++++++++--------------- 1 file changed, 116 insertions(+), 165 deletions(-) diff --git a/var/da/da_obs_io/da_read_obs_bufr.inc b/var/da/da_obs_io/da_read_obs_bufr.inc index 8dcfb59c85..7c57515e95 100644 --- a/var/da/da_obs_io/da_read_obs_bufr.inc +++ b/var/da/da_obs_io/da_read_obs_bufr.inc @@ -95,7 +95,7 @@ subroutine da_read_obs_bufr (iv) type(datalink_BUFR),pointer :: head=>null(), plink=>null() - integer :: isubset + integer :: idom, isubset type (info_type), allocatable :: info_1d(:) type (model_loc_type), allocatable :: loc_1d(:) logical, allocatable :: outside_1d(:), outside_all_1d(:) @@ -135,7 +135,7 @@ subroutine da_read_obs_bufr (iv) tp(:) = 0 -! 1.0 Open file +! 1.0 Establish file open/read settings !---------------------------------------------------------------- ! !check if input file exists @@ -186,25 +186,11 @@ bufrfile: do ibufr=1,numbufr filename='ob1.bufr' endif !yw end added - + + ! -! We want to use specific unit number to read prepbufr data, which enables us to control its endianness - iunit = 96 - - open(unit = iunit, FILE = trim(filename), & - iostat = iost, form = 'unformatted', STATUS = 'OLD') - if (iost /= 0) then - write(unit=message(1),fmt='(A,I5,A)') & - "Error",iost," opening PREPBUFR obs file "//trim(filename) - call da_warning(__FILE__,__LINE__,message(1:1)) - if ( num_fgat_time == 1 ) then - call da_free_unit(iunit) - if (trace_use) call da_trace_exit("da_read_obs_bufr") - return - else - cycle bufrfile - end if - end if +! We want to use specific unit number to read prepbufr data, which enables us to control its endianness + iunit = 96 hdstr='SID XOB YOB DHR TYP ELV T29' obstr='POB QOB TOB ZOB UOB VOB PWO CAT' ! observation @@ -213,120 +199,27 @@ bufrfile: do ibufr=1,numbufr pcstr='PPC QPC TPC ZPC WPC NUL PWP NUL' ! program code -! 2.1.1 Initialize 1d arrays (loc, outside, outside_all) from da_llxy_1d -! (single vectorized call is much faster than >10^5 calls to subroutine) -!------------------------------------------------------------------------- - - call openbf(iunit,'IN',iunit) - call datelen(10) - - call readns(iunit,subset,idate,iret) ! read in the next subset - if ( iret /= 0 ) then - write(unit=message(1),fmt='(A,I5,A)') & - "Error",iret," reading PREPBUFR obs file "//trim(filename) - call da_warning(__FILE__,__LINE__,message(1:1)) - call closbf(iunit) - if (trace_use) call da_trace_exit("da_read_obs_bufr") - return - end if - !rewind(iunit) - - write(unit=message(1),fmt='(a,i10)') 'BUFR file date is: ', idate - - -! 2.1.1 Parse file for number of subsets -!-------------------------------------------------------------- - - isubset = 0 - do while (iret == 0) - isubset = isubset + 1 !increment isubset for every call to readns - call readns(iunit,subset,idate,iret) ! read in the next subset - end do - call closbf(iunit) - close(iunit) - - allocate ( info_1d (isubset) ) - allocate ( loc_1d (isubset) ) - allocate ( outside_1d (isubset) ) - allocate ( outside_all_1d (isubset) ) - +! 2.0 read data, including pre-reading lat/lon +!---------------------------------------------------------------- -! 2.2.1 Parse subsets for lat, lon + other info variables -!-------------------------------------------------------------- + ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) + domtest: do idom = 1, 3 open(unit = iunit, FILE = trim(filename), & iostat = iost, form = 'unformatted', STATUS = 'OLD') - call openbf(iunit,'IN',iunit) - call datelen(10) - - call readns(iunit,subset,idate,iret) ! read in the next subset - if ( iret /= 0 ) then + if (iost /= 0) then write(unit=message(1),fmt='(A,I5,A)') & - "Error",iret," reading PREPBUFR obs file "//trim(filename) + "Error",iost," opening PREPBUFR obs file "//trim(filename) call da_warning(__FILE__,__LINE__,message(1:1)) - call closbf(iunit) - if (trace_use) call da_trace_exit("da_read_obs_bufr") - return + if ( num_fgat_time == 1 ) then + call da_free_unit(iunit) + if (trace_use) call da_trace_exit("da_read_obs_bufr") + return + else + cycle bufrfile + end if end if - !rewind(iunit) - - isubset = 0 - do while (iret == 0 ) - isubset = isubset + 1 !increment isubset for every call to readns - - call ufbint(iunit,hdr,7,1,iret2,hdstr) - r8sid = hdr(1) - info_1d (isubset) % name(1:8) = subset - info_1d (isubset) % name(9:40) = ' ' - info_1d (isubset) % id(1:5) = csid(1:5) - info_1d (isubset) % id(6:40) = ' ' - info_1d (isubset) % dhr = hdr(4) ! difference in hour - info_1d (isubset) % elv = hdr(6) - info_1d (isubset) % lon = hdr(2) - info_1d (isubset) % lat = hdr(3) - - call readns(iunit,subset,idate,iret) ! read in the next subset - end do - call closbf(iunit) - close(iunit) - - ! blacklisted stations should be handled through an external table. - ! For now, temporary fix is implemented here for known incorrect - ! station info in NCEP PREPBUFR file - where ( (info_1d % id(1:4)) == 'BGQQ' ) - info_1d % elv = 19 - info_1d % lon = -69.21 - info_1d % lat = 77.46 - end where - where ( (info_1d % id(1:4)) == 'UWKE' ) - info_1d % elv = 194 - info_1d % lon = 52.09 - info_1d % lat = 55.56 - end where - - ! Put a check on Lon and Lat - where ( info_1d (:) % lon >= 180.0 ) info_1d (:) % lon = info_1d (:) % lon - 360.0 - where ( info_1d (:) % lat < -89.95 ) info_1d (:) % lat = -89.95 - where ( info_1d (:) % lat > 89.95 ) info_1d (:) % lat = 89.95 - - -! 2.1.3 Determine loc_1d, outside_1d, outside_all_1d -!-------------------------------------------------------------- - - !JJG, NOTE: This llxy work/memory could also be divided amongst processors by assigning a subgroup of the subsets to each process. - ! Ultimately all subsets that are .not.outside_all need to have outside_1d and loc_1d values populated on - ! each processor. This procedure is shown in da_read_obs_ncgoesabi with two calls to da_llxy_1d and - ! communications in between those two calls. - - call da_llxy_1d (info_1d, loc_1d, outside_1d, outside_all_1d) - - -! 2.2 Read domain-specific data -!-------------------------------------------------------------- - - open(unit = iunit, FILE = trim(filename), & - iostat = iost, form = 'unformatted', STATUS = 'OLD') call openbf(iunit,'IN',iunit) call datelen(10) @@ -341,39 +234,44 @@ bufrfile: do ibufr=1,numbufr end if !rewind(iunit) - ! open observation error table if provided. - call da_get_unit(junit) - open (unit=junit, file='obs_errtable', form='formatted', status='old', & - iostat=iost) - if ( iost /= 0 ) then - use_errtable = .false. - call da_free_unit(junit) - else - use_errtable = .true. - write(unit=message(1),fmt='(A)') & - "obs_errtable file is found. Will use user-provided obs errors." + if (idom .eq. 1) then + write(unit=message(1),fmt='(a,i10)') 'BUFR file date is: ', idate call da_message(message(1:1)) end if - if ( use_errtable ) then - read_loop: do - read (junit,'(1x,i3)',iostat=iost) itype - if ( iost /=0 ) exit read_loop - do k = 1, 33 - read (junit,'(1x,6e12.5)',iostat=iost) (oetab(itype,k,ivar),ivar=1,6) + if (idom .eq. 3) then + ! open observation error table if provided. + call da_get_unit(junit) + open (unit=junit, file='obs_errtable', form='formatted', status='old', & + iostat=iost) + if ( iost /= 0 ) then + use_errtable = .false. + call da_free_unit(junit) + else + use_errtable = .true. + write(unit=message(1),fmt='(A)') & + "obs_errtable file is found. Will use user-provided obs errors." + call da_message(message(1:1)) + end if + if ( use_errtable ) then + read_loop: do + read (junit,'(1x,i3)',iostat=iost) itype if ( iost /=0 ) exit read_loop - end do - end do read_loop + do k = 1, 33 + read (junit,'(1x,6e12.5)',iostat=iost) (oetab(itype,k,ivar),ivar=1,6) + if ( iost /=0 ) exit read_loop + end do + end do read_loop + end if end if - - match = .false. + end_of_file = .false. + match = .false. outside_all = .false. outside_time = .false. isubset = 1 reports: do while ( .not. end_of_file ) - - if ( match .or. outside_all .or. outside_time ) then + if ( match .or. outside_all .or. outside_time .or. idom.eq.1) then call readns(iunit,subset,idate,iret) ! read in the next subset if ( iret /= 0 ) then write(unit=message(1),fmt='(A,I3,A,I3)') & @@ -384,6 +282,30 @@ bufrfile: do ibufr=1,numbufr end if isubset = isubset + 1 !increment isubset for every call to readns + if (idom .eq. 1) cycle reports + end if + + call ufbint(iunit,hdr,7,1,iret2,hdstr) + call ufbint(iunit,pmo,2,1,nlevels,'PMO PMQ') + call ufbint(iunit,qms,8,255,nlevels,qmstr) + call ufbint(iunit,oes,8,255,nlevels,oestr) + call ufbint(iunit,pco,8,255,nlevels,pcstr) + call ufbint(iunit,obs,8,255,nlevels,obstr) + + r8sid = hdr(1) + if (idom .eq. 2) then + info_1d (isubset) % name(1:8) = subset + info_1d (isubset) % name(9:40) = ' ' + info_1d (isubset) % id(1:5) = csid(1:5) + info_1d (isubset) % id(6:40) = ' ' + info_1d (isubset) % dhr = hdr(4) ! difference in hour + info_1d (isubset) % elv = hdr(6) + info_1d (isubset) % lon = hdr(2) + info_1d (isubset) % lat = hdr(3) + + outside_all = .true. + + cycle reports end if num_report = num_report+1 @@ -401,15 +323,6 @@ bufrfile: do ibufr=1,numbufr cycle reports end if - call ufbint(iunit,hdr,7,1,iret2,hdstr) - call ufbint(iunit,pmo,2,1,nlevels,'PMO PMQ') - call ufbint(iunit,qms,8,255,nlevels,qmstr) - call ufbint(iunit,oes,8,255,nlevels,oestr) - call ufbint(iunit,pco,8,255,nlevels,pcstr) - call ufbint(iunit,obs,8,255,nlevels,obstr) - - r8sid = hdr(1) - ! Restrict to a range of reports, useful for debugging if (num_report < report_start) cycle reports if (num_report > report_end) exit reports @@ -1235,18 +1148,56 @@ bufrfile: do ibufr=1,numbufr end if !3dvar and 4dvar end do reports -call closbf(iunit) -close(iunit) + call closbf(iunit) + close(iunit) + + if (idom .eq. 1) then + allocate ( info_1d (isubset) ) + allocate ( loc_1d (isubset) ) + allocate ( outside_1d (isubset) ) + allocate ( outside_all_1d (isubset) ) + end if + if (idom .eq. 2) then + ! blacklisted stations should be handled through an external table. + ! For now, temporary fix is implemented here for known incorrect + ! station info in NCEP PREPBUFR file + where ( (info_1d % id(1:4)) == 'BGQQ' ) + info_1d % elv = 19 + info_1d % lon = -69.21 + info_1d % lat = 77.46 + end where + where ( (info_1d % id(1:4)) == 'UWKE' ) + info_1d % elv = 194 + info_1d % lon = 52.09 + info_1d % lat = 55.56 + end where + + ! Put a check on Lon and Lat + where ( info_1d (:) % lon >= 180.0 ) info_1d (:) % lon = info_1d (:) % lon - 360.0 + where ( info_1d (:) % lat < -89.95 ) info_1d (:) % lat = -89.95 + where ( info_1d (:) % lat > 89.95 ) info_1d (:) % lat = 89.95 + + !JJG, NOTE: This llxy work/memory could be divided amongst processors by assigning a subgroup of the subsets to each process. + ! Ultimately all subsets that are .not.outside_all need to have outside_1d and loc_1d values populated on + ! each processor. This procedure is shown in da_read_obs_ncgoesabi with two calls to da_llxy_1d and + ! communications of info and loc in between those two calls. + + call da_llxy_1d (info_1d(1:isubset), loc_1d(1:isubset), outside_1d(1:isubset), outside_all_1d(1:isubset)) + end if + if (idom .eq. 3) then + deallocate ( info_1d ) + deallocate ( loc_1d ) + deallocate ( outside_1d ) + deallocate ( outside_all_1d ) + end if + + end do domtest + if ( use_errtable ) then close(junit) call da_free_unit(junit) end if - deallocate ( outside_1d ) - deallocate ( outside_all_1d ) - deallocate ( info_1d ) - deallocate ( loc_1d ) - end do bufrfile From b908ce0df391850982d4c2d998c0daf11efbe20c Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Mon, 26 Nov 2018 15:04:09 -0700 Subject: [PATCH 32/86] Vectorized the llxy test for several radiance instruments This modification speeds up reading of bufr files for the applicable instruments. --- var/da/da_radiance/da_read_obs_bufrairs.inc | 159 ++++++++++++------ var/da/da_radiance/da_read_obs_bufratms.inc | 31 +++- var/da/da_radiance/da_read_obs_bufriasi.inc | 101 +++++++---- var/da/da_radiance/da_read_obs_bufrseviri.inc | 90 +++++++--- var/da/da_radiance/da_read_obs_bufrssmis.inc | 100 +++++++---- var/da/da_radiance/da_read_obs_bufrtovs.inc | 107 +++++++----- 6 files changed, 410 insertions(+), 178 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_bufrairs.inc b/var/da/da_radiance/da_read_obs_bufrairs.inc index e2d73e9569..6153c29a3c 100644 --- a/var/da/da_radiance/da_read_obs_bufrairs.inc +++ b/var/da/da_radiance/da_read_obs_bufrairs.inc @@ -87,6 +87,8 @@ subroutine da_read_obs_bufrairs(obstype,iv,infile) ! BUFR talble file sequencial number character(len=512) :: table_file +! BUFR functions + integer(i_kind) :: ireadsb,ireadmg ! Variables for BUFR IO type(aquaspot_list) :: aquaspot @@ -154,6 +156,11 @@ subroutine da_read_obs_bufrairs(obstype,iv,infile) type(model_loc_type) :: loc type (datalink_type), pointer :: head, p, current, prev + integer :: idom, irads + type(info_type), allocatable :: info_1d(:) + type(model_loc_type), allocatable :: loc_1d(:) + logical, allocatable :: outside_1d(:), outside_all_1d(:) + if (trace_use) call da_trace_entry("da_read_obs_bufrairs") ! 0.0 Initialize variables @@ -272,6 +279,16 @@ bufrfile: do ibufr=1,numbufr lnbufr=97 + if ( ibufr == 1 ) then + allocate ( head ) + ! allocate ( head % tb (1:nchan) ) + nullify ( head % next ) + p => head + endif + + ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) + domtest: do idom = 1, 3 + open(unit=lnbufr,file=trim(filename),form='unformatted',iostat = iost, status = 'old') if (iost /= 0) then call da_warning(__FILE__,__LINE__, & @@ -291,44 +308,43 @@ bufrfile: do ibufr=1,numbufr end if call datelen(10) - ! 2.0 Read header !--------------------------- call readmg(lnbufr,subset,idate,iret) - iy = 0 - im = 0 - idd = 0 - ihh = 0 - if( iret /= 0 ) goto 1000 ! no data? - - write(unit=date,fmt='( i10)') idate - read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh - write(unit=stdout,fmt='(a,4i4,2x,a)') & - 'Bufr file date is ',iy,im,idd,ihh,trim(infile) + if (idom .eq. 1) then + iy = 0 + im = 0 + idd = 0 + ihh = 0 + if( iret /= 0 ) goto 1000 ! no data? + + write(unit=date,fmt='( i10)') idate + read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh + write(unit=stdout,fmt='(a,4i4,2x,a)') & + 'Bufr file date is ',iy,im,idd,ihh,trim(infile) + end if ! 3.0 Loop over observations !---------------------------- - if ( ibufr == 1 ) then - allocate ( head ) - ! allocate ( head % tb (1:nchan) ) - nullify ( head % next ) - p => head - endif - - loop_obspoints: do - -! 3.1 Read headder -!------------------------------- - call readsb(lnbufr,iret) - - if( iret /=0 )then - call readmg(lnbufr,subset,idate,iret) - if( iret /= 0 ) exit loop_obspoints ! end of file - cycle loop_obspoints - end if + irads = 0 + do while (ireadmg(lnbufr,subset,idate)==0) + loop_obspoints: do while (ireadsb(lnbufr)==0) - num_eos_file = num_eos_file + 1 +! loop_obspoints: do +! +!! 3.1 Read headder +!!------------------------------- +! call readsb(lnbufr,iret) +! +! if( iret /=0 )then +! call readmg(lnbufr,subset,idate,iret) +! if( iret /= 0 ) exit loop_obspoints ! end of file +! cycle loop_obspoints +! end if + + irads = irads + 1 + if (idom .eq. 1) cycle loop_obspoints ! 3.2 Read AQUASPOT (SPITSEQN) !------------------------ @@ -362,6 +378,41 @@ bufrfile: do ibufr=1,numbufr airsspot_list_array(11), & airsspot_list_array(12) ) + +! 4.0 Check observing position (lat/lon) +! QC1: juge if data is in the domain, +! read next record if not +!------------------------------------------ + if( abs(airsspot%clath) > R90 .or. & + abs(airsspot%clonh) > R360 .or. & + (abs(airsspot%clath) == R90 .and. airsspot%clonh /= ZERO) )then + cycle loop_obspoints + end if + +! Retrieve observing position + if(airsspot%clonh >= R360) then + airsspot%clonh = airsspot%clonh - R360 +! else if(airsspot%clonh < ZERO) then +! airsspot%clonh = airsspot%clonh + R360 + end if + + if (idom .eq. 2) then + info_1d(irads) % lat = airsspot%clath + info_1d(irads) % lon = airsspot%clonh + cycle loop_obspoints + end if + + info%lat = airsspot%clath + info%lon = airsspot%clonh + + outside_all = outside_all_1d(irads) + + if ( outside_all ) cycle loop_obspoints + + loc = loc_1d(irads) + outside = outside_1d(irads) + +!Temporary moved ! 3.4 Read AIRSCHAN or AMSUCHAN or HSBCHAN !------------------------------------------- if ( trim(senname) == 'AIRS' ) then @@ -385,32 +436,11 @@ bufrfile: do ibufr=1,numbufr cycle loop_obspoints end if +!Temporary moved ! 3.5 Read Cloud Cover from AIRS/VISNIR !------------------------------------------- call ufbint(lnbufr,tocc,1,1,iret,'TOCC') - -! 4.0 Check observing position (lat/lon) -! QC1: juge if data is in the domain, -! read next record if not -!------------------------------------------ - if( abs(airsspot%clath) > R90 .or. & - abs(airsspot%clonh) > R360 .or. & - (abs(airsspot%clath) == R90 .and. airsspot%clonh /= ZERO) )then - cycle loop_obspoints - end if - -! Retrieve observing position - if(airsspot%clonh >= R360) then - airsspot%clonh = airsspot%clonh - R360 -! else if(airsspot%clonh < ZERO) then -! airsspot%clonh = airsspot%clonh + R360 - end if - - info%lat = airsspot%clath - info%lon = airsspot%clonh - call da_llxy (info, loc, outside, outside_all ) - - if ( outside_all ) cycle loop_obspoints + ! 4.1 Check obs time !------------------------------------- @@ -562,11 +592,32 @@ bufrfile: do ibufr=1,numbufr p => p%next nullify (p%next) - end do loop_obspoints + end do loop_obspoints + end do call closbf(lnbufr) close(lnbufr) + if (idom .eq. 1) then + allocate ( info_1d (irads) ) + allocate ( loc_1d (irads) ) + allocate ( outside_1d (irads) ) + allocate ( outside_all_1d (irads) ) + end if + if (idom .eq. 2) then + call da_llxy_1d (info_1d(1:irads), loc_1d(1:irads), outside_1d(1:irads), outside_all_1d(1:irads)) + end if + if (idom .eq. 3) then + deallocate ( info_1d ) + deallocate ( loc_1d ) + deallocate ( outside_1d ) + deallocate ( outside_all_1d ) + end if + + end do domtest + + num_eos_file = num_eos_file + irads + end do bufrfile if (thinning .and. num_eos_global > 0) then diff --git a/var/da/da_radiance/da_read_obs_bufratms.inc b/var/da/da_radiance/da_read_obs_bufratms.inc index dd63757d36..f276677840 100644 --- a/var/da/da_radiance/da_read_obs_bufratms.inc +++ b/var/da/da_radiance/da_read_obs_bufratms.inc @@ -115,6 +115,10 @@ subroutine da_read_obs_bufratms (obstype,iv, infile) real , allocatable :: in(:), out(:) logical :: found, head_found + type(info_type), allocatable :: info_1d(:) + type(model_loc_type), allocatable :: loc_1d(:) + logical, allocatable :: outside_1d(:), outside_all_1d(:) + if (trace_use) call da_trace_entry("da_read_obs_bufratms") ! Initialize variables @@ -333,6 +337,18 @@ bufrfile: do ibufr=1,numbufr call da_error(__FILE__,__LINE__,message(1:1)) endif + allocate ( info_1d (nnum) ) + allocate ( loc_1d (nnum) ) + allocate ( outside_1d (nnum) ) + allocate ( outside_all_1d (nnum) ) + + info_1d%lat = lat_save(1:nnum) + info_1d%lon = lon_save(1:nnum) + + ! Determine loc_1d, outside_1d, outside_all_1d + !--------------------------------------------------------------------------------- + call da_llxy_1d (info_1d, loc_1d, outside_1d, outside_all_1d) + obs: do nn=1, nnum if ( nn == 1 ) then allocate (head) @@ -347,10 +363,14 @@ bufrfile: do ibufr=1,numbufr ! rlat = bfr1bhdr(bufr_lat) ! rlon = bfr1bhdr(bufr_lat) ! if (rlon < 0.0) rlon = rlon+360.0 - info%lat = lat_save(nn) - info%lon = lon_save(nn) +! info%lat = lat_save(nn) +! info%lon = lon_save(nn) - call da_llxy (info, loc, outside, outside_all) +! call da_llxy (info, loc, outside, outside_all) + info = info_1d (nn) + loc = loc_1d (nn) + outside = outside_1d (nn) + outside_all = outside_all_1d (nn) if (outside_all) cycle @@ -518,6 +538,11 @@ bufrfile: do ibufr=1,numbufr ! call closbf(lnbufr) ! close(lnbufr) + deallocate ( info_1d ) + deallocate ( loc_1d ) + deallocate ( outside_1d ) + deallocate ( outside_all_1d ) + !end do bufrfile if (thinning .and. num_tovs_global > 0 ) then diff --git a/var/da/da_radiance/da_read_obs_bufriasi.inc b/var/da/da_radiance/da_read_obs_bufriasi.inc index 7aa45a3d4a..ec4806844a 100644 --- a/var/da/da_radiance/da_read_obs_bufriasi.inc +++ b/var/da/da_radiance/da_read_obs_bufriasi.inc @@ -86,6 +86,10 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) real(r_kind),parameter :: tbmax = 550._r_kind real(r_kind),parameter :: earth_radius = 6371000._r_kind + integer :: idom, irads + type(info_type), allocatable :: info_1d(:) + type(model_loc_type), allocatable :: loc_1d(:) + logical, allocatable :: outside_1d(:), outside_all_1d(:) if (trace_use) call da_trace_entry("da_read_obs_bufriasi") ! 0.0 Initialize variables @@ -108,7 +112,7 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) nread(1:rtminit_nsensor) = 0 ptotal(0:num_fgat_time) = 0 iobs = 0 ! for thinning, argument is inout - num_iasi_file = 0 + num_iasi_file = 0 num_iasi_local = 0 num_iasi_global = 0 num_iasi_used = 0 @@ -143,11 +147,24 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) end if end if lnbufr = 95 + +! Allocate arrays to hold data + nele=nreal+nchan + allocate(data_all(nele)) + if ( ibufr == 1 ) then + allocate (head) + nullify ( head % next ) + p => head + end if + + ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) + domtest: do idom = 1, 3 + open(unit=lnbufr,file=trim(filename),form='unformatted', & iostat = iost, status = 'old') if (iost /= 0) then call da_warning(__FILE__,__LINE__, & - (/"Cannot open file "//infile/)) + (/"Cannot open file: "//infile/)) if (trace_use) call da_trace_exit("da_read_obs_bufriasi") return end if @@ -156,33 +173,26 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) call openbf(lnbufr,'IN',lnbufr) call datelen(10) call readmg(lnbufr,subset,idate,iret) - iy=0 - im=0 - idd=0 - ihh=0 - write(unit=date,fmt='( i10)') idate - read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh - write(unit=stdout,fmt='(a,4i4,2x,a)') & - 'Bufr file date is ',iy,im,idd,ihh,trim(infile) - - ! Loop to read bufr file and assign information to a sequential structure - !------------------------------------------------------------------------- -! Allocate arrays to hold data - nele=nreal+nchan - allocate(data_all(nele)) - if ( ibufr == 1 ) then - allocate (head) - nullify ( head % next ) - p => head - end if - + if (idom .eq. 1) then + iy=0 + im=0 + idd=0 + ihh=0 + write(unit=date,fmt='( i10)') idate + read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh + write(unit=stdout,fmt='(a,4i4,2x,a)') & + 'Bufr file date is ',iy,im,idd,ihh,trim(infile) + end if ! Big loop to read data file + irads = 0 do while(ireadmg(lnbufr,subset,idate)>=0) read_loop: do while (ireadsb(lnbufr)==0) - num_iasi_file = num_iasi_file + 1 + + irads = irads + 1 + if (idom .eq. 1) cycle read_loop ! Read IASI FOV information call ufbint(lnbufr,linele,5,1,iret,'FOVN SLNM QGFQ MJFC SELV') @@ -214,9 +224,19 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) satellite_id = 3 end if -! Check observing position - info%lat = allspot(8) ! latitude - info%lon = allspot(9) ! longitude) + if (idom .eq. 2) then + ! Get observing position + info_1d (irads) % lat = allspot(8) ! latitude + info_1d (irads) % lon = allspot(9) ! longitude + + cycle read_loop + end if + + info = info_1d (irads) + loc = loc_1d (irads) + outside = outside_1d (irads) + outside_all = outside_all_1d (irads) + if( abs(info%lat) > r90 .or. abs(info%lon) > r360 .or. & (abs(info%lat) == r90 .and. info%lon /= zero) )then write(unit=stdout,fmt=*) & @@ -225,8 +245,7 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) cycle read_loop end if - call da_llxy (info, loc, outside, outside_all) - if (outside_all) cycle + if (outside_all) cycle read_loop inst = 0 do i = 1, rtminit_nsensor if (platform_id == rtminit_platform(i) & @@ -421,6 +440,28 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) end do read_loop end do call closbf(lnbufr) + close(lnbufr) + + if (idom .eq. 1) then + allocate ( info_1d (irads) ) + allocate ( loc_1d (irads) ) + allocate ( outside_1d (irads) ) + allocate ( outside_all_1d (irads) ) + end if + if (idom .eq. 2) then + call da_llxy_1d (info_1d(1:irads), loc_1d(1:irads), outside_1d(1:irads), outside_all_1d(1:irads)) + end if + if (idom .eq. 3) then + deallocate ( info_1d ) + deallocate ( loc_1d ) + deallocate ( outside_1d ) + deallocate ( outside_all_1d ) + + end if + + end do domtest + + num_iasi_file = num_iasi_file + irads !Deallocate temporary array for next bufrfile do loop deallocate(data_all) @@ -577,8 +618,8 @@ end do bufrfile deallocate (nread) deallocate (ptotal) - call closbf(lnbufr) - close(lnbufr) +! call closbf(lnbufr) +! close(lnbufr) ! call da_free_unit(lnbufr) diff --git a/var/da/da_radiance/da_read_obs_bufrseviri.inc b/var/da/da_radiance/da_read_obs_bufrseviri.inc index c98e1f0dd6..78e6a9b342 100644 --- a/var/da/da_radiance/da_read_obs_bufrseviri.inc +++ b/var/da/da_radiance/da_read_obs_bufrseviri.inc @@ -120,6 +120,11 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) real(r_kind),parameter:: tbmax = 550._r_kind real(r_kind),parameter:: earth_radius = 6371000._r_kind + integer :: idom, irads + type(info_type), allocatable :: info_1d(:) + type(model_loc_type), allocatable :: loc_1d(:) + logical, allocatable :: outside_1d(:), outside_all_1d(:) + ilath=8 ! the position of latitude in the header ilonh=9 ! the position of longitude in the header ilzah=10 ! satellite zenith angle @@ -191,6 +196,16 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) ! dont change, WRFDA uses specified units to read radiance data lnbufr = 92 + + if ( ibufr == 1 ) then + allocate (head) + nullify ( head % next ) + p => head + end if + + ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) + domtest: do idom = 1, 3 + open(unit=lnbufr,file=trim(filename),form='unformatted', & iostat = iost, status = 'old' ) !,convert='little_endian') if (iost /= 0) then @@ -255,37 +270,33 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) allocate(hdr(nhdr)) + if (idom .eq. 1) then + iy=0 + im=0 + idd=0 + ihh=0 - iy=0 - im=0 - idd=0 - ihh=0 - - sensorindex=1 - write(unit=date,fmt='( i10)') idate - read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh - write(unit=stdout,fmt='(a,4i4,2x,a)') & - 'Bufr file date is ',iy,im,idd,ihh,trim(infile) + sensorindex=1 + write(unit=date,fmt='( i10)') idate + read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh + write(unit=stdout,fmt='(a,4i4,2x,a)') & + 'Bufr file date is ',iy,im,idd,ihh,trim(infile) + end if ! 2.0 Loop to read bufr file and assign information to a sequential structure !------------------------------------------------------------------------- ! Allocate arrays to hold data nele=nreal+nchan - allocate(data_all(nele)) - if ( ibufr == 1 ) then - allocate (head) - nullify ( head % next ) - p => head - end if - + allocate(data_all(nele)) ! Big loop to read data file - + irads = 0 do while(ireadmg(lnbufr,subset,idate)>=0) read_loop: do while (ireadsb(lnbufr)==0) - num_seviri_file = num_seviri_file + 1 + irads = irads + 1 + if (idom .eq. 1) cycle read_loop ! Read SEVIRI information call ufbint(lnbufr,hdr,nhdr,1,iret,hdrsevi) @@ -337,8 +348,18 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) if(allchnmiss) cycle read_loop ! Check observing position - info%lat = hdr(ilath) ! latitude - info%lon = hdr(ilonh) ! longitude + if (idom .eq. 2) then + info_1d(irads) % lat = hdr(ilath) ! latitude + info_1d(irads) % lon = hdr(ilonh) ! longitude + + cycle read_loop + end if + + info = info_1d (irads) + loc = loc_1d (irads) + outside = outside_1d (irads) + outside_all = outside_all_1d (irads) + if( abs(info%lat) > R90 .or. abs(info%lon) > R360 .or. & (abs(info%lat) == R90 .and. info%lon /= ZERO) )then write(unit=stdout,fmt=*) & @@ -459,12 +480,35 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) end do read_loop end do call closbf(lnbufr) + close(lnbufr) !Deallocate temporary arrays for next bufrfile do loop deallocate(datasev1) deallocate(datasev2) deallocate(hdr) deallocate(data_all) + + if (idom .eq. 1) then + allocate ( info_1d (irads) ) + allocate ( loc_1d (irads) ) + allocate ( outside_1d (irads) ) + allocate ( outside_all_1d (irads) ) + end if + if (idom .eq. 2) then + call da_llxy_1d (info_1d(1:irads), loc_1d(1:irads), outside_1d(1:irads), outside_all_1d(1:irads)) + end if + if (idom .eq. 3) then + deallocate ( info_1d ) + deallocate ( loc_1d ) + deallocate ( outside_1d ) + deallocate ( outside_all_1d ) + + end if + + end do domtest + + num_seviri_file = num_seviri_file + irads + end do bufrfile if (thinning .and. num_seviri_global > 0 ) then @@ -619,8 +663,8 @@ end do bufrfile deallocate (nread) deallocate (ptotal) - call closbf(lnbufr) - close(lnbufr) +! call closbf(lnbufr) +! close(lnbufr) call da_free_unit(lnbufr) diff --git a/var/da/da_radiance/da_read_obs_bufrssmis.inc b/var/da/da_radiance/da_read_obs_bufrssmis.inc index f271f58af1..954255da67 100644 --- a/var/da/da_radiance/da_read_obs_bufrssmis.inc +++ b/var/da/da_radiance/da_read_obs_bufrssmis.inc @@ -70,6 +70,11 @@ subroutine da_read_obs_bufrssmis (obstype,iv,infile) integer(i_kind), allocatable :: ptotal(:), nread(:) + integer :: idom, irads + type(info_type), allocatable :: info_1d(:) + type(model_loc_type), allocatable :: loc_1d(:) + logical, allocatable :: outside_1d(:), outside_all_1d(:) + call da_trace_entry("da_read_obs_bufrssmis") allocate(nread(1:rtminit_nsensor)) @@ -127,6 +132,22 @@ bufrfile: do ibufr=1,numbufr end if lnbufr=98 + + if ( ibufr == 1 ) then + allocate (head) + nullify ( head % next ) + p => head + end if + +! Set various variables depending on type of data to be read + + !subfgn = 'NC003003' + subfgn = 'NC021201' + incangl = 53.2_r_kind + + ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) + domtest: do idom = 1, 3 + open(unit=lnbufr,file=trim(filename),form='unformatted', & iostat = iost, status = 'old') if (iost /= 0) then @@ -140,52 +161,52 @@ bufrfile: do ibufr=1,numbufr call datelen(10) call readmg(lnbufr,subset,idate,iret) - iy=0 - im=0 - idd=0 - ihh=0 - write(unit=date,fmt='( i10)') idate - read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh - write(unit=stdout,fmt=*) & - 'Bufr file date is ',iy,im,idd,ihh,infile + if (idom .eq. 1) then + iy=0 + im=0 + idd=0 + ihh=0 + write(unit=date,fmt='( i10)') idate + read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh + write(unit=stdout,fmt=*) & + 'Bufr file date is ',iy,im,idd,ihh,infile + end if ! Loop to read bufr file and assign information to a sequential structure !------------------------------------------------------------------------- - if ( ibufr == 1 ) then - allocate (head) - nullify ( head % next ) - p => head - end if - -! Set various variables depending on type of data to be read - - !subfgn = 'NC003003' - subfgn = 'NC021201' - incangl = 53.2_r_kind - + irads = 0 subset_loop: do while (ireadmg(lnbufr,subset,idate)==0) read_loop: do while (ireadsb(lnbufr)==0 .and. subset==subfgn) - num_ssmis_file = num_ssmis_file + 1 - ! 1.0 Read header record and data record + irads = irads + 1 + if (idom .eq. 1) cycle read_loop + ! 1.0 Read header record call ufbint(lnbufr,bfr1bhdr,n1bhdr,1,iret,hdr1b) - call ufbrep(lnbufr,bufrtbb,2,maxchanl,iret,"CHNM TMBR" ) ! check if observation outside range - ! 2.0 Extract observation location and other required information + ! 2.1 Extract observation location and other required information ! QC1: judge if data is in the domain, read next record if not !------------------------------------------------------------------------ + if (idom .eq. 2) then + info_1d(irads) % lat = bfr1bhdr(bufr_lat) + info_1d(irads) % lon = bfr1bhdr(bufr_lon) - info%lat = bfr1bhdr(bufr_lat) - info%lon = bfr1bhdr(bufr_lon) - call da_llxy (info, loc, outside, outside_all) + cycle read_loop + end if + info = info_1d (irads) + loc = loc_1d (irads) + outside_all = outside_all_1d (irads) + outside = outside_1d (irads) if (outside_all) cycle + ! 2.2 Read data record + call ufbrep(lnbufr,bufrtbb,2,maxchanl,iret,"CHNM TMBR" ) + ! 3.0 Extract other information info%elv = 0.0 @@ -356,6 +377,27 @@ bufrfile: do ibufr=1,numbufr call closbf(lnbufr) close(lnbufr) + if (idom .eq. 1) then + allocate ( info_1d (irads) ) + allocate ( loc_1d (irads) ) + allocate ( outside_1d (irads) ) + allocate ( outside_all_1d (irads) ) + end if + if (idom .eq. 2) then + call da_llxy_1d (info_1d(1:irads), loc_1d(1:irads), outside_1d(1:irads), outside_all_1d(1:irads)) + end if + if (idom .eq. 3) then + deallocate ( info_1d ) + deallocate ( loc_1d ) + deallocate ( outside_1d ) + deallocate ( outside_all_1d ) + + end if + + end do domtest + + num_ssmis_file = num_ssmis_file + irads + end do bufrfile if (thinning .and. num_ssmis_global > 0 ) then @@ -512,8 +554,8 @@ end do bufrfile deallocate (nread) deallocate (ptotal) - call closbf(lnbufr) - close(lnbufr) +! call closbf(lnbufr) +! close(lnbufr) ! call da_free_unit(lnbufr) call da_trace_exit("da_read_obs_bufrssmis") diff --git a/var/da/da_radiance/da_read_obs_bufrtovs.inc b/var/da/da_radiance/da_read_obs_bufrtovs.inc index 0660c8e8b9..197b48359c 100644 --- a/var/da/da_radiance/da_read_obs_bufrtovs.inc +++ b/var/da/da_radiance/da_read_obs_bufrtovs.inc @@ -62,7 +62,6 @@ subroutine da_read_obs_bufrtovs (obstype,iv, infile) ! pixel information integer :: year,month,day,hour,minute,second ! observation time real*8 :: obs_time - ! real :: rlat, rlon ! lat/lon in degrees for Anfovs real :: satzen, satazi, solzen ,solazi ! scan angles for Anfovs integer :: landsea_mask real :: srf_height @@ -89,6 +88,11 @@ subroutine da_read_obs_bufrtovs (obstype,iv, infile) real , allocatable :: in(:), out(:) logical :: found, head_found + integer :: idom, itovs + type(info_type), allocatable :: info_1d(:) + type(model_loc_type), allocatable :: loc_1d(:) + logical, allocatable :: outside_1d(:), outside_all_1d(:) + call da_trace_entry("da_read_obs_bufrtovs") ! Initialize variables @@ -214,11 +218,25 @@ bufrfile: do ibufr=1,numbufr ! We want to use specific unit number for bufr data, so we can control the endian format in environment. lnbufr = 99 + if ( ibufr == 1 ) then + allocate (head) + ! allocate ( head % tb_inv (1:nchan) ) + nullify ( head % next ) + p => head + endif + + if (tovs_start > 1) then + write (unit=stdout,fmt='(A,I6)') " Skipping tovs obs before", tovs_start + end if + + ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) + domtest: do idom = 1, 3 + open(unit=lnbufr,file=trim(filename),form='unformatted', & iostat = iost, status = 'old') if (iost /= 0) then call da_warning(__FILE__,__LINE__, & - (/"Cannot open file "//infile/)) + (/"Cannot open file (1): "//infile/)) call da_trace_exit("da_read_obs_bufrtovs") return end if @@ -235,33 +253,24 @@ bufrfile: do ibufr=1,numbufr call da_error(__FILE__,__LINE__,message(1:2)) end if - iy=0 - im=0 - idd=0 - ihh=0 - write(unit=date,fmt='( i10)') idate - read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh - write(unit=stdout,fmt=*) & - 'Bufr file date is ',iy,im,idd,ihh,infile - - ! Loop to read bufr file and assign information to a sequential structure - !------------------------------------------------------------------------- - - if ( ibufr == 1 ) then - allocate (head) - ! allocate ( head % tb_inv (1:nchan) ) - nullify ( head % next ) - p => head - endif - - if (tovs_start > 1) then - write (unit=stdout,fmt='(A,I6)') " Skipping tovs obs before", tovs_start + if (idom .eq. 1) then + iy=0 + im=0 + idd=0 + ihh=0 + write(unit=date,fmt='( i10)') idate + read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh + write(unit=stdout,fmt=*) & + 'Bufr file date is ',iy,im,idd,ihh,infile end if - + itovs = 0 obs: do while (ireadmg(lnbufr,subset,idate)==0 .and. subset==subfgn) do while (ireadsb(lnbufr)==0) + itovs = itovs + 1 + if (idom .eq. 1) cycle + ! 1.0 Read header record and data record call ufbint(lnbufr,bfr1bhdr,n1bhdr,1,iret,hdr1b) call ufbint(lnbufr,bfr2bhdr,n2bhdr,1,iret,hdr2b) @@ -269,25 +278,25 @@ bufrfile: do ibufr=1,numbufr ! call ufbrep(lnbufr,data1b8,1,1,iret,'BEARAZ') ! check if observation outside range - - num_tovs_file = num_tovs_file + 1 - ! 2.0 Extract observation location and other required information ! QC1: judge if data is in the domain, read next record if not !------------------------------------------------------------------------ - ! rlat = bfr1bhdr(bufr_lat) - ! rlon = bfr1bhdr(bufr_lat) - ! if (rlon < 0.0) rlon = rlon+360.0 - - if(abs(bfr2bhdr(1)) <= 90. .and. abs(bfr2bhdr(2)) <= 360.)then - info%lat = bfr2bhdr(1) - info%lon = bfr2bhdr(2) - elseif(abs(bfr1bhdr(9)) <= 90. .and. abs(bfr1bhdr(10)) <= 360.)then - info%lat = bfr1bhdr(9) - info%lon = bfr1bhdr(10) - endif + if (idom .eq. 2) then + if(abs(bfr2bhdr(1)) <= 90. .and. abs(bfr2bhdr(2)) <= 360.)then + info_1d(itovs)%lat = bfr2bhdr(1) + info_1d(itovs)%lon = bfr2bhdr(2) + elseif(abs(bfr1bhdr(9)) <= 90. .and. abs(bfr1bhdr(10)) <= 360.)then + info_1d(itovs)%lat = bfr1bhdr(9) + info_1d(itovs)%lon = bfr1bhdr(10) + endif - call da_llxy (info, loc, outside, outside_all) + cycle + end if + + info = info_1d (itovs) + loc = loc_1d (itovs) + outside_all = outside_all_1d (itovs) + outside = outside_1d (itovs) if (outside_all) cycle @@ -494,6 +503,26 @@ bufrfile: do ibufr=1,numbufr call closbf(lnbufr) close(lnbufr) + if (idom .eq. 1) then + allocate ( info_1d (itovs) ) + allocate ( loc_1d (itovs) ) + allocate ( outside_1d (itovs) ) + allocate ( outside_all_1d (itovs) ) + end if + if (idom .eq. 2) then + call da_llxy_1d (info_1d(1:itovs), loc_1d(1:itovs), outside_1d(1:itovs), outside_all_1d(1:itovs)) + end if + if (idom .eq. 3) then + deallocate ( info_1d ) + deallocate ( loc_1d ) + deallocate ( outside_1d ) + deallocate ( outside_all_1d ) + end if + + end do domtest + + num_tovs_file = num_tovs_file + itovs + end do bufrfile if (thinning .and. num_tovs_global > 0 ) then From fe1f92b6d0a57c5d5d26f7e10f40d0d44acecd3d Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Mon, 17 Dec 2018 12:56:57 -0700 Subject: [PATCH 33/86] Update VARBC.in for GOES-16 ABI based on 15-23 APR 2018 spinup --- var/run/VARBC.in | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/var/run/VARBC.in b/var/run/VARBC.in index 79972afdab..a1ef703dfb 100644 --- a/var/run/VARBC.in +++ b/var/run/VARBC.in @@ -2187,19 +2187,19 @@ ------------------------------------------------ Platform_id Sat_id Sensor_id Nchanl Npredmax ------------------------------------------------ - 4 16 44 10 8 + 4 16 44 10 8 -----> Bias predictor statistics: Mean & Std & Nbgerr - 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 - 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 + 1.0 9181.9 8559.5 281.9 14.6 3.5 14.3 64.3 + 0.0 250.5 212.7 11.2 11.1 1.4 10.3 64.4 10000 10000 10000 10000 10000 10000 10000 10000 -----> Chanl_id Chanl_nb Pred_use(-1/0/1) Param - 1 1 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 2 2 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 3 3 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 4 4 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 5 5 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 6 6 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 7 7 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 8 8 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 9 9 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 - 10 10 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 1 1 1 1 1 1 1 -1 -1 -1 -1.175 0.496 -0.214 0.151 -0.447 + 2 2 1 1 1 1 1 -1 -1 -1 0.618 -0.002 0.051 0.152 0.060 + 3 3 1 1 1 1 1 -1 -1 -1 1.231 -0.031 0.069 0.082 0.075 + 4 4 1 1 1 1 1 -1 -1 -1 -0.151 -0.055 -0.003 -0.052 0.235 + 5 5 1 1 1 1 1 -1 -1 -1 -1.771 0.122 -0.190 0.353 -0.680 + 6 6 1 1 1 1 1 -1 -1 -1 -16.708 1.273 -2.270 -2.149 0.901 + 7 7 1 1 1 1 1 -1 -1 -1 -1.368 0.289 -0.190 0.568 -1.110 + 8 8 1 1 1 1 1 -1 -1 -1 -1.064 0.400 -0.183 0.825 -1.462 + 9 9 1 1 1 1 1 -1 -1 -1 -1.323 0.293 -0.195 0.859 -1.478 + 10 10 1 1 1 1 1 -1 -1 -1 -2.083 0.063 -0.143 0.314 -0.450 From 8a20078191a6d6edfb5baa4e433254eb9f1ab7db Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Mon, 28 Jan 2019 17:55:27 -0700 Subject: [PATCH 34/86] Small bugfixes to airs/atms 1d reading --- var/da/da_radiance/da_read_obs_bufrairs.inc | 1 + var/da/da_radiance/da_read_obs_bufratms.inc | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_bufrairs.inc b/var/da/da_radiance/da_read_obs_bufrairs.inc index 6153c29a3c..ac68a73bdb 100644 --- a/var/da/da_radiance/da_read_obs_bufrairs.inc +++ b/var/da/da_radiance/da_read_obs_bufrairs.inc @@ -386,6 +386,7 @@ bufrfile: do ibufr=1,numbufr if( abs(airsspot%clath) > R90 .or. & abs(airsspot%clonh) > R360 .or. & (abs(airsspot%clath) == R90 .and. airsspot%clonh /= ZERO) )then + irads = irads - 1 cycle loop_obspoints end if diff --git a/var/da/da_radiance/da_read_obs_bufratms.inc b/var/da/da_radiance/da_read_obs_bufratms.inc index f276677840..9622fd7b38 100644 --- a/var/da/da_radiance/da_read_obs_bufratms.inc +++ b/var/da/da_radiance/da_read_obs_bufratms.inc @@ -345,6 +345,9 @@ bufrfile: do ibufr=1,numbufr info_1d%lat = lat_save(1:nnum) info_1d%lon = lon_save(1:nnum) + deallocate(lat_save) + deallocate(lon_save) + ! Determine loc_1d, outside_1d, outside_all_1d !--------------------------------------------------------------------------------- call da_llxy_1d (info_1d, loc_1d, outside_1d, outside_all_1d) @@ -700,8 +703,6 @@ bufrfile: do ibufr=1,numbufr deallocate(Time_save) deallocate(BT_InOut_save) deallocate(Scanline_save) - deallocate(lat_save) - deallocate(lon_save) deallocate(satid_save) deallocate(obs_time_save) deallocate(satzen_save) From 3d282ec67551405b6448a5df96517ab6847e4808 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 13 Feb 2019 17:05:12 -0700 Subject: [PATCH 35/86] Cleanup of atms and seviri, add amsr2 1d llxy --- var/da/da_radiance/da_read_obs_bufratms.inc | 4 -- var/da/da_radiance/da_read_obs_bufrseviri.inc | 2 - var/da/da_radiance/da_read_obs_hdf5amsr2.inc | 44 +++++++++++++++++-- 3 files changed, 41 insertions(+), 9 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_bufratms.inc b/var/da/da_radiance/da_read_obs_bufratms.inc index 9622fd7b38..026b987cfd 100644 --- a/var/da/da_radiance/da_read_obs_bufratms.inc +++ b/var/da/da_radiance/da_read_obs_bufratms.inc @@ -366,10 +366,6 @@ bufrfile: do ibufr=1,numbufr ! rlat = bfr1bhdr(bufr_lat) ! rlon = bfr1bhdr(bufr_lat) ! if (rlon < 0.0) rlon = rlon+360.0 -! info%lat = lat_save(nn) -! info%lon = lon_save(nn) - -! call da_llxy (info, loc, outside, outside_all) info = info_1d (nn) loc = loc_1d (nn) outside = outside_1d (nn) diff --git a/var/da/da_radiance/da_read_obs_bufrseviri.inc b/var/da/da_radiance/da_read_obs_bufrseviri.inc index 78e6a9b342..10a850e985 100644 --- a/var/da/da_radiance/da_read_obs_bufrseviri.inc +++ b/var/da/da_radiance/da_read_obs_bufrseviri.inc @@ -368,7 +368,6 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) cycle read_loop end if - call da_llxy (info, loc, outside, outside_all) if (outside_all) cycle inst = 0 do i = 1, rtminit_nsensor @@ -502,7 +501,6 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) deallocate ( loc_1d ) deallocate ( outside_1d ) deallocate ( outside_all_1d ) - end if end do domtest diff --git a/var/da/da_radiance/da_read_obs_hdf5amsr2.inc b/var/da/da_radiance/da_read_obs_hdf5amsr2.inc index 8bb20c18e5..655b05ef8f 100644 --- a/var/da/da_radiance/da_read_obs_hdf5amsr2.inc +++ b/var/da/da_radiance/da_read_obs_hdf5amsr2.inc @@ -135,6 +135,11 @@ subroutine da_read_obs_hdf5amsr2 (iv, infile_tb,infile_clw) 'Brightness Temperature (res23,23.8GHz,V)','Brightness Temperature (res23,23.8GHz,H)',& 'Brightness Temperature (res36,36.5GHz,V)','Brightness Temperature (res36,36.5GHz,H)'/ + integer :: ii_1d + type(info_type), allocatable :: info_1d(:) + type(model_loc_type), allocatable :: loc_1d(:) + logical, allocatable :: outside_1d(:), outside_all_1d(:) + if (trace_use) call da_trace_entry("da_read_obs_hdf5amsr2") ! 0.0 Initialize variables @@ -678,6 +683,31 @@ subroutine da_read_obs_hdf5amsr2 (iv, infile_tb,infile_clw) call H5Fclose_f(fhnd2,iret) end if + + allocate ( info_1d (nscan*lo_rez_fov) ) + allocate ( loc_1d (nscan*lo_rez_fov) ) + allocate ( outside_1d (nscan*lo_rez_fov) ) + allocate ( outside_all_1d (nscan*lo_rez_fov) ) + + ii_1d = 0 + do iscan=1, nscan + do i = 1, 6 + idate5(i)=obstime(i, iscan) + end do + call da_get_julian_time(idate5(1),idate5(2),idate5(3),idate5(4),idate5(5),obs_time) + if ( obs_time < time_slots(0) .or. & + obs_time >= time_slots(num_fgat_time) ) cycle + do ifov=1, lo_rez_fov + ii_1d = ii_1d + 1 + info_1d(ii_1d)%lat = latlr(ifov,iscan) + info_1d(ii_1d)%lon = lonlr(ifov,iscan) + end do + end do + + ! Determine loc_1d, outside_1d, outside_all_1d + !--------------------------------------------------------------------------------- + call da_llxy_1d (info_1d(1:ii_1d), loc_1d(1:ii_1d), outside_1d(1:ii_1d), outside_all_1d(1:ii_1d)) + ! 2.0 Loop to read hdf file and assign information to a sequential structure !------------------------------------------------------------------------- @@ -689,6 +719,7 @@ subroutine da_read_obs_hdf5amsr2 (iv, infile_tb,infile_clw) head_allocated = .true. end if ! start scan_loop + ii_1d = 0 scan_loop: do iscan=1, nscan do i = 1, 6 idate5(i)=obstime(i, iscan) @@ -705,10 +736,12 @@ subroutine da_read_obs_hdf5amsr2 (iv, infile_tb,infile_clw) fov_loop: do ifov=1, lo_rez_fov num_amsr2_file = num_amsr2_file + 1 num_amsr2_file_local = num_amsr2_file_local + 1 - info%lat = latlr(ifov,iscan) - info%lon = lonlr(ifov,iscan) + ii_1d = ii_1d + 1 + info = info_1d (ii_1d) + loc = loc_1d (ii_1d) + outside = outside_1d (ii_1d) + outside_all = outside_all_1d (ii_1d) - call da_llxy (info, loc, outside, outside_all) if (outside_all) cycle fov_loop num_amsr2_global = num_amsr2_global + 1 @@ -790,6 +823,11 @@ subroutine da_read_obs_hdf5amsr2 (iv, infile_tb,infile_clw) ! Dellocate arrays deallocate (obstime) + deallocate ( info_1d ) + deallocate ( loc_1d ) + deallocate ( outside_1d ) + deallocate ( outside_all_1d ) + write(stdout,fmt='(3a,i7)') ' In file: ',trim(fname_tb(ifile)),' got num_amsr2_file : ',num_amsr2_file_local write(stdout,fmt='(3a,i7)') ' In file: ',trim(fname_tb(ifile)),' got num_amsr2_global : ',num_amsr2_global_local write(stdout,fmt='(3a,i7)') ' In file: ',trim(fname_tb(ifile)),' got num_amsr2_local : ',num_amsr2_local_local From 28d1d001e1613c41ea82967242dc57f846a494e7 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 13 Feb 2019 17:32:39 -0700 Subject: [PATCH 36/86] Cleanup commented code in abi reading routines --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 161 +------------------ 1 file changed, 2 insertions(+), 159 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 03868db544..2d743cef41 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -97,7 +97,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) character(len=14), parameter :: INST_PREFIX = 'OR_ABI-L1b-Rad' !! File reading variables - character(len=1000) :: fname, command !, fname_short + character(len=1000) :: fname, command character(len=50) :: list_file integer :: file_unit @@ -589,7 +589,6 @@ write(stdout,fmt='(A)') adjustl(trim(command)) ' data time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc fname = trim(this_view % filename(first_file)) -! fname = trim(this_view % fpath)//trim(fname_short) if ( .not.this_view % meta_initialized ) then !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -962,33 +961,11 @@ write(stdout,fmt='(A)') adjustl(trim(command)) pack(this_view % loc_1d % local (1:nrad_local) % y, domainmask_1d ) buf_loc ( buf_i:buf_f ) % x = & pack(this_view % loc_1d % local (1:nrad_local) % x, domainmask_1d ) -!!!! -! buf_loc ( buf_i:buf_f ) % j = & -! pack(this_view % loc_1d % local (1:nrad_local) % j, domainmask_1d ) -! buf_loc ( buf_i:buf_f ) % i = & -! pack(this_view % loc_1d % local (1:nrad_local) % i, domainmask_1d ) -! buf_loc ( buf_i:buf_f ) % dy = & -! pack(this_view % loc_1d % local (1:nrad_local) % dy, domainmask_1d ) -! buf_loc ( buf_i:buf_f ) % dx = & -! pack(this_view % loc_1d % local (1:nrad_local) % dx, domainmask_1d ) -! buf_loc ( buf_i:buf_f ) % dym = & -! pack(this_view % loc_1d % local (1:nrad_local) % dym, domainmask_1d ) -! buf_loc ( buf_i:buf_f ) % dxm = & -! pack(this_view % loc_1d % local (1:nrad_local) % dxm, domainmask_1d ) -!!!! else buf_real(buf_i:buf_f,:) = missing_r buf_int(buf_i:buf_f,:) = missing -!!!! ! buf_loc(buf_i:buf_f)%y = missing_r ! buf_loc(buf_i:buf_f)%x = missing_r -! buf_loc(buf_i:buf_f)%j = missing -! buf_loc(buf_i:buf_f)%i = missing -! buf_loc(buf_i:buf_f)%dy = missing_r -! buf_loc(buf_i:buf_f)%dx = missing_r -! buf_loc(buf_i:buf_f)%dym = missing_r -! buf_loc(buf_i:buf_f)%dxm = missing_r -!!!! end if #ifdef DM_PARALLEL !PERFORM COMMS @@ -998,14 +975,6 @@ write(stdout,fmt='(A)') adjustl(trim(command)) !Only x & y components of loc need to be communicated call mpi_bcast( buf_loc(buf_i:buf_f)%y, nbuf, true_mpi_real, iproc, comm, ierr ) call mpi_bcast( buf_loc(buf_i:buf_f)%x, nbuf, true_mpi_real, iproc, comm, ierr ) -!!!! -! call mpi_bcast( buf_loc(buf_i:buf_f)%j, nbuf, mpi_integer, iproc, comm, ierr ) -! call mpi_bcast( buf_loc(buf_i:buf_f)%i, nbuf, mpi_integer, iproc, comm, ierr ) -! call mpi_bcast( buf_loc(buf_i:buf_f)%dy, nbuf, true_mpi_real, iproc, comm, ierr ) -! call mpi_bcast( buf_loc(buf_i:buf_f)%dx, nbuf, true_mpi_real, iproc, comm, ierr ) -! call mpi_bcast( buf_loc(buf_i:buf_f)%dym, nbuf, true_mpi_real, iproc, comm, ierr ) -! call mpi_bcast( buf_loc(buf_i:buf_f)%dxm, nbuf, true_mpi_real, iproc, comm, ierr ) -!!!! #endif end do ProcLoop ! END SOLUTION 2 @@ -1033,7 +1002,6 @@ write(stdout,fmt='(A)') adjustl(trim(command)) ! Populate remainder of loc and determine in/outside patch allocate ( patchmask_1d (this_view % nrad_on_domain) ) allocate ( dummybool_2d (this_view % nrad_on_domain,1) ) -! patchmask_1d = .false. call da_llxy_1d ( locs = buf_loc, outside = dummybool_2d(:,1), do_xy = .false. ) patchmask_1d = .not.dummybool_2d(:,1) deallocate( dummybool_2d ) @@ -1305,22 +1273,6 @@ write(stdout,fmt='(A)') adjustl(trim(command)) abs( this_view % filedate(jfile) % obs_time / 60.D0 - & (this_view % filedate(ifile) % obs_time / 60.D0 - TEMPIR_delay_minutes) ) -! yr = this_view % filedate(jfile) % yr -! mt = this_view % filedate(jfile) % mt -! dy = this_view % filedate(jfile) % dy -! hr = this_view % filedate(jfile) % hr -! mn = this_view % filedate(jfile) % mn -! sc = this_view % filedate(jfile) % sc -! write(unit=stdout, & -! fmt='(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & -! ' this_time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc -! -!write(unit=stdout,fmt='(A,F14.2)') & -! ' this_time (min): ', this_view % filedate(jfile) % obs_time / 60.D0 -! -! write(unit=stdout,fmt='(A,F7.2,A)') & -! ' TEMPIR: time difference - ',TEMPIR_time_abs_diff,' minutes' - if ( TEMPIR_time_abs_diff .lt. TEMPIR_min_time_diff ) then TEMPIR_ifile = jfile TEMPIR_min_time_diff = TEMPIR_time_abs_diff @@ -1348,7 +1300,6 @@ write(stdout,fmt='(A)') adjustl(trim(command)) end if fname = trim(this_view % filename(ifile)) -! fname = trim(this_view % fpath)//trim(fname_short) call get_abil1b_bt( fname, & this_view % ys_local, this_view % ye_local, & this_view % xs_local, this_view % xe_local, & @@ -1364,7 +1315,6 @@ write(stdout,fmt='(A)') adjustl(trim(command)) if ( TEMPIR_ifile.gt.0 ) then fname = trim(this_view % filename(TEMPIR_ifile)) -! fname = trim(this_view % fpath)//trim(fname_short) call get_abil1b_bt( fname, & this_view % ys_local, this_view % ye_local, & this_view % xs_local, this_view % xe_local, & @@ -1730,7 +1680,6 @@ write(stdout,fmt='(A)') adjustl(trim(command)) deallocate(view_att) if (tot_files_used .lt. 1) then -!! write(unit=message(1),fmt='(A,I2,3A)') "Either no L1B data found or no matching fgat windows for GOES-",satellite_id," ABI using prefix ",INST_PREFIX, " for this process rank. This subdomain may have an unacceptable zenith angle or fall entirely outside the GOES viewing extent." write(unit=message(1),fmt=*) "Either no L1B data found or no matching fgat windows for GOES-",satellite_id," ABI using prefix ",INST_PREFIX, "for this process rank. This subdomain may have an unacceptable zenith angle or fall entirely outside the GOES viewing extent." ! write(unit=message(1),fmt='(A)') "Either no L1B data found or no matching" @@ -1744,7 +1693,7 @@ write(stdout,fmt='(A)') adjustl(trim(command)) end if !------------------------------------------------------ - ! NOTE: Remainder of this subroutine copied from da_read_obs_ncgoesimg.inc + ! NOTE: Remainder of this subroutine modified from da_read_obs_ncgoesimg.inc if (thinning .and. num_goesabi_global > 0 ) then #ifdef DM_PARALLEL @@ -2061,12 +2010,6 @@ subroutine get_abil1b_grid2_1d( yy_abi, xx_abi, req, rpol, pph, nam, satellite_i call get_abil1b_latlon_1d ( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) -!!!JJGDEBUG -! do n = lbound(yy_abi,1), ubound(yy_abi,1) -! call get_abil1b_latlon ( yy_abi(n), xx_abi(n), lat(n), lon(n), req, rpol, hh, nam ) -! end do -!!!JJGDEBUG - where( lat.eq.missing_r .OR. lon.eq.missing_r .OR. & isnan(lat) .OR. isnan(lon) ) earthmask = .false. @@ -2076,15 +2019,6 @@ subroutine get_abil1b_grid2_1d( yy_abi, xx_abi, req, rpol, pph, nam, satellite_i call da_get_sat_angles_1d( lat, lon, satellite_id, satzen, satazi ) -!!!JJGDEBUG -! do n = lbound(yy_abi,1), ubound(yy_abi,1) -! if ( earthmask(n) ) then -! call da_get_sat_angles( lat(n), lon(n), satellite_id, satzen(n), satazi(n) ) -! -! end if -! end do -!!!JJGDEBUG - where ( isnan(satzen) .or. satzen.gt.satzen_limit .or. satzen.eq.missing_r ) satzen = missing_r zenmask = .false. @@ -2097,64 +2031,6 @@ end subroutine get_abil1b_grid2_1d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!subroutine get_abil1b_grid2( yy_abi, xx_abi, req, rpol, pph, nam, satellite_id, & -! lat, lon, satzen, satazi, & -! earthmask, zenmask ) -! -! implicit none -! -! real, intent(in) :: yy_abi, xx_abi -! real(r_double), intent(in) :: req, rpol, pph, nam -! integer, intent(in) :: satellite_id -! -! ! GOES-ABI fields -! real, intent(out) :: lat, lon -! real, intent(out) :: satzen, satazi -! logical, intent(out) :: earthmask, zenmask -! -! ! Internal Variables -! type(info_type) :: info -! logical :: outside_all, dummy_bool -! -! integer :: iy, ix -! real(r_double) :: hh -! real, parameter :: satzen_limit=75.0 -! -! if (trace_use) call da_trace_entry("get_abil1b_grid2") -! -! lat = missing_r -! lon = missing_r -! satzen = missing_r -! satazi = missing_r -! earthmask=.false. -! zenmask=.false. -! -! hh=pph+req -! -! call get_abil1b_latlon ( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) -! -! if( lat.eq.missing_r .OR. lon.eq.missing_r .OR. & -! isnan(lat) .OR. isnan(lon) ) return -! -! earthmask=.true. -! -! call da_get_sat_angles(lat, lon, satellite_id, satzen, satazi) -!! call da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & -!! lat, lon, solzen, solazi ) -! -! if ( isnan(satzen) .or. satzen.gt.satzen_limit ) then -! satzen = missing_r -! return -! end if -! zenmask=.true. -! -! if (trace_use) call da_trace_exit("get_abil1b_grid2") -! -!end subroutine get_abil1b_grid2 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt, inst, ichan ) implicit none @@ -2169,8 +2045,6 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt, inst, ichan ) logical, intent(inout) :: radmask( ys:ye, xs:xe ) real, intent(out) :: bt( ys:ye, xs:xe ) -! real :: rad(ys:ye, xs:xe) -! integer :: DQF(ys:ye, xs:xe) real :: rad(xs:xe, ys:ye) integer :: DQF(xs:xe, ys:ye) @@ -2200,17 +2074,12 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt, inst, ichan ) ierr=nf_inq_varid( ncid, 'Rad', varid ) ierr=nf_get_vara_double ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), rad ) -! ierr=nf_get_vara_double ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), rad ) -! rad(ys:ye,xs:xe) ) ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) ierr=nf_get_att_double(ncid,varid,'add_offset',itp) rad=rad*slp+itp ierr=nf_inq_varid ( ncid, 'DQF', varid ) ierr=nf_get_vara_int ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), DQF ) -! ierr=nf_get_vara_int ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), DQF ) - -! DQF(ys:ye,xs:xe) ) ierr=nf_inq_varid( ncid, 'planck_bc1', varid ) ierr=nf_get_var_double( ncid, varid, bc1 ) @@ -2221,17 +2090,9 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt, inst, ichan ) ierr=nf_inq_varid( ncid, 'planck_fk2', varid ) ierr=nf_get_var_double( ncid, varid, fk2 ) -! radmask = ( radmask .and. (transpose(DQF).eq.0 .or. transpose(DQF).eq.1) & -! .and. transpose(rad).ge.0.0 ) - radmask = ( radmask .and. (transpose(DQF).eq.0 .or. transpose(DQF).eq.1) ) radmask = ( radmask .and. transpose(rad).ge.0.0 ) -!! radmask = ( radmask .and. (DQF.eq.0 .or. DQF.eq.1) & -!! .and. rad.ge.0.0 ) -! -! radmask = ( radmask .and. (DQF.eq.0 .or. DQF.eq.1) ) -! radmask = ( radmask .and. rad.ge.0.0 ) !!!JJGDEBUG ! if (rtm_option == rtm_option_crtm) then @@ -2247,7 +2108,6 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt, inst, ichan ) !!!JJGDEBUG where ( radmask ) -! bt = ( fk2 / ( log(( fk1 / rad ) + 1.0) ) - bc1 ) / bc2 bt = ( fk2 / ( log(( fk1 / transpose(rad) ) + 1.0) ) - bc1 ) / bc2 end where @@ -2255,22 +2115,6 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt, inst, ichan ) ! end if !!!JJGDEBUG -! do ix = xs, xe -! do iy = ys, ye -! if ( radmask( iy, ix ) ) then -! if( rad( iy, ix ).ge.0.0 .and. any(DQF( iy, ix ).eq.(/0,1/)) ) then -! bt( iy, ix ) = ( fk2 / ( log( ( fk1 / rad( iy, ix )) + 1. ) ) - bc1 ) / bc2 -! else -! radmask( iy, ix ) = .false. -! end if -! end if -! end do -! end do - -!#ifdef DM_PARALLEL -! call mpi_barrier(comm, ierr) -!#endif - ierr=nf_close(ncid) call handle_err('Error closing file',ierr) @@ -2315,7 +2159,6 @@ subroutine get_abil1b_terr( filename, ys, ye, xs, xe, terr ) nf_inq_varid( ncid, 'terr', varid ) ) call handle_err ( 'Error reading terrain height', & nf_get_vara_double ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), terr_trans ) ) -! nf_get_vara_double ( ncid, varid, (/ys,xs/), (/nykeep,nxkeep/), terr ) ) terr = transpose(terr_trans) call handle_err ( 'Error with _FillValue', & From d6451446063b22856b38eea0f78d90a0f15c186e Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Tue, 16 Apr 2019 16:26:55 -0600 Subject: [PATCH 37/86] Refactor for lower memory overhead before execute_command_line --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 151 ++++++++++--------- 1 file changed, 83 insertions(+), 68 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 2d743cef41..a841b23b46 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -83,6 +83,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer :: ichan, ifile, iview, ifgat, ipass, ioff, & jchan, jfile, jview, icount, io_stat, & n, i, j, iy, ix, jy, jx, iyl, ixl, iyfd, ixfd, iproc, subgrid + INTEGER :: cstat, estat + CHARACTER(LEN=100) :: cmsg !! Satellite variables integer(i_kind),parameter :: nchan = 10 @@ -92,7 +94,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) integer, parameter :: channel_list(nchan) = (/7,8,9,10,11,12,13,14,15,16/) !List of all available channels ! integer, parameter :: channel_index(channel_list(1):channel_list(nchan)) = (/1,2,3,4,5,6,7,8,9,10/) !List of all available channels - integer, parameter :: nviews=4 + integer, parameter :: nviews = 4 integer(i_kind) :: inst character(len=14), parameter :: INST_PREFIX = 'OR_ABI-L1b-Rad' @@ -312,6 +314,80 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) cld_qc_buffer = 0 end if + tot_files_used = 0 + use_view_mask = .false. + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Collect files available for all views + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do iview = 1, nviews + this_view => view_att(iview) + + if ( .not.this_view % select ) cycle + + write(unit=stdout,fmt='(5A)') 'Searching for GOES ', trim(this_view % name) ,' files in ', trim(this_view % fpath),'...' + + ! Query fpath for files that begin with INST_PREFIX, name, and for this satellite_id + fname = trim(INST_PREFIX)//trim(this_view % name_short) + list_file = 'INST'//trim(this_view % name_short) + + call da_get_unit(file_unit) + + ! Create list_file containing all files for this_view + if (rootproc) then + write(command,fmt='(5A,I2.2,2A)')& + "find ",trim(this_view % fpath), & + " \( -type l -o -type f \) -name '",trim(fname), & + "*G",satellite_id, & + "*' > ",trim(list_file) +! "*' -printf '%P\n' > ",trim(list_file) + + !WARNING: find command requires substantial memory for MESO list_file's +write(stdout,fmt='(A)') adjustl(trim(command)) + cmsg = "" + call execute_command_line ( adjustl(trim(command)), & + WAIT=.true., EXITSTAT=estat, CMDSTAT=cstat, CMDMSG=cmsg ) +write(stdout,*) 'estat: ', estat +write(stdout,*) 'cstat: ', cstat +write(stdout,*) 'cmsg: ', cmsg + + icount = 0 + io_stat = -1 + do while (io_stat .ne. 0) + open(unit=file_unit,file=trim(list_file), iostat = io_stat) + icount = icount + 1 + if (icount .gt. 10000) exit + end do + this_view % nfiles = 0 + do + read(file_unit, fmt=*, iostat = io_stat) + if ( io_stat .ne. 0 ) exit + this_view % nfiles = this_view % nfiles + 1 + end do + close(file_unit) + + i_dummy = this_view % nfiles + end if +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) + call mpi_bcast ( i_dummy(1), 1, mpi_integer, root, comm, ierr ) + this_view % nfiles = i_dummy(1) +#endif + if (this_view % nfiles .lt. 1) then + this_view % select = .false. + cycle + end if + + allocate(this_view % filename(this_view % nfiles)) + + ! Read the file names for this view + open(unit=file_unit,file=trim(list_file)) + read(file_unit, fmt='(A)') (this_view % filename(ifile), ifile=1,this_view % nfiles) + close(file_unit) + + call da_free_unit(file_unit) + end do + !! If Full Disk is selected, take 2 passes over the data: !! + 1st pass: (A) Determine portions of each view corresponding to this patch !! for each fgat and each channel across observed domain @@ -320,13 +396,14 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !! closer to fgat time !! + 2nd pass: read radiance values, convert to BT, calculate quantities for online cloud detection QC !! - !! Otherwise only take one pass, and duplicated data cannot be removed from CONUS/MESO + !! Otherwise only take one pass, and duplicated data cannot be removed from CONUS/MESO1/MESO2 npass = 1 - if (nviews.gt.1 .and. view_att(1) % select) npass = 2 - tot_files_used = 0 - use_view_mask = .false. + if (count(view_att(:) % select).gt.1 .and. view_att(1) % select) npass = 2 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Process data for views w/ nfiles > 1 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! do ipass = 1, npass write(unit=stdout,fmt=*) ' ' write(unit=stdout,fmt=*) ' ' @@ -340,63 +417,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if ( .not.this_view % select ) cycle - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! Collect files available for this view - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if (ipass .eq. 1) then - write(unit=stdout,fmt='(5A)') 'Searching for GOES ', trim(this_view % name) ,' files in ', trim(this_view % fpath),'...' - - ! Query fpath for files that begin with INST_PREFIX, name, and for this satellite_id - fname = trim(INST_PREFIX)//trim(this_view % name_short) - list_file = 'INST'//trim(this_view % name_short) - - call da_get_unit(file_unit) - - if (rootproc) then - write(command,fmt='(5A,I2.2,2A)')& - "find ",trim(this_view % fpath), & - " \( -type l -o -type f \) -name '",trim(fname), & - "*G",satellite_id, & - "*' > ",trim(list_file) -! "*' -printf '%P\n' > ",trim(list_file) - -write(stdout,fmt='(A)') adjustl(trim(command)) - call execute_command_line (adjustl(trim(command))) - - icount = 0 - io_stat = -1 - do while (io_stat .ne. 0) - open(unit=file_unit,file=trim(list_file), iostat = io_stat) - icount = icount + 1 - if (icount .gt. 1000) exit - end do - this_view % nfiles = 0 - do - read(file_unit, fmt=*, iostat = io_stat) - if ( io_stat .ne. 0 ) exit - this_view % nfiles = this_view % nfiles + 1 - end do - close(file_unit) - - i_dummy = this_view % nfiles - end if -#ifdef DM_PARALLEL - call mpi_barrier(comm, ierr) - call mpi_bcast ( i_dummy(1), 1, mpi_integer, root, comm, ierr ) - this_view % nfiles = i_dummy(1) -#endif - if (this_view % nfiles .lt. 1) then - if (iview .eq. 1) then - npass = 1 - end if - this_view % select = .false. - cycle - end if - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Allocate/init components for this_view !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - allocate(this_view % filename(this_view % nfiles)) allocate(this_view % filechan(this_view % nfiles)) allocate(this_view % filedate(this_view % nfiles)) allocate(this_view % file_fgat_match(this_view % nfiles,num_fgat_time)) @@ -418,17 +442,8 @@ write(stdout,fmt='(A)') adjustl(trim(command)) !! + fgat window length !! + channels used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! Read the file names for this view - open(unit=file_unit,file=trim(list_file)) - read(file_unit, fmt='(A)') (this_view % filename(ifile), ifile=1,this_view % nfiles) - close(file_unit) - - call da_free_unit(file_unit) - do ifile = 1, this_view % nfiles - !Grab the filename (without path) using INST_PREFIX fname = trim(this_view % filename(ifile)) ioff = index(fname, trim(INST_PREFIX)) @@ -537,7 +552,7 @@ write(stdout,fmt='(A)') adjustl(trim(command)) cycle end if end do - end if + end if ! ipass == 1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 42c7a35a64d55990089242fc54a3f9709677dfda Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 17 Apr 2019 18:56:53 -0600 Subject: [PATCH 38/86] Clean up execute_command_line interface plus update VARBC.in # of instruments --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 43 ++++++++++++-------- var/run/VARBC.in | 2 +- 2 files changed, 26 insertions(+), 19 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index a841b23b46..db0e6660e8 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -85,6 +85,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) n, i, j, iy, ix, jy, jx, iyl, ixl, iyfd, ixfd, iproc, subgrid INTEGER :: cstat, estat CHARACTER(LEN=100) :: cmsg + logical :: exists !! Satellite variables integer(i_kind),parameter :: nchan = 10 @@ -325,31 +326,36 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if ( .not.this_view % select ) cycle - write(unit=stdout,fmt='(5A)') 'Searching for GOES ', trim(this_view % name) ,' files in ', trim(this_view % fpath),'...' - - ! Query fpath for files that begin with INST_PREFIX, name, and for this satellite_id + ! Query fpath for files that match L1B naming conventions for this_view and satellite_id fname = trim(INST_PREFIX)//trim(this_view % name_short) - list_file = 'INST'//trim(this_view % name_short) + list_file = 'file_list_GOES-ABI_'//trim(this_view % name_short) call da_get_unit(file_unit) - ! Create list_file containing all files for this_view if (rootproc) then - write(command,fmt='(5A,I2.2,2A)')& - "find ",trim(this_view % fpath), & - " \( -type l -o -type f \) -name '",trim(fname), & - "*G",satellite_id, & - "*' > ",trim(list_file) + inquire(file=trim(list_file), exist=exists) + if ( .not.exists ) then + ! Create list_file containing all files for this_view + write(unit=stdout,fmt='(5A)') 'Searching for GOES ', trim(this_view % name) ,' files in ', trim(this_view % fpath),'...' + + write(command,fmt='(5A,I2.2,2A)')& + "find ",trim(this_view % fpath), & + " \( -type l -o -type f \) -name '",trim(fname), & + "*G",satellite_id, & + "*' > ",trim(list_file) ! "*' -printf '%P\n' > ",trim(list_file) - !WARNING: find command requires substantial memory for MESO list_file's -write(stdout,fmt='(A)') adjustl(trim(command)) - cmsg = "" - call execute_command_line ( adjustl(trim(command)), & - WAIT=.true., EXITSTAT=estat, CMDSTAT=cstat, CMDMSG=cmsg ) -write(stdout,*) 'estat: ', estat -write(stdout,*) 'cstat: ', cstat -write(stdout,*) 'cmsg: ', cmsg + write(stdout,fmt='(A)') 'WARNING find requires substantial memory. It is recommended to issue' + write(stdout,fmt='(A)') 'WARNING the following from the command line before running WRFDA:' + write(stdout,fmt='(A)') adjustl(trim(command)) + cmsg = "" + call execute_command_line ( adjustl(trim(command)), & + WAIT=.true., EXITSTAT=estat, CMDSTAT=cstat, CMDMSG=cmsg ) + write(stdout,*) 'estat: ', estat + write(stdout,*) 'cstat: ', cstat + write(stdout,*) 'cmsg: ', cmsg + end if + write(unit=stdout,fmt='(5A)') 'Using GOES ', trim(this_view % name) ,' files listed in ', trim(list_file) icount = 0 io_stat = -1 @@ -358,6 +364,7 @@ write(stdout,*) 'cmsg: ', cmsg icount = icount + 1 if (icount .gt. 10000) exit end do + this_view % nfiles = 0 do read(file_unit, fmt=*, iostat = io_stat) diff --git a/var/run/VARBC.in b/var/run/VARBC.in index e2ba6f4cf4..a3295bf537 100644 --- a/var/run/VARBC.in +++ b/var/run/VARBC.in @@ -1,5 +1,5 @@ VARBC version 1.0 - Number of instruments: - 38 + 40 ------------------------------------------------ Platform_id Sat_id Sensor_id Nchanl Npredmax ------------------------------------------------ From 84b435491b5d71f525b7ac77f45a06f73079c253 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Tue, 30 Apr 2019 13:52:46 -0600 Subject: [PATCH 39/86] Reduce ABI printouts and change ptotal to account for thinning modified: da_radiance/da_read_obs_ncgoesabi.inc --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 85 +++++++++++--------- 1 file changed, 48 insertions(+), 37 deletions(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index db0e6660e8..f1bbf4395f 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -194,7 +194,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Other work variables real(r_double) :: dlon_earth,dlat_earth,dlon_earth_deg,dlat_earth_deg real(r_double) :: ngoes - integer(i_kind) :: num_goesabi_local, num_goesabi_global, num_goesabi_used, & + integer(i_kind) :: num_goesabi_local, num_goesabi_global, & + num_goesabi_used, num_goesabi_used_fgat(num_fgat_time), & num_goesabi_used_tmp, num_goesabi_thinned integer(i_kind) :: itx, itt real, allocatable :: in(:), out(:) @@ -304,10 +305,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) nullify (head % next ) p => head - num_goesabi_local = 0 - num_goesabi_global = 0 - num_goesabi_used = 0 - num_goesabi_thinned = 0 + num_goesabi_local = 0 + num_goesabi_global = 0 + num_goesabi_used_fgat = 0 + num_goesabi_thinned = 0 if ( use_clddet_zz ) then cld_qc_buffer = 10 @@ -416,7 +417,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) write(unit=stdout,fmt=*) ' ' write(unit=stdout,fmt='(A,I0,A,I2.2,A)') & 'Starting pass ',ipass,& - ' of GOES-',satellite_id,' data processing' + ' of GOES-',satellite_id,' ABI data processing' !! Loop over the available views for this instrument (ABI) do iview = 1, nviews @@ -594,9 +595,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if (first_file .eq. 0) cycle fgat_loop if ( sum(this_view % nfiles_used(:)).eq.0) & - write(unit=stdout,fmt='(A,I0,2A)') & - 'Processing GOES-',satellite_id,' ABI data for view: ', trim(this_view % name) - write(unit=stdout,fmt=*) '' + write(unit=stdout,fmt='(2A)') & + 'Processing data for view: ', trim(this_view % name) write(unit=stdout,fmt='(2A)') & ' fgat time: ',fgat_times_c(ifgat) @@ -618,8 +618,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Only ny_global and nx_global need to be read for all views, but this is a cheap subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - write(unit=stdout,fmt='(A)') & - ' Reading abi metadata...' +! write(unit=stdout,fmt='(A)') & +! ' Reading abi metadata...' this_view % meta_initialized = .true. @@ -658,8 +658,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) DoGridGen: if ( this_view % moving .or. .not.this_view % grid_initialized ) then ! Read grid from file, convert to lat, lon, satzen, satazi - write(unit=stdout,fmt='(2A)') & - ' Establishing abi grid info...' +! write(unit=stdout,fmt='(2A)') & +! ' Establishing abi grid info...' this_view % grid_initialized = .true. @@ -760,8 +760,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) deallocate( iy_1d ) deallocate( ix_1d ) - write(unit=stdout,fmt='(3A,I0)') & - ' ',trim(this_view % name),' locations processed on this core: ', nrad_local +! write(unit=stdout,fmt='(3A,I0)') & +! ' ',trim(this_view % name),' locations processed on this core: ', nrad_local if (nrad_local .gt. 0) & call get_abil1b_grid2_1d( yy_1d(1:nrad_local), xx_1d(1:nrad_local), & @@ -1075,10 +1075,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) this_view % xs_p_fd = this_view % xs_p + this_view % xoff_fd - 1 this_view % xe_p_fd = this_view % xe_p + this_view % xoff_fd - 1 - write(stdout,*) 'ABI grid extents for this view:' - write(stdout,'(A,4I10)') 'ys_p, ye_p, xs_p, xe_p ',this_view % ys_p, this_view % ye_p, this_view % xs_p, this_view % xe_p - write(stdout,*) 'ABI grid extents for Full Disk:' - write(stdout,'(A,4I10)') 'ys_p_fd, ye_p_fd, xs_p_fd, xe_p_fd',this_view % ys_p_fd, this_view % ye_p_fd, this_view % xs_p_fd, this_view % xe_p_fd +! write(stdout,*) 'ABI grid extents for this view:' +! write(stdout,'(A,4I10)') 'ys_p, ye_p, xs_p, xe_p ',this_view % ys_p, this_view % ye_p, this_view % xs_p, this_view % xe_p +! write(stdout,*) 'ABI grid extents for Full Disk:' +! write(stdout,'(A,4I10)') 'ys_p_fd, ye_p_fd, xs_p_fd, xe_p_fd',this_view % ys_p_fd, this_view % ye_p_fd, this_view % xs_p_fd, this_view % xe_p_fd ! Setup ZZ clddet extents this_view % ys_local = max(this_view % ys_p - cld_qc_buffer, 1) @@ -1115,8 +1115,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) else this_view % nrad_on_patch_cldqc = 0 end if - write(unit=stdout,fmt='(3A,I0)') & - ' ',trim(this_view % name),' locations within this subdomain eligible for ZZ clddet: ', this_view % nrad_on_patch_cldqc +! write(unit=stdout,fmt='(3A,I0)') & +! ' ',trim(this_view % name),' locations within this subdomain eligible for ZZ clddet: ', this_view % nrad_on_patch_cldqc !FREE UP POINTERS AND BUFFERS @@ -1153,7 +1153,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if ( (ipass.lt.npass .and. iview.eq.1) .or. .not.use_view_mask ) then num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain_cldqc - ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain_cldqc + !ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain_cldqc end if PatchMatch: if (this_view % nrad_on_patch_cldqc .gt. 0) then @@ -1252,8 +1252,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) iview, ichan, ifgat ) ) ) then deallocate(allmask_p, readmask_p) - write(unit=stdout,fmt='(3A,I0)') & - ' ZERO pixels selected for ',trim(this_view % name),' on band ', channel_list(ichan) +! write(unit=stdout,fmt='(3A,I0)') & +! ' ZERO pixels selected for ',trim(this_view % name),' on band ', channel_list(ichan) this_view % nfiles_used(ifgat) = this_view % nfiles_used(ifgat) - 1 cycle end if @@ -1301,12 +1301,12 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if end do if ( TEMPIR_min_time_diff .gt. 0.5 * TEMPIR_delay_minutes ) then - write(unit=stdout,fmt='(A,F7.2,A)') & - ' TEMPIR: minimum time difference is too large - ',TEMPIR_min_time_diff,' minutes' +! write(unit=stdout,fmt='(A,F7.2,A)') & +! ' TEMPIR: minimum time difference is too large - ',TEMPIR_min_time_diff,' minutes' TEMPIR_ifile = -1 - else - write(unit=stdout,fmt='(A,F7.2,A)') & - ' TEMPIR: minimum time difference is accetable - ',TEMPIR_min_time_diff,' minutes' +! else +! write(unit=stdout,fmt='(A,F7.2,A)') & +! ' TEMPIR: minimum time difference is accetable - ',TEMPIR_min_time_diff,' minutes' end if end if @@ -1348,9 +1348,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) hr = this_view % filedate(TEMPIR_ifile) % hr mn = this_view % filedate(TEMPIR_ifile) % mn sc = this_view % filedate(TEMPIR_ifile) % sc - write(unit=stdout, & - fmt='(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & - ' TEMPIR time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc +! write(unit=stdout, & +! fmt='(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & +! ' TEMPIR time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc end if first_chan = (this_view % nfiles_used(ifgat).eq.1) @@ -1432,7 +1432,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if if (first_chan) then - num_goesabi_used = num_goesabi_used + 1 + num_goesabi_used_fgat(ifgat) = num_goesabi_used_fgat(ifgat) + 1 write(unit=info % date_char, & fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & @@ -1756,7 +1756,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) p => head prev => head head_found = .false. - num_goesabi_used_tmp = num_goesabi_used + num_goesabi_used_tmp = sum(num_goesabi_used_fgat) do j = 1, num_goesabi_used_tmp n = p % sensor_index @@ -1790,7 +1790,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if deallocate ( current ) num_goesabi_thinned = num_goesabi_thinned + 1 - num_goesabi_used = num_goesabi_used - 1 + num_goesabi_used_fgat(ifgat) = num_goesabi_used_fgat(ifgat) - 1 continue end if @@ -1810,19 +1810,30 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if ! End of thinning !stop + num_goesabi_used = sum(num_goesabi_used_fgat) iv % total_rad_pixel = iv % total_rad_pixel + num_goesabi_used iv % total_rad_channel = iv % total_rad_channel + num_goesabi_used*nchan iv % info(radiance) % nlocal = iv % info(radiance) % nlocal + num_goesabi_used iv % info(radiance) % ntotal = iv % info(radiance) % ntotal + num_goesabi_global +#ifdef DM_PARALLEL + do i = 1, num_fgat_time + call mpi_allreduce( num_goesabi_used_fgat(i), & + ptotal(i), & + 1, mpi_integer, mpi_sum, comm, ierr ) + end do +#else + ptotal(i) = num_goesabi_used_fgat(i) +#endif + do i = 1, num_fgat_time ptotal(i) = ptotal(i) + ptotal(i-1) iv % info(radiance) % ptotal(i) = iv % info(radiance) % ptotal(i) + ptotal(i) end do - if ( iv % info(radiance) % ptotal(num_fgat_time) /= iv % info(radiance) % ntotal ) then + if ( iv % info(radiance) % ptotal(num_fgat_time) /= (iv % info(radiance) % ntotal - num_goesabi_thinned) ) then write(unit=message(1),fmt='(A,I10,A,I10)') & - "Number of ntotal:",iv % info(radiance) % ntotal," is different from the sum of ptotal:", iv % info(radiance) % ptotal(num_fgat_time) + "Number of ntotal - nthinned:",iv % info(radiance) % ntotal - num_goesabi_thinned," is different from the sum of ptotal:", iv % info(radiance) % ptotal(num_fgat_time) call da_warning(__FILE__,__LINE__,message(1:1)) endif From ca430cf6e109d2da93dadefed08dfb56904723ed Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 1 May 2019 16:16:42 -0600 Subject: [PATCH 40/86] Revert 1d_llxy for non-ABI observations These modifications may cause a bug and need to be thoroughly tested in a separate PR. modified: da_obs_io/da_obs_io.f90 modified: da_obs_io/da_read_obs_bufr.inc modified: da_radiance/da_read_obs_bufrairs.inc modified: da_radiance/da_read_obs_bufratms.inc modified: da_radiance/da_read_obs_bufriasi.inc modified: da_radiance/da_read_obs_bufrseviri.inc modified: da_radiance/da_read_obs_bufrssmis.inc modified: da_radiance/da_read_obs_bufrtovs.inc modified: da_radiance/da_read_obs_hdf5amsr2.inc modified: da_tools/da_llxy.inc --- var/da/da_obs_io/da_obs_io.f90 | 2 +- var/da/da_obs_io/da_read_obs_bufr.inc | 235 +++++++----------- var/da/da_radiance/da_read_obs_bufrairs.inc | 160 ++++-------- var/da/da_radiance/da_read_obs_bufratms.inc | 34 +-- var/da/da_radiance/da_read_obs_bufriasi.inc | 101 +++----- var/da/da_radiance/da_read_obs_bufrseviri.inc | 90 ++----- var/da/da_radiance/da_read_obs_bufrssmis.inc | 100 +++----- var/da/da_radiance/da_read_obs_bufrtovs.inc | 107 +++----- var/da/da_radiance/da_read_obs_hdf5amsr2.inc | 44 +--- var/da/da_tools/da_llxy.inc | 1 - 10 files changed, 279 insertions(+), 595 deletions(-) diff --git a/var/da/da_obs_io/da_obs_io.f90 b/var/da/da_obs_io/da_obs_io.f90 index 66e3f3bf4a..b12f5aed36 100644 --- a/var/da/da_obs_io/da_obs_io.f90 +++ b/var/da/da_obs_io/da_obs_io.f90 @@ -43,7 +43,7 @@ module da_obs_io use da_par_util1, only : da_proc_sum_int use da_physics, only : da_tp_to_qs use da_reporting, only : da_warning, message, da_error - use da_tools, only : da_llxy, da_llxy_1d, da_get_julian_time, da_geo2msl1, da_msl2geo1 + use da_tools, only : da_llxy, da_get_julian_time, da_geo2msl1, da_msl2geo1 use da_tools_serial, only : da_free_unit, da_get_unit, da_advance_time use da_tracing, only : da_trace_entry, da_trace_exit diff --git a/var/da/da_obs_io/da_read_obs_bufr.inc b/var/da/da_obs_io/da_read_obs_bufr.inc index 3ece00f16e..bf84e7b04a 100644 --- a/var/da/da_obs_io/da_read_obs_bufr.inc +++ b/var/da/da_obs_io/da_read_obs_bufr.inc @@ -89,17 +89,11 @@ subroutine da_read_obs_bufr (iv) integer :: nlevels_BUFR integer :: kx_BUFR real :: pco_BUFR(8,255) - logical :: outside type(datalink_BUFR), pointer :: next end type datalink_BUFR type(datalink_BUFR),pointer :: head=>null(), plink=>null() - integer :: idom, isubset - type (info_type), allocatable :: info_1d(:) - type (model_loc_type), allocatable :: loc_1d(:) - logical, allocatable :: outside_1d(:), outside_all_1d(:) - if (trace_use) call da_trace_entry("da_read_obs_bufr") ! 0.0 Initialize variables @@ -135,7 +129,7 @@ subroutine da_read_obs_bufr (iv) tp(:) = 0 -! 1.0 Establish file open/read settings +! 1.0 Open file !---------------------------------------------------------------- ! !check if input file exists @@ -186,11 +180,48 @@ bufrfile: do ibufr=1,numbufr filename='ob1.bufr' endif !yw end added - - + ! -! We want to use specific unit number to read prepbufr data, which enables us to control its endianness - iunit = 96 +! We want to use specific unit number to read prepbufr data, which enables us to control its endianness + iunit = 96 + + open(unit = iunit, FILE = trim(filename), & + iostat = iost, form = 'unformatted', STATUS = 'OLD') + if (iost /= 0) then + write(unit=message(1),fmt='(A,I5,A)') & + "Error",iost," opening PREPBUFR obs file "//trim(filename) + call da_warning(__FILE__,__LINE__,message(1:1)) + if ( num_fgat_time == 1 ) then + call da_free_unit(iunit) + if (trace_use) call da_trace_exit("da_read_obs_bufr") + return + else + cycle bufrfile + end if + end if + ! open observation error table if provided. + call da_get_unit(junit) + open (unit=junit, file='obs_errtable', form='formatted', status='old', & + iostat=iost) + if ( iost /= 0 ) then + use_errtable = .false. + call da_free_unit(junit) + else + use_errtable = .true. + write(unit=message(1),fmt='(A)') & + "obs_errtable file is found. Will use user-provided obs errors." + call da_message(message(1:1)) + end if + if ( use_errtable ) then + read_loop: do + read (junit,'(1x,i3)',iostat=iost) itype + if ( iost /=0 ) exit read_loop + do k = 1, 33 + read (junit,'(1x,6e12.5)',iostat=iost) (oetab(itype,k,ivar),ivar=1,6) + if ( iost /=0 ) exit read_loop + end do + end do read_loop + end if hdstr='SID XOB YOB DHR TYP ELV T29' obstr='POB QOB TOB ZOB UOB VOB PWO CAT' ! observation @@ -198,28 +229,6 @@ bufrfile: do ibufr=1,numbufr oestr='POE QOE TOE NUL WOE NUL PWE NUL' ! observation error pcstr='PPC QPC TPC ZPC WPC NUL PWP NUL' ! program code - -! 2.0 read data, including pre-reading lat/lon -!---------------------------------------------------------------- - - ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) - domtest: do idom = 1, 3 - - open(unit = iunit, FILE = trim(filename), & - iostat = iost, form = 'unformatted', STATUS = 'OLD') - if (iost /= 0) then - write(unit=message(1),fmt='(A,I5,A)') & - "Error",iost," opening PREPBUFR obs file "//trim(filename) - call da_warning(__FILE__,__LINE__,message(1:1)) - if ( num_fgat_time == 1 ) then - call da_free_unit(iunit) - if (trace_use) call da_trace_exit("da_read_obs_bufr") - return - else - cycle bufrfile - end if - end if - call openbf(iunit,'IN',iunit) call datelen(10) @@ -234,44 +243,21 @@ bufrfile: do ibufr=1,numbufr end if !rewind(iunit) - if (idom .eq. 1) then - write(unit=message(1),fmt='(a,i10)') 'BUFR file date is: ', idate - call da_message(message(1:1)) - end if - if (idom .eq. 3) then - ! open observation error table if provided. - call da_get_unit(junit) - open (unit=junit, file='obs_errtable', form='formatted', status='old', & - iostat=iost) - if ( iost /= 0 ) then - use_errtable = .false. - call da_free_unit(junit) - else - use_errtable = .true. - write(unit=message(1),fmt='(A)') & - "obs_errtable file is found. Will use user-provided obs errors." - call da_message(message(1:1)) - end if - if ( use_errtable ) then - read_loop: do - read (junit,'(1x,i3)',iostat=iost) itype - if ( iost /=0 ) exit read_loop - do k = 1, 33 - read (junit,'(1x,6e12.5)',iostat=iost) (oetab(itype,k,ivar),ivar=1,6) - if ( iost /=0 ) exit read_loop - end do - end do read_loop - end if - end if + write(unit=message(1),fmt='(a,i10)') 'BUFR file date is: ', idate + call da_message(message(1:1)) - end_of_file = .false. + +! 2.0 read data +! scan reports first +!-------------------------------------------------------------- + match = .false. + end_of_file = .false. outside_all = .false. outside_time = .false. - isubset = 1 - reports: do while ( .not. end_of_file ) - if ( match .or. outside_all .or. outside_time .or. idom.eq.1) then + + if ( match .or. outside_all .or. outside_time ) then call readns(iunit,subset,idate,iret) ! read in the next subset if ( iret /= 0 ) then write(unit=message(1),fmt='(A,I3,A,I3)') & @@ -280,11 +266,10 @@ bufrfile: do ibufr=1,numbufr !call da_warning(__FILE__,__LINE__,message(1:1)) exit reports end if - - isubset = isubset + 1 !increment isubset for every call to readns - if (idom .eq. 1) cycle reports end if + num_report = num_report+1 + call ufbint(iunit,hdr,7,1,iret2,hdstr) call ufbint(iunit,pmo,2,1,nlevels,'PMO PMQ') call ufbint(iunit,qms,8,255,nlevels,qmstr) @@ -293,26 +278,45 @@ bufrfile: do ibufr=1,numbufr call ufbint(iunit,obs,8,255,nlevels,obstr) r8sid = hdr(1) - if (idom .eq. 2) then - info_1d (isubset) % name(1:8) = subset - info_1d (isubset) % name(9:40) = ' ' - info_1d (isubset) % id(1:5) = csid(1:5) - info_1d (isubset) % id(6:40) = ' ' - info_1d (isubset) % dhr = hdr(4) ! difference in hour - info_1d (isubset) % elv = hdr(6) - info_1d (isubset) % lon = hdr(2) - info_1d (isubset) % lat = hdr(3) - - outside_all = .true. + platform % info % name(1:8) = subset + platform % info % name(9:40) = ' ' + platform % info % id(1:5) = csid(1:5) + platform % info % id(6:40) = ' ' + platform % info % dhr = hdr(4) ! difference in hour + platform % info % elv = hdr(6) + platform % info % lon = hdr(2) + platform % info % lat = hdr(3) - cycle reports + ! blacklisted stations should be handled through an external table. + ! For now, temporary fix is implemented here for known incorrect + ! station info in NCEP PREPBUFR file + if ( trim(platform%info%id) == 'BGQQ' ) then + platform%info%elv = 19 + platform%info%lon = -69.21 + platform%info%lat = 77.46 + end if + if ( trim(platform%info%id) == 'UWKE' ) then + platform%info%elv = 194 + platform%info%lon = 52.09 + platform%info%lat = 55.56 end if - num_report = num_report+1 + ! Put a check on Lon and Lat + if ( platform%info%lon >= 180.0 ) platform%info%lon = platform%info%lon - 360.0 + ! Fix funny wind direction at Poles + !if (platform%info%lat < -89.9999 .or. platform%info%lat > 89.9999) then + ! platform%info%lon = 0.0 + !end if + platform%info%lat = max(platform%info%lat, -89.95) + platform%info%lat = min(platform%info%lat, 89.95) - platform % info = info_1d(isubset) + ! Restrict to a range of reports, useful for debugging + + if (num_report < report_start) cycle reports + if (num_report > report_end) exit reports + + call da_llxy (platform%info, platform%loc,outside, outside_all) - outside_all = outside_all_1d(isubset) if (outside_all) then num_outside_all = num_outside_all + 1 if ( print_detail_obs ) then @@ -323,13 +327,6 @@ bufrfile: do ibufr=1,numbufr cycle reports end if - ! Restrict to a range of reports, useful for debugging - if (num_report < report_start) cycle reports - if (num_report > report_end) exit reports - - outside = outside_1d(isubset) - platform%loc = loc_1d(isubset) - ! check date write(cdate,'(i10)') idate write(dmn,'(i4,a1)') int(platform%info%dhr*60.0), 'm' @@ -399,7 +396,6 @@ bufrfile: do ibufr=1,numbufr if ( iret /= 0 ) then end_of_file = .true. else - isubset = isubset + 1 !increment isubset for every call to readns match_check: do call ufbint(iunit,hdr2,7,1,iret2,hdstr) ! check if this subset and the previous one are matching mass and wind @@ -841,7 +837,6 @@ bufrfile: do ibufr=1,numbufr plink%kx_BUFR=kx plink%t29_BUFR=t29 plink%pco_BUFR=pco - plink%outside = outside num_p=num_p+1 @@ -1141,58 +1136,14 @@ bufrfile: do ibufr=1,numbufr plink%kx_BUFR=kx plink%t29_BUFR=t29 plink%pco_BUFR=pco - plink%outside = outside - + num_p=num_p+1 end do dup_loop end if !3dvar and 4dvar end do reports - call closbf(iunit) - close(iunit) - - if (idom .eq. 1) then - allocate ( info_1d (isubset) ) - allocate ( loc_1d (isubset) ) - allocate ( outside_1d (isubset) ) - allocate ( outside_all_1d (isubset) ) - end if - if (idom .eq. 2) then - ! blacklisted stations should be handled through an external table. - ! For now, temporary fix is implemented here for known incorrect - ! station info in NCEP PREPBUFR file - where ( (info_1d % id(1:4)) == 'BGQQ' ) - info_1d % elv = 19 - info_1d % lon = -69.21 - info_1d % lat = 77.46 - end where - where ( (info_1d % id(1:4)) == 'UWKE' ) - info_1d % elv = 194 - info_1d % lon = 52.09 - info_1d % lat = 55.56 - end where - - ! Put a check on Lon and Lat - where ( info_1d (:) % lon >= 180.0 ) info_1d (:) % lon = info_1d (:) % lon - 360.0 - where ( info_1d (:) % lat < -89.95 ) info_1d (:) % lat = -89.95 - where ( info_1d (:) % lat > 89.95 ) info_1d (:) % lat = 89.95 - - !JJG, NOTE: This llxy work/memory could be divided amongst processors by assigning a subgroup of the subsets to each process. - ! Ultimately all subsets that are .not.outside_all need to have outside_1d and loc_1d values populated on - ! each processor. This procedure is shown in da_read_obs_ncgoesabi with two calls to da_llxy_1d and - ! communications of info and loc in between those two calls. - - call da_llxy_1d (info_1d(1:isubset), loc_1d(1:isubset), outside_1d(1:isubset), outside_all_1d(1:isubset)) - end if - if (idom .eq. 3) then - deallocate ( info_1d ) - deallocate ( loc_1d ) - deallocate ( outside_1d ) - deallocate ( outside_all_1d ) - end if - - end do domtest - +call closbf(iunit) +close(iunit) if ( use_errtable ) then close(junit) call da_free_unit(junit) @@ -1230,7 +1181,7 @@ end do bufrfile if (dlon_earth >= 360.0) dlon_earth = dlon_earth - 360.0 dlat_earth = dlat_earth * deg2rad dlon_earth = dlon_earth * deg2rad - outside = plink%outside + call da_llxy (plink%platform_BUFR%info, plink%platform_BUFR%loc,outside, outside_all) ! Loop over duplicating obs for global ndup = 1 @@ -1627,7 +1578,7 @@ end if if (dlon_earth >= 360.0) dlon_earth = dlon_earth - 360.0 dlat_earth = dlat_earth * deg2rad dlon_earth = dlon_earth * deg2rad - outside = plink%outside + call da_llxy (plink%platform_BUFR%info, plink%platform_BUFR%loc,outside, outside_all) ndup = 1 if (global .and. & (plink%platform_BUFR%loc%i < ids .or. plink%platform_BUFR%loc%i >= ide)) ndup= 2 diff --git a/var/da/da_radiance/da_read_obs_bufrairs.inc b/var/da/da_radiance/da_read_obs_bufrairs.inc index ac68a73bdb..e2d73e9569 100644 --- a/var/da/da_radiance/da_read_obs_bufrairs.inc +++ b/var/da/da_radiance/da_read_obs_bufrairs.inc @@ -87,8 +87,6 @@ subroutine da_read_obs_bufrairs(obstype,iv,infile) ! BUFR talble file sequencial number character(len=512) :: table_file -! BUFR functions - integer(i_kind) :: ireadsb,ireadmg ! Variables for BUFR IO type(aquaspot_list) :: aquaspot @@ -156,11 +154,6 @@ subroutine da_read_obs_bufrairs(obstype,iv,infile) type(model_loc_type) :: loc type (datalink_type), pointer :: head, p, current, prev - integer :: idom, irads - type(info_type), allocatable :: info_1d(:) - type(model_loc_type), allocatable :: loc_1d(:) - logical, allocatable :: outside_1d(:), outside_all_1d(:) - if (trace_use) call da_trace_entry("da_read_obs_bufrairs") ! 0.0 Initialize variables @@ -279,16 +272,6 @@ bufrfile: do ibufr=1,numbufr lnbufr=97 - if ( ibufr == 1 ) then - allocate ( head ) - ! allocate ( head % tb (1:nchan) ) - nullify ( head % next ) - p => head - endif - - ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) - domtest: do idom = 1, 3 - open(unit=lnbufr,file=trim(filename),form='unformatted',iostat = iost, status = 'old') if (iost /= 0) then call da_warning(__FILE__,__LINE__, & @@ -308,43 +291,44 @@ bufrfile: do ibufr=1,numbufr end if call datelen(10) + ! 2.0 Read header !--------------------------- call readmg(lnbufr,subset,idate,iret) - if (idom .eq. 1) then - iy = 0 - im = 0 - idd = 0 - ihh = 0 - if( iret /= 0 ) goto 1000 ! no data? - - write(unit=date,fmt='( i10)') idate - read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh - write(unit=stdout,fmt='(a,4i4,2x,a)') & - 'Bufr file date is ',iy,im,idd,ihh,trim(infile) - end if + iy = 0 + im = 0 + idd = 0 + ihh = 0 + if( iret /= 0 ) goto 1000 ! no data? + + write(unit=date,fmt='( i10)') idate + read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh + write(unit=stdout,fmt='(a,4i4,2x,a)') & + 'Bufr file date is ',iy,im,idd,ihh,trim(infile) ! 3.0 Loop over observations !---------------------------- - irads = 0 - do while (ireadmg(lnbufr,subset,idate)==0) - loop_obspoints: do while (ireadsb(lnbufr)==0) - -! loop_obspoints: do -! -!! 3.1 Read headder -!!------------------------------- -! call readsb(lnbufr,iret) -! -! if( iret /=0 )then -! call readmg(lnbufr,subset,idate,iret) -! if( iret /= 0 ) exit loop_obspoints ! end of file -! cycle loop_obspoints -! end if + if ( ibufr == 1 ) then + allocate ( head ) + ! allocate ( head % tb (1:nchan) ) + nullify ( head % next ) + p => head + endif + + loop_obspoints: do + +! 3.1 Read headder +!------------------------------- + call readsb(lnbufr,iret) + + if( iret /=0 )then + call readmg(lnbufr,subset,idate,iret) + if( iret /= 0 ) exit loop_obspoints ! end of file + cycle loop_obspoints + end if - irads = irads + 1 - if (idom .eq. 1) cycle loop_obspoints + num_eos_file = num_eos_file + 1 ! 3.2 Read AQUASPOT (SPITSEQN) !------------------------ @@ -378,42 +362,6 @@ bufrfile: do ibufr=1,numbufr airsspot_list_array(11), & airsspot_list_array(12) ) - -! 4.0 Check observing position (lat/lon) -! QC1: juge if data is in the domain, -! read next record if not -!------------------------------------------ - if( abs(airsspot%clath) > R90 .or. & - abs(airsspot%clonh) > R360 .or. & - (abs(airsspot%clath) == R90 .and. airsspot%clonh /= ZERO) )then - irads = irads - 1 - cycle loop_obspoints - end if - -! Retrieve observing position - if(airsspot%clonh >= R360) then - airsspot%clonh = airsspot%clonh - R360 -! else if(airsspot%clonh < ZERO) then -! airsspot%clonh = airsspot%clonh + R360 - end if - - if (idom .eq. 2) then - info_1d(irads) % lat = airsspot%clath - info_1d(irads) % lon = airsspot%clonh - cycle loop_obspoints - end if - - info%lat = airsspot%clath - info%lon = airsspot%clonh - - outside_all = outside_all_1d(irads) - - if ( outside_all ) cycle loop_obspoints - - loc = loc_1d(irads) - outside = outside_1d(irads) - -!Temporary moved ! 3.4 Read AIRSCHAN or AMSUCHAN or HSBCHAN !------------------------------------------- if ( trim(senname) == 'AIRS' ) then @@ -437,11 +385,32 @@ bufrfile: do ibufr=1,numbufr cycle loop_obspoints end if -!Temporary moved ! 3.5 Read Cloud Cover from AIRS/VISNIR !------------------------------------------- call ufbint(lnbufr,tocc,1,1,iret,'TOCC') - + +! 4.0 Check observing position (lat/lon) +! QC1: juge if data is in the domain, +! read next record if not +!------------------------------------------ + if( abs(airsspot%clath) > R90 .or. & + abs(airsspot%clonh) > R360 .or. & + (abs(airsspot%clath) == R90 .and. airsspot%clonh /= ZERO) )then + cycle loop_obspoints + end if + +! Retrieve observing position + if(airsspot%clonh >= R360) then + airsspot%clonh = airsspot%clonh - R360 +! else if(airsspot%clonh < ZERO) then +! airsspot%clonh = airsspot%clonh + R360 + end if + + info%lat = airsspot%clath + info%lon = airsspot%clonh + call da_llxy (info, loc, outside, outside_all ) + + if ( outside_all ) cycle loop_obspoints ! 4.1 Check obs time !------------------------------------- @@ -593,32 +562,11 @@ bufrfile: do ibufr=1,numbufr p => p%next nullify (p%next) - end do loop_obspoints - end do + end do loop_obspoints call closbf(lnbufr) close(lnbufr) - if (idom .eq. 1) then - allocate ( info_1d (irads) ) - allocate ( loc_1d (irads) ) - allocate ( outside_1d (irads) ) - allocate ( outside_all_1d (irads) ) - end if - if (idom .eq. 2) then - call da_llxy_1d (info_1d(1:irads), loc_1d(1:irads), outside_1d(1:irads), outside_all_1d(1:irads)) - end if - if (idom .eq. 3) then - deallocate ( info_1d ) - deallocate ( loc_1d ) - deallocate ( outside_1d ) - deallocate ( outside_all_1d ) - end if - - end do domtest - - num_eos_file = num_eos_file + irads - end do bufrfile if (thinning .and. num_eos_global > 0) then diff --git a/var/da/da_radiance/da_read_obs_bufratms.inc b/var/da/da_radiance/da_read_obs_bufratms.inc index 026b987cfd..dd63757d36 100644 --- a/var/da/da_radiance/da_read_obs_bufratms.inc +++ b/var/da/da_radiance/da_read_obs_bufratms.inc @@ -115,10 +115,6 @@ subroutine da_read_obs_bufratms (obstype,iv, infile) real , allocatable :: in(:), out(:) logical :: found, head_found - type(info_type), allocatable :: info_1d(:) - type(model_loc_type), allocatable :: loc_1d(:) - logical, allocatable :: outside_1d(:), outside_all_1d(:) - if (trace_use) call da_trace_entry("da_read_obs_bufratms") ! Initialize variables @@ -337,21 +333,6 @@ bufrfile: do ibufr=1,numbufr call da_error(__FILE__,__LINE__,message(1:1)) endif - allocate ( info_1d (nnum) ) - allocate ( loc_1d (nnum) ) - allocate ( outside_1d (nnum) ) - allocate ( outside_all_1d (nnum) ) - - info_1d%lat = lat_save(1:nnum) - info_1d%lon = lon_save(1:nnum) - - deallocate(lat_save) - deallocate(lon_save) - - ! Determine loc_1d, outside_1d, outside_all_1d - !--------------------------------------------------------------------------------- - call da_llxy_1d (info_1d, loc_1d, outside_1d, outside_all_1d) - obs: do nn=1, nnum if ( nn == 1 ) then allocate (head) @@ -366,10 +347,10 @@ bufrfile: do ibufr=1,numbufr ! rlat = bfr1bhdr(bufr_lat) ! rlon = bfr1bhdr(bufr_lat) ! if (rlon < 0.0) rlon = rlon+360.0 - info = info_1d (nn) - loc = loc_1d (nn) - outside = outside_1d (nn) - outside_all = outside_all_1d (nn) + info%lat = lat_save(nn) + info%lon = lon_save(nn) + + call da_llxy (info, loc, outside, outside_all) if (outside_all) cycle @@ -537,11 +518,6 @@ bufrfile: do ibufr=1,numbufr ! call closbf(lnbufr) ! close(lnbufr) - deallocate ( info_1d ) - deallocate ( loc_1d ) - deallocate ( outside_1d ) - deallocate ( outside_all_1d ) - !end do bufrfile if (thinning .and. num_tovs_global > 0 ) then @@ -699,6 +675,8 @@ bufrfile: do ibufr=1,numbufr deallocate(Time_save) deallocate(BT_InOut_save) deallocate(Scanline_save) + deallocate(lat_save) + deallocate(lon_save) deallocate(satid_save) deallocate(obs_time_save) deallocate(satzen_save) diff --git a/var/da/da_radiance/da_read_obs_bufriasi.inc b/var/da/da_radiance/da_read_obs_bufriasi.inc index ec4806844a..7aa45a3d4a 100644 --- a/var/da/da_radiance/da_read_obs_bufriasi.inc +++ b/var/da/da_radiance/da_read_obs_bufriasi.inc @@ -86,10 +86,6 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) real(r_kind),parameter :: tbmax = 550._r_kind real(r_kind),parameter :: earth_radius = 6371000._r_kind - integer :: idom, irads - type(info_type), allocatable :: info_1d(:) - type(model_loc_type), allocatable :: loc_1d(:) - logical, allocatable :: outside_1d(:), outside_all_1d(:) if (trace_use) call da_trace_entry("da_read_obs_bufriasi") ! 0.0 Initialize variables @@ -112,7 +108,7 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) nread(1:rtminit_nsensor) = 0 ptotal(0:num_fgat_time) = 0 iobs = 0 ! for thinning, argument is inout - num_iasi_file = 0 + num_iasi_file = 0 num_iasi_local = 0 num_iasi_global = 0 num_iasi_used = 0 @@ -147,24 +143,11 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) end if end if lnbufr = 95 - -! Allocate arrays to hold data - nele=nreal+nchan - allocate(data_all(nele)) - if ( ibufr == 1 ) then - allocate (head) - nullify ( head % next ) - p => head - end if - - ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) - domtest: do idom = 1, 3 - open(unit=lnbufr,file=trim(filename),form='unformatted', & iostat = iost, status = 'old') if (iost /= 0) then call da_warning(__FILE__,__LINE__, & - (/"Cannot open file: "//infile/)) + (/"Cannot open file "//infile/)) if (trace_use) call da_trace_exit("da_read_obs_bufriasi") return end if @@ -173,26 +156,33 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) call openbf(lnbufr,'IN',lnbufr) call datelen(10) call readmg(lnbufr,subset,idate,iret) - if (idom .eq. 1) then - iy=0 - im=0 - idd=0 - ihh=0 - write(unit=date,fmt='( i10)') idate - read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh - write(unit=stdout,fmt='(a,4i4,2x,a)') & - 'Bufr file date is ',iy,im,idd,ihh,trim(infile) - end if + iy=0 + im=0 + idd=0 + ihh=0 + write(unit=date,fmt='( i10)') idate + read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh + write(unit=stdout,fmt='(a,4i4,2x,a)') & + 'Bufr file date is ',iy,im,idd,ihh,trim(infile) + + ! Loop to read bufr file and assign information to a sequential structure + !------------------------------------------------------------------------- +! Allocate arrays to hold data + nele=nreal+nchan + allocate(data_all(nele)) + if ( ibufr == 1 ) then + allocate (head) + nullify ( head % next ) + p => head + end if + ! Big loop to read data file - irads = 0 do while(ireadmg(lnbufr,subset,idate)>=0) read_loop: do while (ireadsb(lnbufr)==0) - - irads = irads + 1 - if (idom .eq. 1) cycle read_loop + num_iasi_file = num_iasi_file + 1 ! Read IASI FOV information call ufbint(lnbufr,linele,5,1,iret,'FOVN SLNM QGFQ MJFC SELV') @@ -224,19 +214,9 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) satellite_id = 3 end if - if (idom .eq. 2) then - ! Get observing position - info_1d (irads) % lat = allspot(8) ! latitude - info_1d (irads) % lon = allspot(9) ! longitude - - cycle read_loop - end if - - info = info_1d (irads) - loc = loc_1d (irads) - outside = outside_1d (irads) - outside_all = outside_all_1d (irads) - +! Check observing position + info%lat = allspot(8) ! latitude + info%lon = allspot(9) ! longitude) if( abs(info%lat) > r90 .or. abs(info%lon) > r360 .or. & (abs(info%lat) == r90 .and. info%lon /= zero) )then write(unit=stdout,fmt=*) & @@ -245,7 +225,8 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) cycle read_loop end if - if (outside_all) cycle read_loop + call da_llxy (info, loc, outside, outside_all) + if (outside_all) cycle inst = 0 do i = 1, rtminit_nsensor if (platform_id == rtminit_platform(i) & @@ -440,28 +421,6 @@ subroutine da_read_obs_bufriasi (obstype,iv,infile) end do read_loop end do call closbf(lnbufr) - close(lnbufr) - - if (idom .eq. 1) then - allocate ( info_1d (irads) ) - allocate ( loc_1d (irads) ) - allocate ( outside_1d (irads) ) - allocate ( outside_all_1d (irads) ) - end if - if (idom .eq. 2) then - call da_llxy_1d (info_1d(1:irads), loc_1d(1:irads), outside_1d(1:irads), outside_all_1d(1:irads)) - end if - if (idom .eq. 3) then - deallocate ( info_1d ) - deallocate ( loc_1d ) - deallocate ( outside_1d ) - deallocate ( outside_all_1d ) - - end if - - end do domtest - - num_iasi_file = num_iasi_file + irads !Deallocate temporary array for next bufrfile do loop deallocate(data_all) @@ -618,8 +577,8 @@ end do bufrfile deallocate (nread) deallocate (ptotal) -! call closbf(lnbufr) -! close(lnbufr) + call closbf(lnbufr) + close(lnbufr) ! call da_free_unit(lnbufr) diff --git a/var/da/da_radiance/da_read_obs_bufrseviri.inc b/var/da/da_radiance/da_read_obs_bufrseviri.inc index 10a850e985..c98e1f0dd6 100644 --- a/var/da/da_radiance/da_read_obs_bufrseviri.inc +++ b/var/da/da_radiance/da_read_obs_bufrseviri.inc @@ -120,11 +120,6 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) real(r_kind),parameter:: tbmax = 550._r_kind real(r_kind),parameter:: earth_radius = 6371000._r_kind - integer :: idom, irads - type(info_type), allocatable :: info_1d(:) - type(model_loc_type), allocatable :: loc_1d(:) - logical, allocatable :: outside_1d(:), outside_all_1d(:) - ilath=8 ! the position of latitude in the header ilonh=9 ! the position of longitude in the header ilzah=10 ! satellite zenith angle @@ -196,16 +191,6 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) ! dont change, WRFDA uses specified units to read radiance data lnbufr = 92 - - if ( ibufr == 1 ) then - allocate (head) - nullify ( head % next ) - p => head - end if - - ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) - domtest: do idom = 1, 3 - open(unit=lnbufr,file=trim(filename),form='unformatted', & iostat = iost, status = 'old' ) !,convert='little_endian') if (iost /= 0) then @@ -270,33 +255,37 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) allocate(hdr(nhdr)) - if (idom .eq. 1) then - iy=0 - im=0 - idd=0 - ihh=0 - sensorindex=1 - write(unit=date,fmt='( i10)') idate - read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh - write(unit=stdout,fmt='(a,4i4,2x,a)') & - 'Bufr file date is ',iy,im,idd,ihh,trim(infile) - end if + iy=0 + im=0 + idd=0 + ihh=0 + + sensorindex=1 + write(unit=date,fmt='( i10)') idate + read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh + write(unit=stdout,fmt='(a,4i4,2x,a)') & + 'Bufr file date is ',iy,im,idd,ihh,trim(infile) ! 2.0 Loop to read bufr file and assign information to a sequential structure !------------------------------------------------------------------------- ! Allocate arrays to hold data nele=nreal+nchan - allocate(data_all(nele)) + allocate(data_all(nele)) + if ( ibufr == 1 ) then + allocate (head) + nullify ( head % next ) + p => head + end if + ! Big loop to read data file - irads = 0 + do while(ireadmg(lnbufr,subset,idate)>=0) read_loop: do while (ireadsb(lnbufr)==0) - irads = irads + 1 - if (idom .eq. 1) cycle read_loop + num_seviri_file = num_seviri_file + 1 ! Read SEVIRI information call ufbint(lnbufr,hdr,nhdr,1,iret,hdrsevi) @@ -348,18 +337,8 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) if(allchnmiss) cycle read_loop ! Check observing position - if (idom .eq. 2) then - info_1d(irads) % lat = hdr(ilath) ! latitude - info_1d(irads) % lon = hdr(ilonh) ! longitude - - cycle read_loop - end if - - info = info_1d (irads) - loc = loc_1d (irads) - outside = outside_1d (irads) - outside_all = outside_all_1d (irads) - + info%lat = hdr(ilath) ! latitude + info%lon = hdr(ilonh) ! longitude if( abs(info%lat) > R90 .or. abs(info%lon) > R360 .or. & (abs(info%lat) == R90 .and. info%lon /= ZERO) )then write(unit=stdout,fmt=*) & @@ -368,6 +347,7 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) cycle read_loop end if + call da_llxy (info, loc, outside, outside_all) if (outside_all) cycle inst = 0 do i = 1, rtminit_nsensor @@ -479,34 +459,12 @@ subroutine da_read_obs_bufrseviri (obstype,iv,infile) end do read_loop end do call closbf(lnbufr) - close(lnbufr) !Deallocate temporary arrays for next bufrfile do loop deallocate(datasev1) deallocate(datasev2) deallocate(hdr) deallocate(data_all) - - if (idom .eq. 1) then - allocate ( info_1d (irads) ) - allocate ( loc_1d (irads) ) - allocate ( outside_1d (irads) ) - allocate ( outside_all_1d (irads) ) - end if - if (idom .eq. 2) then - call da_llxy_1d (info_1d(1:irads), loc_1d(1:irads), outside_1d(1:irads), outside_all_1d(1:irads)) - end if - if (idom .eq. 3) then - deallocate ( info_1d ) - deallocate ( loc_1d ) - deallocate ( outside_1d ) - deallocate ( outside_all_1d ) - end if - - end do domtest - - num_seviri_file = num_seviri_file + irads - end do bufrfile if (thinning .and. num_seviri_global > 0 ) then @@ -661,8 +619,8 @@ end do bufrfile deallocate (nread) deallocate (ptotal) -! call closbf(lnbufr) -! close(lnbufr) + call closbf(lnbufr) + close(lnbufr) call da_free_unit(lnbufr) diff --git a/var/da/da_radiance/da_read_obs_bufrssmis.inc b/var/da/da_radiance/da_read_obs_bufrssmis.inc index 954255da67..f271f58af1 100644 --- a/var/da/da_radiance/da_read_obs_bufrssmis.inc +++ b/var/da/da_radiance/da_read_obs_bufrssmis.inc @@ -70,11 +70,6 @@ subroutine da_read_obs_bufrssmis (obstype,iv,infile) integer(i_kind), allocatable :: ptotal(:), nread(:) - integer :: idom, irads - type(info_type), allocatable :: info_1d(:) - type(model_loc_type), allocatable :: loc_1d(:) - logical, allocatable :: outside_1d(:), outside_all_1d(:) - call da_trace_entry("da_read_obs_bufrssmis") allocate(nread(1:rtminit_nsensor)) @@ -132,22 +127,6 @@ bufrfile: do ibufr=1,numbufr end if lnbufr=98 - - if ( ibufr == 1 ) then - allocate (head) - nullify ( head % next ) - p => head - end if - -! Set various variables depending on type of data to be read - - !subfgn = 'NC003003' - subfgn = 'NC021201' - incangl = 53.2_r_kind - - ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) - domtest: do idom = 1, 3 - open(unit=lnbufr,file=trim(filename),form='unformatted', & iostat = iost, status = 'old') if (iost /= 0) then @@ -161,52 +140,52 @@ bufrfile: do ibufr=1,numbufr call datelen(10) call readmg(lnbufr,subset,idate,iret) - if (idom .eq. 1) then - iy=0 - im=0 - idd=0 - ihh=0 - write(unit=date,fmt='( i10)') idate - read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh - write(unit=stdout,fmt=*) & - 'Bufr file date is ',iy,im,idd,ihh,infile - end if + iy=0 + im=0 + idd=0 + ihh=0 + write(unit=date,fmt='( i10)') idate + read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh + write(unit=stdout,fmt=*) & + 'Bufr file date is ',iy,im,idd,ihh,infile ! Loop to read bufr file and assign information to a sequential structure !------------------------------------------------------------------------- - irads = 0 + if ( ibufr == 1 ) then + allocate (head) + nullify ( head % next ) + p => head + end if + +! Set various variables depending on type of data to be read + + !subfgn = 'NC003003' + subfgn = 'NC021201' + incangl = 53.2_r_kind + subset_loop: do while (ireadmg(lnbufr,subset,idate)==0) read_loop: do while (ireadsb(lnbufr)==0 .and. subset==subfgn) - irads = irads + 1 - if (idom .eq. 1) cycle read_loop + num_ssmis_file = num_ssmis_file + 1 + ! 1.0 Read header record and data record - ! 1.0 Read header record call ufbint(lnbufr,bfr1bhdr,n1bhdr,1,iret,hdr1b) + call ufbrep(lnbufr,bufrtbb,2,maxchanl,iret,"CHNM TMBR" ) ! check if observation outside range - ! 2.1 Extract observation location and other required information + ! 2.0 Extract observation location and other required information ! QC1: judge if data is in the domain, read next record if not !------------------------------------------------------------------------ - if (idom .eq. 2) then - info_1d(irads) % lat = bfr1bhdr(bufr_lat) - info_1d(irads) % lon = bfr1bhdr(bufr_lon) - cycle read_loop - end if + info%lat = bfr1bhdr(bufr_lat) + info%lon = bfr1bhdr(bufr_lon) + call da_llxy (info, loc, outside, outside_all) - info = info_1d (irads) - loc = loc_1d (irads) - outside_all = outside_all_1d (irads) - outside = outside_1d (irads) if (outside_all) cycle - ! 2.2 Read data record - call ufbrep(lnbufr,bufrtbb,2,maxchanl,iret,"CHNM TMBR" ) - ! 3.0 Extract other information info%elv = 0.0 @@ -377,27 +356,6 @@ bufrfile: do ibufr=1,numbufr call closbf(lnbufr) close(lnbufr) - if (idom .eq. 1) then - allocate ( info_1d (irads) ) - allocate ( loc_1d (irads) ) - allocate ( outside_1d (irads) ) - allocate ( outside_all_1d (irads) ) - end if - if (idom .eq. 2) then - call da_llxy_1d (info_1d(1:irads), loc_1d(1:irads), outside_1d(1:irads), outside_all_1d(1:irads)) - end if - if (idom .eq. 3) then - deallocate ( info_1d ) - deallocate ( loc_1d ) - deallocate ( outside_1d ) - deallocate ( outside_all_1d ) - - end if - - end do domtest - - num_ssmis_file = num_ssmis_file + irads - end do bufrfile if (thinning .and. num_ssmis_global > 0 ) then @@ -554,8 +512,8 @@ end do bufrfile deallocate (nread) deallocate (ptotal) -! call closbf(lnbufr) -! close(lnbufr) + call closbf(lnbufr) + close(lnbufr) ! call da_free_unit(lnbufr) call da_trace_exit("da_read_obs_bufrssmis") diff --git a/var/da/da_radiance/da_read_obs_bufrtovs.inc b/var/da/da_radiance/da_read_obs_bufrtovs.inc index 197b48359c..0660c8e8b9 100644 --- a/var/da/da_radiance/da_read_obs_bufrtovs.inc +++ b/var/da/da_radiance/da_read_obs_bufrtovs.inc @@ -62,6 +62,7 @@ subroutine da_read_obs_bufrtovs (obstype,iv, infile) ! pixel information integer :: year,month,day,hour,minute,second ! observation time real*8 :: obs_time + ! real :: rlat, rlon ! lat/lon in degrees for Anfovs real :: satzen, satazi, solzen ,solazi ! scan angles for Anfovs integer :: landsea_mask real :: srf_height @@ -88,11 +89,6 @@ subroutine da_read_obs_bufrtovs (obstype,iv, infile) real , allocatable :: in(:), out(:) logical :: found, head_found - integer :: idom, itovs - type(info_type), allocatable :: info_1d(:) - type(model_loc_type), allocatable :: loc_1d(:) - logical, allocatable :: outside_1d(:), outside_all_1d(:) - call da_trace_entry("da_read_obs_bufrtovs") ! Initialize variables @@ -218,25 +214,11 @@ bufrfile: do ibufr=1,numbufr ! We want to use specific unit number for bufr data, so we can control the endian format in environment. lnbufr = 99 - if ( ibufr == 1 ) then - allocate (head) - ! allocate ( head % tb_inv (1:nchan) ) - nullify ( head % next ) - p => head - endif - - if (tovs_start > 1) then - write (unit=stdout,fmt='(A,I6)') " Skipping tovs obs before", tovs_start - end if - - ! Loop over 3 stages of the vectorized domain test (da_llxy_1d) - domtest: do idom = 1, 3 - open(unit=lnbufr,file=trim(filename),form='unformatted', & iostat = iost, status = 'old') if (iost /= 0) then call da_warning(__FILE__,__LINE__, & - (/"Cannot open file (1): "//infile/)) + (/"Cannot open file "//infile/)) call da_trace_exit("da_read_obs_bufrtovs") return end if @@ -253,24 +235,33 @@ bufrfile: do ibufr=1,numbufr call da_error(__FILE__,__LINE__,message(1:2)) end if - if (idom .eq. 1) then - iy=0 - im=0 - idd=0 - ihh=0 - write(unit=date,fmt='( i10)') idate - read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh - write(unit=stdout,fmt=*) & - 'Bufr file date is ',iy,im,idd,ihh,infile + iy=0 + im=0 + idd=0 + ihh=0 + write(unit=date,fmt='( i10)') idate + read(unit=date,fmt='(i4,3i2)') iy,im,idd,ihh + write(unit=stdout,fmt=*) & + 'Bufr file date is ',iy,im,idd,ihh,infile + + ! Loop to read bufr file and assign information to a sequential structure + !------------------------------------------------------------------------- + + if ( ibufr == 1 ) then + allocate (head) + ! allocate ( head % tb_inv (1:nchan) ) + nullify ( head % next ) + p => head + endif + + if (tovs_start > 1) then + write (unit=stdout,fmt='(A,I6)') " Skipping tovs obs before", tovs_start end if - itovs = 0 + obs: do while (ireadmg(lnbufr,subset,idate)==0 .and. subset==subfgn) do while (ireadsb(lnbufr)==0) - itovs = itovs + 1 - if (idom .eq. 1) cycle - ! 1.0 Read header record and data record call ufbint(lnbufr,bfr1bhdr,n1bhdr,1,iret,hdr1b) call ufbint(lnbufr,bfr2bhdr,n2bhdr,1,iret,hdr2b) @@ -278,25 +269,25 @@ bufrfile: do ibufr=1,numbufr ! call ufbrep(lnbufr,data1b8,1,1,iret,'BEARAZ') ! check if observation outside range + + num_tovs_file = num_tovs_file + 1 + ! 2.0 Extract observation location and other required information ! QC1: judge if data is in the domain, read next record if not !------------------------------------------------------------------------ - if (idom .eq. 2) then - if(abs(bfr2bhdr(1)) <= 90. .and. abs(bfr2bhdr(2)) <= 360.)then - info_1d(itovs)%lat = bfr2bhdr(1) - info_1d(itovs)%lon = bfr2bhdr(2) - elseif(abs(bfr1bhdr(9)) <= 90. .and. abs(bfr1bhdr(10)) <= 360.)then - info_1d(itovs)%lat = bfr1bhdr(9) - info_1d(itovs)%lon = bfr1bhdr(10) - endif - - cycle - end if + ! rlat = bfr1bhdr(bufr_lat) + ! rlon = bfr1bhdr(bufr_lat) + ! if (rlon < 0.0) rlon = rlon+360.0 + + if(abs(bfr2bhdr(1)) <= 90. .and. abs(bfr2bhdr(2)) <= 360.)then + info%lat = bfr2bhdr(1) + info%lon = bfr2bhdr(2) + elseif(abs(bfr1bhdr(9)) <= 90. .and. abs(bfr1bhdr(10)) <= 360.)then + info%lat = bfr1bhdr(9) + info%lon = bfr1bhdr(10) + endif - info = info_1d (itovs) - loc = loc_1d (itovs) - outside_all = outside_all_1d (itovs) - outside = outside_1d (itovs) + call da_llxy (info, loc, outside, outside_all) if (outside_all) cycle @@ -503,26 +494,6 @@ bufrfile: do ibufr=1,numbufr call closbf(lnbufr) close(lnbufr) - if (idom .eq. 1) then - allocate ( info_1d (itovs) ) - allocate ( loc_1d (itovs) ) - allocate ( outside_1d (itovs) ) - allocate ( outside_all_1d (itovs) ) - end if - if (idom .eq. 2) then - call da_llxy_1d (info_1d(1:itovs), loc_1d(1:itovs), outside_1d(1:itovs), outside_all_1d(1:itovs)) - end if - if (idom .eq. 3) then - deallocate ( info_1d ) - deallocate ( loc_1d ) - deallocate ( outside_1d ) - deallocate ( outside_all_1d ) - end if - - end do domtest - - num_tovs_file = num_tovs_file + itovs - end do bufrfile if (thinning .and. num_tovs_global > 0 ) then diff --git a/var/da/da_radiance/da_read_obs_hdf5amsr2.inc b/var/da/da_radiance/da_read_obs_hdf5amsr2.inc index 655b05ef8f..8bb20c18e5 100644 --- a/var/da/da_radiance/da_read_obs_hdf5amsr2.inc +++ b/var/da/da_radiance/da_read_obs_hdf5amsr2.inc @@ -135,11 +135,6 @@ subroutine da_read_obs_hdf5amsr2 (iv, infile_tb,infile_clw) 'Brightness Temperature (res23,23.8GHz,V)','Brightness Temperature (res23,23.8GHz,H)',& 'Brightness Temperature (res36,36.5GHz,V)','Brightness Temperature (res36,36.5GHz,H)'/ - integer :: ii_1d - type(info_type), allocatable :: info_1d(:) - type(model_loc_type), allocatable :: loc_1d(:) - logical, allocatable :: outside_1d(:), outside_all_1d(:) - if (trace_use) call da_trace_entry("da_read_obs_hdf5amsr2") ! 0.0 Initialize variables @@ -683,31 +678,6 @@ subroutine da_read_obs_hdf5amsr2 (iv, infile_tb,infile_clw) call H5Fclose_f(fhnd2,iret) end if - - allocate ( info_1d (nscan*lo_rez_fov) ) - allocate ( loc_1d (nscan*lo_rez_fov) ) - allocate ( outside_1d (nscan*lo_rez_fov) ) - allocate ( outside_all_1d (nscan*lo_rez_fov) ) - - ii_1d = 0 - do iscan=1, nscan - do i = 1, 6 - idate5(i)=obstime(i, iscan) - end do - call da_get_julian_time(idate5(1),idate5(2),idate5(3),idate5(4),idate5(5),obs_time) - if ( obs_time < time_slots(0) .or. & - obs_time >= time_slots(num_fgat_time) ) cycle - do ifov=1, lo_rez_fov - ii_1d = ii_1d + 1 - info_1d(ii_1d)%lat = latlr(ifov,iscan) - info_1d(ii_1d)%lon = lonlr(ifov,iscan) - end do - end do - - ! Determine loc_1d, outside_1d, outside_all_1d - !--------------------------------------------------------------------------------- - call da_llxy_1d (info_1d(1:ii_1d), loc_1d(1:ii_1d), outside_1d(1:ii_1d), outside_all_1d(1:ii_1d)) - ! 2.0 Loop to read hdf file and assign information to a sequential structure !------------------------------------------------------------------------- @@ -719,7 +689,6 @@ subroutine da_read_obs_hdf5amsr2 (iv, infile_tb,infile_clw) head_allocated = .true. end if ! start scan_loop - ii_1d = 0 scan_loop: do iscan=1, nscan do i = 1, 6 idate5(i)=obstime(i, iscan) @@ -736,12 +705,10 @@ subroutine da_read_obs_hdf5amsr2 (iv, infile_tb,infile_clw) fov_loop: do ifov=1, lo_rez_fov num_amsr2_file = num_amsr2_file + 1 num_amsr2_file_local = num_amsr2_file_local + 1 - ii_1d = ii_1d + 1 - info = info_1d (ii_1d) - loc = loc_1d (ii_1d) - outside = outside_1d (ii_1d) - outside_all = outside_all_1d (ii_1d) + info%lat = latlr(ifov,iscan) + info%lon = lonlr(ifov,iscan) + call da_llxy (info, loc, outside, outside_all) if (outside_all) cycle fov_loop num_amsr2_global = num_amsr2_global + 1 @@ -823,11 +790,6 @@ subroutine da_read_obs_hdf5amsr2 (iv, infile_tb,infile_clw) ! Dellocate arrays deallocate (obstime) - deallocate ( info_1d ) - deallocate ( loc_1d ) - deallocate ( outside_1d ) - deallocate ( outside_all_1d ) - write(stdout,fmt='(3a,i7)') ' In file: ',trim(fname_tb(ifile)),' got num_amsr2_file : ',num_amsr2_file_local write(stdout,fmt='(3a,i7)') ' In file: ',trim(fname_tb(ifile)),' got num_amsr2_global : ',num_amsr2_global_local write(stdout,fmt='(3a,i7)') ' In file: ',trim(fname_tb(ifile)),' got num_amsr2_local : ',num_amsr2_local_local diff --git a/var/da/da_tools/da_llxy.inc b/var/da/da_tools/da_llxy.inc index 6519ec74c8..2b9f988b31 100644 --- a/var/da/da_tools/da_llxy.inc +++ b/var/da/da_tools/da_llxy.inc @@ -66,7 +66,6 @@ subroutine da_llxy (info, loc, outside, outside_all) end if end if - if (fg_format == fg_format_kma_global) then if ((loc%j < jts-1) .or. (loc%j > jte)) then outside = .true. From d96c28c4e9ddc66bcfdb1aad5414ccef70f9c14d Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Thu, 2 May 2019 09:38:16 -0600 Subject: [PATCH 41/86] Fix dependencies on wrf_dm_bcast_integer/real/string/bytes The missing use statement in da_obs_io.df90 was causing the following compile-time error for a 4D-Var build: catastrophic error: **Internal compiler error: segmentation violation signal raised** Please report this error along with the circumstances in which it occurred in a Software Problem Report. Note: File and line given may not be explicit cause of this error. compilation aborted for da_obs_io.f (code 1) real 0m19.553s user 0m18.652s sys 0m0.668s da.make:421: recipe for target 'da_obs_io.o' failed make[1]: [da_obs_io.o] Error 1 (ignored) The interfaces are updated in da_wrf_interfaces, including assumed-size array behavior in module_dm.f90. All other known missing use statements related to wrf_dm_bcast_* calls are also corrected. modified: var/build/depend.txt modified: var/da/da_gpseph/da_gpseph.f90 modified: var/da/da_obs_io/da_obs_io.f90 modified: var/da/da_par_util/da_par_util.f90 modified: var/da/da_physics/da_physics.f90 modified: var/da/da_radiance/da_radiance.f90 modified: var/da/da_radiance/da_radiance1.f90 modified: var/da/da_setup_structures/da_setup_structures.f90 modified: var/da/da_test/da_test.f90 modified: var/da/da_tools/da_wrf_interfaces.f90 modified: var/da/da_transfer_model/da_transfer_model.f90 modified: var/da/da_transfer_model/da_transfer_wrftoxb.inc --- var/build/depend.txt | 6 +-- var/da/da_gpseph/da_gpseph.f90 | 1 + var/da/da_obs_io/da_obs_io.f90 | 1 + var/da/da_par_util/da_par_util.f90 | 3 +- var/da/da_physics/da_physics.f90 | 2 +- var/da/da_radiance/da_radiance.f90 | 2 +- var/da/da_radiance/da_radiance1.f90 | 1 + .../da_scale_background_errors_cv3.inc | 42 +++++++++---------- .../da_setup_structures.f90 | 3 +- var/da/da_test/da_test.f90 | 3 +- var/da/da_tools/da_wrf_interfaces.f90 | 34 +++++++++++---- .../da_transfer_model/da_transfer_model.f90 | 4 +- .../da_transfer_model/da_transfer_wrftoxb.inc | 6 +-- 13 files changed, 63 insertions(+), 45 deletions(-) diff --git a/var/build/depend.txt b/var/build/depend.txt index b40827b2e9..9f7f9ceaad 100644 --- a/var/build/depend.txt +++ b/var/build/depend.txt @@ -132,7 +132,7 @@ da_module_couple_uv_ad.o : da_module_couple_uv_ad.f90 da_couple_ad.inc da_calc_m da_mtgirs.o : da_mtgirs.f90 da_calculate_grady_mtgirs.inc da_get_innov_vector_mtgirs.inc da_check_max_iv_mtgirs.inc da_transform_xtoy_mtgirs_adj.inc da_transform_xtoy_mtgirs.inc da_print_stats_mtgirs.inc da_oi_stats_mtgirs.inc da_residual_mtgirs.inc da_jo_mtgirs_uvtq.inc da_jo_and_grady_mtgirs.inc da_ao_stats_mtgirs.inc da_tracing.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_netcdf_interface.o : da_netcdf_interface.f90 da_atotime.inc da_get_bdytimestr_cdf.inc da_get_bdyfrq.inc da_put_att_cdf.inc da_get_att_cdf.inc da_put_var_2d_int_cdf.inc da_get_var_2d_int_cdf.inc da_put_var_2d_real_cdf.inc da_put_var_3d_real_cdf.inc da_get_var_2d_real_cdf.inc da_get_var_3d_real_cdf.inc da_get_gl_att_real_cdf.inc da_get_gl_att_int_cdf.inc da_get_dims_cdf.inc da_get_times_cdf.inc da_get_var_1d_real_cdf.inc da_obs.o : da_obs.f90 da_grid_definitions.o da_set_obs_missing.inc da_obs_sensitivity.inc da_count_filtered_obs.inc da_store_obs_grid_info_rad.inc da_store_obs_grid_info.inc da_random_omb_all.inc da_fill_obs_structures.inc da_fill_obs_structures_rain.inc da_fill_obs_structures_radar.inc da_check_missing.inc da_add_noise_to_ob.inc da_transform_xtoy_adj.inc da_transform_xtoy.inc da_obs_proc_station.inc module_dm.o da_tracing.o da_tools.o da_tools_serial.o da_synop.o da_ssmi.o da_tamdar.o da_mtgirs.o da_sound.o da_ships.o da_satem.o da_rttov.o da_reporting.o da_rain.o da_radar.o da_qscat.o da_pseudo.o da_profiler.o da_polaramv.o da_pilot.o da_physics.o da_metar.o da_gpsref.o da_gpspw.o da_geoamv.o da_crtm.o da_control.o da_buoy.o da_bogus.o da_airsr.o da_airep.o module_domain.o da_define_structures.o da_gpseph.o -da_obs_io.o : da_obs_io.f90 da_grid_definitions.o da_final_write_modified_filtered_obs.inc da_final_write_filtered_obs.inc da_write_noise_to_ob.inc da_read_omb_tmp.inc da_read_rand_unit.inc da_read_y_unit.inc da_final_write_y.inc da_final_write_obs.inc da_read_obs_bufrgpsro.inc da_read_obs_bufr.inc da_write_y.inc da_write_modified_filtered_obs.inc da_write_filtered_obs.inc da_write_obs_etkf.inc da_search_obs.inc da_read_iv_for_multi_inc.inc da_write_iv_for_multi_inc.inc da_write_obs.inc da_use_obs_errfac.inc da_read_errfac.inc da_read_obs_rain.inc da_scan_obs_rain.inc da_scan_obs_radar.inc da_read_obs_radar.inc da_scan_obs_ascii.inc da_read_obs_ascii.inc da_par_util.o gsi_thinning.o module_radiance.o da_tracing.o da_tools_serial.o da_tools.o da_reporting.o da_physics.o da_par_util1.o da_obs.o da_grid_definitions.o da_define_structures.o da_control.o module_domain.o da_read_lsac_util.inc da_read_obs_lsac.inc da_scan_obs_lsac.inc da_netcdf_interface.o da_gpseph.o da_read_obs_bufrgpsro_eph.inc +da_obs_io.o : da_obs_io.f90 da_grid_definitions.o da_final_write_modified_filtered_obs.inc da_final_write_filtered_obs.inc da_write_noise_to_ob.inc da_read_omb_tmp.inc da_read_rand_unit.inc da_read_y_unit.inc da_final_write_y.inc da_final_write_obs.inc da_read_obs_bufrgpsro.inc da_read_obs_bufr.inc da_write_y.inc da_write_modified_filtered_obs.inc da_write_filtered_obs.inc da_write_obs_etkf.inc da_search_obs.inc da_read_iv_for_multi_inc.inc da_write_iv_for_multi_inc.inc da_write_obs.inc da_use_obs_errfac.inc da_read_errfac.inc da_read_obs_rain.inc da_scan_obs_rain.inc da_scan_obs_radar.inc da_read_obs_radar.inc da_scan_obs_ascii.inc da_read_obs_ascii.inc da_par_util.o gsi_thinning.o module_radiance.o da_tracing.o da_tools_serial.o da_tools.o da_reporting.o da_physics.o da_par_util1.o da_obs.o da_grid_definitions.o da_define_structures.o da_control.o module_domain.o da_wrf_interfaces.o da_read_lsac_util.inc da_read_obs_lsac.inc da_scan_obs_lsac.inc da_netcdf_interface.o da_gpseph.o da_read_obs_bufrgpsro_eph.inc da_par_util.o : da_par_util.f90 da_proc_maxmin_combine.inc da_proc_stats_combine.inc da_system.inc da_y_facade_to_global.inc da_generic_boilerplate.inc da_deallocate_global_synop.inc da_deallocate_global_sound.inc da_deallocate_global_sonde_sfc.inc da_generic_methods.inc da_patch_to_global_3d.inc da_patch_to_global_dual_res.inc da_patch_to_global_2d.inc da_cv_to_global.inc da_transpose_y2x_v2.inc da_transpose_x2y_v2.inc da_transpose_z2y.inc da_transpose_y2z.inc da_transpose_x2z.inc da_transpose_z2x.inc da_transpose_y2x.inc da_transpose_x2y.inc da_unpack_count_obs.inc da_pack_count_obs.inc da_copy_tile_dims.inc da_copy_dims.inc da_alloc_and_copy_be_arrays.inc da_vv_to_cv.inc da_cv_to_vv.inc da_generic_typedefs.inc da_wrf_interfaces.o da_tracing.o da_reporting.o da_define_structures.o da_par_util1.o module_dm.o module_domain.o da_control.o da_par_util1.o : da_par_util1.f90 da_proc_sum_real.inc da_proc_sum_ints.inc da_proc_sum_int.inc da_control.o da_physics.o : da_physics.f90 da_uv_to_sd_lin.inc da_uv_to_sd_adj.inc da_integrat_dz.inc da_wdt.inc da_filter_adj.inc da_filter.inc da_evapo_lin.inc da_condens_lin.inc da_condens_adj.inc da_moist_phys_lin.inc da_moist_phys_adj.inc da_sfc_pre_adj.inc da_sfc_pre_lin.inc da_sfc_pre.inc da_transform_xtowtq_adj.inc da_transform_xtowtq.inc da_transform_xtopsfc_adj.inc da_transform_xtopsfc.inc da_sfc_wtq_adj.inc da_sfc_wtq_lin.inc da_sfc_wtq.inc da_julian_day.inc da_roughness_from_lanu.inc da_get_q_error.inc da_check_rh_simple.inc da_check_rh.inc da_transform_xtogpsref_lin.inc da_transform_xtogpsref_adj.inc da_transform_xtogpsref.inc da_transform_xtotpw_adj.inc da_transform_xtotpw.inc da_transform_xtoztd_adj.inc da_transform_xtoztd_lin.inc da_transform_xtoztd.inc da_tv_profile_tl.inc da_thickness_tl.inc da_find_layer_adj.inc da_thickness.inc da_tv_profile_adj.inc da_find_layer.inc da_thickness_adj.inc da_find_layer_tl.inc da_tv_profile.inc da_tpq_to_slp_adj.inc da_tpq_to_slp_lin.inc da_wrf_tpq_2_slp.inc da_tpq_to_slp.inc da_trh_to_td.inc da_tp_to_qs_lin1.inc da_tp_to_qs_lin.inc da_tp_to_qs_adj1.inc da_tp_to_qs_adj.inc da_tp_to_qs1.inc da_tp_to_qs.inc da_tprh_to_q_lin1.inc da_tprh_to_q_lin.inc da_tprh_to_q_adj1.inc da_tprh_to_q_adj.inc da_tpq_to_rh_lin1.inc da_tpq_to_rh_lin.inc da_tpq_to_rh.inc da_pt_to_rho_lin.inc da_pt_to_rho_adj.inc da_uvprho_to_w_adj.inc da_uvprho_to_w_lin.inc da_prho_to_t_lin.inc da_prho_to_t_adj.inc da_wrf_interfaces.o da_reporting.o da_dynamics.o da_interpolation.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_grid_definitions.o da_gpseph.o @@ -144,7 +144,7 @@ da_qscat.o : da_qscat.f90 da_calculate_grady_qscat.inc da_transform_xtoy_qscat_a da_rad_diags.o : da_rad_diags.f90 da_radar.o : da_radar.f90 da_write_oa_radar_ascii.inc da_max_error_qc_radar.inc da_calculate_grady_radar.inc da_radial_velocity_adj.inc da_radial_velocity_lin.inc da_radial_velocity.inc da_radar_rf.inc da_get_innov_vector_radar.inc da_check_max_iv_radar.inc da_transform_xtoy_radar_adj.inc da_transform_xtoy_radar.inc da_print_stats_radar.inc da_oi_stats_radar.inc da_residual_radar.inc da_jo_and_grady_radar.inc da_ao_stats_radar.inc da_tools_serial.o da_reporting.o da_tracing.o da_tools.o da_statistics.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_satzen.inc da_read_obs_hdf5ahi.inc da_read_obs_netcdf4ahi_jaxa.inc da_read_obs_netcdf4ahi_geocat.inc -da_radiance1.o : da_radiance1.f90 da_mspps_ts.inc da_mspps_emis.inc da_setup_satcv.inc da_qc_rad.inc da_print_stats_rad.inc da_oi_stats_rad.inc da_ao_stats_rad.inc da_cld_eff_radius.inc da_detsurtyp.inc da_write_oa_rad_ascii.inc da_write_iv_rad_ascii.inc da_qc_mhs.inc da_qc_ssmis.inc da_qc_hirs.inc da_qc_amsub.inc da_qc_amsua.inc da_qc_airs.inc da_cloud_detect_airs.inc da_cloud_sim.inc da_qc_seviri.inc da_qc_iasi.inc da_cloud_detect_iasi.inc da_qc_crtm.inc da_predictor_crtm.inc da_predictor_rttov.inc da_write_biasprep.inc da_biasprep.inc da_read_biascoef.inc da_biascorr.inc da_residual_rad.inc da_jo_and_grady_rad.inc gsi_constants.o da_tracing.o da_tools_serial.o da_tools.o da_statistics.o da_reporting.o da_par_util1.o da_par_util.o module_dm.o da_define_structures.o da_control.o module_radiance.o da_qc_amsr2.inc da_qc_goesimg.inc da_qc_ahi.inc +da_radiance1.o : da_radiance1.f90 da_mspps_ts.inc da_mspps_emis.inc da_setup_satcv.inc da_qc_rad.inc da_print_stats_rad.inc da_oi_stats_rad.inc da_ao_stats_rad.inc da_cld_eff_radius.inc da_detsurtyp.inc da_write_oa_rad_ascii.inc da_write_iv_rad_ascii.inc da_qc_mhs.inc da_qc_ssmis.inc da_qc_hirs.inc da_qc_amsub.inc da_qc_amsua.inc da_qc_airs.inc da_cloud_detect_airs.inc da_cloud_sim.inc da_qc_seviri.inc da_qc_iasi.inc da_cloud_detect_iasi.inc da_qc_crtm.inc da_predictor_crtm.inc da_predictor_rttov.inc da_write_biasprep.inc da_biasprep.inc da_read_biascoef.inc da_biascorr.inc da_residual_rad.inc da_jo_and_grady_rad.inc gsi_constants.o da_tracing.o da_tools_serial.o da_tools.o da_statistics.o da_reporting.o da_par_util1.o da_par_util.o module_dm.o da_define_structures.o da_control.o module_radiance.o da_wrf_interfaces.o da_qc_amsr2.inc da_qc_goesimg.inc da_qc_ahi.inc da_rain.o : da_rain.f90 da_calculate_grady_rain.inc da_get_innov_vector_rain.inc da_get_hr_rain.inc da_check_max_iv_rain.inc da_transform_xtoy_rain_adj.inc da_transform_xtoy_rain.inc da_print_stats_rain.inc da_oi_stats_rain.inc da_residual_rain.inc da_jo_and_grady_rain.inc da_ao_stats_rain.inc da_tracing.o da_tools.o da_statistics.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_recursive_filter.o : da_recursive_filter.f90 da_apply_rf_adj.inc da_apply_rf.inc da_apply_rf_1v_adj.inc da_apply_rf_1v.inc da_transform_through_rf_adj.inc da_transform_through_rf.inc da_recursive_filter_1d_adj.inc da_recursive_filter_1d.inc da_calculate_rf_factors.inc da_transform_through_rf_dual_res.inc da_transform_through_rf_adj_dual_res.inc da_perform_2drf.inc da_rf_cv3.o da_rfz_cv3.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_domain.o da_reporting.o : da_reporting.f90 da_message2.inc da_message.inc da_warning.inc da_error.inc da_control.o @@ -165,7 +165,7 @@ da_test.o : da_test.f90 da_test_vxtransform.inc da_check_gradient.inc da_get_y_l da_tools.o : da_tools.f90 da_geo2msl1.inc da_msl2geo1.inc da_get_time_slots.inc da_get_julian_time.inc da_get_print_lvl.inc da_get_3d_sum.inc da_get_2d_sum.inc da_set_boundary_3d.inc da_set_boundary_xb.inc da_set_boundary_xa.inc da_ludcmp.inc da_lubksb.inc da_eof_decomposition.inc da_eof_decomposition_test.inc da_buddy_qc.inc da_unifva.inc da_togrid.inc da_togrid_new.inc da_smooth_anl.inc da_openfile.inc da_gaus_noise.inc da_set_randomcv.inc da_random_omb.inc da_max_error_qc.inc da_add_noise_new.inc da_add_noise.inc da_residual_new.inc da_residual.inc da_diff_seconds.inc da_mo_correction.inc da_intpsfc_tem.inc da_intpsfc_prs.inc da_sfcprs.inc da_obs_sfc_correction.inc da_1d_eigendecomposition.inc da_convert_zk.inc da_lc_cone.inc da_set_merc.inc da_map_set.inc da_map_init.inc da_set_ps.inc da_set_lc.inc da_xyll_ps.inc da_xyll_merc.inc da_xyll_lc.inc da_xyll_latlon.inc da_xyll_default.inc da_xyll.inc da_llxy_wrf_new.inc da_llxy_wrf.inc da_llxy_ps_new.inc da_llxy_ps.inc da_llxy_merc_new.inc da_llxy_merc.inc da_llxy_lc_new.inc da_llxy_lc.inc da_llxy_latlon_new.inc da_llxy_latlon.inc da_llxy_rotated_latlon.inc da_llxy_global_new.inc da_llxy_global.inc da_llxy_kma_global_new.inc da_llxy_kma_global.inc da_llxy_default_new.inc da_llxy_default.inc da_llxy_new.inc da_llxy.inc da_map_utils_defines.inc da_lapack.o da_reporting.o da_tracing.o da_tools_serial.o da_define_structures.o da_control.o module_domain.o module_dm.o module_bc.o da_sfc_hori_interp_weights.inc da_tools_serial.o : da_tools_serial.f90 da_find_fft_trig_funcs.inc da_find_fft_factors.inc da_advance_time.inc da_advance_cymdh.inc da_array_print.inc da_change_date.inc da_free_unit.inc da_get_unit.inc da_reporting.o da_control.o da_tracing.o : da_tracing.f90 da_trace_report.inc da_trace_real_sort.inc da_trace_int_sort.inc da_trace_exit.inc da_trace.inc da_trace_entry.inc da_trace_init.inc da_reporting.o da_par_util1.o da_control.o -da_transfer_model.o : da_transfer_model.f90 da_get_2nd_firstguess.inc da_setup_firstguess_kma.inc da_setup_firstguess_wrf_nmm_regional.inc da_setup_firstguess_wrf.inc da_setup_firstguess.inc da_transfer_xatoanalysis.inc da_transfer_wrftl_lbc_t0_adj.inc da_transfer_xatowrftl_adj_lbc.inc da_transfer_xatowrftl_adj.inc da_transfer_wrftl_lbc_t0.inc da_transfer_xatowrftl_lbc.inc da_transfer_xatowrftl.inc da_transfer_wrftltoxa_adj.inc da_transfer_wrftltoxa.inc da_transfer_xatokma.inc da_transfer_xatowrf_nmm_regional.inc da_transfer_xatowrf.inc da_transfer_kmatoxb.inc da_transfer_wrf_nmm_regional_toxb.inc da_transfer_wrftoxb.inc module_io_wrf.o module_bc.o da_4dvar.o da_vtox_transforms.o da_tracing.o da_tools.o da_ssmi.o da_setup_structures.o da_reporting.o da_physics.o da_par_util.o da_grid_definitions.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_state_description.o module_io_domain.o module_domain.o module_date_time.o module_configure.o da_radar.o +da_transfer_model.o : da_transfer_model.f90 da_get_2nd_firstguess.inc da_setup_firstguess_kma.inc da_setup_firstguess_wrf_nmm_regional.inc da_setup_firstguess_wrf.inc da_setup_firstguess.inc da_transfer_xatoanalysis.inc da_transfer_wrftl_lbc_t0_adj.inc da_transfer_xatowrftl_adj_lbc.inc da_transfer_xatowrftl_adj.inc da_transfer_wrftl_lbc_t0.inc da_transfer_xatowrftl_lbc.inc da_transfer_xatowrftl.inc da_transfer_wrftltoxa_adj.inc da_transfer_wrftltoxa.inc da_transfer_xatokma.inc da_transfer_xatowrf_nmm_regional.inc da_transfer_xatowrf.inc da_transfer_kmatoxb.inc da_transfer_wrf_nmm_regional_toxb.inc da_transfer_wrftoxb.inc module_io_wrf.o module_bc.o da_4dvar.o da_vtox_transforms.o da_tracing.o da_tools.o da_ssmi.o da_setup_structures.o da_reporting.o da_physics.o da_par_util.o da_grid_definitions.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_state_description.o module_io_domain.o module_domain.o module_date_time.o module_configure.o da_wrf_interfaces.o da_radar.o da_tune_obs_desroziers.o : da_tune_obs_desroziers.f90 da_tune_obs_hollingsworth1.o : da_tune_obs_hollingsworth1.f90 da_control.o da_tune_obs_hollingsworth2.o : da_tune_obs_hollingsworth2.f90 da_control.o diff --git a/var/da/da_gpseph/da_gpseph.f90 b/var/da/da_gpseph/da_gpseph.f90 index 5f200533e7..e2b65b04b2 100644 --- a/var/da/da_gpseph/da_gpseph.f90 +++ b/var/da/da_gpseph/da_gpseph.f90 @@ -26,6 +26,7 @@ module da_gpseph use da_tools_serial, only : da_free_unit, da_get_unit use da_tracing, only : da_trace_entry, da_trace_exit use da_reporting, only : da_error + use da_wrf_interfaces, only : wrf_dm_bcast_real ! The "stats_gpseph_type" is ONLY used locally in da_gpseph: diff --git a/var/da/da_obs_io/da_obs_io.f90 b/var/da/da_obs_io/da_obs_io.f90 index b12f5aed36..7d4a0ef68f 100644 --- a/var/da/da_obs_io/da_obs_io.f90 +++ b/var/da/da_obs_io/da_obs_io.f90 @@ -34,6 +34,7 @@ module da_obs_io gpsro_drift, max_gpseph_input, use_gpsephobs, gpseph, gpseph_loadbalance, kds, kde, kts, kte, & use_radar_rhv, use_radar_rqv + use da_wrf_interfaces, only : wrf_dm_bcast_integer, wrf_dm_bcast_real use da_define_structures, only : iv_type, multi_level_type, multi_level_type_BUFR, & radar_multi_level_type, y_type, field_type, each_level_type, & radar_each_level_type, info_type, model_loc_type,gpsref_type, rain_single_level_type, rain_each_type, & diff --git a/var/da/da_par_util/da_par_util.f90 b/var/da/da_par_util/da_par_util.f90 index 4df7054b6b..b5cda15342 100644 --- a/var/da/da_par_util/da_par_util.f90 +++ b/var/da/da_par_util/da_par_util.f90 @@ -40,7 +40,8 @@ module da_par_util use da_tracing, only : da_trace_entry, da_trace_exit use da_wrf_interfaces, only : & wrf_dm_xpose_z2x, wrf_dm_xpose_x2y, wrf_dm_xpose_y2x, wrf_dm_xpose_x2z, & - wrf_dm_xpose_z2y, wrf_dm_xpose_y2z, wrf_patch_to_global_real, wrf_debug + wrf_dm_xpose_z2y, wrf_dm_xpose_y2z, wrf_patch_to_global_real, wrf_debug, & + wrf_dm_bcast_integer, wrf_dm_bcast_real implicit none diff --git a/var/da/da_physics/da_physics.f90 b/var/da/da_physics/da_physics.f90 index b5bd689bab..f138dafc4c 100644 --- a/var/da/da_physics/da_physics.f90 +++ b/var/da/da_physics/da_physics.f90 @@ -28,7 +28,7 @@ module da_physics use da_dynamics, only : da_w_adjustment_adj, da_uv_to_divergence_adj, & da_w_adjustment_lin, da_uv_to_divergence use da_reporting, only : da_error, message - use da_wrf_interfaces, only : wrf_debug + use da_wrf_interfaces, only : wrf_debug, wrf_dm_bcast_real use da_grid_definitions, only : da_ffdduv_model use da_gpseph, only : global_xa_ref diff --git a/var/da/da_radiance/da_radiance.f90 b/var/da/da_radiance/da_radiance.f90 index 1fc091a872..60eb490dc1 100644 --- a/var/da/da_radiance/da_radiance.f90 +++ b/var/da/da_radiance/da_radiance.f90 @@ -93,7 +93,7 @@ module da_radiance da_trace_int_sort use da_varbc, only : da_varbc_direct,da_varbc_coldstart,da_varbc_precond, & da_varbc_pred - use da_wrf_interfaces, only : wrf_dm_bcast_integer + use da_wrf_interfaces, only : wrf_dm_bcast_real use gsi_thinning, only : r999,r360,rlat_min,rlat_max,rlon_min,rlon_max, & dlat_grid,dlon_grid,thinning_grid, & makegrids,map2grids, & diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index 1b1f29a86d..f8dc833285 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -33,6 +33,7 @@ module da_radiance1 use da_tools, only : da_residual_new, da_eof_decomposition use da_tools_serial, only : da_free_unit, da_get_unit use da_tracing, only : da_trace_entry, da_trace_exit, da_trace_int_sort + use da_wrf_interfaces, only : wrf_dm_bcast_integer #if defined(RTTOV) || defined(CRTM) use da_control, only : rtminit_sensor,write_profile,num_procs,tovs_min_transfer diff --git a/var/da/da_setup_structures/da_scale_background_errors_cv3.inc b/var/da/da_setup_structures/da_scale_background_errors_cv3.inc index 838120b11b..62ba583de5 100644 --- a/var/da/da_setup_structures/da_scale_background_errors_cv3.inc +++ b/var/da/da_setup_structures/da_scale_background_errors_cv3.inc @@ -7,8 +7,8 @@ subroutine da_scale_background_errors_cv3 ( grid, be, it ) REAL, DIMENSION( ids: ide, jds: jde, kds: kde, 1:4) :: hwll REAL, DIMENSION( ids: ide, jds: jde) :: hwllp, global_fac REAL, DIMENSION( kts: kte, kts: kte) :: vv - integer :: n, i, j, k, ic, jc, ii, ij, ijk, & - iis, iie, jjs, jje, kks, kke + integer :: n, i, j, k, ic, jc, ii, ij, ijk + integer, dimension(1) :: iis, iie, jjs, jje, kks, kke, ivar real, dimension(1) :: xsum real, dimension(ids: ide, jds: jde) :: global_2d real, dimension(ids: ide, jds: jde, kds: kde) :: global_3d @@ -16,8 +16,8 @@ subroutine da_scale_background_errors_cv3 ( grid, be, it ) character(len=9) :: chr character(len=8) :: i_char - INTEGER :: nta, ndeg, ku, kz - real :: samp,s2u,tin,as(5),as0(5),slim + INTEGER :: nta, ndeg, ku(1), kz + real :: samp(1),s2u,tin,as(5),as0(5),slim character(len=256) :: mesg integer :: ier, be_rf_unit, be_print_unit @@ -76,32 +76,32 @@ subroutine da_scale_background_errors_cv3 ( grid, be, it ) write (be_print_unit,'(3x,a)') 'VARIANCE:' do ii = 1, 4 if (rootproc) & - read (be_rf_unit) chr, vname, i, global_3d + read (be_rf_unit) chr, vname, ivar, global_3d call wrf_dm_bcast_string( chr, 9 ) call wrf_dm_bcast_string( vname, 6 ) - call wrf_dm_bcast_integer( i, 1 ) + call wrf_dm_bcast_integer( ivar, 1 ) call wrf_dm_bcast_real( global_3d, ijk ) - be%corz(its:ite,jts:jte,kts:kte,i) = global_3d(its:ite,jts:jte,kts:kte) - xsum(1) = sum (be%corz(its:ite,jts:jte,kts:kte,i)*be%corz(its:ite,jts:jte,kts:kte,i)) + be%corz(its:ite,jts:jte,kts:kte,ivar(1)) = global_3d(its:ite,jts:jte,kts:kte) + xsum(1) = sum (be%corz(its:ite,jts:jte,kts:kte,ivar(1))*be%corz(its:ite,jts:jte,kts:kte,ivar(1))) call da_proc_sum_real(xsum) if (rootproc .and. print_detail_be) & write (be_print_unit,'(5x,i3,1x,a,2x,"sum^2=",e20.12)') ii, vname, xsum(1) -! write (*,'(3x,a9,2x,a6,2x,i3)') chr, vname, i +! write (*,'(3x,a9,2x,a6,2x,i3)') chr, vname, ivar enddo ! Psfc Variance before the normalization. if (rootproc) & - read (be_rf_unit) chr, vname, ii, global_2d + read (be_rf_unit) chr, vname, ivar, global_2d call wrf_dm_bcast_string( chr, 9 ) call wrf_dm_bcast_string( vname, 6 ) - call wrf_dm_bcast_integer( ii, 1 ) + call wrf_dm_bcast_integer( ivar, 1 ) call wrf_dm_bcast_real( global_2d, ij ) be%corp(its:ite,jts:jte) = global_2d(its:ite,jts:jte) xsum(1) = sum (be%corp(its:ite,jts:jte)*be%corp(its:ite,jts:jte)) call da_proc_sum_real(xsum) if (rootproc .and. print_detail_be) & write (be_print_unit,'(9x,a,2x,"sum^2=",e20.12)') 'PSFC_u', xsum(1) -! write (*,'(3x,a9,2x,a6,2x,i3)') chr, vname, ii +! write (*,'(3x,a9,2x,a6,2x,i3)') chr, vname, ivar ! ! 2.4 Read in the vertical scales to "be_print_unit": ! @@ -111,23 +111,23 @@ subroutine da_scale_background_errors_cv3 ( grid, be, it ) write (be_print_unit,'(3x,a)') 'VERTICAL SCALE:' do ii = 1, 4 if (rootproc) & - read (be_rf_unit) chr, vname, n, global_3d + read (be_rf_unit) chr, vname, ivar, global_3d call wrf_dm_bcast_string( chr, 9 ) call wrf_dm_bcast_string( vname, 6 ) - call wrf_dm_bcast_integer( n, 1 ) + call wrf_dm_bcast_integer( ivar, 1 ) call wrf_dm_bcast_real( global_3d, ijk ) do i = its, ite do j = jts, jte do k = kts, kte - be%vz(k,i,j,n) = global_3d(i,j,k) + be%vz(k,i,j,ivar(1)) = global_3d(i,j,k) enddo enddo enddo - xsum(1) = sum (be%vz(kts:kte,its:ite,jts:jte,n)*be%vz(kts:kte,its:ite,jts:jte,n)) + xsum(1) = sum (be%vz(kts:kte,its:ite,jts:jte,ivar(1))*be%vz(kts:kte,its:ite,jts:jte,ivar(1))) call da_proc_sum_real(xsum) if (rootproc .and. print_detail_be) & write (be_print_unit,'(5x,i3,1x,a,2x,"sum^2=",e20.12)') ii, vname, xsum(1) -! write (*,'(3x,a9,2x,a6,2x,i3)') chr, vname, n +! write (*,'(3x,a9,2x,a6,2x,i3)') chr, vname, ivar enddo ! ! 2.5 Read in the Horizontal scales, and write out vertical scales to "be_print_unit": @@ -263,7 +263,7 @@ subroutine da_scale_background_errors_cv3 ( grid, be, it ) ! Normalize the covariance for psi, chi, t, and rh: do k=kts,kte be % corz(i,j,k,n)=be % corz(i,j,k,n)*as(n) & - *samp/hwll(i,j,k,n)/vv(k,k)/global_fac(i,j) + *samp(1)/hwll(i,j,k,n)/vv(k,k)/global_fac(i,j) enddo enddo @@ -286,7 +286,7 @@ subroutine da_scale_background_errors_cv3 ( grid, be, it ) ! write (*,'("as(5)=",f15.5,2x,"samp=",f15.5)') as(5), samp be % corp(its:ite,jts:jte)=be % corp(its:ite,jts:jte)*as(5) & - *samp/hwllp(its:ite,jts:jte)/global_fac(its:ite,jts:jte) + *samp(1)/hwllp(its:ite,jts:jte)/global_fac(its:ite,jts:jte) ! xsum(1) = sum (be%corp(its:ite,jts:jte)*be%corp(its:ite,jts:jte)) ! call da_proc_sum_real(xsum) @@ -331,7 +331,7 @@ subroutine da_scale_background_errors_cv3 ( grid, be, it ) ! Above level ku, the sljy fields are set to a constant ! for psi and chi, i.e. homogenous: do n=1,2 - do k=max(ku, grid%xp%kpsy), grid%xp%kpey + do k=max(ku(1), grid%xp%kpsy), grid%xp%kpey slim=1./global_fac(ic,jc)/hwll(ic,jc,k,n) do j= grid%xp%jpsy, grid%xp%jpey do i= grid%xp%ipsy, grid%xp%ipey @@ -368,7 +368,7 @@ subroutine da_scale_background_errors_cv3 ( grid, be, it ) ! Above level ku, the sljy fields are set to a constant ! for psi and chi, i.e. homogenous: do n=1,2 - do k=max(ku, grid%xp%kpsx), grid%xp%kpex + do k=max(ku(1), grid%xp%kpsx), grid%xp%kpex slim=1./global_fac(ic,jc)/hwll(ic,jc,k,n) do j= grid%xp%jpsx, grid%xp%jpex do i= grid%xp%ipsx, grid%xp%ipex diff --git a/var/da/da_setup_structures/da_setup_structures.f90 b/var/da/da_setup_structures/da_setup_structures.f90 index cfd04566f5..17e7fd615a 100644 --- a/var/da/da_setup_structures/da_setup_structures.f90 +++ b/var/da/da_setup_structures/da_setup_structures.f90 @@ -12,7 +12,8 @@ module da_setup_structures multi_level_type,each_level_type, da_allocate_observations_rain use da_define_structures, only : da_allocate_obs_info, da_allocate_y, da_allocate_y_radar, & da_allocate_y_rain - use da_wrf_interfaces, only : wrf_debug + use da_wrf_interfaces, only : wrf_debug, & + wrf_dm_bcast_string, wrf_dm_bcast_integer, wrf_dm_bcast_real use da_control, only : trace_use,vert_evalue,stdout,rootproc, myproc, & analysis_date,coarse_ix,coarse_ds,map_projection,coarse_jy, c2,dsm,phic, & pole, cone_factor, start_x,base_pres,ptop,psi1,start_y, base_lapse,base_temp,truelat2_3dv, & diff --git a/var/da/da_test/da_test.f90 b/var/da/da_test/da_test.f90 index ee5235a173..67de010087 100644 --- a/var/da/da_test/da_test.f90 +++ b/var/da/da_test/da_test.f90 @@ -74,8 +74,7 @@ module da_test use da_tracing, only : da_trace_entry,da_trace_exit use da_transfer_model, only : da_transfer_wrftltoxa,da_transfer_xatowrftl, & da_transfer_xatowrftl_adj,da_transfer_wrftltoxa_adj,da_transfer_wrftoxb - ! Don't use, as we pass a 3D array into a 1D one - ! use da_wrf_interfaces, only : wrf_dm_bcast_real + use da_wrf_interfaces, only : wrf_dm_bcast_real use da_wrf_interfaces, only : wrf_debug, wrf_shutdown use da_wrfvar_io, only : da_med_initialdata_output,da_med_initialdata_input use da_vtox_transforms, only : da_transform_xtotb_lin, & diff --git a/var/da/da_tools/da_wrf_interfaces.f90 b/var/da/da_tools/da_wrf_interfaces.f90 index 6b37b65cfb..3dd99f1585 100644 --- a/var/da/da_tools/da_wrf_interfaces.f90 +++ b/var/da/da_tools/da_wrf_interfaces.f90 @@ -8,7 +8,7 @@ end subroutine disable_quilting interface subroutine wrf_dm_bcast_real (buf, n1) integer, intent(in) :: n1 - real, intent(inout) :: buf(:) + real, intent(inout) :: buf(*) end subroutine wrf_dm_bcast_real end interface @@ -25,12 +25,36 @@ real function wrf_dm_sum_real (inval) end function wrf_dm_sum_real end interface + interface + subroutine wrf_dm_bcast_integer(buf, n1) + implicit none + integer, intent(in) :: n1 + integer, intent(inout) :: buf(*) + end subroutine wrf_dm_bcast_integer + end interface + interface integer function wrf_dm_sum_integer (inval) integer, intent(in) :: inval end function wrf_dm_sum_integer end interface + interface + subroutine wrf_dm_bcast_string(buf, n1) + implicit none + integer, intent(in) :: n1 + character*(*), intent(inout) :: buf(*) + end subroutine wrf_dm_bcast_string + end interface + + interface + subroutine wrf_dm_bcast_bytes(buf, size) + implicit none + integer, intent(in) :: size + integer, intent(inout) :: buf(*) + end subroutine wrf_dm_bcast_bytes + end interface + interface subroutine wrf_patch_to_global_real (buf,globbuf,domdesc,stagger, & ordering,& @@ -128,14 +152,6 @@ subroutine wrf_debug(level , str) end subroutine wrf_debug end interface - interface - subroutine wrf_dm_bcast_integer(buf, n1) - implicit none - integer, intent(in) :: n1 - integer, intent(inout) :: buf(:) - end subroutine wrf_dm_bcast_integer - end interface - interface subroutine setup_timekeeping(grid) use module_domain, only : domain diff --git a/var/da/da_transfer_model/da_transfer_model.f90 b/var/da/da_transfer_model/da_transfer_model.f90 index 1bd9e77c81..9bb4f665c7 100644 --- a/var/da/da_transfer_model/da_transfer_model.f90 +++ b/var/da/da_transfer_model/da_transfer_model.f90 @@ -63,9 +63,7 @@ module da_transfer_model use da_vtox_transforms, only : da_get_vpoles use da_radar, only : zlcl_mean use da_gpseph, only : da_gpseph_init - ! Do not use line below, because it shows that we are passing a scalar to - ! an array - ! use da_wrf_interfaces, only : wrf_dm_bcast_real + use da_wrf_interfaces, only : wrf_dm_bcast_real #ifdef VAR4D use da_4dvar, only : model_grid, push_ad_forcing, push_tl_pert, pop_tl_pert, kj_swap, & kj_swap_reverse, model_config_flags, g_couple, g_stuff_bdy, a_couple, a_stuff_bdy, & diff --git a/var/da/da_transfer_model/da_transfer_wrftoxb.inc b/var/da/da_transfer_model/da_transfer_wrftoxb.inc index cfc549e563..e836223d4a 100644 --- a/var/da/da_transfer_model/da_transfer_wrftoxb.inc +++ b/var/da/da_transfer_model/da_transfer_wrftoxb.inc @@ -21,7 +21,7 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) character(len=19) :: current_date - real :: loc_psac_mean + real :: loc_psac_mean(1) real, dimension(jds:jde) :: loc_latc_mean @@ -911,12 +911,12 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) if (test_dm_exact) then ! Broadcast result from monitor to other tasks. call wrf_dm_bcast_real(loc_psac_mean, 1) - xbx % psac_mean = loc_psac_mean + xbx % psac_mean = loc_psac_mean(1) ! Broadcast result from monitor to other tasks. call wrf_dm_bcast_real(loc_latc_mean, (jde-jds+1)) xbx % latc_mean = loc_latc_mean else - xbx % psac_mean = wrf_dm_sum_real(loc_psac_mean) + xbx % psac_mean = wrf_dm_sum_real(loc_psac_mean(1)) call wrf_dm_sum_reals(loc_latc_mean, xbx % latc_mean) end if From 99ec57b7ce4d3aa4aa8adb2cdd8a3fb6c0e12cac Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Mon, 13 May 2019 14:51:48 -0600 Subject: [PATCH 42/86] Series of fixes/updates to goes-abi metadata generation Improves performance for debug builds and gives non-failing behavior when solar angles indicate night time. Update BTlim with 9km CONUS values...still to be updated modified: da_radiance/da_get_solar_angles.inc modified: da_radiance/da_get_solar_angles_1d.inc modified: da_radiance/da_qc_goesabi.inc modified: da_radiance/da_read_obs_ncgoesabi.inc --- var/da/da_radiance/da_get_solar_angles.inc | 48 +- var/da/da_radiance/da_get_solar_angles_1d.inc | 77 ++-- var/da/da_radiance/da_qc_goesabi.inc | 142 ++---- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 412 ++++++++++-------- 4 files changed, 339 insertions(+), 340 deletions(-) diff --git a/var/da/da_radiance/da_get_solar_angles.inc b/var/da/da_radiance/da_get_solar_angles.inc index b91f13cf79..0f1fc12b01 100644 --- a/var/da/da_radiance/da_get_solar_angles.inc +++ b/var/da/da_radiance/da_get_solar_angles.inc @@ -48,7 +48,7 @@ subroutine da_get_solar_angles( yr, mt, dy, hr, mn, sc, & real(r_double) :: delta, ju, jmod, time, gmst, lmst real(r_double) :: mnlon, mnanom, eclon, oblqec real(r_double) :: num, den, ra, dec, ha - real(r_double) :: elev, elc, refrac + real(r_double) :: elev, refrac !, elc ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:12:00 (see da_get_julian_time) real(r_double), parameter :: jd_jmod = 43510.0 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) @@ -56,12 +56,12 @@ subroutine da_get_solar_angles( yr, mt, dy, hr, mn, sc, & ! ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:00:00 (see da_get_julian_time) ! real(r_double), parameter :: jd_jmod = 43509.5 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + solzen = missing_r + solazi = missing_r if ( lat .gt. 90. .or. & lat .lt. -90. .or. & lon .gt. 180. .or. & lon .lt. -180. ) then - solzen = missing_r - solazi = missing_r return end if @@ -104,6 +104,7 @@ subroutine da_get_solar_angles( yr, mt, dy, hr, mn, sc, & endif ! Calculate declination in radians + ! (asin varies between -pi/2 to pi/2) dec = asin( sin( oblqec ) * sin( eclon ) ) ! Calculate Greenwich mean sidereal time in hours @@ -133,8 +134,15 @@ subroutine da_get_solar_angles( yr, mt, dy, hr, mn, sc, & ! mnlon in degs, gmst in hours, ju in days minus 2.4e6; ! mnanom, eclon, oblqec, ra, lmst, and ha in radians - ! Calculate elevation and azimuth + ! Calculate elevation (90 - zenith) + ! (asin varies between -pi/2 to pi/2) elev = asin( sin( dec ) * sin( latrad ) + cos( dec ) * cos( latrad ) * cos( ha ) ) + + ! Night-time angles are inconsequential + if ( elev < 0. ) return + + ! Calculate azimuth + ! (asin varies between -pi/2 to pi/2) solazi = asin( -cos( dec ) * sin( ha ) / cos( elev ) ) !JJG: From J.P. Justiniano (not in Michalsky, causes differences with NREL SPA) @@ -145,26 +153,40 @@ subroutine da_get_solar_angles( yr, mt, dy, hr, mn, sc, & ! solazi = PI - solazi ! endif - ! When solazi=90 degs, elev == elcritical = asin( sin(dec) / sin(latrad) ) - elc = asin( sin( dec ) / sin( latrad ) ) - if ( elev.ge.elc ) solazi = PI - solazi - if ( elev.le.elc .and. ha.gt.0. ) solazi = 2.0*PI + solazi - ! Convert az to degs before returning +! ! When solazi=90 degs, elev == elcritical = asin( sin(dec) / sin(latrad) ) +! JJG: elc is undefined when sin(dec) / sin(latrad) is outside [-1,1] or dec > latrad when both are positive...need better method to determine quadrant + !ORIGINAL: + !elc = asin( sin( dec ) / sin( latrad ) ) + !if ( elev.ge.elc ) solazi = PI - solazi + !if ( elev.le.elc .and. ha.gt.0. ) solazi = 2.0*PI + solazi + + !Updated according to Eq. 3.18 at https://www.powerfromthesun.net/Book/chapter03/chapter03.html + ! "Power From The Sun" is the great new website by William Stine and Michael Geyer. It features + ! a revised and updated (and free!) version of "Solar Energy Systems Design" by W.B.Stine and + ! R.W.Harrigan (John Wiley and Sons, Inc. 1986) retitled "Power From The Sun", along with + ! resources we hope you will find useful in learning about solar energy. + if ( cos(ha) < ( tan(dec) / tan(latrad) ) ) then + solazi = 2.0*PI + solazi + else + solazi = PI - solazi + end if + + ! Convert az to degs, force between 0 and 2*pi solazi = solazi / deg2rad + solazi = mod( solazi, 360. ) ! Calculate refraction correction for US stan. atmosphere ! (need to have elev in degs before calculating correction) elev = elev / deg2rad - !JJG: Added these bounds + !JJG: Added these bounds (should not need them) !Keep elevation between -90. to +90. if ( elev.lt.-90. ) & elev = - (180. + elev) if ( elev.gt.90. ) & elev = 180. - elev - ! ! Michalsky (1988) ! if ( elev.gt. - 0.56 ) then ! refrac = 3.51579 * ( 0.1594 + 0.0196*elev + 0.00002*elev**2 ) / & @@ -186,8 +208,8 @@ subroutine da_get_solar_angles( yr, mt, dy, hr, mn, sc, & ! note that 3.51579=1013.25 mb/288.2 C elev = elev + refrac - + ! Convert elevation to topocentric zenith - solzen = 90.0 - elev + solzen = 90.0_r_kind - elev end subroutine da_get_solar_angles diff --git a/var/da/da_radiance/da_get_solar_angles_1d.inc b/var/da/da_radiance/da_get_solar_angles_1d.inc index 44547e191e..aff7a519b5 100644 --- a/var/da/da_radiance/da_get_solar_angles_1d.inc +++ b/var/da/da_radiance/da_get_solar_angles_1d.inc @@ -50,14 +50,14 @@ subroutine da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & real(r_double), allocatable :: lmst(:), ha(:) real(r_double) :: mnlon, mnanom, eclon, oblqec real(r_double) :: num, den, ra, dec - real(r_double), allocatable :: elev(:), elc(:), refrac(:) + real(r_double), allocatable :: elev(:), refrac(:) !, elc(:) logical, allocatable :: valid_loc(:) ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:12:00 (see da_get_julian_time) - real(r_kind), parameter :: jd_jmod = 43510.0 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + real(r_double), parameter :: jd_jmod = 43510.0 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) ! ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:00:00 (see da_get_julian_time) -! real(r_kind), parameter :: jd_jmod = 43509.5 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) +! real(r_double), parameter :: jd_jmod = 43509.5 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) integer :: n @@ -67,6 +67,7 @@ subroutine da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & allocate( lmst(n) ) allocate( ha(n) ) allocate( elev(n) ) +! allocate( elc(n) ) allocate( refrac(n) ) allocate( valid_loc(n) ) @@ -112,8 +113,8 @@ subroutine da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & dec = asin( sin( oblqec ) * sin( eclon ) ) ! Calculate Greenwich mean sidereal time in hours -! gmst = 6.697375 + 0.0657098242*time + real(hr,r_kind) + real(mn,r_kind) / 60. + real(sc,r_kind) / 3600. - gmst = 6.697375 + 0.0657098242*time + real(hr * 3600 + mn * 60 + sc, r_kind) / 3600. +! gmst = 6.697375 + 0.0657098242*time + real(hr,r_double) + real(mn,r_double) / 60. + real(sc,r_double) / 3600. + gmst = 6.697375 + 0.0657098242*time + real(hr * 3600 + mn * 60 + sc, r_double) / 3600. ! Hour not changed to sidereal time since 'time' includes the fractional day gmst = mod( gmst, 24. ) @@ -146,6 +147,7 @@ subroutine da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & where ( ha .gt. PI .and. valid_loc ) ha = ha - 2.0*PI ! Change latitude to radians + latrad = missing_r where ( valid_loc ) latrad = lat * deg2rad end where @@ -154,10 +156,19 @@ subroutine da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & ! mnlon in degs, gmst in hours, jd in days if 2.4e6 added; ! mnanom, eclon, oblqec, ra, lmst, and ha in radians - ! Calculate elevation and azimuth - solazi = missing_r + ! Calculate elevation (90 - zenith) + ! (asin varies between -pi/2 to pi/2) where ( valid_loc ) elev = asin( sin( dec ) * sin( latrad ) + cos( dec ) * cos( latrad ) * cos( ha ) ) + end where + + ! Night-time angles are inconsequential + valid_loc = (valid_loc .and. elev.ge.0.) + + ! Calculate azimuth + ! (asin varies between -pi/2 to pi/2) + solazi = missing_r + where ( valid_loc ) solazi = asin( -cos( dec ) * sin( ha ) / cos( elev ) ) end where @@ -170,20 +181,42 @@ subroutine da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & ! endif ! When solazi=90 degs, elev == elcritical = asin( sin(dec) / sin(latrad) ) - where ( valid_loc ) - elc = asin( sin( dec ) / sin( latrad ) ) +! JJG: elc is undefined when sin(dec) / sin(latrad) is outside [-1,1] or dec > latrad when both are positive...need better method to determine quadrant + !where ( valid_loc ) + ! elc = asin( sin( dec ) / sin( latrad ) ) + !end where + !where ( elev.ge.elc .and. valid_loc ) solazi = PI - solazi + !where ( elev.le.elc .and. ha.gt.0. .and. valid_loc ) solazi = 2.0*PI + solazi + + !Updated according to Eq. 3.18 at https://www.powerfromthesun.net/Book/chapter03/chapter03.html + ! "Power From The Sun" is the great new website by William Stine and Michael Geyer. It features + ! a revised and updated (and free!) version of "Solar Energy Systems Design" by W.B.Stine and + ! R.W.Harrigan (John Wiley and Sons, Inc. 1986) retitled "Power From The Sun", along with + ! resources we hope you will find useful in learning about solar energy. + where ( valid_loc .and. cos(ha) < ( tan(dec) / tan(latrad) ) ) + solazi = 2.0*PI + solazi + elsewhere ( valid_loc ) + solazi = PI - solazi end where - where ( elev.ge.elc .and. valid_loc ) solazi = PI - solazi - where ( elev.le.elc .and. ha.gt.0. .and. valid_loc ) solazi = 2.0*PI + solazi - ! Convert azimuth and elevation to degs before returning + ! Convert az to degs, force between 0 and 2*pi where ( valid_loc ) solazi = solazi / deg2rad - elev = elev / deg2rad end where + solazi = mod( solazi, 360. ) ! Calculate refraction correction for US stan. atmosphere - ! (need to have elev in degs) + ! (need to have elev in degs before calculating correction) + where ( valid_loc ) + elev = elev / deg2rad + end where + + !JJG: Added these bounds (should not need them) + !Keep elevation between -90. to +90. + where ( valid_loc .and. elev.lt.-90.) & + elev = - (180. + elev) + where ( valid_loc .and. elev.gt.90.) & + elev = 180. - elev ! ! Michalsky (1988) ! where ( elev.gt. - 0.56 ) @@ -204,25 +237,17 @@ subroutine da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & end where ! note that 3.51579=1013.25 mb/288.2 C - - solzen = missing_r where ( valid_loc ) elev = elev + refrac end where - !JJG: Added these bounds - !Keep elevation between -90. to +90. - where ( valid_loc .and. elev.lt.-90.) & - elev = - (180. + elev) - where ( valid_loc .and. elev.gt.90.) & - elev = 180. - elev - where ( valid_loc ) - ! Convert elevation to topocentric zenith - solzen = 90.0 - elev + ! Convert elevation to topocentric zenith + solzen = missing_r + where (valid_loc) + solzen = 90.0_r_kind - elev end where - deallocate( latrad, lmst, ha, elev, refrac, valid_loc ) end subroutine da_get_solar_angles_1d diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 24e3929f4d..2116ef85d6 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -39,7 +39,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) logical :: print_cld_debug !! Additional variables used by Harnish, Weissmann, & Perianez (2016) - real :: BTlim(nchan), BTlim_temp + real :: BTlim(nchan) real, allocatable :: cld_impact(:,:), cld_impact_global(:,:), weights_global(:) integer :: buf_i, buf_f, nbuf, nlocal, nglobal, iproc real, parameter :: camin = 0.0 @@ -152,103 +152,17 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if ( crtm_cloud ) then tb_xb_clr => iv%instid(i)%tb_xb_clr -! if (calc_ir_btlim) then - allocate ( cld_impact (iv%instid(i)%info%n1:iv%instid(i)%info%n2, 1:2) ) - cld_impact = missing_r - BTlim = missing_r - nlocal = iv%instid(i)%info%n2 - iv%instid(i)%info%n1 + 1 -#ifdef DM_PARALLEL - call mpi_allreduce( nlocal, nglobal, 1, mpi_integer, mpi_sum, comm, ierr ) -#else - nglobal = nlocal -#endif - allocate(cld_impact_global(nglobal, 1:2)) - allocate(weights_global(nglobal)) - - do k = 1, nchan - do n= iv%instid(i)%info%n1,iv%instid(i)%info%n2 - if ( .true. & - .and. tb_inv( k, n ) .gt. missing_r & - .and. tb_ob( k, n ) .gt. 0. & - .and. tb_xb( k, n ) .gt. 0. & - ) then - - cld_impact(n,1) = tb_xb(k,n) - cld_impact(n,2) = tb_xb_clr(k,n) - tb_xb(k,n) -!JJGDEBUG - if (print_cld_debug) write(stdout,'(A,2I8,2F16.8,6(2x,A))') 'PIXEL_DEBUG91: ', n, k, & - cld_impact(n,1:2), & - iv%instid(i)%info%date_char(n)(1:4), & - iv%instid(i)%info%date_char(n)(6:7), & - iv%instid(i)%info%date_char(n)(9:10), & - iv%instid(i)%info%date_char(n)(12:13), & - iv%instid(i)%info%date_char(n)(15:16), & - iv%instid(i)%info%date_char(n)(18:19) -! iv%instid(i)%info%date_char(n) - -!JJGDEBUG - end if - - end do - - buf_f = 0 - ProcLoop: do iproc = 0, num_procs-1 - nbuf = nlocal -#ifdef DM_PARALLEL - call mpi_bcast(nbuf, 1, mpi_integer, iproc, comm, ierr ) -#endif - if (nbuf .eq. 0) cycle - buf_i = buf_f + 1 - buf_f = buf_i + nbuf - 1 - - if (iproc .eq. myproc) then - cld_impact_global(buf_i:buf_f,:) = cld_impact(:,:) - else - cld_impact_global(buf_i:buf_f,:) = missing_r - end if - call mpi_bcast(cld_impact_global(buf_i:buf_f,:), nbuf * 2, true_mpi_real, iproc, comm, ierr ) - end do ProcLoop - - - ! JJG: This is a very rough estimate of BTlim for now -! where ( cld_impact_global(:,2) .ge. 0.1 ) !Really need to do this offline with stats from multiple days... - where ( cld_impact_global(:,2) .le. 0.00001 .or. cld_impact_global(:,2) .ge. 0.2 ) - cld_impact_global(:,1) = missing_r - end where - -! BTlim_temp = sum(cld_impact_global(:,1), cld_impact_global(:,1).gt.missing_r) / & -! count(cld_impact_global(:,1).gt.missing_r) - - where ( cld_impact_global(:,1).gt.missing_r ) - weights_global = 1. - abs(cld_impact_global(:,2) - 0.1) - elsewhere - weights_global = missing_r - end where - BTlim_temp = sum(cld_impact_global(:,1) * weights_global, cld_impact_global(:,1).gt.missing_r) / & - sum(weights_global, cld_impact_global(:,1).gt.missing_r) - -! BTlim_temp = minval(cld_impact_global(:,1), cld_impact_global(:,1).gt.missing_r) - if ( BTlim_temp.eq.BTlim_temp ) then - if ( BTlim_temp .gt. 0 ) BTlim(k) = BTlim_temp - end if -!Really need to do this offline with stats from multiple days...BTlim will be a lookup table across channels. - - !Alternatively could sort cld_impact by clr-cld difference, then - ! find median tb_xb at difference of 0.1 (how??) - -!JJGDEBUG - if (print_cld_debug) write(stdout,'(A,I8,F12.4)') 'PIXEL_DEBUG92: ', k, & - BTlim(k) -!JJGDEBUG - - end do - deallocate ( cld_impact ) - deallocate ( cld_impact_global ) - deallocate ( weights_global ) - -! else -! BTlim = 240. -! end if + !JJG: for Harnisch et al. BTlim using stats from CONUS 9km 2-hr WRF forecast from GSI analysis + BTlim(1) = 269.5 + BTlim(2) = 231.5 + BTlim(3) = 240.0 + BTlim(4) = 250.0 + BTlim(5) = 271.0 + BTlim(6) = 258.0 + BTlim(7) = 272.0 + BTlim(8) = 268.0 + BTlim(9) = 270.5 + BTlim(10) = 258.0 end if PixelQCLoop: do n= iv%instid(i)%info%n1,iv%instid(i)%info%n2 @@ -481,18 +395,20 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !-------------------------------------------------------------------------- ! Modify EMISS for sun glint area may be not work, because we are at north land ! - compute relative azimuth - Relaz = RELATIVE_AZIMUTH(iv%instid(i)%solazi(n),iv%instid(i)%satazi(n)) - - ! - compute glint angle - Glintzen = GLINT_ANGLE(iv%instid(i)%solzen(n),iv%instid(i)%satzen(n),Relaz ) - - if ( Glintzen.lt.40.0 .and. isflg==sea_flag) then - crit_clddet = - tb_inv(ch7,n) ! (B_ch7 - O_ch7) - offset_clddet = 1 - else - if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) & - crit_clddet = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14)/ & - (rad_b_ch7 / rad_b_ch14) + crit_clddet = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14)/ & + (rad_b_ch7 / rad_b_ch14) + + if ( iv%instid(i)%solzen(n) > 0. & + .and. iv%instid(i)%solzen(n) < 90. ) then + Relaz = RELATIVE_AZIMUTH(iv%instid(i)%solazi(n),iv%instid(i)%satazi(n)) + + ! - compute glint angle + Glintzen = GLINT_ANGLE(iv%instid(i)%solzen(n),iv%instid(i)%satzen(n),Relaz ) + + if ( Glintzen.lt.40.0 .and. isflg==sea_flag) then + crit_clddet = - tb_inv(ch7,n) ! (B_ch7 - O_ch7) + offset_clddet = 1 + end if end if case (8) @@ -546,7 +462,9 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) tb_qc_clddet = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) then nrej_clddet(:,itest) = nrej_clddet(:,itest) + 1 - write(stdout,"(A,F14.6,A,I4,2D12.4)") trim(crit_names_clddet(itest)), crit_clddet, " isflg", isflg, iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n) +!JJGDEBUG + if (print_cld_debug) write(stdout,"(A,F14.6,A,I4,2D12.4)") trim(crit_names_clddet(itest)), crit_clddet, " isflg", isflg, iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n) +!JJGDEBUG end if clddet_tests(itest) = 1 @@ -587,7 +505,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & ! max( 0., BTlim(k) - tb_ob(k,n) ) ) -! above using ob with VarBC +! using ob with VarBC ! ------------------------------- ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & max( 0., BTlim(k) - (tb_inv(k,n) + tb_xb(k,n)) ) ) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index f1bbf4395f..2b78722853 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -32,6 +32,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) type(info_type) :: info type(model_loc_type) :: loc integer(i_kind), allocatable :: ptotal(:) + integer(i_kind) :: nthinned real(r_double) :: crit integer(i_kind) :: iout, iobs, i_dummy(1) logical :: outside, outside_all, iuse, first_chan @@ -322,10 +323,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Collect files available for all views !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do iview = 1, nviews + PrepViews: do iview = 1, nviews this_view => view_att(iview) - if ( .not.this_view % select ) cycle + if ( .not.this_view % select ) cycle PrepViews ! Query fpath for files that match L1B naming conventions for this_view and satellite_id fname = trim(INST_PREFIX)//trim(this_view % name_short) @@ -383,7 +384,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) #endif if (this_view % nfiles .lt. 1) then this_view % select = .false. - cycle + cycle PrepViews end if allocate(this_view % filename(this_view % nfiles)) @@ -394,7 +395,156 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) close(file_unit) call da_free_unit(file_unit) - end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Allocate/init components for this_view + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + allocate(this_view % filechan(this_view % nfiles)) + allocate(this_view % filedate(this_view % nfiles)) + allocate(this_view % file_fgat_match(this_view % nfiles,num_fgat_time)) + allocate(this_view % fgat_time_abs_diff(this_view % nfiles,num_fgat_time)) + allocate(this_view % min_time_diff(nchan,num_fgat_time)) + allocate(this_view % nfiles_used(num_fgat_time)) + + this_view % file_fgat_match = .false. + do ifgat=1,num_fgat_time + this_view % fgat_time_abs_diff(:,ifgat) = & + abs(time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 !seconds + + this_view % min_time_diff(:,ifgat) = & + abs(time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 / 2.D0 !seconds + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Determine which of the files will be used based on user-definitions: + !! + fgat window length + !! + channels used + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do ifile = 1, this_view % nfiles + + !Grab the filename (without path) using INST_PREFIX + fname = trim(this_view % filename(ifile)) + ioff = index(fname, trim(INST_PREFIX)) +!! this_view % filepath(ifile) = fname(1:ioff-1) + fname = trim(fname(ioff:len(adjustl(trim(fname))))) +!! this_view % filename(ifile) = trim(fname) + + ioff = 0 + if (iview.eq.3 .or. iview.eq.4) ioff=1 + ioff = ioff+19 + read(fname(1+ioff:2+ioff),fmt='(I2.2)') this_view % filechan(ifile) + +!!! !! The channel could instead be read from band_id in each file, but +!!! !! opening/closing files for all channels is time consuming +!!! ierr=nf_open(trim(this_view % fpath)//trim(fname),nf_nowrite,ncid) +!!! ierr=nf_inq_varid(ncid,'band_id',varid) +!!! ierr=nf_get_var_int(ncid,varid,this_view % filechan(ifile)) +!!! ierr=nf_close(ncid) + + ! Check if channel is selected +! if ( .not.any(this_view % filechan(ifile) .eq. channel_select) .or. & + if ( .not.any(this_view % filechan(ifile) .eq. channel_list) ) then +!!! ierr=nf_close(ncid) + cycle + end if + + !! Determine central date of this file for obs binning + !obs START time + ioff = ioff + 8 + read(fname(1+ioff:4+ioff),fmt='(I4.4)') yr + read(fname(5+ioff:7+ioff),fmt='(I3.3)') jdy + read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr + read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn + read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc + obs_time = real(sc,8)/60.D0 / 2.D0 + + call jday2cal(jdy, yr, mt, dy) + call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(1)) + + this_view % filedate(ifile) % jdy = jdy + + !obs END time + ioff = ioff + 16 + read(fname(1+ioff:4+ioff),fmt='(I4.4)') yr + read(fname(5+ioff:7+ioff),fmt='(I3.3)') jdy + read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr + read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn + read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc + obs_time = obs_time + real(sc,8)/60.D0 / 2.D0 + + call jday2cal(jdy, yr, mt, dy) + call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(2)) + + obs_time = obs_time + (timbdy(1) + timbdy(2)) / 2.D0 + +!! The time it takes to read time_bounds from each file is not insignificant. Above method is much faster. +! !! Determine central date of this file for obs binning +!!! ierr=nf_open(trim(this_view % fpath)//trim(fname),nf_nowrite,ncid) +!!! ierr=nf_inq_varid(ncid,'time_bounds',varid) +!!! ierr=nf_get_var_double(ncid,varid,timbdy) +!!! ierr=nf_close(ncid) +!!! j2000=(timbdy(1) + timbdy(2)) / 2.D0 /86400.D0 + + call da_get_cal_time(obs_time,yr,mt,dy,hr,mn,sc) + obs_time = obs_time * 60.D0 + + this_view % filedate(ifile) % yr = yr + this_view % filedate(ifile) % mt = mt + this_view % filedate(ifile) % dy = dy + this_view % filedate(ifile) % hr = hr + this_view % filedate(ifile) % mn = mn + this_view % filedate(ifile) % sc = sc + this_view % filedate(ifile) % obs_time = obs_time + + +!JJG: Note that this test being limited by time_slots prevents the use of data before/after the first/last time of the window even if the observations outside the window were recorded at times nearer to those bounds than data contained within the window. + if ( obs_time < time_slots(0) * 60.D0 .or. & + obs_time >= time_slots(num_fgat_time) * 60.D0 ) then + cycle + end if + + do ifgat=1,num_fgat_time + this_view % file_fgat_match(ifile,ifgat) = & + ( obs_time >= time_slots(ifgat-1) * 60.D0 .and. & + obs_time < time_slots(ifgat) * 60.D0 ) + if (this_view % file_fgat_match(ifile,ifgat)) exit + end do + + this_view % fgat_time_abs_diff(ifile,ifgat) = & + abs( obs_time - fgat_times_r(ifgat) ) + + call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) + if ( this_view % fgat_time_abs_diff(ifile, ifgat) .ge. & + this_view % min_time_diff(ichan, ifgat) ) then + this_view % file_fgat_match(ifile,ifgat) = .false. + else + this_view % min_time_diff(ichan, ifgat) = this_view % fgat_time_abs_diff(ifile, ifgat) + end if + + if (count(this_view % file_fgat_match(ifile,:)) .gt. 1) then + print*, 'WARNING: More than one bin was selected for ',trim(fname) + print*, 'num_bin_per_file = ',count(this_view % file_fgat_match(ifile,:)) + print*, 'obs_time = ',obs_time + print*, 'Ignoring this file for reading.' + this_view % file_fgat_match(ifile,:) = .false. + cycle + end if + end do + + do ifgat = 1, num_fgat_time + ! Select a single file for this view, channel, and fgat using min_time_diff + if ( count(this_view % file_fgat_match(:, ifgat)).gt.1 ) then + do ifile = 1, this_view % nfiles + if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle + call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) + if ( this_view % fgat_time_abs_diff(ifile, ifgat) .gt. & + this_view % min_time_diff(ichan, ifgat) ) then + this_view % file_fgat_match(ifile,ifgat) = .false. + end if + end do + end if + end do + end do PrepViews !! If Full Disk is selected, take 2 passes over the data: !! + 1st pass: (A) Determine portions of each view corresponding to this patch @@ -425,144 +575,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if ( .not.this_view % select ) cycle - if (ipass .eq. 1) then - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! Allocate/init components for this_view - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - allocate(this_view % filechan(this_view % nfiles)) - allocate(this_view % filedate(this_view % nfiles)) - allocate(this_view % file_fgat_match(this_view % nfiles,num_fgat_time)) - allocate(this_view % fgat_time_abs_diff(this_view % nfiles,num_fgat_time)) - allocate(this_view % min_time_diff(nchan,num_fgat_time)) - allocate(this_view % nfiles_used(num_fgat_time)) - - this_view % file_fgat_match = .false. - do ifgat=1,num_fgat_time - this_view % fgat_time_abs_diff(:,ifgat) = & - abs(time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 !seconds - - this_view % min_time_diff(:,ifgat) = & - abs(time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 / 2.D0 !seconds - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! Determine which of the files will be used based on user-definitions: - !! + fgat window length - !! + channels used - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do ifile = 1, this_view % nfiles - - !Grab the filename (without path) using INST_PREFIX - fname = trim(this_view % filename(ifile)) - ioff = index(fname, trim(INST_PREFIX)) -!! this_view % filepath(ifile) = fname(1:ioff-1) - fname = trim(fname(ioff:len(adjustl(trim(fname))))) -!! this_view % filename(ifile) = trim(fname) - - ioff = 0 - if (iview.eq.3 .or. iview.eq.4) ioff=1 - ioff = ioff+19 - read(fname(1+ioff:2+ioff),fmt='(I2.2)') this_view % filechan(ifile) - -!!! !! The channel could instead be read from band_id in each file, but -!!! !! opening/closing files for all channels is time consuming -!!! ierr=nf_open(trim(this_view % fpath)//trim(fname),nf_nowrite,ncid) -!!! ierr=nf_inq_varid(ncid,'band_id',varid) -!!! ierr=nf_get_var_int(ncid,varid,this_view % filechan(ifile)) -!!! ierr=nf_close(ncid) - - ! Check if channel is selected -! if ( .not.any(this_view % filechan(ifile) .eq. channel_select) .or. & - if ( .not.any(this_view % filechan(ifile) .eq. channel_list) ) then -!!! ierr=nf_close(ncid) - cycle - end if - - !! Determine central date of this file for obs binning - !obs START time - ioff = ioff + 8 - read(fname(1+ioff:4+ioff),fmt='(I4.4)') yr - read(fname(5+ioff:7+ioff),fmt='(I3.3)') jdy - read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr - read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn - read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc - obs_time = real(sc,8)/60.D0 / 2.D0 - - call jday2cal(jdy, yr, mt, dy) - call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(1)) - - this_view % filedate(ifile) % jdy = jdy - - !obs END time - ioff = ioff + 16 - read(fname(1+ioff:4+ioff),fmt='(I4.4)') yr - read(fname(5+ioff:7+ioff),fmt='(I3.3)') jdy - read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr - read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn - read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc - obs_time = obs_time + real(sc,8)/60.D0 / 2.D0 - - call jday2cal(jdy, yr, mt, dy) - call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(2)) - - obs_time = obs_time + (timbdy(1) + timbdy(2)) / 2.D0 - -!! The time it takes to read time_bounds from each file is not insignificant. Above method is much faster. -! !! Determine central date of this file for obs binning -!!! ierr=nf_open(trim(this_view % fpath)//trim(fname),nf_nowrite,ncid) -!!! ierr=nf_inq_varid(ncid,'time_bounds',varid) -!!! ierr=nf_get_var_double(ncid,varid,timbdy) -!!! ierr=nf_close(ncid) -!!! j2000=(timbdy(1) + timbdy(2)) / 2.D0 /86400.D0 - - call da_get_cal_time(obs_time,yr,mt,dy,hr,mn,sc) - obs_time = obs_time * 60.D0 - - this_view % filedate(ifile) % yr = yr - this_view % filedate(ifile) % mt = mt - this_view % filedate(ifile) % dy = dy - this_view % filedate(ifile) % hr = hr - this_view % filedate(ifile) % mn = mn - this_view % filedate(ifile) % sc = sc - this_view % filedate(ifile) % obs_time = obs_time - - -!JJG: Note that this test being limited by time_slots prevents the use of data before/after the first/last time of the window even if the observations outside the window were recorded at times nearer to those bounds than data contained within the window. - if ( obs_time < time_slots(0) * 60.D0 .or. & - obs_time >= time_slots(num_fgat_time) * 60.D0 ) then - cycle - end if - - do ifgat=1,num_fgat_time - this_view % file_fgat_match(ifile,ifgat) = & - ( obs_time >= time_slots(ifgat-1) * 60.D0 .and. & - obs_time < time_slots(ifgat) * 60.D0 ) - if (this_view % file_fgat_match(ifile,ifgat)) exit - end do - - this_view % fgat_time_abs_diff(ifile,ifgat) = & - abs( obs_time - fgat_times_r(ifgat) ) - - call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) - if ( this_view % fgat_time_abs_diff(ifile, ifgat) .ge. & - this_view % min_time_diff(ichan, ifgat) ) then - this_view % file_fgat_match(ifile,ifgat) = .false. - else - this_view % min_time_diff(ichan, ifgat) = this_view % fgat_time_abs_diff(ifile, ifgat) - end if - - if (count(this_view % file_fgat_match(ifile,:)) .gt. 1) then - print*, 'WARNING: More than one bin was selected for ',trim(fname) - print*, 'num_bin_per_file = ',count(this_view % file_fgat_match(ifile,:)) - print*, 'obs_time = ',obs_time - print*, 'Ignoring this file for reading.' - this_view % file_fgat_match(ifile,:) = .false. - cycle - end if - end do - end if ! ipass == 1 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Access netcdf channel/band files across all fgat windows !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -574,18 +586,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) cycle fgat_loop end if - if ( ipass .eq. 1 .and. count(this_view % file_fgat_match(:, ifgat)).gt.1 ) then - ! Select a single file for this view, channel, and fgat using min_time_diff - do ifile = 1, this_view % nfiles - if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle - call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) - if ( this_view % fgat_time_abs_diff(ifile, ifgat) .gt. & - this_view % min_time_diff(ichan, ifgat) ) then - this_view % file_fgat_match(ifile,ifgat) = .false. - end if - end do - end if - first_file = 0 do ifile = 1, this_view % nfiles if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle @@ -960,7 +960,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) #ifdef DM_PARALLEL call mpi_bcast(nbuf, 1, mpi_integer, iproc, comm, ierr ) #endif - if (nbuf .eq. 0) cycle + if (nbuf .eq. 0) cycle ProcLoop buf_i = buf_f + 1 buf_f = buf_i + nbuf - 1 @@ -1140,8 +1140,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) #endif end if DoGridGen - if ( iview.eq.1 .and. ipass.lt.npass .and. sum(this_view % nfiles_used(:)).eq.0 ) then - if (this_view % nrad_on_patch_cldqc .gt. 0) then + if ( iview.eq.1 .and. ipass.lt.npass .and. & + sum(this_view % nfiles_used(:)).eq.0 ) then + if ( this_view % nrad_on_patch_cldqc .gt. 0 ) then allocate( view_mask( & this_view % ys_p_fd-2:this_view % ye_p_fd+2, & this_view % xs_p_fd-2:this_view % xe_p_fd+2, & @@ -1151,10 +1152,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) use_view_mask = .true. end if - if ( (ipass.lt.npass .and. iview.eq.1) .or. .not.use_view_mask ) then - num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain_cldqc - !ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain_cldqc - end if +! if ( (ipass.lt.npass .and. iview.eq.1) .or. .not.use_view_mask ) then +! num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain_cldqc +! !ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain_cldqc +! end if PatchMatch: if (this_view % nrad_on_patch_cldqc .gt. 0) then @@ -1169,7 +1170,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) exit end if end do - if ( ifile .eq. 0 ) cycle + if ( ifile .eq. 0 ) cycle ChannelLoop this_view % nfiles_used(ifgat) = this_view % nfiles_used(ifgat) + 1 @@ -1221,7 +1222,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if else - if (inst == 0) cycle !!Utilizing these masks to eliminate data: !! + earthmask !! + zenmask @@ -1247,15 +1247,16 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Only use locations where this view is nearest to this fgat time ! - only available when FD data present for any fgat time if ( use_view_mask ) then - if ( .not.any( view_mask ( this_view % ys_p_fd:this_view % ye_p_fd, & - this_view % xs_p_fd:this_view % xe_p_fd, & - iview, ichan, ifgat ) ) ) then + if ( .not.any( & + view_mask ( this_view % ys_p_fd:this_view % ye_p_fd, & + this_view % xs_p_fd:this_view % xe_p_fd, & + iview, ichan, ifgat ) & + ) ) then deallocate(allmask_p, readmask_p) - -! write(unit=stdout,fmt='(3A,I0)') & -! ' ZERO pixels selected for ',trim(this_view % name),' on band ', channel_list(ichan) + write(unit=stdout,fmt='(3A,I0)') & + ' ZERO pixels selected for ',trim(this_view % name),' on band ', channel_list(ichan) this_view % nfiles_used(ifgat) = this_view % nfiles_used(ifgat) - 1 - cycle + cycle ChannelLoop end if do n = 1, this_view % nrad_on_patch iy = this_view % iy_1d % patch (n) @@ -1278,9 +1279,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !! + fgat !! + channel/band !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - write(unit=stdout,fmt='(A,I0)') & - ' Reading abi radiances for band ',channel_list(ichan) - + write(unit=stdout,fmt='(A,I0,A,I0)') & + ' Reading ', count(readmask_p), ' abi radiances for band ',channel_list(ichan) + if ( use_clddet_zz) write(unit=stdout,fmt='(A,I0)') & + ' which includes the cloud detection halo' TEMPIR_ifile = -1 if ( use_clddet_zz .and. channel_list(ichan).eq.14 ) then ! Require earlier file to be withn 1/2 of TEMPIR_delay_minutes @@ -1320,7 +1322,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) this_view % ys_local:this_view % ye_local, & this_view % xs_local:this_view % xe_local, 1 ) ) end if - fname = trim(this_view % filename(ifile)) call get_abil1b_bt( fname, & this_view % ys_local, this_view % ye_local, & @@ -1334,7 +1335,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! flag in the datalink_type. ! Presently readmask_p is used internally within get_abil1b_bt to set bt_p=missing_r (works fine) !allmask_p = (allmask_p .and. readmask_p) - if ( TEMPIR_ifile.gt.0 ) then fname = trim(this_view % filename(TEMPIR_ifile)) call get_abil1b_bt( fname, & @@ -1389,6 +1389,15 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) call da_get_solar_angles_1d ( yr, mt, dy, hr, mn, sc, & this_view % lat_1d % patch, this_view % lon_1d % patch, & solzen_1d, solazi_1d ) + +! do n = 1, this_view % nrad_on_patch +! iy = this_view % iy_1d % patch (n) +! ix = this_view % ix_1d % patch (n) +! if (.not. allmask_p( iy, ix )) cycle +! call da_get_solar_angles ( yr, mt, dy, hr, mn, sc, & +! this_view % lat_1d % patch(n), this_view % lon_1d % patch(n), & +! solzen_1d(n), solazi_1d(n) ) +! end do end if allocate(thinmask(this_view % ys_p:this_view % ye_p, & @@ -1398,16 +1407,16 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) p => p_fgat end if - do n = 1, this_view % nrad_on_patch + PixelLoop: do n = 1, this_view % nrad_on_patch iy = this_view % iy_1d % patch (n) ix = this_view % ix_1d % patch (n) - if (.not. allmask_p( iy, ix )) cycle + if (.not. allmask_p( iy, ix )) cycle PixelLoop if (first_chan) then info % lat = this_view % lat_1d % patch (n) ! latitude info % lon = this_view % lon_1d % patch (n) ! longitude - +! num_goesabi_global = num_goesabi_global + 1 num_goesabi_local = num_goesabi_local + 1 end if @@ -1424,10 +1433,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if (.not. iuse) then num_goesabi_thinned=num_goesabi_thinned+1 thinmask( iy, ix ) = .true. - cycle + cycle PixelLoop end if else - if (thinmask( iy, ix )) cycle + if (thinmask( iy, ix )) cycle PixelLoop end if end if @@ -1463,6 +1472,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) p % solzen = missing_r p % solazi = missing_r end if + if ( p % solzen < 0. ) p % solzen = 150. p % sensor_index = inst p % ifgat = ifgat end if @@ -1647,8 +1657,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if (first_chan) & nullify (p % next) - end do - deallocate( bt_p, allmask_p, readmask_p) + end do PixelLoop + if ( allocated(bt_p) ) deallocate ( bt_p ) + if ( allocated(allmask_p) ) deallocate ( allmask_p ) + if ( allocated(readmask_p) ) deallocate ( readmask_p ) if ( allocated(terrain_hgt) ) deallocate ( terrain_hgt ) end if VIEW_SELECT end do ChannelLoop @@ -1656,6 +1668,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if ( allocated(thinmask) ) deallocate ( thinmask ) if ( allocated(solzen_1d) ) deallocate ( solzen_1d ) if ( allocated(solazi_1d) ) deallocate ( solazi_1d ) + else + write(unit=stdout,fmt='(A)') & + ' No pixels to read within this subdomain. Waiting for other processors...' end if PatchMatch #ifdef DM_PARALLEL @@ -1714,6 +1729,14 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) call da_warning(__FILE__,__LINE__, message(1:1)) end if +#ifdef DM_PARALLEL + call mpi_allreduce( num_goesabi_local, & + num_goesabi_global, & + 1, mpi_integer, mpi_sum, comm, ierr ) +#else + num_goesabi_global = num_goesabi_local +#endif + !------------------------------------------------------ ! NOTE: Remainder of this subroutine modified from da_read_obs_ncgoesimg.inc @@ -1817,29 +1840,40 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) iv % info(radiance) % nlocal = iv % info(radiance) % nlocal + num_goesabi_used iv % info(radiance) % ntotal = iv % info(radiance) % ntotal + num_goesabi_global -#ifdef DM_PARALLEL do i = 1, num_fgat_time +#ifdef DM_PARALLEL call mpi_allreduce( num_goesabi_used_fgat(i), & ptotal(i), & 1, mpi_integer, mpi_sum, comm, ierr ) - end do #else - ptotal(i) = num_goesabi_used_fgat(i) + ptotal(i) = num_goesabi_used_fgat(i) #endif + end do do i = 1, num_fgat_time ptotal(i) = ptotal(i) + ptotal(i-1) iv % info(radiance) % ptotal(i) = iv % info(radiance) % ptotal(i) + ptotal(i) end do - if ( iv % info(radiance) % ptotal(num_fgat_time) /= (iv % info(radiance) % ntotal - num_goesabi_thinned) ) then + +#ifdef DM_PARALLEL + call mpi_allreduce( num_goesabi_thinned, & + nthinned, & + 1, mpi_integer, mpi_sum, comm, ierr ) +#else + nthinned = num_goesabi_thinned +#endif + + if ( iv % info(radiance) % ptotal(num_fgat_time) /= (iv % info(radiance) % ntotal - nthinned) ) then write(unit=message(1),fmt='(A,I10,A,I10)') & - "Number of ntotal - nthinned:",iv % info(radiance) % ntotal - num_goesabi_thinned," is different from the sum of ptotal:", iv % info(radiance) % ptotal(num_fgat_time) + "Number of ntotal - nthinned:",iv % info(radiance) % ntotal - nthinned," is different from the sum of ptotal:", iv % info(radiance) % ptotal(num_fgat_time) call da_warning(__FILE__,__LINE__,message(1:1)) endif - write(unit=stdout,fmt='(a)') 'num_goesabi_global, num_goesabi_local, num_goesabi_used, num_goesabi_thinned' - write(unit=stdout,fmt=*) num_goesabi_global, num_goesabi_local, num_goesabi_used, num_goesabi_thinned + write(unit=stdout,fmt='(a)') 'num_goesabi_global, num_goesabi_thinned_global, num_goesabi_used_global' + write(unit=stdout,fmt=*) num_goesabi_global, nthinned, ptotal(num_fgat_time) + write(unit=stdout,fmt='(a)') 'num_goesabi_local, num_goesabi_thinned, num_goesabi_used' + write(unit=stdout,fmt=*) num_goesabi_local, num_goesabi_thinned, num_goesabi_used ! 5.0 allocate innovation radiance structure !---------------------------------------------------------------- From 105a525bdfb1b1ddd491c406d37ff1296bdb2cae Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Thu, 23 May 2019 12:29:19 -0600 Subject: [PATCH 43/86] Small fix to depend.txt, include da_togrid_1d.inc --- var/build/depend.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/var/build/depend.txt b/var/build/depend.txt index f2c4ead016..bbf5dedf93 100644 --- a/var/build/depend.txt +++ b/var/build/depend.txt @@ -162,7 +162,7 @@ da_statistics.o : da_statistics.f90 da_print_qcstat.inc da_stats_calculate.inc d da_synop.o : da_synop.f90 da_check_buddy_synop.inc da_calculate_grady_synop.inc da_check_max_iv_synop.inc da_get_innov_vector_synop.inc da_transform_xtoy_synop_adj.inc da_transform_xtoy_synop.inc da_print_stats_synop.inc da_oi_stats_synop.inc da_residual_synop.inc da_jo_synop_uvtq.inc da_jo_and_grady_synop.inc da_ao_stats_synop.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_tamdar.o : da_tamdar.f90 da_calculate_grady_tamdar_sfc.inc da_check_max_iv_tamdar_sfc.inc da_get_innov_vector_tamdar_sfc.inc da_transform_xtoy_tamdar_sfc_adj.inc da_transform_xtoy_tamdar_sfc.inc da_print_stats_tamdar_sfc.inc da_oi_stats_tamdar_sfc.inc da_residual_tamdar_sfc.inc da_jo_tamdar_sfc_uvtq.inc da_jo_and_grady_tamdar_sfc.inc da_ao_stats_tamdar_sfc.inc da_calculate_grady_tamdar.inc da_get_innov_vector_tamdar.inc da_check_max_iv_tamdar.inc da_transform_xtoy_tamdar_adj.inc da_transform_xtoy_tamdar.inc da_print_stats_tamdar.inc da_oi_stats_tamdar.inc da_residual_tamdar.inc da_jo_tamdar_uvtq.inc da_jo_and_grady_tamdar.inc da_ao_stats_tamdar.inc da_tracing.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_test.o : da_test.f90 da_test_vxtransform.inc da_check_gradient.inc da_get_y_lhs_value.inc da_check_vtoy_adjoint.inc da_set_tst_trnsf_fld.inc da_check_psfc.inc da_check_sfc_assi.inc da_setup_testfield.inc da_check_xtoy_adjoint_buoy.inc da_check_xtoy_adjoint_profiler.inc da_check_xtoy_adjoint_ssmt2.inc da_check_xtoy_adjoint_ssmt1.inc da_check_xtoy_adjoint_qscat.inc da_check_xtoy_adjoint_pseudo.inc da_dot_cv.inc da_dot.inc da_check.inc da_check_gradient.inc da_transform_xtovp.inc da_check_xtoy_adjoint_rad.inc da_check_xtoy_adjoint_synop.inc da_check_xtoy_adjoint_tamdar_sfc.inc da_check_xtoy_adjoint_tamdar.inc da_check_xtoy_adjoint_mtgirs.inc da_check_xtoy_adjoint_sonde_sfc.inc da_check_xtoy_adjoint_sound.inc da_check_xtoy_adjoint_bogus.inc da_check_xtoy_adjoint_rain.inc da_check_xtoy_adjoint_radar.inc da_check_xtoy_adjoint_ships.inc da_check_xtoy_adjoint_polaramv.inc da_check_xtoy_adjoint_geoamv.inc da_check_xtoy_adjoint_satem.inc da_check_xtoy_adjoint_ssmi_tb.inc da_check_xtoy_adjoint_ssmi_rv.inc da_check_xtoy_adjoint_pilot.inc da_check_xtoy_adjoint_metar.inc da_check_xtoy_adjoint_gpsref.inc da_check_xtoy_adjoint_gpspw.inc da_check_xtoy_adjoint_airep.inc da_check_xtoy_adjoint.inc da_check_xtovptox_errors.inc da_check_vvtovp_adjoint.inc da_check_vp_errors.inc da_check_vptox_adjoint.inc da_check_vtox_adjoint.inc da_check_cvtovv_adjoint.inc da_check_balance.inc da_4dvar.o da_vtox_transforms.o da_wrfvar_io.o da_wrf_interfaces.o da_transfer_model.o da_tracing.o da_tools_serial.o da_statistics.o da_ssmi.o da_spectral.o da_reporting.o da_physics.o da_par_util1.o da_par_util.o da_obs.o da_minimisation.o da_ffts.o da_dynamics.o da_define_structures.o module_state_description.o module_domain.o da_control.o module_comm_dm.o module_dm.o module_configure.o da_rain.o da_check_dynamics_adjoint.inc da_check_xtoy_adjoint_gpseph.inc -da_tools.o : da_tools.f90 da_geo2msl1.inc da_msl2geo1.inc da_get_time_slots.inc da_get_julian_time.inc da_get_print_lvl.inc da_get_3d_sum.inc da_get_2d_sum.inc da_set_boundary_3d.inc da_set_boundary_xb.inc da_set_boundary_xa.inc da_ludcmp.inc da_lubksb.inc da_eof_decomposition.inc da_eof_decomposition_test.inc da_buddy_qc.inc da_unifva.inc da_togrid.inc da_togrid_new.inc da_smooth_anl.inc da_openfile.inc da_gaus_noise.inc da_set_randomcv.inc da_random_omb.inc da_max_error_qc.inc da_add_noise_new.inc da_add_noise.inc da_residual_new.inc da_residual.inc da_diff_seconds.inc da_mo_correction.inc da_intpsfc_tem.inc da_intpsfc_prs.inc da_sfcprs.inc da_obs_sfc_correction.inc da_1d_eigendecomposition.inc da_convert_zk.inc da_lc_cone.inc da_set_merc.inc da_map_set.inc da_map_init.inc da_set_ps.inc da_set_lc.inc da_xyll_ps.inc da_xyll_merc.inc da_xyll_lc.inc da_xyll_latlon.inc da_xyll_default.inc da_xyll.inc da_llxy_wrf_new.inc da_llxy_wrf.inc da_llxy_ps_new.inc da_llxy_ps.inc da_llxy_merc_new.inc da_llxy_merc.inc da_llxy_lc_new.inc da_llxy_lc.inc da_llxy_latlon_new.inc da_llxy_latlon.inc da_llxy_rotated_latlon.inc da_llxy_global_new.inc da_llxy_global.inc da_llxy_kma_global_new.inc da_llxy_kma_global.inc da_llxy_default_new.inc da_llxy_default.inc da_llxy_new.inc da_llxy.inc da_llxy_1d.inc da_llxy_default_1d.inc da_llxy_kma_global_1d.inc da_llxy_global_1d.inc da_llxy_rotated_latlon_1d.inc da_llxy_latlon_1d.inc da_llxy_lc_1d.inc da_llxy_merc_1d.inc da_llxy_ps_1d.inc da_llxy_wrf_1d.inc da_map_utils_defines.inc da_lapack.o da_reporting.o da_tracing.o da_tools_serial.o da_define_structures.o da_control.o module_domain.o module_dm.o module_bc.o da_sfc_hori_interp_weights.inc +da_tools.o : da_tools.f90 da_geo2msl1.inc da_msl2geo1.inc da_get_time_slots.inc da_get_julian_time.inc da_get_print_lvl.inc da_get_3d_sum.inc da_get_2d_sum.inc da_set_boundary_3d.inc da_set_boundary_xb.inc da_set_boundary_xa.inc da_ludcmp.inc da_lubksb.inc da_eof_decomposition.inc da_eof_decomposition_test.inc da_buddy_qc.inc da_unifva.inc da_togrid.inc da_togrid_new.inc da_smooth_anl.inc da_openfile.inc da_gaus_noise.inc da_set_randomcv.inc da_random_omb.inc da_max_error_qc.inc da_add_noise_new.inc da_add_noise.inc da_residual_new.inc da_residual.inc da_diff_seconds.inc da_mo_correction.inc da_intpsfc_tem.inc da_intpsfc_prs.inc da_sfcprs.inc da_obs_sfc_correction.inc da_1d_eigendecomposition.inc da_convert_zk.inc da_lc_cone.inc da_set_merc.inc da_map_set.inc da_map_init.inc da_set_ps.inc da_set_lc.inc da_xyll_ps.inc da_xyll_merc.inc da_xyll_lc.inc da_xyll_latlon.inc da_xyll_default.inc da_xyll.inc da_llxy_wrf_new.inc da_llxy_wrf.inc da_llxy_ps_new.inc da_llxy_ps.inc da_llxy_merc_new.inc da_llxy_merc.inc da_llxy_lc_new.inc da_llxy_lc.inc da_llxy_latlon_new.inc da_llxy_latlon.inc da_llxy_rotated_latlon.inc da_llxy_global_new.inc da_llxy_global.inc da_llxy_kma_global_new.inc da_llxy_kma_global.inc da_llxy_default_new.inc da_llxy_default.inc da_llxy_new.inc da_llxy.inc da_llxy_1d.inc da_llxy_default_1d.inc da_llxy_global_1d.inc da_llxy_kma_global_1d.inc da_llxy_latlon_1d.inc da_llxy_lc_1d.inc da_llxy_merc_1d.inc da_llxy_ps_1d.inc da_llxy_rotated_latlon_1d.inc da_llxy_wrf_1d.inc da_togrid_1d.inc da_map_utils_defines.inc da_lapack.o da_reporting.o da_tracing.o da_tools_serial.o da_define_structures.o da_control.o module_domain.o module_dm.o module_bc.o da_sfc_hori_interp_weights.inc da_tools_serial.o : da_tools_serial.f90 da_find_fft_trig_funcs.inc da_find_fft_factors.inc da_advance_time.inc da_advance_cymdh.inc da_array_print.inc da_change_date.inc da_free_unit.inc da_get_unit.inc da_reporting.o da_control.o da_tracing.o : da_tracing.f90 da_trace_report.inc da_trace_real_sort.inc da_trace_int_sort.inc da_trace_exit.inc da_trace.inc da_trace_entry.inc da_trace_init.inc da_reporting.o da_par_util1.o da_control.o da_transfer_model.o : da_transfer_model.f90 da_get_2nd_firstguess.inc da_setup_firstguess_kma.inc da_setup_firstguess_wrf_nmm_regional.inc da_setup_firstguess_wrf.inc da_setup_firstguess.inc da_transfer_xatoanalysis.inc da_transfer_wrftl_lbc_t0_adj.inc da_transfer_xatowrftl_adj_lbc.inc da_transfer_xatowrftl_adj.inc da_transfer_wrftl_lbc_t0.inc da_transfer_xatowrftl_lbc.inc da_transfer_xatowrftl.inc da_transfer_wrftltoxa_adj.inc da_transfer_wrftltoxa.inc da_transfer_xatokma.inc da_transfer_xatowrf_nmm_regional.inc da_transfer_xatowrf.inc da_transfer_kmatoxb.inc da_transfer_wrf_nmm_regional_toxb.inc da_transfer_wrftoxb.inc module_io_wrf.o module_bc.o da_4dvar.o da_vtox_transforms.o da_tracing.o da_tools.o da_ssmi.o da_setup_structures.o da_reporting.o da_physics.o da_par_util.o da_grid_definitions.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_state_description.o module_io_domain.o module_domain.o module_date_time.o module_configure.o da_wrf_interfaces.o da_radar.o From ea59aaaa23e81fb9a7c0ba1b6e95ab6acbc9b092 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Tue, 4 Jun 2019 16:55:50 -0600 Subject: [PATCH 44/86] Updating all-sky statistics and code --- var/da/da_radiance/da_qc_goesabi.inc | 83 +++++++++++++++----------- var/run/radiance_info/goes-16-abi.info | 20 +++---- 2 files changed, 59 insertions(+), 44 deletions(-) diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 9b3619ec68..26e90bf67d 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -42,7 +42,8 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) real :: BTlim(nchan) real, allocatable :: cld_impact(:,:), cld_impact_global(:,:), weights_global(:) integer :: buf_i, buf_f, nbuf, nlocal, nglobal, iproc - real, parameter :: camin = 0.0 + real, parameter :: camin = 0.0 !Harnisch et al. (2016) + !real, parameter :: camin = 0.5 !Okamoto et al. (2013) !! Additional variables used by Zhuge and Zou (2017) integer :: itest @@ -154,9 +155,14 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !JJG: for Harnisch et al. BTlim using stats from CONUS 9km 2-hr WRF forecast from GSI analysis BTlim(1) = 269.5 - BTlim(2) = 231.5 - BTlim(3) = 240.0 - BTlim(4) = 250.0 +!3km 2/3 CONUS stats 01 MAY 2018 (mean) + BTlim(2) = 237.0 + BTlim(3) = 249.0 + BTlim(4) = 261.0 +!3km 2/3 CONUS stats 01 MAY 2018 (median) +! BTlim(2) = 231.5 +! BTlim(3) = 240.0 +! BTlim(4) = 250.5 BTlim(5) = 271.0 BTlim(6) = 258.0 BTlim(7) = 272.0 @@ -497,54 +503,63 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) .and. tb_inv( k, n ) .gt. missing_r & .and. tb_ob( k, n ) .gt. 0. & .and. tb_xb( k, n ) .gt. 0. & - .and. BTlim(k) .gt. 0. & ) then -! using ob without VarBC +! using ob with VarBC (tb_inv + tb_xb) ! ------------------------------- -! ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & -! max( 0., BTlim(k) - tb_ob(k,n) ) ) - -! using ob with VarBC -! ------------------------------- - ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & - max( 0., BTlim(k) - (tb_inv(k,n) + tb_xb(k,n)) ) ) +!! Harnisch et al. (2016) + if ( BTlim(k) .gt. 0. ) then + ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & + max( 0., BTlim(k) - (tb_inv(k,n) + tb_xb(k,n)) ) ) + end if +! if ( tb_xb_clr(k,n) .gt. 0. ) then +!! Okamoto et al. (2013) +! ca_mean(k,n) = 0.5 * ( abs( tb_xb(k,n) - tb_xb_clr(k,n) ) + & +! abs( (tb_inv(k,n) + tb_xb(k,n)) - tb_xb_clr(k,n) ) ) +!!! J. Guerrette +! ca_mean(k,n) = 0.5 * ( max( 0., tb_xb_clr(k,n) - tb_xb(k,n) ) + & +! max( 0., tb_xb_clr(k,n) - (tb_inv(k,n) + tb_xb(k,n)) ) ) +! end if end if !JJGDEBUG if (print_cld_debug) write(stdout,'(A,2I8,2F16.8)') 'PIXEL_DEBUG93: ', n, k, & ca_mean(k,n) !JJGDEBUG - end do - ! symmetric error model, Harnish, Weissmann, & Perianez (2016) + ! symmetric error model + ! - Okamoto, McNally, & Bell (2013) + ! - Harnish, Weissmann, & Perianez (2016) do k = 1, nchan - if ( ca_mean(k,n).lt.camin .and. ca_mean(k,n).gt.missing_r ) then - iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) - else if ( ca_mean(k,n) .lt. satinfo(i)%error_cld_x(k) ) then - iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) + & - ( satinfo(i)%error_cld_y(k) - satinfo(i)%error_std(k) ) * & - ( ca_mean(k,n) - camin ) / ( satinfo(i)%error_cld_x(k) - camin ) + if ( ca_mean(k,n).gt.missing_r ) then + if ( ca_mean(k,n).lt.camin ) then + iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) + else if ( ca_mean(k,n) .lt. satinfo(i)%error_cld_x(k) ) then + iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) + & + ( satinfo(i)%error_cld_y(k) - satinfo(i)%error_std(k) ) * & + ( ca_mean(k,n) - camin ) / ( satinfo(i)%error_cld_x(k) - camin ) + else + iv%instid(i)%tb_error(k,n) = satinfo(i)%error_cld_y(k) + end if else - iv%instid(i)%tb_error(k,n) = satinfo(i)%error_cld_y(k) + iv%instid(i)%tb_error(k,n) = missing_r end if end do ! nchan end if ! 5.1 check innovation !----------------------------------------------------------------- - if (.not. crtm_cloud ) then - ! absolute departure check - do k = 1, nchan - inv_grosscheck = 15.0 - if (use_satcv(2)) inv_grosscheck = 100.0 - if (abs(tb_inv(k,n)) > inv_grosscheck) then - tb_qc(k) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & - nrej_omb_abs(k) = nrej_omb_abs(k) + 1 - end if - end do ! nchan - end if + ! absolute departure check + inv_grosscheck = 15.0 + if (crtm_cloud) inv_grosscheck = 80.0 + if (use_satcv(2)) inv_grosscheck = 100.0 + do k = 1, nchan + if (abs(tb_inv(k,n)) > inv_grosscheck) then + tb_qc(k) = qc_bad + if (iv%instid(i)%info%proc_domain(1,n)) & + nrej_omb_abs(k) = nrej_omb_abs(k) + 1 + end if + end do ! nchan iv%instid(i)%tb_qc(:,n) = tb_qc diff --git a/var/run/radiance_info/goes-16-abi.info b/var/run/radiance_info/goes-16-abi.info index ad646d9ce6..e3833c7294 100644 --- a/var/run/radiance_info/goes-16-abi.info +++ b/var/run/radiance_info/goes-16-abi.info @@ -1,11 +1,11 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) - 1023 1 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 2 1 1 0 5.0000000000E+00 0.0000000000E+00 10.00000 9.00000 - 1023 3 1 1 0 5.0000000000E+00 0.0000000000E+00 16.00000 15.00000 - 1023 4 1 1 0 5.0000000000E+00 0.0000000000E+00 21.00000 19.00000 - 1023 5 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 6 1 1 0 10.0000000000E+00 0.0000000000E+00 30.00000 8.00000 - 1023 7 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 8 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 9 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 10 1 1 0 5.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 1 -1 1 0 2.7200000000E+00 0.0000000000E+00 24.00000 27.00000 + 1023 2 1 1 0 1.7900000000E+00 0.0000000000E+00 8.60000 18.00000 + 1023 3 1 1 0 1.9200000000E+00 0.0000000000E+00 12.00000 26.00000 + 1023 4 1 1 0 1.7400000000E+00 0.0000000000E+00 16.90000 23.00000 + 1023 5 -1 1 0 5.0000000000E+00 0.0000000000E+00 27.00000 18.00000 + 1023 6 -1 1 0 2.7900000000E+00 0.0000000000E+00 15.00000 10.00000 + 1023 7 -1 1 0 3.0800000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 8 -1 1 0 3.0600000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 9 -1 1 0 2.8200000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 10 -1 1 0 1.7400000000E+00 0.0000000000E+00 20.00000 12.00000 From 38ed46bafb435659f056adb70b51bee5ae88ddce Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Sat, 8 Jun 2019 12:11:24 -0600 Subject: [PATCH 45/86] Better cloud info in diagnostic outputs --- var/da/da_monitor/da_rad_diags.f90 | 15 +- var/da/da_radiance/da_qc_goesabi.inc | 140 ++++++++++--------- var/da/da_radiance/da_write_iv_rad_ascii.inc | 2 + var/da/da_radiance/da_write_oa_rad_ascii.inc | 2 + 4 files changed, 89 insertions(+), 70 deletions(-) diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index 7235562f17..8a51bd85b8 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -60,7 +60,7 @@ program da_rad_diags real*4, dimension(:), allocatable :: ret_clw real*4, dimension(:), allocatable :: satzen, satazi, t2m, mr2m, u10, v10, ps, ts real*4, dimension(:), allocatable :: smois, tslb, snowh, vegfra, clwp - integer, dimension(:,:), allocatable :: tb_qc + integer, dimension(:,:), allocatable :: tb_qc, tb_cloud real*4, dimension(:,:), allocatable :: tb_obs, tb_bak, tb_inv, tb_oma, tb_err, ems, ems_jac real*4, dimension(:,:), allocatable :: ca_mean, tb_bak_clr real*4, dimension(:,:), allocatable :: prf_pfull, prf_phalf, prf_t, prf_q, prf_water @@ -254,6 +254,7 @@ program da_rad_diags allocate ( tb_oma(1:nchan,1:total_npixel) ) allocate ( tb_err(1:nchan,1:total_npixel) ) allocate ( tb_qc(1:nchan,1:total_npixel) ) + allocate ( tb_cloud(1:nchan,1:total_npixel) ) if ( abi ) then allocate ( ca_mean(1:nchan,1:total_npixel) ) allocate ( tb_bak_clr(1:nchan,1:total_npixel) ) @@ -380,7 +381,13 @@ program da_rad_diags read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_err(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! QC read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_qc(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CA or INFO or level + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CLOUD, CA, INFO, or level + if ( buf(1:5) == "CLOUD" ) then ! read cloud detection info + read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_cloud(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CA, INFO, or level + else + tb_cloud = 0 + end if if ( abi .and. buf(1:2) == "CA" ) then ! read ca_mean, tb_bak_clr for abi read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) ca_mean(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! BGCLR @@ -513,6 +520,7 @@ program da_rad_diags end if ios = NF_DEF_VAR(ncid, 'tb_err', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_DEF_VAR(ncid, 'tb_qc', NF_INT, 2, ishape(1:2), varid) + ios = NF_DEF_VAR(ncid, 'tb_cloud', NF_INT, 2, ishape(1:2), varid) if ( abi ) then ios = NF_DEF_VAR(ncid, 'ca_mean', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) @@ -656,6 +664,8 @@ program da_rad_diags ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_err) ios = NF_INQ_VARID (ncid, 'tb_qc', varid) ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), tb_qc) + ios = NF_INQ_VARID (ncid, 'tb_cloud', varid) + ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), tb_cloud) if ( abi ) then ios = NF_INQ_VARID (ncid, 'ca_mean', varid) ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), ca_mean) @@ -875,6 +885,7 @@ program da_rad_diags if ( jac_found ) deallocate ( ems_jac ) deallocate ( tb_err ) deallocate ( tb_qc ) + deallocate ( tb_cloud ) if ( prf_found .and. (rtm_option == 'CRTM') ) then deallocate ( prf_pfull ) deallocate ( prf_phalf ) diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 26e90bf67d..9b59ea4cac 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -1,4 +1,4 @@ -subroutine da_qc_goesabi (it, i, nchan, ob, iv) +subroutine da_qc_goesabi (it, isens, nchan, ob, iv) !--------------------------------------------------------------------------- ! Purpose: perform quality control for abi data. @@ -8,7 +8,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) implicit none integer, intent(in) :: it ! outer loop count - integer, intent(in) :: i ! sensor index. + integer, intent(in) :: isens ! sensor index. integer, intent(in) :: nchan ! number of channel type (y_type), intent(in) :: ob ! Observation structure. type (iv_type), intent(inout) :: iv ! O-B structure. @@ -84,7 +84,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if (trace_use) call da_trace_entry("da_qc_goesabi") -!! if (iv%instid(i)%num_rad .le. 0) return +!! if (iv%instid(isens)%num_rad .le. 0) return ! These values can change as SRF (spectral response function) is updated ! It is recommended to acquire these from L1B files, not copy them from GOES R PUG L1b Vol. 3 @@ -142,16 +142,16 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) nrej_clddet = 0 - tb_ob => ob%instid(i)%tb - tb_xb => iv%instid(i)%tb_xb - tb_inv => iv%instid(i)%tb_inv + tb_ob => ob%instid(isens)%tb + tb_xb => iv%instid(isens)%tb_xb + tb_inv => iv%instid(isens)%tb_inv ! print_cld_debug = .true. print_cld_debug = .false. if ( crtm_cloud ) then - tb_xb_clr => iv%instid(i)%tb_xb_clr + tb_xb_clr => iv%instid(isens)%tb_xb_clr !JJG: for Harnisch et al. BTlim using stats from CONUS 9km 2-hr WRF forecast from GSI analysis BTlim(1) = 269.5 @@ -169,20 +169,24 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) BTlim(8) = 268.0 BTlim(9) = 270.5 BTlim(10) = 258.0 + + ca_mean => iv%instid(isens)%ca_mean + ca_mean = missing_r end if - PixelQCLoop: do n= iv%instid(i)%info%n1,iv%instid(i)%info%n2 + PixelQCLoop: do n= iv%instid(isens)%info%n1,iv%instid(isens)%info%n2 - if (iv%instid(i)%info%proc_domain(1,n)) & + if (iv%instid(isens)%info%proc_domain(1,n)) & num_proc_domain = num_proc_domain + 1 ! 0.0 initialise QC by flags assuming good obs !----------------------------------------------------------------- tb_qc = qc_good + iv%instid(isens)%cloud_flag(:,n) = qc_good ! 1.0 reject all channels over mixed surface type !------------------------------------------------------ - isflg = iv%instid(i)%isflg(n) + isflg = iv%instid(isens)%isflg(n) lmix = (isflg==msea_flag) .or. & (isflg==mland_flag) .or. & (isflg==msnow_flag) .or. & @@ -190,7 +194,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if (lmix) then tb_qc = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & + if (iv%instid(isens)%info%proc_domain(1,n)) & nrej_mixsurface = nrej_mixsurface + 1 end if @@ -206,31 +210,31 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! 2.0 check iuse !----------------------------------------------------------------- do k = 1, nchan - if (satinfo(i)%iuse(k) .eq. -1) & + if (satinfo(isens)%iuse(k) .eq. -1) & tb_qc(k) = qc_bad end do ! 3.0 check cloud !----------------------------------------------------------------- if (.not. crtm_cloud ) then - if (iv%instid(i)%clwp(n) >= 0.2) then + if (iv%instid(isens)%clwp(n) >= 0.2) then tb_qc = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & + if (iv%instid(isens)%info%proc_domain(1,n)) & nrej_clw(:) = nrej_clw(:) + 1 end if cloud_detection=.false. if (cloud_detection) then - if (iv%instid(i)%landsea_mask(n) == 0 ) then + if (iv%instid(isens)%landsea_mask(n) == 0 ) then if ( ( tb_xb(3,n) - tb_ob(3,n) ) > 3.5) then tb_qc = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & + if (iv%instid(isens)%info%proc_domain(1,n)) & nrej_eccloud(:) = nrej_eccloud(:) + 1 end if else if ( ( tb_xb(3,n) - tb_ob(3,n) ) > 2.5) then tb_qc = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & + if (iv%instid(isens)%info%proc_domain(1,n)) & nrej_eccloud(:) = nrej_eccloud(:) + 1 end if end if @@ -242,6 +246,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) .and. all(tb_ob( (/ch7,ch14,ch15/), n ) .gt. missing_r) & .and. all(tb_xb( (/ch7,ch14,ch15/), n ) .gt. missing_r) & ) then + !!=============================================================================== !!=============================================================================== !! @@ -253,7 +258,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !!=============================================================================== !JJGDEBUG -! print_cld_debug = iv%instid(i)%info%proc_domain(1,n) +! print_cld_debug = iv%instid(isens)%info%proc_domain(1,n) if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG1: ', n, & tb_inv(:,n) if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG2: ', n, & @@ -266,23 +271,23 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) end if if (print_cld_debug) write(stdout,'(A,I8,8F12.4,2x,A)') 'PIXEL_DEBUG5: ', n, & - iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & - iv%instid(i)%satzen(n), iv%instid(i)%satazi(n), & - iv%instid(i)%solzen(n), iv%instid(i)%solazi(n), & - iv%instid(i)%tropt(n), iv%instid(i)%cld_qc(n)%terr_hgt, & - iv%instid(i)%info%date_char(n) + iv%instid(isens)%info%lat(1,n), iv%instid(isens)%info%lon(1,n), & + iv%instid(isens)%satzen(n), iv%instid(isens)%satazi(n), & + iv%instid(isens)%solzen(n), iv%instid(isens)%solazi(n), & + iv%instid(isens)%tropt(n), iv%instid(isens)%cld_qc(n)%terr_hgt, & + iv%instid(isens)%info%date_char(n) !JJGDEBUG clddet_tests = 0 - if ( tb_xb(ch14,n) .gt. 0. .and. iv%instid(i)%tropt(n) .gt. 0. ) then + if ( tb_xb(ch14,n) .gt. 0. .and. iv%instid(isens)%tropt(n) .gt. 0. ) then tb_temp1 = tb_ob(ch14,n) rad_O14 = plfk1(ch14) / & ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_temp1 ) ) -1 ) tb_temp1 = tb_xb(ch14,n) rad_M14 = plfk1(ch14) / & ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_temp1) ) -1 ) - tb_temp1 = iv%instid(i)%tropt(n) + tb_temp1 = iv%instid(isens)%tropt(n) rad_tropt = plfk1(ch14) / & ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_temp1) ) -1 ) else @@ -323,7 +328,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !-------------------------------------------------------------------------- ! 4.1 Relative Thermal Contrast Test (RTCT) !-------------------------------------------------------------------------- - crit_clddet = iv%instid(i)%cld_qc(n)%RTCT + crit_clddet = iv%instid(isens)%cld_qc(n)%RTCT qual_clddet(3:4) = .false. case (2) @@ -331,7 +336,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! 4.2 Cloud check: step 1 ! Emissivity at Tropopause Test (ETROP) !-------------------------------------------------------------------------- - if ( tb_xb(ch14,n) .gt. 0. .and. iv%instid(i)%tropt(n) .gt. 0. ) & + if ( tb_xb(ch14,n) .gt. 0. .and. iv%instid(isens)%tropt(n) .gt. 0. ) & crit_clddet = (rad_O14 - rad_M14) / (rad_tropt - rad_M14) case (3) @@ -343,7 +348,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) qual_clddet = (tb_xb(ch14,n).ge.tb_xb(ch15,n)) if ( (tb_inv(ch14,n) + tb_xb(ch14,n)).le.310. .and. & - iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch14).ge.0.3 .and. & + iv%instid(isens)%cld_qc(n)%tb_stddev_3x3(ch14).ge.0.3 .and. & tb_ob(ch14,n).gt.0. .and. tb_ob(ch15,n).gt.0. ) & crit_clddet = ( tb_ob(ch14,n) - tb_ob(ch15,n) ) ! above using ob without VarBC @@ -381,7 +386,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) qual_clddet(2) = qual_clddet(2) .and. tb_ob(ch14,n) .le. 300. qual_clddet(3:4) = .false. - crit_clddet = iv%instid(i)%cld_qc(n)%RFMFT + crit_clddet = iv%instid(isens)%cld_qc(n)%RFMFT case (6) !-------------------------------------------------------------------------- @@ -389,11 +394,11 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !-------------------------------------------------------------------------- ! See ABI Cloud Mask Description for qual_clddet qual_clddet = & - iv%instid(i)%cld_qc(n)%terr_hgt .le. 2000. & - .and. iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch10) .gt. 0.5 & - .and. iv%instid(i)%cld_qc(n)%tb_stddev_3x3(ch14) .gt. 0.5 - if ( allocated(iv%instid(i)%cld_qc(n)%CIRH2O) ) & - crit_clddet = iv%instid(i)%cld_qc(n)%CIRH2O(1,1,1) + iv%instid(isens)%cld_qc(n)%terr_hgt .le. 2000. & + .and. iv%instid(isens)%cld_qc(n)%tb_stddev_3x3(ch10) .gt. 0.5 & + .and. iv%instid(isens)%cld_qc(n)%tb_stddev_3x3(ch14) .gt. 0.5 + if ( allocated(iv%instid(isens)%cld_qc(n)%CIRH2O) ) & + crit_clddet = iv%instid(isens)%cld_qc(n)%CIRH2O(1,1,1) case (7) !-------------------------------------------------------------------------- @@ -404,12 +409,12 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) crit_clddet = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14)/ & (rad_b_ch7 / rad_b_ch14) - if ( iv%instid(i)%solzen(n) > 0. & - .and. iv%instid(i)%solzen(n) < 90. ) then - Relaz = RELATIVE_AZIMUTH(iv%instid(i)%solazi(n),iv%instid(i)%satazi(n)) + if ( iv%instid(isens)%solzen(n) > 0. & + .and. iv%instid(isens)%solzen(n) < 90. ) then + Relaz = RELATIVE_AZIMUTH(iv%instid(isens)%solazi(n),iv%instid(isens)%satazi(n)) ! - compute glint angle - Glintzen = GLINT_ANGLE(iv%instid(i)%solzen(n),iv%instid(i)%satzen(n),Relaz ) + Glintzen = GLINT_ANGLE(iv%instid(isens)%solzen(n),iv%instid(isens)%satzen(n),Relaz ) if ( Glintzen.lt.40.0 .and. isflg==sea_flag) then crit_clddet = - tb_inv(ch7,n) ! (B_ch7 - O_ch7) @@ -422,7 +427,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! 4.8 Uniform low stratus Test (ULST) !-------------------------------------------------------------------------- !JJG, AHI error: Changed this to solzen instead of solazi for night/day test - qual_clddet = iv%instid(i)%solzen(n) >= 85.0 + qual_clddet = iv%instid(isens)%solzen(n) >= 85.0 if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) & crit_clddet = rad_b_ch7/rad_b_ch14 - rad_o_ch7/rad_o_ch14 @@ -431,7 +436,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! 4.9 New Optically Thin Cloud Test (N-OTC) !-------------------------------------------------------------------------- !JJG, AHI error: Changed this to solzen instead of solazi for night/day test - if ( iv%instid(i)%solzen(n) .ge. 85.0 ) & + if ( iv%instid(isens)%solzen(n) .ge. 85.0 ) & offset_clddet = 1 ! night time if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) & @@ -448,7 +453,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) !-------------------------------------------------------------------------- ! 4.10 Temporal Infrared Test (TEMPIR) !-------------------------------------------------------------------------- - crit_clddet = iv%instid(i)%cld_qc(n)%TEMPIR + crit_clddet = iv%instid(isens)%cld_qc(n)%TEMPIR case default cycle @@ -456,7 +461,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) ! call evaluate_clddet_test ( & ! isflg, isflgs_clddet, crit_clddet, eps_clddet(index_clddet(itest)+offset_clddet,:), qual_clddet, & -! iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n), & +! iv%instid(isens)%info%lat(1,n), iv%instid(isens)%info%lon(1,n), & ! reject_clddet ) reject_clddet = crit_clddet.gt.missing_r .and. & @@ -466,10 +471,10 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if (reject_clddet) then tb_qc_clddet = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) then + if (iv%instid(isens)%info%proc_domain(1,n)) then nrej_clddet(:,itest) = nrej_clddet(:,itest) + 1 !JJGDEBUG - if (print_cld_debug) write(stdout,"(A,F14.6,A,I4,2D12.4)") trim(crit_names_clddet(itest)), crit_clddet, " isflg", isflg, iv%instid(i)%info%lat(1,n), iv%instid(i)%info%lon(1,n) + if (print_cld_debug) write(stdout,"(A,F14.6,A,I4,2D12.4)") trim(crit_names_clddet(itest)), crit_clddet, " isflg", isflg, iv%instid(isens)%info%lat(1,n), iv%instid(isens)%info%lon(1,n) !JJGDEBUG end if @@ -477,6 +482,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) end if end do if (.not. crtm_cloud ) tb_qc = tb_qc_clddet + if (any(tb_qc_clddet.lt.0)) iv%instid(isens)%cloud_flag(:,n) = sum(clddet_tests) * qc_bad !JJGDEBUG if (print_cld_debug) write(stdout,'(A,I8,*(2x,I1:))') 'PIXEL_DEBUG6: ', n, clddet_tests @@ -488,16 +494,14 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if (.not. crtm_cloud ) then do k = 1, nchan if (use_error_factor_rad) then - iv%instid(i)%tb_error(k,n) = & - satinfo(i)%error_std(k) * satinfo(i)%error_factor(k) + iv%instid(isens)%tb_error(k,n) = & + satinfo(isens)%error_std(k) * satinfo(isens)%error_factor(k) else - iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) end if end do ! nchan else !crtm_cloud ! calculate ca_mean - ca_mean => iv%instid(i)%ca_mean - ca_mean = missing_r do k = 1, nchan if ( .true. & .and. tb_inv( k, n ) .gt. missing_r & @@ -533,16 +537,16 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) do k = 1, nchan if ( ca_mean(k,n).gt.missing_r ) then if ( ca_mean(k,n).lt.camin ) then - iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) - else if ( ca_mean(k,n) .lt. satinfo(i)%error_cld_x(k) ) then - iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) + & - ( satinfo(i)%error_cld_y(k) - satinfo(i)%error_std(k) ) * & - ( ca_mean(k,n) - camin ) / ( satinfo(i)%error_cld_x(k) - camin ) + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + else if ( ca_mean(k,n) .lt. satinfo(isens)%error_cld_x(k) ) then + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + & + ( satinfo(isens)%error_cld_y(k) - satinfo(isens)%error_std(k) ) * & + ( ca_mean(k,n) - camin ) / ( satinfo(isens)%error_cld_x(k) - camin ) else - iv%instid(i)%tb_error(k,n) = satinfo(i)%error_cld_y(k) + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_cld_y(k) end if else - iv%instid(i)%tb_error(k,n) = missing_r + iv%instid(isens)%tb_error(k,n) = missing_r end if end do ! nchan end if @@ -556,28 +560,28 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) do k = 1, nchan if (abs(tb_inv(k,n)) > inv_grosscheck) then tb_qc(k) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & + if (iv%instid(isens)%info%proc_domain(1,n)) & nrej_omb_abs(k) = nrej_omb_abs(k) + 1 end if end do ! nchan - iv%instid(i)%tb_qc(:,n) = tb_qc + iv%instid(isens)%tb_qc(:,n) = tb_qc do k = 1, nchan ! relative departure check - if (abs(tb_inv(k,n)) > 3.0 * iv%instid(i)%tb_error(k,n)) then - iv%instid(i)%tb_qc(k,n) = qc_bad - if (iv%instid(i)%info%proc_domain(1,n)) & + if (abs(tb_inv(k,n)) > 3.0 * iv%instid(isens)%tb_error(k,n)) then + iv%instid(isens)%tb_qc(k,n) = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & nrej_omb_std(k) = nrej_omb_std(k) + 1 end if ! final QC decsion - if (iv%instid(i)%tb_qc(k,n) == qc_bad) then - iv%instid(i)%tb_error(k,n) = 500.0 - if (iv%instid(i)%info%proc_domain(1,n)) & + if (iv%instid(isens)%tb_qc(k,n) == qc_bad) then + iv%instid(isens)%tb_error(k,n) = 500.0 + if (iv%instid(isens)%info%proc_domain(1,n)) & nrej(k) = nrej(k) + 1 else - if (iv%instid(i)%info%proc_domain(1,n)) & + if (iv%instid(isens)%info%proc_domain(1,n)) & ngood(k) = ngood(k) + 1 end if end do ! nchan @@ -601,9 +605,9 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) if (rootproc) then if (num_fgat_time > 1) then - write(filename,'(i2.2,a,i2.2)') it,'_qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time + write(filename,'(i2.2,a,i2.2)') it,'_qcstat_'//trim(iv%instid(isens)%rttovid_string)//'_',iv%time else - write(filename,'(i2.2,a)') it,'_qcstat_'//trim(iv%instid(i)%rttovid_string) + write(filename,'(i2.2,a)') it,'_qcstat_'//trim(iv%instid(isens)%rttovid_string) end if call da_get_unit(fgat_rad_unit) @@ -613,7 +617,7 @@ subroutine da_qc_goesabi (it, i, nchan, ob, iv) call da_error(__FILE__,__LINE__,message(1:1)) end if - write(fgat_rad_unit, fmt='(/a/)') ' Quality Control Statistics for '//iv%instid(i)%rttovid_string + write(fgat_rad_unit, fmt='(/a/)') ' Quality Control Statistics for '//iv%instid(isens)%rttovid_string if(num_proc_domain > 0) write(fgat_rad_unit,'(a20,i7)') ' num_proc_domain = ', num_proc_domain write(fgat_rad_unit,'(a20,i7)') ' nrej_mixsurface = ', nrej_mixsurface write(fgat_rad_unit,'(a20,i7)') ' nrej_land = ', nrej_land diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index 30a80b0bc1..f186b8612e 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -148,6 +148,8 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=innov_rad_unit,fmt='(a)') 'QC : ' write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) + write(unit=innov_rad_unit,fmt='(a)') 'CLOUD : ' + write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) if ( abi .and. crtm_cloud ) then ! write out ca_mean, tb_xb_clr write(unit=innov_rad_unit,fmt='(a)') 'CA : ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%ca_mean(:,n) diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index 191d62d72f..dee03fb984 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -137,6 +137,8 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=oma_rad_unit,fmt='(a)') 'QC : ' write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) + write(unit=oma_rad_unit,fmt='(a)') 'CLOUD : ' + write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) if ( abi .and. crtm_cloud ) then ! write out ca_mean, tb_xb_clr write(unit=oma_rad_unit,fmt='(a)') 'CA : ' write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%ca_mean(:,n) From 81a339ecba36bf4e1aeb2d1f9f972499b1f9ff59 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Mon, 17 Jun 2019 12:43:20 -0600 Subject: [PATCH 46/86] Small bugfix for efficiency in da_rad_diags.f90 --- var/da/da_monitor/da_rad_diags.f90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index 8a51bd85b8..bde4c3d64c 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -255,6 +255,7 @@ program da_rad_diags allocate ( tb_err(1:nchan,1:total_npixel) ) allocate ( tb_qc(1:nchan,1:total_npixel) ) allocate ( tb_cloud(1:nchan,1:total_npixel) ) + tb_cloud = 0 if ( abi ) then allocate ( ca_mean(1:nchan,1:total_npixel) ) allocate ( tb_bak_clr(1:nchan,1:total_npixel) ) @@ -385,8 +386,6 @@ program da_rad_diags if ( buf(1:5) == "CLOUD" ) then ! read cloud detection info read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_cloud(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CA, INFO, or level - else - tb_cloud = 0 end if if ( abi .and. buf(1:2) == "CA" ) then ! read ca_mean, tb_bak_clr for abi read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) ca_mean(:,ipixel) From 95d99a40c9d1a1d8224263d3bfa7a8c022ae1e6c Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Mon, 17 Jun 2019 15:15:10 -0600 Subject: [PATCH 47/86] Extra tuning of abi qc Allow choice of symmetric error model Turn off resetting tb_error to 500.0 --- Registry/registry.var | 1 + var/da/da_radiance/da_qc_goesabi.inc | 100 +++++++++++++-------------- var/da/da_radiance/da_radiance1.f90 | 2 +- 3 files changed, 52 insertions(+), 51 deletions(-) diff --git a/Registry/registry.var b/Registry/registry.var index 3f72654a20..f9675b10c7 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -442,6 +442,7 @@ rconfig integer varbc_nbgerr namelist,wrfvar14 1 5000 - "va rconfig integer varbc_nobsmin namelist,wrfvar14 1 10 - "varbc_nobsmin" "" "" rconfig integer use_clddet namelist,wrfvar14 1 2 - "use_clddet" "0: off, 1: mmr, 2: pf, 3: ecmwf" "" rconfig logical use_clddet_abi namelist,wrfvar14 1 .false. - "use_clddet_abi" "" "" +rconfig logical use_rad_symm_err namelist,wrfvar14 1 .true. - "use_rad_symm_err" "" "" rconfig logical airs_warmest_fov namelist,wrfvar14 1 .false. - "airs_warmest_fov" "" "" rconfig logical use_satcv namelist,wrfvar14 2 .false. - "use_satcv" "" "" rconfig logical use_blacklist_rad namelist,wrfvar14 1 .true. - "use_blacklist_rad" "" "" diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 9b59ea4cac..bf04b535a3 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -149,6 +149,9 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! print_cld_debug = .true. print_cld_debug = .false. + inv_grosscheck = 15.0 + if (crtm_cloud) inv_grosscheck = 80.0 + if (use_satcv(2)) inv_grosscheck = 100.0 if ( crtm_cloud ) then tb_xb_clr => iv%instid(isens)%tb_xb_clr @@ -209,10 +212,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! 2.0 check iuse !----------------------------------------------------------------- - do k = 1, nchan - if (satinfo(isens)%iuse(k) .eq. -1) & - tb_qc(k) = qc_bad - end do + where (satinfo(isens)%iuse(:) == -1) tb_qc = qc_bad ! 3.0 check cloud !----------------------------------------------------------------- @@ -492,71 +492,71 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! --------------------------- ! 5.0 assigning obs errors if (.not. crtm_cloud ) then - do k = 1, nchan - if (use_error_factor_rad) then - iv%instid(isens)%tb_error(k,n) = & - satinfo(isens)%error_std(k) * satinfo(isens)%error_factor(k) - else - iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) - end if - end do ! nchan + if (use_error_factor_rad) then + iv%instid(isens)%tb_error(:,n) = & + satinfo(isens)%error_std(:) * satinfo(isens)%error_factor(:) + else + iv%instid(isens)%tb_error(:,n) = satinfo(isens)%error_std(:) + end if else !crtm_cloud ! calculate ca_mean - do k = 1, nchan - if ( .true. & - .and. tb_inv( k, n ) .gt. missing_r & - .and. tb_ob( k, n ) .gt. 0. & - .and. tb_xb( k, n ) .gt. 0. & - ) then + where ( tb_inv( :, n ) .gt. missing_r & + .and. tb_ob( :, n ) .gt. 0. & + .and. tb_xb( :, n ) .gt. 0. & + ) +! .and. tb_xb_clr(:,n) .gt. 0. & !Okamoto or Guerrette ! using ob with VarBC (tb_inv + tb_xb) ! ------------------------------- !! Harnisch et al. (2016) if ( BTlim(k) .gt. 0. ) then - ca_mean(k,n) = 0.5 * ( max( 0., BTlim(k) - tb_xb(k,n) ) + & - max( 0., BTlim(k) - (tb_inv(k,n) + tb_xb(k,n)) ) ) + ca_mean(:,n) = & + 0.5 * ( max( 0., BTlim(:) - tb_xb(:,n) ) + & + max( 0., BTlim(:) - (tb_inv(:,n) + tb_xb(:,n)) ) ) end if -! if ( tb_xb_clr(k,n) .gt. 0. ) then !! Okamoto et al. (2013) -! ca_mean(k,n) = 0.5 * ( abs( tb_xb(k,n) - tb_xb_clr(k,n) ) + & -! abs( (tb_inv(k,n) + tb_xb(k,n)) - tb_xb_clr(k,n) ) ) +! ca_mean(:,n) = & +! 0.5 * ( abs( tb_xb(:,n) - tb_xb_clr(:,n) ) + & +! abs( (tb_inv(:,n) + tb_xb(:,n)) - tb_xb_clr(:,n) ) ) !!! J. Guerrette -! ca_mean(k,n) = 0.5 * ( max( 0., tb_xb_clr(k,n) - tb_xb(k,n) ) + & -! max( 0., tb_xb_clr(k,n) - (tb_inv(k,n) + tb_xb(k,n)) ) ) -! end if - end if +! ca_mean(:,n) = & +! 0.5 * ( max( 0., tb_xb_clr(:,n) - tb_xb(:,n) ) + & +! max( 0., tb_xb_clr(:,n) - (tb_inv(:,n) + tb_xb(:,n)) ) ) + endwhere !JJGDEBUG - if (print_cld_debug) write(stdout,'(A,2I8,2F16.8)') 'PIXEL_DEBUG93: ', n, k, & - ca_mean(k,n) + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F16.8))') 'PIXEL_DEBUG93: ', n, & + ca_mean(:,n) !JJGDEBUG - end do - ! symmetric error model - ! - Okamoto, McNally, & Bell (2013) - ! - Harnish, Weissmann, & Perianez (2016) - do k = 1, nchan - if ( ca_mean(k,n).gt.missing_r ) then - if ( ca_mean(k,n).lt.camin ) then - iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) - else if ( ca_mean(k,n) .lt. satinfo(isens)%error_cld_x(k) ) then - iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + & - ( satinfo(isens)%error_cld_y(k) - satinfo(isens)%error_std(k) ) * & - ( ca_mean(k,n) - camin ) / ( satinfo(isens)%error_cld_x(k) - camin ) - else - iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_cld_y(k) - end if + if (it == 1) then + if (use_rad_symm_err) then + ! symmetric error model + ! - Okamoto, McNally, & Bell (2013) + ! - Harnish, Weissmann, & Perianez (2016) + do k = 1, nchan + if ( ca_mean(k,n).gt.missing_r ) then + if ( ca_mean(k,n).lt.camin ) then + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + else if ( ca_mean(k,n) .lt. satinfo(isens)%error_cld_x(k) ) then + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + & + ( satinfo(isens)%error_cld_y(k) - satinfo(isens)%error_std(k) ) * & + ( ca_mean(k,n) - camin ) / ( satinfo(isens)%error_cld_x(k) - camin ) + else + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_cld_y(k) + end if + else + iv%instid(isens)%tb_error(k,n) = missing_r + end if + end do ! nchan else - iv%instid(isens)%tb_error(k,n) = missing_r + iv%instid(isens)%tb_error(1:nchan,n) = satinfo(isens)%error_std(1:nchan) end if - end do ! nchan + end if end if ! 5.1 check innovation !----------------------------------------------------------------- ! absolute departure check - inv_grosscheck = 15.0 - if (crtm_cloud) inv_grosscheck = 80.0 - if (use_satcv(2)) inv_grosscheck = 100.0 do k = 1, nchan if (abs(tb_inv(k,n)) > inv_grosscheck) then tb_qc(k) = qc_bad @@ -577,7 +577,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! final QC decsion if (iv%instid(isens)%tb_qc(k,n) == qc_bad) then - iv%instid(isens)%tb_error(k,n) = 500.0 +! iv%instid(isens)%tb_error(k,n) = 500.0 if (iv%instid(isens)%info%proc_domain(1,n)) & nrej(k) = nrej(k) + 1 else diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index 6dda3f6508..36e1a9a8d9 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -23,7 +23,7 @@ module da_radiance1 global, gas_constant, gravity, monitor_on,kts,kte,use_rttov_kmatrix, & use_pseudo_rad, pi, t_triple, crtm_cloud, DT_cloud_model,write_jacobian, & use_crtm_kmatrix,use_clddet, use_clddet_abi, use_satcv, cv_size_domain, & - cv_size_domain_js, calc_weightfunc, deg_to_rad, rad_to_deg + cv_size_domain_js, calc_weightfunc, deg_to_rad, rad_to_deg, use_rad_symm_err use da_define_structures, only : info_type,model_loc_type,maxmin_type, & iv_type, y_type, jo_type,bad_data_type,bad_data_type,number_type, & be_type, cld_qc_type From a03712252319493a515bc61709769361f1cfb4ad Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Fri, 12 Jul 2019 15:58:55 -0600 Subject: [PATCH 48/86] Bugfix to where statement --- var/da/da_radiance/da_qc_goesabi.inc | 26 +++++++++++--------------- 1 file changed, 11 insertions(+), 15 deletions(-) diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index bf04b535a3..2c86f2267f 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -500,28 +500,24 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) end if else !crtm_cloud ! calculate ca_mean - where ( tb_inv( :, n ) .gt. missing_r & - .and. tb_ob( :, n ) .gt. 0. & - .and. tb_xb( :, n ) .gt. 0. & + where ( tb_inv( :, n ) > missing_r & + .and. tb_ob( :, n ) > 0. & + .and. tb_xb( :, n ) > 0. & + .and. BTlim( : ) > 0. & !Harnisch ) -! .and. tb_xb_clr(:,n) .gt. 0. & !Okamoto or Guerrette +! .and. tb_xb_clr( :, n ) > 0. & !Okamoto or Guerrette ! using ob with VarBC (tb_inv + tb_xb) ! ------------------------------- !! Harnisch et al. (2016) - if ( BTlim(k) .gt. 0. ) then - ca_mean(:,n) = & - 0.5 * ( max( 0., BTlim(:) - tb_xb(:,n) ) + & - max( 0., BTlim(:) - (tb_inv(:,n) + tb_xb(:,n)) ) ) - end if + ca_mean(:,n) = 0.5 * ( max( 0., BTlim(:) - tb_xb(:,n) ) + & + max( 0., BTlim(:) - (tb_inv(:,n) + tb_xb(:,n)) ) ) !! Okamoto et al. (2013) -! ca_mean(:,n) = & -! 0.5 * ( abs( tb_xb(:,n) - tb_xb_clr(:,n) ) + & -! abs( (tb_inv(:,n) + tb_xb(:,n)) - tb_xb_clr(:,n) ) ) +! ca_mean(:,n) = 0.5 * ( abs( tb_xb(:,n) - tb_xb_clr(:,n) ) + & +! abs( (tb_inv(:,n) + tb_xb(:,n)) - tb_xb_clr(:,n) ) ) !!! J. Guerrette -! ca_mean(:,n) = & -! 0.5 * ( max( 0., tb_xb_clr(:,n) - tb_xb(:,n) ) + & -! max( 0., tb_xb_clr(:,n) - (tb_inv(:,n) + tb_xb(:,n)) ) ) +! ca_mean(:,n) = 0.5 * ( max( 0., tb_xb_clr(:,n) - tb_xb(:,n) ) + & +! max( 0., tb_xb_clr(:,n) - (tb_inv(:,n) + tb_xb(:,n)) ) ) endwhere !JJGDEBUG if (print_cld_debug) write(stdout,'(A,I8,*(2x,F16.8))') 'PIXEL_DEBUG93: ', n, & From 11794736a3605f7e796c7ce58ad99ddf62577ae8 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 17 Jul 2019 11:04:54 -0600 Subject: [PATCH 49/86] Allow crtm_cloud different in each outer iteration --- Registry/registry.var | 2 +- var/da/da_main/da_solve.inc | 2 +- var/da/da_minimisation/da_calculate_gradj.inc | 12 +++++------ var/da/da_minimisation/da_calculate_j.inc | 4 ++-- var/da/da_minimisation/da_sensitivity.inc | 4 ++-- var/da/da_minimisation/da_transform_vtoy.inc | 7 ++++--- .../da_minimisation/da_transform_vtoy_adj.inc | 7 ++++--- var/da/da_obs/da_transform_xtoy.inc | 7 ++++--- var/da/da_obs/da_transform_xtoy_adj.inc | 7 ++++--- var/da/da_radiance/da_allocate_rad_iv.inc | 6 +++--- var/da/da_radiance/da_deallocate_radiance.inc | 6 +++--- .../da_radiance/da_get_innov_vector_crtm.inc | 12 +++++------ .../da_radiance/da_get_innov_vector_crtmk.inc | 10 ++++----- var/da/da_radiance/da_initialize_rad_iv.inc | 6 +++--- var/da/da_radiance/da_qc_ahi.inc | 10 ++++----- var/da/da_radiance/da_qc_amsr2.inc | 10 ++++----- var/da/da_radiance/da_qc_amsub.inc | 6 +++--- var/da/da_radiance/da_qc_goesimg.inc | 4 ++-- .../da_setup_radiance_structures.inc | 2 +- var/da/da_radiance/da_transform_xtoy_crtm.inc | 19 +++++++++-------- .../da_transform_xtoy_crtm_adj.inc | 21 ++++++++++--------- var/da/da_radiance/da_write_iv_rad_ascii.inc | 8 +++---- var/da/da_radiance/da_write_oa_rad_ascii.inc | 4 ++-- .../da_setup_be_nmm_regional.inc | 2 +- .../da_setup_be_regional.inc | 2 +- var/da/da_test/da_check_vptox_adjoint.inc | 8 +++---- var/da/da_test/da_check_vtox_adjoint.inc | 4 ++-- var/da/da_test/da_check_vtoy_adjoint.inc | 4 ++-- var/da/da_test/da_check_xtoy_adjoint.inc | 4 ++-- var/da/da_test/da_setup_testfield.inc | 2 +- var/da/da_test/da_test_vtoy_transform.inc | 4 ++-- 31 files changed, 106 insertions(+), 100 deletions(-) diff --git a/Registry/registry.var b/Registry/registry.var index 9ecfe1fee0..7502b611c5 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -419,7 +419,7 @@ rconfig logical tovs_batch namelist,wrfvar14 1 .false. - "to rconfig integer rtm_option namelist,wrfvar14 1 1 - "rtm_option" "" "" rconfig logical use_crtm_kmatrix namelist,wrfvar14 1 .true. - "use_crtm_kmatrix" "" "" rconfig logical use_rttov_kmatrix namelist,wrfvar14 1 .false. - "use_rttov_kmatrix" "" "" -rconfig logical crtm_cloud namelist,wrfvar14 1 .false. - "crtm_cloud" "" "" +rconfig logical crtm_cloud namelist,wrfvar14 max_outer_iterations .false. - "crtm_cloud" "" "" rconfig logical only_sea_rad namelist,wrfvar14 1 .false. - "only_sea_rad" "" "" rconfig logical use_pseudo_rad namelist,wrfvar14 1 .false. - "use_pseudo_rad" "" "" rconfig integer pseudo_rad_platid namelist,wrfvar14 1 1 - "pseudo_rad_platid" "" "" diff --git a/var/da/da_main/da_solve.inc b/var/da/da_main/da_solve.inc index 22a9655531..1c1d4c876c 100644 --- a/var/da/da_main/da_solve.inc +++ b/var/da/da_main/da_solve.inc @@ -461,7 +461,7 @@ call da_calculate_grady(iv, re, jo_grad_y) call da_zero_x(grid%xa) - call da_transform_xtoy_adj(cv_size, xhat, grid, iv, jo_grad_y, grid%xa) + call da_transform_xtoy_adj(1, cv_size, xhat, grid, iv, jo_grad_y, grid%xa) call da_transform_xtoxa_adj(grid) call da_transfer_wrftltoxa_adj(grid, config_flags, 'fcst', timestr) diff --git a/var/da/da_minimisation/da_calculate_gradj.inc b/var/da/da_minimisation/da_calculate_gradj.inc index 401d1d1917..838da77b02 100644 --- a/var/da/da_minimisation/da_calculate_gradj.inc +++ b/var/da/da_minimisation/da_calculate_gradj.inc @@ -85,26 +85,26 @@ subroutine da_calculate_gradj(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size call da_calculate_grady(iv, re, jo_grad_y) if ( iter > 0 .and. test_gradient ) jcdf_flag = .true. #ifdef VAR4D - call da_transform_vtoy_adj(cv_size, be, grid%ep, grad_jo, iv, & + call da_transform_vtoy_adj(it, cv_size, be, grid%ep, grad_jo, iv, & grid%vp, grid%vv, xbx, jo_grad_y, grid, config_flags, jcdf_flag, grid%vp6, grid%vv6) #else - call da_transform_vtoy_adj(cv_size, be, grid%ep, grad_jo, iv, & + call da_transform_vtoy_adj(it, cv_size, be, grid%ep, grad_jo, iv, & grid%vp, grid%vv, xbx, jo_grad_y, grid, config_flags, jcdf_flag) #endif else #ifdef VAR4D - call da_transform_vtoy(cv_size, be, grid%ep, cv, iv, grid%vp, & + call da_transform_vtoy(it, cv_size, be, grid%ep, cv, iv, grid%vp, & grid%vv, xbx, y, grid, config_flags, grid%vp6, grid%vv6) #else - call da_transform_vtoy(cv_size, be, grid%ep, cv, iv, grid%vp, & + call da_transform_vtoy(it, cv_size, be, grid%ep, cv, iv, grid%vp, & grid%vv, xbx, y, grid, config_flags) #endif call da_calculate_grady(iv, y, jo_grad_y) #ifdef VAR4D - call da_transform_vtoy_adj(cv_size, be, grid%ep, grad_jo, iv, & + call da_transform_vtoy_adj(it, cv_size, be, grid%ep, grad_jo, iv, & grid%vp, grid%vv, xbx, jo_grad_y, grid, config_flags, .true., grid%vp6, grid%vv6) #else - call da_transform_vtoy_adj(cv_size, be, grid%ep, grad_jo, iv, & + call da_transform_vtoy_adj(it, cv_size, be, grid%ep, grad_jo, iv, & grid%vp, grid%vv, xbx, jo_grad_y, grid, config_flags, .true.) #endif grad_jo = - grad_jo !! Compensate for sign in calculation of grad_v (Jo) diff --git a/var/da/da_minimisation/da_calculate_j.inc b/var/da/da_minimisation/da_calculate_j.inc index 4f23bffc77..2e9ae3da9f 100644 --- a/var/da/da_minimisation/da_calculate_j.inc +++ b/var/da/da_minimisation/da_calculate_j.inc @@ -75,11 +75,11 @@ subroutine da_calculate_j(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size_jp, if (iter > 0) then #ifdef VAR4D - call da_transform_vtoy(cv_size, be, grid%ep, xhat, iv, grid%vp, grid%vv,& + call da_transform_vtoy(it, cv_size, be, grid%ep, xhat, iv, grid%vp, grid%vv,& xbx, y, & grid, config_flags, grid%vp6, grid%vv6) #else - call da_transform_vtoy(cv_size, be, grid%ep, xhat, iv, grid%vp, grid%vv,& + call da_transform_vtoy(it, cv_size, be, grid%ep, xhat, iv, grid%vp, grid%vv,& xbx, y, & grid, config_flags) #endif diff --git a/var/da/da_minimisation/da_sensitivity.inc b/var/da/da_minimisation/da_sensitivity.inc index 0b265d62fa..91422a340a 100644 --- a/var/da/da_minimisation/da_sensitivity.inc +++ b/var/da/da_minimisation/da_sensitivity.inc @@ -59,10 +59,10 @@ subroutine da_sensitivity(grid, config_flags, it, cv_size, xbx, be, iv, xhat, qh ! Apply observation operator H #ifdef VAR4D - call da_transform_vtoy(cv_size, be, grid%ep, amat, iv, grid%vp, grid%vv, & + call da_transform_vtoy(it, cv_size, be, grid%ep, amat, iv, grid%vp, grid%vv, & xbx, ktr, grid, config_flags, grid%vp6, grid%vv6) #else - call da_transform_vtoy(cv_size, be, grid%ep, amat, iv, grid%vp, grid%vv, & + call da_transform_vtoy(it, cv_size, be, grid%ep, amat, iv, grid%vp, grid%vv, & xbx, ktr, grid, config_flags) #endif diff --git a/var/da/da_minimisation/da_transform_vtoy.inc b/var/da/da_minimisation/da_transform_vtoy.inc index c754bd11f7..d9997110fc 100644 --- a/var/da/da_minimisation/da_transform_vtoy.inc +++ b/var/da/da_minimisation/da_transform_vtoy.inc @@ -1,4 +1,4 @@ -subroutine da_transform_vtoy(cv_size, be, ep, cv, iv, vp, vv, xbx, & +subroutine da_transform_vtoy(it, cv_size, be, ep, cv, iv, vp, vv, xbx, & y, grid, config_flags, vp6, vv6) !---------------------------------------------------------------------- @@ -7,6 +7,7 @@ subroutine da_transform_vtoy(cv_size, be, ep, cv, iv, vp, vv, xbx, & implicit none + integer, intent(in) :: it ! external iteration #. integer, intent(in) :: cv_size ! Size of cv array. type(be_type), intent(in) :: be ! background error structure. type(ep_type), intent(in) :: ep ! Ensemble perturbation structure. @@ -110,7 +111,7 @@ subroutine da_transform_vtoy(cv_size, be, ep, cv, iv, vp, vv, xbx, & g_rainnc(:,:,nobwin)=grid%g_rainnc(:,:) endif call da_transform_xtoxa(grid) - call da_transform_xtoy(cv_size, cv, grid, iv, y) + call da_transform_xtoy(it, cv_size, cv, grid, iv, y) if ( nobwin > 1 ) call domain_clockadvance (grid) ! We don't need the advance at the last step call domain_clockprint(150, grid, 'DEBUG : get CurrTime from clock,') @@ -199,7 +200,7 @@ subroutine da_transform_vtoy(cv_size, be, ep, cv, iv, vp, vv, xbx, & iv%instid(:)%info%n2 = iv%instid(:)%num_rad end if end if !4denvar - call da_transform_xtoy(cv_size, cv, grid, iv, y) + call da_transform_xtoy(it, cv_size, cv, grid, iv, y) end do end if ! var4d diff --git a/var/da/da_minimisation/da_transform_vtoy_adj.inc b/var/da/da_minimisation/da_transform_vtoy_adj.inc index e67b2017e8..07381fe103 100644 --- a/var/da/da_minimisation/da_transform_vtoy_adj.inc +++ b/var/da/da_minimisation/da_transform_vtoy_adj.inc @@ -1,4 +1,4 @@ -subroutine da_transform_vtoy_adj(cv_size, be, ep, cv, iv, vp, vv, xbx, y, & +subroutine da_transform_vtoy_adj(it, cv_size, be, ep, cv, iv, vp, vv, xbx, y, & grid, config_flags, jcdf_flag, vp6, vv6) !------------------------------------------------------------------------- @@ -7,6 +7,7 @@ subroutine da_transform_vtoy_adj(cv_size, be, ep, cv, iv, vp, vv, xbx, y, & implicit none + integer, intent(in) :: it ! external iteration #. integer, intent(in) :: cv_size ! Size of cv array. type(be_type), intent(in) :: be ! background error structure. type(ep_type), intent(in) :: ep ! ensemble perturbation structure. @@ -139,7 +140,7 @@ subroutine da_transform_vtoy_adj(cv_size, be, ep, cv, iv, vp, vv, xbx, y, & call da_zero_x(grid%xa) grid%g_rainnc = 0.0 grid%g_rainc = 0.0 - call da_transform_xtoy_adj(cv_size, cv, grid, iv, y, grid%xa) + call da_transform_xtoy_adj(it, cv_size, cv, grid, iv, y, grid%xa) call da_transform_xtoxa_adj(grid) write(unit=filnam,fmt='(a2,i2.2)') 'af',nobwin @@ -236,7 +237,7 @@ subroutine da_transform_vtoy_adj(cv_size, be, ep, cv, iv, vp, vv, xbx, y, & end if end if !4denvar call da_zero_x(grid%xa) - call da_transform_xtoy_adj(cv_size, cv_local, grid, iv, y, grid%xa) + call da_transform_xtoy_adj(it, cv_size, cv_local, grid, iv, y, grid%xa) call da_transform_xtoxa_adj(grid) call da_zero_vp_type (vp) call da_transform_vpatox_adj(grid, be, ep, vp, nobwin) diff --git a/var/da/da_obs/da_transform_xtoy.inc b/var/da/da_obs/da_transform_xtoy.inc index 6f53970241..c293df4c58 100644 --- a/var/da/da_obs/da_transform_xtoy.inc +++ b/var/da/da_obs/da_transform_xtoy.inc @@ -1,11 +1,12 @@ -subroutine da_transform_xtoy(cv_size, cv, grid, iv, y) +subroutine da_transform_xtoy(it, cv_size, cv, grid, iv, y) !------------------------------------------------------------------------- ! Purpose: TBD !------------------------------------------------------------------------- implicit none - + + integer, intent(in) :: it ! external iteration #. integer, intent(in) :: cv_size ! Size of cv array. real, intent(in) :: cv(1:cv_size) ! control variables. type (domain), intent(inout) :: grid @@ -64,7 +65,7 @@ subroutine da_transform_xtoy(cv_size, cv, grid, iv, y) !else if (use_crtm_kmatrix_fast) then ! call da_transform_xtoy_crtmk_f (grid, iv, y) !else - call da_transform_xtoy_crtm (cv_size, cv, grid, iv, y) + call da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y) !end if #endif else diff --git a/var/da/da_obs/da_transform_xtoy_adj.inc b/var/da/da_obs/da_transform_xtoy_adj.inc index 07bf0b8633..307c078c8d 100644 --- a/var/da/da_obs/da_transform_xtoy_adj.inc +++ b/var/da/da_obs/da_transform_xtoy_adj.inc @@ -1,4 +1,4 @@ -subroutine da_transform_xtoy_adj(cv_size, cv, grid, iv, jo_grad_y, jo_grad_x) +subroutine da_transform_xtoy_adj(it, cv_size, cv, grid, iv, jo_grad_y, jo_grad_x) !-------------------------------------------------------------------------- ! Purpose: TBD @@ -7,7 +7,8 @@ subroutine da_transform_xtoy_adj(cv_size, cv, grid, iv, jo_grad_y, jo_grad_x) !-------------------------------------------------------------------------- implicit none - + + integer, intent(in) :: it ! external iteration #. integer, intent(in) :: cv_size ! Size of cv array. real, intent(inout) :: cv(1:cv_size) ! control variables. type (domain), intent(inout) :: grid @@ -103,7 +104,7 @@ subroutine da_transform_xtoy_adj(cv_size, cv, grid, iv, jo_grad_y, jo_grad_x) #endif elseif (rtm_option == rtm_option_crtm) then #ifdef CRTM - call da_transform_xtoy_crtm_adj (cv_size, cv, iv, jo_grad_y, jo_grad_x) + call da_transform_xtoy_crtm_adj (it, cv_size, cv, iv, jo_grad_y, jo_grad_x) #endif else call da_warning(__FILE__,__LINE__,(/"Unknown radiative transfer model"/)) diff --git a/var/da/da_radiance/da_allocate_rad_iv.inc b/var/da/da_radiance/da_allocate_rad_iv.inc index 9dc6c8e3a9..e2c26c0cab 100644 --- a/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/var/da/da_radiance/da_allocate_rad_iv.inc @@ -40,7 +40,7 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate (iv%instid(i)%qm (kms:kme,iv%instid(i)%num_rad)) allocate (iv%instid(i)%qrn(kms:kme,iv%instid(i)%num_rad)) allocate (iv%instid(i)%qcw(kms:kme,iv%instid(i)%num_rad)) - if ( crtm_cloud ) then + if ( any(crtm_cloud) ) then allocate (iv%instid(i)%qci(kms:kme,iv%instid(i)%num_rad)) allocate (iv%instid(i)%qsn(kms:kme,iv%instid(i)%num_rad)) allocate (iv%instid(i)%qgr(kms:kme,iv%instid(i)%num_rad)) @@ -83,7 +83,7 @@ subroutine da_allocate_rad_iv (i, nchan, iv) end if allocate (iv%instid(i)%ps(iv%instid(i)%num_rad)) allocate (iv%instid(i)%tb_xb(nchan,iv%instid(i)%num_rad)) - if ( crtm_cloud ) then + if ( any(crtm_cloud) ) then allocate (iv%instid(i)%tb_xb_clr(nchan,iv%instid(i)%num_rad)) end if allocate (iv%instid(i)%tb_qc(nchan,iv%instid(i)%num_rad)) @@ -120,7 +120,7 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate(iv%instid(i)%ice_coverage(iv%instid(i)%num_rad)) allocate(iv%instid(i)%snow_coverage(iv%instid(i)%num_rad)) if (use_crtm_kmatrix) then - if ( crtm_cloud ) then + if ( any(crtm_cloud) ) then allocate(iv%instid(i)%water_jacobian(nchan,kte,iv%instid(i)%num_rad)) allocate(iv%instid(i)%ice_jacobian(nchan,kte,iv%instid(i)%num_rad)) allocate(iv%instid(i)%rain_jacobian(nchan,kte,iv%instid(i)%num_rad)) diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index fa5dec69eb..4bb401b0fe 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -63,7 +63,7 @@ deallocate (iv%instid(i)%qm) deallocate (iv%instid(i)%qrn) deallocate (iv%instid(i)%qcw) - if ( crtm_cloud ) then + if ( any(crtm_cloud) ) then deallocate (iv%instid(i)%qci) deallocate (iv%instid(i)%qsn) deallocate (iv%instid(i)%qgr) @@ -106,7 +106,7 @@ end if deallocate (iv%instid(i)%ps) deallocate (iv%instid(i)%tb_xb) - if ( crtm_cloud ) then + if ( any(crtm_cloud) ) then deallocate (iv%instid(i)%tb_xb_clr) end if deallocate (iv%instid(i)%tb_qc) @@ -154,7 +154,7 @@ deallocate(iv%instid(i)%ice_coverage) deallocate(iv%instid(i)%snow_coverage) if (use_crtm_kmatrix) then - if ( crtm_cloud ) then + if ( any(crtm_cloud) ) then deallocate(iv%instid(i)%water_jacobian) deallocate(iv%instid(i)%ice_jacobian) deallocate(iv%instid(i)%rain_jacobian) diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index 6bc85db10b..b4153cb12d 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -155,7 +155,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) n_absorbers = 2 n_aerosols = 0 n_clouds = 0 - if ( crtm_cloud ) n_clouds = 6 + if ( crtm_cloud(it) ) n_clouds = 6 call CRTM_Atmosphere_Create ( Atmosphere(1), & n_layers, & @@ -172,7 +172,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) Atmosphere(1)%Absorber_Units(1) = MASS_MIXING_RATIO_UNITS Atmosphere(1)%Absorber_Units(2) = VOLUME_MIXING_RATIO_UNITS - if (crtm_cloud) then + if (crtm_cloud(it)) then Atmosphere(1)%Cloud(1)%Type=WATER_CLOUD Atmosphere(1)%Cloud(2)%Type=ICE_CLOUD Atmosphere(1)%Cloud(3)%Type=RAIN_CLOUD @@ -226,7 +226,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) end if calc_tb_clr = .false. - if ( crtm_cloud .and. & + if ( crtm_cloud(it) .and. & trim( crtm_sensor_name(rtminit_sensor(inst))) == 'amsr2' ) then !Tb_clear_sky is only needed for symmetric obs error model !symmetric obs error model only implemented for amsr2 for now @@ -372,7 +372,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) call da_interp_2d_partial (grid%xb%qcw(:,:,k), iv%instid(inst)%info,k,n,n, model_qcw(kte-k+1:kte-k+1)) - if (crtm_cloud) then + if (crtm_cloud(it)) then call da_interp_2d_partial (grid%xb%qci(:,:,k), iv%instid(inst)%info,k,n,n,qci) @@ -451,7 +451,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) end do ! convert cloud content unit from kg/kg to kg/m^2 - if (crtm_cloud) then + if (crtm_cloud(it)) then do k=kts,kte do icld=1,Atmosphere(1)%n_Clouds Atmosphere(1)%Cloud(icld)%Water_Content(k)= Atmosphere(1)%Cloud(icld)%Water_Content(k)* & @@ -719,7 +719,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) end if end do - if (crtm_cloud) then + if (crtm_cloud(it)) then do k=1,Atmosphere(1)%n_layers iv%instid(inst)%qcw(k,n) = Atmosphere(1)%cloud(1)%water_content(k) iv%instid(inst)%qci(k,n) = Atmosphere(1)%cloud(2)%water_content(k) diff --git a/var/da/da_radiance/da_get_innov_vector_crtmk.inc b/var/da/da_radiance/da_get_innov_vector_crtmk.inc index c71d599ad7..ddd75cf20b 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtmk.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtmk.inc @@ -77,7 +77,7 @@ subroutine da_get_innov_vector_crtmk ( it, grid, ob, iv ) Atmosphere(1)%n_Absorbers=2 Atmosphere(1)%n_Clouds=0 Atmosphere(1)%n_Aerosols=0 - if (crtm_cloud) Atmosphere(1)%n_Clouds=6 + if (crtm_cloud(it)) Atmosphere(1)%n_Clouds=6 Error_Status = CRTM_Allocate_Atmosphere( Atmosphere(1)%n_Layers, & Atmosphere(1)%n_Absorbers, & @@ -92,7 +92,7 @@ subroutine da_get_innov_vector_crtmk ( it, grid, ob, iv ) Atmosphere(1)%Absorber_ID(1)=H2O_ID Atmosphere(1)%Absorber_ID(2)=O3_ID - if (crtm_cloud) then + if (crtm_cloud(it)) then Atmosphere(1)%Cloud(1)%Type=WATER_CLOUD Atmosphere(1)%Cloud(2)%Type=ICE_CLOUD Atmosphere(1)%Cloud(3)%Type=RAIN_CLOUD @@ -217,7 +217,7 @@ subroutine da_get_innov_vector_crtmk ( it, grid, ob, iv ) call da_interp_lin_2d_partial (grid%xb%qcw(:,:,k), iv%instid(inst)%info,k,n,n, model_qcw(kte-k+1:kte-k+1)) - if (crtm_cloud) then + if (crtm_cloud(it)) then Atmosphere(1)%Cloud(1)%Water_Content(kte-k+1) = model_qcw(kte-k+1) call da_interp_lin_2d_partial (grid%xb%qci(:,:,k), iv%instid(inst)%info,k,n,n, & @@ -278,7 +278,7 @@ subroutine da_get_innov_vector_crtmk ( it, grid, ob, iv ) end do ! convert cloud content unit from kg/kg to kg/m^2 - if (crtm_cloud) then + if (crtm_cloud(it)) then do k=kts,kte do icld=1,Atmosphere(1)%n_Clouds Atmosphere(1)%Cloud(icld)%Water_Content(k)= Atmosphere(1)%Cloud(icld)%Water_Content(k)* & @@ -437,7 +437,7 @@ subroutine da_get_innov_vector_crtmk ( it, grid, ob, iv ) iv%instid(inst)%t_jacobian(l,k,n) = Atmosphere_k(l,1)%temperature(k) iv%instid(inst)%q_jacobian(l,k,n) = Atmosphere_k(l,1)%absorber(k,1) end do - if (crtm_cloud) then + if (crtm_cloud(it)) then iv%instid(inst)%qcw(k,n) = Atmosphere(1)%cloud(1)%water_content(k) iv%instid(inst)%qci(k,n) = Atmosphere(1)%cloud(2)%water_content(k) iv%instid(inst)%qrn(k,n) = Atmosphere(1)%cloud(3)%water_content(k) diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index a6d6a0892a..842e0e7de5 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -38,7 +38,7 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%qm(:,n) = 0.0 iv%instid(i)%qrn(:,n) = 0.0 iv%instid(i)%qcw(:,n) = 0.0 - if ( crtm_cloud ) then + if ( any(crtm_cloud) ) then iv%instid(i)%qci(:,n) = 0.0 iv%instid(i)%qsn(:,n) = 0.0 iv%instid(i)%qgr(:,n) = 0.0 @@ -78,7 +78,7 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%cloud_flag(:,n) = qc_good ! no cloud iv%instid(i)%ps(n) = 0.0 iv%instid(i)%tb_xb(:,n) = 0.0 - if ( crtm_cloud ) then + if ( any(crtm_cloud) ) then iv%instid(i)%tb_xb_clr(:,n) = 0.0 end if iv%instid(i)%tb_inv(:,n) = p%tb_inv(:) @@ -125,7 +125,7 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%ice_coverage(n)=0.0 iv%instid(i)%snow_coverage(n)=0.0 if (use_crtm_kmatrix) then - if ( crtm_cloud ) then + if ( any(crtm_cloud) ) then iv%instid(i)%water_jacobian(:,:,n)=0.0 iv%instid(i)%ice_jacobian(:,:,n)=0.0 iv%instid(i)%rain_jacobian(:,:,n)=0.0 diff --git a/var/da/da_radiance/da_qc_ahi.inc b/var/da/da_radiance/da_qc_ahi.inc index f9411eaedf..6202d3f06b 100644 --- a/var/da/da_radiance/da_qc_ahi.inc +++ b/var/da/da_radiance/da_qc_ahi.inc @@ -50,7 +50,7 @@ subroutine da_qc_ahi (it, i, nchan, ob, iv) if (iv%instid(i)%info%proc_domain(1,n)) & num_proc_domain = num_proc_domain + 1 - if ( crtm_cloud ) then + if ( crtm_cloud(it) ) then ! calculate c37_mean c37_mean = 1.0-(ob%instid(i)%tb(11,n)-ob%instid(i)%tb(12,n)+ & iv%instid(i)%tb_xb(11,n)-iv%instid(i)%tb_xb(12,n))/ & @@ -91,7 +91,7 @@ subroutine da_qc_ahi (it, i, nchan, ob, iv) ! 4.0 check cloud !----------------------------------------------------------------- - if (.not. crtm_cloud ) then + if (.not. crtm_cloud(it) ) then do k = 1, nchan @@ -128,7 +128,7 @@ subroutine da_qc_ahi (it, i, nchan, ob, iv) end if ! assigning obs errors - if (.not. crtm_cloud ) then + if (.not. crtm_cloud(it) ) then do k = 1, nchan if (use_error_factor_rad) then iv%instid(i)%tb_error(k,n) = & @@ -138,7 +138,7 @@ subroutine da_qc_ahi (it, i, nchan, ob, iv) end if end do ! nchan - else !crtm_cloud + else !crtm_cloud(it) ! symmetric error model, Geer and Bauer (2011) do k = 1, nchan if (c37_mean.lt.0.05) then @@ -155,7 +155,7 @@ subroutine da_qc_ahi (it, i, nchan, ob, iv) ! 5.0 check innovation !----------------------------------------------------------------- - if (.not. crtm_cloud ) then + if (.not. crtm_cloud(it) ) then ! absolute departure check do k = 1, nchan inv_grosscheck = 8.0 diff --git a/var/da/da_radiance/da_qc_amsr2.inc b/var/da/da_radiance/da_qc_amsr2.inc index fb05e52a12..5231ae7940 100644 --- a/var/da/da_radiance/da_qc_amsr2.inc +++ b/var/da/da_radiance/da_qc_amsr2.inc @@ -45,7 +45,7 @@ subroutine da_qc_amsr2 (it, i, nchan, ob, iv) if (iv%instid(i)%info%proc_domain(1,n)) & num_proc_domain = num_proc_domain + 1 - if ( crtm_cloud ) then + if ( crtm_cloud(it) ) then ! calculate c37_mean c37_mean = 1.0-(ob%instid(i)%tb(11,n)-ob%instid(i)%tb(12,n)+ & iv%instid(i)%tb_xb(11,n)-iv%instid(i)%tb_xb(12,n))/ & @@ -90,7 +90,7 @@ subroutine da_qc_amsr2 (it, i, nchan, ob, iv) ! 4.0 check cloud !----------------------------------------------------------------- - if (.not. crtm_cloud ) then + if (.not. crtm_cloud(it) ) then do k = 1, nchan ! clw check ! channel dependent criteria @@ -105,7 +105,7 @@ subroutine da_qc_amsr2 (it, i, nchan, ob, iv) end if ! assigning obs errors - if (.not. crtm_cloud ) then + if (.not. crtm_cloud(it) ) then do k = 1, nchan if (use_error_factor_rad) then iv%instid(i)%tb_error(k,n) = & @@ -115,7 +115,7 @@ subroutine da_qc_amsr2 (it, i, nchan, ob, iv) end if end do ! nchan - else !crtm_cloud + else !crtm_cloud(it) ! symmetric error model, Geer and Bauer (2011) do k = 1, nchan if (c37_mean.lt.0.05) then @@ -132,7 +132,7 @@ subroutine da_qc_amsr2 (it, i, nchan, ob, iv) ! 5.0 check innovation !----------------------------------------------------------------- - if (.not. crtm_cloud ) then + if (.not. crtm_cloud(it) ) then ! absolute departure check do k = 1, nchan if ( k <= 7 .or. k == 11 .or. k == 12) then diff --git a/var/da/da_radiance/da_qc_amsub.inc b/var/da/da_radiance/da_qc_amsub.inc index 6173607d56..0155b1d8cd 100644 --- a/var/da/da_radiance/da_qc_amsub.inc +++ b/var/da/da_radiance/da_qc_amsub.inc @@ -48,7 +48,7 @@ subroutine da_qc_amsub (it, i, nchan, ob, iv) ! 0.0 initialise QC flags by assuming good obs !--------------------------------------------- iv%instid(i)%tb_qc(:,n) = qc_good - if (crtm_cloud) go to 2508 + if (crtm_cloud(it)) go to 2508 ! a. reject all channels over mixture surface type !------------------------------------------------------ @@ -129,7 +129,7 @@ subroutine da_qc_amsub (it, i, nchan, ob, iv) !----------------------------------------------------------- do k = 1, nchan ! absolute departure check - if (.not. crtm_cloud) then + if (.not. crtm_cloud(it)) then if (abs(iv%instid(i)%tb_inv(k,n)) > 15.0) then iv%instid(i)%tb_qc(k,n) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & @@ -145,7 +145,7 @@ subroutine da_qc_amsub (it, i, nchan, ob, iv) iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) end if - if (.not. crtm_cloud) then + if (.not. crtm_cloud(it)) then if (abs(iv%instid(i)%tb_inv(k,n)) > 3.0*iv%instid(i)%tb_error(k,n)) then iv%instid(i)%tb_qc(k,n) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & diff --git a/var/da/da_radiance/da_qc_goesimg.inc b/var/da/da_radiance/da_qc_goesimg.inc index eff20e0bf6..0a64c1c96d 100644 --- a/var/da/da_radiance/da_qc_goesimg.inc +++ b/var/da/da_radiance/da_qc_goesimg.inc @@ -81,7 +81,7 @@ subroutine da_qc_goesimg(it, i, nchan, ob, iv) ! b. cloud detection !----------------------------------------------------------- - if (.not.crtm_cloud) then + if (.not.crtm_cloud(it)) then if (iv%instid(i)%clwp(n) >= 0.2) then iv%instid(i)%tb_qc(:,n) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & @@ -154,7 +154,7 @@ subroutine da_qc_goesimg(it, i, nchan, ob, iv) ! c.1. check absolute value of innovation !------------------------------------------------ - if (.not.crtm_cloud) then + if (.not.crtm_cloud(it)) then inv_grosscheck = 15.0 if (use_satcv(2)) inv_grosscheck = 100.0 if (abs(iv%instid(i)%tb_inv(k,n)) > inv_grosscheck) then diff --git a/var/da/da_radiance/da_setup_radiance_structures.inc b/var/da/da_radiance/da_setup_radiance_structures.inc index 2c19d2f883..c72173e59f 100644 --- a/var/da/da_radiance/da_setup_radiance_structures.inc +++ b/var/da/da_radiance/da_setup_radiance_structures.inc @@ -315,7 +315,7 @@ subroutine da_setup_radiance_structures( grid, ob, iv ) ! Calculate DT for Cloudy Radiance DA - if (use_rad .and. crtm_cloud .and. .not. DT_cloud_model) then + if (use_rad .and. any(crtm_cloud) .and. .not. DT_cloud_model) then its = grid%xp % its ite = grid%xp % ite jts = grid%xp % jts diff --git a/var/da/da_radiance/da_transform_xtoy_crtm.inc b/var/da/da_radiance/da_transform_xtoy_crtm.inc index 447ce6dea2..75f913ddd1 100644 --- a/var/da/da_radiance/da_transform_xtoy_crtm.inc +++ b/var/da/da_radiance/da_transform_xtoy_crtm.inc @@ -1,4 +1,4 @@ -subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) +subroutine da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y ) !--------------------------------------------------------------------------- ! PURPOSE: transform from analysis increment to @@ -16,6 +16,7 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) implicit none + integer, intent(in) :: it ! external iteration #. integer, intent(in) :: cv_size ! Size of cv array. real, intent(in) :: cv(1:cv_size) ! control variables. type (domain), intent(in) :: grid @@ -150,7 +151,7 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) n_absorbers = 2 n_aerosols = 0 n_clouds = 0 - if ( crtm_cloud ) n_clouds = 6 + if ( crtm_cloud(it) ) n_clouds = 6 call CRTM_Atmosphere_Create( Atmosphere(n), & n_layers, & @@ -168,7 +169,7 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) Atmosphere(n)%Absorber_Units(2) = VOLUME_MIXING_RATIO_UNITS Atmosphere(n)%Climatology=iv%instid(inst)%crtm_climat(n) - if (crtm_cloud) then + if (crtm_cloud(it)) then Atmosphere(n)%Cloud(1)%Type=WATER_CLOUD Atmosphere(n)%Cloud(2)%Type=ICE_CLOUD Atmosphere(n)%Cloud(3)%Type=RAIN_CLOUD @@ -222,7 +223,7 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) xb_q(:,:) = 0.0 psfc(:) = 0.0 - if (crtm_cloud) then + if (crtm_cloud(it)) then allocate (qcw(Atmosphere(iv%instid(inst)%info%n1)%n_layers, iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) allocate (qci(Atmosphere(iv%instid(inst)%info%n1)%n_layers, iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) @@ -243,7 +244,7 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) call da_interp_2d_partial (grid%xa%q(:,:,k), iv%instid(inst)%info, k, iv%instid(inst)%info%n1, iv%instid(inst)%info%n2, & absorber(kte-k+1,:)) - if ( crtm_cloud .and. cloud_cv_options > 0 ) then + if ( crtm_cloud(it) .and. cloud_cv_options > 0 ) then call da_interp_2d_partial (grid%xa%qcw(:,:,k), iv%instid(inst)%info, k, iv%instid(inst)%info%n1, iv%instid(inst)%info%n2, & qcw(kte-k+1,:)) @@ -297,7 +298,7 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) Atmosphere(n)%absorber(k,1) = iv%instid(inst)%qm(k,n) xb_q(k,n) = 0.001*iv%instid(inst)%qm(k,n)/(1.0+iv%instid(inst)%qm(k,n)) ! specific humidity end do - if (crtm_cloud) then + if (crtm_cloud(it)) then do k=1,Atmosphere(n)%n_layers Atmosphere(n)%cloud(1)%water_content(k)=iv%instid(inst)%qcw(k,n) Atmosphere(n)%cloud(2)%water_content(k)=iv%instid(inst)%qci(k,n) @@ -384,7 +385,7 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) Atmosphere_TL(n)%Temperature(kts+1:kte) = temperature(kts+1:kte,n) ! Zero Jacobian for top level Atmosphere_TL(n)%Level_Pressure(Atmosphere_TL(n)%n_Layers) = 0.01 * psfc(n) - if (crtm_cloud) then + if (crtm_cloud(it)) then Atmosphere_TL(n)%Cloud(1)%Water_Content(kts:kte) = qcw(kts:kte,n) Atmosphere_TL(n)%Cloud(2)%Water_Content(kts:kte) = qci(kts:kte,n) Atmosphere_TL(n)%Cloud(3)%Water_Content(kts:kte) = qrn(kts:kte,n) @@ -479,7 +480,7 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) RTSolution_TL(l,n)%brightness_temperature = RTSolution_TL(l,n)%brightness_temperature + & iv%instid(inst)%t_jacobian(l,k,n) * Atmosphere_TL(n)%Temperature(k) + & iv%instid(inst)%q_jacobian(l,k,n) * Atmosphere_TL(n)%absorber(k,1) - if (crtm_cloud) then + if (crtm_cloud(it)) then RTSolution_TL(l,n)%brightness_temperature = RTSolution_TL(l,n)%brightness_temperature + & iv%instid(inst)%water_jacobian(l,k,n) * Atmosphere_TL(n)%Cloud(1)%Water_Content(k) + & iv%instid(inst)%ice_jacobian(l,k,n) * Atmosphere_TL(n)%Cloud(2)%Water_Content(k) + & @@ -522,7 +523,7 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) deallocate (xb_q) deallocate (psfc) - if (crtm_cloud) then + if (crtm_cloud(it)) then deallocate (qcw) deallocate (qci) deallocate (qrn) diff --git a/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc b/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc index 06047ed068..9efa9c3c03 100644 --- a/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc +++ b/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc @@ -1,4 +1,4 @@ -subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) +subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_x ) !--------------------------------------------------------------------------- ! PURPOSE: transform gradient from obs space to model grid space. @@ -16,6 +16,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) implicit none + integer, intent(in) :: it ! external iteration #. integer, intent(in) :: cv_size ! Size of cv array. real, intent(inout) :: cv(1:cv_size) ! control variables. type (x_type), intent(inout) :: jo_grad_x ! @@ -167,7 +168,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) n_absorbers = 2 n_aerosols = 0 n_clouds = 0 - if ( crtm_cloud ) n_clouds = 6 + if ( crtm_cloud(it) ) n_clouds = 6 call CRTM_Atmosphere_Create( Atmosphere(n), & n_layers, & @@ -184,7 +185,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) Atmosphere(n)%Absorber_Units(2) = VOLUME_MIXING_RATIO_UNITS Atmosphere(n)%Climatology=iv%instid(inst)%crtm_climat(n) - if (crtm_cloud) then + if (crtm_cloud(it)) then Atmosphere(n)%Cloud(1)%Type=WATER_CLOUD Atmosphere(n)%Cloud(2)%Type=ICE_CLOUD Atmosphere(n)%Cloud(3)%Type=RAIN_CLOUD @@ -206,7 +207,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) p_ad = 0.0 xb_q = 0.0 - if (crtm_cloud) then + if (crtm_cloud(it)) then allocate (qcw_ad(kts:kte,iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) allocate (qci_ad(kts:kte,iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) allocate (qrn_ad(kts:kte,iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) @@ -282,7 +283,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) xb_q(k,n) = 0.001*iv%instid(inst)%qm(k,n)/(1.0+iv%instid(inst)%qm(k,n)) ! specific humidity end do - if (crtm_cloud) then + if (crtm_cloud(it)) then do k=1,Atmosphere(n)%n_layers Atmosphere(n)%cloud(1)%water_content(k)=iv%instid(inst)%qcw(k,n) Atmosphere(n)%cloud(2)%water_content(k)=iv%instid(inst)%qci(k,n) @@ -405,7 +406,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) iv%instid(inst)%t_jacobian(i,k,n) * RTSolution_AD(i,n)%brightness_temperature Atmosphere_AD(n)%absorber(k,1) = Atmosphere_AD(n)%absorber(k,1) + & iv%instid(inst)%q_jacobian(i,k,n) * RTSolution_AD(i,n)%brightness_temperature - if (crtm_cloud) then + if (crtm_cloud(it)) then Atmosphere_AD(n)%Cloud(1)%Water_Content(k) = Atmosphere_AD(n)%Cloud(1)%Water_Content(k) + & iv%instid(inst)%water_jacobian(i,k,n) * RTSolution_AD(i,n)%brightness_temperature Atmosphere_AD(n)%Cloud(2)%Water_Content(k) = Atmosphere_AD(n)%Cloud(2)%Water_Content(k) + & @@ -475,7 +476,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) ! [1.5] Scale transformation and fill zero for no-control variable ! Convert cloud content unit from kg/kg to kg/m^2 - if (crtm_cloud) then + if (crtm_cloud(it)) then do k=kts,kte do icld=1,Atmosphere(n)%n_Clouds Atmosphere_AD(n)%Cloud(icld)%Water_Content(k) = & @@ -487,7 +488,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) ! [1.6] Adjoint of Interpolate horizontally from ob to grid: - if (crtm_cloud) then + if (crtm_cloud(it)) then do k=kts,kte ! from bottom to top qcw_ad(k,n)=Atmosphere_AD(n)%Cloud(1)%Water_Content(kte-k+1) qci_ad(k,n)=Atmosphere_AD(n)%Cloud(2)%Water_Content(kte-k+1) @@ -542,7 +543,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) !!! call wrf_dm_sum_reals(cv_local, cv) !#endif - if ( crtm_cloud .and. cloud_cv_options > 0 ) then + if ( crtm_cloud(it) .and. cloud_cv_options > 0 ) then call da_interp_lin_2d_adj_partial(jo_grad_x%qcw(:,:,kts:kte),iv%instid(inst)%info, kts,kte, qcw_ad) call da_interp_lin_2d_adj_partial(jo_grad_x%qrn(:,:,kts:kte),iv%instid(inst)%info, kts,kte, qrn_ad) if ( cloud_cv_options > 1 ) then @@ -561,7 +562,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) deallocate (p_ad) deallocate (xb_q) - if (crtm_cloud) then + if (crtm_cloud(it)) then deallocate (qcw_ad) deallocate (qci_ad) deallocate (qrn_ad) diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index 4c14d51466..e5e492a34e 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -180,7 +180,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) #ifdef CRTM write(unit=innov_rad_unit,fmt='(a)') & 'level fullp(mb) halfp(mb) t(k) q(g/kg) water(mm) ice(mm) rain(mm) snow(mm) graupel(mm) hail(mm)' - if (crtm_cloud) then + if (crtm_cloud(it)) then do k=1,iv%instid(i)%nlevels-1 write(unit=innov_rad_unit,fmt='(i3,2f10.2,f8.2,13f8.3)') & k, & @@ -216,7 +216,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) 0.0, & 0.0 end do ! end loop profile - end if ! end if crtm_cloud + end if ! end if crtm_cloud(it) #endif end if ! end if rtm_option_crtm @@ -241,7 +241,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(a)') & 'channel level halfp(mb) t(k) q(g/kg) der_trans trans_jac trans lod_jac lod water(mm) ice(mm) rain(mm) snow(mm) graupel(mm) hail(mm)' - if (crtm_cloud) then + if (crtm_cloud(it)) then do l=1,iv%instid(i)%nchan do k=1,iv%instid(i)%nlevels-1 write(unit=innov_rad_unit,fmt='(i5,i3,f10.2,13f14.7,6f14.7)') & @@ -295,7 +295,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) 0. end do ! end loop profile end do ! end loop channels - end if ! end if crtm_cloud + end if ! end if crtm_cloud(it) #endif end if ! end if write_jacobian diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index 8f6d5f1bfc..8e5a677be1 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -169,7 +169,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) #ifdef CRTM write(unit=oma_rad_unit,fmt='(a)') & 'level fullp(mb) halfp(mb) t(k) q(g/kg) water(mm) ice(mm) rain(mm) snow(mm) graupel(mm) hail(mm)' - if (crtm_cloud) then + if (crtm_cloud(it)) then do k=1,iv%instid(i)%nlevels-1 write(unit=oma_rad_unit,fmt='(i3,2f10.2,f8.2,13f8.3)') & k, & @@ -205,7 +205,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) 0.0, & 0.0 end do ! end loop profile - end if ! end if crtm_cloud + end if ! end if crtm_cloud(it) #endif end if ! end if crtm_option diff --git a/var/da/da_setup_structures/da_setup_be_nmm_regional.inc b/var/da/da_setup_structures/da_setup_be_nmm_regional.inc index 5598b62a44..051666f740 100644 --- a/var/da/da_setup_structures/da_setup_be_nmm_regional.inc +++ b/var/da/da_setup_structures/da_setup_be_nmm_regional.inc @@ -389,7 +389,7 @@ subroutine da_setup_be_nmm_regional(xb, be) deallocate (eval_loc) ! - if(use_radarobs .and. use_radar_rf .or. use_rad .and. crtm_cloud) then + if(use_radarobs .and. use_radar_rf .or. use_rad .and. any(crtm_cloud)) then if ( cloud_cv_options == 1 ) be % v4 % name = 'qt ' end if diff --git a/var/da/da_setup_structures/da_setup_be_regional.inc b/var/da/da_setup_structures/da_setup_be_regional.inc index 7869f120ca..a7017af903 100644 --- a/var/da/da_setup_structures/da_setup_be_regional.inc +++ b/var/da/da_setup_structures/da_setup_be_regional.inc @@ -803,7 +803,7 @@ subroutine da_setup_be_regional(xb, be, grid) deallocate (evec_loc) deallocate (eval_loc) - if(use_radarobs .and. use_radar_rf .or. use_rad .and. crtm_cloud) then + if(use_radarobs .and. use_radar_rf .or. use_rad .and. any(crtm_cloud)) then if ( cloud_cv_options == 1 ) be % v4 % name = 'qt ' end if diff --git a/var/da/da_test/da_check_vptox_adjoint.inc b/var/da/da_test/da_check_vptox_adjoint.inc index 4f6113fcdb..d0815c7bd9 100644 --- a/var/da/da_test/da_check_vptox_adjoint.inc +++ b/var/da/da_test/da_check_vptox_adjoint.inc @@ -157,7 +157,7 @@ subroutine da_check_vptox_adjoint(grid, ne, be, ep, vp, cv_size) adj_par_lhs = sum(grid%xa%u(its:ite,jts:jte,:)**2)/typical_u_rms**2 adj_par_lhs = sum(grid%xa%v(its:ite,jts:jte,:)**2)/typical_v_rms**2 + adj_par_lhs adj_par_lhs = sum(grid%xa%t(its:ite,jts:jte,:)**2)/typical_t_rms**2 + adj_par_lhs - if ( (use_radar_rf .or. crtm_cloud) .and. (cloud_cv_options == 1) ) then + if ( (use_radar_rf .or. crtm_cloud(1)) .and. (cloud_cv_options == 1) ) then adj_par_lhs = sum(grid%xa%qt(its:ite,jts:jte,:)**2)/typical_q_rms**2 + adj_par_lhs else adj_par_lhs = sum(grid%xa%q(its:ite,jts:jte,:)**2)/typical_q_rms**2 + adj_par_lhs @@ -194,7 +194,7 @@ subroutine da_check_vptox_adjoint(grid, ne, be, ep, vp, cv_size) typical_qgr_rms**2 + adj_par_lhs end if - if (use_radar_rf .or. crtm_cloud) then + if (use_radar_rf .or. crtm_cloud(1)) then if ( cloud_cv_options == 1 ) then adj_par_lhs = sum(grid%xa % qcw(its:ite,jts:jte,kts:kte)**2) / & typical_qcw_rms**2 + adj_par_lhs @@ -210,7 +210,7 @@ subroutine da_check_vptox_adjoint(grid, ne, be, ep, vp, cv_size) grid%xa % u(:,:,:) = grid%xa % u(:,:,:) / typical_u_rms**2 grid%xa % v(:,:,:) = grid%xa % v(:,:,:) / typical_v_rms**2 grid%xa % t(:,:,:) = grid%xa % t(:,:,:) / typical_t_rms**2 - if ( (use_radar_rf .or. crtm_cloud) .and. (cloud_cv_options == 1) ) then + if ( (use_radar_rf .or. crtm_cloud(1)) .and. (cloud_cv_options == 1) ) then grid%xa % qt(:,:,:) = grid%xa % qt(:,:,:) / typical_q_rms**2 else grid%xa % q(:,:,:) = grid%xa % q(:,:,:) / typical_q_rms**2 @@ -239,7 +239,7 @@ subroutine da_check_vptox_adjoint(grid, ne, be, ep, vp, cv_size) grid%xa % qgr(:,:,:) = grid%xa % qgr(:,:,:) / typical_qgr_rms**2 end if - if (use_radar_rf .or. crtm_cloud) then + if (use_radar_rf .or. crtm_cloud(1)) then if ( cloud_cv_options == 1 ) then grid%xa % qcw(:,:,:) = grid%xa % qcw(:,:,:) / typical_qcw_rms**2 grid%xa % qrn(:,:,:) = grid%xa % qrn(:,:,:) / typical_qrn_rms**2 diff --git a/var/da/da_test/da_check_vtox_adjoint.inc b/var/da/da_test/da_check_vtox_adjoint.inc index 8457c5b7f7..df6dd425e8 100644 --- a/var/da/da_test/da_check_vtox_adjoint.inc +++ b/var/da/da_test/da_check_vtox_adjoint.inc @@ -61,7 +61,7 @@ subroutine da_check_vtox_adjoint(grid, cv_size, xbx, be, ep, cv1, vv, vp) + sum(grid%xa % rh(its:ite, jts:jte, kts:kte)**2) / typical_rh_rms**2 end if ! - if (use_radar_rf .or. use_radar_rhv .or. crtm_cloud ) then + if (use_radar_rf .or. use_radar_rhv .or. crtm_cloud(1) ) then adj_par_lhs = adj_par_lhs & + sum(grid%xa % qcw(its:ite, jts:jte, kts:kte)**2)/typical_qcw_rms**2 & + sum(grid%xa % qrn(its:ite, jts:jte, kts:kte)**2)/typical_qrn_rms**2 @@ -99,7 +99,7 @@ subroutine da_check_vtox_adjoint(grid, cv_size, xbx, be, ep, cv1, vv, vp) end if ! - if (use_radar_rf .or. use_radar_rhv .or. crtm_cloud ) then + if (use_radar_rf .or. use_radar_rhv .or. crtm_cloud(1) ) then grid%xa % qcw(:,:,:) = grid%xa % qcw(:,:,:) / typical_qcw_rms**2 grid%xa % qrn(:,:,:) = grid%xa % qrn(:,:,:) / typical_qrn_rms**2 if ( cloud_cv_options /= 1 ) then diff --git a/var/da/da_test/da_check_vtoy_adjoint.inc b/var/da/da_test/da_check_vtoy_adjoint.inc index cba3911229..3faffad26d 100644 --- a/var/da/da_test/da_check_vtoy_adjoint.inc +++ b/var/da/da_test/da_check_vtoy_adjoint.inc @@ -41,7 +41,7 @@ subroutine da_check_vtoy_adjoint(cv_size,grid, config_flags, vp, vv, xbx, be, ep call da_zero_vp_type(vp) call da_zero_vp_type(vv) - call da_transform_vtoy(cv_size, be, ep, cv, iv, vp, vv, xbx, y, grid, config_flags, vp, vv) + call da_transform_vtoy(1, cv_size, be, ep, cv, iv, vp, vv, xbx, y, grid, config_flags, vp, vv) !------------------------------------------------------------------------- ! [3.0] Calculate LHS of adjoint test equation and @@ -57,7 +57,7 @@ subroutine da_check_vtoy_adjoint(cv_size,grid, config_flags, vp, vv, xbx, be, ep ! call da_zero_vp_type(vv) ! call da_zero_x(grid%xa) - call da_transform_vtoy_adj(cv_size, be, ep, cv, iv, vp, vv, xbx, y, grid, & + call da_transform_vtoy_adj(1, cv_size, be, ep, cv, iv, vp, vv, xbx, y, grid, & config_flags, .true., vp, vv) adj_rhs = sum(cv(1:cv_size) * cv_2(1:cv_size)) diff --git a/var/da/da_test/da_check_xtoy_adjoint.inc b/var/da/da_test/da_check_xtoy_adjoint.inc index 6b966820ab..8025a8e80c 100644 --- a/var/da/da_test/da_check_xtoy_adjoint.inc +++ b/var/da/da_test/da_check_xtoy_adjoint.inc @@ -315,7 +315,7 @@ print*,__FILE__,jte,' xa2_v.xa2_v for row= ',jte+1,sum(xa2_v(its:ite, jte+1, kts !---------------------------------------------------------------------- ! [2.0] Perform y = Hx transform: !---------------------------------------------------------------------- - call da_transform_xtoy (cv_size, cv, grid, iv, y) + call da_transform_xtoy (1, cv_size, cv, grid, iv, y) #ifdef VAR4D if (iv%info(rain)%nlocal > 0 .and. var4d) & @@ -372,7 +372,7 @@ print*,__FILE__,jte,' xa2_v.xa2_v for row= ',jte+1,sum(xa2_v(its:ite, jte+1, kts endif #endif - call da_transform_xtoy_adj (cv_size, cv, grid, iv, y, grid%xa) + call da_transform_xtoy_adj (1, cv_size, cv, grid, iv, y, grid%xa) #ifdef A2C if( ite == ide ) & diff --git a/var/da/da_test/da_setup_testfield.inc b/var/da/da_test/da_setup_testfield.inc index 56aa2a5147..01e5b524f9 100644 --- a/var/da/da_test/da_setup_testfield.inc +++ b/var/da/da_test/da_setup_testfield.inc @@ -33,7 +33,7 @@ subroutine da_setup_testfield(grid) call da_set_tst_trnsf_fld(grid, grid%xa%t, grid%xb%t, typical_t_rms) call da_set_tst_trnsf_fld(grid, grid%xa%p, grid%xb%p, typical_p_rms) call da_set_tst_trnsf_fld(grid, grid%xa%q, grid%xb%q, typical_q_rms) - if ( ( use_rad .and. crtm_cloud ) .or. use_radar_rf .or. use_radar_rhv ) then + if ( ( use_rad .and. crtm_cloud(1) ) .or. use_radar_rf .or. use_radar_rhv ) then call da_set_tst_trnsf_fld(grid, grid%xa%qcw, grid%xb%qcw, typical_qcw_rms) call da_set_tst_trnsf_fld(grid, grid%xa%qrn, grid%xb%qrn, typical_qrn_rms) call da_set_tst_trnsf_fld(grid, grid%xa%qci, grid%xb%qci, typical_qci_rms) diff --git a/var/da/da_test/da_test_vtoy_transform.inc b/var/da/da_test/da_test_vtoy_transform.inc index 22c318880c..066cb3ad81 100644 --- a/var/da/da_test/da_test_vtoy_transform.inc +++ b/var/da/da_test/da_test_vtoy_transform.inc @@ -40,7 +40,7 @@ subroutine da_test_vtoy_transform(grid, config_flags, vp, vv, xbx, be, iv, y) call da_zero_vp_type(vp) call da_zero_vp_type(vv) - call da_transform_vtoy(be, cv, iv, vp, vv, xbx, y, grid, config_flags ) + call da_transform_vtoy(1, be, cv, iv, vp, vv, xbx, y, grid, config_flags ) !------------------------------------------------------------------------- ! [3.0] Calculate LHS of adjoint test equation and @@ -55,7 +55,7 @@ subroutine da_test_vtoy_transform(grid, config_flags, vp, vv, xbx, be, iv, y) ! call da_zero_vp_type(vv) ! call da_zero_x(grid%xa) - call da_transform_vtoy_adj(be, cv, iv, vp, vv, xbx, y, grid, config_flags, .true. ) + call da_transform_vtoy_adj(1, be, cv, iv, vp, vv, xbx, y, grid, config_flags, .true. ) adj_rhs = sum( cv(1:cv_size) * cv_2(1:cv_size) ) !------------------------------------------------------------------------- From 885cdfdd6f03a9c3f273ce9d1fae25cff5606609 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Fri, 26 Jul 2019 12:27:07 -0600 Subject: [PATCH 50/86] Allow ABI tb_err to change each outer iteration --- var/da/da_radiance/da_qc_goesabi.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 55dd86e2d4..d219d6ceed 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -524,7 +524,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ca_mean(:,n) !JJGDEBUG - if (it == 1) then + if ( crtm_cloud(it) ) then if (use_rad_symm_err) then ! symmetric error model ! - Okamoto, McNally, & Bell (2013) From 42bd5eca0e4df154af6878bbf7cff03090664c00 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 4 Sep 2019 15:44:42 -0600 Subject: [PATCH 51/86] Update goes-16-abi.info --- var/run/radiance_info/goes-16-abi.info | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/var/run/radiance_info/goes-16-abi.info b/var/run/radiance_info/goes-16-abi.info index e3833c7294..bb9e6ce4ac 100644 --- a/var/run/radiance_info/goes-16-abi.info +++ b/var/run/radiance_info/goes-16-abi.info @@ -1,11 +1,11 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) - 1023 1 -1 1 0 2.7200000000E+00 0.0000000000E+00 24.00000 27.00000 + 1023 1 1 -1 0 2.7200000000E+00 0.0000000000E+00 25.00000 12.00000 1023 2 1 1 0 1.7900000000E+00 0.0000000000E+00 8.60000 18.00000 1023 3 1 1 0 1.9200000000E+00 0.0000000000E+00 12.00000 26.00000 1023 4 1 1 0 1.7400000000E+00 0.0000000000E+00 16.90000 23.00000 - 1023 5 -1 1 0 5.0000000000E+00 0.0000000000E+00 27.00000 18.00000 - 1023 6 -1 1 0 2.7900000000E+00 0.0000000000E+00 15.00000 10.00000 - 1023 7 -1 1 0 3.0800000000E+00 0.0000000000E+00 28.00000 20.00000 - 1023 8 -1 1 0 3.0600000000E+00 0.0000000000E+00 28.00000 20.00000 - 1023 9 -1 1 0 2.8200000000E+00 0.0000000000E+00 28.00000 20.00000 - 1023 10 -1 1 0 1.7400000000E+00 0.0000000000E+00 20.00000 12.00000 + 1023 5 1 -1 0 5.0000000000E+00 0.0000000000E+00 27.00000 18.00000 + 1023 6 1 -1 0 2.7900000000E+00 0.0000000000E+00 15.00000 10.00000 + 1023 7 1 -1 0 3.0800000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 8 1 -1 0 3.0600000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 9 1 -1 0 2.8200000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 10 1 -1 0 1.7400000000E+00 0.0000000000E+00 20.00000 12.00000 From 7cc33d3500da8f12966987ccaec90ad485eb4040 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Fri, 8 Nov 2019 14:04:16 -0700 Subject: [PATCH 52/86] Divide ca_mean diagnostic into model and obs components --- .../da_define_structures.f90 | 3 +- var/da/da_monitor/da_rad_diags.f90 | 29 +++++--- var/da/da_radiance/da_allocate_rad_iv.inc | 3 +- var/da/da_radiance/da_deallocate_radiance.inc | 3 +- var/da/da_radiance/da_qc_goesabi.inc | 71 ++++++++++--------- var/da/da_radiance/da_write_iv_rad_ascii.inc | 8 ++- var/da/da_radiance/da_write_oa_rad_ascii.inc | 8 ++- 7 files changed, 73 insertions(+), 52 deletions(-) diff --git a/var/da/da_define_structures/da_define_structures.f90 b/var/da/da_define_structures/da_define_structures.f90 index f6ff6d1566..e4faee76fa 100644 --- a/var/da/da_define_structures/da_define_structures.f90 +++ b/var/da/da_define_structures/da_define_structures.f90 @@ -523,7 +523,8 @@ module da_define_structures integer, pointer :: cloud_flag(:,:) integer, pointer :: cloudflag(:) integer, pointer :: rain_flag(:) - real, pointer :: ca_mean(:,:) + real, pointer :: cloud_mod(:,:) + real, pointer :: cloud_obs(:,:) real, pointer :: satzen(:) real, pointer :: satazi(:) real, pointer :: solzen(:) diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index bde4c3d64c..6a531bf343 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -62,7 +62,7 @@ program da_rad_diags real*4, dimension(:), allocatable :: smois, tslb, snowh, vegfra, clwp integer, dimension(:,:), allocatable :: tb_qc, tb_cloud real*4, dimension(:,:), allocatable :: tb_obs, tb_bak, tb_inv, tb_oma, tb_err, ems, ems_jac - real*4, dimension(:,:), allocatable :: ca_mean, tb_bak_clr + real*4, dimension(:,:), allocatable :: cloud_mod, cloud_obs, tb_bak_clr real*4, dimension(:,:), allocatable :: prf_pfull, prf_phalf, prf_t, prf_q, prf_water real*4, dimension(:,:), allocatable :: prf_ice, prf_rain, prf_snow, prf_grau, prf_hail real*4, dimension(:,:), allocatable :: prf_water_reff, prf_ice_reff, prf_rain_reff @@ -257,7 +257,8 @@ program da_rad_diags allocate ( tb_cloud(1:nchan,1:total_npixel) ) tb_cloud = 0 if ( abi ) then - allocate ( ca_mean(1:nchan,1:total_npixel) ) + allocate ( cloud_mod(1:nchan,1:total_npixel) ) + allocate ( cloud_obs(1:nchan,1:total_npixel) ) allocate ( tb_bak_clr(1:nchan,1:total_npixel) ) end if allocate ( ems(1:nchan,1:total_npixel) ) @@ -329,7 +330,8 @@ program da_rad_diags tb_oma = missing_r tb_err = missing_r if ( abi ) then - ca_mean = missing_r + cloud_mod = missing_r + cloud_obs = missing_r tb_bak_clr = missing_r end if @@ -385,10 +387,12 @@ program da_rad_diags read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CLOUD, CA, INFO, or level if ( buf(1:5) == "CLOUD" ) then ! read cloud detection info read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_cloud(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CA, INFO, or level + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CMOD, INFO, or level end if - if ( abi .and. buf(1:2) == "CA" ) then ! read ca_mean, tb_bak_clr for abi - read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) ca_mean(:,ipixel) + if ( abi .and. buf(1:4) == "CMOD" ) then ! read cloud_mod, cloud_obs, tb_bak_clr for abi + read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) cloud_mod(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! COBS + read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) cloud_obs(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! BGCLR read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_bak_clr(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! INFO or level @@ -521,7 +525,9 @@ program da_rad_diags ios = NF_DEF_VAR(ncid, 'tb_qc', NF_INT, 2, ishape(1:2), varid) ios = NF_DEF_VAR(ncid, 'tb_cloud', NF_INT, 2, ishape(1:2), varid) if ( abi ) then - ios = NF_DEF_VAR(ncid, 'ca_mean', NF_FLOAT, 2, ishape(1:2), varid) + ios = NF_DEF_VAR(ncid, 'cloud_mod', NF_FLOAT, 2, ishape(1:2), varid) + ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) + ios = NF_DEF_VAR(ncid, 'cloud_obs', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) ios = NF_DEF_VAR(ncid, 'tb_bak_clr', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) @@ -666,8 +672,10 @@ program da_rad_diags ios = NF_INQ_VARID (ncid, 'tb_cloud', varid) ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), tb_cloud) if ( abi ) then - ios = NF_INQ_VARID (ncid, 'ca_mean', varid) - ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), ca_mean) + ios = NF_INQ_VARID (ncid, 'cloud_mod', varid) + ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), cloud_mod) + ios = NF_INQ_VARID (ncid, 'cloud_obs', varid) + ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), cloud_obs) ios = NF_INQ_VARID (ncid, 'tb_bak_clr', varid) ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_bak_clr) end if @@ -876,7 +884,8 @@ program da_rad_diags deallocate ( tb_bak ) deallocate ( tb_inv ) if ( abi ) then - deallocate ( ca_mean ) + deallocate ( cloud_mod ) + deallocate ( cloud_obs ) deallocate ( tb_bak_clr ) end if deallocate ( tb_oma ) diff --git a/var/da/da_radiance/da_allocate_rad_iv.inc b/var/da/da_radiance/da_allocate_rad_iv.inc index 1d84a437bb..b63b71a9ea 100644 --- a/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/var/da/da_radiance/da_allocate_rad_iv.inc @@ -84,7 +84,8 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate (iv%instid(i)%cloudflag(iv%instid(i)%num_rad)) end if if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then - allocate (iv%instid(i)%ca_mean(nchan,iv%instid(i)%num_rad)) + allocate (iv%instid(i)%cloud_mod(nchan,iv%instid(i)%num_rad)) + allocate (iv%instid(i)%cloud_obs(nchan,iv%instid(i)%num_rad)) end if allocate (iv%instid(i)%ps(iv%instid(i)%num_rad)) allocate (iv%instid(i)%tb_xb(nchan,iv%instid(i)%num_rad)) diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index 7abd7b403f..3ac8a809a2 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -106,7 +106,8 @@ deallocate (iv%instid(i)%cloudflag) end if if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then - deallocate (iv%instid(i)%ca_mean) + deallocate (iv%instid(i)%cloud_mod) + deallocate (iv%instid(i)%cloud_obs) end if deallocate (iv%instid(i)%ps) deallocate (iv%instid(i)%tb_xb) diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index d219d6ceed..f681b88d93 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -39,7 +39,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) logical :: print_cld_debug !! Additional variables used by Harnish, Weissmann, & Perianez (2016) - real :: BTlim(nchan) + real :: BTlim(nchan), cloud_mean(nchan) real, allocatable :: cld_impact(:,:), cld_impact_global(:,:), weights_global(:) integer :: buf_i, buf_f, nbuf, nlocal, nglobal, iproc real, parameter :: camin = 0.0 !Harnisch et al. (2016) @@ -65,7 +65,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) integer :: nrej_clddet(nchan,num_clddet_tests) integer*2 :: clddet_tests(num_clddet_tests) - real, pointer :: tb_ob(:,:), tb_xb(:,:), tb_inv(:,:), tb_xb_clr(:,:), ca_mean(:,:) + real, pointer :: tb_ob(:,:), tb_xb(:,:), tb_inv(:,:), tb_xb_clr(:,:), cloud_obs(:,:), cloud_mod(:,:) integer :: tb_qc(nchan), tb_qc_clddet(nchan) real :: big_num @@ -173,8 +173,11 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) BTlim(9) = 270.5 BTlim(10) = 258.0 - ca_mean => iv%instid(isens)%ca_mean - ca_mean = missing_r + cloud_obs => iv%instid(isens)%cloud_obs + cloud_obs = missing_r + + cloud_mod => iv%instid(isens)%cloud_mod + cloud_mod = missing_r end if PixelQCLoop: do n= iv%instid(isens)%info%n1,iv%instid(isens)%info%n2 @@ -499,7 +502,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) iv%instid(isens)%tb_error(:,n) = satinfo(isens)%error_std(:) end if else !crtm_cloud(it) - ! calculate ca_mean + ! calculate cloud impacts where ( tb_inv( :, n ) > missing_r & .and. tb_ob( :, n ) > 0. & .and. tb_xb( :, n ) > 0. & @@ -510,43 +513,45 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! using ob with VarBC (tb_inv + tb_xb) ! ------------------------------- !! Harnisch et al. (2016) - ca_mean(:,n) = 0.5 * ( max( 0., BTlim(:) - tb_xb(:,n) ) + & - max( 0., BTlim(:) - (tb_inv(:,n) + tb_xb(:,n)) ) ) + cloud_mod(:,n) = max( 0., BTlim(:) - tb_xb(:,n) ) + cloud_obs(:,n) = max( 0., BTlim(:) - (tb_inv(:,n) + tb_xb(:,n)) ) + !! Okamoto et al. (2013) -! ca_mean(:,n) = 0.5 * ( abs( tb_xb(:,n) - tb_xb_clr(:,n) ) + & -! abs( (tb_inv(:,n) + tb_xb(:,n)) - tb_xb_clr(:,n) ) ) +! cloud_mod(:,n) = abs( tb_xb(:,n) - tb_xb_clr(:,n) ) + & +! cloud_obs(:,n) = abs( (tb_inv(:,n) + tb_xb(:,n)) - tb_xb_clr(:,n) ) !!! J. Guerrette -! ca_mean(:,n) = 0.5 * ( max( 0., tb_xb_clr(:,n) - tb_xb(:,n) ) + & -! max( 0., tb_xb_clr(:,n) - (tb_inv(:,n) + tb_xb(:,n)) ) ) +! cloud_mod(:,n) = max( 0., tb_xb_clr(:,n) - tb_xb(:,n) ) + & +! cloud_obs(:,n) = max( 0., tb_xb_clr(:,n) - (tb_inv(:,n) + tb_xb(:,n)) ) endwhere !JJGDEBUG if (print_cld_debug) write(stdout,'(A,I8,*(2x,F16.8))') 'PIXEL_DEBUG93: ', n, & - ca_mean(:,n) + 0.5 * ( cloud_mod(:,n) + cloud_obs(:,n) ) !JJGDEBUG - if ( crtm_cloud(it) ) then - if (use_rad_symm_err) then - ! symmetric error model - ! - Okamoto, McNally, & Bell (2013) - ! - Harnish, Weissmann, & Perianez (2016) - do k = 1, nchan - if ( ca_mean(k,n).gt.missing_r ) then - if ( ca_mean(k,n).lt.camin ) then - iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) - else if ( ca_mean(k,n) .lt. satinfo(isens)%error_cld_x(k) ) then - iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + & - ( satinfo(isens)%error_cld_y(k) - satinfo(isens)%error_std(k) ) * & - ( ca_mean(k,n) - camin ) / ( satinfo(isens)%error_cld_x(k) - camin ) - else - iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_cld_y(k) - end if + if (use_rad_symm_err) then + ! symmetric error model + ! - Okamoto, McNally, & Bell (2013) + ! - Harnish, Weissmann, & Perianez (2016) + + cloud_mean = 0.5 * ( cloud_mod(:,n) + cloud_obs(:,n) ) + + do k = 1, nchan + if ( cloud_mean(k).gt.missing_r ) then + if ( cloud_mean(k).lt.camin ) then + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + else if ( cloud_mean(k) .lt. satinfo(isens)%error_cld_x(k) ) then + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + & + ( satinfo(isens)%error_cld_y(k) - satinfo(isens)%error_std(k) ) * & + ( cloud_mean(k) - camin ) / ( satinfo(isens)%error_cld_x(k) - camin ) else - iv%instid(isens)%tb_error(k,n) = missing_r + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_cld_y(k) end if - end do ! nchan - else - iv%instid(isens)%tb_error(1:nchan,n) = satinfo(isens)%error_std(1:nchan) - end if + else + iv%instid(isens)%tb_error(k,n) = missing_r + end if + end do ! nchan + else + iv%instid(isens)%tb_error(1:nchan,n) = satinfo(isens)%error_std(1:nchan) end if end if diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index 89b1eb5946..1593de57be 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -150,9 +150,11 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) write(unit=innov_rad_unit,fmt='(a)') 'CLOUD : ' write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) - if ( abi .and. crtm_cloud(it) ) then ! write out ca_mean, tb_xb_clr - write(unit=innov_rad_unit,fmt='(a)') 'CA : ' - write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%ca_mean(:,n) + if ( abi .and. crtm_cloud(it) ) then ! write out cloud_mod, cloud_obs, tb_xb_clr + write(unit=innov_rad_unit,fmt='(a)') 'CMOD : ' + write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_mod(:,n) + write(unit=innov_rad_unit,fmt='(a)') 'COBS : ' + write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_obs(:,n) write(unit=innov_rad_unit,fmt='(a)') 'BGCLR: ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb_clr(:,n) end if diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index b2ece04a1d..67518886bb 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -139,9 +139,11 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) write(unit=oma_rad_unit,fmt='(a)') 'CLOUD : ' write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) - if ( abi .and. crtm_cloud(it) ) then ! write out ca_mean, tb_xb_clr - write(unit=oma_rad_unit,fmt='(a)') 'CA : ' - write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%ca_mean(:,n) + if ( abi .and. crtm_cloud(it) ) then ! write out cloud_mod, cloud_obs, tb_xb_clr + write(unit=oma_rad_unit,fmt='(a)') 'CMOD : ' + write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_mod(:,n) + write(unit=oma_rad_unit,fmt='(a)') 'COBS : ' + write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_obs(:,n) write(unit=oma_rad_unit,fmt='(a)') 'BGCLR: ' write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb_clr(:,n) end if From 490f40fd205c161e5a99d49579f4fa122ab1baf5 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Mon, 18 Nov 2019 16:29:21 -0700 Subject: [PATCH 53/86] Add super-obbing for ABI --- Registry/registry.var | 2 + var/da/da_radiance/da_radiance.f90 | 2 +- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 58 ++++++++++++-------- 3 files changed, 38 insertions(+), 24 deletions(-) diff --git a/Registry/registry.var b/Registry/registry.var index 1594f528dd..c25b5ad48c 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -442,6 +442,8 @@ rconfig integer varbc_nbgerr namelist,wrfvar14 1 5000 - "va rconfig integer varbc_nobsmin namelist,wrfvar14 1 10 - "varbc_nobsmin" "" "" rconfig integer use_clddet namelist,wrfvar14 1 2 - "use_clddet" "0: off, 1: mmr, 2: pf, 3: ecmwf" "" rconfig logical use_clddet_abi namelist,wrfvar14 1 .false. - "use_clddet_abi" "" "" +rconfig integer abi_superob_buffer namelist,wrfvar14 1 0 - "abi_superob_buffer" "" "" + rconfig logical use_rad_symm_err namelist,wrfvar14 1 .true. - "use_rad_symm_err" "" "" rconfig logical airs_warmest_fov namelist,wrfvar14 1 .false. - "airs_warmest_fov" "" "" rconfig logical use_satcv namelist,wrfvar14 2 .false. - "use_satcv" "" "" diff --git a/var/da/da_radiance/da_radiance.f90 b/var/da/da_radiance/da_radiance.f90 index 3316a7478e..3ab1ca864e 100644 --- a/var/da/da_radiance/da_radiance.f90 +++ b/var/da/da_radiance/da_radiance.f90 @@ -62,7 +62,7 @@ module da_radiance airs_warmest_fov, time_slots, interp_option, ids, ide, jds, jde, & ips, ipe, jps, jpe, simulated_rad_ngrid, obs_qc_pointer, use_blacklist_rad, use_satcv, & use_goesimgobs, use_goesabiobs, pi, earth_radius, satellite_height, & - var4d, var4d_bin, use_clddet_abi + var4d, var4d_bin, use_clddet_abi, abi_superob_buffer #ifdef CRTM use da_crtm, only : da_crtm_init, da_get_innov_vector_crtm diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 250c33b528..d300086a8e 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -203,7 +203,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !Cloud QC variables integer :: tbuf, nkeep, ikeep - integer :: cld_qc_buffer ! Must be ≥ 0 + integer :: neighbor_buffer ! Must be ≥ 0 real :: mu10, mu14, sigma10, sigma14, pearson, temp_max real :: mu, sigma real, allocatable :: tb_temp(:,:) @@ -312,9 +312,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) num_goesabi_thinned = 0 if ( use_clddet_abi ) then - cld_qc_buffer = 10 + neighbor_buffer = max(10,abi_superob_buffer) else - cld_qc_buffer = 0 + neighbor_buffer = max(0,abi_superob_buffer) end if tot_files_used = 0 @@ -1081,10 +1081,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! write(stdout,'(A,4I10)') 'ys_p_fd, ye_p_fd, xs_p_fd, xe_p_fd',this_view % ys_p_fd, this_view % ye_p_fd, this_view % xs_p_fd, this_view % xe_p_fd ! Setup ZZ clddet extents - this_view % ys_local = max(this_view % ys_p - cld_qc_buffer, 1) - this_view % ye_local = min(this_view % ye_p + cld_qc_buffer, ny_global) - this_view % xs_local = max(this_view % xs_p - cld_qc_buffer, 1) - this_view % xe_local = min(this_view % xe_p + cld_qc_buffer, nx_global) + this_view % ys_local = max(this_view % ys_p - neighbor_buffer, 1) + this_view % ye_local = min(this_view % ye_p + neighbor_buffer, ny_global) + this_view % xs_local = max(this_view % xs_p - neighbor_buffer, 1) + this_view % xe_local = min(this_view % xe_p + neighbor_buffer, nx_global) ! Setup patch mask for this view, including ZZ clddet buffer allocate( this_view % patchmask( & @@ -1097,8 +1097,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ix = this_view % ix_1d % patch (n) cldqc = .true. - do jy = iy - cld_qc_buffer, iy + cld_qc_buffer - do jx = ix - cld_qc_buffer, ix + cld_qc_buffer + do jy = iy - neighbor_buffer, iy + neighbor_buffer + do jx = ix - neighbor_buffer, ix + neighbor_buffer if ( & jy.ge.1 .and. jy.le.ny_global & .and. jx.ge.1 .and. jx.le.nx_global & @@ -1355,7 +1355,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) first_chan = (this_view % nfiles_used(ifgat).eq.1) - if ( use_clddet_abi .and. channel_list(ichan).eq.14 .and. cld_qc_buffer.ge.1) then + if ( use_clddet_abi .and. channel_list(ichan).eq.14 .and. neighbor_buffer.ge.1) then ! Allocate terrain_hgt using local indices for this view allocate( terrain_hgt ( & this_view % ys_local:this_view % ye_local, & @@ -1446,7 +1446,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) write(unit=info % date_char, & fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc - info % elv = 0.0 !aquaspot % selv + info % elv = 0.0 allocate ( p % tb_inv (1:nchan) ) p % tb_inv = missing_r @@ -1455,11 +1455,11 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) p % landsea_mask = 1 ! ??? if (use_view_mask) then - p % scanpos = & + p % scanpos = & ( iy + this_view % yoff_fd-1 - 1) * (nscan+1) / view_att(1) % ny_global ! ??? "scan" position (IS THIS CORRECT? NECESSARY? iFOV?) else - p % scanpos = & + p % scanpos = & ( iy + this_view % yoff_fd-1 - 1) * (nscan+1) / 5424 ! ??? "scan" position (IS THIS CORRECT? NECESSARY? iFOV?) end if @@ -1477,9 +1477,21 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) p % ifgat = ifgat end if - ! Exctract this BT value for each channel - p % tb_inv(ichan) = bt_p( iy, ix, 1 ) - + ! Super-ob the BT for this channel + tbuf = abi_superob_buffer + if (neighbor_buffer.ge.tbuf .and. tbuf.gt.0) then + nkeep = count ( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r ) + if (nkeep .gt. 0) then + allocate( tb_temp ( nkeep, 1 ) ) + tb_temp(:,1) = pack( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ), & + bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r) + p % tb_inv(ichan) = sum( tb_temp(:,1) ) / real(nkeep,r_double) + deallocate( tb_temp ) + end if + else + ! Extract single pixel BT value for this channel + p % tb_inv(ichan) = bt_p( iy, ix, 1 ) + end if ! Preprocessing for Cloud Mask (da_qc_goesabi.inc) including ! extracting Tb values from cloud QC buffer @@ -1489,7 +1501,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if tbuf = 1 - if (cld_qc_buffer.ge.tbuf .and. p % tb_inv(ichan).gt.missing_r) then + if (neighbor_buffer.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then nkeep = count ( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r ) if (nkeep .gt. 0) then @@ -1534,7 +1546,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if (temp_max .gt. missing_r) then ! Store RTCT - p % cld_qc % RTCT = temp_max - p % tb_inv(ichan) - & + p % cld_qc % RTCT = temp_max - bt_p( iy, ix, 1 ) - & 3.0_r_double * 0.007_r_double * sigma else p % cld_qc % RTCT = missing_r @@ -1559,7 +1571,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Values for RFMFT cloud QC ! - channels 14 and 15 tbuf = 10 - if (cld_qc_buffer.ge.tbuf .and. p % tb_inv(ichan).gt.missing_r) then + if (neighbor_buffer.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then if (channel_list(ichan).eq.14) then !Determine Neighboring Warm Center (NWC) for this pixel temp_max = 0. @@ -1575,13 +1587,13 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end do end do p % cld_qc % RFMFT = & - p % tb_inv(ichan) - temp_max + bt_p( iy, ix, 1 ) - temp_max end if if (channel_list(ichan).eq.15 .and. all(p % cld_qc % RFMFT_ij.gt.0)) then temp_max = bt_p ( p % cld_qc % RFMFT_ij(1), & p % cld_qc % RFMFT_ij(2), 1 ) p % cld_qc % RFMFT = abs( p % cld_qc % RFMFT + & - temp_max - p % tb_inv(ichan) ) + temp_max - bt_p( iy, ix, 1 ) ) end if else if ( any( channel_list(ichan).eq.(/14,15/) ) ) then @@ -1593,7 +1605,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Values for CIRH2O cloud QC ! - channels 10 and 14 for Pearson correlation coefficient of CIRH2O test tbuf = 2 - if (cld_qc_buffer.ge.tbuf .and. p % tb_inv(ichan).gt.missing_r) then + if (neighbor_buffer.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then if (channel_list(ichan).eq.10) then allocate( p % cld_qc % CIRH2O ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 2 ) ) p % cld_qc % CIRH2O(:,:,1) = bt_p( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) @@ -1643,7 +1655,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if ( use_clddet_abi .and. (channel_list(ichan).eq.14) ) then p % cld_qc % TEMPIR = missing_r if ( TEMPIR_ifile.gt.0 .and. & - p % tb_inv(ichan).gt.missing_r ) then + bt_p( iy, ix, 1 ).gt.missing_r ) then if ( bt_p( iy, ix, 2 ).lt.330. ) & p % cld_qc % TEMPIR = bt_p( iy, ix, 2 ) - bt_p( iy, ix, 1 ) end if From 19fdc37df3b99e3569b2589199ba75f0bfa5e88f Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Thu, 9 Jan 2020 14:31:06 -0700 Subject: [PATCH 54/86] Re-add some log prints, reduce count when abi_superob_halfwidth > 0 --- Registry/registry.var | 3 +- var/da/da_radiance/da_radiance.f90 | 2 +- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 70 +++++++++++--------- 3 files changed, 40 insertions(+), 35 deletions(-) diff --git a/Registry/registry.var b/Registry/registry.var index c25b5ad48c..a6a91a06e7 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -442,8 +442,7 @@ rconfig integer varbc_nbgerr namelist,wrfvar14 1 5000 - "va rconfig integer varbc_nobsmin namelist,wrfvar14 1 10 - "varbc_nobsmin" "" "" rconfig integer use_clddet namelist,wrfvar14 1 2 - "use_clddet" "0: off, 1: mmr, 2: pf, 3: ecmwf" "" rconfig logical use_clddet_abi namelist,wrfvar14 1 .false. - "use_clddet_abi" "" "" -rconfig integer abi_superob_buffer namelist,wrfvar14 1 0 - "abi_superob_buffer" "" "" - +rconfig integer abi_superob_halfwidth namelist,wrfvar14 1 0 - "abi_superob_halfwidth" "" "" rconfig logical use_rad_symm_err namelist,wrfvar14 1 .true. - "use_rad_symm_err" "" "" rconfig logical airs_warmest_fov namelist,wrfvar14 1 .false. - "airs_warmest_fov" "" "" rconfig logical use_satcv namelist,wrfvar14 2 .false. - "use_satcv" "" "" diff --git a/var/da/da_radiance/da_radiance.f90 b/var/da/da_radiance/da_radiance.f90 index 3ab1ca864e..853ab6e42f 100644 --- a/var/da/da_radiance/da_radiance.f90 +++ b/var/da/da_radiance/da_radiance.f90 @@ -62,7 +62,7 @@ module da_radiance airs_warmest_fov, time_slots, interp_option, ids, ide, jds, jde, & ips, ipe, jps, jpe, simulated_rad_ngrid, obs_qc_pointer, use_blacklist_rad, use_satcv, & use_goesimgobs, use_goesabiobs, pi, earth_radius, satellite_height, & - var4d, var4d_bin, use_clddet_abi, abi_superob_buffer + var4d, var4d_bin, use_clddet_abi, abi_superob_halfwidth #ifdef CRTM use da_crtm, only : da_crtm_init, da_get_innov_vector_crtm diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index d300086a8e..decce4ae3d 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -203,7 +203,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !Cloud QC variables integer :: tbuf, nkeep, ikeep - integer :: neighbor_buffer ! Must be ≥ 0 + integer :: abi_halo_width ! Must be ≥ 0 real :: mu10, mu14, sigma10, sigma14, pearson, temp_max real :: mu, sigma real, allocatable :: tb_temp(:,:) @@ -312,9 +312,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) num_goesabi_thinned = 0 if ( use_clddet_abi ) then - neighbor_buffer = max(10,abi_superob_buffer) + abi_halo_width = max(10,abi_superob_halfwidth) else - neighbor_buffer = max(0,abi_superob_buffer) + abi_halo_width = max(0,abi_superob_halfwidth) end if tot_files_used = 0 @@ -618,8 +618,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Only ny_global and nx_global need to be read for all views, but this is a cheap subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! write(unit=stdout,fmt='(A)') & -! ' Reading abi metadata...' + write(unit=stdout,fmt='(A)') & + ' Reading abi metadata...' this_view % meta_initialized = .true. @@ -658,8 +658,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) DoGridGen: if ( this_view % moving .or. .not.this_view % grid_initialized ) then ! Read grid from file, convert to lat, lon, satzen, satazi -! write(unit=stdout,fmt='(2A)') & -! ' Establishing abi grid info...' + write(unit=stdout,fmt='(2A)') & + ' Establishing abi grid info...' this_view % grid_initialized = .true. @@ -710,18 +710,24 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) do ixl = 1, nx_local do iyl = 1, ny_local - !This mod test produces balanced loads between processors - if ( mod( n, num_procs ) .eq. myproc ) then - icount = icount + 1 - - iy = iyl + this_view % ys_local - 1 - ix = ixl + this_view % xs_local - 1 - yy_1d ( icount ) = yy_abi( iy ) - xx_1d ( icount ) = xx_abi( ix ) - iy_1d ( icount ) = iy - ix_1d ( icount ) = ix + iy = iyl + this_view % ys_local - 1 + ix = ixl + this_view % xs_local - 1 + if ( mod( iy-abi_superob_halfwidth-1, 2*abi_superob_halfwidth+1 ) == 0 .and. & + mod( ix-abi_superob_halfwidth-1, 2*abi_superob_halfwidth+1 ) == 0 ) then +! if ( abi_superob_halfwidth == 0 .or. & +! ( mod( iy-abi_superob_halfwidth-1, 2*abi_superob_halfwidth+1 ) == 0 .and. & +! mod( ix-abi_superob_halfwidth-1, 2*abi_superob_halfwidth+1 ) == 0 ) ) then + !This mod test produces balanced loads between processors + if ( mod( n, num_procs ) .eq. myproc ) then + icount = icount + 1 + + yy_1d ( icount ) = yy_abi( iy ) + xx_1d ( icount ) = xx_abi( ix ) + iy_1d ( icount ) = iy + ix_1d ( icount ) = ix + end if + n = n + 1 end if - n = n + 1 end do end do end do @@ -760,8 +766,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) deallocate( iy_1d ) deallocate( ix_1d ) -! write(unit=stdout,fmt='(3A,I0)') & -! ' ',trim(this_view % name),' locations processed on this core: ', nrad_local + write(unit=stdout,fmt='(3A,I0)') & + ' ',trim(this_view % name),' locations processed on this core: ', nrad_local if (nrad_local .gt. 0) & call get_abil1b_grid2_1d( yy_1d(1:nrad_local), xx_1d(1:nrad_local), & @@ -1081,10 +1087,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! write(stdout,'(A,4I10)') 'ys_p_fd, ye_p_fd, xs_p_fd, xe_p_fd',this_view % ys_p_fd, this_view % ye_p_fd, this_view % xs_p_fd, this_view % xe_p_fd ! Setup ZZ clddet extents - this_view % ys_local = max(this_view % ys_p - neighbor_buffer, 1) - this_view % ye_local = min(this_view % ye_p + neighbor_buffer, ny_global) - this_view % xs_local = max(this_view % xs_p - neighbor_buffer, 1) - this_view % xe_local = min(this_view % xe_p + neighbor_buffer, nx_global) + this_view % ys_local = max(this_view % ys_p - abi_halo_width, 1) + this_view % ye_local = min(this_view % ye_p + abi_halo_width, ny_global) + this_view % xs_local = max(this_view % xs_p - abi_halo_width, 1) + this_view % xe_local = min(this_view % xe_p + abi_halo_width, nx_global) ! Setup patch mask for this view, including ZZ clddet buffer allocate( this_view % patchmask( & @@ -1097,8 +1103,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ix = this_view % ix_1d % patch (n) cldqc = .true. - do jy = iy - neighbor_buffer, iy + neighbor_buffer - do jx = ix - neighbor_buffer, ix + neighbor_buffer + do jy = iy - abi_halo_width, iy + abi_halo_width + do jx = ix - abi_halo_width, ix + abi_halo_width if ( & jy.ge.1 .and. jy.le.ny_global & .and. jx.ge.1 .and. jx.le.nx_global & @@ -1355,7 +1361,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) first_chan = (this_view % nfiles_used(ifgat).eq.1) - if ( use_clddet_abi .and. channel_list(ichan).eq.14 .and. neighbor_buffer.ge.1) then + if ( use_clddet_abi .and. channel_list(ichan).eq.14 .and. abi_halo_width.ge.1) then ! Allocate terrain_hgt using local indices for this view allocate( terrain_hgt ( & this_view % ys_local:this_view % ye_local, & @@ -1478,8 +1484,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if ! Super-ob the BT for this channel - tbuf = abi_superob_buffer - if (neighbor_buffer.ge.tbuf .and. tbuf.gt.0) then + tbuf = abi_superob_halfwidth + if (abi_halo_width.ge.tbuf .and. tbuf.gt.0) then nkeep = count ( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r ) if (nkeep .gt. 0) then allocate( tb_temp ( nkeep, 1 ) ) @@ -1501,7 +1507,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if tbuf = 1 - if (neighbor_buffer.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then + if (abi_halo_width.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then nkeep = count ( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r ) if (nkeep .gt. 0) then @@ -1571,7 +1577,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Values for RFMFT cloud QC ! - channels 14 and 15 tbuf = 10 - if (neighbor_buffer.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then + if (abi_halo_width.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then if (channel_list(ichan).eq.14) then !Determine Neighboring Warm Center (NWC) for this pixel temp_max = 0. @@ -1605,7 +1611,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Values for CIRH2O cloud QC ! - channels 10 and 14 for Pearson correlation coefficient of CIRH2O test tbuf = 2 - if (neighbor_buffer.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then + if (abi_halo_width.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then if (channel_list(ichan).eq.10) then allocate( p % cld_qc % CIRH2O ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 2 ) ) p % cld_qc % CIRH2O(:,:,1) = bt_p( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) From 45f1e944b683efb102fcf31bb200748ae0c8efaf Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Fri, 10 Jan 2020 13:11:37 -0700 Subject: [PATCH 55/86] Fully implemented super-obbing and refactoring of cloud detection added cloud_fraction diagnostic --- .../da_define_structures.f90 | 12 +- var/da/da_monitor/da_rad_diags.f90 | 37 +- var/da/da_radiance/da_allocate_rad_iv.inc | 20 +- var/da/da_radiance/da_deallocate_radiance.inc | 25 +- var/da/da_radiance/da_initialize_rad_iv.inc | 41 +- var/da/da_radiance/da_qc_goesabi.inc | 275 +++++--- var/da/da_radiance/da_radiance1.f90 | 8 +- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 667 ++++++++++-------- var/da/da_radiance/da_write_iv_rad_ascii.inc | 9 +- var/da/da_radiance/da_write_oa_rad_ascii.inc | 7 +- 10 files changed, 645 insertions(+), 456 deletions(-) diff --git a/var/da/da_define_structures/da_define_structures.f90 b/var/da/da_define_structures/da_define_structures.f90 index e4faee76fa..75b5da6e45 100644 --- a/var/da/da_define_structures/da_define_structures.f90 +++ b/var/da/da_define_structures/da_define_structures.f90 @@ -491,11 +491,17 @@ module da_define_structures end type cv_index_type type cld_qc_type - real :: RTCT, RFMFT, RFMFT_ij(2), TEMPIR, terr_hgt + real :: RTCT, RFMFT, TEMPIR, terr_hgt + integer :: RFMFT_ij(2) real, allocatable :: tb_stddev_3x3(:) real, allocatable :: CIRH2O(:,:,:) end type cld_qc_type + type superob_type + real, allocatable :: tb_obs(:,:) + type(cld_qc_type), allocatable :: cld_qc(:) + end type superob_type + type instid_type ! Instrument triplet, follow the convension of RTTOV integer :: platform_id, satellite_id, sensor_id @@ -525,6 +531,7 @@ module da_define_structures integer, pointer :: rain_flag(:) real, pointer :: cloud_mod(:,:) real, pointer :: cloud_obs(:,:) + real, allocatable :: cloud_frac(:) real, pointer :: satzen(:) real, pointer :: satazi(:) real, pointer :: solzen(:) @@ -605,7 +612,8 @@ module da_define_structures real, pointer :: ice_coverage(:) real, pointer :: snow_coverage(:) integer, pointer :: crtm_climat(:) ! CRTM only - type (cld_qc_type), pointer :: cld_qc(:) + integer :: superob_width = 1 + type (superob_type), allocatable :: superob(:,:) type (varbc_info_type) :: varbc_info type (varbc_type),pointer :: varbc(:) diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index 6a531bf343..26239996f1 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -59,8 +59,8 @@ program da_rad_diags real*4, dimension(:), allocatable :: lat, lon, elv, elev real*4, dimension(:), allocatable :: ret_clw real*4, dimension(:), allocatable :: satzen, satazi, t2m, mr2m, u10, v10, ps, ts - real*4, dimension(:), allocatable :: smois, tslb, snowh, vegfra, clwp - integer, dimension(:,:), allocatable :: tb_qc, tb_cloud + real*4, dimension(:), allocatable :: smois, tslb, snowh, vegfra, clwp, cloud_frac + integer, dimension(:,:), allocatable :: tb_qc, cloud_flag real*4, dimension(:,:), allocatable :: tb_obs, tb_bak, tb_inv, tb_oma, tb_err, ems, ems_jac real*4, dimension(:,:), allocatable :: cloud_mod, cloud_obs, tb_bak_clr real*4, dimension(:,:), allocatable :: prf_pfull, prf_phalf, prf_t, prf_q, prf_water @@ -248,14 +248,15 @@ program da_rad_diags allocate ( vegfra(1:total_npixel) ) allocate ( elev(1:total_npixel) ) allocate ( clwp(1:total_npixel) ) !model/guess clwp + allocate ( cloud_frac(1:total_npixel) ) allocate ( tb_obs(1:nchan,1:total_npixel) ) allocate ( tb_bak(1:nchan,1:total_npixel) ) allocate ( tb_inv(1:nchan,1:total_npixel) ) allocate ( tb_oma(1:nchan,1:total_npixel) ) allocate ( tb_err(1:nchan,1:total_npixel) ) allocate ( tb_qc(1:nchan,1:total_npixel) ) - allocate ( tb_cloud(1:nchan,1:total_npixel) ) - tb_cloud = 0 + allocate ( cloud_flag(1:nchan,1:total_npixel) ) + cloud_flag = 0 if ( abi ) then allocate ( cloud_mod(1:nchan,1:total_npixel) ) allocate ( cloud_obs(1:nchan,1:total_npixel) ) @@ -359,11 +360,10 @@ program da_rad_diags read(unit=iunit(iproc),fmt='(7x,i7,2x,a19,i6,i3,f6.0,4f8.2,f8.3)',iostat=ios) & n, datestr2(ipixel), scanpos(ipixel), landsea_mask(ipixel), elv(ipixel), & lat(ipixel), lon(ipixel), satzen(ipixel), satazi(ipixel), ret_clw(ipixel) - - read(unit=iunit(iproc),fmt='(14x,9f10.2,3i3,3f10.2)',iostat=ios) & + read(unit=iunit(iproc),fmt='(14x,9f10.2,3i3,f8.3,f10.2,f8.3,f15.5)',iostat=ios) & t2m(ipixel), mr2m(ipixel), u10(ipixel), v10(ipixel), ps(ipixel), ts(ipixel), & smois(ipixel), tslb(ipixel), snowh(ipixel), isflg(ipixel), soiltyp(ipixel), & - vegtyp(ipixel), vegfra(ipixel), elev(ipixel), clwp(ipixel) + vegtyp(ipixel), vegfra(ipixel), elev(ipixel), clwp(ipixel), cloud_frac(ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! OBS read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_obs(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! BAK @@ -384,11 +384,9 @@ program da_rad_diags read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_err(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! QC read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_qc(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CLOUD, CA, INFO, or level - if ( buf(1:5) == "CLOUD" ) then ! read cloud detection info - read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_cloud(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CMOD, INFO, or level - end if + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CLOUD + read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) cloud_flag(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CMOD, INFO, or level if ( abi .and. buf(1:4) == "CMOD" ) then ! read cloud_mod, cloud_obs, tb_bak_clr for abi read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) cloud_mod(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! COBS @@ -523,7 +521,7 @@ program da_rad_diags end if ios = NF_DEF_VAR(ncid, 'tb_err', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_DEF_VAR(ncid, 'tb_qc', NF_INT, 2, ishape(1:2), varid) - ios = NF_DEF_VAR(ncid, 'tb_cloud', NF_INT, 2, ishape(1:2), varid) + ios = NF_DEF_VAR(ncid, 'cloud_flag', NF_INT, 2, ishape(1:2), varid) if ( abi ) then ios = NF_DEF_VAR(ncid, 'cloud_mod', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) @@ -634,6 +632,9 @@ program da_rad_diags if ( amsr2 ) then ios = NF_DEF_VAR(ncid, 'ret_clw', NF_FLOAT, 1, ishape(1), varid) end if + ios = NF_DEF_VAR(ncid, 'cloud_frac', NF_FLOAT, 1, ishape(1), varid) + ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) + ios = NF_ENDDEF(ncid) ! @@ -669,8 +670,8 @@ program da_rad_diags ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_err) ios = NF_INQ_VARID (ncid, 'tb_qc', varid) ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), tb_qc) - ios = NF_INQ_VARID (ncid, 'tb_cloud', varid) - ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), tb_cloud) + ios = NF_INQ_VARID (ncid, 'cloud_flag', varid) + ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), cloud_flag) if ( abi ) then ios = NF_INQ_VARID (ncid, 'cloud_mod', varid) ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), cloud_mod) @@ -848,6 +849,9 @@ program da_rad_diags ios = NF_INQ_VARID (ncid, 'ret_clw', varid) ios = NF_PUT_VARA_REAL(ncid, varid, istart(2), icount(2), ret_clw) end if + ios = NF_INQ_VARID (ncid, 'cloud_frac', varid) + ios = NF_PUT_VARA_REAL(ncid, varid, istart(2), icount(2), cloud_frac) + ! ios = NF_CLOSE(ncid) @@ -879,6 +883,7 @@ program da_rad_diags deallocate ( vegfra ) deallocate ( elev ) deallocate ( clwp ) + deallocate ( cloud_frac ) deallocate ( ret_clw ) deallocate ( tb_obs ) deallocate ( tb_bak ) @@ -893,7 +898,7 @@ program da_rad_diags if ( jac_found ) deallocate ( ems_jac ) deallocate ( tb_err ) deallocate ( tb_qc ) - deallocate ( tb_cloud ) + deallocate ( cloud_flag ) if ( prf_found .and. (rtm_option == 'CRTM') ) then deallocate ( prf_pfull ) deallocate ( prf_phalf ) diff --git a/var/da/da_radiance/da_allocate_rad_iv.inc b/var/da/da_radiance/da_allocate_rad_iv.inc index b63b71a9ea..00f1cb6b1c 100644 --- a/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/var/da/da_radiance/da_allocate_rad_iv.inc @@ -11,7 +11,7 @@ subroutine da_allocate_rad_iv (i, nchan, iv) integer , intent (in) :: i, nchan type (iv_type) , intent (inout) :: iv - integer :: n + integer :: n, ix, iy call da_trace_entry("da_allocate_rad_iv") @@ -111,11 +111,21 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate (iv%instid(i)%solzen(iv%instid(i)%num_rad)) allocate (iv%instid(i)%solazi(iv%instid(i)%num_rad)) allocate (iv%instid(i)%tropt(iv%instid(i)%num_rad)) + allocate (iv%instid(i)%cloud_frac(iv%instid(i)%num_rad)) allocate (iv%instid(i)%gamma_jacobian(nchan,iv%instid(i)%num_rad)) - if ( use_clddet_abi ) then - allocate (iv%instid(i)%cld_qc(iv%instid(i)%num_rad)) - do n = 1, iv%instid(i)%num_rad - allocate (iv%instid(i)%cld_qc(n)%tb_stddev_3x3(nchan)) + if ( use_clddet_abi .and. & + index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + iv%instid(i)%superob_width = 2*abi_superob_halfwidth+1 + allocate (iv%instid(i)%superob(iv%instid(i)%superob_width, & + iv%instid(i)%superob_width)) + do iy = 1, iv%instid(i)%superob_width + do ix = 1, iv%instid(i)%superob_width + allocate (iv%instid(i)%superob(ix,iy)%cld_qc(iv%instid(i)%num_rad)) + allocate (iv%instid(i)%superob(ix,iy)%tb_obs(nchan,iv%instid(i)%num_rad)) + do n = 1, iv%instid(i)%num_rad + allocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3(nchan)) + end do + end do end do end if if ( use_rttov_kmatrix .or. use_crtm_kmatrix ) then diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index 3ac8a809a2..7606a09d2c 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -11,7 +11,7 @@ type (iv_type), intent(inout) :: iv ! Obs. increment structure. type (j_type), intent(inout) :: j ! Cost function. - integer :: i,n,ichan + integer :: i,n,ichan,ix,iy if (trace_use) call da_trace_entry("da_deallocate_radiance") @@ -133,17 +133,24 @@ deallocate (iv%instid(i)%solzen) deallocate (iv%instid(i)%solazi) deallocate (iv%instid(i)%tropt) - if ( use_clddet_abi ) then - do n = 1,iv%instid(i)%num_rad - if ( allocated (iv%instid(i)%cld_qc(n)%tb_stddev_3x3) ) & - deallocate (iv%instid(i)%cld_qc(n)%tb_stddev_3x3) - if ( allocated (iv%instid(i)%cld_qc(n)%CIRH2O) ) & - deallocate (iv%instid(i)%cld_qc(n)%CIRH2O) + deallocate(iv%instid(i)%cloud_frac) + if ( use_clddet_abi .and. & + index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + do iy = 1, iv%instid(i)%superob_width + do ix = 1, iv%instid(i)%superob_width + do n = 1,iv%instid(i)%num_rad + if ( allocated (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3) ) & + deallocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3) + if ( allocated (iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O) ) & + deallocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O) + end do + deallocate (iv%instid(i)%superob(ix,iy)%cld_qc) + deallocate (iv%instid(i)%superob(ix,iy)%tb_obs) end do - deallocate (iv%instid(i)%cld_qc) + end do + deallocate (iv%instid(i)%superob) deallocate (iv%instid(i)%gamma_jacobian) end if - if (ANY(use_satcv)) then if (use_satcv(2)) then do n = 1,iv%instid(i)%num_rad diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index 707c211f80..5e371d3ea5 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -11,6 +11,7 @@ subroutine da_initialize_rad_iv (i, n, iv, p) integer, intent(in) :: i, n type(datalink_type), intent(in) :: p type(iv_type), intent(inout) :: iv + integer :: ix, iy call da_trace_entry("da_initialize_rad_iv") @@ -87,7 +88,11 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%tb_sens(:,n) = 0.0 iv%instid(i)%tb_imp(:,n) = 0.0 iv%instid(i)%rad_xb(:,n) = 0.0 - iv%instid(i)%rad_obs(:,n) = 0.0 + if ( associated( p % rad_obs ) ) then + iv%instid(i)%rad_obs(:,n) = p%rad_obs(:) + else + iv%instid(i)%rad_obs(:,n) = 0.0 + end if iv%instid(i)%rad_ovc(:,:,n) = 0.0 iv%instid(i)%emiss(:,n) = 0.0 iv%instid(i)%scanpos(n) = p%scanpos @@ -102,19 +107,27 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%solazi(n) = p%solazi ! iv%instid(i)%solazi(n) = 0.0 iv%instid(i)%tropt(n) = 0.0 - if ( use_clddet_abi ) then - if ( associated ( p % cld_qc ) ) then - iv%instid(i)%cld_qc(n)%RTCT = p % cld_qc % RTCT - iv%instid(i)%cld_qc(n)%RFMFT = p % cld_qc % RFMFT - iv%instid(i)%cld_qc(n)%TEMPIR = p % cld_qc % TEMPIR - if ( allocated ( p % cld_qc % tb_stddev_3x3 ) ) & - iv%instid(i)%cld_qc(n)%tb_stddev_3x3(:) = p % cld_qc % tb_stddev_3x3(:) - iv%instid(i)%cld_qc(n)%terr_hgt = p % cld_qc % terr_hgt - if ( allocated ( p % cld_qc % CIRH2O ) .and. & - size(p % cld_qc % CIRH2O).eq.1) then - allocate ( iv%instid(i)%cld_qc(n)%CIRH2O(1,1,1) ) - iv%instid(i)%cld_qc(n)%CIRH2O = p % cld_qc % CIRH2O - end if + iv%instid(i)%cloud_frac(n) = missing_r + if ( use_clddet_abi .and. & + index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + if ( allocated ( p % superob ) ) then + do iy = 1, iv%instid(i)%superob_width + do ix = 1, iv%instid(i)%superob_width + iv%instid(i)%superob(ix,iy)%tb_obs(:,n) = p % superob(ix,iy) % tb_obs(:,1) + + iv%instid(i)%superob(ix,iy)%cld_qc(n)%RTCT = p % superob(ix,iy) % cld_qc(1) % RTCT + iv%instid(i)%superob(ix,iy)%cld_qc(n)%RFMFT = p % superob(ix,iy) % cld_qc(1) % RFMFT + iv%instid(i)%superob(ix,iy)%cld_qc(n)%TEMPIR = p % superob(ix,iy) % cld_qc(1) % TEMPIR + if ( allocated ( p % superob(ix,iy) % cld_qc(1) % tb_stddev_3x3 ) ) & + iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3(:) = p % superob(ix,iy) % cld_qc(1) % tb_stddev_3x3(:) + iv%instid(i)%superob(ix,iy)%cld_qc(n)%terr_hgt = p % superob(ix,iy) % cld_qc(1) % terr_hgt + if ( allocated ( p % superob(ix,iy) % cld_qc(1) % CIRH2O ) .and. & + size(p % superob(ix,iy) % cld_qc(1) % CIRH2O).eq.1) then + allocate ( iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O(1,1,1) ) + iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O = p % superob(ix,iy) % cld_qc(1) % CIRH2O + end if + end do + end do end if end if diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index f681b88d93..40ec289ebf 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -51,7 +51,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) real :: crit_clddet real :: rad_O14, rad_M14, rad_tropt real :: rad_o_ch7, rad_b_ch7, rad_o_ch14, rad_b_ch14 - real :: Relaz, Glintzen, tb_temp1 + real :: Relaz, Glintzen real :: wave_num(10) real :: plbc1(10), plbc2(10) real :: plfk1(10), plfk2(10) @@ -63,10 +63,15 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) logical :: qual_clddet(num_clddet_cats) character(len=10) :: crit_names_clddet(num_clddet_tests) integer :: nrej_clddet(nchan,num_clddet_tests) - integer*2 :: clddet_tests(num_clddet_tests) + integer :: superob_center + integer*2 :: clddet_tests(iv%instid(isens)%superob_width, & + iv%instid(isens)%superob_width, & + num_clddet_tests) + integer :: isuper, jsuper - real, pointer :: tb_ob(:,:), tb_xb(:,:), tb_inv(:,:), tb_xb_clr(:,:), cloud_obs(:,:), cloud_mod(:,:) - integer :: tb_qc(nchan), tb_qc_clddet(nchan) + real, pointer :: tb_obs(:,:), tb_xb(:,:), tb_inv(:,:), tb_xb_clr(:,:), & + cloud_obs(:,:), cloud_mod(:,:) + integer :: tb_qc(nchan) real :: big_num @@ -84,7 +89,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) if (trace_use) call da_trace_entry("da_qc_goesabi") -!! if (iv%instid(isens)%num_rad .le. 0) return +!! if (iv%instid(isens)%num_rad <= 0) return ! These values can change as SRF (spectral response function) is updated ! It is recommended to acquire these from L1B files, not copy them from GOES R PUG L1b Vol. 3 @@ -142,7 +147,6 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) nrej_clddet = 0 - tb_ob => ob%instid(isens)%tb tb_xb => iv%instid(isens)%tb_xb tb_inv => iv%instid(isens)%tb_inv @@ -178,9 +182,14 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) cloud_mod => iv%instid(isens)%cloud_mod cloud_mod = missing_r + else + tb_xb_clr => iv%instid(isens)%tb_xb end if - PixelQCLoop: do n= iv%instid(isens)%info%n1,iv%instid(isens)%info%n2 + superob_center = abi_superob_halfwidth + 1 + + ABIPixelQCLoop: do n= iv%instid(isens)%info%n1,iv%instid(isens)%info%n2 + tb_obs => ob%instid(isens)%tb if (iv%instid(isens)%info%proc_domain(1,n)) & num_proc_domain = num_proc_domain + 1 @@ -188,7 +197,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! 0.0 initialise QC by flags assuming good obs !----------------------------------------------------------------- tb_qc = qc_good - iv%instid(isens)%cloud_flag(:,n) = qc_good + iv%instid(isens)%cloud_flag(:,n) = 0 ! 1.0 reject all channels over mixed surface type !------------------------------------------------------ @@ -229,13 +238,13 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) cloud_detection=.false. if (cloud_detection) then if (iv%instid(isens)%landsea_mask(n) == 0 ) then - if ( ( tb_xb(3,n) - tb_ob(3,n) ) > 3.5) then + if ( ( tb_xb(3,n) - tb_obs(3,n) ) > 3.5) then tb_qc = qc_bad if (iv%instid(isens)%info%proc_domain(1,n)) & nrej_eccloud(:) = nrej_eccloud(:) + 1 end if else - if ( ( tb_xb(3,n) - tb_ob(3,n) ) > 2.5) then + if ( ( tb_xb(3,n) - tb_obs(3,n) ) > 2.5) then tb_qc = qc_bad if (iv%instid(isens)%info%proc_domain(1,n)) & nrej_eccloud(:) = nrej_eccloud(:) + 1 @@ -244,11 +253,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) end if end if - abi_clddet: if ( use_clddet_abi & - .and. all(tb_inv( (/ch7,ch14,ch15/), n ) .gt. missing_r) & - .and. all(tb_ob( (/ch7,ch14,ch15/), n ) .gt. missing_r) & - .and. all(tb_xb( (/ch7,ch14,ch15/), n ) .gt. missing_r) & - ) then + abi_clddet: if ( use_clddet_abi ) then !!=============================================================================== !!=============================================================================== @@ -265,9 +270,9 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG1: ', n, & tb_inv(:,n) if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG2: ', n, & - tb_xb(:,n) + tb_xb_clr(:,n) if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG3: ', n, & - tb_ob(:,n) + tb_obs(:,n) if (crtm_cloud(it) ) then if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG4: ', n, & tb_xb_clr(:,n) @@ -277,51 +282,64 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) iv%instid(isens)%info%lat(1,n), iv%instid(isens)%info%lon(1,n), & iv%instid(isens)%satzen(n), iv%instid(isens)%satazi(n), & iv%instid(isens)%solzen(n), iv%instid(isens)%solazi(n), & - iv%instid(isens)%tropt(n), iv%instid(isens)%cld_qc(n)%terr_hgt, & + iv%instid(isens)%tropt(n), iv%instid(isens)%superob(superob_center,superob_center)%cld_qc(n)%terr_hgt, & iv%instid(isens)%info%date_char(n) !JJGDEBUG - clddet_tests = 0 - if ( tb_xb(ch14,n) .gt. 0. .and. iv%instid(isens)%tropt(n) .gt. 0. ) then - tb_temp1 = tb_ob(ch14,n) - rad_O14 = plfk1(ch14) / & - ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_temp1 ) ) -1 ) - tb_temp1 = tb_xb(ch14,n) - rad_M14 = plfk1(ch14) / & - ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_temp1) ) -1 ) - tb_temp1 = iv%instid(isens)%tropt(n) - rad_tropt = plfk1(ch14) / & - ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_temp1) ) -1 ) + ! Assume tb_xb_clr (central pixel) is applicable to all super-obbed pixels + if (tb_xb_clr(ch7,n) > 0.) then + rad_b_ch7 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_xb_clr(ch7,n) ) ) - 1.0 ) else - rad_O14 = missing_r - rad_M14 = missing_r - rad_tropt = missing_r + rad_b_ch7 = missing_r end if - if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) then - tb_temp1 = tb_ob(ch7,n) - rad_o_ch7 = plfk1(ch7) / & - ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) - tb_temp1 = tb_xb(ch7,n) - rad_b_ch7 = plfk1(ch7) / & - ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) - tb_temp1 = tb_ob(ch14,n) - rad_o_ch14 = plfk1(ch7) / & - ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) - tb_temp1 = tb_xb(ch14,n) - rad_b_ch14 = plfk1(ch7) / & - ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_temp1 ) ) - 1. ) + if (tb_xb_clr(ch14,n) > 0.) then + rad_b_ch14 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_xb_clr(ch14,n) ) ) - 1.0 ) else - rad_o_ch7 = missing_r - rad_b_ch7 = missing_r - rad_o_ch14 = missing_r rad_b_ch14 = missing_r end if - tb_qc_clddet = tb_qc + if ( tb_xb_clr(ch14,n) > 0. ) then + rad_M14 = plfk1(ch14) / & + ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_xb_clr(ch14,n)) ) - 1.0 ) + else + rad_M14 = missing_r + end if + if ( iv%instid(isens)%tropt(n) > 0. ) then + rad_tropt = plfk1(ch14) / & + ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * iv%instid(isens)%tropt(n)) ) - 1.0 ) + else + rad_tropt = missing_r + end if + + clddet_tests = 0 + do jsuper = 1, iv%instid(isens)%superob_width + do isuper = 1, iv%instid(isens)%superob_width + ! Use tb_obs for this particular super-ob pixel + + tb_obs => iv%instid(isens)%superob(isuper,jsuper)%tb_obs + + if (tb_obs(ch7,n) > 0.) then + rad_o_ch7 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_obs(ch7,n) ) ) - 1.0 ) + else + rad_o_ch7 = missing_r + end if + if (tb_obs(ch14,n) > 0.) then + rad_o_ch14 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_obs(ch14,n) ) ) - 1.0 ) + rad_O14 = plfk1(ch14) / & + ( exp( plfk2(ch14) / ( plbc1(ch14) + plbc2(ch14) * tb_obs(ch14,n) ) ) - 1.0 ) + else + rad_o_ch14 = missing_r + rad_O14 = missing_r + end if + - do itest = 1, num_clddet_tests + ABICloudTestLoop: do itest = 1, num_clddet_tests qual_clddet = .true. offset_clddet = 0 crit_clddet = missing_r @@ -331,7 +349,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) !-------------------------------------------------------------------------- ! 4.1 Relative Thermal Contrast Test (RTCT) !-------------------------------------------------------------------------- - crit_clddet = iv%instid(isens)%cld_qc(n)%RTCT + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%RTCT qual_clddet(3:4) = .false. case (2) @@ -339,7 +357,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! 4.2 Cloud check: step 1 ! Emissivity at Tropopause Test (ETROP) !-------------------------------------------------------------------------- - if ( tb_xb(ch14,n) .gt. 0. .and. iv%instid(isens)%tropt(n) .gt. 0. ) & + if ( all((/rad_O14,rad_M14,rad_tropt/) > 0.0) ) & crit_clddet = (rad_O14 - rad_M14) / (rad_tropt - rad_M14) case (3) @@ -348,48 +366,54 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! Positive Fourteen Minus Fifteen Test (PFMFT) !-------------------------------------------------------------------------- ! See ABI Cloud Mask Description for qual_clddet - qual_clddet = (tb_xb(ch14,n).ge.tb_xb(ch15,n)) - - if ( (tb_inv(ch14,n) + tb_xb(ch14,n)).le.310. .and. & - iv%instid(isens)%cld_qc(n)%tb_stddev_3x3(ch14).ge.0.3 .and. & - tb_ob(ch14,n).gt.0. .and. tb_ob(ch15,n).gt.0. ) & - crit_clddet = ( tb_ob(ch14,n) - tb_ob(ch15,n) ) + qual_clddet = & + tb_xb_clr(ch14,n) > 0.0 .and. & + tb_xb_clr(ch15,n) > 0.0 .and. & + (tb_xb_clr(ch14,n) >= tb_xb_clr(ch15,n)) + + if ( (tb_obs(ch14,n)) <= 310. .and. & + iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%tb_stddev_3x3(ch14) >= 0.3 .and. & + tb_obs(ch14,n) > 0. .and. tb_obs(ch15,n) > 0. ) & + crit_clddet = ( tb_obs(ch14,n) - tb_obs(ch15,n) ) ! above using ob without VarBC ! ------------------------------- -! crit_clddet = (tb_inv(ch14,n) + tb_xb(ch14,n) - & -! (tb_inv(ch15,n) + tb_xb(ch15,n)) ) -! above using ob with VarBC +! crit_clddet = (tb_inv(ch14,n) + tb_xb_clr(ch14,n) - & +! (tb_inv(ch15,n) + tb_xb_clr(ch15,n)) ) +! above using ob with VarBC (requires clear-sky tb_inv) ! ------------------------------- -!JJG: Why does this logical test not use tb_ob(ch14,n)? Something to do with VarBC... - if ( crit_clddet.gt.missing_r .and. & - (tb_inv(ch14,n) + tb_xb(ch14,n)).gt.270. .and. & - tb_xb(ch14,n).gt.270. ) & - crit_clddet = crit_clddet - & - (tb_xb(ch14,n) - tb_xb(ch15,n)) * & - (tb_ob(ch14,n) - 260.) / (tb_xb(ch14,n) - 260.) + if ( crit_clddet > missing_r .and. & + (tb_obs(ch14,n)) > 270. .and. & + tb_xb_clr(ch14,n) > 270. ) & + crit_clddet = crit_clddet - & + (tb_xb_clr(ch14,n) - tb_xb_clr(ch15,n)) * & + (tb_obs(ch14,n) - 260.) / (tb_xb_clr(ch14,n) - 260.) ! above 1 line using ob without VarBC -! (tb_inv(ch14,n) + tb_xb(ch14,n) - 260.)/ & -! (tb_xb(ch14,n) - 260.) -! above 2 lines using ob with VarBC +! (tb_inv(ch14,n) + tb_xb_clr(ch14,n) - 260.)/ & +! (tb_xb_clr(ch14,n) - 260.) +! above 2 lines using ob with VarBC (requires clear-sky tb_inv) case (4) !-------------------------------------------------------------------------- ! 4.4 Negative Fourteen Minus Fifteen Test (NFMFT) !-------------------------------------------------------------------------- - if (tb_ob(ch14,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) & - crit_clddet = tb_inv(ch15,n) - tb_inv(ch14,n) + if (tb_obs(ch14,n) > 0. .and. tb_obs(ch15,n) > 0. .and. & + tb_xb_clr(ch14,n) > 0. .and. tb_xb_clr(ch15,n) > 0. ) & + crit_clddet = (tb_xb_clr(ch14,n) - tb_xb_clr(ch15,n) ) & + - (tb_obs(ch14,n) - tb_obs(ch15,n)) case (5) !-------------------------------------------------------------------------- ! 4.5 Relative Fourteen Minus Fifteen Test (RFMFT) !-------------------------------------------------------------------------- ! See ABI Cloud Mask Description for qual_clddet - qual_clddet = ( tb_ob(ch14,n) - tb_ob(ch15,n) ) .lt. 1.0 - qual_clddet(2) = qual_clddet(2) .and. tb_ob(ch14,n) .le. 300. - qual_clddet(3:4) = .false. + if (tb_obs(ch14,n) > 0. .and. tb_obs(ch15,n) > 0. ) then + qual_clddet = ( tb_obs(ch14,n) - tb_obs(ch15,n) ) < 1.0 + qual_clddet(2) = qual_clddet(2) .and. tb_obs(ch14,n) <= 300. + qual_clddet(3:4) = .false. - crit_clddet = iv%instid(isens)%cld_qc(n)%RFMFT + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%RFMFT + end if case (6) !-------------------------------------------------------------------------- @@ -397,11 +421,11 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) !-------------------------------------------------------------------------- ! See ABI Cloud Mask Description for qual_clddet qual_clddet = & - iv%instid(isens)%cld_qc(n)%terr_hgt .le. 2000. & - .and. iv%instid(isens)%cld_qc(n)%tb_stddev_3x3(ch10) .gt. 0.5 & - .and. iv%instid(isens)%cld_qc(n)%tb_stddev_3x3(ch14) .gt. 0.5 - if ( allocated(iv%instid(isens)%cld_qc(n)%CIRH2O) ) & - crit_clddet = iv%instid(isens)%cld_qc(n)%CIRH2O(1,1,1) + iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%terr_hgt <= 2000. & + .and. iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%tb_stddev_3x3(ch10) > 0.5 & + .and. iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%tb_stddev_3x3(ch14) > 0.5 + if ( allocated(iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%CIRH2O) ) & + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%CIRH2O(1,1,1) case (7) !-------------------------------------------------------------------------- @@ -409,8 +433,9 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) !-------------------------------------------------------------------------- ! Modify EMISS for sun glint area may be not work, because we are at north land ! - compute relative azimuth - crit_clddet = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14)/ & - (rad_b_ch7 / rad_b_ch14) + if ( all((/rad_o_ch7,rad_o_ch14,rad_b_ch7,rad_b_ch14/) > 0.0) ) & + crit_clddet = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14) / & + (rad_b_ch7 / rad_b_ch14) if ( iv%instid(isens)%solzen(n) > 0. & .and. iv%instid(isens)%solzen(n) < 90. ) then @@ -419,8 +444,12 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! - compute glint angle Glintzen = GLINT_ANGLE(iv%instid(isens)%solzen(n),iv%instid(isens)%satzen(n),Relaz ) - if ( Glintzen.lt.40.0 .and. isflg==sea_flag) then - crit_clddet = - tb_inv(ch7,n) ! (B_ch7 - O_ch7) + if ( Glintzen < 40.0 .and. isflg==sea_flag) then + if (tb_xb_clr(ch7,n) > 0. .and. tb_obs(ch7,n) > 0.) then + crit_clddet = tb_xb_clr(ch7,n) - tb_obs(ch7,n) ! (B_ch7 - O_ch7) + else + crit_clddet = missing_r + endif offset_clddet = 1 end if end if @@ -431,7 +460,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) !-------------------------------------------------------------------------- !JJG, AHI error: Changed this to solzen instead of solazi for night/day test qual_clddet = iv%instid(isens)%solzen(n) >= 85.0 - if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch14,n) .gt. 0.) & + if ( all((/rad_o_ch7,rad_o_ch14,rad_b_ch7,rad_b_ch14/) > 0.0) ) & crit_clddet = rad_b_ch7/rad_b_ch14 - rad_o_ch7/rad_o_ch14 case (9) @@ -439,27 +468,27 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! 4.9 New Optically Thin Cloud Test (N-OTC) !-------------------------------------------------------------------------- !JJG, AHI error: Changed this to solzen instead of solazi for night/day test - if ( iv%instid(isens)%solzen(n) .ge. 85.0 ) & + if ( iv%instid(isens)%solzen(n) >= 85.0 ) & offset_clddet = 1 ! night time - if (tb_ob(ch7,n) .gt. 0. .and. tb_ob(ch15,n) .gt. 0.) & + if (tb_obs(ch7,n) > 0. .and. tb_obs(ch15,n) > 0.) & ! using ob without VarBC ! ------------------------------- - crit_clddet = tb_ob(ch7,n) - tb_ob(ch15,n) + crit_clddet = tb_obs(ch7,n) - tb_obs(ch15,n) -! using ob with VarBC +! using ob with VarBC (requires clear-sky tb_inv) ! ------------------------------- -! crit_clddet = tb_inv(ch7,n) + tb_xb(ch7,n) - & -! (tb_inv(ch15,n) + tb_xb(ch15,n)) +! crit_clddet = tb_inv(ch7,n) + tb_xb_clr(ch7,n) - & +! (tb_inv(ch15,n) + tb_xb_clr(ch15,n)) case (10) !-------------------------------------------------------------------------- ! 4.10 Temporal Infrared Test (TEMPIR) !-------------------------------------------------------------------------- - crit_clddet = iv%instid(isens)%cld_qc(n)%TEMPIR + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%TEMPIR case default - cycle + cycle ABICloudTestLoop end select ! call evaluate_clddet_test ( & @@ -467,13 +496,12 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! iv%instid(isens)%info%lat(1,n), iv%instid(isens)%info%lon(1,n), & ! reject_clddet ) - reject_clddet = crit_clddet.gt.missing_r .and. & + reject_clddet = crit_clddet > missing_r .and. & any( isflg.eq.isflgs_clddet .and. & - crit_clddet.gt.eps_clddet(index_clddet(itest)+offset_clddet,:) .and. & + crit_clddet > eps_clddet(index_clddet(itest)+offset_clddet,:) .and. & qual_clddet ) if (reject_clddet) then - tb_qc_clddet = qc_bad if (iv%instid(isens)%info%proc_domain(1,n)) then nrej_clddet(:,itest) = nrej_clddet(:,itest) + 1 !JJGDEBUG @@ -481,17 +509,32 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) !JJGDEBUG end if - clddet_tests(itest) = 1 + clddet_tests(isuper, jsuper, itest) = 1 end if - end do - if (.not. crtm_cloud(it) ) tb_qc = tb_qc_clddet - if (any(tb_qc_clddet.lt.0)) iv%instid(isens)%cloud_flag(:,n) = sum(clddet_tests) * qc_bad + end do ABICloudTestLoop + end do ! isuper + end do ! jsuper + if ( iv%instid(isens)%superob_width > 1 ) then + iv%instid(isens)%cloud_frac(n) = & + real( count(sum(clddet_tests,3) > 0), 8 ) / real( iv%instid(isens)%superob_width**2, 8 ) + end if + + ! cloud_flag = - round (mean number of tests failed) + iv%instid(isens)%cloud_flag(:,n) = & + - NINT( real( sum(clddet_tests) , 8 ) / real( iv%instid(isens)%superob_width**2, 8 ) ) + + if (.not. crtm_cloud(it) .and. & + iv%instid(isens)%cloud_flag(1,n) < 0) then + tb_qc = qc_bad + end if !JJGDEBUG - if (print_cld_debug) write(stdout,'(A,I8,*(2x,I1:))') 'PIXEL_DEBUG6: ', n, clddet_tests + if (print_cld_debug) write(stdout,'(A,I8,*(2x,I1:))') 'PIXEL_DEBUG6: ', n, clddet_tests(superob_center,superob_center,:) !JJGDEBUG end if abi_clddet + tb_obs => ob%instid(isens)%tb + ! --------------------------- ! 5.0 assigning obs errors if (.not. crtm_cloud(it) ) then @@ -504,7 +547,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) else !crtm_cloud(it) ! calculate cloud impacts where ( tb_inv( :, n ) > missing_r & - .and. tb_ob( :, n ) > 0. & + .and. tb_obs( :, n ) > 0. & .and. tb_xb( :, n ) > 0. & .and. BTlim( : ) > 0. & !Harnisch ) @@ -536,10 +579,10 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) cloud_mean = 0.5 * ( cloud_mod(:,n) + cloud_obs(:,n) ) do k = 1, nchan - if ( cloud_mean(k).gt.missing_r ) then - if ( cloud_mean(k).lt.camin ) then + if ( cloud_mean(k) > missing_r ) then + if ( cloud_mean(k) < camin ) then iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) - else if ( cloud_mean(k) .lt. satinfo(isens)%error_cld_x(k) ) then + else if ( cloud_mean(k) < satinfo(isens)%error_cld_x(k) ) then iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + & ( satinfo(isens)%error_cld_y(k) - satinfo(isens)%error_std(k) ) * & ( cloud_mean(k) - camin ) / ( satinfo(isens)%error_cld_x(k) - camin ) @@ -555,7 +598,19 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) end if end if - ! 5.1 check innovation + ! 5.1 check obs and background + !----------------------------------------------------------------- + do k = 1, nchan + if (tb_obs(k,n) < 0.0) then + tb_qc(k) = qc_bad + end if + if (tb_xb(k,n) < 0.0) then + tb_qc(k) = qc_bad + end if + end do ! nchan + + + ! 5.2 check innovation !----------------------------------------------------------------- ! absolute departure check do k = 1, nchan @@ -586,7 +641,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ngood(k) = ngood(k) + 1 end if end do ! nchan - end do PixelQCLoop + end do ABIPixelQCLoop ! Do inter-processor communication to gather statistics. call da_proc_sum_int (num_proc_domain) @@ -698,7 +753,7 @@ end function glint_angle ! logical, intent(out) :: reject_clddet ! ! reject_clddet = .false. -! reject_clddet = crit_clddet.gt.missing_r .and. any( isflg.eq.isflgs .and. crit_clddet.gt.eps .and. extra_qual ) +! reject_clddet = crit_clddet > missing_r .and. any( isflg.eq.isflgs .and. crit_clddet > eps .and. extra_qual ) ! !end subroutine evaluate_clddet_test diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index 36e1a9a8d9..985094be04 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -23,10 +23,11 @@ module da_radiance1 global, gas_constant, gravity, monitor_on,kts,kte,use_rttov_kmatrix, & use_pseudo_rad, pi, t_triple, crtm_cloud, DT_cloud_model,write_jacobian, & use_crtm_kmatrix,use_clddet, use_clddet_abi, use_satcv, cv_size_domain, & - cv_size_domain_js, calc_weightfunc, deg_to_rad, rad_to_deg, use_rad_symm_err + cv_size_domain_js, calc_weightfunc, deg_to_rad, rad_to_deg, use_rad_symm_err, & + abi_superob_halfwidth use da_define_structures, only : info_type,model_loc_type,maxmin_type, & iv_type, y_type, jo_type,bad_data_type,bad_data_type,number_type, & - be_type, cld_qc_type + be_type, superob_type use module_dm, only : wrf_dm_sum_real, wrf_dm_sum_integer #ifdef DM_PARALLEL use da_par_util, only : da_proc_stats_combine, true_mpi_real @@ -57,7 +58,7 @@ module da_radiance1 type (info_type) :: info type (model_loc_type) :: loc - type (cld_qc_type), pointer :: cld_qc => null() + type (superob_type), allocatable :: superob(:,:) integer :: ifgat, landsea_mask, rain_flag integer :: scanline, scanpos real :: satzen, satazi, solzen, solazi ! satellite and solar angles @@ -78,6 +79,7 @@ module da_radiance1 real, pointer :: tb_inv(:) real, pointer :: tb_qc(:) real, pointer :: tb_error(:) + real, pointer :: rad_obs(:) integer :: sensor_index type (datalink_type), pointer :: next ! pointer to next data end type datalink_type diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index decce4ae3d..147d7e4a4d 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -22,7 +22,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! WRFDA subs: da_llxy, da_get_julian_time, ! da_get_unit, da_free_unit, ! da_get_sat_angles(_1d), da_get_solar_angles(_1d) - ! da_trace_entry, da_trace_exit, + ! da_trace_entry, da_trace_exit, ! precisions: r_double, i_kind type (iv_type),intent (inout) :: iv @@ -78,12 +78,14 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Brightness Temperature (K) - real, allocatable :: bt_p(:,:,:), terrain_hgt(:,:) + real, allocatable :: bt_p(:,:,:), rad_p(:,:,:), terrain_hgt(:,:) + real :: bc1, bc2, fk1, fk2 !! Iterates integer :: ichan, ifile, iview, ifgat, ipass, ioff, & jchan, jfile, jview, icount, io_stat, & - n, i, j, iy, ix, jy, jx, iyl, ixl, iyfd, ixfd, iproc, subgrid + n, i, j, iy, ix, jy, jx, iyl, ixl, iyfd, ixfd, iproc, subgrid, & + isup, jsup, ixsup, iysup INTEGER :: cstat, estat CHARACTER(LEN=100) :: cmsg logical :: exists @@ -145,7 +147,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) logical, allocatable :: file_fgat_match(:,:) real*8, allocatable :: fgat_time_abs_diff(:,:) ! seconds real*8, allocatable :: min_time_diff(:,:) ! seconds - integer, allocatable :: nfiles_used(:) + integer, allocatable :: nfiles_used(:) logical :: meta_initialized = .false. logical :: grid_initialized = .false. integer :: ny_global, nx_global, yoff_fd, xoff_fd @@ -204,6 +206,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !Cloud QC variables integer :: tbuf, nkeep, ikeep integer :: abi_halo_width ! Must be ≥ 0 + integer :: superob_width real :: mu10, mu14, sigma10, sigma14, pearson, temp_max real :: mu, sigma real, allocatable :: tb_temp(:,:) @@ -273,7 +276,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) allocate(view_att(nviews)) ! (default) All views are used (algorithm figures out which views have files present) ! Could set this according to namelist entries - view_att(:) % select = .true. + view_att(:) % select = .true. view_att(1) % name_short = 'F' view_att(2) % name_short = 'C' view_att(3) % name_short = 'M1' @@ -311,12 +314,13 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) num_goesabi_used_fgat = 0 num_goesabi_thinned = 0 + abi_halo_width = abi_superob_halfwidth if ( use_clddet_abi ) then - abi_halo_width = max(10,abi_superob_halfwidth) - else - abi_halo_width = max(0,abi_superob_halfwidth) + abi_halo_width = abi_halo_width + 10 end if + superob_width = 2*abi_superob_halfwidth+1 + tot_files_used = 0 use_view_mask = .false. @@ -361,7 +365,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) icount = 0 io_stat = -1 - do while (io_stat .ne. 0) + do while (io_stat .ne. 0) open(unit=file_unit,file=trim(list_file), iostat = io_stat) icount = icount + 1 if (icount .gt. 10000) exit @@ -522,7 +526,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if if (count(this_view % file_fgat_match(ifile,:)) .gt. 1) then - print*, 'WARNING: More than one bin was selected for ',trim(fname) + print*, 'WARNING: More than one bin was selected for ',trim(fname) print*, 'num_bin_per_file = ',count(this_view % file_fgat_match(ifile,:)) print*, 'obs_time = ',obs_time print*, 'Ignoring this file for reading.' @@ -697,8 +701,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) n = 0 ; icount = 0 !JJG: Not convinced that these subgrids are needed. Might be able to loop over global X/Y instead. This solution may be overly complex. mod test for load balancing is still needed! - ! This loop over subgrids and the selective logic - ! below for myproc balances the processor loads + ! This loop over subgrids and the selective logic + ! below for myproc balances the processor loads ! when some imager pixels are off-earth or outside ! zenith-angle limits (Full Disk and CONUS) do subgrid = 1, num_procs @@ -712,11 +716,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) do iyl = 1, ny_local iy = iyl + this_view % ys_local - 1 ix = ixl + this_view % xs_local - 1 - if ( mod( iy-abi_superob_halfwidth-1, 2*abi_superob_halfwidth+1 ) == 0 .and. & - mod( ix-abi_superob_halfwidth-1, 2*abi_superob_halfwidth+1 ) == 0 ) then -! if ( abi_superob_halfwidth == 0 .or. & -! ( mod( iy-abi_superob_halfwidth-1, 2*abi_superob_halfwidth+1 ) == 0 .and. & -! mod( ix-abi_superob_halfwidth-1, 2*abi_superob_halfwidth+1 ) == 0 ) ) then + if ( mod( iy-abi_superob_halfwidth-1, superob_width ) == 0 .and. & + mod( ix-abi_superob_halfwidth-1, superob_width ) == 0 ) then !This mod test produces balanced loads between processors if ( mod( n, num_procs ) .eq. myproc ) then icount = icount + 1 @@ -778,9 +779,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) this_view % satazi_1d % local, & earthmask_1d, zenmask_1d ) - ! Reduce values for iy, ix, lat, lon, satzen, satazi + ! Reduce values for iy, ix, lat, lon, satzen, satazi ! using earth and zenith masks - nrad_mask = count ( earthmask_1d .and. zenmask_1d ) + nrad_mask = count ( earthmask_1d .and. zenmask_1d ) this_view % lat_1d % local(1:nrad_mask) = & pack(this_view % lat_1d % local , earthmask_1d .and. zenmask_1d ) this_view % lon_1d % local(1:nrad_mask) = & @@ -818,7 +819,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) call mpi_barrier(comm, ierr) #endif ! COMMUNICATE 1D FIELDS FROM REMOTE PROCS TO LOCAL BUFFER - ! Note: these comms are a minor bottleneck, which will be + ! Note: these comms are a minor bottleneck, which will be ! more noticeable for 4D-Var when MESO1/2 is processed ! at multiple fgat's ! Potential Solutions @@ -855,7 +856,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! ! displs = 0 ! do iproc = 1, num_procs - 1 -! displs(iproc+1) = displs(iproc) + nbufs(iproc) +! displs(iproc+1) = displs(iproc) + nbufs(iproc) ! end do ! ! this_view % nrad_on_domain = sum( nbufs ) @@ -1053,7 +1054,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) allocate( this_view % satzen_1d % patch (this_view % nrad_on_patch) ) allocate( this_view % satazi_1d % patch (this_view % nrad_on_patch) ) allocate( this_view % iy_1d % patch (this_view % nrad_on_patch) ) - allocate( this_view % ix_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % ix_1d % patch (this_view % nrad_on_patch) ) allocate( this_view % loc_1d % patch (this_view % nrad_on_patch) ) this_view % lat_1d % patch = & @@ -1183,9 +1184,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) VIEW_SELECT: & if ( ipass.lt.npass .and. use_view_mask ) then !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! Determine which view has the closest observed + !! Determine which view has the closest observed !! time to fgat for this channel - !! Note: this only needs to be done for a single channel, + !! Note: this only needs to be done for a single channel, !! unless individual channel files are missing at fgat. !! Solution where file view availability differs by channel used here. !! (only available when FD data present for one of the fgat times) @@ -1206,7 +1207,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) best_view = best_view .and. & this_view % min_time_diff(ichan, ifgat) .lt. & view_att(jview) % min_time_diff(ichan, ifgat) - end do + end do if ( best_view ) then do n = 1, this_view % nrad_on_patch iy = this_view % iy_1d % patch (n) @@ -1280,7 +1281,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Read radiance and convert to brightness temp. - !! once per permutation of + !! once per permutation of !! + INST VIEW (FD, CONUS, MESOx2) !! + fgat !! + channel/band @@ -1320,33 +1321,53 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Allocate and read bt for this patch and current time if ( TEMPIR_ifile.gt.0 ) then + allocate( rad_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) ) + allocate( bt_p ( & this_view % ys_local:this_view % ye_local, & this_view % xs_local:this_view % xe_local, 2 ) ) else + allocate( rad_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 1 ) ) + allocate( bt_p ( & this_view % ys_local:this_view % ye_local, & this_view % xs_local:this_view % xe_local, 1 ) ) end if + fname = trim(this_view % filename(ifile)) - call get_abil1b_bt( fname, & - this_view % ys_local, this_view % ye_local, & - this_view % xs_local, this_view % xe_local, & - readmask_p, bt_p(:,:,1), inst, ichan ) + call get_abil1b_rad( fname, & + this_view % ys_local, this_view % ye_local, & + this_view % xs_local, this_view % xe_local, & + readmask_p, inst, ichan, & + rad_p(:,:,1), bc1, bc2, fk1, fk2 ) + + bt_p = missing_r + where (readmask_p) + bt_p(:,:,1) = rad2bt(rad_p(:,:,1), bc1, bc2, fk1, fk2) + end where !JJG: It is possible for readmask_p to differ across channels. - ! readmask_p needs to be incorporated, but presently causes error between channel reading - ! when lining up channels to identical members of linked p list. - ! Fixing this will require moving away from linked list including the readmask_p quality + ! readmask_p needs to be incorporated, but presently causes error between channel reading + ! when lining up channels to identical members of linked p list. + ! Fixing this will require moving away from linked list including the readmask_p quality ! flag in the datalink_type. - ! Presently readmask_p is used internally within get_abil1b_bt to set bt_p=missing_r (works fine) + ! Presently readmask_p is used internally within get_abil1b_rad to set rad_p=missing_r (works fine) !allmask_p = (allmask_p .and. readmask_p) if ( TEMPIR_ifile.gt.0 ) then fname = trim(this_view % filename(TEMPIR_ifile)) - call get_abil1b_bt( fname, & - this_view % ys_local, this_view % ye_local, & - this_view % xs_local, this_view % xe_local, & - readmask_p, bt_p(:,:,2), inst, ichan ) + call get_abil1b_rad( fname, & + this_view % ys_local, this_view % ye_local, & + this_view % xs_local, this_view % xe_local, & + readmask_p, inst, ichan, & + rad_p(:,:,2), bc1, bc2, fk1, fk2 ) + + where (readmask_p) + bt_p(:,:,2) = rad2bt(rad_p(:,:,2), bc1, bc2, fk1, fk2) + end where yr = this_view % filedate(TEMPIR_ifile) % yr mt = this_view % filedate(TEMPIR_ifile) % mt @@ -1361,22 +1382,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) first_chan = (this_view % nfiles_used(ifgat).eq.1) - if ( use_clddet_abi .and. channel_list(ichan).eq.14 .and. abi_halo_width.ge.1) then - ! Allocate terrain_hgt using local indices for this view - allocate( terrain_hgt ( & - this_view % ys_local:this_view % ye_local, & - this_view % xs_local:this_view % xe_local ) ) - - ! Read terrain file using Full Disk global indices - call get_abil1b_terr( terr_fname, & - this_view % ys_local + this_view % yoff_fd - 1, & - this_view % ye_local + this_view % yoff_fd - 1, & - this_view % xs_local + this_view % xoff_fd - 1, & - this_view % xe_local + this_view % xoff_fd - 1, & - terrain_hgt ) - - end if - !! Write bt, lat, lon, satzen, satazi, solzen, solazi to datalink structures if (first_chan) then p_fgat => p @@ -1388,22 +1393,27 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) mn = this_view % filedate(ifile) % mn sc = this_view % filedate(ifile) % sc - if ( use_clddet_abi ) then - allocate( solzen_1d (this_view % nrad_on_patch) ) - allocate( solazi_1d (this_view % nrad_on_patch) ) - - call da_get_solar_angles_1d ( yr, mt, dy, hr, mn, sc, & - this_view % lat_1d % patch, this_view % lon_1d % patch, & - solzen_1d, solazi_1d ) - -! do n = 1, this_view % nrad_on_patch -! iy = this_view % iy_1d % patch (n) -! ix = this_view % ix_1d % patch (n) -! if (.not. allmask_p( iy, ix )) cycle -! call da_get_solar_angles ( yr, mt, dy, hr, mn, sc, & -! this_view % lat_1d % patch(n), this_view % lon_1d % patch(n), & -! solzen_1d(n), solazi_1d(n) ) -! end do + allocate( solzen_1d (this_view % nrad_on_patch) ) + allocate( solazi_1d (this_view % nrad_on_patch) ) + + call da_get_solar_angles_1d ( yr, mt, dy, hr, mn, sc, & + this_view % lat_1d % patch, this_view % lon_1d % patch, & + solzen_1d, solazi_1d ) + + if ( use_clddet_abi .and. & + abi_halo_width-abi_superob_halfwidth.ge.1) then + ! Allocate terrain_hgt using local indices for this view + allocate( terrain_hgt ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local ) ) + + ! Read terrain file using Full Disk global indices + call get_abil1b_terr( terr_fname, & + this_view % ys_local + this_view % yoff_fd - 1, & + this_view % ye_local + this_view % yoff_fd - 1, & + this_view % xs_local + this_view % xoff_fd - 1, & + this_view % xe_local + this_view % xoff_fd - 1, & + terrain_hgt ) end if allocate(thinmask(this_view % ys_p:this_view % ye_p, & @@ -1422,7 +1432,6 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if (first_chan) then info % lat = this_view % lat_1d % patch (n) ! latitude info % lon = this_view % lon_1d % patch (n) ! longitude -! num_goesabi_global = num_goesabi_global + 1 num_goesabi_local = num_goesabi_local + 1 end if @@ -1449,13 +1458,19 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if (first_chan) then num_goesabi_used_fgat(ifgat) = num_goesabi_used_fgat(ifgat) + 1 + allocate ( p % tb_inv (1:nchan) ) + allocate ( p % rad_obs (1:nchan) ) + p % tb_inv = missing_r + p % rad_obs = missing_r + write(unit=info % date_char, & fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc - info % elv = 0.0 - allocate ( p % tb_inv (1:nchan) ) - p % tb_inv = missing_r - + if ( allocated(terrain_hgt) ) then + info % elv = terrain_hgt( iy, ix ) + else + info % elv = 0.0 + end if p % info = info p % loc = this_view % loc_1d % patch (n) @@ -1471,201 +1486,247 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if p % satzen = this_view % satzen_1d % patch (n) p % satazi = this_view % satazi_1d % patch (n) - if ( use_clddet_abi ) then - p % solzen = solzen_1d (n) - p % solazi = solazi_1d (n) - else - p % solzen = missing_r - p % solazi = missing_r - end if + p % solzen = solzen_1d (n) + p % solazi = solazi_1d (n) if ( p % solzen < 0. ) p % solzen = 150. p % sensor_index = inst p % ifgat = ifgat end if - ! Super-ob the BT for this channel + ! Super-ob the radiance, then convert to BT for this channel tbuf = abi_superob_halfwidth if (abi_halo_width.ge.tbuf .and. tbuf.gt.0) then - nkeep = count ( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r ) - if (nkeep .gt. 0) then - allocate( tb_temp ( nkeep, 1 ) ) - tb_temp(:,1) = pack( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ), & - bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r) - p % tb_inv(ichan) = sum( tb_temp(:,1) ) / real(nkeep,r_double) - deallocate( tb_temp ) + ! require that nkeep >= superob_width to filter out bad data + nkeep = count ( rad_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. 0.0 ) + if (nkeep .ge. superob_width) then + p % rad_obs(ichan) = sum( pack( & + rad_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ), & + rad_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. 0.0 ) ) & + / real(nkeep,r_double) end if else - ! Extract single pixel BT value for this channel - p % tb_inv(ichan) = bt_p( iy, ix, 1 ) + ! Extract single pixel BT and radiance value for this channel + p % rad_obs(ichan) = rad_p( iy, ix, 1 ) + end if + if (p % rad_obs(ichan) .gt. 0.0) then + p % tb_inv(ichan) = rad2bt(p % rad_obs(ichan), bc1, bc2, fk1, fk2 ) end if ! Preprocessing for Cloud Mask (da_qc_goesabi.inc) including ! extracting Tb values from cloud QC buffer - if (.not. associated(p % cld_qc)) then - allocate( p % cld_qc ) - allocate( p % cld_qc % tb_stddev_3x3(nchan) ) + if (.not. allocated(p % superob)) then + allocate( p % superob(superob_width,superob_width) ) end if - tbuf = 1 - if (abi_halo_width.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then - - nkeep = count ( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r ) - if (nkeep .gt. 0) then - allocate( tb_temp ( nkeep, 1 ) ) - tb_temp(:,1) = pack( bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ), & - bt_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. missing_r) - mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) - sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) - deallocate( tb_temp ) - - p % cld_qc % tb_stddev_3x3(ichan) = sigma - else - p % cld_qc % tb_stddev_3x3(ichan) = missing_r + ! Loops over superob pixels + do jsup = 1, superob_width + do isup = 1, superob_width + iysup = iy + jsup-1-abi_superob_halfwidth + ixsup = ix + isup-1-abi_superob_halfwidth + if (first_chan) then + allocate ( p % superob(isup,jsup) % tb_obs (1:nchan,1) ) + allocate ( p % superob(isup,jsup) % cld_qc(1) ) + allocate ( p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(nchan) ) end if - if (channel_list(ichan).eq.14) then - - if ( allocated(terrain_hgt) ) then - ! Determine sigma_z of terrain height across these pixels - p % cld_qc % terr_hgt = terrain_hgt( iy, ix ) - p % info % elv = p % cld_qc % terr_hgt - - nkeep = count ( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r ) - if (nkeep .gt. 0) then - allocate( tb_temp ( nkeep, 1 ) ) - tb_temp(:,1) = pack( terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ), & - terrain_hgt ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf ) .gt. missing_r) - mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) - sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) - deallocate( tb_temp ) - - ! Values for RTCT cloud QC - ! - channel 14 and sigma_z (std. dev. of terrain height in km) - ! w/ landmask and lapse rate of 7 K km^-1 - - temp_max = 0. - do jy = iy-tbuf, iy+tbuf - do jx = ix-tbuf, ix+tbuf - if ( bt_p( jy, jx, 1) .gt. 0. ) & - temp_max = max(temp_max,bt_p( jy, jx, 1 ) ) - end do - end do - - if (temp_max .gt. missing_r) then - ! Store RTCT - p % cld_qc % RTCT = temp_max - bt_p( iy, ix, 1 ) - & - 3.0_r_double * 0.007_r_double * sigma + p % superob(isup,jsup) % tb_obs(ichan,1) = bt_p( iysup, ixsup, 1 ) + + tbuf = 1 + if (abi_halo_width-abi_superob_halfwidth.ge.tbuf .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0) then + nkeep = count ( bt_p ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) .gt. 0.0 ) + if (nkeep .gt. 0) then + allocate( tb_temp ( nkeep, 1 ) ) + tb_temp(:,1) = pack( bt_p ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ), & + bt_p ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) .gt. 0.0) + mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) + deallocate( tb_temp ) + + p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(ichan) = sigma + else + p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(ichan) = missing_r + end if + if (channel_list(ichan).eq.14) then + + if ( allocated(terrain_hgt) ) then + ! Determine sigma_z of terrain height across these pixels + p % superob(isup,jsup) % cld_qc(1) % terr_hgt = terrain_hgt( iysup, ixsup ) + nkeep = count ( terrain_hgt ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf ) .gt. missing_r ) + if (nkeep .gt. 0) then + allocate( tb_temp ( nkeep, 1 ) ) + tb_temp(:,1) = pack( terrain_hgt ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf ), & + terrain_hgt ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf ) .gt. missing_r) + mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) + deallocate( tb_temp ) + + ! Values for RTCT cloud QC + ! - channel 14 and sigma_z (std. dev. of terrain height in km) + ! w/ landmask and lapse rate of 7 K km^-1 + + temp_max = 0. + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf + if ( bt_p( jy, jx, 1) .gt. 0. ) & + temp_max = max(temp_max,bt_p( jy, jx, 1 ) ) + end do + end do + + if (temp_max .gt. missing_r) then + ! Store RTCT + p % superob(isup,jsup) % cld_qc(1) % RTCT = temp_max - bt_p( iysup, ixsup, 1 ) - & + 3.0_r_double * 0.007_r_double * sigma + else + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r + end if else - p % cld_qc % RTCT = missing_r + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r end if else - p % cld_qc % RTCT = missing_r + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r + p % superob(isup,jsup) % cld_qc(1) % terr_hgt = missing_r end if - else - p % cld_qc % RTCT = missing_r - p % cld_qc % terr_hgt = missing_r - end if + end if + else + p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(ichan) = missing_r + if (channel_list(ichan).eq.14) then + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r + p % superob(isup,jsup) % cld_qc(1) % terr_hgt = missing_r + end if end if - else - p % cld_qc % tb_stddev_3x3(ichan) = missing_r - if (channel_list(ichan).eq.14) then - p % cld_qc % RTCT = missing_r - p % cld_qc % terr_hgt = missing_r - end if - end if - ! Values for RFMFT cloud QC - ! - channels 14 and 15 - tbuf = 10 - if (abi_halo_width.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then - if (channel_list(ichan).eq.14) then - !Determine Neighboring Warm Center (NWC) for this pixel - temp_max = 0. - do jy = iy-tbuf, iy+tbuf - do jx = ix-tbuf, ix+tbuf - if ( bt_p( jy, jx, 1 ) .gt. missing_r ) then + ! Values for RFMFT cloud QC + ! - channels 14 and 15 + tbuf = 10 + if (abi_halo_width-abi_superob_halfwidth.ge.tbuf .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0) then + if (channel_list(ichan).eq.14) then + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij = -1 + + !Determine Neighboring Warm Center (NWC) for this pixel + temp_max = 0.0 + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf if ( bt_p( jy, jx, 1 ) .gt. temp_max ) then temp_max = bt_p( jy, jx, 1 ) - p % cld_qc % RFMFT_ij(1) = jy - p % cld_qc % RFMFT_ij(2) = jx + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(1) = jy + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(2) = jx end if - end if - end do - end do - p % cld_qc % RFMFT = & - bt_p( iy, ix, 1 ) - temp_max - end if - if (channel_list(ichan).eq.15 .and. all(p % cld_qc % RFMFT_ij.gt.0)) then - temp_max = bt_p ( p % cld_qc % RFMFT_ij(1), & - p % cld_qc % RFMFT_ij(2), 1 ) - p % cld_qc % RFMFT = abs( p % cld_qc % RFMFT + & - temp_max - bt_p( iy, ix, 1 ) ) - end if - else - if ( any( channel_list(ichan).eq.(/14,15/) ) ) then - p % cld_qc % RFMFT = missing_r - p % cld_qc % RFMFT_ij = -1 - end if - end if + end do + end do + p % superob(isup,jsup) % cld_qc(1) % RFMFT = & + bt_p( iysup, ixsup, 1 ) - temp_max + end if + if (channel_list(ichan).eq.15 .and. & + all(p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij.gt.0)) then - ! Values for CIRH2O cloud QC - ! - channels 10 and 14 for Pearson correlation coefficient of CIRH2O test - tbuf = 2 - if (abi_halo_width.ge.tbuf .and. bt_p( iy, ix, 1 ).gt.missing_r) then - if (channel_list(ichan).eq.10) then - allocate( p % cld_qc % CIRH2O ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 2 ) ) - p % cld_qc % CIRH2O(:,:,1) = bt_p( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) - end if - if (channel_list(ichan).eq.14 .and. size(p % cld_qc % CIRH2O).gt.1) then - p % cld_qc % CIRH2O(:,:,2) = bt_p( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) - nkeep = 0 - do jy = iy-tbuf, iy+tbuf - do jx = ix-tbuf, ix+tbuf - if ( all(p % cld_qc % CIRH2O( jy, jx, : ) .gt. missing_r) ) nkeep = nkeep + 1 - end do - end do - allocate( tb_temp ( nkeep, 2 ) ) - ikeep = 0 - do jy = iy-tbuf, iy+tbuf - do jx = ix-tbuf, ix+tbuf - if ( all(p % cld_qc % CIRH2O( jy, jx, : ) .gt. missing_r) ) then - ikeep = ikeep + 1 - tb_temp(ikeep,1) = p % cld_qc % CIRH2O( jy, jx, 1 ) - tb_temp(ikeep,2) = p % cld_qc % CIRH2O( jy, jx, 2 ) - end if - end do - end do - mu10 = sum( tb_temp(:,1) ) / real(nkeep,r_double) - sigma10 = sqrt( sum( (tb_temp(:,1) - mu10)**2 ) & - / real(nkeep,r_double) ) - mu14 = sum( tb_temp(:,2) ) / real(nkeep,r_double) - sigma14 = sqrt( sum( (tb_temp(:,2) - mu14)**2 ) / & - real(nkeep,r_double) ) - pearson = sum((tb_temp(:,1) - mu10) * (tb_temp(:,2) - mu14)) / & - real(nkeep,r_double) / ( sigma10 * sigma14 ) - deallocate( tb_temp ) - deallocate( p % cld_qc % CIRH2O ) - allocate( p % cld_qc % CIRH2O (1,1,1) ) - p % cld_qc % CIRH2O (1,1,1) = pearson + temp_max = bt_p ( p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(1), & + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(2), 1 ) + + p % superob(isup,jsup) % cld_qc(1) % RFMFT = abs( & + p % superob(isup,jsup) % cld_qc(1) % RFMFT + & + temp_max - bt_p( iysup, ixsup, 1 ) ) + + end if + else + if ( any( channel_list(ichan).eq.(/14,15/) ) ) then + + p % superob(isup,jsup) % cld_qc(1) % RFMFT = missing_r + + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij = -1 + + end if end if - else - if ( any( channel_list(ichan).eq.(/10,14/) ) ) then - if ( allocated( p % cld_qc % CIRH2O ) ) deallocate( p % cld_qc % CIRH2O) - allocate( p % cld_qc % CIRH2O (1,1,1)) - p % cld_qc % CIRH2O = missing_r + + ! Values for CIRH2O cloud QC + ! - channels 10 and 14 for Pearson correlation coefficient of CIRH2O test + tbuf = 2 + if (abi_halo_width-abi_superob_halfwidth.ge.tbuf .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0) then + + if (channel_list(ichan).eq.10) then + + allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O ( & + iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 2 ) ) + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O(:,:,1) = & + bt_p( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) + + end if + if (channel_list(ichan).eq.14 .and. & + size(p % superob(isup,jsup) % cld_qc(1) % CIRH2O).gt.1) then + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O(:,:,2) = & + bt_p( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) + nkeep = 0 + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf + if ( all(p % superob(isup,jsup) % cld_qc(1) % CIRH2O( jy, jx, : ) .gt. missing_r) ) nkeep = nkeep + 1 + end do + end do + allocate( tb_temp ( nkeep, 2 ) ) + ikeep = 0 + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf + if ( all(p % superob(isup,jsup) % cld_qc(1) % CIRH2O( jy, jx, : ) .gt. missing_r) ) then + ikeep = ikeep + 1 + tb_temp(ikeep,1) = & + p % superob(isup,jsup) % cld_qc(1) % CIRH2O( jy, jx, 1 ) + tb_temp(ikeep,2) = & + p % superob(isup,jsup) % cld_qc(1) % CIRH2O( jy, jx, 2 ) + end if + end do + end do + + mu10 = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma10 = sqrt( sum( (tb_temp(:,1) - mu10)**2 ) & + / real(nkeep,r_double) ) + + mu14 = sum( tb_temp(:,2) ) / real(nkeep,r_double) + sigma14 = sqrt( sum( (tb_temp(:,2) - mu14)**2 ) / & + real(nkeep,r_double) ) + + pearson = sum((tb_temp(:,1) - mu10) * (tb_temp(:,2) - mu14)) / & + real(nkeep,r_double) / ( sigma10 * sigma14 ) + + deallocate( tb_temp ) + deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O ) + allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O (1,1,1) ) + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O (1,1,1) = pearson + + end if + else + if ( any( channel_list(ichan).eq.(/10,14/) ) ) then + + if ( allocated( p % superob(isup,jsup) % cld_qc(1) % CIRH2O ) ) & + deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O) + + allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O (1,1,1)) + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O = missing_r + + end if end if - end if - ! Values for TEMPIR cloud QC - ! - channel 14 - if ( use_clddet_abi .and. (channel_list(ichan).eq.14) ) then - p % cld_qc % TEMPIR = missing_r - if ( TEMPIR_ifile.gt.0 .and. & - bt_p( iy, ix, 1 ).gt.missing_r ) then - if ( bt_p( iy, ix, 2 ).lt.330. ) & - p % cld_qc % TEMPIR = bt_p( iy, ix, 2 ) - bt_p( iy, ix, 1 ) + ! Values for TEMPIR cloud QC + ! - channel 14 + if ( use_clddet_abi .and. (channel_list(ichan).eq.14) ) then + + p % superob(isup,jsup) % cld_qc(1) % TEMPIR = missing_r + + if ( TEMPIR_ifile.gt.0 .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0 .and. & + bt_p( iysup, ixsup, 2 ).gt.0.0 ) then + if ( bt_p( iysup, ixsup, 2 ).lt.330. ) & + p % superob(isup,jsup) % cld_qc(1) % TEMPIR = & + bt_p( iysup, ixsup, 2 ) - bt_p( iysup, ixsup, 1 ) + end if + end if - end if + end do ! isup + end do ! jsup if (first_chan) & allocate (p % next) ! add next data @@ -1677,11 +1738,12 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end do PixelLoop if ( allocated(bt_p) ) deallocate ( bt_p ) + if ( allocated(rad_p) ) deallocate ( rad_p ) if ( allocated(allmask_p) ) deallocate ( allmask_p ) if ( allocated(readmask_p) ) deallocate ( readmask_p ) - if ( allocated(terrain_hgt) ) deallocate ( terrain_hgt ) end if VIEW_SELECT end do ChannelLoop + if ( allocated(terrain_hgt) ) deallocate ( terrain_hgt ) if ( allocated(thinmask) ) deallocate ( thinmask ) if ( allocated(solzen_1d) ) deallocate ( solzen_1d ) @@ -1712,7 +1774,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if (ipass .eq. 2) tot_files_used = tot_files_used + sum(view_att(iview) % nfiles_used) end do ! end view loop - + end do ! end pass loop if ( allocated(view_mask) ) deallocate(view_mask) @@ -1739,7 +1801,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! write(unit=message(1),fmt='(A)') "Either no L1B data found or no matching" ! write(unit=message(2),fmt='(A,I2,A)') "fgat windows for GOES-",satellite_id," ABI using" -! write(unit=message(3),fmt='(3A)') "prefix ",INST_PREFIX, " for this process rank." +! write(unit=message(3),fmt='(3A)') "prefix ",INST_PREFIX, " for this process rank." ! write(unit=message(4),fmt='(A)') "This subdomain may have an unacceptable zenith " ! write(unit=message(5),fmt='(A)') "angle or fall entirely outside the GOES viewing" ! write(unit=message(6),fmt='(A)') "extent." @@ -1822,12 +1884,18 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) prev => p end if deallocate ( current % tb_inv ) - ! deallocate ( current % cloud_flag ) - if ( associated(current % cld_qc ) ) then - if ( allocated ( current % cld_qc % CIRH2O ) ) & - deallocate ( current % cld_qc % CIRH2O ) - deallocate ( current % cld_qc % tb_stddev_3x3 ) - deallocate ( current % cld_qc ) + deallocate ( current % rad_obs ) + if ( allocated( current % superob ) ) then + do jsup = 1, superob_width + do isup = 1, superob_width + deallocate ( current % superob(isup,jsup) % tb_obs ) + if ( allocated ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O ) ) & + deallocate ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O ) + deallocate ( current % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3 ) + deallocate ( current % superob(isup,jsup) % cld_qc ) + end do + end do + deallocate ( current % superob ) end if deallocate ( current ) num_goesabi_thinned = num_goesabi_thinned + 1 @@ -1917,12 +1985,18 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! free current data deallocate ( current % tb_inv ) -!!! deallocate ( current % cloud_flag ) - if ( associated ( current % cld_qc ) ) then - if ( allocated ( current % cld_qc % CIRH2O ) ) & - deallocate ( current % cld_qc % CIRH2O ) - deallocate ( current % cld_qc % tb_stddev_3x3 ) - deallocate ( current % cld_qc ) + deallocate ( current % rad_obs ) + if ( allocated ( current % superob ) ) then + do jsup = 1, superob_width + do isup = 1, superob_width + deallocate ( current % superob(isup,jsup) % tb_obs ) + if ( allocated ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O ) ) & + deallocate ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O ) + deallocate ( current % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3 ) + deallocate ( current % superob(isup,jsup) % cld_qc ) + end do + end do + deallocate ( current % superob ) end if deallocate ( current ) end do @@ -2037,7 +2111,7 @@ subroutine get_abil1b_grid1( filename, & ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) ierr=nf_get_att_double(ncid,varid,'add_offset',itp) - yy_abi = yy_abi*slp+itp + yy_abi = yy_abi*slp+itp yoff = floor(itp/slp) ierr=nf_inq_varid(ncid,'x',varid) @@ -2096,7 +2170,7 @@ subroutine get_abil1b_grid2_1d( yy_abi, xx_abi, req, rpol, pph, nam, satellite_i call get_abil1b_latlon_1d ( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) where( lat.eq.missing_r .OR. lon.eq.missing_r .OR. & - isnan(lat) .OR. isnan(lon) ) + isnan(lat) .OR. isnan(lon) ) earthmask = .false. lat = missing_r lon = missing_r @@ -2116,7 +2190,8 @@ end subroutine get_abil1b_grid2_1d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt, inst, ichan ) +subroutine get_abil1b_rad( filename, ys, ye, xs, xe, radmask, inst, ichan, & + radout, bc1, bc2, fk1, fk2 ) implicit none character(*), intent(in) :: filename @@ -2124,11 +2199,12 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt, inst, ichan ) !Size of full data set !Starting and stopping indices of this view desired (not equivalent to Full Disk indices) - integer, intent(in) :: ys, ye, xs, xe + integer, intent(in) :: ys, ye, xs, xe integer, intent(in) :: inst, ichan logical, intent(inout) :: radmask( ys:ye, xs:xe ) - real, intent(out) :: bt( ys:ye, xs:xe ) + real, intent(out) :: radout( ys:ye, xs:xe ) + real, intent(out) :: bc1, bc2, fk1, fk2 real :: rad(xs:xe, ys:ye) integer :: DQF(xs:xe, ys:ye) @@ -2137,11 +2213,9 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt, inst, ichan ) integer :: iy, ix integer :: nykeep, nxkeep real :: slp, itp - real :: bc1, bc2, fk1, fk2 - if (trace_use) call da_trace_entry("get_abil1b_bt") + if (trace_use) call da_trace_entry("get_abil1b_rad") - bt = missing_r rad = missing_r !! Save rad reading time by selecting a subset of netcdf var @@ -2176,36 +2250,49 @@ subroutine get_abil1b_bt( filename, ys, ye, xs, xe, radmask, bt, inst, ichan ) ierr=nf_get_var_double( ncid, varid, fk2 ) radmask = ( radmask .and. (transpose(DQF).eq.0 .or. transpose(DQF).eq.1) ) - radmask = ( radmask .and. transpose(rad).ge.0.0 ) - - -!!!JJGDEBUG -! if (rtm_option == rtm_option_crtm) then -! do ix = xs, xe -! do iy = ys, ye -! if ( radmask( iy, ix ) ) then -!! call CRTM_Planck_Temperature(inst, ichan, rad( iy, ix ), bt( iy, ix )) -! call CRTM_Planck_Temperature(inst, ichan, rad( ix, iy ), bt( iy, ix )) -! end if -! end do -! end do -! else -!!!JJGDEBUG - - where ( radmask ) - bt = ( fk2 / ( log(( fk1 / transpose(rad) ) + 1.0) ) - bc1 ) / bc2 - end where - -!!!JJGDEBUG -! end if -!!!JJGDEBUG + radmask = ( radmask .and. transpose(rad).gt.0.0 ) + + radout = missing_r + where ( radmask ) + radout = transpose(rad) + end where ierr=nf_close(ncid) call handle_err('Error closing file',ierr) - if (trace_use) call da_trace_exit("get_abil1b_bt") + if (trace_use) call da_trace_exit("get_abil1b_rad") -end subroutine get_abil1b_bt +end subroutine get_abil1b_rad + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +elemental function rad2bt( rad, bc1, bc2, fk1, fk2 ) result(bt) + implicit none + + real, intent(in) :: rad + real, intent(in) :: bc1, bc2, fk1, fk2 + + real :: bt + + bt = ( fk2 / ( log(( fk1 / rad ) + 1.0) ) - bc1 ) / bc2 + +end function rad2bt + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +elemental function bt2rad( bt, bc1, bc2, fk1, fk2 ) result(rad) + implicit none + + real, intent(in) :: bt + real, intent(in) :: bc1, bc2, fk1, fk2 + + real :: rad + + rad = fk1 / ( exp( fk2 / (bc1 + bc2 * bt)) - 1.0 ) + +end function bt2rad !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -2218,7 +2305,7 @@ subroutine get_abil1b_terr( filename, ys, ye, xs, xe, terr ) !Size of full data set !Starting and stopping indices of this view desired (not equivalent to Full Disk indices) - integer, intent(in) :: ys, ye, xs, xe + integer, intent(in) :: ys, ye, xs, xe real, intent(out) :: terr( ys:ye, xs:xe ) ! unit = meters real :: terr_trans( xs:xe, ys:ye ) ! unit = meters @@ -2519,7 +2606,7 @@ subroutine handle_err(rmarker,nf_status) if (nf_status .ne. nf_noerr) then write(*,*) 'NetCDF error : ',rmarker write(*,*) ' ',nf_strerror(nf_status) - stop - endif + stop + endif end subroutine handle_err diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index 1593de57be..e41f0d1a22 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -70,7 +70,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(a)') ' pixel-info : i date scanpos landsea_mask elv lat lon satzen satazi' end if write(unit=innov_rad_unit,fmt='(a)') ' grid%xb-surf-info : i t2m mr2m(ppmv) u10 v10 ps ts smois tslb snowh isflg & - & soiltyp vegtyp vegfra elev clwp' + & soiltyp vegtyp vegfra elev clwp cloud_frac' ndomain = 0 do n =1,iv%instid(i)%num_rad if (iv%instid(i)%info%proc_domain(1,n)) then @@ -115,7 +115,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) case (7) ; surftype = 'MSNO : ' end select - write(unit=innov_rad_unit,fmt='(a,i7,9f10.2,3i3,f8.3,f10.2,f8.3)') surftype, n, & + write(unit=innov_rad_unit,fmt='(a,i7,9f10.2,3i3,f8.3,f10.2,f8.3,f15.5)') surftype, n, & iv%instid(i)%t2m(n), & iv%instid(i)%mr2m(n), & iv%instid(i)%u10(n), & @@ -130,7 +130,8 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) nint(iv%instid(i)%vegtyp(n)), & iv%instid(i)%vegfra(n), & iv%instid(i)%elevation(n), & - iv%instid(i)%clwp(n) + iv%instid(i)%clwp(n), & + iv%instid(i)%cloud_frac(n) write(unit=innov_rad_unit,fmt='(a)') 'OBS : ' write(unit=innov_rad_unit,fmt='(10f11.2)') ob%instid(i)%tb(:,n) @@ -148,7 +149,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=innov_rad_unit,fmt='(a)') 'QC : ' write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) - write(unit=innov_rad_unit,fmt='(a)') 'CLOUD : ' + write(unit=innov_rad_unit,fmt='(a)') 'CLOUD : ' write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) if ( abi .and. crtm_cloud(it) ) then ! write out cloud_mod, cloud_obs, tb_xb_clr write(unit=innov_rad_unit,fmt='(a)') 'CMOD : ' diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index 67518886bb..4e101ffb7f 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -61,7 +61,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) write(unit=oma_rad_unit,fmt='(a)') ' pixel-info : i date scanpos landsea_mask elv lat lon satzen satazi ' end if write(unit=oma_rad_unit,fmt='(a)') ' xb-surf-info : i t2m mr2m(ppmv) u10 v10 ps ts smois tslb snowh isflg & - & soiltyp vegtyp vegfra elev clwp' + & soiltyp vegtyp vegfra elev clwp cloud_frac' ndomain = 0 do n=1,iv%instid(i)%num_rad if (iv%instid(i)%info%proc_domain(1,n)) then @@ -106,7 +106,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) case (7) ; surftype = 'MSNO : ' end select - write(unit=oma_rad_unit,fmt='(a,i7,9f10.2,3i3,f8.3,f10.2,f8.3)') surftype, n, & + write(unit=oma_rad_unit,fmt='(a,i7,9f10.2,3i3,f8.3,f10.2,f8.3,f15.5)') surftype, n, & iv%instid(i)%t2m(n), & iv%instid(i)%mr2m(n), & iv%instid(i)%u10(n), & @@ -121,7 +121,8 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) nint(iv%instid(i)%vegtyp(n)), & iv%instid(i)%vegfra(n), & iv%instid(i)%elevation(n), & - iv%instid(i)%clwp(n) + iv%instid(i)%clwp(n), & + iv%instid(i)%cloud_frac(n) write(unit=oma_rad_unit,fmt='(a)') 'OBS : ' write(unit=oma_rad_unit,fmt='(10f11.2)') ob%instid(i)%tb(:,n) From cd663b3d79d41c172567b5a75c63934e150b6164 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 15 Jan 2020 11:09:29 -0700 Subject: [PATCH 56/86] Add solzen+solazi to rad diags --- var/da/da_monitor/da_rad_diags.f90 | 18 +++++++++++++++--- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 5 ++--- var/da/da_radiance/da_write_iv_rad_ascii.inc | 14 +++++++++----- var/da/da_radiance/da_write_oa_rad_ascii.inc | 14 +++++++++----- 4 files changed, 35 insertions(+), 16 deletions(-) diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index 26239996f1..37ed53f0c7 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -58,7 +58,8 @@ program da_rad_diags integer, dimension(:), allocatable :: landsea_mask, soiltyp, vegtyp real*4, dimension(:), allocatable :: lat, lon, elv, elev real*4, dimension(:), allocatable :: ret_clw - real*4, dimension(:), allocatable :: satzen, satazi, t2m, mr2m, u10, v10, ps, ts + real*4, dimension(:), allocatable :: satzen, satazi, solzen, solazi + real*4, dimension(:), allocatable :: t2m, mr2m, u10, v10, ps, ts real*4, dimension(:), allocatable :: smois, tslb, snowh, vegfra, clwp, cloud_frac integer, dimension(:,:), allocatable :: tb_qc, cloud_flag real*4, dimension(:,:), allocatable :: tb_obs, tb_bak, tb_inv, tb_oma, tb_err, ems, ems_jac @@ -232,6 +233,8 @@ program da_rad_diags allocate ( lon(1:total_npixel) ) allocate ( satzen(1:total_npixel) ) allocate ( satazi(1:total_npixel) ) + allocate ( solzen(1:total_npixel) ) + allocate ( solazi(1:total_npixel) ) allocate ( ret_clw(1:total_npixel) ) !obs retrieved clw allocate ( t2m(1:total_npixel) ) allocate ( mr2m(1:total_npixel) ) @@ -357,9 +360,10 @@ program da_rad_diags npixel_loop: do ipixel = ips, ipe - read(unit=iunit(iproc),fmt='(7x,i7,2x,a19,i6,i3,f6.0,4f8.2,f8.3)',iostat=ios) & + read(unit=iunit(iproc),fmt='(7x,i7,2x,a19,i6,i3,f6.0,6f8.2,f8.3)',iostat=ios) & n, datestr2(ipixel), scanpos(ipixel), landsea_mask(ipixel), elv(ipixel), & - lat(ipixel), lon(ipixel), satzen(ipixel), satazi(ipixel), ret_clw(ipixel) + lat(ipixel), lon(ipixel), satzen(ipixel), satazi(ipixel), solzen(ipixel), & + solazi(ipixel), ret_clw(ipixel) read(unit=iunit(iproc),fmt='(14x,9f10.2,3i3,f8.3,f10.2,f8.3,f15.5)',iostat=ios) & t2m(ipixel), mr2m(ipixel), u10(ipixel), v10(ipixel), ps(ipixel), ts(ipixel), & smois(ipixel), tslb(ipixel), snowh(ipixel), isflg(ipixel), soiltyp(ipixel), & @@ -614,6 +618,8 @@ program da_rad_diags ios = NF_DEF_VAR(ncid, 'lon', NF_FLOAT, 1, ishape(1), varid) ios = NF_DEF_VAR(ncid, 'satzen', NF_FLOAT, 1, ishape(1), varid) ios = NF_DEF_VAR(ncid, 'satazi', NF_FLOAT, 1, ishape(1), varid) + ios = NF_DEF_VAR(ncid, 'solzen', NF_FLOAT, 1, ishape(1), varid) + ios = NF_DEF_VAR(ncid, 'solazi', NF_FLOAT, 1, ishape(1), varid) ios = NF_DEF_VAR(ncid, 't2m', NF_FLOAT, 1, ishape(1), varid) ios = NF_DEF_VAR(ncid, 'mr2m', NF_FLOAT, 1, ishape(1), varid) ios = NF_DEF_VAR(ncid, 'u10', NF_FLOAT, 1, ishape(1), varid) @@ -815,6 +821,10 @@ program da_rad_diags ios = NF_PUT_VARA_REAL(ncid, varid, istart(2), icount(2), satzen) ios = NF_INQ_VARID (ncid, 'satazi', varid) ios = NF_PUT_VARA_REAL(ncid, varid, istart(2), icount(2), satazi) + ios = NF_INQ_VARID (ncid, 'solzen', varid) + ios = NF_PUT_VARA_REAL(ncid, varid, istart(2), icount(2), solzen) + ios = NF_INQ_VARID (ncid, 'solazi', varid) + ios = NF_PUT_VARA_REAL(ncid, varid, istart(2), icount(2), solazi) ios = NF_INQ_VARID (ncid, 't2m', varid) ios = NF_PUT_VARA_REAL(ncid, varid, istart(2), icount(2), t2m) ios = NF_INQ_VARID (ncid, 'mr2m', varid) @@ -868,6 +878,8 @@ program da_rad_diags deallocate ( lon ) deallocate ( satzen ) deallocate ( satazi ) + deallocate ( solzen ) + deallocate ( solazi ) deallocate ( t2m ) deallocate ( mr2m ) deallocate ( u10 ) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 147d7e4a4d..6620592c3b 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -1739,15 +1739,14 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end do PixelLoop if ( allocated(bt_p) ) deallocate ( bt_p ) if ( allocated(rad_p) ) deallocate ( rad_p ) + if ( allocated(solzen_1d) ) deallocate ( solzen_1d ) + if ( allocated(solazi_1d) ) deallocate ( solazi_1d ) if ( allocated(allmask_p) ) deallocate ( allmask_p ) if ( allocated(readmask_p) ) deallocate ( readmask_p ) end if VIEW_SELECT end do ChannelLoop if ( allocated(terrain_hgt) ) deallocate ( terrain_hgt ) - if ( allocated(thinmask) ) deallocate ( thinmask ) - if ( allocated(solzen_1d) ) deallocate ( solzen_1d ) - if ( allocated(solazi_1d) ) deallocate ( solazi_1d ) else write(unit=stdout,fmt='(A)') & ' No pixels to read within this subdomain. Waiting for other processors...' diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index e41f0d1a22..bd18bb19e1 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -65,9 +65,9 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) ' index-of-channels : ' write(unit=innov_rad_unit,fmt='(10i5)') iv%instid(i)%ichan if ( amsr2 ) then - write(unit=innov_rad_unit,fmt='(a)') ' pixel-info : i date scanpos landsea_mask elv lat lon satzen satazi clw' + write(unit=innov_rad_unit,fmt='(a)') ' pixel-info : i date scanpos landsea_mask elv lat lon satzen satazi solzen solazi clw' else - write(unit=innov_rad_unit,fmt='(a)') ' pixel-info : i date scanpos landsea_mask elv lat lon satzen satazi' + write(unit=innov_rad_unit,fmt='(a)') ' pixel-info : i date scanpos landsea_mask elv lat lon satzen satazi solzen solazi' end if write(unit=innov_rad_unit,fmt='(a)') ' grid%xb-surf-info : i t2m mr2m(ppmv) u10 v10 ps ts smois tslb snowh isflg & & soiltyp vegtyp vegfra elev clwp cloud_frac' @@ -76,7 +76,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) if (iv%instid(i)%info%proc_domain(1,n)) then ndomain=ndomain+1 if ( amsr2 ) then ! write out clw - write(unit=innov_rad_unit,fmt='(a,i7,2x,a,i6,i3,f6.0,4f8.2,f8.3)') 'INFO : ', ndomain, & + write(unit=innov_rad_unit,fmt='(a,i7,2x,a,i6,i3,f6.0,6f8.2,f8.3)') 'INFO : ', ndomain, & iv%instid(i)%info%date_char(n), & iv%instid(i)%scanpos(n), & iv%instid(i)%landsea_mask(n), & @@ -85,9 +85,11 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) iv%instid(i)%info%lon(1,n), & iv%instid(i)%satzen(n), & iv%instid(i)%satazi(n), & + iv%instid(i)%solzen(n), & + iv%instid(i)%solazi(n), & iv%instid(i)%clw(n) else ! no clw info - write(unit=innov_rad_unit,fmt='(a,i7,2x,a,i6,i3,f6.0,4f8.2)') 'INFO : ', ndomain, & + write(unit=innov_rad_unit,fmt='(a,i7,2x,a,i6,i3,f6.0,6f8.2)') 'INFO : ', ndomain, & iv%instid(i)%info%date_char(n), & iv%instid(i)%scanpos(n), & iv%instid(i)%landsea_mask(n), & @@ -95,7 +97,9 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) iv%instid(i)%info%lat(1,n), & iv%instid(i)%info%lon(1,n), & iv%instid(i)%satzen(n), & - iv%instid(i)%satazi(n) + iv%instid(i)%satazi(n), & + iv%instid(i)%solzen(n), & + iv%instid(i)%solazi(n) end if select case (iv%instid(i)%isflg(n)) case (0) ; diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index 4e101ffb7f..db89774ae1 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -56,9 +56,9 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) ' index-of-channels : ' write(unit=oma_rad_unit,fmt='(10i5)') iv%instid(i)%ichan if ( amsr2 ) then - write(unit=oma_rad_unit,fmt='(a)') ' pixel-info : i date scanpos landsea_mask elv lat lon satzen satazi clw' + write(unit=oma_rad_unit,fmt='(a)') ' pixel-info : i date scanpos landsea_mask elv lat lon satzen satazi solzen solazi clw' else - write(unit=oma_rad_unit,fmt='(a)') ' pixel-info : i date scanpos landsea_mask elv lat lon satzen satazi ' + write(unit=oma_rad_unit,fmt='(a)') ' pixel-info : i date scanpos landsea_mask elv lat lon satzen satazi solzen solazi ' end if write(unit=oma_rad_unit,fmt='(a)') ' xb-surf-info : i t2m mr2m(ppmv) u10 v10 ps ts smois tslb snowh isflg & & soiltyp vegtyp vegfra elev clwp cloud_frac' @@ -67,7 +67,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) if (iv%instid(i)%info%proc_domain(1,n)) then ndomain=ndomain+1 if ( amsr2 ) then !write out clw - write(unit=oma_rad_unit,fmt='(a,i7,2x,a,i6,i3,f6.0,4f8.2,f8.3)') 'INFO : ', ndomain, & + write(unit=oma_rad_unit,fmt='(a,i7,2x,a,i6,i3,f6.0,6f8.2,f8.3)') 'INFO : ', ndomain, & iv%instid(i)%info%date_char(n), & iv%instid(i)%scanpos(n), & iv%instid(i)%landsea_mask(n), & @@ -76,9 +76,11 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) iv%instid(i)%info%lon(1,n), & iv%instid(i)%satzen(n), & iv%instid(i)%satazi(n), & + iv%instid(i)%solzen(n), & + iv%instid(i)%solazi(n), & iv%instid(i)%clw(n) else !no clw info - write(unit=oma_rad_unit,fmt='(a,i7,2x,a,i6,i3,f6.0,4f8.2)') 'INFO : ', ndomain, & + write(unit=oma_rad_unit,fmt='(a,i7,2x,a,i6,i3,f6.0,6f8.2)') 'INFO : ', ndomain, & iv%instid(i)%info%date_char(n), & iv%instid(i)%scanpos(n), & iv%instid(i)%landsea_mask(n), & @@ -86,7 +88,9 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) iv%instid(i)%info%lat(1,n), & iv%instid(i)%info%lon(1,n), & iv%instid(i)%satzen(n), & - iv%instid(i)%satazi(n) + iv%instid(i)%satazi(n), & + iv%instid(i)%solzen(n), & + iv%instid(i)%solazi(n) end if select case (iv%instid(i)%isflg(n)) case (0) ; From 8d386b5c6d1f670d9a9dfbc394c950bf34baeb97 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Wed, 15 Jan 2020 16:31:41 -0700 Subject: [PATCH 57/86] Remove pixels with all missing tb_obs --- var/da/da_radiance/da_get_innov_vector_crtm.inc | 8 ++++++++ var/da/da_radiance/da_read_obs_ncgoesabi.inc | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index c61897cafb..6b20011e4e 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -480,6 +480,14 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) cycle pixel_loop end if end do + if ( all(ob%instid(inst)%tb(1:nchanl,n) < 0.) ) then + write(message(1),'(a,2i5.0,a)') ' Skipping the pixel at loc ', i, j, & + ' where all observed BTs are < 0' + call da_warning(__FILE__,__LINE__,message(1:1)) + iv%instid(inst)%tb_inv(:,n) = missing_r + iv%instid(inst)%info%proc_domain(:,n) = .false. + cycle pixel_loop + end if ! convert cloud content unit from kg/kg to kg/m^2 if (crtm_cloud(it)) then diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 6620592c3b..485a8a2bd7 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -1854,7 +1854,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) deallocate( out ) #endif - ! Delete the nodes which being thinning out + ! Delete the nodes being thinned out p => head prev => head head_found = .false. From d0227ad01c121d0e6b560a6dbe19f4eedfd87c93 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Thu, 16 Jan 2020 14:51:25 -0700 Subject: [PATCH 58/86] Enable GOES-17 --- var/da/da_radiance/da_get_sat_angles_1d.inc | 7 +++---- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 17 ++++++++++------- .../da_setup_radiance_structures.inc | 2 +- 3 files changed, 14 insertions(+), 12 deletions(-) diff --git a/var/da/da_radiance/da_get_sat_angles_1d.inc b/var/da/da_radiance/da_get_sat_angles_1d.inc index a7d4e4385c..64b65d71cf 100644 --- a/var/da/da_radiance/da_get_sat_angles_1d.inc +++ b/var/da/da_radiance/da_get_sat_angles_1d.inc @@ -53,10 +53,9 @@ subroutine da_get_sat_angles_1d ( lat, lon, sate_index, satzen, satazi ) else if (sate_index .eq. 15) then alon_sat = -135. * deg2rad else if (sate_index .eq. 16) then -! alon_sat = -75.2 * deg2rad !True Value? - alon_sat = -75. * deg2rad !Nominal Value -! else if (sate_index .eq. 17) then -! alon_sat = -137. * deg2rad + alon_sat = -75.2 * deg2rad + else if (sate_index .eq. 17) then + alon_sat = -137.2 * deg2rad else write(*,*)'this satellite is not included' stop diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 485a8a2bd7..f0e08b546c 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -211,7 +211,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) real :: mu, sigma real, allocatable :: tb_temp(:,:) logical :: cldqc - character(18), parameter :: terr_fname = 'OR_ABI-TERR_G16.nc' + character(18) :: terr_fname integer :: TEMPIR_ifile real :: TEMPIR_min_time_diff, TEMPIR_time_abs_diff @@ -227,6 +227,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) return endif + write(terr_fname,'(A,I2.2,A)') 'OR_ABI-TERR_G',satellite_id,'.nc' + ! determine if sensor triplet is in the sensor list !----------------------------------------------------- inst = 0 @@ -240,7 +242,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) end if end do if (inst == 0) then - write(unit=message(1),fmt='(A,I2,A)') " goes-",satellite_id,"-abi is not in sensor list" + write(unit=message(1),fmt='(A,I2.2,A)') " goes-",satellite_id,"-abi is not in sensor list" call da_warning(__FILE__,__LINE__, message(1:1)) return end if @@ -287,10 +289,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) view_att(3) % name = 'MESO1' view_att(4) % name = 'MESO2' - view_att(1) % fpath = "./goes-fdisk*/" - view_att(2) % fpath = "./goes-conus*/" - view_att(3) % fpath = "./goes-meso*/" - view_att(4) % fpath = "./goes-meso*/" + write(view_att(1) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-fdisk*/" + write(view_att(2) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-conus*/" + write(view_att(3) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-meso*/" + write(view_att(4) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-meso*/" ! (default) Full Disk and CONUS are fixed while MESO 1 & 2 can move within an assimilation window view_att(1) % moving = .false. @@ -334,7 +336,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Query fpath for files that match L1B naming conventions for this_view and satellite_id fname = trim(INST_PREFIX)//trim(this_view % name_short) - list_file = 'file_list_GOES-ABI_'//trim(this_view % name_short) + write(list_file,'(A,I2.2,2A)') & + 'file_list_GOES-',satellite_id,'-ABI_',trim(this_view % name_short) call da_get_unit(file_unit) diff --git a/var/da/da_radiance/da_setup_radiance_structures.inc b/var/da/da_radiance/da_setup_radiance_structures.inc index e03758a9a1..450d4b5252 100644 --- a/var/da/da_radiance/da_setup_radiance_structures.inc +++ b/var/da/da_radiance/da_setup_radiance_structures.inc @@ -267,7 +267,7 @@ subroutine da_setup_radiance_structures( grid, ob, iv ) call da_read_obs_ncgoesabi(iv, 16) -! call da_read_obs_ncgoesabi(iv, 17) + call da_read_obs_ncgoesabi(iv, 17) end if end if From fb67cf7dd676221e3a4a68c393701cecedb97e17 Mon Sep 17 00:00:00 2001 From: jjguerrette Date: Mon, 30 Mar 2020 15:22:01 -0600 Subject: [PATCH 59/86] Add terrain grid debug prints --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index f0e08b546c..ddb2a3c6ac 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -1411,12 +1411,18 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) this_view % xs_local:this_view % xe_local ) ) ! Read terrain file using Full Disk global indices + write(*,*) 'DEBUG da_read_obs_ncgoesabi, ys_local, ye_local, yoff_fd-1: ', & + this_view % ys_local, this_view % ye_local, this_view % yoff_fd-1 + write(*,*) 'DEBUG da_read_obs_ncgoesabi, xs_local, xe_local, xoff_fd-1: ', & + this_view % xs_local, this_view % xe_local, this_view % xoff_fd-1 + call get_abil1b_terr( terr_fname, & this_view % ys_local + this_view % yoff_fd - 1, & this_view % ye_local + this_view % yoff_fd - 1, & this_view % xs_local + this_view % xoff_fd - 1, & this_view % xe_local + this_view % xoff_fd - 1, & terrain_hgt ) + end if allocate(thinmask(this_view % ys_p:this_view % ye_p, & @@ -2331,6 +2337,9 @@ subroutine get_abil1b_terr( filename, ys, ye, xs, xe, terr ) nf_open(trim(filename),nf_nowrite,ncid) ) call handle_err ( 'Error getting terr ID', & nf_inq_varid( ncid, 'terr', varid ) ) + + write(*,*) 'DEBUG get_abil1b_terr, xs, ys, xs+nxkeep, ys+nykeep: ',xs,ys,xs+nxkeep,ys+nykeep + call handle_err ( 'Error reading terrain height', & nf_get_vara_double ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), terr_trans ) ) terr = transpose(terr_trans) From e74774f373d47edff4513615645e378afde64a22 Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 10:54:24 -0700 Subject: [PATCH 60/86] modified: Registry/registry.var --- Registry/registry.var | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Registry/registry.var b/Registry/registry.var index bf06b0a52b..5426277aa6 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -437,7 +437,7 @@ rconfig logical tovs_batch namelist,wrfvar14 1 .false. - "to rconfig integer rtm_option namelist,wrfvar14 1 1 - "rtm_option" "" "" rconfig logical use_crtm_kmatrix namelist,wrfvar14 1 .true. - "use_crtm_kmatrix" "" "" rconfig logical use_rttov_kmatrix namelist,wrfvar14 1 .false. - "use_rttov_kmatrix" "" "" -rconfig logical crtm_cloud namelist,wrfvar14 max_outer_iterations .false. - "crtm_cloud" "" "" +rconfig logical crtm_cloud namelist,wrfvar14 1 .false. - "crtm_cloud" "" "" rconfig logical only_sea_rad namelist,wrfvar14 1 .false. - "only_sea_rad" "" "" rconfig logical use_pseudo_rad namelist,wrfvar14 1 .false. - "use_pseudo_rad" "" "" rconfig integer pseudo_rad_platid namelist,wrfvar14 1 1 - "pseudo_rad_platid" "" "" From 93e5f9097fc49d496851547ecdcc290f403b7238 Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 11:00:00 -0700 Subject: [PATCH 61/86] modified: Registry/registry.var --- Registry/registry.var | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Registry/registry.var b/Registry/registry.var index 5426277aa6..5eb260f25a 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -457,11 +457,10 @@ rconfig logical freeze_varbc namelist,wrfvar14 1 .false. - "fr rconfig real varbc_factor namelist,wrfvar14 1 1.0 - "varbc_factor" "" "" rconfig integer varbc_nbgerr namelist,wrfvar14 1 5000 - "varbc_nbgerr" "" "" rconfig integer varbc_nobsmin namelist,wrfvar14 1 10 - "varbc_nobsmin" "" "" -rconfig logical use_clddet_abi namelist,wrfvar14 1 .false. - "use_clddet_abi" "" "" -rconfig logical use_rad_symm_err namelist,wrfvar14 1 .true. - "use_rad_symm_err" "" "" rconfig integer use_clddet namelist,wrfvar14 1 2 - "use_clddet" "0: off, 1: mmr, 2: pf, 3: ecmwf" "" rconfig logical use_clddet_zz namelist,wrfvar14 1 .false. - "use_clddet_zz" "cloud detection scheme from Zhuge X. and Zou X. JAMC, 2016." "" rconfig integer ahi_superob_halfwidth namelist,wrfvar14 1 0 - "ahi_superob_halfwidth" "" "" +rconfig integer abi_superob_halfwidth namelist,wrfvar14 1 0 - "abi_superob_halfwidth" "" "" rconfig logical airs_warmest_fov namelist,wrfvar14 1 .false. - "airs_warmest_fov" "" "" rconfig logical use_satcv namelist,wrfvar14 2 .false. - "use_satcv" "" "" rconfig logical use_blacklist_rad namelist,wrfvar14 1 .true. - "use_blacklist_rad" "" "" @@ -471,6 +470,7 @@ rconfig character crtm_irwater_coef namelist,wrfvar14 1 "Nalli.IRwater rconfig character crtm_mwwater_coef namelist,wrfvar14 1 "FASTEM5.MWwater.EmisCoeff.bin" - "crtm_mwwater_coef" "" "" rconfig character crtm_irland_coef namelist,wrfvar14 1 "USGS.IRland.EmisCoeff.bin" - "crtm_irland_coef" "" "" rconfig character crtm_visland_coef namelist,wrfvar14 1 "USGS.VISland.EmisCoeff.bin" - "crtm_visland_coef" "" "" +rconfig logical abi_use_symm_obs_err namelist,wrfvar14 1 .false. - "abi_use_symm_obs_err" "" "" rconfig logical ahi_use_symm_obs_err namelist,wrfvar14 1 .false. - "ahi_use_symm_obs_err" "" "" rconfig logical ahi_apply_clrsky_bias namelist,wrfvar14 1 .false. - "ahi_apply_clrsky_bias" "" "" rconfig integer num_pseudo namelist,wrfvar15 1 0 - "num_pseudo" "" "" From c4b29d4ebe542c7b1a2a9f4b60f139a0aea77b4a Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 11:04:31 -0700 Subject: [PATCH 62/86] modified: var/da/da_control/da_control.f90 --- var/da/da_control/da_control.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/var/da/da_control/da_control.f90 b/var/da/da_control/da_control.f90 index 5f62efcdd1..5abe3ff927 100644 --- a/var/da/da_control/da_control.f90 +++ b/var/da/da_control/da_control.f90 @@ -52,7 +52,7 @@ module da_control real, parameter :: gravity = 9.81 ! m/s - value used in WRF. ! real, parameter :: earth_radius = 6378.15 real, parameter :: earth_radius = 6370.0 ! Be consistant with WRF - real, parameter :: satellite_height = 35800.0 ! used by da_get_sat_angles + real, parameter :: satellite_height = 35800.0 ! used by da_get_satzen ! real, parameter :: earth_omega = 2.0*pi/86400.0 ! Omega real, parameter :: earth_omega = 0.000072921 ! Omega 7.2921*10**-5 From 0e29322063325d40eac8030f7ef58add40741b8e Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 11:10:49 -0700 Subject: [PATCH 63/86] modified: var/da/da_main/da_solve.inc --- var/da/da_main/da_solve.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/var/da/da_main/da_solve.inc b/var/da/da_main/da_solve.inc index 1cfe03fa25..a2ce91ccba 100644 --- a/var/da/da_main/da_solve.inc +++ b/var/da/da_main/da_solve.inc @@ -465,7 +465,7 @@ call da_calculate_grady(iv, re, jo_grad_y) call da_zero_x(grid%xa) - call da_transform_xtoy_adj(1, cv_size, xhat, grid, iv, jo_grad_y, grid%xa) + call da_transform_xtoy_adj(cv_size, xhat, grid, iv, jo_grad_y, grid%xa) call da_transform_xtoxa_adj(grid) call da_transfer_wrftltoxa_adj(grid, config_flags, 'fcst', timestr) From 314977ff2695110765ee971d191f6f460a4c2198 Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 11:20:58 -0700 Subject: [PATCH 64/86] modified: var/da/da_minimisation/da_calculate_gradj.inc modified: var/da/da_minimisation/da_calculate_j.inc modified: var/da/da_minimisation/da_sensitivity.inc modified: var/da/da_minimisation/da_transform_vtoy.inc modified: var/da/da_minimisation/da_transform_vtoy_adj.inc --- var/da/da_minimisation/da_calculate_gradj.inc | 6 +++--- var/da/da_minimisation/da_calculate_j.inc | 4 ++-- var/da/da_minimisation/da_sensitivity.inc | 4 ++-- var/da/da_minimisation/da_transform_vtoy.inc | 5 ++--- var/da/da_minimisation/da_transform_vtoy_adj.inc | 3 +-- 5 files changed, 10 insertions(+), 12 deletions(-) diff --git a/var/da/da_minimisation/da_calculate_gradj.inc b/var/da/da_minimisation/da_calculate_gradj.inc index 9fa6d86f8a..1d47f0bc1f 100644 --- a/var/da/da_minimisation/da_calculate_gradj.inc +++ b/var/da/da_minimisation/da_calculate_gradj.inc @@ -94,7 +94,7 @@ subroutine da_calculate_gradj(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size call da_calculate_grady(iv, re, jo_grad_y) if ( iter > 0 .and. test_gradient ) jcdf_flag = .true. #ifdef VAR4D - call da_transform_vtoy_adj(it, cv_size, be, grid%ep, grad_jo, iv, & + call da_transform_vtoy_adj(cv_size, be, grid%ep, grad_jo, iv, & grid%vp, grid%vv, xbx, jo_grad_y, grid, config_flags, jcdf_flag, grid%vp6, grid%vv6) #else call da_transform_vtoy_adj(cv_size, be, grid%ep, grad_jo, iv, & @@ -107,7 +107,7 @@ subroutine da_calculate_gradj(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size #endif else #ifdef VAR4D - call da_transform_vtoy(it, cv_size, be, grid%ep, cv, iv, grid%vp, & + call da_transform_vtoy(cv_size, be, grid%ep, cv, iv, grid%vp, & grid%vv, xbx, y, grid, config_flags, grid%vp6, grid%vv6) #else call da_transform_vtoy(cv_size, be, grid%ep, cv, iv, grid%vp, & @@ -119,7 +119,7 @@ subroutine da_calculate_gradj(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size #endif call da_calculate_grady(iv, y, jo_grad_y) #ifdef VAR4D - call da_transform_vtoy_adj(it, cv_size, be, grid%ep, grad_jo, iv, & + call da_transform_vtoy_adj(cv_size, be, grid%ep, grad_jo, iv, & grid%vp, grid%vv, xbx, jo_grad_y, grid, config_flags, .true., grid%vp6, grid%vv6) #else call da_transform_vtoy_adj(cv_size, be, grid%ep, grad_jo, iv, & diff --git a/var/da/da_minimisation/da_calculate_j.inc b/var/da/da_minimisation/da_calculate_j.inc index 710c11aaab..fb45711f62 100644 --- a/var/da/da_minimisation/da_calculate_j.inc +++ b/var/da/da_minimisation/da_calculate_j.inc @@ -86,11 +86,11 @@ subroutine da_calculate_j(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size_jp, if (iter > 0) then #ifdef VAR4D - call da_transform_vtoy(it, cv_size, be, grid%ep, xhat, iv, grid%vp, grid%vv,& + call da_transform_vtoy(cv_size, be, grid%ep, xhat, iv, grid%vp, grid%vv,& xbx, y, & grid, config_flags, grid%vp6, grid%vv6) #else - call da_transform_vtoy(it, cv_size, be, grid%ep, xhat, iv, grid%vp, grid%vv,& + call da_transform_vtoy(cv_size, be, grid%ep, xhat, iv, grid%vp, grid%vv,& xbx, y, & grid, config_flags & !!When vch includes initial conditions, need to add vch=grid%vch at end of this call diff --git a/var/da/da_minimisation/da_sensitivity.inc b/var/da/da_minimisation/da_sensitivity.inc index 37478b2eff..68767bf75d 100644 --- a/var/da/da_minimisation/da_sensitivity.inc +++ b/var/da/da_minimisation/da_sensitivity.inc @@ -63,10 +63,10 @@ subroutine da_sensitivity(grid, config_flags, it, cv_size, xbx, be, iv, xhat, qh ! Apply observation operator H #ifdef VAR4D - call da_transform_vtoy(it, cv_size, be, grid%ep, amat, iv, grid%vp, grid%vv, & + call da_transform_vtoy(cv_size, be, grid%ep, amat, iv, grid%vp, grid%vv, & xbx, ktr, grid, config_flags, grid%vp6, grid%vv6) #else - call da_transform_vtoy(it, cv_size, be, grid%ep, amat, iv, grid%vp, grid%vv, & + call da_transform_vtoy(cv_size, be, grid%ep, amat, iv, grid%vp, grid%vv, & xbx, ktr, grid, config_flags) #endif diff --git a/var/da/da_minimisation/da_transform_vtoy.inc b/var/da/da_minimisation/da_transform_vtoy.inc index fa9a3aaf03..4ae63cae98 100644 --- a/var/da/da_minimisation/da_transform_vtoy.inc +++ b/var/da/da_minimisation/da_transform_vtoy.inc @@ -11,7 +11,6 @@ subroutine da_transform_vtoy(cv_size, be, ep, cv, iv, vp, vv, xbx, & implicit none - integer, intent(in) :: it ! external iteration #. integer, intent(in) :: cv_size ! Size of cv array. type(be_type), intent(in) :: be ! background error structure. type(ep_type), intent(in) :: ep ! Ensemble perturbation structure. @@ -118,7 +117,7 @@ subroutine da_transform_vtoy(cv_size, be, ep, cv, iv, vp, vv, xbx, & g_rainnc(:,:,nobwin)=grid%g_rainnc(:,:) endif call da_transform_xtoxa(grid) - call da_transform_xtoy(it, cv_size, cv, grid, iv, y) + call da_transform_xtoy(cv_size, cv, grid, iv, y) if ( nobwin > 1 ) call domain_clockadvance (grid) ! We don't need the advance at the last step call domain_clockprint(150, grid, 'DEBUG : get CurrTime from clock,') @@ -220,7 +219,7 @@ subroutine da_transform_vtoy(cv_size, be, ep, cv, iv, vp, vv, xbx, & iv%instid(:)%info%n2 = iv%instid(:)%num_rad end if end if !4denvar - call da_transform_xtoy(it, cv_size, cv, grid, iv, y) + call da_transform_xtoy(cv_size, cv, grid, iv, y) end do end if ! var4d diff --git a/var/da/da_minimisation/da_transform_vtoy_adj.inc b/var/da/da_minimisation/da_transform_vtoy_adj.inc index c754dba775..83c2aab12a 100644 --- a/var/da/da_minimisation/da_transform_vtoy_adj.inc +++ b/var/da/da_minimisation/da_transform_vtoy_adj.inc @@ -10,7 +10,6 @@ subroutine da_transform_vtoy_adj(cv_size, be, ep, cv, iv, vp, vv, xbx, y, & implicit none - integer, intent(in) :: it ! external iteration #. integer, intent(in) :: cv_size ! Size of cv array. type(be_type), intent(in) :: be ! background error structure. type(ep_type), intent(in) :: ep ! ensemble perturbation structure. @@ -146,7 +145,7 @@ subroutine da_transform_vtoy_adj(cv_size, be, ep, cv, iv, vp, vv, xbx, y, & call da_zero_x(grid%xa) grid%g_rainnc = 0.0 grid%g_rainc = 0.0 - call da_transform_xtoy_adj(it, cv_size, cv, grid, iv, y, grid%xa) + call da_transform_xtoy_adj(cv_size, cv, grid, iv, y, grid%xa) call da_transform_xtoxa_adj(grid) write(unit=filnam,fmt='(a2,i2.2)') 'af',nobwin From c440acc973f37177886f0dc1e483d25c6d80d4fb Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 12:57:54 -0700 Subject: [PATCH 65/86] modified: var/da/da_obs/da_transform_xtoy.inc modified: var/da/da_obs/da_transform_xtoy_adj.inc --- var/da/da_obs/da_transform_xtoy.inc | 5 ++--- var/da/da_obs/da_transform_xtoy_adj.inc | 4 ++-- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/var/da/da_obs/da_transform_xtoy.inc b/var/da/da_obs/da_transform_xtoy.inc index 1e91bdd29d..d0240f94dd 100644 --- a/var/da/da_obs/da_transform_xtoy.inc +++ b/var/da/da_obs/da_transform_xtoy.inc @@ -1,4 +1,4 @@ -subroutine da_transform_xtoy(it, cv_size, cv, grid, iv, y) +subroutine da_transform_xtoy(cv_size, cv, grid, iv, y) !------------------------------------------------------------------------- ! Purpose: TBD @@ -6,7 +6,6 @@ subroutine da_transform_xtoy(it, cv_size, cv, grid, iv, y) implicit none - integer, intent(in) :: it ! external iteration #. integer, intent(in) :: cv_size ! Size of cv array. real, intent(in) :: cv(1:cv_size) ! control variables. type (domain), intent(inout) :: grid @@ -70,7 +69,7 @@ subroutine da_transform_xtoy(it, cv_size, cv, grid, iv, y) !else if (use_crtm_kmatrix_fast) then ! call da_transform_xtoy_crtmk_f (grid, iv, y) !else - call da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y) + call da_transform_xtoy_crtm (cv_size, cv, grid, iv, y) !end if #endif else diff --git a/var/da/da_obs/da_transform_xtoy_adj.inc b/var/da/da_obs/da_transform_xtoy_adj.inc index bb708d00dd..fec16ce8b2 100644 --- a/var/da/da_obs/da_transform_xtoy_adj.inc +++ b/var/da/da_obs/da_transform_xtoy_adj.inc @@ -11,7 +11,7 @@ subroutine da_transform_xtoy_adj(cv_size, cv, grid, iv, jo_grad_y, jo_grad_x & !-------------------------------------------------------------------------- implicit none - + integer, intent(in) :: cv_size ! Size of cv array. real, intent(inout) :: cv(1:cv_size) ! control variables. type (domain), intent(inout) :: grid @@ -120,7 +120,7 @@ subroutine da_transform_xtoy_adj(cv_size, cv, grid, iv, jo_grad_y, jo_grad_x & #endif elseif (rtm_option == rtm_option_crtm) then #ifdef CRTM - call da_transform_xtoy_crtm_adj (it, cv_size, cv, iv, jo_grad_y, jo_grad_x) + call da_transform_xtoy_crtm_adj (cv_size, cv, iv, jo_grad_y, jo_grad_x) #endif else call da_warning(__FILE__,__LINE__,(/"Unknown radiative transfer model"/)) From e5c3603cf4eb4dbb5b9b20bf06d843e5007967c3 Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 13:00:11 -0700 Subject: [PATCH 66/86] modified: var/da/da_obs/da_transform_xtoy.inc modified: var/da/da_obs/da_transform_xtoy_adj.inc --- var/da/da_obs/da_transform_xtoy.inc | 2 +- var/da/da_obs/da_transform_xtoy_adj.inc | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/var/da/da_obs/da_transform_xtoy.inc b/var/da/da_obs/da_transform_xtoy.inc index d0240f94dd..db05bd81d7 100644 --- a/var/da/da_obs/da_transform_xtoy.inc +++ b/var/da/da_obs/da_transform_xtoy.inc @@ -5,7 +5,7 @@ subroutine da_transform_xtoy(cv_size, cv, grid, iv, y) !------------------------------------------------------------------------- implicit none - + integer, intent(in) :: cv_size ! Size of cv array. real, intent(in) :: cv(1:cv_size) ! control variables. type (domain), intent(inout) :: grid diff --git a/var/da/da_obs/da_transform_xtoy_adj.inc b/var/da/da_obs/da_transform_xtoy_adj.inc index fec16ce8b2..489c25a6eb 100644 --- a/var/da/da_obs/da_transform_xtoy_adj.inc +++ b/var/da/da_obs/da_transform_xtoy_adj.inc @@ -11,7 +11,7 @@ subroutine da_transform_xtoy_adj(cv_size, cv, grid, iv, jo_grad_y, jo_grad_x & !-------------------------------------------------------------------------- implicit none - + integer, intent(in) :: cv_size ! Size of cv array. real, intent(inout) :: cv(1:cv_size) ! control variables. type (domain), intent(inout) :: grid From 5e7ef0c060a00ce45aa5d1828a549249e4890bec Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 13:01:46 -0700 Subject: [PATCH 67/86] modified: var/da/da_obs/da_transform_xtoy.inc --- var/da/da_obs/da_transform_xtoy.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/var/da/da_obs/da_transform_xtoy.inc b/var/da/da_obs/da_transform_xtoy.inc index db05bd81d7..d0240f94dd 100644 --- a/var/da/da_obs/da_transform_xtoy.inc +++ b/var/da/da_obs/da_transform_xtoy.inc @@ -5,7 +5,7 @@ subroutine da_transform_xtoy(cv_size, cv, grid, iv, y) !------------------------------------------------------------------------- implicit none - + integer, intent(in) :: cv_size ! Size of cv array. real, intent(in) :: cv(1:cv_size) ! control variables. type (domain), intent(inout) :: grid From 1032f4592867e82f61f5fa8b869c407ccbdeda8e Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 13:51:39 -0700 Subject: [PATCH 68/86] modified: var/da/da_obs/da_transform_xtoy.inc modified: var/da/da_obs/da_transform_xtoy_adj.inc modified: var/da/da_radiance/da_allocate_rad_iv.inc modified: var/da/da_radiance/da_crtm.f90 modified: var/da/da_radiance/da_deallocate_radiance.inc modified: var/da/da_radiance/da_get_innov_vector_crtm.inc modified: var/da/da_radiance/da_get_innov_vector_crtmk.inc modified: var/da/da_radiance/da_get_innov_vector_rttov.inc new file: var/da/da_radiance/da_get_satzen.inc modified: var/da/da_radiance/da_initialize_rad_iv.inc modified: var/da/da_radiance/da_qc_amsr2.inc modified: var/da/da_radiance/da_qc_amsub.inc modified: var/da/da_radiance/da_qc_goesimg.inc modified: var/da/da_radiance/da_radiance1.f90 modified: var/da/da_radiance/da_read_obs_ncgoesimg.inc modified: var/da/da_radiance/da_rttov.f90 modified: var/da/da_radiance/da_setup_radiance_structures.inc modified: var/da/da_radiance/da_transform_xtoy_crtm.inc modified: var/da/da_radiance/da_transform_xtoy_crtm_adj.inc modified: var/da/da_radiance/da_write_iv_rad_ascii.inc modified: var/da/da_radiance/da_write_oa_rad_ascii.inc --- var/da/da_obs/da_transform_xtoy.inc | 2 +- var/da/da_obs/da_transform_xtoy_adj.inc | 2 +- var/da/da_radiance/da_allocate_rad_iv.inc | 6 +-- var/da/da_radiance/da_crtm.f90 | 2 +- var/da/da_radiance/da_deallocate_radiance.inc | 8 +-- .../da_radiance/da_get_innov_vector_crtm.inc | 14 ++--- .../da_radiance/da_get_innov_vector_crtmk.inc | 10 ++-- .../da_radiance/da_get_innov_vector_rttov.inc | 6 +-- var/da/da_radiance/da_get_satzen.inc | 51 +++++++++++++++++++ var/da/da_radiance/da_initialize_rad_iv.inc | 4 +- var/da/da_radiance/da_qc_amsr2.inc | 16 +++--- var/da/da_radiance/da_qc_amsub.inc | 6 +-- var/da/da_radiance/da_qc_goesimg.inc | 4 +- var/da/da_radiance/da_radiance1.f90 | 2 +- var/da/da_radiance/da_read_obs_ncgoesimg.inc | 4 +- var/da/da_radiance/da_rttov.f90 | 2 +- .../da_setup_radiance_structures.inc | 2 +- var/da/da_radiance/da_transform_xtoy_crtm.inc | 19 ++++--- .../da_transform_xtoy_crtm_adj.inc | 21 ++++---- var/da/da_radiance/da_write_iv_rad_ascii.inc | 10 ++-- var/da/da_radiance/da_write_oa_rad_ascii.inc | 6 +-- 21 files changed, 123 insertions(+), 74 deletions(-) create mode 100644 var/da/da_radiance/da_get_satzen.inc diff --git a/var/da/da_obs/da_transform_xtoy.inc b/var/da/da_obs/da_transform_xtoy.inc index d0240f94dd..83817517a8 100644 --- a/var/da/da_obs/da_transform_xtoy.inc +++ b/var/da/da_obs/da_transform_xtoy.inc @@ -5,7 +5,7 @@ subroutine da_transform_xtoy(cv_size, cv, grid, iv, y) !------------------------------------------------------------------------- implicit none - + integer, intent(in) :: cv_size ! Size of cv array. real, intent(in) :: cv(1:cv_size) ! control variables. type (domain), intent(inout) :: grid diff --git a/var/da/da_obs/da_transform_xtoy_adj.inc b/var/da/da_obs/da_transform_xtoy_adj.inc index 489c25a6eb..dbbe9ddd15 100644 --- a/var/da/da_obs/da_transform_xtoy_adj.inc +++ b/var/da/da_obs/da_transform_xtoy_adj.inc @@ -11,7 +11,7 @@ subroutine da_transform_xtoy_adj(cv_size, cv, grid, iv, jo_grad_y, jo_grad_x & !-------------------------------------------------------------------------- implicit none - + integer, intent(in) :: cv_size ! Size of cv array. real, intent(inout) :: cv(1:cv_size) ! control variables. type (domain), intent(inout) :: grid diff --git a/var/da/da_radiance/da_allocate_rad_iv.inc b/var/da/da_radiance/da_allocate_rad_iv.inc index 0a17696c10..1c68ae680b 100644 --- a/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/var/da/da_radiance/da_allocate_rad_iv.inc @@ -40,7 +40,7 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate (iv%instid(i)%qm (kms:kme,iv%instid(i)%num_rad)) allocate (iv%instid(i)%qrn(kms:kme,iv%instid(i)%num_rad)) allocate (iv%instid(i)%qcw(kms:kme,iv%instid(i)%num_rad)) - if ( any(crtm_cloud) ) then + if ( crtm_cloud ) then allocate (iv%instid(i)%qci(kms:kme,iv%instid(i)%num_rad)) allocate (iv%instid(i)%qsn(kms:kme,iv%instid(i)%num_rad)) allocate (iv%instid(i)%qgr(kms:kme,iv%instid(i)%num_rad)) @@ -90,7 +90,7 @@ subroutine da_allocate_rad_iv (i, nchan, iv) end if allocate (iv%instid(i)%ps(iv%instid(i)%num_rad)) allocate (iv%instid(i)%tb_xb(nchan,iv%instid(i)%num_rad)) - if ( any(crtm_cloud) ) then + if ( crtm_cloud ) then allocate (iv%instid(i)%tb_xb_clr(nchan,iv%instid(i)%num_rad)) allocate (iv%instid(i)%cip(iv%instid(i)%num_rad)) end if @@ -148,7 +148,7 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate(iv%instid(i)%ice_coverage(iv%instid(i)%num_rad)) allocate(iv%instid(i)%snow_coverage(iv%instid(i)%num_rad)) if (use_crtm_kmatrix) then - if ( any(crtm_cloud) ) then + if ( crtm_cloud ) then allocate(iv%instid(i)%water_jacobian(nchan,kte,iv%instid(i)%num_rad)) allocate(iv%instid(i)%ice_jacobian(nchan,kte,iv%instid(i)%num_rad)) allocate(iv%instid(i)%rain_jacobian(nchan,kte,iv%instid(i)%num_rad)) diff --git a/var/da/da_radiance/da_crtm.f90 b/var/da/da_radiance/da_crtm.f90 index ad512551ef..dd1a538842 100644 --- a/var/da/da_radiance/da_crtm.f90 +++ b/var/da/da_radiance/da_crtm.f90 @@ -36,7 +36,7 @@ module da_crtm use_crtm_kmatrix, use_varbc, freeze_varbc, use_pseudo_rad, & use_antcorr, time_slots, use_satcv, use_simulated_rad, simulated_rad_io, & simulated_rad_ngrid, interp_option, use_mspps_emis, use_mspps_ts, calc_weightfunc, & - use_clddet_abi, its,ite,jts,jte, & + its,ite,jts,jte, & crtm_coef_path, crtm_irwater_coef, crtm_mwwater_coef, crtm_irland_coef, crtm_visland_coef, & cloud_cv_options use da_interpolation, only : da_interp_lin_2d_partial,da_interp_lin_2d_adj_partial, & diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index 5fffd47fc8..946aab9fc7 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -76,7 +76,7 @@ deallocate (iv%instid(i)%qm) deallocate (iv%instid(i)%qrn) deallocate (iv%instid(i)%qcw) - if ( any(crtm_cloud) ) then + if ( crtm_cloud ) then deallocate (iv%instid(i)%qci) deallocate (iv%instid(i)%qsn) deallocate (iv%instid(i)%qgr) @@ -111,7 +111,7 @@ deallocate (iv%instid(i)%vegfra) deallocate (iv%instid(i)%vegtyp) deallocate (iv%instid(i)%clwp) - if ( index(iv%instid(i)%rttovid_string, 'amsr2') > 0 ) then + if ( index(iv%instid(i)%rttovid_string,'amsr2') > 0 ) then deallocate (iv%instid(i)%clw) end if if ( index(iv%instid(i)%rttovid_string, 'ahi') > 0 ) then @@ -126,7 +126,7 @@ end if deallocate (iv%instid(i)%ps) deallocate (iv%instid(i)%tb_xb) - if ( any(crtm_cloud) ) then + if ( crtm_cloud ) then deallocate (iv%instid(i)%tb_xb_clr) deallocate (iv%instid(i)%cip) end if @@ -200,7 +200,7 @@ deallocate(iv%instid(i)%ice_coverage) deallocate(iv%instid(i)%snow_coverage) if (use_crtm_kmatrix) then - if ( any(crtm_cloud) ) then + if ( crtm_cloud ) then deallocate(iv%instid(i)%water_jacobian) deallocate(iv%instid(i)%ice_jacobian) deallocate(iv%instid(i)%rain_jacobian) diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index c4bcd3b88e..6d72b1decc 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -160,7 +160,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) n_absorbers = 2 n_aerosols = 0 n_clouds = 0 - if ( crtm_cloud(it) ) n_clouds = 6 + if ( crtm_cloud ) n_clouds = 6 call CRTM_Atmosphere_Create ( Atmosphere(1), & n_layers, & @@ -177,7 +177,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) Atmosphere(1)%Absorber_Units(1) = MASS_MIXING_RATIO_UNITS Atmosphere(1)%Absorber_Units(2) = VOLUME_MIXING_RATIO_UNITS - if (crtm_cloud(it)) then + if (crtm_cloud) then Atmosphere(1)%Cloud(1)%Type=WATER_CLOUD Atmosphere(1)%Cloud(2)%Type=ICE_CLOUD Atmosphere(1)%Cloud(3)%Type=RAIN_CLOUD @@ -246,7 +246,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) trim( crtm_sensor_name(rtminit_sensor(inst))) == 'abi' .or. & trim( crtm_sensor_name(rtminit_sensor(inst))) == 'ahi') ) then !Tb_clear_sky is only needed for symmetric obs error model - !symmetric obs error model only implemented for amsr2 & abi for now + !symmetric obs error model only implemented for amsr2 & abi/ahi for now calc_tb_clr = .true. end if @@ -389,7 +389,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) call da_interp_2d_partial (grid%xb%qcw(:,:,k), iv%instid(inst)%info,k,n,n, model_qcw(kte-k+1:kte-k+1)) - if (crtm_cloud(it)) then + if (crtm_cloud) then call da_interp_2d_partial (grid%xb%qci(:,:,k), iv%instid(inst)%info,k,n,n,qci) call da_interp_2d_partial (grid%xb%qci(:,:,k), iv%instid(inst)%info,k,n,n,model_qci(kte-k+1:kte-k+1)) @@ -445,7 +445,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) end if - if ( use_clddet_abi & + if ( use_clddet_zz & .AND. trim( crtm_sensor_name(rtminit_sensor(inst))) == 'abi' ) then ! Find tropopause temperature for Zhuge and Zou Cloud Detection do k = kts, min(kte,kme-1) @@ -498,7 +498,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) end if ! convert cloud content unit from kg/kg to kg/m^2 - if (crtm_cloud(it)) then + if (crtm_cloud) then do k=kts,kte do icld=1,Atmosphere(1)%n_Clouds Atmosphere(1)%Cloud(icld)%Water_Content(k)= Atmosphere(1)%Cloud(icld)%Water_Content(k)* & @@ -776,7 +776,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) end if end do - if (crtm_cloud(it)) then + if (crtm_cloud) then do k=1,Atmosphere(1)%n_layers iv%instid(inst)%qcw(k,n) = Atmosphere(1)%cloud(1)%water_content(k) iv%instid(inst)%qci(k,n) = Atmosphere(1)%cloud(2)%water_content(k) diff --git a/var/da/da_radiance/da_get_innov_vector_crtmk.inc b/var/da/da_radiance/da_get_innov_vector_crtmk.inc index ddd75cf20b..c71d599ad7 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtmk.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtmk.inc @@ -77,7 +77,7 @@ subroutine da_get_innov_vector_crtmk ( it, grid, ob, iv ) Atmosphere(1)%n_Absorbers=2 Atmosphere(1)%n_Clouds=0 Atmosphere(1)%n_Aerosols=0 - if (crtm_cloud(it)) Atmosphere(1)%n_Clouds=6 + if (crtm_cloud) Atmosphere(1)%n_Clouds=6 Error_Status = CRTM_Allocate_Atmosphere( Atmosphere(1)%n_Layers, & Atmosphere(1)%n_Absorbers, & @@ -92,7 +92,7 @@ subroutine da_get_innov_vector_crtmk ( it, grid, ob, iv ) Atmosphere(1)%Absorber_ID(1)=H2O_ID Atmosphere(1)%Absorber_ID(2)=O3_ID - if (crtm_cloud(it)) then + if (crtm_cloud) then Atmosphere(1)%Cloud(1)%Type=WATER_CLOUD Atmosphere(1)%Cloud(2)%Type=ICE_CLOUD Atmosphere(1)%Cloud(3)%Type=RAIN_CLOUD @@ -217,7 +217,7 @@ subroutine da_get_innov_vector_crtmk ( it, grid, ob, iv ) call da_interp_lin_2d_partial (grid%xb%qcw(:,:,k), iv%instid(inst)%info,k,n,n, model_qcw(kte-k+1:kte-k+1)) - if (crtm_cloud(it)) then + if (crtm_cloud) then Atmosphere(1)%Cloud(1)%Water_Content(kte-k+1) = model_qcw(kte-k+1) call da_interp_lin_2d_partial (grid%xb%qci(:,:,k), iv%instid(inst)%info,k,n,n, & @@ -278,7 +278,7 @@ subroutine da_get_innov_vector_crtmk ( it, grid, ob, iv ) end do ! convert cloud content unit from kg/kg to kg/m^2 - if (crtm_cloud(it)) then + if (crtm_cloud) then do k=kts,kte do icld=1,Atmosphere(1)%n_Clouds Atmosphere(1)%Cloud(icld)%Water_Content(k)= Atmosphere(1)%Cloud(icld)%Water_Content(k)* & @@ -437,7 +437,7 @@ subroutine da_get_innov_vector_crtmk ( it, grid, ob, iv ) iv%instid(inst)%t_jacobian(l,k,n) = Atmosphere_k(l,1)%temperature(k) iv%instid(inst)%q_jacobian(l,k,n) = Atmosphere_k(l,1)%absorber(k,1) end do - if (crtm_cloud(it)) then + if (crtm_cloud) then iv%instid(inst)%qcw(k,n) = Atmosphere(1)%cloud(1)%water_content(k) iv%instid(inst)%qci(k,n) = Atmosphere(1)%cloud(2)%water_content(k) iv%instid(inst)%qrn(k,n) = Atmosphere(1)%cloud(3)%water_content(k) 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 3949e1d063..2152f291dc 100644 --- a/var/da/da_radiance/da_get_innov_vector_rttov.inc +++ b/var/da/da_radiance/da_get_innov_vector_rttov.inc @@ -61,7 +61,7 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) ! [1.0] calculate the background bright temperature !------------------------------------------------------- - if ( use_clddet_abi ) then + if ( use_clddet_zz ) then allocate ( geoht_full(ims:ime,jms:jme,kms:kme-1) ) do k = kms, kme-1 do j = jms, jme @@ -149,7 +149,7 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) iv%instid(inst)%surftype(n) = 0 end if - if ( use_clddet_abi & + if ( use_clddet_zz & .AND. trim( rttov_inst_name(rtminit_sensor(inst))) == 'abi' ) then ! Find tropopause temperature for Zhuge and Zou Cloud Detection do k = kts, min(kte,kme-1) @@ -412,7 +412,7 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) end do ! end loop for sensor - if ( use_clddet_abi ) deallocate ( geoht_full ) + if ( use_clddet_zz ) deallocate ( geoht_full ) if (trace_use) call da_trace_exit("da_get_innov_vector_rttov") #else diff --git a/var/da/da_radiance/da_get_satzen.inc b/var/da/da_radiance/da_get_satzen.inc new file mode 100644 index 0000000000..b522d24e62 --- /dev/null +++ b/var/da/da_radiance/da_get_satzen.inc @@ -0,0 +1,51 @@ +subroutine da_get_satzen ( lat,lon,sate_index,theta_true ) +!------------------------------------------------- +! Purpose: calculate geostationary satellite_zenith_angle +! +! Menthod: Yang et al., 2017: Impact of assimilating GOES imager +! clear-sky radiance with a rapid refresh assimilation +! system for convection-permitting forecast over Mexico. +! J. Geophys. Res. Atmos., 122, 5472–5490 +!------------------------------------------------- + + implicit none + + real, intent(in) :: lat,lon + integer, intent(in) :: sate_index + real, intent(out) :: theta_true + + real :: alat, alon, alon_sat + real :: theta, r_tmp, theta_tmp + + + alat = lat + alon = lon + + if (sate_index .eq. 11) then + alon_sat = -135.*pi/180. + else if (sate_index .eq. 12) then + alon_sat = -60.*pi/180. + else if (sate_index .eq. 13) then + alon_sat = -75.*pi/180. + else if (sate_index .eq. 14) then + alon_sat = -105.*pi/180. + else if (sate_index .eq. 15) then + alon_sat = -135.*pi/180. + else + write(*,*)'this satellite is not included' + stop + end if + + alat = alat*pi/180. + alon = alon*pi/180. + theta = abs(alon-alon_sat) + r_tmp = (2*earth_radius*sin(theta/2.)-earth_radius*(1-cos(alat))*sin(theta/2.))**2 & + +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(theta/2.))**2 + r_tmp = sqrt(r_tmp) + theta_true = 2*asin(r_tmp/earth_radius/2.) + theta_tmp = atan(earth_radius*sin(theta_true)/(satellite_height+earth_radius*(1-sin(theta_true)))) + theta_true = (theta_true+theta_tmp)*180./pi + + return + +end subroutine da_get_satzen diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index 8191337a25..b5f551677d 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -39,7 +39,7 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%qm(:,n) = 0.0 iv%instid(i)%qrn(:,n) = 0.0 iv%instid(i)%qcw(:,n) = 0.0 - if ( any(crtm_cloud) ) then + if ( crtm_cloud ) then iv%instid(i)%qci(:,n) = 0.0 iv%instid(i)%qsn(:,n) = 0.0 iv%instid(i)%qgr(:,n) = 0.0 @@ -159,7 +159,7 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%ice_coverage(n)=0.0 iv%instid(i)%snow_coverage(n)=0.0 if (use_crtm_kmatrix) then - if ( any(crtm_cloud) ) then + if ( crtm_cloud ) then iv%instid(i)%water_jacobian(:,:,n)=0.0 iv%instid(i)%ice_jacobian(:,:,n)=0.0 iv%instid(i)%rain_jacobian(:,:,n)=0.0 diff --git a/var/da/da_radiance/da_qc_amsr2.inc b/var/da/da_radiance/da_qc_amsr2.inc index 166758714f..fb05e52a12 100644 --- a/var/da/da_radiance/da_qc_amsr2.inc +++ b/var/da/da_radiance/da_qc_amsr2.inc @@ -45,7 +45,7 @@ subroutine da_qc_amsr2 (it, i, nchan, ob, iv) if (iv%instid(i)%info%proc_domain(1,n)) & num_proc_domain = num_proc_domain + 1 - if ( crtm_cloud(it) ) then + if ( crtm_cloud ) then ! calculate c37_mean c37_mean = 1.0-(ob%instid(i)%tb(11,n)-ob%instid(i)%tb(12,n)+ & iv%instid(i)%tb_xb(11,n)-iv%instid(i)%tb_xb(12,n))/ & @@ -90,7 +90,7 @@ subroutine da_qc_amsr2 (it, i, nchan, ob, iv) ! 4.0 check cloud !----------------------------------------------------------------- - if (.not. crtm_cloud(it) ) then + if (.not. crtm_cloud ) then do k = 1, nchan ! clw check ! channel dependent criteria @@ -105,7 +105,7 @@ subroutine da_qc_amsr2 (it, i, nchan, ob, iv) end if ! assigning obs errors - if (.not. crtm_cloud(it) ) then + if (.not. crtm_cloud ) then do k = 1, nchan if (use_error_factor_rad) then iv%instid(i)%tb_error(k,n) = & @@ -115,16 +115,16 @@ subroutine da_qc_amsr2 (it, i, nchan, ob, iv) end if end do ! nchan - else !crtm_cloud(it) + else !crtm_cloud ! symmetric error model, Geer and Bauer (2011) do k = 1, nchan if (c37_mean.lt.0.05) then iv%instid(i)%tb_error(k,n)= satinfo(i)%error_std(k) - else if (c37_mean.ge.0.05.and.c37_mean.lt.satinfo(i)%error_cld_x(k)) then + else if (c37_mean.ge.0.05.and.c37_mean.lt.0.5) then iv%instid(i)%tb_error(k,n)= satinfo(i)%error_std(k)+ & - (c37_mean-0.05)*(satinfo(i)%error_cld_y(k)-satinfo(i)%error_std(k))/(satinfo(i)%error_cld_x(k)-0.05) + (c37_mean-0.05)*(satinfo(i)%error_cld(k)-satinfo(i)%error_std(k))/(0.5-0.05) else - iv%instid(i)%tb_error(k,n)= satinfo(i)%error_cld_y(k) + iv%instid(i)%tb_error(k,n)= satinfo(i)%error_cld(k) end if end do ! nchan @@ -132,7 +132,7 @@ subroutine da_qc_amsr2 (it, i, nchan, ob, iv) ! 5.0 check innovation !----------------------------------------------------------------- - if (.not. crtm_cloud(it) ) then + if (.not. crtm_cloud ) then ! absolute departure check do k = 1, nchan if ( k <= 7 .or. k == 11 .or. k == 12) then diff --git a/var/da/da_radiance/da_qc_amsub.inc b/var/da/da_radiance/da_qc_amsub.inc index 0155b1d8cd..6173607d56 100644 --- a/var/da/da_radiance/da_qc_amsub.inc +++ b/var/da/da_radiance/da_qc_amsub.inc @@ -48,7 +48,7 @@ subroutine da_qc_amsub (it, i, nchan, ob, iv) ! 0.0 initialise QC flags by assuming good obs !--------------------------------------------- iv%instid(i)%tb_qc(:,n) = qc_good - if (crtm_cloud(it)) go to 2508 + if (crtm_cloud) go to 2508 ! a. reject all channels over mixture surface type !------------------------------------------------------ @@ -129,7 +129,7 @@ subroutine da_qc_amsub (it, i, nchan, ob, iv) !----------------------------------------------------------- do k = 1, nchan ! absolute departure check - if (.not. crtm_cloud(it)) then + if (.not. crtm_cloud) then if (abs(iv%instid(i)%tb_inv(k,n)) > 15.0) then iv%instid(i)%tb_qc(k,n) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & @@ -145,7 +145,7 @@ subroutine da_qc_amsub (it, i, nchan, ob, iv) iv%instid(i)%tb_error(k,n) = satinfo(i)%error_std(k) end if - if (.not. crtm_cloud(it)) then + if (.not. crtm_cloud) then if (abs(iv%instid(i)%tb_inv(k,n)) > 3.0*iv%instid(i)%tb_error(k,n)) then iv%instid(i)%tb_qc(k,n) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & diff --git a/var/da/da_radiance/da_qc_goesimg.inc b/var/da/da_radiance/da_qc_goesimg.inc index 0a64c1c96d..eff20e0bf6 100644 --- a/var/da/da_radiance/da_qc_goesimg.inc +++ b/var/da/da_radiance/da_qc_goesimg.inc @@ -81,7 +81,7 @@ subroutine da_qc_goesimg(it, i, nchan, ob, iv) ! b. cloud detection !----------------------------------------------------------- - if (.not.crtm_cloud(it)) then + if (.not.crtm_cloud) then if (iv%instid(i)%clwp(n) >= 0.2) then iv%instid(i)%tb_qc(:,n) = qc_bad if (iv%instid(i)%info%proc_domain(1,n)) & @@ -154,7 +154,7 @@ subroutine da_qc_goesimg(it, i, nchan, ob, iv) ! c.1. check absolute value of innovation !------------------------------------------------ - if (.not.crtm_cloud(it)) then + if (.not.crtm_cloud) then inv_grosscheck = 15.0 if (use_satcv(2)) inv_grosscheck = 100.0 if (abs(iv%instid(i)%tb_inv(k,n)) > inv_grosscheck) then diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index 716ad23d1d..1c57f87634 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -24,7 +24,7 @@ module da_radiance1 use_pseudo_rad, pi, t_triple, crtm_cloud, DT_cloud_model,write_jacobian, & use_crtm_kmatrix,use_clddet, use_satcv, cv_size_domain, & cv_size_domain_js, calc_weightfunc, deg_to_rad, rad_to_deg,use_clddet_zz, & - ahi_superob_halfwidth, abi_superob_halfwidth, ahi_use_symm_obs_err, use_rad_symm_err + ahi_superob_halfwidth, abi_superob_halfwidth, ahi_use_symm_obs_err, abi_use_symm_obs_err use da_define_structures, only : info_type,model_loc_type,maxmin_type, & iv_type, y_type, jo_type,bad_data_type,bad_data_type,number_type, & be_type, clddet_geoir_type, superob_type diff --git a/var/da/da_radiance/da_read_obs_ncgoesimg.inc b/var/da/da_radiance/da_read_obs_ncgoesimg.inc index b69fac96a6..d5c7fa8d2e 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesimg.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesimg.inc @@ -134,7 +134,7 @@ subroutine da_read_obs_ncgoesimg (iv,infile) elseif(infile(6:7)=='15') then satellite_id = 15 else - write(*,*) 'goes satellite ', satellite_id, ' is not supported for imager instrument' + write(*,*) 'goes satellite ', satellite_id, ' is not supported' return endif @@ -305,7 +305,7 @@ subroutine da_read_obs_ncgoesimg (iv,infile) sat_zen=missing_r do jj=1,dims(2) do ii=1,dims(1) - call da_get_sat_angles(lat(ii,jj),lon(ii,jj),satellite_id,sat_zen(ii,jj)) + call da_get_satzen(lat(ii,jj),lon(ii,jj),satellite_id,sat_zen(ii,jj)) if(sat_zen(ii,jj) > 75.0) sat_zen(ii,jj)=missing_r end do end do diff --git a/var/da/da_radiance/da_rttov.f90 b/var/da/da_radiance/da_rttov.f90 index 84f5f094b2..9bad0db61f 100644 --- a/var/da/da_radiance/da_rttov.f90 +++ b/var/da/da_radiance/da_rttov.f90 @@ -31,7 +31,7 @@ module da_rttov num_fgat_time,stdout,trace_use, use_error_factor_rad, & qc_good, qc_bad,myproc,biascorr, global,ims,ime,jms,jme, & use_clddet, time_slots, rttov_emis_atlas_ir, rttov_emis_atlas_mw, & - use_mspps_emis, use_mspps_ts, use_clddet_abi + use_mspps_emis, use_mspps_ts, use_clddet_zz use da_interpolation, only : da_to_zk_new, & da_interp_lin_2d, da_interp_lin_3d, da_interp_lin_3d_adj, da_interp_lin_2d_adj, & da_interp_2d_partial diff --git a/var/da/da_radiance/da_setup_radiance_structures.inc b/var/da/da_radiance/da_setup_radiance_structures.inc index 5d51b30162..40e2e868bb 100644 --- a/var/da/da_radiance/da_setup_radiance_structures.inc +++ b/var/da/da_radiance/da_setup_radiance_structures.inc @@ -288,7 +288,7 @@ subroutine da_setup_radiance_structures( grid, ob, iv ) ! Calculate DT for Cloudy Radiance DA - if (use_rad .and. any(crtm_cloud) .and. .not. DT_cloud_model) then + if (use_rad .and. crtm_cloud .and. .not. DT_cloud_model) then its = grid%xp % its ite = grid%xp % ite jts = grid%xp % jts diff --git a/var/da/da_radiance/da_transform_xtoy_crtm.inc b/var/da/da_radiance/da_transform_xtoy_crtm.inc index c49443dba3..ed9febc0c6 100644 --- a/var/da/da_radiance/da_transform_xtoy_crtm.inc +++ b/var/da/da_radiance/da_transform_xtoy_crtm.inc @@ -1,4 +1,4 @@ -subroutine da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y ) +subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) !--------------------------------------------------------------------------- ! PURPOSE: transform from analysis increment to @@ -16,7 +16,6 @@ subroutine da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y ) implicit none - integer, intent(in) :: it ! external iteration #. integer, intent(in) :: cv_size ! Size of cv array. real, intent(in) :: cv(1:cv_size) ! control variables. type (domain), intent(in) :: grid @@ -151,7 +150,7 @@ subroutine da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y ) n_absorbers = 2 n_aerosols = 0 n_clouds = 0 - if ( crtm_cloud(it) ) n_clouds = 6 + if ( crtm_cloud ) n_clouds = 6 call CRTM_Atmosphere_Create( Atmosphere(n), & n_layers, & @@ -169,7 +168,7 @@ subroutine da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y ) Atmosphere(n)%Absorber_Units(2) = VOLUME_MIXING_RATIO_UNITS Atmosphere(n)%Climatology=iv%instid(inst)%crtm_climat(n) - if (crtm_cloud(it)) then + if (crtm_cloud) then Atmosphere(n)%Cloud(1)%Type=WATER_CLOUD Atmosphere(n)%Cloud(2)%Type=ICE_CLOUD Atmosphere(n)%Cloud(3)%Type=RAIN_CLOUD @@ -223,7 +222,7 @@ subroutine da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y ) xb_q(:,:) = 0.0 psfc(:) = 0.0 - if (crtm_cloud(it)) then + if (crtm_cloud) then allocate (qcw(Atmosphere(iv%instid(inst)%info%n1)%n_layers, iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) allocate (qci(Atmosphere(iv%instid(inst)%info%n1)%n_layers, iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) @@ -246,7 +245,7 @@ subroutine da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y ) call da_interp_2d_partial (grid%xa%q(:,:,k), iv%instid(inst)%info, k, iv%instid(inst)%info%n1, iv%instid(inst)%info%n2, & absorber(kte-k+1,:)) - if ( crtm_cloud(it) .and. cloud_cv_options > 0 ) then + if ( crtm_cloud .and. cloud_cv_options > 0 ) then call da_interp_2d_partial (grid%xa%qcw(:,:,k), iv%instid(inst)%info, k, iv%instid(inst)%info%n1, iv%instid(inst)%info%n2, & qcw(kte-k+1,:)) @@ -301,7 +300,7 @@ subroutine da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y ) ! convert mixing ratio (g h2o / kg dry air) to specific humidity (kg h2o / kg moist air) xb_q(k,n) = 0.001*iv%instid(inst)%qm(k,n)/(1.0+0.001*iv%instid(inst)%qm(k,n)) ! specific humidity end do - if (crtm_cloud(it)) then + if (crtm_cloud) then do k=1,Atmosphere(n)%n_layers Atmosphere(n)%cloud(1)%water_content(k)=iv%instid(inst)%qcw(k,n) Atmosphere(n)%cloud(2)%water_content(k)=iv%instid(inst)%qci(k,n) @@ -389,7 +388,7 @@ subroutine da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y ) Atmosphere_TL(n)%Temperature(kts+1:kte) = temperature(kts+1:kte,n) ! Zero Jacobian for top level Atmosphere_TL(n)%Level_Pressure(Atmosphere_TL(n)%n_Layers) = 0.01 * psfc(n) - if (crtm_cloud(it)) then + if (crtm_cloud) then Atmosphere_TL(n)%Cloud(1)%Water_Content(kts:kte) = qcw(kts:kte,n) Atmosphere_TL(n)%Cloud(2)%Water_Content(kts:kte) = qci(kts:kte,n) Atmosphere_TL(n)%Cloud(3)%Water_Content(kts:kte) = qrn(kts:kte,n) @@ -484,7 +483,7 @@ subroutine da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y ) RTSolution_TL(l,n)%brightness_temperature = RTSolution_TL(l,n)%brightness_temperature + & iv%instid(inst)%t_jacobian(l,k,n) * Atmosphere_TL(n)%Temperature(k) + & iv%instid(inst)%q_jacobian(l,k,n) * Atmosphere_TL(n)%absorber(k,1) - if (crtm_cloud(it)) then + if (crtm_cloud) then RTSolution_TL(l,n)%brightness_temperature = RTSolution_TL(l,n)%brightness_temperature + & iv%instid(inst)%water_jacobian(l,k,n) * Atmosphere_TL(n)%Cloud(1)%Water_Content(k) + & iv%instid(inst)%ice_jacobian(l,k,n) * Atmosphere_TL(n)%Cloud(2)%Water_Content(k) + & @@ -527,7 +526,7 @@ subroutine da_transform_xtoy_crtm (it, cv_size, cv, grid, iv, y ) deallocate (xb_q) deallocate (psfc) - if (crtm_cloud(it)) then + if (crtm_cloud) then deallocate (qcw) deallocate (qci) deallocate (qrn) diff --git a/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc b/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc index 4a950fc298..9de898e492 100644 --- a/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc +++ b/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc @@ -1,4 +1,4 @@ -subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_x ) +subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) !--------------------------------------------------------------------------- ! PURPOSE: transform gradient from obs space to model grid space. @@ -16,7 +16,6 @@ subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_ implicit none - integer, intent(in) :: it ! external iteration #. integer, intent(in) :: cv_size ! Size of cv array. real, intent(inout) :: cv(1:cv_size) ! control variables. type (x_type), intent(inout) :: jo_grad_x ! @@ -168,7 +167,7 @@ subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_ n_absorbers = 2 n_aerosols = 0 n_clouds = 0 - if ( crtm_cloud(it) ) n_clouds = 6 + if ( crtm_cloud ) n_clouds = 6 call CRTM_Atmosphere_Create( Atmosphere(n), & n_layers, & @@ -185,7 +184,7 @@ subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_ Atmosphere(n)%Absorber_Units(2) = VOLUME_MIXING_RATIO_UNITS Atmosphere(n)%Climatology=iv%instid(inst)%crtm_climat(n) - if (crtm_cloud(it)) then + if (crtm_cloud) then Atmosphere(n)%Cloud(1)%Type=WATER_CLOUD Atmosphere(n)%Cloud(2)%Type=ICE_CLOUD Atmosphere(n)%Cloud(3)%Type=RAIN_CLOUD @@ -207,7 +206,7 @@ subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_ p_ad = 0.0 xb_q = 0.0 - if (crtm_cloud(it)) then + if (crtm_cloud) then allocate (qcw_ad(kts:kte,iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) allocate (qci_ad(kts:kte,iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) allocate (qrn_ad(kts:kte,iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) @@ -284,7 +283,7 @@ subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_ xb_q(k,n) = 0.001*iv%instid(inst)%qm(k,n)/(1.0+0.001*iv%instid(inst)%qm(k,n)) ! specific humidity end do - if (crtm_cloud(it)) then + if (crtm_cloud) then do k=1,Atmosphere(n)%n_layers Atmosphere(n)%cloud(1)%water_content(k)=iv%instid(inst)%qcw(k,n) Atmosphere(n)%cloud(2)%water_content(k)=iv%instid(inst)%qci(k,n) @@ -407,7 +406,7 @@ subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_ iv%instid(inst)%t_jacobian(i,k,n) * RTSolution_AD(i,n)%brightness_temperature Atmosphere_AD(n)%absorber(k,1) = Atmosphere_AD(n)%absorber(k,1) + & iv%instid(inst)%q_jacobian(i,k,n) * RTSolution_AD(i,n)%brightness_temperature - if (crtm_cloud(it)) then + if (crtm_cloud) then Atmosphere_AD(n)%Cloud(1)%Water_Content(k) = Atmosphere_AD(n)%Cloud(1)%Water_Content(k) + & iv%instid(inst)%water_jacobian(i,k,n) * RTSolution_AD(i,n)%brightness_temperature Atmosphere_AD(n)%Cloud(2)%Water_Content(k) = Atmosphere_AD(n)%Cloud(2)%Water_Content(k) + & @@ -477,7 +476,7 @@ subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_ ! [1.5] Scale transformation and fill zero for no-control variable ! Convert cloud content unit from kg/kg to kg/m^2 - if (crtm_cloud(it)) then + if (crtm_cloud) then do k=kts,kte do icld=1,Atmosphere(n)%n_Clouds Atmosphere_AD(n)%Cloud(icld)%Water_Content(k) = & @@ -489,7 +488,7 @@ subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_ ! [1.6] Adjoint of Interpolate horizontally from ob to grid: - if (crtm_cloud(it)) then + if (crtm_cloud) then do k=kts,kte ! from bottom to top qcw_ad(k,n)=Atmosphere_AD(n)%Cloud(1)%Water_Content(kte-k+1) qci_ad(k,n)=Atmosphere_AD(n)%Cloud(2)%Water_Content(kte-k+1) @@ -546,7 +545,7 @@ subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_ !!! call wrf_dm_sum_reals(cv_local, cv) !#endif - if ( crtm_cloud(it) .and. cloud_cv_options > 0 ) then + if ( crtm_cloud .and. cloud_cv_options > 0 ) then call da_interp_lin_2d_adj_partial(jo_grad_x%qcw(:,:,kts:kte),iv%instid(inst)%info, kts,kte, qcw_ad) call da_interp_lin_2d_adj_partial(jo_grad_x%qrn(:,:,kts:kte),iv%instid(inst)%info, kts,kte, qrn_ad) if ( cloud_cv_options > 1 ) then @@ -565,7 +564,7 @@ subroutine da_transform_xtoy_crtm_adj ( it, cv_size, cv, iv, jo_grad_y, jo_grad_ deallocate (p_ad) deallocate (xb_q) - if (crtm_cloud(it)) then + if (crtm_cloud) then deallocate (qcw_ad) deallocate (qci_ad) deallocate (qrn_ad) diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index a36e432d66..1d26c9959c 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -200,7 +200,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) write(unit=innov_rad_unit,fmt='(a)') 'CLOUD : ' write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) - if ( abi .and. crtm_cloud(it) ) then ! write out cloud_mod, cloud_obs, tb_xb_clr + if ( abi .and. crtm_cloud ) then ! write out cloud_mod, cloud_obs, tb_xb_clr write(unit=innov_rad_unit,fmt='(a)') 'CMOD : ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_mod(:,n) write(unit=innov_rad_unit,fmt='(a)') 'COBS : ' @@ -241,7 +241,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) #ifdef CRTM write(unit=innov_rad_unit,fmt='(a)') & 'level fullp(mb) halfp(mb) t(k) q(g/kg) water(mm) ice(mm) rain(mm) snow(mm) graupel(mm) hail(mm)' - if (crtm_cloud(it)) then + if (crtm_cloud) then do k=1,iv%instid(i)%nlevels-1 write(unit=innov_rad_unit,fmt='(i3,2f10.2,f8.2,13f8.3)') & k, & @@ -277,7 +277,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) 0.0, & 0.0 end do ! end loop profile - end if ! end if crtm_cloud(it) + end if ! end if crtm_cloud #endif end if ! end if rtm_option_crtm @@ -302,7 +302,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(a)') & 'channel level halfp(mb) t(k) q(g/kg) der_trans trans_jac trans lod_jac lod water(mm) ice(mm) rain(mm) snow(mm) graupel(mm) hail(mm)' - if (crtm_cloud(it)) then + if (crtm_cloud) then do l=1,iv%instid(i)%nchan do k=1,iv%instid(i)%nlevels-1 write(unit=innov_rad_unit,fmt='(i5,i3,f10.2,13f14.7,6f14.7)') & @@ -356,7 +356,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) 0. end do ! end loop profile end do ! end loop channels - end if ! end if crtm_cloud(it) + end if ! end if crtm_cloud #endif end if ! end if write_jacobian diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index c48f9f0830..23664ed58c 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -144,7 +144,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) write(unit=oma_rad_unit,fmt='(a)') 'CLOUD : ' write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) - if ( abi .and. crtm_cloud(it) ) then ! write out cloud_mod, cloud_obs, tb_xb_clr + if ( abi .and. crtm_cloud ) then ! write out cloud_mod, cloud_obs, tb_xb_clr write(unit=oma_rad_unit,fmt='(a)') 'CMOD : ' write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_mod(:,n) write(unit=oma_rad_unit,fmt='(a)') 'COBS : ' @@ -185,7 +185,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) #ifdef CRTM write(unit=oma_rad_unit,fmt='(a)') & 'level fullp(mb) halfp(mb) t(k) q(g/kg) water(mm) ice(mm) rain(mm) snow(mm) graupel(mm) hail(mm)' - if (crtm_cloud(it)) then + if (crtm_cloud) then do k=1,iv%instid(i)%nlevels-1 write(unit=oma_rad_unit,fmt='(i3,2f10.2,f8.2,13f8.3)') & k, & @@ -221,7 +221,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) 0.0, & 0.0 end do ! end loop profile - end if ! end if crtm_cloud(it) + end if ! end if crtm_cloud #endif end if ! end if crtm_option From 80df487bf531701e62da55a6e39a2c14a1019d0c Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 14:26:35 -0700 Subject: [PATCH 69/86] modified: var/da/da_setup_structures/da_setup_be_nmm_regional.inc modified: var/da/da_setup_structures/da_setup_be_regional.inc modified: var/da/da_setup_structures/da_setup_obs_structures.inc --- var/da/da_setup_structures/da_setup_be_nmm_regional.inc | 2 +- var/da/da_setup_structures/da_setup_be_regional.inc | 2 +- var/da/da_setup_structures/da_setup_obs_structures.inc | 3 +++ 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/var/da/da_setup_structures/da_setup_be_nmm_regional.inc b/var/da/da_setup_structures/da_setup_be_nmm_regional.inc index c396f1b71b..e7a77091d9 100644 --- a/var/da/da_setup_structures/da_setup_be_nmm_regional.inc +++ b/var/da/da_setup_structures/da_setup_be_nmm_regional.inc @@ -389,7 +389,7 @@ subroutine da_setup_be_nmm_regional(xb, be) deallocate (eval_loc) ! - if(use_radarobs .and. use_radar_rf .or. use_rad .and. any(crtm_cloud)) then + if(use_radarobs .and. use_radar_rf .or. use_rad .and. crtm_cloud) then if ( cloud_cv_options == 1 ) be % v4 % name = 'qt ' end if diff --git a/var/da/da_setup_structures/da_setup_be_regional.inc b/var/da/da_setup_structures/da_setup_be_regional.inc index 19299e670c..e16e0c7932 100644 --- a/var/da/da_setup_structures/da_setup_be_regional.inc +++ b/var/da/da_setup_structures/da_setup_be_regional.inc @@ -2243,7 +2243,7 @@ if ( jb_factor > 0.0 ) then deallocate (evec_loc) deallocate (eval_loc) - if(use_radarobs .and. use_radar_rf .or. use_rad .and. any(crtm_cloud)) then + if(use_radarobs .and. use_radar_rf .or. use_rad .and. crtm_cloud) then if ( cloud_cv_options == 1 ) be % v4 % name = 'qt ' end if diff --git a/var/da/da_setup_structures/da_setup_obs_structures.inc b/var/da/da_setup_structures/da_setup_obs_structures.inc index 54c440691d..c851c86d18 100644 --- a/var/da/da_setup_structures/da_setup_obs_structures.inc +++ b/var/da/da_setup_structures/da_setup_obs_structures.inc @@ -417,6 +417,9 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) if ( use_goesabiobs ) then call da_message((/'Using GOES ABI radiance input in netcdf format'/)) end if + if ( use_ahiobs ) then + call da_message((/'Using himawari AHI radiance input in netcdf format'/)) + end if if ( use_gmiobs ) then call da_message((/'Using GMI radiance input in HDF5 format'/)) end if From 773190e16a2419637e69ec992e614c2bc06422b9 Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 14:33:15 -0700 Subject: [PATCH 70/86] modified: var/da/da_test/da_check_vptox_adjoint.inc modified: var/da/da_test/da_check_vtox_adjoint.inc modified: var/da/da_test/da_check_vtoy_adjoint.inc modified: var/da/da_test/da_check_xtoy_adjoint.inc modified: var/da/da_test/da_setup_testfield.inc modified: var/da/da_test/da_test_vtoy_transform.inc --- var/da/da_test/da_check_vptox_adjoint.inc | 8 ++++---- var/da/da_test/da_check_vtox_adjoint.inc | 4 ++-- var/da/da_test/da_check_vtoy_adjoint.inc | 4 ++-- var/da/da_test/da_check_xtoy_adjoint.inc | 4 ++-- var/da/da_test/da_setup_testfield.inc | 2 +- var/da/da_test/da_test_vtoy_transform.inc | 4 ++-- 6 files changed, 13 insertions(+), 13 deletions(-) diff --git a/var/da/da_test/da_check_vptox_adjoint.inc b/var/da/da_test/da_check_vptox_adjoint.inc index d0815c7bd9..4f6113fcdb 100644 --- a/var/da/da_test/da_check_vptox_adjoint.inc +++ b/var/da/da_test/da_check_vptox_adjoint.inc @@ -157,7 +157,7 @@ subroutine da_check_vptox_adjoint(grid, ne, be, ep, vp, cv_size) adj_par_lhs = sum(grid%xa%u(its:ite,jts:jte,:)**2)/typical_u_rms**2 adj_par_lhs = sum(grid%xa%v(its:ite,jts:jte,:)**2)/typical_v_rms**2 + adj_par_lhs adj_par_lhs = sum(grid%xa%t(its:ite,jts:jte,:)**2)/typical_t_rms**2 + adj_par_lhs - if ( (use_radar_rf .or. crtm_cloud(1)) .and. (cloud_cv_options == 1) ) then + if ( (use_radar_rf .or. crtm_cloud) .and. (cloud_cv_options == 1) ) then adj_par_lhs = sum(grid%xa%qt(its:ite,jts:jte,:)**2)/typical_q_rms**2 + adj_par_lhs else adj_par_lhs = sum(grid%xa%q(its:ite,jts:jte,:)**2)/typical_q_rms**2 + adj_par_lhs @@ -194,7 +194,7 @@ subroutine da_check_vptox_adjoint(grid, ne, be, ep, vp, cv_size) typical_qgr_rms**2 + adj_par_lhs end if - if (use_radar_rf .or. crtm_cloud(1)) then + if (use_radar_rf .or. crtm_cloud) then if ( cloud_cv_options == 1 ) then adj_par_lhs = sum(grid%xa % qcw(its:ite,jts:jte,kts:kte)**2) / & typical_qcw_rms**2 + adj_par_lhs @@ -210,7 +210,7 @@ subroutine da_check_vptox_adjoint(grid, ne, be, ep, vp, cv_size) grid%xa % u(:,:,:) = grid%xa % u(:,:,:) / typical_u_rms**2 grid%xa % v(:,:,:) = grid%xa % v(:,:,:) / typical_v_rms**2 grid%xa % t(:,:,:) = grid%xa % t(:,:,:) / typical_t_rms**2 - if ( (use_radar_rf .or. crtm_cloud(1)) .and. (cloud_cv_options == 1) ) then + if ( (use_radar_rf .or. crtm_cloud) .and. (cloud_cv_options == 1) ) then grid%xa % qt(:,:,:) = grid%xa % qt(:,:,:) / typical_q_rms**2 else grid%xa % q(:,:,:) = grid%xa % q(:,:,:) / typical_q_rms**2 @@ -239,7 +239,7 @@ subroutine da_check_vptox_adjoint(grid, ne, be, ep, vp, cv_size) grid%xa % qgr(:,:,:) = grid%xa % qgr(:,:,:) / typical_qgr_rms**2 end if - if (use_radar_rf .or. crtm_cloud(1)) then + if (use_radar_rf .or. crtm_cloud) then if ( cloud_cv_options == 1 ) then grid%xa % qcw(:,:,:) = grid%xa % qcw(:,:,:) / typical_qcw_rms**2 grid%xa % qrn(:,:,:) = grid%xa % qrn(:,:,:) / typical_qrn_rms**2 diff --git a/var/da/da_test/da_check_vtox_adjoint.inc b/var/da/da_test/da_check_vtox_adjoint.inc index df6dd425e8..8457c5b7f7 100644 --- a/var/da/da_test/da_check_vtox_adjoint.inc +++ b/var/da/da_test/da_check_vtox_adjoint.inc @@ -61,7 +61,7 @@ subroutine da_check_vtox_adjoint(grid, cv_size, xbx, be, ep, cv1, vv, vp) + sum(grid%xa % rh(its:ite, jts:jte, kts:kte)**2) / typical_rh_rms**2 end if ! - if (use_radar_rf .or. use_radar_rhv .or. crtm_cloud(1) ) then + if (use_radar_rf .or. use_radar_rhv .or. crtm_cloud ) then adj_par_lhs = adj_par_lhs & + sum(grid%xa % qcw(its:ite, jts:jte, kts:kte)**2)/typical_qcw_rms**2 & + sum(grid%xa % qrn(its:ite, jts:jte, kts:kte)**2)/typical_qrn_rms**2 @@ -99,7 +99,7 @@ subroutine da_check_vtox_adjoint(grid, cv_size, xbx, be, ep, cv1, vv, vp) end if ! - if (use_radar_rf .or. use_radar_rhv .or. crtm_cloud(1) ) then + if (use_radar_rf .or. use_radar_rhv .or. crtm_cloud ) then grid%xa % qcw(:,:,:) = grid%xa % qcw(:,:,:) / typical_qcw_rms**2 grid%xa % qrn(:,:,:) = grid%xa % qrn(:,:,:) / typical_qrn_rms**2 if ( cloud_cv_options /= 1 ) then diff --git a/var/da/da_test/da_check_vtoy_adjoint.inc b/var/da/da_test/da_check_vtoy_adjoint.inc index 3faffad26d..cba3911229 100644 --- a/var/da/da_test/da_check_vtoy_adjoint.inc +++ b/var/da/da_test/da_check_vtoy_adjoint.inc @@ -41,7 +41,7 @@ subroutine da_check_vtoy_adjoint(cv_size,grid, config_flags, vp, vv, xbx, be, ep call da_zero_vp_type(vp) call da_zero_vp_type(vv) - call da_transform_vtoy(1, cv_size, be, ep, cv, iv, vp, vv, xbx, y, grid, config_flags, vp, vv) + call da_transform_vtoy(cv_size, be, ep, cv, iv, vp, vv, xbx, y, grid, config_flags, vp, vv) !------------------------------------------------------------------------- ! [3.0] Calculate LHS of adjoint test equation and @@ -57,7 +57,7 @@ subroutine da_check_vtoy_adjoint(cv_size,grid, config_flags, vp, vv, xbx, be, ep ! call da_zero_vp_type(vv) ! call da_zero_x(grid%xa) - call da_transform_vtoy_adj(1, cv_size, be, ep, cv, iv, vp, vv, xbx, y, grid, & + call da_transform_vtoy_adj(cv_size, be, ep, cv, iv, vp, vv, xbx, y, grid, & config_flags, .true., vp, vv) adj_rhs = sum(cv(1:cv_size) * cv_2(1:cv_size)) diff --git a/var/da/da_test/da_check_xtoy_adjoint.inc b/var/da/da_test/da_check_xtoy_adjoint.inc index 8025a8e80c..6b966820ab 100644 --- a/var/da/da_test/da_check_xtoy_adjoint.inc +++ b/var/da/da_test/da_check_xtoy_adjoint.inc @@ -315,7 +315,7 @@ print*,__FILE__,jte,' xa2_v.xa2_v for row= ',jte+1,sum(xa2_v(its:ite, jte+1, kts !---------------------------------------------------------------------- ! [2.0] Perform y = Hx transform: !---------------------------------------------------------------------- - call da_transform_xtoy (1, cv_size, cv, grid, iv, y) + call da_transform_xtoy (cv_size, cv, grid, iv, y) #ifdef VAR4D if (iv%info(rain)%nlocal > 0 .and. var4d) & @@ -372,7 +372,7 @@ print*,__FILE__,jte,' xa2_v.xa2_v for row= ',jte+1,sum(xa2_v(its:ite, jte+1, kts endif #endif - call da_transform_xtoy_adj (1, cv_size, cv, grid, iv, y, grid%xa) + call da_transform_xtoy_adj (cv_size, cv, grid, iv, y, grid%xa) #ifdef A2C if( ite == ide ) & diff --git a/var/da/da_test/da_setup_testfield.inc b/var/da/da_test/da_setup_testfield.inc index 01e5b524f9..56aa2a5147 100644 --- a/var/da/da_test/da_setup_testfield.inc +++ b/var/da/da_test/da_setup_testfield.inc @@ -33,7 +33,7 @@ subroutine da_setup_testfield(grid) call da_set_tst_trnsf_fld(grid, grid%xa%t, grid%xb%t, typical_t_rms) call da_set_tst_trnsf_fld(grid, grid%xa%p, grid%xb%p, typical_p_rms) call da_set_tst_trnsf_fld(grid, grid%xa%q, grid%xb%q, typical_q_rms) - if ( ( use_rad .and. crtm_cloud(1) ) .or. use_radar_rf .or. use_radar_rhv ) then + if ( ( use_rad .and. crtm_cloud ) .or. use_radar_rf .or. use_radar_rhv ) then call da_set_tst_trnsf_fld(grid, grid%xa%qcw, grid%xb%qcw, typical_qcw_rms) call da_set_tst_trnsf_fld(grid, grid%xa%qrn, grid%xb%qrn, typical_qrn_rms) call da_set_tst_trnsf_fld(grid, grid%xa%qci, grid%xb%qci, typical_qci_rms) diff --git a/var/da/da_test/da_test_vtoy_transform.inc b/var/da/da_test/da_test_vtoy_transform.inc index 066cb3ad81..22c318880c 100644 --- a/var/da/da_test/da_test_vtoy_transform.inc +++ b/var/da/da_test/da_test_vtoy_transform.inc @@ -40,7 +40,7 @@ subroutine da_test_vtoy_transform(grid, config_flags, vp, vv, xbx, be, iv, y) call da_zero_vp_type(vp) call da_zero_vp_type(vv) - call da_transform_vtoy(1, be, cv, iv, vp, vv, xbx, y, grid, config_flags ) + call da_transform_vtoy(be, cv, iv, vp, vv, xbx, y, grid, config_flags ) !------------------------------------------------------------------------- ! [3.0] Calculate LHS of adjoint test equation and @@ -55,7 +55,7 @@ subroutine da_test_vtoy_transform(grid, config_flags, vp, vv, xbx, be, iv, y) ! call da_zero_vp_type(vv) ! call da_zero_x(grid%xa) - call da_transform_vtoy_adj(1, be, cv, iv, vp, vv, xbx, y, grid, config_flags, .true. ) + call da_transform_vtoy_adj(be, cv, iv, vp, vv, xbx, y, grid, config_flags, .true. ) adj_rhs = sum( cv(1:cv_size) * cv_2(1:cv_size) ) !------------------------------------------------------------------------- From f6766cc65ff609081bafca18775df037a86cfacf Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 14:41:12 -0700 Subject: [PATCH 71/86] modified: var/run/radiance_info/gcom-w-1-amsr2.info --- var/run/radiance_info/gcom-w-1-amsr2.info | 28 +++++++++++------------ 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/var/run/radiance_info/gcom-w-1-amsr2.info b/var/run/radiance_info/gcom-w-1-amsr2.info index 72e9a2d6d6..0948930bea 100644 --- a/var/run/radiance_info/gcom-w-1-amsr2.info +++ b/var/run/radiance_info/gcom-w-1-amsr2.info @@ -1,15 +1,15 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) - 478 1 1 -1 0 0.7260000000E+00 0.0000000000E+00 10.14561 0.500000 - 478 2 1 -1 0 0.9560000000E+00 1.0000000000E+00 18.24548 0.500000 - 478 3 1 -1 0 0.7750000000E+00 0.0000000000E+00 11.14696 0.500000 - 478 4 1 -1 0 0.9910000000E+00 1.0000000000E+00 20.18668 0.500000 - 478 5 1 1 0 0.8660000000E+00 0.0000000000E+00 21.93555 0.500000 - 478 6 1 1 0 1.1290000000E+00 1.0000000000E+00 40.92418 0.500000 - 478 7 1 1 0 1.2270000000E+00 0.0000000000E+00 28.30175 0.500000 - 478 8 1 1 0 1.7470000000E+00 1.0000000000E+00 57.58830 0.500000 - 478 9 1 1 0 1.6000000000E+00 0.0000000000E+00 12.69287 0.500000 - 478 10 1 1 0 2.6790000000E+00 1.0000000000E+00 27.33099 0.500000 - 478 11 1 1 0 1.1790000000E+00 0.0000000000E+00 23.24269 0.500000 - 478 12 1 1 0 2.2680000000E+00 1.0000000000E+00 53.35099 0.500000 - 478 13 1 -1 0 2.1310000000E+00 0.0000000000E+00 36.07700 0.500000 - 478 14 1 -1 0 4.0750000000E+00 1.0000000000E+00 33.61592 0.500000 + 478 1 1 -1 0 0.7260000000E+00 0.0000000000E+00 10.14561 + 478 2 1 -1 0 0.9560000000E+00 1.0000000000E+00 18.24548 + 478 3 1 -1 0 0.7750000000E+00 0.0000000000E+00 11.14696 + 478 4 1 -1 0 0.9910000000E+00 1.0000000000E+00 20.18668 + 478 5 1 1 0 0.8660000000E+00 0.0000000000E+00 21.93555 + 478 6 1 1 0 1.1290000000E+00 1.0000000000E+00 40.92418 + 478 7 1 1 0 1.2270000000E+00 0.0000000000E+00 28.30175 + 478 8 1 1 0 1.7470000000E+00 1.0000000000E+00 57.58830 + 478 9 1 1 0 1.6000000000E+00 0.0000000000E+00 12.69287 + 478 10 1 1 0 2.6790000000E+00 1.0000000000E+00 27.33099 + 478 11 1 1 0 1.1790000000E+00 0.0000000000E+00 23.24269 + 478 12 1 1 0 2.2680000000E+00 1.0000000000E+00 53.35099 + 478 13 1 -1 0 2.1310000000E+00 0.0000000000E+00 36.07700 + 478 14 1 -1 0 4.0750000000E+00 1.0000000000E+00 33.61592 From c9c93d51aee24c964371ccb864766bab35efdd7c Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 14:45:17 -0700 Subject: [PATCH 72/86] modified: var/da/da_tools/da_get_julian_time.inc --- var/da/da_tools/da_get_julian_time.inc | 1 - 1 file changed, 1 deletion(-) diff --git a/var/da/da_tools/da_get_julian_time.inc b/var/da/da_tools/da_get_julian_time.inc index 8de14fead1..6d718e831d 100644 --- a/var/da/da_tools/da_get_julian_time.inc +++ b/var/da/da_tools/da_get_julian_time.inc @@ -2,7 +2,6 @@ subroutine da_get_julian_time(year,month,day,hour,minute,gstime) !------------------------------------------------------------------------------ ! Purpose: Calculate Julian time from year/month/day/hour/minute. - ! Reference time: 1978 Jan 01 00:00:00 !------------------------------------------------------------------------------ implicit none From 703b03186819f010658a99c4d8bcbde48684901a Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 14:53:16 -0700 Subject: [PATCH 73/86] modified: var/da/da_radiance/da_initialize_rad_iv.inc --- var/da/da_radiance/da_initialize_rad_iv.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index b5f551677d..9a9f508912 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -82,7 +82,7 @@ subroutine da_initialize_rad_iv (i, n, iv, p) end if iv%instid(i)%ps(n) = 0.0 iv%instid(i)%tb_xb(:,n) = 0.0 - if ( any(crtm_cloud) ) then + if ( crtm_cloud ) then iv%instid(i)%tb_xb_clr(:,n) = 0.0 iv%instid(i)%cip(n) = 0.0 end if From 8d8214a58db0c77d64af66445ebdff0b4dfc0411 Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 14:55:22 -0700 Subject: [PATCH 74/86] modified: var/da/da_radiance/da_qc_rad.inc --- var/da/da_radiance/da_qc_rad.inc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/var/da/da_radiance/da_qc_rad.inc b/var/da/da_radiance/da_qc_rad.inc index efa720b05f..2d320227ab 100644 --- a/var/da/da_radiance/da_qc_rad.inc +++ b/var/da/da_radiance/da_qc_rad.inc @@ -65,8 +65,8 @@ subroutine da_qc_rad (it, ob, iv) seviri = trim(rttov_inst_name(rtminit_sensor(i))) == 'seviri' amsr2 = trim(rttov_inst_name(rtminit_sensor(i))) == 'amsr2' imager = trim(rttov_inst_name(rtminit_sensor(i))) == 'imager' - ahi = trim(rttov_inst_name(rtminit_sensor(i))) == 'ahi' - abi = trim(rttov_inst_name(rtminit_sensor(i))) == 'abi' + ahi = trim(rttov_inst_name(rtminit_sensor(i))) == 'ahi' + abi = trim(rttov_inst_name(rtminit_sensor(i))) == 'abi' gmi = trim(rttov_inst_name(rtminit_sensor(i))) == 'gmi' if (hirs) then ! 1.0 QC for HIRS From 9cb56da741e86e81fccf02f3c1ece2c82faed858 Mon Sep 17 00:00:00 2001 From: liujake Date: Thu, 28 Dec 2023 16:19:24 -0700 Subject: [PATCH 75/86] modified: var/da/da_radiance/da_qc_goesabi.inc modified: var/da/da_radiance/da_read_obs_ncgoesabi.inc --- var/da/da_radiance/da_qc_goesabi.inc | 16 ++++++++-------- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 12 ++++++------ 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index 40ec289ebf..e3667e9811 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -154,10 +154,10 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) print_cld_debug = .false. inv_grosscheck = 15.0 - if ( crtm_cloud(it) ) inv_grosscheck = 80.0 + if ( crtm_cloud ) inv_grosscheck = 80.0 if ( use_satcv(2) ) inv_grosscheck = 100.0 - if ( crtm_cloud(it) ) then + if ( crtm_cloud ) then tb_xb_clr => iv%instid(isens)%tb_xb_clr !JJG: for Harnisch et al. BTlim using stats from CONUS 9km 2-hr WRF forecast from GSI analysis @@ -228,7 +228,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! 3.0 check cloud !----------------------------------------------------------------- - if (.not. crtm_cloud(it) ) then + if (.not. crtm_cloud ) then if (iv%instid(isens)%clwp(n) >= 0.2) then tb_qc = qc_bad if (iv%instid(isens)%info%proc_domain(1,n)) & @@ -253,7 +253,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) end if end if - abi_clddet: if ( use_clddet_abi ) then + abi_clddet: if ( use_clddet_zz ) then !!=============================================================================== !!=============================================================================== @@ -523,7 +523,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) iv%instid(isens)%cloud_flag(:,n) = & - NINT( real( sum(clddet_tests) , 8 ) / real( iv%instid(isens)%superob_width**2, 8 ) ) - if (.not. crtm_cloud(it) .and. & + if (.not. crtm_cloud .and. & iv%instid(isens)%cloud_flag(1,n) < 0) then tb_qc = qc_bad end if @@ -537,14 +537,14 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) ! --------------------------- ! 5.0 assigning obs errors - if (.not. crtm_cloud(it) ) then + if (.not. crtm_cloud ) then if (use_error_factor_rad) then iv%instid(isens)%tb_error(:,n) = & satinfo(isens)%error_std(:) * satinfo(isens)%error_factor(:) else iv%instid(isens)%tb_error(:,n) = satinfo(isens)%error_std(:) end if - else !crtm_cloud(it) + else !crtm_cloud ! calculate cloud impacts where ( tb_inv( :, n ) > missing_r & .and. tb_obs( :, n ) > 0. & @@ -571,7 +571,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) 0.5 * ( cloud_mod(:,n) + cloud_obs(:,n) ) !JJGDEBUG - if (use_rad_symm_err) then + if (abi_use_symm_obs_err) then ! symmetric error model ! - Okamoto, McNally, & Bell (2013) ! - Harnish, Weissmann, & Perianez (2016) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index ddb2a3c6ac..42e1b5003f 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -317,7 +317,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) num_goesabi_thinned = 0 abi_halo_width = abi_superob_halfwidth - if ( use_clddet_abi ) then + if ( use_clddet_zz ) then abi_halo_width = abi_halo_width + 10 end if @@ -1291,10 +1291,10 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! write(unit=stdout,fmt='(A,I0,A,I0)') & ' Reading ', count(readmask_p), ' abi radiances for band ',channel_list(ichan) - if ( use_clddet_abi) write(unit=stdout,fmt='(A,I0)') & + if ( use_clddet_zz) write(unit=stdout,fmt='(A,I0)') & ' which includes the cloud detection halo' TEMPIR_ifile = -1 - if ( use_clddet_abi .and. channel_list(ichan).eq.14 ) then + if ( use_clddet_zz .and. channel_list(ichan).eq.14 ) then ! Require earlier file to be withn 1/2 of TEMPIR_delay_minutes TEMPIR_min_time_diff = TEMPIR_delay_minutes !write(unit=stdout,fmt='(A,F14.2)') & @@ -1403,7 +1403,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) this_view % lat_1d % patch, this_view % lon_1d % patch, & solzen_1d, solazi_1d ) - if ( use_clddet_abi .and. & + if ( use_clddet_zz .and. & abi_halo_width-abi_superob_halfwidth.ge.1) then ! Allocate terrain_hgt using local indices for this view allocate( terrain_hgt ( & @@ -1721,7 +1721,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) ! Values for TEMPIR cloud QC ! - channel 14 - if ( use_clddet_abi .and. (channel_list(ichan).eq.14) ) then + if ( use_clddet_zz .and. (channel_list(ichan).eq.14) ) then p % superob(isup,jsup) % cld_qc(1) % TEMPIR = missing_r @@ -2015,7 +2015,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) call mpi_barrier(comm, ierr) #endif - if (trace_use) call da_trace_exit("da_read_obs_ncgoesimg") + if (trace_use) call da_trace_exit("da_read_obs_ncgoesabi") end subroutine da_read_obs_ncgoesabi From a263f4347e6102066eeea9bbf4a320f934e08559 Mon Sep 17 00:00:00 2001 From: liujake Date: Fri, 29 Dec 2023 13:29:10 -0700 Subject: [PATCH 76/86] modified: var/da/da_define_structures/da_define_structures.f90 --- .../da_define_structures.f90 | 28 ++++++------------- 1 file changed, 9 insertions(+), 19 deletions(-) diff --git a/var/da/da_define_structures/da_define_structures.f90 b/var/da/da_define_structures/da_define_structures.f90 index cfda9b20db..b960760f55 100644 --- a/var/da/da_define_structures/da_define_structures.f90 +++ b/var/da/da_define_structures/da_define_structures.f90 @@ -577,7 +577,9 @@ module da_define_structures real :: RTCT, RFMFT, TEMPIR, terr_hgt real :: tb_stddev_10, tb_stddev_13,tb_stddev_14 real :: CIRH2O - !real, allocatable :: CIRH2O(:,:,:) + real, allocatable :: CIRH2O_abi(:,:,:) ! only for ABI + real, allocatable :: tb_stddev_3x3(:) ! only for ABI + integer :: RFMFT_ij(2) ! only for ABI end type clddet_geoir_type type superob_type real, allocatable :: tb_obs(:,:) @@ -591,18 +593,6 @@ module da_define_structures real, pointer :: vtox(:,:) end type cv_index_type - type cld_qc_type - real :: RTCT, RFMFT, TEMPIR, terr_hgt - integer :: RFMFT_ij(2) - real, allocatable :: tb_stddev_3x3(:) - real, allocatable :: CIRH2O(:,:,:) - end type cld_qc_type - - type superob_type - real, allocatable :: tb_obs(:,:) - type(cld_qc_type), allocatable :: cld_qc(:) - end type superob_type - type instid_type ! Instrument triplet, follow the convension of RTTOV integer :: platform_id, satellite_id, sensor_id @@ -630,8 +620,8 @@ module da_define_structures integer, pointer :: cloud_flag(:,:) integer, pointer :: cloudflag(:) integer, pointer :: rain_flag(:) - real, pointer :: cloud_mod(:,:) - real, pointer :: cloud_obs(:,:) + real, pointer :: cloud_mod(:,:) ! only for ABI + real, pointer :: cloud_obs(:,:) ! only for ABI real, allocatable :: cloud_frac(:) real, pointer :: satzen(:) real, pointer :: satazi(:) @@ -646,10 +636,10 @@ module da_define_structures real, pointer :: lod(:,:,:) ! layer_optical_depth real, pointer :: trans(:,:,:) ! layer transmittance real, pointer :: der_trans(:,:,:) ! d(transmittance)/dp - real, pointer :: kmin_t(:) - real, pointer :: kmax_p(:) - real, pointer :: sensitivity_ratio(:,:,:) - real, pointer :: p_chan_level(:,:) + real, pointer :: kmin_t(:) + real, pointer :: kmax_p(:) + real, pointer :: sensitivity_ratio(:,:,:) + real, pointer :: p_chan_level(:,:) real, pointer :: qrn(:,:) real, pointer :: qcw(:,:) real, pointer :: qci(:,:) From bd8d1769b1e973a43218a86beeeaa465d8c1ccd5 Mon Sep 17 00:00:00 2001 From: liujake Date: Fri, 29 Dec 2023 14:42:18 -0700 Subject: [PATCH 77/86] modified: var/da/da_define_structures/da_define_structures.f90 modified: var/da/da_radiance/da_allocate_rad_iv.inc modified: var/da/da_radiance/da_deallocate_radiance.inc modified: var/da/da_radiance/da_initialize_rad_iv.inc modified: var/da/da_radiance/module_radiance.f90 modified: var/run/radiance_info/goes-16-abi.info modified: var/run/radiance_info/goes-17-abi.info --- .../da_define_structures.f90 | 1 - var/da/da_radiance/da_allocate_rad_iv.inc | 8 ++++--- var/da/da_radiance/da_deallocate_radiance.inc | 22 +++++++------------ var/da/da_radiance/da_initialize_rad_iv.inc | 11 ++++------ var/da/da_radiance/module_radiance.f90 | 1 + var/run/radiance_info/goes-16-abi.info | 20 ++++++++--------- var/run/radiance_info/goes-17-abi.info | 18 +++++++-------- 7 files changed, 37 insertions(+), 44 deletions(-) diff --git a/var/da/da_define_structures/da_define_structures.f90 b/var/da/da_define_structures/da_define_structures.f90 index b960760f55..0bbb205134 100644 --- a/var/da/da_define_structures/da_define_structures.f90 +++ b/var/da/da_define_structures/da_define_structures.f90 @@ -577,7 +577,6 @@ module da_define_structures real :: RTCT, RFMFT, TEMPIR, terr_hgt real :: tb_stddev_10, tb_stddev_13,tb_stddev_14 real :: CIRH2O - real, allocatable :: CIRH2O_abi(:,:,:) ! only for ABI real, allocatable :: tb_stddev_3x3(:) ! only for ABI integer :: RFMFT_ij(2) ! only for ABI end type clddet_geoir_type diff --git a/var/da/da_radiance/da_allocate_rad_iv.inc b/var/da/da_radiance/da_allocate_rad_iv.inc index 1c68ae680b..bfb448196a 100644 --- a/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/var/da/da_radiance/da_allocate_rad_iv.inc @@ -127,9 +127,11 @@ subroutine da_allocate_rad_iv (i, nchan, iv) do ix = 1, iv%instid(i)%superob_width allocate (iv%instid(i)%superob(ix,iy)%cld_qc(iv%instid(i)%num_rad)) allocate (iv%instid(i)%superob(ix,iy)%tb_obs(nchan,iv%instid(i)%num_rad)) - do n = 1, iv%instid(i)%num_rad - allocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3(nchan)) - end do + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + do n = 1, iv%instid(i)%num_rad + allocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3(nchan)) + end do + end if end do end do end if diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index 946aab9fc7..967377aacc 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -21,6 +21,7 @@ deallocate (satinfo(i) % ichan) deallocate (satinfo(i) % iuse) deallocate (satinfo(i) % error) + deallocate (satinfo(i) % error_cld) deallocate (satinfo(i) % error_cld_y) deallocate (satinfo(i) % error_cld_x) deallocate (satinfo(i) % polar) @@ -149,31 +150,24 @@ deallocate (iv%instid(i)%solzen) deallocate (iv%instid(i)%solazi) deallocate (iv%instid(i)%tropt) - deallocate(iv%instid(i)%cloud_frac) deallocate (iv%instid(i)%gamma_jacobian) deallocate(iv%instid(i)%cloud_frac) if ( use_clddet_zz ) then - if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then do iy = 1, iv%instid(i)%superob_width do ix = 1, iv%instid(i)%superob_width + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then do n = 1,iv%instid(i)%num_rad if ( allocated (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3) ) & deallocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3) - if ( allocated (iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O) ) & - deallocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O) + if ( allocated (iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O_abi) ) & + deallocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O_abi) end do + end if + deallocate (iv%instid(i)%superob(ix,iy)%cld_qc) + deallocate (iv%instid(i)%superob(ix,iy)%tb_obs) end do end do - end if - if ( index(iv%instid(i)%rttovid_string, 'ahi') > 0 ) then - do iy = 1, iv%instid(i)%superob_width - do ix = 1, iv%instid(i)%superob_width - deallocate (iv%instid(i)%superob(ix,iy)%cld_qc) - deallocate (iv%instid(i)%superob(ix,iy)%tb_obs) - end do - end do - end if - deallocate (iv%instid(i)%superob) + deallocate (iv%instid(i)%superob) end if if (ANY(use_satcv)) then if (use_satcv(2)) then diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index 9a9f508912..54d5944b9a 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -112,19 +112,15 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%tropt(n) = 0.0 iv%instid(i)%cloud_frac(n) = missing_r ! iv%instid(i)%solazi(n) = 0.0 - if ( use_clddet_zz .and. & - ( (index(iv%instid(i)%rttovid_string, 'abi') > 0) .or. (index(iv%instid(i)%rttovid_string, 'ahi') > 0) ) ) then + if ( use_clddet_zz ) then if ( allocated ( p % superob ) ) then do iy = 1, iv%instid(i)%superob_width do ix = 1, iv%instid(i)%superob_width iv%instid(i)%superob(ix,iy)%tb_obs(:,n) = p % superob(ix,iy) % tb_obs(:,1) + if (index(iv%instid(i)%rttovid_string, 'abi') > 0) then if ( allocated ( p % superob(ix,iy) % cld_qc(1) % tb_stddev_3x3 ) ) & iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3(:) = p % superob(ix,iy) % cld_qc(1) % tb_stddev_3x3(:) - if ( allocated ( p % superob(ix,iy) % cld_qc(1) % CIRH2O ) .and. & - size(p % superob(ix,iy) % cld_qc(1) % CIRH2O).eq.1) then - allocate ( iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O(1,1,1) ) - iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O = p % superob(ix,iy) % cld_qc(1) % CIRH2O - end if + end if iv%instid(i)%superob(ix,iy)%cld_qc(n)%RTCT = p % superob(ix,iy) % cld_qc(1) % RTCT iv%instid(i)%superob(ix,iy)%cld_qc(n)%RFMFT = p % superob(ix,iy) % cld_qc(1) % RFMFT iv%instid(i)%superob(ix,iy)%cld_qc(n)%TEMPIR = p % superob(ix,iy) % cld_qc(1) % TEMPIR @@ -132,6 +128,7 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_13 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_13 iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_14 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_14 iv%instid(i)%superob(ix,iy)%cld_qc(n)%terr_hgt = p % superob(ix,iy) % cld_qc(1) % terr_hgt + iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O = p % superob(ix,iy) % cld_qc(1) % CIRH2O end do end do end if diff --git a/var/da/da_radiance/module_radiance.f90 b/var/da/da_radiance/module_radiance.f90 index a030e3f3c5..fd63eaf668 100644 --- a/var/da/da_radiance/module_radiance.f90 +++ b/var/da/da_radiance/module_radiance.f90 @@ -160,6 +160,7 @@ module module_radiance integer, pointer :: ichan(:) ! channel index integer, pointer :: iuse (:) ! usage flag (-1: not use) from radiance info file real , pointer :: error(:) ! error Standard Deviation from radiance info file + real , pointer :: error_cld(:) ! error Standard Deviation for cloudy radiance from radiance info file real , pointer :: error_cld_y(:) ! error Standard Deviation for cloudy radiance from radiance info file real , pointer :: error_cld_x(:) ! error Standard Deviation for cloudy radiance from radiance info file real , pointer :: polar(:) ! polarisation (0:ver; 1:hori) from radiance info file diff --git a/var/run/radiance_info/goes-16-abi.info b/var/run/radiance_info/goes-16-abi.info index bb9e6ce4ac..7c3cd410c8 100644 --- a/var/run/radiance_info/goes-16-abi.info +++ b/var/run/radiance_info/goes-16-abi.info @@ -1,11 +1,11 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) - 1023 1 1 -1 0 2.7200000000E+00 0.0000000000E+00 25.00000 12.00000 - 1023 2 1 1 0 1.7900000000E+00 0.0000000000E+00 8.60000 18.00000 - 1023 3 1 1 0 1.9200000000E+00 0.0000000000E+00 12.00000 26.00000 - 1023 4 1 1 0 1.7400000000E+00 0.0000000000E+00 16.90000 23.00000 - 1023 5 1 -1 0 5.0000000000E+00 0.0000000000E+00 27.00000 18.00000 - 1023 6 1 -1 0 2.7900000000E+00 0.0000000000E+00 15.00000 10.00000 - 1023 7 1 -1 0 3.0800000000E+00 0.0000000000E+00 28.00000 20.00000 - 1023 8 1 -1 0 3.0600000000E+00 0.0000000000E+00 28.00000 20.00000 - 1023 9 1 -1 0 2.8200000000E+00 0.0000000000E+00 28.00000 20.00000 - 1023 10 1 -1 0 1.7400000000E+00 0.0000000000E+00 20.00000 12.00000 + 1023 7 1 -1 0 2.7200000000E+00 0.0000000000E+00 25.00000 12.00000 + 1023 8 1 1 0 1.7900000000E+00 0.0000000000E+00 8.60000 18.00000 + 1023 9 1 1 0 1.9200000000E+00 0.0000000000E+00 12.00000 26.00000 + 1023 10 1 1 0 1.7400000000E+00 0.0000000000E+00 16.90000 23.00000 + 1023 11 1 -1 0 5.0000000000E+00 0.0000000000E+00 27.00000 18.00000 + 1023 12 1 -1 0 2.7900000000E+00 0.0000000000E+00 15.00000 10.00000 + 1023 13 1 -1 0 3.0800000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 14 1 -1 0 3.0600000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 15 1 -1 0 2.8200000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 16 1 -1 0 1.7400000000E+00 0.0000000000E+00 20.00000 12.00000 diff --git a/var/run/radiance_info/goes-17-abi.info b/var/run/radiance_info/goes-17-abi.info index ad646d9ce6..e3e93b26af 100644 --- a/var/run/radiance_info/goes-17-abi.info +++ b/var/run/radiance_info/goes-17-abi.info @@ -1,11 +1,11 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) - 1023 1 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 2 1 1 0 5.0000000000E+00 0.0000000000E+00 10.00000 9.00000 - 1023 3 1 1 0 5.0000000000E+00 0.0000000000E+00 16.00000 15.00000 - 1023 4 1 1 0 5.0000000000E+00 0.0000000000E+00 21.00000 19.00000 - 1023 5 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 6 1 1 0 10.0000000000E+00 0.0000000000E+00 30.00000 8.00000 1023 7 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 8 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 9 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 10 1 1 0 5.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 8 1 1 0 5.0000000000E+00 0.0000000000E+00 10.00000 9.00000 + 1023 9 1 1 0 5.0000000000E+00 0.0000000000E+00 16.00000 15.00000 + 1023 10 1 1 0 5.0000000000E+00 0.0000000000E+00 21.00000 19.00000 + 1023 11 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 12 1 1 0 10.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 13 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 14 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 15 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 16 1 1 0 5.0000000000E+00 0.0000000000E+00 30.00000 8.00000 From 79b625a44a61e9dfcb7f11f68ddb77f724326e28 Mon Sep 17 00:00:00 2001 From: liujake Date: Fri, 29 Dec 2023 15:23:41 -0700 Subject: [PATCH 78/86] This commit allows to build WRFDA-3DVar on derecho modified: var/da/da_define_structures/da_define_structures.f90 modified: var/da/da_radiance/da_qc_goesabi.inc modified: var/da/da_radiance/da_radiance1.f90 modified: var/da/da_radiance/da_read_obs_ncgoesabi.inc --- .../da_define_structures.f90 | 3 +- var/da/da_radiance/da_qc_goesabi.inc | 59 +------------------ var/da/da_radiance/da_radiance1.f90 | 4 -- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 38 ++++++------ 4 files changed, 24 insertions(+), 80 deletions(-) diff --git a/var/da/da_define_structures/da_define_structures.f90 b/var/da/da_define_structures/da_define_structures.f90 index 0bbb205134..ac0b2c1843 100644 --- a/var/da/da_define_structures/da_define_structures.f90 +++ b/var/da/da_define_structures/da_define_structures.f90 @@ -575,8 +575,9 @@ module da_define_structures end type varbc_type type clddet_geoir_type real :: RTCT, RFMFT, TEMPIR, terr_hgt - real :: tb_stddev_10, tb_stddev_13,tb_stddev_14 + real :: tb_stddev_10, tb_stddev_13,tb_stddev_14 ! only for AHI real :: CIRH2O + real, allocatable :: CIRH2O_abi(:,:,:) ! only for ABI real, allocatable :: tb_stddev_3x3(:) ! only for ABI integer :: RFMFT_ij(2) ! only for ABI end type clddet_geoir_type diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc index e3667e9811..ec860279e9 100644 --- a/var/da/da_radiance/da_qc_goesabi.inc +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -273,7 +273,7 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) tb_xb_clr(:,n) if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG3: ', n, & tb_obs(:,n) - if (crtm_cloud(it) ) then + if (crtm_cloud ) then if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG4: ', n, & tb_xb_clr(:,n) end if @@ -424,8 +424,8 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%terr_hgt <= 2000. & .and. iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%tb_stddev_3x3(ch10) > 0.5 & .and. iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%tb_stddev_3x3(ch14) > 0.5 - if ( allocated(iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%CIRH2O) ) & - crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%CIRH2O(1,1,1) + + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%CIRH2O case (7) !-------------------------------------------------------------------------- @@ -704,56 +704,3 @@ subroutine da_qc_goesabi (it, isens, nchan, ob, iv) end subroutine da_qc_goesabi - - -function relative_azimuth ( sol_az ,sen_az ) - - implicit none - - real :: sol_az - real :: sen_az - real :: relative_azimuth - - relative_azimuth = abs(sol_az - sen_az) - if (relative_azimuth > 180.0) then - relative_azimuth = 360.0 - relative_azimuth - endif - relative_azimuth = 180.0 - relative_azimuth - -end function relative_azimuth - - -function glint_angle ( sol_zen , sat_zen , rel_az ) - !------------------------------------------------------------------------------------ - ! Glint angle (the angle difference between direct "specular" reflection off - ! the surface and actual reflection toward the satellite.) - !------------------------------------------------------------------------------------ - - implicit none - - real :: sol_zen - real :: sat_zen - real :: rel_az - real :: glint_angle - - glint_angle = cos(sol_zen * deg2rad) * cos(sat_zen * deg2rad) + & - sin(sol_zen * deg2rad) * sin(sat_zen * deg2rad) * cos(rel_az * deg2rad) - glint_angle = max(-1.0 , min( glint_angle ,1.0 )) - glint_angle = acos(glint_angle) / deg2rad - -end function glint_angle - -!subroutine evaluate_clddet_test ( isflg, isflgs, crit_clddet, eps, extra_qual, & -! lat, lon, & -! reject_clddet ) -! -! integer, intent(in) :: isflg, isflgs(:) -! real, intent(in) :: crit_clddet, eps(:), lat, lon -! logical, intent(in) :: extra_qual(:) -! logical, intent(out) :: reject_clddet -! -! reject_clddet = .false. -! reject_clddet = crit_clddet > missing_r .and. any( isflg.eq.isflgs .and. crit_clddet > eps .and. extra_qual ) -! -!end subroutine evaluate_clddet_test - diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index 1c57f87634..d53688d6a5 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -55,10 +55,6 @@ module da_radiance1 implicit none -#ifdef DM_PARALLEL - include 'mpif.h' -#endif - type datalink_type type (info_type) :: info diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 42e1b5003f..20d1b04fae 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -1656,34 +1656,34 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if (channel_list(ichan).eq.10) then - allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O ( & + allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ( & iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 2 ) ) - p % superob(isup,jsup) % cld_qc(1) % CIRH2O(:,:,1) = & + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi(:,:,1) = & bt_p( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) end if if (channel_list(ichan).eq.14 .and. & - size(p % superob(isup,jsup) % cld_qc(1) % CIRH2O).gt.1) then + size(p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi).gt.1) then - p % superob(isup,jsup) % cld_qc(1) % CIRH2O(:,:,2) = & + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi(:,:,2) = & bt_p( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) nkeep = 0 do jy = iysup-tbuf, iysup+tbuf do jx = ixsup-tbuf, ixsup+tbuf - if ( all(p % superob(isup,jsup) % cld_qc(1) % CIRH2O( jy, jx, : ) .gt. missing_r) ) nkeep = nkeep + 1 + if ( all(p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, : ) .gt. missing_r) ) nkeep = nkeep + 1 end do end do allocate( tb_temp ( nkeep, 2 ) ) ikeep = 0 do jy = iysup-tbuf, iysup+tbuf do jx = ixsup-tbuf, ixsup+tbuf - if ( all(p % superob(isup,jsup) % cld_qc(1) % CIRH2O( jy, jx, : ) .gt. missing_r) ) then + if ( all(p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, : ) .gt. missing_r) ) then ikeep = ikeep + 1 tb_temp(ikeep,1) = & - p % superob(isup,jsup) % cld_qc(1) % CIRH2O( jy, jx, 1 ) + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, 1 ) tb_temp(ikeep,2) = & - p % superob(isup,jsup) % cld_qc(1) % CIRH2O( jy, jx, 2 ) + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, 2 ) end if end do end do @@ -1700,21 +1700,21 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) real(nkeep,r_double) / ( sigma10 * sigma14 ) deallocate( tb_temp ) - deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O ) - allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O (1,1,1) ) + deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) + allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1) ) - p % superob(isup,jsup) % cld_qc(1) % CIRH2O (1,1,1) = pearson + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1) = pearson end if else if ( any( channel_list(ichan).eq.(/10,14/) ) ) then - if ( allocated( p % superob(isup,jsup) % cld_qc(1) % CIRH2O ) ) & - deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O) + if ( allocated( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) ) & + deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi) - allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O (1,1,1)) + allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1)) - p % superob(isup,jsup) % cld_qc(1) % CIRH2O = missing_r + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi = missing_r end if end if @@ -1897,8 +1897,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) do jsup = 1, superob_width do isup = 1, superob_width deallocate ( current % superob(isup,jsup) % tb_obs ) - if ( allocated ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O ) ) & - deallocate ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O ) + if ( allocated ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) ) & + deallocate ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) deallocate ( current % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3 ) deallocate ( current % superob(isup,jsup) % cld_qc ) end do @@ -1998,8 +1998,8 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) do jsup = 1, superob_width do isup = 1, superob_width deallocate ( current % superob(isup,jsup) % tb_obs ) - if ( allocated ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O ) ) & - deallocate ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O ) + if ( allocated ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) ) & + deallocate ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) deallocate ( current % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3 ) deallocate ( current % superob(isup,jsup) % cld_qc ) end do From 7513457cb9a02495239eccf518213bb86b3d6557 Mon Sep 17 00:00:00 2001 From: liujake Date: Sun, 7 Jan 2024 14:56:14 -0700 Subject: [PATCH 79/86] More clear up modified: compile modified: var/da/da_monitor/da_rad_diags.f90 modified: var/da/da_radiance/da_get_innov_vector_crtm.inc modified: var/da/da_radiance/da_get_innov_vector_rttov.inc modified: var/da/da_radiance/da_initialize_rad_iv.inc modified: var/da/da_radiance/da_radiance_init.inc modified: var/da/da_radiance/da_setup_radiance_structures.inc modified: var/da/da_radiance/da_write_iv_rad_ascii.inc modified: var/da/da_radiance/da_write_oa_rad_ascii.inc modified: var/da/da_radiance/module_radiance.f90 modified: var/da/da_setup_structures/da_setup_obs_structures.inc modified: var/da/da_tools/da_tools.f90 modified: var/run/radiance_info/goes-17-abi.info --- compile | 2 +- var/da/da_monitor/da_rad_diags.f90 | 26 ++++++------------- .../da_radiance/da_get_innov_vector_crtm.inc | 12 --------- .../da_radiance/da_get_innov_vector_rttov.inc | 3 +-- var/da/da_radiance/da_initialize_rad_iv.inc | 10 ++++--- var/da/da_radiance/da_radiance_init.inc | 2 ++ .../da_setup_radiance_structures.inc | 1 - var/da/da_radiance/da_write_iv_rad_ascii.inc | 10 +++---- var/da/da_radiance/da_write_oa_rad_ascii.inc | 10 +++---- var/da/da_radiance/module_radiance.f90 | 4 +-- .../da_setup_obs_structures.inc | 8 ++++++ var/da/da_tools/da_tools.f90 | 2 +- var/run/radiance_info/goes-17-abi.info | 14 +++++----- 13 files changed, 44 insertions(+), 60 deletions(-) diff --git a/compile b/compile index 0595d05db1..71624ba466 100755 --- a/compile +++ b/compile @@ -351,7 +351,7 @@ else 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" + setenv RTTOV_LIB "-L${hdf5path}/lib -lhdf5_hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -lhdf5_hl_f90cstub -lhdf5_f90cstub -lhdf5_hl_cpp -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." diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index 318bb29a12..d762ad0256 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -264,12 +264,11 @@ program da_rad_diags allocate ( tb_oma(1:nchan,1:total_npixel) ) allocate ( tb_err(1:nchan,1:total_npixel) ) allocate ( tb_qc(1:nchan,1:total_npixel) ) - allocate ( cloud_flag(1:nchan,1:total_npixel) ) - cloud_flag = 0 if ( abi ) then allocate ( cloud_mod(1:nchan,1:total_npixel) ) allocate ( cloud_obs(1:nchan,1:total_npixel) ) - allocate ( tb_bak_clr(1:nchan,1:total_npixel) ) + allocate ( cloud_flag(1:nchan,1:total_npixel)) + cloud_flag = 0 end if allocate ( ems(1:nchan,1:total_npixel) ) if ( jac_found ) then @@ -344,7 +343,6 @@ program da_rad_diags if ( abi ) then cloud_mod = missing_r cloud_obs = missing_r - tb_bak_clr = missing_r end if ncname = 'diags_'//trim(instid(iinst))//"_"//datestr1(itime)//'.nc' @@ -407,15 +405,13 @@ program da_rad_diags read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! QC read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_qc(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CLOUD - read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) cloud_flag(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CMOD, INFO, or level if ( abi .and. buf(1:4) == "CMOD" ) then ! read cloud_mod, cloud_obs, tb_bak_clr for abi read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) cloud_mod(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! COBS read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) cloud_obs(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! BGCLR - read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_bak_clr(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! INFO or level + read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) cloud_flag(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CMOD, INFO, or level end if if ( buf(1:4) == "INFO" ) then backspace(iunit(iproc)) @@ -547,14 +543,12 @@ program da_rad_diags end if ios = NF_DEF_VAR(ncid, 'tb_err', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_DEF_VAR(ncid, 'tb_qc', NF_INT, 2, ishape(1:2), varid) - ios = NF_DEF_VAR(ncid, 'cloud_flag', NF_INT, 2, ishape(1:2), varid) if ( abi ) then ios = NF_DEF_VAR(ncid, 'cloud_mod', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) ios = NF_DEF_VAR(ncid, 'cloud_obs', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) - ios = NF_DEF_VAR(ncid, 'tb_bak_clr', NF_FLOAT, 2, ishape(1:2), varid) - ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) + ios = NF_DEF_VAR(ncid, 'cloud_flag', NF_INT, 2, ishape(1:2), varid) end if ! ! define 2-D array with dimensions nlev * total_npixel @@ -663,8 +657,6 @@ program da_rad_diags ios = NF_DEF_VAR(ncid, 'ret_clw', NF_FLOAT, 1, ishape(1), varid) end if ios = NF_DEF_VAR(ncid, 'cloud_frac', NF_FLOAT, 1, ishape(1), varid) - ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) - ios = NF_ENDDEF(ncid) ! @@ -704,15 +696,13 @@ program da_rad_diags ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_err) ios = NF_INQ_VARID (ncid, 'tb_qc', varid) ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), tb_qc) - ios = NF_INQ_VARID (ncid, 'cloud_flag', varid) - ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), cloud_flag) if ( abi ) then ios = NF_INQ_VARID (ncid, 'cloud_mod', varid) ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), cloud_mod) ios = NF_INQ_VARID (ncid, 'cloud_obs', varid) ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), cloud_obs) - ios = NF_INQ_VARID (ncid, 'tb_bak_clr', varid) - ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_bak_clr) + ios = NF_INQ_VARID (ncid, 'cloud_flag', varid) + ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), cloud_flag) end if ! ! output 2-D array with dimensions nlev * total_npixel @@ -938,13 +928,13 @@ program da_rad_diags if ( abi ) then deallocate ( cloud_mod ) deallocate ( cloud_obs ) + deallocate ( cloud_flag ) end if deallocate ( tb_oma ) deallocate ( ems ) if ( jac_found ) deallocate ( ems_jac ) deallocate ( tb_err ) deallocate ( tb_qc ) - deallocate ( cloud_flag ) if ( prf_found .and. (rtm_option == 'CRTM') ) then deallocate ( prf_pfull ) deallocate ( prf_phalf ) diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index 6d72b1decc..f2fceb00c2 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -444,18 +444,6 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) call da_trop_wmo ( tt_pixel, geoht_pixel, pp_pixel, (min(kte,kme-1)-kts+1), tropt = iv%instid(inst)%tropt(n) ) end if - - if ( use_clddet_zz & - .AND. trim( crtm_sensor_name(rtminit_sensor(inst))) == 'abi' ) then - ! Find tropopause temperature for Zhuge and Zou Cloud Detection - do k = kts, min(kte,kme-1) - tt_pixel(k) = Atmosphere(1)%Temperature(kte-k+1) - pp_pixel(k) = Atmosphere(1)%Pressure(kte-k+1) - call da_interp_2d_partial ( geoht_full(:,:,k), iv%instid(inst)%info, k, n, n, geoht_pixel(k) ) - end do - call da_trop_wmo ( tt_pixel, geoht_pixel, pp_pixel, (min(kte,kme-1)-kts+1), tropt = iv%instid(inst)%tropt(n) ) - end if - call da_interp_2d_partial (grid%xb%u10, iv%instid(inst)%info, 1, n, n, model_u10(n:n)) call da_interp_2d_partial (grid%xb%v10, iv%instid(inst)%info, 1, n, n, model_v10(n:n)) call da_interp_2d_partial (grid%xb%psfc, iv%instid(inst)%info, 1, n, n, model_psfc(n:n)) 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 2152f291dc..3f4dce9799 100644 --- a/var/da/da_radiance/da_get_innov_vector_rttov.inc +++ b/var/da/da_radiance/da_get_innov_vector_rttov.inc @@ -149,8 +149,7 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) iv%instid(inst)%surftype(n) = 0 end if - if ( use_clddet_zz & - .AND. trim( rttov_inst_name(rtminit_sensor(inst))) == 'abi' ) then + if ( use_clddet_zz ) then ! Find tropopause temperature for Zhuge and Zou Cloud Detection do k = kts, min(kte,kme-1) call da_interp_2d_partial ( grid%xb%t(:,:,k), iv%instid(inst)%info, k, n, n, tt_pixel(k) ) diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index 54d5944b9a..77f89b7067 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -121,14 +121,16 @@ subroutine da_initialize_rad_iv (i, n, iv, p) if ( allocated ( p % superob(ix,iy) % cld_qc(1) % tb_stddev_3x3 ) ) & iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3(:) = p % superob(ix,iy) % cld_qc(1) % tb_stddev_3x3(:) end if - iv%instid(i)%superob(ix,iy)%cld_qc(n)%RTCT = p % superob(ix,iy) % cld_qc(1) % RTCT - iv%instid(i)%superob(ix,iy)%cld_qc(n)%RFMFT = p % superob(ix,iy) % cld_qc(1) % RFMFT - iv%instid(i)%superob(ix,iy)%cld_qc(n)%TEMPIR = p % superob(ix,iy) % cld_qc(1) % TEMPIR + if (index(iv%instid(i)%rttovid_string, 'ahi') > 0) then iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_10 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_10 iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_13 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_13 iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_14 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_14 - iv%instid(i)%superob(ix,iy)%cld_qc(n)%terr_hgt = p % superob(ix,iy) % cld_qc(1) % terr_hgt iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O = p % superob(ix,iy) % cld_qc(1) % CIRH2O + end if + iv%instid(i)%superob(ix,iy)%cld_qc(n)%RTCT = p % superob(ix,iy) % cld_qc(1) % RTCT + iv%instid(i)%superob(ix,iy)%cld_qc(n)%RFMFT = p % superob(ix,iy) % cld_qc(1) % RFMFT + iv%instid(i)%superob(ix,iy)%cld_qc(n)%TEMPIR = p % superob(ix,iy) % cld_qc(1) % TEMPIR + iv%instid(i)%superob(ix,iy)%cld_qc(n)%terr_hgt = p % superob(ix,iy) % cld_qc(1) % terr_hgt end do end do end if diff --git a/var/da/da_radiance/da_radiance_init.inc b/var/da/da_radiance/da_radiance_init.inc index 09f3e70f91..f10d047f2b 100644 --- a/var/da/da_radiance/da_radiance_init.inc +++ b/var/da/da_radiance/da_radiance_init.inc @@ -195,10 +195,12 @@ subroutine da_radiance_init(iv,ob) allocate ( satinfo(n) % ichan(nchanl(n)) ) allocate ( satinfo(n) % iuse (nchanl(n)) ) allocate ( satinfo(n) % error(nchanl(n)) ) + allocate ( satinfo(n) % error_cld(nchanl(n)) ) allocate ( satinfo(n) % error_cld_y(nchanl(n)) ) allocate ( satinfo(n) % error_cld_x(nchanl(n)) ) allocate ( satinfo(n) % polar(nchanl(n)) ) + satinfo(n) % error_cld(:) = 500.0 !initialize satinfo(n) % error_cld_y(:) = 500.0 !initialize satinfo(n) % error_cld_x(:) = 5.0 !initialize diff --git a/var/da/da_radiance/da_setup_radiance_structures.inc b/var/da/da_radiance/da_setup_radiance_structures.inc index 40e2e868bb..10f5f1c724 100644 --- a/var/da/da_radiance/da_setup_radiance_structures.inc +++ b/var/da/da_radiance/da_setup_radiance_structures.inc @@ -11,7 +11,6 @@ subroutine da_setup_radiance_structures( grid, ob, iv ) type (iv_type), intent(inout) :: iv ! O-B structure. character(len=200) :: filename - character(len=200) :: fpath(4) integer :: i, j, n, ios, ifgat logical :: lprinttovs diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index 1d26c9959c..efb3b2874c 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -178,7 +178,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10f11.2)') ob%instid(i)%tb(:,n) write(unit=innov_rad_unit,fmt='(a)') 'BAK : ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb(:,n) - if (rtm_option==rtm_option_crtm .and. crtm_cloud .and. (amsr2 .or. ahi) ) then + if (rtm_option==rtm_option_crtm .and. crtm_cloud .and. (amsr2 .or. ahi .or. abi) ) then write(unit=innov_rad_unit,fmt='(a)') 'BAK_clr : ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb_clr(:,n) endif @@ -198,15 +198,13 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=innov_rad_unit,fmt='(a)') 'QC : ' write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) - write(unit=innov_rad_unit,fmt='(a)') 'CLOUD : ' - write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) - if ( abi .and. crtm_cloud ) then ! write out cloud_mod, cloud_obs, tb_xb_clr + if ( abi .and. crtm_cloud ) then ! write out cloud_mod, cloud_obs write(unit=innov_rad_unit,fmt='(a)') 'CMOD : ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_mod(:,n) write(unit=innov_rad_unit,fmt='(a)') 'COBS : ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_obs(:,n) - write(unit=innov_rad_unit,fmt='(a)') 'BGCLR: ' - write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb_clr(:,n) + write(unit=innov_rad_unit,fmt='(a)') 'CLOUD : ' + write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) end if if (write_profile) then diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index 23664ed58c..613cbcf4c5 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -61,7 +61,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) write(unit=oma_rad_unit,fmt='(a)') ' pixel-info : i date scanpos landsea_mask elv lat lon satzen satazi solzen solazi' end if write(unit=oma_rad_unit,fmt='(a)') ' xb-surf-info : i t2m mr2m(ppmv) u10 v10 ps ts smois tslb snowh isflg & - & soiltyp vegtyp vegfra elev clwp cloud_frac' + & soiltyp vegtyp vegfra elev clwp' ndomain = 0 do n=1,iv%instid(i)%num_rad if (iv%instid(i)%info%proc_domain(1,n)) then @@ -142,15 +142,13 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=oma_rad_unit,fmt='(a)') 'QC : ' write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) - write(unit=oma_rad_unit,fmt='(a)') 'CLOUD : ' - write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) - if ( abi .and. crtm_cloud ) then ! write out cloud_mod, cloud_obs, tb_xb_clr + if ( abi .and. crtm_cloud ) then ! write out cloud_mod, cloud_obs, cloud_flag write(unit=oma_rad_unit,fmt='(a)') 'CMOD : ' write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_mod(:,n) write(unit=oma_rad_unit,fmt='(a)') 'COBS : ' write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_obs(:,n) - write(unit=oma_rad_unit,fmt='(a)') 'BGCLR: ' - write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb_clr(:,n) + write(unit=oma_rad_unit,fmt='(a)') 'CLOUD : ' + write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) end if if (write_profile) then diff --git a/var/da/da_radiance/module_radiance.f90 b/var/da/da_radiance/module_radiance.f90 index fd63eaf668..ba3ad3f581 100644 --- a/var/da/da_radiance/module_radiance.f90 +++ b/var/da/da_radiance/module_radiance.f90 @@ -161,8 +161,8 @@ module module_radiance integer, pointer :: iuse (:) ! usage flag (-1: not use) from radiance info file real , pointer :: error(:) ! error Standard Deviation from radiance info file real , pointer :: error_cld(:) ! error Standard Deviation for cloudy radiance from radiance info file - real , pointer :: error_cld_y(:) ! error Standard Deviation for cloudy radiance from radiance info file - real , pointer :: error_cld_x(:) ! error Standard Deviation for cloudy radiance from radiance info file + real , pointer :: error_cld_y(:) ! error Standard Deviation for cloudy radiance from radiance info file, for ABI + real , pointer :: error_cld_x(:) ! error Standard Deviation for cloudy radiance from radiance info file, for ABI real , pointer :: polar(:) ! polarisation (0:ver; 1:hori) from radiance info file real , pointer :: error_factor(:) ! error tuning factor ! from error tuning file ! new air mass bias correction coefs. diff --git a/var/da/da_setup_structures/da_setup_obs_structures.inc b/var/da/da_setup_structures/da_setup_obs_structures.inc index f0c6b9a394..e627396308 100644 --- a/var/da/da_setup_structures/da_setup_obs_structures.inc +++ b/var/da/da_setup_structures/da_setup_obs_structures.inc @@ -67,6 +67,10 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) use_airsobs = .false. use_eos_amsuaobs = .false. use_hsbobs = .false. + use_ahiobs = .false. + use_mwhs2obs = .false. + use_gmiobs = .false. + use_goesabiobs = .false. use_obsgts = .false. use_rad = .false. use_airsretobs = .false. @@ -154,6 +158,10 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) use_airsobs = .false. use_eos_amsuaobs = .false. use_hsbobs = .false. + use_ahiobs = .false. + use_mwhs2obs = .false. + use_gmiobs = .false. + use_goesabiobs = .false. use_obsgts = .false. use_rad = .false. use_airsretobs = .false. diff --git a/var/da/da_tools/da_tools.f90 b/var/da/da_tools/da_tools.f90 index e5b00ae9db..fa5247d1c1 100644 --- a/var/da/da_tools/da_tools.f90 +++ b/var/da/da_tools/da_tools.f90 @@ -108,8 +108,8 @@ module da_tools #include "da_gaus_noise.inc" #include "da_openfile.inc" #include "da_smooth_anl.inc" -#include "da_togrid.inc" #include "da_togrid_new.inc" +#include "da_togrid.inc" #include "da_togrid_1d.inc" #include "da_unifva.inc" #include "da_buddy_qc.inc" diff --git a/var/run/radiance_info/goes-17-abi.info b/var/run/radiance_info/goes-17-abi.info index e3e93b26af..db8322f635 100644 --- a/var/run/radiance_info/goes-17-abi.info +++ b/var/run/radiance_info/goes-17-abi.info @@ -1,11 +1,11 @@ sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) - 1023 7 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 7 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 1023 8 1 1 0 5.0000000000E+00 0.0000000000E+00 10.00000 9.00000 1023 9 1 1 0 5.0000000000E+00 0.0000000000E+00 16.00000 15.00000 1023 10 1 1 0 5.0000000000E+00 0.0000000000E+00 21.00000 19.00000 - 1023 11 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 12 1 1 0 10.0000000000E+00 0.0000000000E+00 30.00000 8.00000 - 1023 13 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 14 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 15 1 1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 - 1023 16 1 1 0 5.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 11 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 12 1 -1 0 10.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 13 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 14 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 15 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 16 1 -1 0 5.0000000000E+00 0.0000000000E+00 30.00000 8.00000 From 498675e7ce9426c0d8b94ed7ff27b17d444355c8 Mon Sep 17 00:00:00 2001 From: liujake Date: Sun, 7 Jan 2024 17:29:01 -0700 Subject: [PATCH 80/86] modified: var/da/da_monitor/da_rad_diags.f90 --- var/da/da_monitor/da_rad_diags.f90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index d762ad0256..0c9aa79a60 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -404,14 +404,14 @@ program da_rad_diags read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_err(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! QC read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_qc(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CLOUD - if ( abi .and. buf(1:4) == "CMOD" ) then ! read cloud_mod, cloud_obs, tb_bak_clr for abi + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf + if ( abi .and. buf(1:4) == "CMOD" ) then ! read cloud_mod, cloud_obs, cloud_flag for abi read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) cloud_mod(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! COBS + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CMOD read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) cloud_obs(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! BGCLR + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! COBS read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) cloud_flag(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CMOD, INFO, or level + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! cloud_flag end if if ( buf(1:4) == "INFO" ) then backspace(iunit(iproc)) From 153425996563d6c34920a56a998b010886411ef1 Mon Sep 17 00:00:00 2001 From: liujake Date: Sun, 7 Jan 2024 17:32:31 -0700 Subject: [PATCH 81/86] modified: var/da/da_monitor/da_rad_diags.f90 --- var/da/da_monitor/da_rad_diags.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index 0c9aa79a60..6d2db8f686 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -263,7 +263,7 @@ program da_rad_diags allocate ( tb_inv(1:nchan,1:total_npixel) ) allocate ( tb_oma(1:nchan,1:total_npixel) ) allocate ( tb_err(1:nchan,1:total_npixel) ) - allocate ( tb_qc(1:nchan,1:total_npixel) ) + allocate ( tb_qc(1:nchan,1:total_npixel) ) if ( abi ) then allocate ( cloud_mod(1:nchan,1:total_npixel) ) allocate ( cloud_obs(1:nchan,1:total_npixel) ) From 877acffecda65c35d5ea0353f6625446f628298d Mon Sep 17 00:00:00 2001 From: liujake Date: Sun, 7 Jan 2024 19:47:11 -0700 Subject: [PATCH 82/86] modified: var/da/da_radiance/da_deallocate_radiance.inc modified: var/da/da_radiance/da_radiance_init.inc --- var/da/da_radiance/da_deallocate_radiance.inc | 4 +-- var/da/da_radiance/da_radiance_init.inc | 28 +++++++++++-------- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index 967377aacc..d15f89ffc1 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -22,8 +22,8 @@ deallocate (satinfo(i) % iuse) deallocate (satinfo(i) % error) deallocate (satinfo(i) % error_cld) - deallocate (satinfo(i) % error_cld_y) - deallocate (satinfo(i) % error_cld_x) +! deallocate (satinfo(i) % error_cld_y) +! deallocate (satinfo(i) % error_cld_x) deallocate (satinfo(i) % polar) deallocate (satinfo(i) % scanbias) diff --git a/var/da/da_radiance/da_radiance_init.inc b/var/da/da_radiance/da_radiance_init.inc index f10d047f2b..8b34ccbd03 100644 --- a/var/da/da_radiance/da_radiance_init.inc +++ b/var/da/da_radiance/da_radiance_init.inc @@ -34,7 +34,7 @@ subroutine da_radiance_init(iv,ob) integer :: iunit character(len=filename_len) :: filename character(len=20) :: cdum - real :: error_cld_y, error_cld_x +! real :: error_cld_y, error_cld_x character(len=12) :: cdum12 real :: error_cld @@ -196,13 +196,13 @@ subroutine da_radiance_init(iv,ob) allocate ( satinfo(n) % iuse (nchanl(n)) ) allocate ( satinfo(n) % error(nchanl(n)) ) allocate ( satinfo(n) % error_cld(nchanl(n)) ) - allocate ( satinfo(n) % error_cld_y(nchanl(n)) ) - allocate ( satinfo(n) % error_cld_x(nchanl(n)) ) +! allocate ( satinfo(n) % error_cld_y(nchanl(n)) ) +! allocate ( satinfo(n) % error_cld_x(nchanl(n)) ) allocate ( satinfo(n) % polar(nchanl(n)) ) satinfo(n) % error_cld(:) = 500.0 !initialize - satinfo(n) % error_cld_y(:) = 500.0 !initialize - satinfo(n) % error_cld_x(:) = 5.0 !initialize +! satinfo(n) % error_cld_y(:) = 500.0 !initialize +! satinfo(n) % error_cld_x(:) = 5.0 !initialize ! Allocate additional fields for AHI if ( index(iv%instid(n)%rttovid_string, 'ahi') > 0 ) then @@ -228,7 +228,7 @@ subroutine da_radiance_init(iv,ob) if ( len_trim(cdum) > 0 .and. index(cdum,'-') == 0 ) then ! read the line again to get error_cld when it is available backspace(iunit) - read(iunit,'(1x,5i5,2e18.10,2f10.5)') & + read(iunit,'(1x,5i5,2e18.10,f10.5)') & wmo_sensor_id, & satinfo(n)%ichan(j), & sensor_type, & @@ -236,12 +236,16 @@ subroutine da_radiance_init(iv,ob) idum, & satinfo(n)%error(j), & satinfo(n)%polar(j), & - error_cld_y, & - error_cld_x - if ( error_cld_y > 0.0 ) & - satinfo(n)%error_cld_y(j) = error_cld_y - if ( error_cld_x > 0.0 ) & - satinfo(n)%error_cld_x(j) = error_cld_x + error_cld + if ( error_cld > 0.0 ) then + satinfo(n)%error_cld(j) = error_cld + end if +! error_cld_y, & +! error_cld_x +! if ( error_cld_y > 0.0 ) & +! satinfo(n)%error_cld_y(j) = error_cld_y +! if ( error_cld_x > 0.0 ) & +! satinfo(n)%error_cld_x(j) = error_cld_x end if From 9d62429f121d961eeb562be5d4885934a31cf7b6 Mon Sep 17 00:00:00 2001 From: liujake Date: Mon, 8 Jan 2024 11:55:42 -0700 Subject: [PATCH 83/86] modified: var/da/da_obs/da_fill_obs_structures.inc modified: var/da/da_radiance/da_get_innov_vector_crtm.inc modified: var/da/da_radiance/da_initialize_rad_iv.inc --- var/da/da_obs/da_fill_obs_structures.inc | 75 +++++++++++-------- .../da_radiance/da_get_innov_vector_crtm.inc | 16 ++-- var/da/da_radiance/da_initialize_rad_iv.inc | 11 +-- 3 files changed, 59 insertions(+), 43 deletions(-) diff --git a/var/da/da_obs/da_fill_obs_structures.inc b/var/da/da_obs/da_fill_obs_structures.inc index 860114da80..56e4f438fa 100644 --- a/var/da/da_obs/da_fill_obs_structures.inc +++ b/var/da/da_obs/da_fill_obs_structures.inc @@ -16,9 +16,24 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) real :: geometric_h, geopotential_h integer :: i,j logical :: outside + logical :: uvq_direct_local if (trace_use) call da_trace_entry("da_fill_obs_structures") + !--------------------------------------------------------------------------- + ! Initialise uvq_direct_local (for intel oneAPI) + !--------------------------------------------------------------------------- + + if (.not. present(uvq_direct)) then + uvq_direct_local = .false. + else + if (.not. uvq_direct) then + uvq_direct_local = .false. + else + uvq_direct_local = .true. + end if + end if + !--------------------------------------------------------------------------- ! Initialise obs error factors (which will be overwritten in use_obs_errfac) !--------------------------------------------------------------------------- @@ -147,8 +162,8 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) if ( q_error_options == 1 ) then ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then - rh_error = iv%synop(n)%q%error ! q error is rh at this stage! + if (.not. uvq_direct_local) then + rh_error = iv%synop(n)%q%error ! q error is rh at this stage! ! if((ob % synop(n) % p > iv%ptop) .AND. & ! (ob % synop(n) % t > 100.0) .AND. & @@ -156,12 +171,12 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! (iv % synop(n) % p % qc >= obs_qc_pointer) .and. & ! (iv % synop(n) % t % qc >= obs_qc_pointer) .and. & ! (iv % synop(n) % q % qc >= obs_qc_pointer)) then - call da_get_q_error(ob % synop(n) % p, & + call da_get_q_error(ob % synop(n) % p, & ob % synop(n) % t, & ob % synop(n) % q, & iv % synop(n) % t % error, & rh_error, iv % synop(n) % q % error) - if (iv%synop(n)% q % error == missing_r) iv%synop(n)% q % qc = missing_data + if (iv%synop(n)% q % error == missing_r) iv%synop(n)% q % qc = missing_data ! end if end if @@ -181,16 +196,16 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then - rh_error = iv%metar(n)%q%error ! q error is rh at this stage! - call da_get_q_error(iv % metar(n) % p % inv, & + if (.not. uvq_direct_local) then + rh_error = iv%metar(n)%q%error ! q error is rh at this stage! + call da_get_q_error(iv % metar(n) % p % inv, & ob % metar(n) % t, & ob % metar(n) % q, & iv % metar(n) % t % error, & rh_error, q_error) - iv % metar(n) % q % error = q_error - if (iv%metar(n)% q % error == missing_r) & - iv%metar(n)% q % qc = missing_data + iv % metar(n) % q % error = q_error + if (iv%metar(n)% q % error == missing_r) & + iv%metar(n)% q % qc = missing_data end if end do end if @@ -207,16 +222,16 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then - rh_error = iv%ships(n)%q%error ! q error is rh at this stage! - call da_get_q_error(iv % ships(n) % p % inv, & + if (.not. uvq_direct_local) then + rh_error = iv%ships(n)%q%error ! q error is rh at this stage! + call da_get_q_error(iv % ships(n) % p % inv, & ob % ships(n) % t, & ob % ships(n) % q, & iv % ships(n) % t % error, & rh_error, q_error) - iv % ships(n) % q % error = q_error + iv % ships(n) % q % error = q_error - if(iv%ships(n)% q % error == missing_r) iv%ships(n)% q % qc = missing_data + if(iv%ships(n)% q % error == missing_r) iv%ships(n)% q % qc = missing_data end if end do @@ -301,7 +316,7 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then + if (.not. uvq_direct_local) then rh_error = iv%sound(n)%q(k)%error ! q error is rh at this stage! call da_get_q_error(iv % sound(n) % p(k), & ob % sound(n) % t(k), & @@ -310,8 +325,8 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) rh_error, q_error) iv % sound(n) % q(k) % error = q_error - if (iv%sound(n)% q(k) % error == missing_r) & - iv%sound(n)% q(k) % qc = missing_data + if (iv%sound(n)% q(k) % error == missing_r) & + iv%sound(n)% q(k) % qc = missing_data end if end do end do @@ -327,15 +342,15 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then - rh_error = iv%sonde_sfc(n)%q%error ! q error is rh at this stage! - call da_get_q_error(iv % sonde_sfc(n) % p % inv, & + if (.not. uvq_direct_local) then + rh_error = iv%sonde_sfc(n)%q%error ! q error is rh at this stage! + call da_get_q_error(iv % sonde_sfc(n) % p % inv, & ob % sonde_sfc(n) % t, & ob % sonde_sfc(n) % q, & iv % sonde_sfc(n) % t % error, & rh_error, iv % sonde_sfc(n) % q % error) - if (iv%sonde_sfc(n)% q % error == missing_r) & - iv%sonde_sfc(n)% q % qc = missing_data + if (iv%sonde_sfc(n)% q % error == missing_r) & + iv%sonde_sfc(n)% q % qc = missing_data end if end do end if @@ -350,7 +365,7 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ob % airep(n) % t(k) = iv % airep(n) % t(k) % inv ob % airep(n) % q(k) = iv % airep(n) % q(k) % inv - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then + if (.not. uvq_direct_local) then rh_error = iv%airep(n)%q(k)%error ! q error is rh at this stage! call da_get_q_error(iv % airep(n) % p(k), & ob % airep(n) % t(k), & @@ -463,16 +478,16 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then - rh_error = iv%buoy(n)%q%error ! q error is rh at this stage! - call da_get_q_error(iv % buoy(n) % p % inv, & + if (.not. uvq_direct_local) then + rh_error = iv%buoy(n)%q%error ! q error is rh at this stage! + call da_get_q_error(iv % buoy(n) % p % inv, & ob % buoy(n) % t, & ob % buoy(n) % q, & iv % buoy(n) % t % error, & rh_error, q_error) - iv % buoy(n) % q % error = q_error + iv % buoy(n) % q % error = q_error - if(iv%buoy (n)% q % error == missing_r) iv%buoy (n)% q % qc = missing_data + if(iv%buoy (n)% q % error == missing_r) iv%buoy (n)% q % qc = missing_data end if end do end if @@ -555,7 +570,7 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then + if (.not. uvq_direct_local) then rh_error = iv%airsr(n)%q(k)%error ! q error is rh at this stage! call da_get_q_error(iv % airsr(n) % p(k), & ob % airsr(n) % t(k), & diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index f2fceb00c2..17a8d4c635 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -476,14 +476,14 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) cycle pixel_loop end if end do - if ( all(ob%instid(inst)%tb(1:nchanl,n) < 0.) ) then - write(message(1),'(a,2i5.0,a)') ' Skipping the pixel at loc ', i, j, & - ' where all observed BTs are < 0' - call da_warning(__FILE__,__LINE__,message(1:1)) - iv%instid(inst)%tb_inv(:,n) = missing_r - iv%instid(inst)%info%proc_domain(:,n) = .false. - cycle pixel_loop - end if + !if ( all(ob%instid(inst)%tb(1:nchanl,n) < 0.) ) then + ! write(message(1),'(a,2i5.0,a)') ' Skipping the pixel at loc ', i, j, & + ! ' where all observed BTs are < 0' + ! call da_warning(__FILE__,__LINE__,message(1:1)) + ! iv%instid(inst)%tb_inv(:,n) = missing_r + ! iv%instid(inst)%info%proc_domain(:,n) = .false. + ! cycle pixel_loop + !end if ! convert cloud content unit from kg/kg to kg/m^2 if (crtm_cloud) then diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index 77f89b7067..e4d91d3dbb 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -92,11 +92,12 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%tb_sens(:,n) = 0.0 iv%instid(i)%tb_imp(:,n) = 0.0 iv%instid(i)%rad_xb(:,n) = 0.0 - if ( associated( p % rad_obs ) ) then - iv%instid(i)%rad_obs(:,n) = p%rad_obs(:) - else - iv%instid(i)%rad_obs(:,n) = 0.0 - end if + iv%instid(i)%rad_obs(:,n) = 0.0 + !if ( associated( p % rad_obs ) ) then + ! iv%instid(i)%rad_obs(:,n) = p%rad_obs(:) + !else + ! iv%instid(i)%rad_obs(:,n) = 0.0 + !end if iv%instid(i)%rad_ovc(:,:,n) = 0.0 iv%instid(i)%emiss(:,n) = 0.0 iv%instid(i)%scanpos(n) = p%scanpos From 7a04ace8310883c502e92e2d69a56533b297419b Mon Sep 17 00:00:00 2001 From: liujake Date: Mon, 15 Jan 2024 11:57:01 -0700 Subject: [PATCH 84/86] modified: var/da/da_radiance/da_allocate_rad_iv.inc modified: var/da/da_radiance/da_deallocate_radiance.inc modified: var/da/da_radiance/da_get_innov_vector_crtm.inc modified: var/da/da_radiance/da_radiance_init.inc modified: var/run/VARBC.in --- var/da/da_radiance/da_allocate_rad_iv.inc | 1 + var/da/da_radiance/da_deallocate_radiance.inc | 9 +++- .../da_radiance/da_get_innov_vector_crtm.inc | 16 +++--- var/da/da_radiance/da_radiance_init.inc | 49 +++++++++++++------ var/run/VARBC.in | 38 +++++++------- 5 files changed, 70 insertions(+), 43 deletions(-) diff --git a/var/da/da_radiance/da_allocate_rad_iv.inc b/var/da/da_radiance/da_allocate_rad_iv.inc index bfb448196a..947498601b 100644 --- a/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/var/da/da_radiance/da_allocate_rad_iv.inc @@ -116,6 +116,7 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate (iv%instid(i)%gamma_jacobian(nchan,iv%instid(i)%num_rad)) allocate (iv%instid(i)%cloud_frac(iv%instid(i)%num_rad)) if ( use_clddet_zz ) then + ! here we assume AHI and ABI (they cover different regions) are not used simultaneously if ( index(iv%instid(i)%rttovid_string, 'ahi') > 0 ) & iv%instid(i)%superob_width = 2*ahi_superob_halfwidth+1 if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) & diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index d15f89ffc1..1ba3834654 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -22,8 +22,6 @@ deallocate (satinfo(i) % iuse) deallocate (satinfo(i) % error) deallocate (satinfo(i) % error_cld) -! deallocate (satinfo(i) % error_cld_y) -! deallocate (satinfo(i) % error_cld_x) deallocate (satinfo(i) % polar) deallocate (satinfo(i) % scanbias) @@ -40,6 +38,13 @@ deallocate ( satinfo(i) % clearSkyBias) endif + ! Deallocate extra variables for ABI + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + deallocate (satinfo(i) % error_cld_y) + deallocate (satinfo(i) % error_cld_x) + endif + + if (use_error_factor_rad) then deallocate (satinfo(i) % error_factor) endif diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index 17a8d4c635..f2fceb00c2 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -476,14 +476,14 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) cycle pixel_loop end if end do - !if ( all(ob%instid(inst)%tb(1:nchanl,n) < 0.) ) then - ! write(message(1),'(a,2i5.0,a)') ' Skipping the pixel at loc ', i, j, & - ! ' where all observed BTs are < 0' - ! call da_warning(__FILE__,__LINE__,message(1:1)) - ! iv%instid(inst)%tb_inv(:,n) = missing_r - ! iv%instid(inst)%info%proc_domain(:,n) = .false. - ! cycle pixel_loop - !end if + if ( all(ob%instid(inst)%tb(1:nchanl,n) < 0.) ) then + write(message(1),'(a,2i5.0,a)') ' Skipping the pixel at loc ', i, j, & + ' where all observed BTs are < 0' + call da_warning(__FILE__,__LINE__,message(1:1)) + iv%instid(inst)%tb_inv(:,n) = missing_r + iv%instid(inst)%info%proc_domain(:,n) = .false. + cycle pixel_loop + end if ! convert cloud content unit from kg/kg to kg/m^2 if (crtm_cloud) then diff --git a/var/da/da_radiance/da_radiance_init.inc b/var/da/da_radiance/da_radiance_init.inc index 8b34ccbd03..63e471de9c 100644 --- a/var/da/da_radiance/da_radiance_init.inc +++ b/var/da/da_radiance/da_radiance_init.inc @@ -34,9 +34,9 @@ subroutine da_radiance_init(iv,ob) integer :: iunit character(len=filename_len) :: filename character(len=20) :: cdum -! real :: error_cld_y, error_cld_x + real :: error_cld_y, error_cld_x ! for ABI character(len=12) :: cdum12 - real :: error_cld + real :: error_cld ! for AMSR2 ! local variables for tuning error factor !---------------------------------------- @@ -196,13 +196,9 @@ subroutine da_radiance_init(iv,ob) allocate ( satinfo(n) % iuse (nchanl(n)) ) allocate ( satinfo(n) % error(nchanl(n)) ) allocate ( satinfo(n) % error_cld(nchanl(n)) ) -! allocate ( satinfo(n) % error_cld_y(nchanl(n)) ) -! allocate ( satinfo(n) % error_cld_x(nchanl(n)) ) allocate ( satinfo(n) % polar(nchanl(n)) ) satinfo(n) % error_cld(:) = 500.0 !initialize -! satinfo(n) % error_cld_y(:) = 500.0 !initialize -! satinfo(n) % error_cld_x(:) = 5.0 !initialize ! Allocate additional fields for AHI if ( index(iv%instid(n)%rttovid_string, 'ahi') > 0 ) then @@ -212,6 +208,14 @@ subroutine da_radiance_init(iv,ob) allocate ( satinfo(n) % clearSkyBias(nchanl(n)) ) endif + ! Allocate additional fields for ABI + if ( index(iv%instid(n)%rttovid_string, 'abi') > 0 ) then + allocate ( satinfo(n) % error_cld_y(nchanl(n)) ) + allocate ( satinfo(n) % error_cld_x(nchanl(n)) ) + satinfo(n) % error_cld_y(:) = 500.0 !initialize + satinfo(n) % error_cld_x(:) = 5.0 !initialize + endif + read(iunit,*) do j = 1, nchanl(n) read(iunit,'(1x,5i5,2e18.10,a20)') & @@ -225,7 +229,7 @@ subroutine da_radiance_init(iv,ob) cdum !in the current radiance info files, the last column !can be either sensor_id_string or blank - if ( len_trim(cdum) > 0 .and. index(cdum,'-') == 0 ) then + if ( len_trim(cdum) > 0 .and. index(cdum,'-') == 0 ) then ! this is for AMSR2 ! read the line again to get error_cld when it is available backspace(iunit) read(iunit,'(1x,5i5,2e18.10,f10.5)') & @@ -240,13 +244,6 @@ subroutine da_radiance_init(iv,ob) if ( error_cld > 0.0 ) then satinfo(n)%error_cld(j) = error_cld end if -! error_cld_y, & -! error_cld_x -! if ( error_cld_y > 0.0 ) & -! satinfo(n)%error_cld_y(j) = error_cld_y -! if ( error_cld_x > 0.0 ) & -! satinfo(n)%error_cld_x(j) = error_cld_x - end if ! If AHI, read some extra things @@ -273,6 +270,30 @@ subroutine da_radiance_init(iv,ob) write(*,fmt='(i7,6x,4f9.3)') satinfo(n)%ichan(j), satinfo(n)%BTLim(j), satinfo(n)%ca1(j), satinfo(n)%ca2(j), satinfo(n)%clearSkyBias(j) endif + ! If ABI, read some extra things + ! Unfortunately, we need to read everything again... + if ( index(iv%instid(n)%rttovid_string, 'abi') > 0 ) then + backspace(iunit) + read(iunit,'(1x,5i5,2e18.10,2f10.5)') & + wmo_sensor_id, & + satinfo(n)%ichan(j), & + sensor_type, & + satinfo(n)%iuse(j) , & + idum, & + satinfo(n)%error(j), & + satinfo(n)%polar(j), & + error_cld_y, error_cld_x + if ( error_cld_y > 0.0 ) & + satinfo(n)%error_cld_y(j) = error_cld_y + if ( error_cld_x > 0.0 ) & + satinfo(n)%error_cld_x(j) = error_cld_x + if ( j == 1 ) then + write(*,*)'Reading extra data for ABI' + write(*,*)'Channel error_cld_y error_cld_x' + endif + write(*,fmt='(i7,6x,2f10.5)') satinfo(n)%ichan(j), satinfo(n)%error_cld_y(j), satinfo(n)%error_cld_x(j) + endif + iv%instid(n)%ichan(j) = satinfo(n)%ichan(j) ob%instid(n)%ichan(j) = satinfo(n)%ichan(j) end do diff --git a/var/run/VARBC.in b/var/run/VARBC.in index 30d511950e..8c407c79eb 100644 --- a/var/run/VARBC.in +++ b/var/run/VARBC.in @@ -2405,6 +2405,25 @@ 8 8 0 0 0 0 0 -1 -1 -1 -0.600 0.000 0.000 0.000 0.000 9 9 0 0 0 0 0 -1 -1 -1 -1.000 0.000 0.000 0.000 0.000 10 10 0 0 0 0 0 -1 -1 -1 -2.000 0.000 0.000 0.000 0.000 + ------------------------------------------------ + Platform_id Sat_id Sensor_id Nchanl Npredmax + ------------------------------------------------ + 4 16 44 10 8 + -----> Bias predictor statistics: Mean & Std & Nbgerr + 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 + 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 + 10000 10000 10000 10000 10000 10000 10000 10000 + -----> Chanl_id Chanl_nb Pred_use(-1/0/1) Param + 1 1 0 0 0 0 0 -1 -1 -1 2.100 0.000 0.000 0.000 0.000 + 2 2 0 0 0 0 0 -1 -1 -1 0.299 0.000 -0.001 -0.006 0.009 + 3 3 0 0 0 0 0 -1 -1 -1 0.516 0.001 -0.005 0.000 0.019 + 4 4 0 0 0 0 0 -1 -1 -1 -0.095 -0.005 0.001 -0.002 0.024 + 5 5 0 0 0 0 0 -1 -1 -1 -1.000 0.000 0.000 0.000 0.000 + 6 6 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 7 7 0 0 0 0 0 -1 -1 -1 -0.800 0.000 0.000 0.000 0.000 + 8 8 0 0 0 0 0 -1 -1 -1 -0.600 0.000 0.000 0.000 0.000 + 9 9 0 0 0 0 0 -1 -1 -1 -1.000 0.000 0.000 0.000 0.000 + 10 10 0 0 0 0 0 -1 -1 -1 -2.000 0.000 0.000 0.000 0.000 ------------------------------------------------ Platform_id Sat_id Sensor_id Nchanl Npredmax ------------------------------------------------ @@ -2444,22 +2463,3 @@ 2 3 1 1 1 1 1 -1 -1 -1 3.628 -0.025 0.107 0.022 0.238 3 4 1 1 1 1 1 -1 -1 -1 -0.443 0.329 -0.067 -0.454 0.448 4 6 1 1 1 1 1 -1 -1 -1 -0.605 0.202 -0.073 -0.160 0.511 - ------------------------------------------------ - Platform_id Sat_id Sensor_id Nchanl Npredmax - ------------------------------------------------ - 4 16 44 10 8 - -----> Bias predictor statistics: Mean & Std & Nbgerr - 1.0 9181.9 8559.5 281.9 14.6 3.5 14.3 64.3 - 0.0 250.5 212.7 11.2 11.1 1.4 10.3 64.4 - 10000 10000 10000 10000 10000 10000 10000 10000 - -----> Chanl_id Chanl_nb Pred_use(-1/0/1) Param - 1 1 1 1 1 1 1 -1 -1 -1 -1.175 0.496 -0.214 0.151 -0.447 - 2 2 1 1 1 1 1 -1 -1 -1 0.618 -0.002 0.051 0.152 0.060 - 3 3 1 1 1 1 1 -1 -1 -1 1.231 -0.031 0.069 0.082 0.075 - 4 4 1 1 1 1 1 -1 -1 -1 -0.151 -0.055 -0.003 -0.052 0.235 - 5 5 1 1 1 1 1 -1 -1 -1 -1.771 0.122 -0.190 0.353 -0.680 - 6 6 1 1 1 1 1 -1 -1 -1 -16.708 1.273 -2.270 -2.149 0.901 - 7 7 1 1 1 1 1 -1 -1 -1 -1.368 0.289 -0.190 0.568 -1.110 - 8 8 1 1 1 1 1 -1 -1 -1 -1.064 0.400 -0.183 0.825 -1.462 - 9 9 1 1 1 1 1 -1 -1 -1 -1.323 0.293 -0.195 0.859 -1.478 - 10 10 1 1 1 1 1 -1 -1 -1 -2.083 0.063 -0.143 0.314 -0.450 From 718e5ae32f4567d3ea83c82adbd79a7aa383c72c Mon Sep 17 00:00:00 2001 From: liujake Date: Mon, 15 Jan 2024 16:00:46 -0700 Subject: [PATCH 85/86] modified: var/da/da_radiance/da_read_obs_ncgoesabi.inc --- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 20d1b04fae..83dc0598c1 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -1805,7 +1805,7 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) deallocate(view_att) if (tot_files_used .lt. 1) then - write(unit=message(1),fmt=*) "Either no L1B data found or no matching fgat windows for GOES-",satellite_id," ABI using prefix ",INST_PREFIX, "for this process rank. This subdomain may have an unacceptable zenith angle or fall entirely outside the GOES viewing extent." + write(unit=message(1),fmt=*) "Either no L1B data found or no matching fgat windows for GOES-",satellite_id," ABI using prefix ",INST_PREFIX, " for this process rank. This subdomain may have an unacceptable zenith angle or fall entirely outside the GOES viewing extent." ! write(unit=message(1),fmt='(A)') "Either no L1B data found or no matching" ! write(unit=message(2),fmt='(A,I2,A)') "fgat windows for GOES-",satellite_id," ABI using" From 825734292cacb4ed169634025f2a522205c02e3d Mon Sep 17 00:00:00 2001 From: liujake Date: Mon, 15 Jan 2024 18:31:08 -0700 Subject: [PATCH 86/86] modified: var/da/da_define_structures/da_define_structures.f90 modified: var/da/da_radiance/da_get_innov_vector_crtm.inc modified: var/da/da_radiance/da_initialize_rad_iv.inc modified: var/da/da_radiance/da_read_obs_ncgoesabi.inc --- .../da_define_structures.f90 | 4 ++-- var/da/da_radiance/da_get_innov_vector_crtm.inc | 16 ++++++++-------- var/da/da_radiance/da_initialize_rad_iv.inc | 2 +- var/da/da_radiance/da_read_obs_ncgoesabi.inc | 8 ++++---- 4 files changed, 15 insertions(+), 15 deletions(-) diff --git a/var/da/da_define_structures/da_define_structures.f90 b/var/da/da_define_structures/da_define_structures.f90 index ac0b2c1843..2ecff3eaaa 100644 --- a/var/da/da_define_structures/da_define_structures.f90 +++ b/var/da/da_define_structures/da_define_structures.f90 @@ -574,9 +574,9 @@ module da_define_structures real, pointer :: vtox(:,:) end type varbc_type type clddet_geoir_type - real :: RTCT, RFMFT, TEMPIR, terr_hgt + real :: RTCT, RFMFT, TEMPIR, terr_hgt ! for both ABI and AHI real :: tb_stddev_10, tb_stddev_13,tb_stddev_14 ! only for AHI - real :: CIRH2O + real :: CIRH2O ! for both ABI and AHI real, allocatable :: CIRH2O_abi(:,:,:) ! only for ABI real, allocatable :: tb_stddev_3x3(:) ! only for ABI integer :: RFMFT_ij(2) ! only for ABI diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index f2fceb00c2..17a8d4c635 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -476,14 +476,14 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) cycle pixel_loop end if end do - if ( all(ob%instid(inst)%tb(1:nchanl,n) < 0.) ) then - write(message(1),'(a,2i5.0,a)') ' Skipping the pixel at loc ', i, j, & - ' where all observed BTs are < 0' - call da_warning(__FILE__,__LINE__,message(1:1)) - iv%instid(inst)%tb_inv(:,n) = missing_r - iv%instid(inst)%info%proc_domain(:,n) = .false. - cycle pixel_loop - end if + !if ( all(ob%instid(inst)%tb(1:nchanl,n) < 0.) ) then + ! write(message(1),'(a,2i5.0,a)') ' Skipping the pixel at loc ', i, j, & + ! ' where all observed BTs are < 0' + ! call da_warning(__FILE__,__LINE__,message(1:1)) + ! iv%instid(inst)%tb_inv(:,n) = missing_r + ! iv%instid(inst)%info%proc_domain(:,n) = .false. + ! cycle pixel_loop + !end if ! convert cloud content unit from kg/kg to kg/m^2 if (crtm_cloud) then diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index e4d91d3dbb..4cc7740f33 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -126,8 +126,8 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_10 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_10 iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_13 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_13 iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_14 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_14 - iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O = p % superob(ix,iy) % cld_qc(1) % CIRH2O end if + iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O = p % superob(ix,iy) % cld_qc(1) % CIRH2O iv%instid(i)%superob(ix,iy)%cld_qc(n)%RTCT = p % superob(ix,iy) % cld_qc(1) % RTCT iv%instid(i)%superob(ix,iy)%cld_qc(n)%RFMFT = p % superob(ix,iy) % cld_qc(1) % RFMFT iv%instid(i)%superob(ix,iy)%cld_qc(n)%TEMPIR = p % superob(ix,iy) % cld_qc(1) % TEMPIR diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc index 83dc0598c1..30ba8f994b 100644 --- a/var/da/da_radiance/da_read_obs_ncgoesabi.inc +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -1701,9 +1701,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) deallocate( tb_temp ) deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) - allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1) ) + !allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1) ) - p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1) = pearson + p % superob(isup,jsup) % cld_qc(1) % CIRH2O = pearson end if else @@ -1712,9 +1712,9 @@ subroutine da_read_obs_ncgoesabi (iv, satellite_id) if ( allocated( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) ) & deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi) - allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1)) + !allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1)) - p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi = missing_r + p % superob(isup,jsup) % cld_qc(1) % CIRH2O = missing_r end if end if