SCALE-RM
scale_letkf.F90
Go to the documentation of this file.
1 !-------------------------------------------------------------------------------
10 !-------------------------------------------------------------------------------
11 #include "scalelib.h"
12 module scale_letkf
13  !-----------------------------------------------------------------------------
14  !
15  !++ used modules
16  !
17  use scale_precision
18  use scale_io
19  use scale_prof
20 
21  use mpi
22 
23  use scale_prc, only: &
24  prc_universal_ismaster
25 
26  !-----------------------------------------------------------------------------
27  implicit none
28  private
29  !-----------------------------------------------------------------------------
30  !
31  !++ Public procedure
32  !
33  public :: letkf_setup
34  public :: letkf_finalize
35  public :: letkf_obs_readfile
36  public :: letkf_obs_clear
37  public :: letkf_obs_operator
38  public :: letkf_obs_initialize
39  public :: letkf_system
40  public :: letkf_param_estimation_system
41  public :: letkf_add_inflation_setup
42 
43  !-----------------------------------------------------------------------------
44  !
45  !++ Public parameters & variables
46  !
47  integer, public, parameter :: nv3d = 11 ! number of 3D prognostic variables
48  integer, public, parameter :: nv2d = 0 ! number of 2D prognostic variables
49  integer, public, parameter :: nid_obs = 16 ! number of variable types
50  integer, public, parameter :: nobtype = 24 ! number of observation report types
51 
52  integer, public, parameter :: max_obs_info_meta = 3 ! maximum array size for type(obs_info)%meta
53  integer, public, parameter :: n_qc_steps = 2
54  integer, public, parameter :: i_before_qc = 1
55  integer, public, parameter :: i_after_qc = 2
56 
57  type, public :: obs_info
58  integer :: nobs = 0
59  integer, allocatable :: elm(:)
60  real(rp), allocatable :: lon(:)
61  real(rp), allocatable :: lat(:)
62  real(rp), allocatable :: lev(:)
63  real(rp), allocatable :: dat(:)
64  real(rp), allocatable :: err(:)
65  integer, allocatable :: typ(:)
66  real(rp), allocatable :: dif(:)
67  real(rp) :: meta(max_obs_info_meta) = -9.99e+33_rp
68  real(rp), allocatable :: ri(:)
69  real(rp), allocatable :: rj(:)
70  integer, allocatable :: rank(:)
71  end type obs_info
72 
73  type, public :: obs_da_value
74  integer :: nobs = 0
75  integer :: nobs_in_key = 0
76  integer, allocatable :: set(:)
77  integer, allocatable :: idx(:)
78  integer, allocatable :: key(:)
79  real(rp), allocatable :: val(:)
80  real(rp), allocatable :: ensval(:,:)
81  real(rp), allocatable :: eqv(:,:) ! qv (ensemble)
82  real(rp), allocatable :: qv(:) ! qv (mean)
83  real(rp), allocatable :: tm(:) ! temp (mean)
84  real(rp), allocatable :: pm(:) ! pressure (mean)
85  integer, allocatable :: qc(:)
86  end type obs_da_value
87 
88  type, public :: obs_grid_type
89  integer :: ngrd_i
90  integer :: ngrd_j
91  real(rp) :: grdspc_i
92  real(rp) :: grdspc_j
93  integer :: ngrdsch_i
94  integer :: ngrdsch_j
95  integer :: ngrdext_i
96  integer :: ngrdext_j
97  integer, allocatable :: n(:,:,:)
98  integer, allocatable :: ac(:,:,:)
99  integer, allocatable :: tot(:)
100  integer, allocatable :: n_ext(:,:)
101  integer, allocatable :: ac_ext(:,:)
102  integer :: tot_ext
103  integer :: tot_sub(n_qc_steps) ! only for diagnostic print; 1: before QC; 2: after QC
104  integer :: tot_g(n_qc_steps) ! only for diagnostic print
105  integer, allocatable :: next(:,:) ! temporary array
106  end type obs_grid_type
107 
108  !-----------------------------------------------------------------------------
109  !
110  !++ Private procedure
111  !
112  private :: letkf_core
113  private :: get_nobs
114  private :: get_nobs_radar
115  private :: read_obs
116  private :: read_obs_radar
117  private :: read_obs_radar_toshiba_pawr
118  private :: read_obs_radar_toshiba_mp_pawr
119  private :: str_replace
120  private :: jst2utc
121  private :: radar_georeference
122  private :: define_grid
123  private :: calc_ref_vr
124  private :: obs_local
125  private :: obs_local_range
126  private :: obs_local_cal
127  private :: relax_beta
128  private :: weight_rtpp
129  private :: weight_rtps
130  private :: com_distll_1
131  private :: ensmean_grd
132  private :: trans_xtoy
133  private :: trans_xtoy_radar
134  private :: prsadj
135  private :: phys2ijk
136  private :: phys2ijkz
137  private :: phys2ij
138  private :: itpl_2d
139  private :: itpl_2d_column
140  private :: itpl_3d
141  private :: merge_sort_parallel
142  private :: merge_sort_2threads
143  private :: merge_2threads
144  private :: merge
145  private :: merge_sort_mpi
146  private :: merge_mpi
147  private :: merge_mpi_no_nest
148  private :: scatter_grd_mpi
149  private :: scatter_grd_mpi_all2all
150  private :: gather_grd_mpi_all2all
151  private :: grd_to_buf
152  private :: buf_to_grd
153  private :: calc_z_grd
154  private :: qc_indexing_and_packing
155  private :: uid_obs
156  private :: uid_obs_varlocal
157  private :: binary_search_i8
158  private :: rank_1d_2d
159  private :: rank_2d_1d
160  private :: rij_rank
161  private :: rij_g2l
162  private :: ij_obsgrd
163  private :: ij_obsgrd_ext
164  private :: obs_choose
165  private :: obs_choose_ext
166  private :: obs_info_allocate
167  private :: obs_info_deallocate
168  private :: obs_da_value_allocate
169  private :: obs_da_value_deallocate
170  private :: obs_da_value_allreduce
171  private :: obs_da_value_partial_reduce_iter
172  private :: read_ens_mpi_addiinfl
173  private :: monit_obs
174  private :: monit_obs_mpi
175  private :: monit_dep
176  private :: monit_print
177  private :: state_to_history
178 
179  !-----------------------------------------------------------------------------
180  !
181  !++ Private parameters & variables
182  !
183  integer, parameter :: n_search_incr = 8
184  integer, parameter :: nobsfilemax = 10
185  integer, parameter :: membermax = 10000
186 
187  integer, parameter :: iv3d_rho = 1 !-- State in restart files
188  integer, parameter :: iv3d_rhou = 2 !
189  integer, parameter :: iv3d_rhov = 3 !
190  integer, parameter :: iv3d_rhow = 4 !
191  integer, parameter :: iv3d_rhot = 5 !
192  integer, parameter :: iv3d_u = 1 !-- State for LETKF
193  integer, parameter :: iv3d_v = 2 !
194  integer, parameter :: iv3d_w = 3 !
195  integer, parameter :: iv3d_t = 4 !
196  integer, parameter :: iv3d_p = 5 !
197  integer, parameter :: iv3d_q = 6 !
198  integer, parameter :: iv3d_qc = 7 !
199  integer, parameter :: iv3d_qr = 8 !
200  integer, parameter :: iv3d_qi = 9 !
201  integer, parameter :: iv3d_qs = 10 !
202  integer, parameter :: iv3d_qg = 11 !
203 
204  !--- 3D, 2D diagnostic variables (in SCALE history files)
205  integer, parameter :: nv3dd = 13
206  integer, parameter :: nv2dd = 7
207  integer, parameter :: iv3dd_u = 1
208  integer, parameter :: iv3dd_v = 2
209  integer, parameter :: iv3dd_w = 3
210  integer, parameter :: iv3dd_t = 4
211  integer, parameter :: iv3dd_p = 5
212  integer, parameter :: iv3dd_q = 6
213  integer, parameter :: iv3dd_qc = 7
214  integer, parameter :: iv3dd_qr = 8
215  integer, parameter :: iv3dd_qi = 9
216  integer, parameter :: iv3dd_qs = 10
217  integer, parameter :: iv3dd_qg = 11
218  integer, parameter :: iv3dd_rh = 12
219  integer, parameter :: iv3dd_hgt = 13
220  integer, parameter :: iv2dd_topo = 1
221  integer, parameter :: iv2dd_ps = 2
222  integer, parameter :: iv2dd_rain = 3
223  integer, parameter :: iv2dd_u10m = 4
224  integer, parameter :: iv2dd_v10m = 5
225  integer, parameter :: iv2dd_t2m = 6
226  integer, parameter :: iv2dd_q2m = 7
227 
228  integer, parameter :: iqc_good = 0
229  integer, parameter :: iqc_gross_err = 5
230  integer, parameter :: iqc_ps_ter = 10
231  integer, parameter :: iqc_ref_low = 11
232  integer, parameter :: iqc_ref_mem = 12
233  integer, parameter :: iqc_radar_vhi = 19
234  integer, parameter :: iqc_out_vhi = 20
235  integer, parameter :: iqc_out_vlo = 21
236  integer, parameter :: iqc_obs_bad = 50
237  integer, parameter :: iqc_otype = 90
238  integer, parameter :: iqc_time = 97
239  integer, parameter :: iqc_out_h = 98
240  integer, parameter :: iqc_undef = 99
241 
242  integer, parameter :: nid_obs_varlocal = 8
243  !
244  ! conventional observations
245  !
246  integer, parameter :: id_u_obs = 2819
247  integer, parameter :: id_v_obs = 2820
248  integer, parameter :: id_t_obs = 3073
249  integer, parameter :: id_tv_obs = 3074
250  integer, parameter :: id_q_obs = 3330
251  integer, parameter :: id_rh_obs = 3331
252  !
253  ! surface observations codes > 9999
254  !
255  integer, parameter :: id_ps_obs = 14593
256  integer, parameter :: id_rain_obs = 19999
257  integer, parameter :: id_tclon_obs = 99991 ! TC vital
258  integer, parameter :: id_tclat_obs = 99992 ! TC vital
259  integer, parameter :: id_tcmip_obs = 99993 ! TC vital
260  !
261  ! radar observations
262  !
263  integer, parameter :: id_radar_ref_obs = 4001
264  integer, parameter :: id_radar_ref_zero_obs = 4004
265  integer, parameter :: id_radar_vr_obs = 4002
266  integer, parameter :: id_radar_prh_obs = 4003
267  !
268  ! Himawari-8 (H08) observations
269  !
270  integer, parameter :: id_h08ir_obs = 8800
271 
272  real(rp), parameter :: dist_zero_fac = 3.651483717 ! SQRT(10.0d0/3.0d0) * 2.0d0
273  real(rp), parameter :: dist_zero_fac_square = 13.33333333 ! dist_zero_fac * dist_zero_fac
274  real(rp), parameter :: minz = 0.01_rp ! Minimum radar power.
275  real(rp), parameter :: vr_min_dist = 8000.0_rp
276 
277  integer, parameter :: elem_uid(nid_obs) = &
278  (/ id_u_obs, id_v_obs, id_t_obs, id_tv_obs, id_q_obs, &
279  id_rh_obs, id_ps_obs, id_rain_obs, id_radar_ref_obs, id_radar_ref_zero_obs, &
280  id_radar_vr_obs, id_radar_prh_obs, id_h08ir_obs, id_tclon_obs, id_tclat_obs, &
281  id_tcmip_obs /)
282 
283  character(3), parameter :: obelmlist(nid_obs) = &
284  (/ ' U', ' V', ' T', ' Tv', ' Q', &
285  ' RH', ' PS', 'PRC', 'REF', 'RE0', &
286  ' Vr', 'PRH', 'H08', 'TCX', 'TCY', &
287  'TCP' /)
288 
289  character(3), parameter :: obelmlist_varlocal(nid_obs_varlocal) = &
290  (/ 'WND', ' T', 'MOI', ' PS', 'PRC', &
291  'TCV', 'REF', ' Vr' /)
292 
293  character(6), parameter :: obtypelist(nobtype) = &
294  (/ 'ADPUPA', 'AIRCAR', 'AIRCFT', 'SATWND', 'PROFLR', &
295  'VADWND', 'SATEMP', 'ADPSFC', 'SFCSHP', 'SFCBOG', &
296  'SPSSMI', 'SYNDAT', 'ERS1DA', 'GOESND', 'QKSWND', &
297  'MSONET', 'GPSIPW', 'RASSDA', 'WDSATR', 'ASCATW', &
298  'TMPAPR', 'PHARAD', 'H08IRB', 'TCVITL' /) ! H08
299 
300  logical :: ens_with_mdet = .false. ! Run additional member of 'mdet'?
301 
302  logical :: use_obs(nobtype) = .true.
303  logical :: obs_postfix_timelabel = .false.
304  logical :: obsda_run(nobsfilemax) = .true.
305  logical :: obsda_out = .false.
306  character(len=H_LONG) :: obs_in_name(nobsfilemax) = ''
307  character(len=H_LONG) :: obsda_out_basename = ''
308  character(len=H_LONG) :: obsda_mean_out_basename = ''
309  character(len=H_LONG) :: obsda_mdet_out_basename = ''
310 
311  integer :: slot_start = 1
312  integer :: slot_end = 1
313  integer :: slot_base = 1
314  real(rp) :: slot_tinterval = 3600.0_rp ! unit: [sec]
315 
316  logical :: departure_stat_radar = .false.
317  real(rp) :: departure_stat_t_range = 0.0 ! time range within which observations are considered in the departure statistics.
318  ! 0: no limit
319 
320  !--- PARAM_LETKF_VAR_LOCAL
321  real(rp) :: var_local_uv(nv3d+nv2d) = 1.0_rp
322  real(rp) :: var_local_t(nv3d+nv2d) = 1.0_rp
323  real(rp) :: var_local_q(nv3d+nv2d) = 1.0_rp
324  real(rp) :: var_local_ps(nv3d+nv2d) = 1.0_rp
325  real(rp) :: var_local_rain(nv3d+nv2d) = 1.0_rp
326  real(rp) :: var_local_tc(nv3d+nv2d) = 1.0_rp
327  real(rp) :: var_local_radar_ref(nv3d+nv2d) = 1.0_rp
328  real(rp) :: var_local_radar_vr(nv3d+nv2d) = 1.0_rp
329 
330  character(len=H_LONG) :: infl_mul_in_basename = ''
331  character(len=H_LONG) :: infl_mul_out_basename = ''
332  real(rp) :: infl_mul = 1.0_rp ! > 0: globally constant covariance inflation
333  ! <= 0: use 3D inflation field from 'INFL_MUL_IN_BASENAME' file
334  real(rp) :: infl_mul_min = -1.0_rp ! minimum inlfation factor (<= 0: not used)
335  logical :: infl_mul_adaptive = .false. ! if true, outout adaptively estimated 3D inlfation field to 'INFL_MUL_OUT_BASENAME' file
336 
337  character(len=H_LONG) :: infl_add_in_basename = ''
338  real(rp) :: infl_add = 0.0_rp ! additive inflation
339  logical :: infl_add_shuffle = .false. ! shuffle the additive inflation members?
340  logical :: infl_add_q_ratio = .false.
341  logical :: infl_add_ref_only = .false.
342 
343  !--- PARAM_OBS_ERROR
344  real(rp) :: obserr_u = 1.0_rp
345  real(rp) :: obserr_v = 1.0_rp
346  real(rp) :: obserr_t = 1.0_rp
347  real(rp) :: obserr_q = 0.001_rp
348  real(rp) :: obserr_rh = 10.0_rp
349  real(rp) :: obserr_ps = 100.0_rp ! (Pa)
350  real(rp) :: obserr_radar_ref = 5.0_rp
351  real(rp) :: obserr_radar_vr = 3.0_rp
352  real(rp) :: obserr_tcx = 50.e+3_rp ! (m)
353  real(rp) :: obserr_tcy = 50.e+3_rp ! (m)
354  real(rp) :: obserr_tcp = 5.e+2_rp ! (Pa)
355  real(rp) :: obserr_pq = 0.001_rp ! (kg/m3)
356 
357  ! PARAMETERS FOR RADAR DATA ASSIMILATION
358  integer :: nradartype = 1 ! Currently PAWR (1) and LIDAR (2) ... not used?
359  real(rp) :: radar_so_size_hori = 1000.0_rp
360  real(rp) :: radar_so_size_vert = 1000.0_rp
361  real(rp) :: radar_max_abs_vr = 100.0_rp
362  integer :: radar_thin_letkf_method = 0 ! Thinning method
363  ! 0: No thinning
364  ! 1: Nearest (2z)*(2x)^2 grids & their columns and
365  ! rows + staggered grids
366  ! x is given by RADAR_THIN_LETKF_HGRID_HNEAR
367  ! z is given by RADAR_THIN_LETKF_HGRID_VNEAR
368  integer :: radar_thin_letkf_hgrid = 1 ! Horizontal thinning level in obs_local
369  integer :: radar_thin_letkf_vgrid = 1 ! Vertical thinning level in obs_local
370  integer :: radar_thin_letkf_hnear = 1
371  integer :: radar_thin_letkf_vnear = 1
372  integer :: radar_thin_hori = 1 ! Thinning horizontal interval (# of grids)
373  integer :: radar_thin_vert = 1 ! Thinning vertical interval (# of grids)
374  logical :: radar_use_vr_std = .true. ! If we are going to use the wind std threshold within each box.
375  logical :: radar_bias_cor_rain = .false. ! Simple bias correction for radar obs (rain)
376  logical :: radar_bias_cor_clr = .false. ! Simple bias correction for radar obs (clear sky)
377  real(rp) :: radar_bias_rain_const_dbz = 0.0_rp ! Simply bias correction for radar obs (rain)
378  real(rp) :: radar_bias_clr_const_dbz = 0.0_rp ! Simply bias correction for radar obs (clear sky)
379  real(rp) :: vr_std_threshold = 2.5_rp ! If wind variability within each superob is greather than this threshold the box is rejected.
380  real(rp) :: attenuation_threshold = 0.25_rp ! 0.1 is 10dbz, 0.5 is aprox 5 dbz.
381 
382  logical :: use_radar_ref = .true.
383  logical :: use_radar_vr = .true.
384  logical :: use_radar_pseudo_rh = .false.
385 
386  logical :: use_obserr_radar_ref = .false.
387  logical :: use_obserr_radar_vr = .false.
388  logical :: radar_obs_4d = .false.
389  logical :: radar_pqv = .false. ! Pseudo qv DA for radar
390 
391  real(rp) :: radar_pqv_omb = 25.0_rp ! Threshold Obs-B for pseudo qv DA for radar
392  real(rp) :: radar_ref_thres_dbz = 15.0_rp ! Threshold of rain/no rain
393  integer :: min_radar_ref_member_obsrain = 1 ! Minimum rainy ensemble members for assimilating rainy radar obs
394  integer :: min_radar_ref_member_obsnorain = 1 ! Minimum rainy ensemble members for assimilating clear-sky radar obs
395 
396  real(rp) :: min_radar_ref_dbz = 0.0_rp ! Minimum reflectivity
397  real(rp) :: min_radar_ref_dbz_vr = 5.0_rp ! Minimum reflectivity (dBZ) for Doppler velocity observation
398  real(rp) :: min_radar_ref_vr = 0.0_rp ! Minimum reflectivity (Z) for Doppler velocity observation
399  real(rp) :: low_ref_shift = 0.0_rp
400 
401  real(rp) :: radar_zmax = 99.e+3_rp ! Height limit of radar data to be used
402  real(rp) :: radar_zmin = -99.e+3_rp ! Height limit of radar data to be used
403  real(rp) :: radar_prh_error = 0.1_rp ! Obserational error for pseudo RH observations.
404 
405  integer :: interpolation_technique = 1 ! These 2 flags affects the computation of model reflectivity and radial velocity.
406  integer :: method_ref_calc = 3
407  logical :: use_method3_ref_melt = .false. ! Use radar operator considering melting (Xue et al. 2009QJRMS)
408  logical :: use_t08_rs2014 = .false. ! Use RS2014 in snow obsope (must be consistent with SCALE)
409  logical :: use_terminal_velocity = .false.
410  logical :: use_attenuation = .true. ! Consider attenuation in superobbing
411  logical :: use_qcflag = .true. ! Consider or not qc flag.
412 
413  real(rp) :: relax_alpha = 0.0_rp ! RTPP relaxation parameter
414  real(rp) :: relax_alpha_spread = 0.0_rp ! RTPS relaxation parameter
415  logical :: relax_to_inflated_prior = .false. ! .true. : relaxation to multiplicatively inflated prior
416  ! .false.: relaxation to original prior
417  logical :: relax_spread_out = .false.
418  character(len=H_LONG) :: relax_spread_out_basename = ''
419 
420  real(rp) :: gross_error = 5.0_rp
421  real(rp) :: gross_error_rain = -1.0_rp ! < 0: same as GROSS_ERROR
422  real(rp) :: gross_error_radar_ref = -1.0_rp ! < 0: same as GROSS_ERROR
423  real(rp) :: gross_error_radar_vr = -1.0_rp ! < 0: same as GROSS_ERROR
424  real(rp) :: gross_error_radar_prh = -1.0_rp ! < 0: same as GROSS_ERROR
425  real(rp) :: gross_error_tcx = -1.0_rp ! debug ! < 0: same as GROSS_ERROR
426  real(rp) :: gross_error_tcy = -1.0_rp ! debug ! < 0: same as GROSS_ERROR
427  real(rp) :: gross_error_tcp = -1.0_rp ! debug ! < 0: same as GROSS_ERROR
428 
429  real(rp) :: q_update_top = 0.0_rp ! water vapor and hydrometeors are updated only below this pressure level (Pa)
430  real(rp) :: q_sprd_max = -1.0_rp ! maximum q (ensemble spread)/(ensemble mean) (only effective when > 0)
431 
432  real(rp) :: boundary_buffer_width = 0.0_rp
433  real(rp) :: ps_adjust_thres = 100.0_rp
434 
435  logical :: nobs_out = .false.
436  character(len=H_LONG) :: nobs_out_basename = ''
437 
438  real(rp) :: hori_local(nobtype) = & ! >0: localization length scale (m)
439  (/ 0.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, & ! 0: no localization XXX not implemented yet XXX
440  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, & ! <0: same as HORI_LOCAL(1)
441  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, &
442  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, &
443  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp /)
444  real(rp) :: vert_local(nobtype) = & ! >0: localization length scale [ln(p) or m depends on obstype]
445  (/ 0.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, & ! 0: no localization
446  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, & ! <0: same as VERT_LOCAL(1)
447  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, &
448  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, &
449  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp /)
450  real(rp) :: time_local(nobtype) = & ! >0: localization length scale (sec) XXX not implemented yet XXX
451  (/ 0.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, & ! 0: no localization
452  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, & ! <0: same as TIME_LOCAL(1)
453  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, &
454  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, &
455  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp /)
456 
457  real(rp) :: hori_local_radar_obsnoref = -1.0_rp ! <0: same as HORI_LOCAL(22=PHARAD)
458  real(rp) :: hori_local_radar_vr = -1.0_rp ! <0: same as HORI_LOCAL(22=PHARAD)
459  real(rp) :: vert_local_radar_vr = -1.0_rp ! <0: same as VERT_LOCAL(22=PHARAD)
460  real(rp) :: vert_local_rain_base = 85000.0_rp
461 
462  integer :: max_nobs_per_grid(nobtype) = & ! >0: observation number limit
463  (/ 0, -1, -1, -1, -1, -1, -1, -1, -1, -1, & ! 0: do not limit observation numbers
464  -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & ! <0: same as MAX_NOBS_PER_GRID(1)
465  -1, -1, -1, -1/)
466 
467  integer :: max_nobs_per_grid_criterion = 1 ! 1: normalized 3D distance (from closest)
468  ! 2: localization weight (from largest)
469  ! 3: weighted observation error variance (from smallest)
470 
471  real(rp) :: obs_min_spacing(nobtype) = & ! >0: typical minimum spacing of the obsetvation types in the densest observed area (not tuned carefully yet)
472  (/ 0.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, & ! *this is only used for automatically determine OBS_SORT_GRID_SPACING. if using pre-set OBS_SORT_GRID_SPACING, this has no effect.
473  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, & ! <=0: same as OBS_MIN_SPACING(1)
474  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, &
475  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, &
476  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp /)
477 
478  real(rp) :: obs_sort_grid_spacing(nobtype) = & ! >0: optimal grid spacing for bucket sorting of observations
479  (/ 0.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, & ! 0: automatically determined based on HORI_LOCAL, MAX_NOBS_PER_GRID, and OBS_MIN_SPACING
480  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, & ! <0: same as OBS_SORT_GRID_SPACING(1)
481  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, &
482  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp, &
483  -1.0_rp, -1.0_rp, -1.0_rp, -1.0_rp /)
484 
485  integer :: utime_obs(6) = &
486  (/ -1, -1, -1, -1, -1, -1 /)
487 
488  integer :: mmean = -99 ! use a value different from -1 to avoid equivalence to (my)rank_to_mem
489  integer :: mmdet = -99 ! when no member is corresponded to a rank/iteration
490  integer :: mmdetin = -99 !
491  integer :: mmdetobs = -99 !
492 
493  logical :: letkf_entire_grid_search_x = .false. ! Gather all obs to analyze global constant parameters via ETKF (as in Kotsuki et al.)
494  logical :: letkf_entire_grid_search_y = .false. !
495 
496  logical :: letkf_debug_log = .false.
497 
498  type(obs_info), allocatable :: obs(:)
499 
500  type(obs_da_value) :: obsda
501  type(obs_da_value) :: obsda_sort ! sorted obsda
502 
503  type(obs_grid_type), allocatable :: obsgrd(:)
504 
505  real(rp) :: min_radar_ref
506  real(rp) :: radar_ref_thres
507  real(rp) :: radar_bias_rain_const
508  real(rp) :: radar_bias_clr_const
509 
510  real(rp), allocatable :: var_local(:,:)
511 
512  integer, allocatable :: n_merge(:)
513  integer, allocatable :: ic_merge(:,:)
514 
515  integer :: nobstotalg
516  integer :: nobstotal
517  integer :: maxnobs_per_ctype
518 
519  ! combined obs type: {variable type (elm_u), report type (typ)}, allocated only when observations exist
520  integer :: nctype ! number of combined obs type
521  integer :: ctype_elmtyp(nid_obs,nobtype) ! array of ctype for each combination of (elm_u, typ)
522  integer, allocatable :: elm_ctype(:) ! array of elm for each combined obs type
523  integer, allocatable :: elm_u_ctype(:) ! array of elm_u for each combined obs type
524  integer, allocatable :: typ_ctype(:) ! array of typ for each combined obs type
525  real(rp), allocatable :: hori_loc_ctype(:) ! array of horizontal localization length for each combined obs type
526  real(rp), allocatable :: vert_loc_ctype(:) ! array of vertical localization length for each combined obs type
527 
528  ! observation monitor
529  integer :: obsdep_nobs ! obsdep information
530  integer, allocatable :: obsdep_set(:) !
531  integer, allocatable :: obsdep_idx(:) !
532  integer, allocatable :: obsdep_qc (:) !
533  real(rp), allocatable :: obsdep_omb(:) !
534  real(rp), allocatable :: obsdep_oma(:) !
535 
536  integer :: datatype
537  integer :: n_merge_max
538  logical :: radar_only
539 
540  integer :: nitmax
541  integer :: nij1
542  integer :: nij1max
543  integer :: nproc_x
544  integer :: nproc_y
545  integer :: nens
546  integer :: nensobs
547  integer :: nmem
548  integer :: nlon
549  integer :: nlat
550  integer :: nlev
551  integer :: nlonh
552  integer :: nlath
553  integer :: nlevh
554  integer :: nlong
555  integer :: nlatg
556  integer :: nlevall
557  integer :: xhalo
558  integer :: yhalo
559  integer :: zhalo
560  integer :: start_x
561  integer :: end_x
562  integer :: start_y
563  integer :: end_y
564  integer :: start_z
565  integer :: end_z
566 
567  integer :: comm_lcl
568  integer :: nprc_lcl
569  integer :: rank_lcl
570  integer :: comm_ens
571  integer :: nprc_ens
572  integer :: rank_ens
573 
574  real(rp) :: dx
575  real(rp) :: dy
576 
577  integer, allocatable :: nij1node(:)
578 
579  real(rp), allocatable :: rig1(:)
580  real(rp), allocatable :: rjg1(:)
581  real(rp), allocatable :: topo1(:)
582  real(rp), allocatable :: hgt1(:,:)
583  real(rp), allocatable :: v3dg(:,:,:,:)
584  real(rp), allocatable :: v2dg(:,:,:)
585  real(rp), allocatable :: v3d(:,:,:)
586  real(rp), allocatable :: v2d(:,:)
587  real(rp), allocatable :: topo2d(:,:)
588 
589  !-----------------------------------------------------------------------------
590 contains
591  !-----------------------------------------------------------------------------
593  subroutine letkf_setup( &
594  OBS_IN_NUM, &
595  ensemble_comm, &
596  ensemble_nprocs, &
597  ensemble_myrank, &
598  local_comm, &
599  local_nprocs, &
600  local_myrank, &
601  PRC_NUM_X, &
602  PRC_NUM_Y, &
603  KA, KS, KE, &
604  IA, IS, IE, &
605  JA, JS, JE, &
606  KMAX, &
607  IMAX, &
608  JMAX, &
609  KHALO, &
610  IHALO, &
611  JHALO, &
612  delta_x, &
613  delta_y, &
614  Zsfc )
615  use mpi
616  use scale_prc, only: &
617  prc_abort
618  use scale_prc_cartesc, only: &
619  prc_2drank
620  implicit none
621 
622  integer, intent(in) :: obs_in_num
623  integer, intent(in) :: ensemble_comm
624  integer, intent(in) :: ensemble_nprocs
625  integer, intent(in) :: ensemble_myrank
626  integer, intent(in) :: local_comm
627  integer, intent(in) :: local_nprocs
628  integer, intent(in) :: local_myrank
629  integer, intent(in) :: prc_num_x
630  integer, intent(in) :: prc_num_y
631  integer, intent(in) :: ka, ks, ke
632  integer, intent(in) :: ia, is, ie
633  integer, intent(in) :: ja, js, je
634  integer, intent(in) :: kmax
635  integer, intent(in) :: imax
636  integer, intent(in) :: jmax
637  integer, intent(in) :: khalo
638  integer, intent(in) :: ihalo
639  integer, intent(in) :: jhalo
640 
641  real(rp), intent(in) :: delta_x
642  real(rp), intent(in) :: delta_y
643  real(rp), intent(in) :: zsfc(:,:)
644 
645  logical :: letkf_deterministic_run
646 
647  integer :: letkf_mem_nodes = 0 ! Number of nodes used for one member (0: automatically determined)
648 
649  namelist / param_letkf / &
650  letkf_debug_log, &
651  letkf_deterministic_run, &
652  letkf_mem_nodes, &
653  slot_start, &
654  slot_end, &
655  slot_base, &
656  slot_tinterval, &
657  departure_stat_radar, &
658  infl_mul, &
659  infl_mul_min, &
660  infl_mul_adaptive, &
661  infl_add, &
662  infl_add_shuffle, &
663  infl_add_q_ratio, &
664  infl_add_ref_only, &
665  relax_alpha, &
666  relax_alpha_spread, &
667  relax_to_inflated_prior, &
668  gross_error, &
669  gross_error_rain, &
670  gross_error_radar_ref, &
671  gross_error_radar_vr, &
672  gross_error_radar_prh, &
673  gross_error_tcx, &
674  gross_error_tcy, &
675  gross_error_tcp, &
676  q_update_top, &
677  q_sprd_max, &
678  boundary_buffer_width, &
679  hori_local, &
680  vert_local, &
681  time_local, &
682  hori_local_radar_obsnoref, &
683  hori_local_radar_vr, &
684  vert_local_radar_vr, &
685  max_nobs_per_grid, &
686  max_nobs_per_grid_criterion, &
687  obs_min_spacing, &
688  obs_sort_grid_spacing, &
689  use_radar_ref, &
690  use_radar_vr, &
691  method_ref_calc, &
692  use_terminal_velocity, &
693  use_obserr_radar_ref, &
694  use_obserr_radar_vr, &
695  radar_ref_thres_dbz, &
696  min_radar_ref_member_obsrain, &
697  min_radar_ref_member_obsnorain, &
698  min_radar_ref_dbz, &
699  min_radar_ref_dbz_vr, &
700  low_ref_shift, &
701  radar_zmax, &
702  radar_zmin, &
703  radar_so_size_hori, &
704  radar_so_size_vert, &
705  radar_max_abs_vr, &
706  use_method3_ref_melt, &
707  radar_bias_cor_rain, &
708  radar_bias_cor_clr, &
709  radar_bias_rain_const_dbz, &
710  radar_bias_clr_const_dbz, &
711  radar_thin_letkf_method, &
712  radar_thin_letkf_hgrid, &
713  radar_thin_letkf_vgrid, &
714  radar_thin_letkf_hnear, &
715  radar_thin_letkf_vnear, &
716  radar_thin_hori, &
717  radar_thin_vert, &
718  obserr_u, &
719  obserr_v, &
720  obserr_t, &
721  obserr_q, &
722  obserr_rh, &
723  obserr_ps, &
724  obserr_radar_ref, &
725  obserr_radar_vr, &
726  obserr_pq, &
727  letkf_entire_grid_search_x, &
728  letkf_entire_grid_search_y
729 
730  integer :: n_mem
731  integer :: n_mempn
732 
733  integer :: i, j, k, n
734  integer :: ierr
735  !---------------------------------------------------------------------------
736 
737  log_newline
738  log_info("LETKF_setup",*) 'Setup'
739 
740  if ( rp == sp ) then
741  datatype = mpi_real
742  else if( rp == dp ) then
743  datatype = mpi_double_precision
744  else
745  log_error("obsope_tool",*) 'The precision has not been implemented yet:', rp
746  call prc_abort
747  endif
748 
749  letkf_deterministic_run = .false.
750 
751  !--- read namelist
752  rewind(io_fid_conf)
753  read(io_fid_conf,nml=param_letkf,iostat=ierr)
754  if( ierr < 0 ) then !--- missing
755  log_info("LETKF_setup",*) 'Not found namelist. Default used.'
756  elseif( ierr > 0 ) then !--- fatal error
757  log_error("LETKF_setup",*) 'Not appropriate names in namelist PARAM_LETKF. Check!'
758  call prc_abort
759  endif
760  log_nml(param_letkf)
761 
762  nproc_x = prc_num_x
763  nproc_y = prc_num_y
764  nens = ensemble_nprocs
765  nensobs = ensemble_nprocs
766  nmem = ensemble_nprocs
767  nlon = imax
768  nlat = jmax
769  nlev = kmax
770  nlonh = ia
771  nlath = ja
772  nlevh = ka
773  nlong = imax * prc_num_x
774  nlatg = jmax * prc_num_y
775  nlevall = nlev * nv3d + nv2d
776  xhalo = ihalo
777  yhalo = jhalo
778  zhalo = khalo
779  start_x = is
780  end_x = ie
781  start_y = js
782  end_y = je
783  start_z = ks
784  end_z = ke
785  mmean = nens + 1
786 
787  comm_ens = ensemble_comm
788  nprc_ens = ensemble_nprocs
789  rank_ens = ensemble_myrank
790  comm_lcl = local_comm
791  nprc_lcl = local_nprocs
792  rank_lcl = local_myrank
793 
794  dx = delta_x
795  dy = delta_y
796 
797  if( letkf_deterministic_run ) then ! set deterministic run
798  ens_with_mdet = .true.
799  ! deterministic run is set to the last of ensemble member
800  mmdet = nens
801  mmdetin = nens
802  mmdetobs = nens
803  nmem = nens - 1 ! member size except for deterministic run
804  end if
805 
806  if( letkf_mem_nodes == 0 ) then
807  letkf_mem_nodes = 1 ! (nprocs_m-1) / PPN + 1
808  end if
809  if( letkf_mem_nodes > 1 ) then
810  n_mem = nprc_ens / letkf_mem_nodes
811  n_mempn = 1
812  else
813  n_mem = nprc_ens
814  n_mempn = 1 ! PPN / nprocs_m
815  end if
816  nitmax = ( nprc_ens - 1 ) / ( n_mem * n_mempn ) + 1
817 
818  i = mod( nlon*nlat, nprc_ens )
819  nij1max = ( nlon*nlat - i ) / nprc_ens + 1
820  if( rank_ens < i ) then
821  nij1 = nij1max
822  else
823  nij1 = nij1max - 1
824  end if
825 
826  allocate( obs( obs_in_num ) )
827  allocate( nij1node( nprc_ens ) )
828 
829  do n = 1, nprc_ens
830  if( n-1 < i ) then
831  nij1node(n) = nij1max
832  else
833  nij1node(n) = nij1max - 1
834  end if
835  end do
836 
837  allocate( rig1( nij1 ) )
838  allocate( rjg1( nij1 ) )
839  allocate( topo1( nij1 ) )
840  allocate( hgt1( nij1, nlev ) )
841 
842  allocate( v3dg( nlev, nlon, nlat, nv3d ) )
843  allocate( v2dg( nlon, nlat, nv2d ) )
844 
845  allocate( v3d( nij1, nlev, nv3d ) )
846  allocate( v2d( nij1, nv2d ) )
847 
848  do j = 1, jmax
849  do i = 1, imax
850  v3dg(1,i,j,1) = real( i + prc_2drank(local_myrank,1) * imax + ihalo, kind=rp )
851  v3dg(1,i,j,2) = real( j + prc_2drank(local_myrank,2) * jmax + jhalo, kind=rp )
852  v3dg(1,i,j,3) = zsfc(i+ihalo,j+jhalo)
853  end do
854  end do
855 
856  call scatter_grd_mpi( mod( nens, n_mem*n_mempn ), v3dg, v2dg, v3d, v2d )
857 
858  rig1(:) = v3d(:,1,1)
859  rjg1(:) = v3d(:,1,2)
860  topo1(:) = v3d(:,1,3)
861 
862  call calc_z_grd( nij1, topo1, hgt1 )
863 
864  allocate( var_local( nv3d+nv2d, nid_obs_varlocal ) )
865 
866  if( radar_ref_thres_dbz < min_radar_ref_dbz ) then
867  radar_ref_thres_dbz = min_radar_ref_dbz
868  end if
869 
870  min_radar_ref = 10.0_rp ** ( min_radar_ref_dbz / 10.0_rp )
871  min_radar_ref_vr = 10.0_rp ** ( min_radar_ref_dbz_vr / 10.0_rp )
872  radar_ref_thres = 10.0_rp ** ( radar_ref_thres_dbz / 10.0_rp )
873  radar_bias_rain_const = 10.0_rp ** ( radar_bias_rain_const_dbz / 10.0_rp )
874  radar_bias_clr_const = 10.0_rp ** ( radar_bias_clr_const_dbz / 10.0_rp )
875 
876  return
877  end subroutine letkf_setup
878 
879  !-----------------------------------------------------------------------------
880  subroutine letkf_finalize()
881  implicit none
882 
883  deallocate( rig1 )
884  deallocate( rjg1 )
885  deallocate( topo1 )
886  deallocate( hgt1 )
887  deallocate( v3dg )
888  deallocate( v2dg )
889  deallocate( v3d )
890  deallocate( v2d )
891 
892  deallocate( var_local )
893 
894  deallocate( obs )
895  deallocate( nij1node )
896 
897  return
898  end subroutine letkf_finalize
899 
900  !-----------------------------------------------------------------------------
901  subroutine letkf_obs_readfile( &
902  OBS_IN_NUM, &
903  OBS_IN_FORMAT, &
904  OBS_IN_BASENAME, &
905  OBS_IN_MASKFILE )
906  use scale_prc, only: &
907  prc_abort
908  use scale_time, only: &
909  time_gettimelabel
910  implicit none
911 
912  integer, intent(in) :: obs_in_num
913 
914  character(len=H_LONG), intent(in) :: obs_in_format(:)
915  character(len=H_LONG), intent(in) :: obs_in_basename(:)
916  character(len=H_LONG), intent(in) :: obs_in_maskfile
917 
918  character(len=H_LONG) :: obsfile
919  character(len=H_LONG) :: timelabel_obsfile
920 
921  logical :: err
922 
923  integer :: n
924  integer :: ierr
925  !---------------------------------------------------------------------------
926 
927  log_progress(*) 'data-assimilation / LETKF / obs / readfile'
928 
929  if( rank_ens == 0 .and. rank_lcl == 0 ) then
930  timelabel_obsfile = '_???????????????????.dat'
931  call time_gettimelabel( timelabel_obsfile(2:20) )
932 
933  do n = 1, obs_in_num
934  obsfile = trim(obs_in_basename(n))//trim(timelabel_obsfile)
935 
936  if (obs_in_format(n) /= 'PAWR_TOSHIBA' .and. &
937  obs_in_format(n) /= 'MP_PAWR_TOSHIBA' ) then
938  inquire( file=obsfile, exist=err )
939  if( .not. err ) then
940  log_info("LETKF_obs_readfile",*) 'Warning: File (',trim(obsfile),') is not found. Skip.'
941  ! skip process
942  obs(n)%nobs = 0
943  call obs_info_allocate(obs(n), extended=.true.)
944  cycle
945  end if
946  end if
947 
948  select case( obs_in_format(n) )
949  case ( 'PREPBUFR' )
950  call get_nobs( obsfile, 8, obs(n)%nobs )
951  call obs_info_allocate( obs(n), extended=.true. )
952  call read_obs( obsfile, obs(n) )
953  case ( 'RADAR' )
954  call get_nobs_radar( obsfile, obs(n)%nobs, obs(n)%meta(1), obs(n)%meta(2), obs(n)%meta(3) )
955  call obs_info_allocate( obs(n), extended=.true. )
956  call read_obs_radar( obsfile, obs(n) )
957  case ( 'PAWR_JRC' )
958  log_error("LETKF_obs_readfile",*) 'Error: This system has not been implemented yet. (OBS_IN_FORMAT(:) = PAWR_JRC)'
959  call prc_abort
960  ! call read_obs_radar_jrc( obsfile, obs(n) )
961  case ( 'PAWR_TOSHIBA' )
962  call read_obs_radar_toshiba_pawr( obs(n), obsfile )
963  case ( 'MP_PAWR_TOSHIBA' )
964  call read_obs_radar_toshiba_mp_pawr( obs(n), obsfile, obs_in_maskfile )
965  case default
966  log_error("LETKF_obs_readfile",*) 'Error: Unsupported observation file format.'
967  call prc_abort
968  end select
969  end do
970  end if
971 
972  do n = 1, obs_in_num
973  ! communicate obs. data to ensemble world in each local domain master at first
974  if( rank_lcl == 0 ) then
975  call mpi_bcast( obs(n)%nobs, 1, mpi_integer, 0, comm_ens, ierr )
976 
977  if( rank_ens /= 0 ) then
978  call obs_info_allocate( obs(n), extended=.true. )
979  end if
980 
981  call mpi_bcast( obs(n)%elm, obs(n)%nobs, mpi_integer, 0, comm_ens, ierr )
982  call mpi_bcast( obs(n)%lon, obs(n)%nobs, datatype, 0, comm_ens, ierr )
983  call mpi_bcast( obs(n)%lat, obs(n)%nobs, datatype, 0, comm_ens, ierr )
984  call mpi_bcast( obs(n)%lev, obs(n)%nobs, datatype, 0, comm_ens, ierr )
985  call mpi_bcast( obs(n)%dat, obs(n)%nobs, datatype, 0, comm_ens, ierr )
986  call mpi_bcast( obs(n)%err, obs(n)%nobs, datatype, 0, comm_ens, ierr )
987  call mpi_bcast( obs(n)%typ, obs(n)%nobs, mpi_integer, 0, comm_ens, ierr )
988  call mpi_bcast( obs(n)%dif, obs(n)%nobs, datatype, 0, comm_ens, ierr )
989  call mpi_bcast( obs(n)%meta, max_obs_info_meta, datatype, 0, comm_ens, ierr )
990  end if
991 
992  ! broadcast obs. data to local domain
993  call mpi_bcast( obs(n)%nobs, 1, mpi_integer, 0, comm_lcl, ierr )
994 
995  if( rank_lcl /= 0 ) then
996  call obs_info_allocate( obs(n), extended=.true. )
997  end if
998 
999  call mpi_bcast( obs(n)%elm, obs(n)%nobs, mpi_integer, 0, comm_lcl, ierr )
1000  call mpi_bcast( obs(n)%lon, obs(n)%nobs, datatype, 0, comm_lcl, ierr )
1001  call mpi_bcast( obs(n)%lat, obs(n)%nobs, datatype, 0, comm_lcl, ierr )
1002  call mpi_bcast( obs(n)%lev, obs(n)%nobs, datatype, 0, comm_lcl, ierr )
1003  call mpi_bcast( obs(n)%dat, obs(n)%nobs, datatype, 0, comm_lcl, ierr )
1004  call mpi_bcast( obs(n)%err, obs(n)%nobs, datatype, 0, comm_lcl, ierr )
1005  call mpi_bcast( obs(n)%typ, obs(n)%nobs, mpi_integer, 0, comm_lcl, ierr )
1006  call mpi_bcast( obs(n)%dif, obs(n)%nobs, datatype, 0, comm_lcl, ierr )
1007  call mpi_bcast( obs(n)%meta, max_obs_info_meta, datatype, 0, comm_lcl, ierr )
1008 
1009  log_info('LETKF_obs_readfile',*) 'observations input:', obs(n)%nobs
1010  end do
1011 
1012  return
1013  end subroutine letkf_obs_readfile
1014 
1015  subroutine letkf_obs_clear( OBS_IN_NUM )
1016  implicit none
1017 
1018  integer, intent(in) :: obs_in_num
1019 
1020  integer :: n
1021  !---------------------------------------------------------------------------
1022 
1023  log_progress(*) 'data-assimilation / LETKF / cleaning'
1024 
1025  do n = 1, obs_in_num
1026  call obs_info_deallocate( obs(n) )
1027  end do
1028 
1029  call obs_da_value_deallocate( obsda_sort )
1030 
1031  return
1032  end subroutine letkf_obs_clear
1033 
1034  !-----------------------------------------------------------------------
1035  ! Observation operator calculation
1036  !-----------------------------------------------------------------------
1037  subroutine letkf_obs_operator( &
1038  OBS_IN_NUM, & ! [IN]
1039  OBS_IN_FORMAT, & ! [IN]
1040  U, & ! [IN]
1041  V, & ! [IN]
1042  W, & ! [IN]
1043  TEMP, & ! [IN]
1044  PRES, & ! [IN]
1045  QV, & ! [IN]
1046  QC, & ! [IN]
1047  QR, & ! [IN]
1048  QI, & ! [IN]
1049  QS, & ! [IN]
1050  QG, & ! [IN]
1051  RH, & ! [IN]
1052  HGT, & ! [IN]
1053  TOPO, & ! [IN]
1054  PS, & ! [IN]
1055  RAIN, & ! [IN]
1056  U10M, & ! [IN]
1057  V10M, & ! [IN]
1058  T2M, & ! [IN]
1059  Q2M, & ! [IN]
1060  nobs_extern ) ! [IN]
1061  implicit none
1062 
1063  integer, intent(in) :: obs_in_num
1064  character(len=H_LONG), intent(in) :: obs_in_format(:)
1065 
1066  real(rp), intent(in) :: u (nlevh,nlonh,nlath)
1067  real(rp), intent(in) :: v (nlevh,nlonh,nlath)
1068  real(rp), intent(in) :: w (nlevh,nlonh,nlath)
1069  real(rp), intent(in) :: temp(nlevh,nlonh,nlath)
1070  real(rp), intent(in) :: pres(nlevh,nlonh,nlath)
1071  real(rp), intent(in) :: qv (nlevh,nlonh,nlath)
1072  real(rp), intent(in) :: qc (nlevh,nlonh,nlath)
1073  real(rp), intent(in) :: qr (nlevh,nlonh,nlath)
1074  real(rp), intent(in) :: qi (nlevh,nlonh,nlath)
1075  real(rp), intent(in) :: qs (nlevh,nlonh,nlath)
1076  real(rp), intent(in) :: qg (nlevh,nlonh,nlath)
1077  real(rp), intent(in) :: rh (nlevh,nlonh,nlath)
1078  real(rp), intent(in) :: hgt (nlevh,nlonh,nlath)
1079 
1080  real(rp), intent(in) :: topo(nlonh,nlath)
1081  real(rp), intent(in) :: ps (nlonh,nlath)
1082  real(rp), intent(in) :: rain(nlonh,nlath)
1083  real(rp), intent(in) :: u10m(nlonh,nlath)
1084  real(rp), intent(in) :: v10m(nlonh,nlath)
1085  real(rp), intent(in) :: t2m (nlonh,nlath)
1086  real(rp), intent(in) :: q2m (nlonh,nlath)
1087 
1088  integer, optional, intent(in) :: nobs_extern
1089 
1090  type(obs_da_value) :: obsda_tmp
1091 
1092  integer :: i, j, k
1093  integer :: it, im, iof, islot, ierr
1094  integer :: n, nn, nsub, nmod, n1, n2
1095 
1096  integer :: nobs ! observation number processed in this subroutine
1097  integer :: nobs_all
1098  integer :: nobs_max_per_file
1099  integer :: nobs_max_per_file_sub
1100  integer :: slot_nobsg
1101 
1102  integer :: ip, ibufs
1103  integer, allocatable :: cntr(:), dspr(:)
1104  integer, allocatable :: cnts(:), dsps(:)
1105  integer, allocatable :: bsn(:,:), bsna(:,:), bsnext(:,:)
1106  integer :: islot_time_out, islot_domain_out
1107 
1108  integer, allocatable :: obrank_bufs(:)
1109  real(rp), allocatable :: ri_bufs(:)
1110  real(rp), allocatable :: rj_bufs(:)
1111 
1112  integer, allocatable :: obset_bufs(:)
1113  integer, allocatable :: obidx_bufs(:)
1114 
1115  integer :: slot_id(slot_start:slot_end)
1116  real(rp) :: slot_lb(slot_start:slot_end)
1117  real(rp) :: slot_ub(slot_start:slot_end)
1118 
1119  real(rp), allocatable :: v3dg(:,:,:,:)
1120  real(rp), allocatable :: v2dg(:,:,:)
1121 
1122  real(rp) :: ril, rjl, rk, rkz
1123 
1124  character(len=4) :: nstr
1125  !-------------------------------------------------------------------------------
1126 
1127  log_progress(*) 'data-assimilation / LETKF / obs / operator'
1128 
1129  !-------------------------------------------------------------------------------
1130  ! First scan of all observation data: Compute their horizontal location and time
1131  !-------------------------------------------------------------------------------
1132 
1133  nobs_all = 0
1134  nobs_max_per_file = 0
1135  do iof = 1, obs_in_num
1136  if (obs(iof)%nobs > nobs_max_per_file) then
1137  nobs_max_per_file = obs(iof)%nobs
1138  end if
1139  if (obsda_run(iof)) then
1140  nobs_all = nobs_all + obs(iof)%nobs
1141  end if
1142  end do
1143 
1144  nobs_max_per_file_sub = (nobs_max_per_file - 1) / nprc_lcl + 1
1145  allocate( obrank_bufs(nobs_max_per_file_sub) )
1146  allocate( ri_bufs(nobs_max_per_file_sub) )
1147  allocate( rj_bufs(nobs_max_per_file_sub) )
1148 
1149  allocate( cntr(nprc_lcl) )
1150  allocate( dspr(nprc_lcl) )
1151 
1152  ! Use all processes to compute the basic obsevration information
1153  ! (locations in model grids and the subdomains they belong to)
1154  !-----------------------------------------------------------------------------
1155 
1156  do iof = 1, obs_in_num
1157  if( obs(iof)%nobs > 0 ) then ! Process basic obsevration information for all observations since this information is not saved in obsda files
1158  ! when using separate observation operators; ignore the 'OBSDA_RUN' setting for this section
1159  nsub = obs(iof)%nobs / nprc_lcl
1160  nmod = mod( obs(iof)%nobs, nprc_lcl )
1161  do ip = 1, nmod
1162  cntr(ip) = nsub + 1
1163  end do
1164  do ip = nmod+1, nprc_lcl
1165  cntr(ip) = nsub
1166  end do
1167  dspr(1) = 0
1168  do ip = 2, nprc_lcl
1169  dspr(ip) = dspr(ip-1) + cntr(ip-1)
1170  end do
1171 
1172  obrank_bufs(:) = -1
1173  do ibufs = 1, cntr(rank_lcl+1)
1174  n = dspr(rank_lcl+1) + ibufs
1175 
1176  call phys2ij(obs(iof)%lon(n), obs(iof)%lat(n), ri_bufs(ibufs), rj_bufs(ibufs))
1177  call rij_rank(ri_bufs(ibufs), rj_bufs(ibufs), obrank_bufs(ibufs))
1178  end do
1179 
1180  call mpi_allgatherv( obrank_bufs, cntr(rank_lcl+1), mpi_integer, obs(iof)%rank, cntr, dspr, mpi_integer, comm_lcl, ierr )
1181  call mpi_allgatherv( ri_bufs, cntr(rank_lcl+1), datatype, obs(iof)%ri, cntr, dspr, datatype, comm_lcl, ierr )
1182  call mpi_allgatherv( rj_bufs, cntr(rank_lcl+1), datatype, obs(iof)%rj, cntr, dspr, datatype, comm_lcl, ierr )
1183 
1184  end if
1185  end do
1186 
1187  deallocate(cntr, dspr)
1188  deallocate(obrank_bufs, ri_bufs, rj_bufs)
1189 
1190  ! Bucket sort of observation wrt. time slots and subdomains using the process rank 0
1191  !-----------------------------------------------------------------------------
1192 
1193  islot_time_out = slot_end + 1 ! slot = SLOT_END+1 for observation not in the assimilation time window
1194  islot_domain_out = slot_end + 2 ! slot = SLOT_END+2 for observation outside of the model domain
1195 
1196  allocate( bsn( slot_start :slot_end+2, 0:nprc_lcl-1 ) )
1197  allocate( bsna( slot_start-1:slot_end+2, 0:nprc_lcl-1 ) )
1198 
1199  if (rank_ens == 0) then
1200  allocate ( obset_bufs(nobs_all) )
1201  allocate ( obidx_bufs(nobs_all) )
1202  end if
1203 
1204  if (rank_ens == 0 .and. rank_lcl == 0) then
1205  allocate( bsnext( slot_start:slot_end+2, 0:nprc_lcl-1 ) )
1206  bsn(:,:) = 0
1207  bsna(:,:) = 0
1208  bsnext(:,:) = 0
1209 
1210  do iof = 1, obs_in_num
1211  if (obsda_run(iof) .and. obs(iof)%nobs > 0) then
1212  do n = 1, obs(iof)%nobs
1213  if (obs(iof)%rank(n) == -1) then
1214  ! process the observations outside of the model domain in process rank 0
1215  bsn(islot_domain_out, 0) = bsn(islot_domain_out, 0) + 1
1216  else
1217  islot = ceiling(obs(iof)%dif(n) / slot_tinterval - 0.5d0) + slot_base
1218  if (islot < slot_start .or. islot > slot_end) then
1219  islot = islot_time_out
1220  end if
1221  bsn(islot, obs(iof)%rank(n)) = bsn(islot, obs(iof)%rank(n)) + 1
1222  end if
1223  end do
1224  end if
1225  end do
1226 
1227  do ip = 0, nprc_lcl-1
1228  if (ip > 0) then
1229  bsna(slot_start-1, ip) = bsna(slot_end+2, ip-1)
1230  end if
1231  do islot = slot_start, slot_end+2
1232  bsna(islot, ip) = bsna(islot-1, ip) + bsn(islot, ip)
1233  end do
1234  bsnext(slot_start:slot_end+2, ip) = bsna(slot_start-1:slot_end+1, ip)
1235  end do
1236 
1237  do iof = 1, obs_in_num
1238  if (obsda_run(iof) .and. obs(iof)%nobs > 0) then
1239  do n = 1, obs(iof)%nobs
1240  if (obs(iof)%rank(n) == -1) then
1241  ! process the observations outside of the model domain in process rank 0
1242  bsnext(islot_domain_out, 0) = bsnext(islot_domain_out, 0) + 1
1243  obset_bufs(bsnext(islot_domain_out, 0)) = iof
1244  obidx_bufs(bsnext(islot_domain_out, 0)) = n
1245  else
1246  islot = ceiling(obs(iof)%dif(n) / slot_tinterval - 0.5d0) + slot_base
1247  if (islot < slot_start .or. islot > slot_end) then
1248  islot = islot_time_out
1249  end if
1250  bsnext(islot, obs(iof)%rank(n)) = bsnext(islot, obs(iof)%rank(n)) + 1
1251  obset_bufs(bsnext(islot, obs(iof)%rank(n))) = iof
1252  obidx_bufs(bsnext(islot, obs(iof)%rank(n))) = n
1253  end if
1254  end do
1255  end if
1256  end do
1257 
1258  deallocate( bsnext )
1259 
1260  end if
1261 
1262  ! Broadcast the bucket-sort observation numbers to all processes and print
1263  !-----------------------------------------------------------------------------
1264 
1265  if( rank_lcl == 0 ) then
1266  call mpi_bcast( bsn, (slot_end-slot_start+3)*nprc_lcl, mpi_integer, 0, comm_ens, ierr )
1267  call mpi_bcast( bsna, (slot_end-slot_start+4)*nprc_lcl, mpi_integer, 0, comm_ens, ierr )
1268  end if
1269  call mpi_bcast( bsn, (slot_end-slot_start+3)*nprc_lcl, mpi_integer, 0, comm_lcl, ierr )
1270  call mpi_bcast( bsna, (slot_end-slot_start+4)*nprc_lcl, mpi_integer, 0, comm_lcl, ierr )
1271 
1272  do islot = slot_start, slot_end
1273  slot_id(islot) = islot - slot_start + 1
1274  slot_lb(islot) = (real(islot - slot_base, rp) - 0.5d0) * slot_tinterval
1275  slot_ub(islot) = (real(islot - slot_base, rp) + 0.5d0) * slot_tinterval
1276  end do
1277 
1278  ! Scatter the basic obsevration information to processes group {myrank_e = 0},
1279  ! each of which only gets the data in its own subdomain
1280  !-----------------------------------------------------------------------------
1281 
1282  nobs = bsna( slot_end+2, rank_lcl ) - bsna( slot_start-1, rank_lcl )
1283 
1284  obsda_tmp%nobs = nobs
1285  call obs_da_value_allocate(obsda_tmp, 0)
1286 
1287  if (present(nobs_extern)) then
1288  obsda%nobs = nobs + nobs_extern
1289  else
1290  obsda%nobs = nobs
1291  end if
1292  call obs_da_value_allocate(obsda, nitmax)
1293 
1294  if (rank_ens == 0) then
1295  allocate (cnts(nprc_lcl))
1296  allocate (dsps(nprc_lcl))
1297  do ip = 0, nprc_lcl-1
1298  dsps(ip+1) = bsna(slot_start-1, ip)
1299  cnts(ip+1) = bsna(slot_end+2, ip) - dsps(ip+1)
1300  end do
1301 
1302  call mpi_scatterv(obset_bufs, cnts, dsps, mpi_integer, obsda_tmp%set, cnts(rank_lcl+1), mpi_integer, 0, comm_lcl, ierr)
1303  call mpi_scatterv(obidx_bufs, cnts, dsps, mpi_integer, obsda_tmp%idx, cnts(rank_lcl+1), mpi_integer, 0, comm_lcl, ierr)
1304 
1305  deallocate (cnts, dsps)
1306  deallocate (obset_bufs, obidx_bufs)
1307  end if
1308 
1309  ! Broadcast the basic obsevration information
1310  ! from processes group {myrank_e = 0} to all processes
1311  !-----------------------------------------------------------------------------
1312 
1313  call mpi_bcast(obsda_tmp%set, nobs, mpi_integer, 0, comm_ens, ierr)
1314  call mpi_bcast(obsda_tmp%idx, nobs, mpi_integer, 0, comm_ens, ierr)
1315 
1316  obsda%set(1:nobs) = obsda_tmp%set
1317  obsda%idx(1:nobs) = obsda_tmp%idx
1318 
1319  !-------------------------------------------------------------------------------
1320  ! Second scan of observation data in own subdomain: Compute H(x), QC, ... etc.
1321  !-------------------------------------------------------------------------------
1322 
1323  allocate ( v3dg(nlevh,nlonh,nlath,nv3dd) )
1324  allocate ( v2dg( nlonh,nlath,nv2dd) )
1325 
1326  do j = 1, nlath
1327  do i = 1, nlonh
1328  do k = 1, nlevh
1329  v3dg(k,i,j,iv3dd_u ) = u(k,i,j)
1330  v3dg(k,i,j,iv3dd_v ) = v(k,i,j)
1331  v3dg(k,i,j,iv3dd_w ) = w(k,i,j)
1332  v3dg(k,i,j,iv3dd_t ) = temp(k,i,j)
1333  v3dg(k,i,j,iv3dd_p ) = pres(k,i,j)
1334  v3dg(k,i,j,iv3dd_q ) = qv(k,i,j)
1335  v3dg(k,i,j,iv3dd_qc ) = qc(k,i,j)
1336  v3dg(k,i,j,iv3dd_qr ) = qr(k,i,j)
1337  v3dg(k,i,j,iv3dd_qi ) = qi(k,i,j)
1338  v3dg(k,i,j,iv3dd_qs ) = qs(k,i,j)
1339  v3dg(k,i,j,iv3dd_qg ) = qg(k,i,j)
1340  v3dg(k,i,j,iv3dd_rh ) = rh(k,i,j)
1341  v3dg(k,i,j,iv3dd_hgt) = hgt(k,i,j)
1342  end do
1343  end do
1344  end do
1345  do j = 1, nlath
1346  do i = 1, nlonh
1347  v2dg(i,j,iv2dd_topo) = topo(i,j)
1348  v2dg(i,j,iv2dd_ps ) = ps(i,j)
1349  v2dg(i,j,iv2dd_rain) = rain(i,j)
1350  v2dg(i,j,iv2dd_u10m) = u10m(i,j)
1351  v2dg(i,j,iv2dd_v10m) = v10m(i,j)
1352  v2dg(i,j,iv2dd_t2m ) = t2m(i,j)
1353  v2dg(i,j,iv2dd_q2m ) = q2m(i,j)
1354  end do
1355  end do
1356 
1357  do it = 1, nitmax
1358  if (nobs > 0) then
1359  obsda_tmp%qc(1:nobs) = iqc_undef
1360  end if
1361 
1362  ! Observations not in the assimilation time window
1363  !
1364  n1 = bsna(islot_time_out-1, rank_lcl) - bsna(slot_start-1, rank_lcl) + 1
1365  n2 = bsna(islot_time_out, rank_lcl) - bsna(slot_start-1, rank_lcl)
1366  if (n1 <= n2) then
1367  obsda_tmp%qc(n1:n2) = iqc_time
1368  end if
1369 
1370  ! Observations outside of the model domain
1371  !
1372  n1 = bsna(islot_domain_out-1, rank_lcl) - bsna(slot_start-1, rank_lcl) + 1
1373  n2 = bsna(islot_domain_out, rank_lcl) - bsna(slot_start-1, rank_lcl)
1374  if (n1 <= n2) then
1375  obsda_tmp%qc(n1:n2) = iqc_out_h
1376  end if
1377 
1378  ! Valid observations: loop over time slots
1379  !
1380  do islot = slot_start, slot_end
1381  n1 = bsna(islot-1, rank_lcl) - bsna(slot_start-1, rank_lcl) + 1
1382  n2 = bsna(islot, rank_lcl) - bsna(slot_start-1, rank_lcl)
1383  slot_nobsg = sum(bsn(islot, :))
1384 
1385  if (slot_nobsg <= 0) then
1386  cycle
1387  end if
1388 
1389  !call read_history( filename, it, islot, v3dg, v2dg )
1390 
1391  do nn = n1, n2
1392  iof = obsda_tmp%set(nn)
1393  n = obsda_tmp%idx(nn)
1394 
1395  call rij_g2l(rank_lcl, obs(iof)%ri(n), obs(iof)%rj(n), ril, rjl)
1396 
1397  if (.not. use_obs(obs(iof)%typ(n))) then
1398  obsda_tmp%qc(nn) = iqc_otype
1399  cycle
1400  end if
1401 
1402  select case (obs_in_format(iof))
1403  !=====================================================================
1404  case ( 'PREPBUFR' )
1405  !---------------------------------------------------------------------
1406  call phys2ijk(v3dg(:,:,:,iv3dd_p), obs(iof)%elm(n), ril, rjl, obs(iof)%lev(n), rk, obsda_tmp%qc(nn))
1407  if (obsda_tmp%qc(nn) == iqc_good) then
1408  call trans_xtoy(obs(iof)%elm(n), ril, rjl, rk, &
1409  obs(iof)%lon(n), obs(iof)%lat(n), v3dg, v2dg, obsda_tmp%val(nn), obsda_tmp%qc(nn))
1410  end if
1411  !=====================================================================
1412  case ( 'RADAR', 'PAWR_TOSHIBA', 'MP_PAWR_TOSHIBA', 'PAWR_JRC', 'HIMAWARI8' )
1413  !---------------------------------------------------------------------
1414  if ( obs(iof)%lev(n) > radar_zmax .or. obs(iof)%lev(n) < radar_zmin ) then
1415  obsda_tmp%qc(nn) = iqc_radar_vhi
1416  else
1417  call phys2ijkz(v3dg(:,:,:,iv3dd_hgt), ril, rjl, obs(iof)%lev(n), rkz, obsda_tmp%qc(nn))
1418  end if
1419  if (obsda_tmp%qc(nn) == iqc_good) then
1420  call trans_xtoy_radar(obs(iof)%elm(n), obs(iof)%meta(1), obs(iof)%meta(2), obs(iof)%meta(3), ril, rjl, rkz, &
1421  obs(iof)%lon(n), obs(iof)%lat(n), obs(iof)%lev(n), v3dg, v2dg, obsda_tmp%val(nn), obsda_tmp%qc(nn))
1422  !if (obsda_tmp%qc(nn) == iqc_ref_low) obsda_tmp%qc(nn) = iqc_good ! when process the observation operator, we don't care if reflectivity is too small
1423 
1424  call itpl_3d( v3dg(:,:,:,iv3dd_p), rkz, ril, rjl, obsda_tmp%pm(nn) )
1425  call itpl_3d( v3dg(:,:,:,iv3dd_t), rkz, ril, rjl, obsda_tmp%tm(nn) )
1426  call itpl_3d( v3dg(:,:,:,iv3dd_q), rkz, ril, rjl, obsda_tmp%qv(nn) )
1427 
1428  end if
1429  end select
1430  end do
1431  end do
1432 
1433  !!! (tentative) avoid a bug with GCC 5-8 compiler in L1421 (process to treat iqc_ref_low as iqc_good) !!!
1434  where( obsda_tmp%qc(:) == iqc_ref_low )
1435  obsda_tmp%qc(:) = iqc_good
1436  end where
1437 
1438  ! Prepare variables that will need to be communicated if obsda_return is given
1439  !
1440  call obs_da_value_partial_reduce_iter(obsda, it, 1, nobs, obsda_tmp%val, obsda_tmp%qc, &
1441  obsda_tmp%qv, obsda_tmp%tm, obsda_tmp%pm )
1442  end do
1443 
1444  deallocate ( v3dg, v2dg )
1445  deallocate ( bsn, bsna )
1446 
1447  call obs_da_value_deallocate( obsda_tmp )
1448 
1449  return
1450  end subroutine letkf_obs_operator
1451 
1452  subroutine letkf_obs_initialize( OBS_IN_NUM, nobs_extern )
1453  use scale_prc, only: &
1454  prc_abort
1455  use scale_const, only: &
1456  undef => const_undef, &
1457  tem00 => const_tem00
1458  IMPLICIT NONE
1459 
1460  integer, intent(in) :: obs_in_num
1461  integer, optional, intent(in) :: nobs_extern
1462 
1463  INTEGER :: n,i,j,ierr,im,iof,iidx
1464 
1465  integer :: n1, n2
1466 
1467  integer :: mem_ref
1468  real(rp) :: qvs, qdry
1469 
1470  integer :: it,ip
1471  integer :: ityp,ielm,ielm_u,ictype
1472  real(rp) :: target_grdspc
1473 
1474  integer :: myp_i,myp_j
1475  integer :: ip_i,ip_j
1476 
1477  integer :: nobs_sub(n_qc_steps),nobs_g(n_qc_steps)
1478 
1479  integer :: nobs_elms(nid_obs)
1480  integer :: nobs_elms_sum(nid_obs)
1481 
1482  integer :: nobs_intern
1483  integer :: nobs_extern_
1484 
1485 
1486  character(len=3) :: use_obs_print
1487  character(4) :: nstr
1488 
1489  integer :: cnts
1490  integer :: cntr(nprc_lcl)
1491  integer :: dspr(nprc_lcl)
1492  integer :: nensobs_div, nensobs_mod
1493  integer :: im_obs_1, im_obs_2, nensobs_part
1494 
1495  integer :: ns_ext, ne_ext, ns_bufr, ne_bufr
1496  integer :: ishift, jshift
1497 
1498  type(obs_da_value) :: obsbufs, obsbufr
1499  integer :: imin1,imax1,jmin1,jmax1,imin2,imax2,jmin2,jmax2
1500 
1501  real(rp),allocatable :: tmpelm(:)
1502  integer :: monit_nobs(nid_obs)
1503  real(rp) :: bias(nid_obs)
1504  real(rp) :: rmse(nid_obs)
1505 
1506  type(obs_da_value) :: obsda_ext
1507  logical :: ctype_use(nid_obs,nobtype)
1508  !-------------------------------------------------------------------------------
1509 
1510  log_progress(*) 'data-assimilation / LETKF / obs / initialize'
1511 
1512  if( present(nobs_extern) ) then
1513  nobs_extern_ = nobs_extern
1514  else
1515  nobs_extern_ = 0
1516  endif
1517 
1518  nobs_intern = obsda%nobs - nobs_extern_
1519  if( letkf_debug_log ) then
1520  log_info("LETKF_debug",'(1x,A,I8)') 'Internally processed observations: ', nobs_intern
1521  log_info("LETKF_debug",'(1x,A,I8)') 'Externally processed observations: ', nobs_extern_
1522  log_info("LETKF_debug",'(1x,A,I8)') 'Total observations: ', obsda%nobs
1523  endif
1524 
1525  !-------------------------------------------------------------------------------
1526  ! Read externally processed observations
1527  !-------------------------------------------------------------------------------
1528 
1529  !if( nobs_extern > 0 ) then
1530  ! n1 = nobs_intern + 1
1531  ! n2 = obsda%nobs
1532 
1533  ! obsda_ext%nobs = nobs_extern
1534  ! call obs_da_value_allocate(obsda_ext,0)
1535 
1536  ! do it = 1, nitmax
1537  ! im = myrank_to_mem(it)
1538  ! if ((im >= 1 .and. im <= MEMBER) .or. im == mmdetin) then
1539  ! if (im <= MEMBER) then
1540  ! obsdafile = OBSDA_IN_BASENAME
1541  ! call filename_replace_mem(obsdafile, im)
1542  ! else if (im == mmean) then
1543  ! obsdafile = OBSDA_MEAN_IN_BASENAME
1544  ! else if (im == mmdet) then
1545  ! obsdafile = OBSDA_MDET_IN_BASENAME
1546  ! end if
1547  ! call read_obs_da(trim(obsdafile)//obsda_suffix,obsda_ext,0)
1548 
1549  ! if (OBSDA_OUT) then
1550  ! if (im <= MEMBER) then
1551  ! obsdafile = OBSDA_OUT_BASENAME
1552  ! call filename_replace_mem(obsdafile, im)
1553  ! else if (im == mmean) then
1554  ! obsdafile = OBSDA_MEAN_OUT_BASENAME
1555  ! else if (im == mmdet) then
1556  ! obsdafile = OBSDA_MDET_OUT_BASENAME
1557  ! end if
1558  ! call write_obs_da(trim(obsdafile)//obsda_suffix,obsda_ext,0,append=.true.)
1559  ! end if
1560 
1561  ! ! variables without an ensemble dimension
1562  ! if (it == 1) then
1563  ! obsda%set(n1:n2) = obsda_ext%set
1564  ! obsda%idx(n1:n2) = obsda_ext%idx
1565  ! end if
1566 
1567  ! call obs_da_value_partial_reduce_iter(obsda, it, n1, n2, obsda_ext%val, obsda_ext%qc, &
1568  ! obsda_ext%qv, obsda_ext%tm, obsda_ext%pm )
1569 
1570  ! end if ! [ (im >= 1 .and. im <= MEMBER) .or. im == mmdetin ]
1571  ! end do ! [ it = 1, nitmax ]
1572 
1573  ! call obs_da_value_deallocate(obsda_ext)
1574 
1575  ! ! Broadcast the observation information shared by members (e.g., grid numbers)
1576  ! !---------------------------------------------------------------------------
1577 
1578  ! if (nprocs_e > MEMBER) then
1579  ! call MPI_BCAST(obsda%set(n1:n2), nobs_extern, MPI_INTEGER, 0, MPI_COMM_e, ierr)
1580  ! call MPI_BCAST(obsda%idx(n1:n2), nobs_extern, MPI_INTEGER, 0, MPI_COMM_e, ierr)
1581  ! end if
1582  !end if
1583 
1584  !-------------------------------------------------------------------------------
1585  ! Allreduce externally processed observations
1586  !---------------------------------------------------------------------------
1587 
1588  call obs_da_value_allreduce( obsda )
1589 
1590  !-------------------------------------------------------------------------------
1591  ! Process observations and quality control (QC)
1592  !-------------------------------------------------------------------------------
1593 
1594  ! Pre-process data
1595  !-----------------------------------------------------------------------------
1596 
1597  ctype_use(:,:) = .false.
1598  do iof = 1, obs_in_num
1599  do n = 1, obs(iof)%nobs
1600  select case (obs(iof)%elm(n))
1601  case (id_radar_ref_obs)
1602  if (obs(iof)%dat(n) >= 0.0d0 .and. obs(iof)%dat(n) < 1.0d10) then
1603  if (obs(iof)%dat(n) < min_radar_ref) then
1604  obs(iof)%elm(n) = id_radar_ref_zero_obs
1605  obs(iof)%dat(n) = min_radar_ref_dbz + low_ref_shift
1606  else
1607  obs(iof)%dat(n) = 10.0d0 * log10(obs(iof)%dat(n))
1608  end if
1609  else
1610  obs(iof)%dat(n) = undef
1611  end if
1612  if (use_obserr_radar_ref) then
1613  obs(iof)%err(n) = obserr_radar_ref
1614  end if
1615  case (id_radar_ref_zero_obs)
1616  obs(iof)%dat(n) = min_radar_ref_dbz + low_ref_shift
1617  if (use_obserr_radar_ref) then
1618  obs(iof)%err(n) = obserr_radar_ref
1619  end if
1620  case (id_radar_vr_obs)
1621  if (use_obserr_radar_vr) then
1622  obs(iof)%err(n) = obserr_radar_vr
1623  end if
1624  end select
1625 
1626  ! mark (elm, typ) combinations for which observations exist
1627  ctype_use(uid_obs(obs(iof)%elm(n)), obs(iof)%typ(n)) = .true.
1628  end do
1629  end do
1630 
1631  ! do this outside of the above obs loop, so these (ctype) arrays can be in ascending order
1632  nctype = count(ctype_use)
1633  if (allocated(elm_ctype )) deallocate(elm_ctype )
1634  if (allocated(elm_u_ctype )) deallocate(elm_u_ctype )
1635  if (allocated(typ_ctype )) deallocate(typ_ctype )
1636  if (allocated(hori_loc_ctype)) deallocate(hori_loc_ctype)
1637  if (allocated(vert_loc_ctype)) deallocate(vert_loc_ctype)
1638  allocate (elm_ctype(nctype))
1639  allocate (elm_u_ctype(nctype))
1640  allocate (typ_ctype(nctype))
1641  allocate (hori_loc_ctype(nctype))
1642  allocate (vert_loc_ctype(nctype))
1643  ictype = 0
1644  ctype_elmtyp(:,:) = 0
1645  do ityp = 1, nobtype
1646  do ielm_u = 1, nid_obs
1647  if (ctype_use(ielm_u, ityp)) then
1648  ictype = ictype + 1
1649  ctype_elmtyp(ielm_u, ityp) = ictype
1650 
1651  elm_ctype(ictype) = elem_uid(ielm_u)
1652  elm_u_ctype(ictype) = ielm_u
1653  typ_ctype(ictype) = ityp
1654 
1655  ! horizontal localization
1656  if (elm_ctype(ictype) == id_radar_ref_zero_obs) then
1657  hori_loc_ctype(ictype) = hori_local_radar_obsnoref
1658  else if (elm_ctype(ictype) == id_radar_vr_obs) then
1659  hori_loc_ctype(ictype) = hori_local_radar_vr
1660  else
1661  hori_loc_ctype(ictype) = hori_local(ityp)
1662  end if
1663  ! vertical localization
1664  if (elm_ctype(ictype) == id_radar_vr_obs) then
1665  vert_loc_ctype(ictype) = vert_local_radar_vr
1666  else
1667  vert_loc_ctype(ictype) = vert_local(ityp)
1668  end if
1669  end if ! [ ctype_use(ielm_u, ityp) ]
1670  end do ! [ ielm_u = 1, nid_obs ]
1671  end do ! [ ityp = 1, nobtype ]
1672 
1673  ! Compute perturbation and departure
1674  ! -- gross error check
1675  ! -- QC based on background (radar reflectivity)
1676  ! -- process Himawari-8 data
1677  !-----------------------------------------------------------------------------
1678 
1679  allocate(tmpelm(obsda%nobs))
1680 
1681  do n = 1, obsda%nobs
1682  IF(obsda%qc(n) > 0) cycle
1683 
1684  iof = obsda%set(n)
1685  iidx = obsda%idx(n)
1686 
1687  tmpelm(n) = obs(iof)%elm(iidx)
1688 
1689  !!! ###### RADAR assimilation ######
1690  if (obs(iof)%elm(iidx) == id_radar_ref_obs .or. obs(iof)%elm(iidx) == id_radar_ref_zero_obs) then
1691  if (.not. use_radar_ref) then
1692  obsda%qc(n) = iqc_otype
1693  cycle
1694  end if
1695 
1696  if (obs(iof)%dat(iidx) == undef) then
1697  obsda%qc(n) = iqc_obs_bad
1698  cycle
1699  end if
1700 
1701  !!! obsda%ensval: already converted to dBZ
1702  mem_ref = 0
1703  do i = 1, nmem
1704  if (obsda%ensval(i,n) > radar_ref_thres_dbz+1.0d-6 ) then
1705  mem_ref = mem_ref + 1
1706  end if
1707  end do
1708 
1709  ! Obs: Rain
1710  if (obs(iof)%dat(iidx) > radar_ref_thres_dbz+1.0d-6) then
1711  if (mem_ref < min_radar_ref_member_obsrain) then
1712  obsda%qc(n) = iqc_ref_mem
1713 
1714  if ( .not. radar_pqv ) cycle
1715  ! When RADAR_PQV=True, pseudo qv obs is assimilated even if mem_ref is
1716  ! too small
1717  end if
1718 
1719  else
1720  ! Obs: No rain
1721  if (mem_ref < min_radar_ref_member_obsnorain) then
1722  obsda%qc(n) = iqc_ref_mem
1723  cycle
1724  end if
1725  end if
1726 
1727  end if
1728 
1729  if (obs(iof)%elm(iidx) == id_radar_vr_obs) then
1730  if (.not. use_radar_vr) then
1731  obsda%qc(n) = iqc_otype
1732  cycle
1733  end if
1734  end if
1735  !!! ###### end RADAR assimilation ######
1736 
1737  obsda%val(n) = 0.0_rp
1738  do i = 1, nmem
1739  obsda%val(n) = obsda%val(n) + obsda%ensval(i,n)
1740  end do
1741  obsda%val(n) = obsda%val(n) / real(nmem,kind=rp)
1742 
1743  do i = 1, nmem
1744  obsda%ensval(i,n) = obsda%ensval(i,n) - obsda%val(n) ! Hdx
1745  end do
1746  obsda%val(n) = obs(iof)%dat(iidx) - obsda%val(n) ! y-Hx
1747  if( ens_with_mdet ) then
1748  obsda%ensval(mmdetobs,n) = obs(iof)%dat(iidx) - obsda%ensval(mmdetobs,n) ! y-Hx for deterministic run
1749  end if
1750 
1751  select case (obs(iof)%elm(iidx)) !gross error
1752  case (id_rain_obs)
1753  IF(abs(obsda%val(n)) > gross_error_rain * obs(iof)%err(iidx)) THEN
1754  obsda%qc(n) = iqc_gross_err
1755  END IF
1756  case (id_radar_ref_obs,id_radar_ref_zero_obs)
1757 
1758  if( radar_pqv .and. obsda%val(n) > radar_pqv_omb ) then
1759 
1760  ! pseudo qv
1761  obsda%val(n) = 0.0_rp
1762  do i = 1, nmem
1763  obsda%val(n) = obsda%val(n) + obsda%eqv(i,n)
1764  enddo
1765  obsda%val(n) = obsda%val(n) / real(nmem, kind=rp)
1766 
1767  do i = 1, nmem
1768  obsda%ensval(i,n) = obsda%eqv(i,n) - obsda%val(n) ! Hdx
1769  enddO
1770 
1771  ! Tetens equation es(Pa)
1772  qvs = 611.2d0*exp(17.67d0*(obsda%tm(n)-tem00)/(obsda%tm(n) - tem00 + 243.5d0))
1773 
1774  ! Saturtion mixing ratio
1775  qvs = 0.622d0*qvs / ( obsda%pm(n) - qvs )
1776 
1777  obsda%val(n) = qvs - obsda%val(n) ! y-Hx
1778 
1779  if (ens_with_mdet) then
1780  obsda%ensval(mmdetobs,n) = qvs - obsda%eqv(mmdetobs,n) ! y-Hx for deterministic run
1781  end if
1782 
1783  obsda%tm(n) = -1.0d0
1784 
1785  else
1786  IF(abs(obsda%val(n)) > gross_error_radar_ref * obs(iof)%err(iidx)) THEN
1787  obsda%qc(n) = iqc_gross_err
1788  END IF
1789  endif
1790  case (id_radar_vr_obs)
1791  IF(abs(obsda%val(n)) > gross_error_radar_vr * obs(iof)%err(iidx)) THEN
1792  obsda%qc(n) = iqc_gross_err
1793  END IF
1794  case (id_radar_prh_obs)
1795  IF(abs(obsda%val(n)) > gross_error_radar_prh * obs(iof)%err(iidx)) THEN
1796  obsda%qc(n) = iqc_gross_err
1797  END IF
1798  case default
1799  IF(abs(obsda%val(n)) > gross_error * obs(iof)%err(iidx)) THEN
1800  obsda%qc(n) = iqc_gross_err
1801  END IF
1802  end select
1803 
1804  END DO
1805 
1806  if( letkf_debug_log ) then
1807  log_info("LETKF_debug",'(1x,A,I6,A)') 'OBSERVATIONAL DEPARTURE STATISTICS (IN THIS SUBDOMAIN #', rank_lcl, '):'
1808 
1809  call monit_dep( obsda%nobs, tmpelm, obsda%val, obsda%qc, monit_nobs, bias, rmse )
1810  call monit_print( monit_nobs, bias, rmse )
1811  end if
1812 
1813  deallocate(tmpelm)
1814 
1815  !-------------------------------------------------------------------------------
1816  ! "Bucket sort" of observations of each combined type (with different sorting meshes)
1817  !-------------------------------------------------------------------------------
1818 
1819  if (allocated(obsgrd)) deallocate(obsgrd)
1820  allocate (obsgrd(nctype))
1821 
1822  ! Determine mesh size for bucket sort
1823  !-----------------------------------------------------------------------------
1824 
1825  do ictype = 1, nctype
1826  ityp = typ_ctype(ictype)
1827 
1828  if( obs_sort_grid_spacing(ityp) > 0.0_rp ) then
1829  target_grdspc = obs_sort_grid_spacing(ityp)
1830  else if( max_nobs_per_grid(ityp) > 0 ) then
1831  target_grdspc = 0.1_rp * sqrt( real(max_nobs_per_grid(ityp), kind=rp) ) * obs_min_spacing(ityp) ! need to be tuned
1832  else
1833  target_grdspc = hori_loc_ctype(ictype) * dist_zero_fac / 6.0_rp ! need to be tuned
1834  end if
1835  obsgrd(ictype)%ngrd_i = min( ceiling( dx * real( nlon, kind=rp ) / target_grdspc), nlon )
1836  obsgrd(ictype)%ngrd_j = min( ceiling( dy * real( nlat, kind=rp ) / target_grdspc), nlat )
1837  obsgrd(ictype)%grdspc_i = dx * real( nlon, kind=rp ) / real( obsgrd( ictype )%ngrd_i, kind=rp )
1838  obsgrd(ictype)%grdspc_j = dy * real( nlat, kind=rp ) / real( obsgrd( ictype )%ngrd_j, kind=rp )
1839  if( letkf_entire_grid_search_x ) then
1840  obsgrd(ictype)%ngrdsch_i = ceiling( dx * nlong / obsgrd( ictype )%grdspc_i )
1841  else
1842  obsgrd(ictype)%ngrdsch_i = ceiling( hori_loc_ctype( ictype ) * dist_zero_fac / obsgrd( ictype )%grdspc_i )
1843  endif
1844  if( letkf_entire_grid_search_y ) then
1845  obsgrd(ictype)%ngrdsch_j = ceiling( dy * nlatg / obsgrd( ictype )%grdspc_j )
1846  else
1847  obsgrd(ictype)%ngrdsch_j = ceiling( hori_loc_ctype( ictype ) * dist_zero_fac / obsgrd( ictype )%grdspc_j )
1848  endif
1849  obsgrd(ictype)%ngrdext_i = obsgrd( ictype )%ngrd_i + obsgrd( ictype )%ngrdsch_i * 2
1850  obsgrd(ictype)%ngrdext_j = obsgrd( ictype )%ngrd_j + obsgrd( ictype )%ngrdsch_j * 2
1851 
1852  allocate (obsgrd(ictype)%n ( obsgrd(ictype)%ngrd_i, obsgrd(ictype)%ngrd_j, 0:nprc_lcl-1))
1853  allocate (obsgrd(ictype)%ac(0:obsgrd(ictype)%ngrd_i, obsgrd(ictype)%ngrd_j, 0:nprc_lcl-1))
1854  allocate (obsgrd(ictype)%tot(0:nprc_lcl-1))
1855  allocate (obsgrd(ictype)%n_ext ( obsgrd(ictype)%ngrdext_i, obsgrd(ictype)%ngrdext_j))
1856  allocate (obsgrd(ictype)%ac_ext(0:obsgrd(ictype)%ngrdext_i, obsgrd(ictype)%ngrdext_j))
1857 
1858  obsgrd(ictype)%n (:,:,:) = 0
1859  obsgrd(ictype)%ac(:,:,:) = 0
1860  obsgrd(ictype)%tot(:) = 0
1861  obsgrd(ictype)%n_ext (:,:) = 0
1862  obsgrd(ictype)%ac_ext(:,:) = 0
1863  obsgrd(ictype)%tot_ext = 0
1864  obsgrd(ictype)%tot_sub(:) = 0
1865  obsgrd(ictype)%tot_g(:) = 0
1866 
1867  allocate (obsgrd(ictype)%next(obsgrd(ictype)%ngrd_i, obsgrd(ictype)%ngrd_j))
1868  end do
1869 
1870  ! First scan: count the observation numbers in each mesh (in each subdomian)
1871  !-----------------------------------------------------------------------------
1872 
1873  do n = 1, obsda%nobs
1874  iof = obsda%set(n)
1875  iidx = obsda%idx(n)
1876  ictype = ctype_elmtyp(uid_obs(obs(iof)%elm(iidx)), obs(iof)%typ(iidx))
1877 
1878  if (obsda%qc(n) == iqc_good) then
1879  call ij_obsgrd( ictype, obs(iof)%ri(iidx), obs(iof)%rj(iidx), i, j )
1880  if (i < 1) i = 1 ! Assume the process assignment was correct,
1881  if (i > obsgrd(ictype)%ngrd_i) i = obsgrd(ictype)%ngrd_i ! so this correction is only to remedy the round-off problem.
1882  if (j < 1) j = 1 !
1883  if (j > obsgrd(ictype)%ngrd_j) j = obsgrd(ictype)%ngrd_j !
1884 
1885  obsgrd(ictype)%n(i,j,rank_lcl) = obsgrd(ictype)%n(i,j,rank_lcl) + 1
1886  obsgrd(ictype)%tot_sub(i_after_qc) = obsgrd(ictype)%tot_sub(i_after_qc) + 1 ! only used for diagnostic print (obs number after qc)
1887  end if
1888 
1889  obsgrd(ictype)%tot_sub(i_before_qc) = obsgrd(ictype)%tot_sub(i_before_qc) + 1 ! only used for diagnostic print (obs number before qc)
1890  end do
1891 
1892  ! Compute the accumulated numbers in each mesh
1893  !-----------------------------------------------------------------------------
1894 
1895  do ictype = 1, nctype
1896  if (ictype > 1) then
1897  obsgrd(ictype)%ac(0,1,rank_lcl) = obsgrd(ictype-1)%ac(obsgrd(ictype-1)%ngrd_i,obsgrd(ictype-1)%ngrd_j,rank_lcl)
1898  end if
1899  do j = 1, obsgrd(ictype)%ngrd_j
1900  if (j > 1) then
1901  obsgrd(ictype)%ac(0,j,rank_lcl) = obsgrd(ictype)%ac(obsgrd(ictype)%ngrd_i,j-1,rank_lcl)
1902  end if
1903  do i = 1, obsgrd(ictype)%ngrd_i
1904  obsgrd(ictype)%ac(i,j,rank_lcl) = obsgrd(ictype)%ac(i-1,j,rank_lcl) + obsgrd(ictype)%n(i,j,rank_lcl)
1905  end do
1906  end do
1907  obsgrd(ictype)%next(1:obsgrd(ictype)%ngrd_i,:) = obsgrd(ictype)%ac(0:obsgrd(ictype)%ngrd_i-1,:,rank_lcl)
1908  end do
1909 
1910  ! Second scan: save the indices of bucket-sorted observations in obsda%keys(:)
1911  !-----------------------------------------------------------------------------
1912 
1913  do n = 1, obsda%nobs
1914  if (obsda%qc(n) == iqc_good) then
1915  iof = obsda%set(n)
1916  iidx = obsda%idx(n)
1917  ictype = ctype_elmtyp(uid_obs(obs(iof)%elm(iidx)), obs(iof)%typ(iidx))
1918 
1919  call ij_obsgrd( ictype, obs(iof)%ri(iidx), obs(iof)%rj(iidx), i, j )
1920  if (i < 1) i = 1 ! Assume the process assignment was correct,
1921  if (i > obsgrd(ictype)%ngrd_i) i = obsgrd(ictype)%ngrd_i ! so this correction is only to remedy the round-off problem.
1922  if (j < 1) j = 1 !
1923  if (j > obsgrd(ictype)%ngrd_j) j = obsgrd(ictype)%ngrd_j !
1924 
1925  obsgrd(ictype)%next(i,j) = obsgrd(ictype)%next(i,j) + 1
1926  obsda%key(obsgrd(ictype)%next(i,j)) = n
1927  end if
1928  end do
1929 
1930  ! ALLREDUCE observation number information from subdomains, and compute total numbers
1931  !-----------------------------------------------------------------------------
1932 
1933  nobs_sub(:) = 0
1934  nobs_g(:) = 0
1935  do ictype = 1, nctype
1936  if (nprc_lcl > 1) then
1937  call mpi_allreduce(mpi_in_place, obsgrd(ictype)%n, obsgrd(ictype)%ngrd_i*obsgrd(ictype)%ngrd_j*nprc_lcl, &
1938  mpi_integer, mpi_sum, comm_lcl, ierr)
1939  call mpi_allreduce(mpi_in_place, obsgrd(ictype)%ac(0:obsgrd(ictype)%ngrd_i,:,:), (obsgrd(ictype)%ngrd_i+1)*obsgrd(ictype)%ngrd_j*nprc_lcl, &
1940  mpi_integer, mpi_sum, comm_lcl, ierr)
1941  end if
1942  call mpi_allreduce(obsgrd(ictype)%tot_sub, obsgrd(ictype)%tot_g, n_qc_steps, mpi_integer, mpi_sum, comm_lcl, ierr)
1943 
1944  if (ictype == 1) then
1945  obsgrd(ictype)%tot(:) = obsgrd(ictype)%ac(obsgrd(ictype)%ngrd_i,obsgrd(ictype)%ngrd_j,:)
1946  else
1947  obsgrd(ictype)%tot(:) = obsgrd(ictype)%ac(obsgrd(ictype)%ngrd_i,obsgrd(ictype)%ngrd_j,:) &
1948  - obsgrd(ictype-1)%ac(obsgrd(ictype-1)%ngrd_i,obsgrd(ictype-1)%ngrd_j,:)
1949  end if
1950 
1951  nobs_sub(:) = nobs_sub(:) + obsgrd(ictype)%tot_sub(:)
1952  nobs_g(:) = nobs_g(:) + obsgrd(ictype)%tot_g(:)
1953 
1954  deallocate (obsgrd(ictype)%next)
1955  end do
1956 
1957  nobstotalg = nobs_g(i_after_qc) ! total obs number in the global domain (all types)
1958 
1959  ! Calculate observation numbers in the extended (localization) subdomain,
1960  ! in preparation for communicating obsetvations in the extended subdomain
1961  !-----------------------------------------------------------------------------
1962 
1963  call rank_1d_2d(rank_lcl, myp_i, myp_j)
1964 
1965  do ictype = 1, nctype
1966  imin1 = myp_i*obsgrd(ictype)%ngrd_i+1 - obsgrd(ictype)%ngrdsch_i
1967  imax1 = (myp_i+1)*obsgrd(ictype)%ngrd_i + obsgrd(ictype)%ngrdsch_i
1968  jmin1 = myp_j*obsgrd(ictype)%ngrd_j+1 - obsgrd(ictype)%ngrdsch_j
1969  jmax1 = (myp_j+1)*obsgrd(ictype)%ngrd_j + obsgrd(ictype)%ngrdsch_j
1970 
1971  do ip = 0, nprc_lcl-1
1972  call rank_1d_2d(ip, ip_i, ip_j)
1973  imin2 = max(1, imin1 - ip_i*obsgrd(ictype)%ngrd_i)
1974  imax2 = min(obsgrd(ictype)%ngrd_i, imax1 - ip_i*obsgrd(ictype)%ngrd_i)
1975  jmin2 = max(1, jmin1 - ip_j*obsgrd(ictype)%ngrd_j)
1976  jmax2 = min(obsgrd(ictype)%ngrd_j, jmax1 - ip_j*obsgrd(ictype)%ngrd_j)
1977  if (imin2 > imax2 .or. jmin2 > jmax2) cycle
1978 
1979  ishift = (ip_i - myp_i) * obsgrd(ictype)%ngrd_i + obsgrd(ictype)%ngrdsch_i
1980  jshift = (ip_j - myp_j) * obsgrd(ictype)%ngrd_j + obsgrd(ictype)%ngrdsch_j
1981  obsgrd(ictype)%n_ext(imin2+ishift:imax2+ishift, jmin2+jshift:jmax2+jshift) = obsgrd(ictype)%n(imin2:imax2, jmin2:jmax2, ip)
1982  end do
1983 
1984  if (ictype > 1) then
1985  obsgrd(ictype)%ac_ext(0,1) = obsgrd(ictype-1)%ac_ext(obsgrd(ictype-1)%ngrdext_i,obsgrd(ictype-1)%ngrdext_j)
1986  end if
1987  do j = 1, obsgrd(ictype)%ngrdext_j
1988  if (j > 1) then
1989  obsgrd(ictype)%ac_ext(0,j) = obsgrd(ictype)%ac_ext(obsgrd(ictype)%ngrdext_i,j-1)
1990  end if
1991  do i = 1, obsgrd(ictype)%ngrdext_i
1992  obsgrd(ictype)%ac_ext(i,j) = obsgrd(ictype)%ac_ext(i-1,j) + obsgrd(ictype)%n_ext(i,j)
1993  end do
1994  end do
1995 
1996  if (ictype == 1) then
1997  obsgrd(ictype)%tot_ext = obsgrd(ictype)%ac_ext(obsgrd(ictype)%ngrdext_i,obsgrd(ictype)%ngrdext_j)
1998  else
1999  obsgrd(ictype)%tot_ext = obsgrd(ictype)%ac_ext(obsgrd(ictype)%ngrdext_i,obsgrd(ictype)%ngrdext_j) &
2000  - obsgrd(ictype-1)%ac_ext(obsgrd(ictype-1)%ngrdext_i,obsgrd(ictype-1)%ngrdext_j)
2001  end if
2002  end do
2003 
2004  if (nctype > 0) then
2005  nobstotal = obsgrd(nctype)%ac_ext(obsgrd(nctype)%ngrdext_i,obsgrd(nctype)%ngrdext_j) ! total obs number in the extended subdomain (all types)
2006 
2007  maxnobs_per_ctype = obsgrd(1)%tot_ext
2008  do ictype = 2, nctype
2009  maxnobs_per_ctype = max(maxnobs_per_ctype, obsgrd(ictype)%tot_ext)
2010  end do
2011  else
2012  nobstotal = 0
2013  maxnobs_per_ctype = 0
2014  end if
2015 
2016  ! Construct sorted obsda_sort:
2017  !-----------------------------------------------------------------------------
2018 
2019  ! 1) Copy the observation data in own subdomains to send buffer (obsbufs) with
2020  ! sorted order
2021  !-----------------------------------------------------------------------------
2022  if (nctype > 0) then
2023  cntr(:) = obsgrd(nctype)%ac(obsgrd(nctype)%ngrd_i,obsgrd(nctype)%ngrd_j,:)
2024  cnts = cntr(rank_lcl+1)
2025  dspr(1) = 0
2026  do ip = 2, nprc_lcl
2027  dspr(ip) = dspr(ip-1) + cntr(ip-1)
2028  end do
2029 
2030  nensobs_mod = mod(nensobs, nprc_ens)
2031  nensobs_div = (nensobs - nensobs_mod) / nprc_ens
2032  if (rank_ens < nensobs_mod) then
2033  im_obs_1 = (nensobs_div+1) * rank_ens + 1
2034  im_obs_2 = (nensobs_div+1) * (rank_ens+1)
2035  nensobs_part = nensobs_div + 1
2036  else
2037  im_obs_1 = (nensobs_div+1) * nensobs_mod + nensobs_div * (rank_ens-nensobs_mod) + 1
2038  im_obs_2 = (nensobs_div+1) * nensobs_mod + nensobs_div * (rank_ens-nensobs_mod+1)
2039  nensobs_part = nensobs_div
2040  end if
2041 
2042  obsbufs%nobs = nobs_sub(i_after_qc)
2043  call obs_da_value_allocate(obsbufs, nensobs_part)
2044 
2045  do n = 1, nobs_sub(i_after_qc)
2046  obsbufs%set(n) = obsda%set(obsda%key(n))
2047  obsbufs%idx(n) = obsda%idx(obsda%key(n))
2048  obsbufs%val(n) = obsda%val(obsda%key(n))
2049  obsbufs%tm(n) = obsda%tm(obsda%key(n))
2050  if (nensobs_part > 0) then
2051  obsbufs%ensval(1:nensobs_part,n) = obsda%ensval(im_obs_1:im_obs_2,obsda%key(n))
2052  end if
2053  obsbufs%qc(n) = obsda%qc(obsda%key(n))
2054  end do
2055  end if
2056 
2057  call obs_da_value_deallocate(obsda)
2058 
2059  ! 2) Communicate to get global observations;
2060  ! for variables with an ensemble dimension (ensval),
2061  ! only obtain data from partial members (nensobs_part) to save memory usage
2062  !-----------------------------------------------------------------------------
2063  if (nctype > 0) then
2064  obsbufr%nobs = nobs_g(i_after_qc)
2065  call obs_da_value_allocate(obsbufr, nensobs_part)
2066 
2067  call mpi_allgatherv( obsbufs%set, cnts, mpi_integer, obsbufr%set, cntr, dspr, mpi_integer, comm_lcl, ierr )
2068  call mpi_allgatherv( obsbufs%idx, cnts, mpi_integer, obsbufr%idx, cntr, dspr, mpi_integer, comm_lcl, ierr )
2069  call mpi_allgatherv( obsbufs%val, cnts, datatype, obsbufr%val, cntr, dspr, datatype, comm_lcl, ierr )
2070  call mpi_allgatherv( obsbufs%tm, cnts, datatype, obsbufr%tm, cntr, dspr, datatype, comm_lcl, ierr )
2071  if (nensobs_part > 0) then
2072  call mpi_allgatherv(obsbufs%ensval, cnts*nensobs_part, datatype, obsbufr%ensval, cntr*nensobs_part, dspr*nensobs_part, datatype, comm_lcl, ierr)
2073  end if
2074  call mpi_allgatherv(obsbufs%qc, cnts, mpi_integer, obsbufr%qc, cntr, dspr, mpi_integer, comm_lcl, ierr)
2075 
2076  call obs_da_value_deallocate(obsbufs)
2077  end if
2078 
2079  ! 3) Copy observation data within the extended (localization) subdomains
2080  ! from receive buffer (obsbufr) to obsda_sort; rearrange with sorted order
2081  !-----------------------------------------------------------------------------
2082  obsda_sort%nobs = nobstotal
2083  call obs_da_value_allocate(obsda_sort, nensobs)
2084 
2085  do ip = 0, nprc_lcl-1
2086  call rank_1d_2d(ip, ip_i, ip_j)
2087 
2088  do ictype = 1, nctype
2089  imin1 = myp_i*obsgrd(ictype)%ngrd_i+1 - obsgrd(ictype)%ngrdsch_i
2090  imax1 = (myp_i+1)*obsgrd(ictype)%ngrd_i + obsgrd(ictype)%ngrdsch_i
2091  jmin1 = myp_j*obsgrd(ictype)%ngrd_j+1 - obsgrd(ictype)%ngrdsch_j
2092  jmax1 = (myp_j+1)*obsgrd(ictype)%ngrd_j + obsgrd(ictype)%ngrdsch_j
2093 
2094  imin2 = max(1, imin1 - ip_i*obsgrd(ictype)%ngrd_i)
2095  imax2 = min(obsgrd(ictype)%ngrd_i, imax1 - ip_i*obsgrd(ictype)%ngrd_i)
2096  jmin2 = max(1, jmin1 - ip_j*obsgrd(ictype)%ngrd_j)
2097  jmax2 = min(obsgrd(ictype)%ngrd_j, jmax1 - ip_j*obsgrd(ictype)%ngrd_j)
2098  if (imin2 > imax2 .or. jmin2 > jmax2) cycle
2099 
2100  ishift = (ip_i - myp_i) * obsgrd(ictype)%ngrd_i + obsgrd(ictype)%ngrdsch_i
2101  jshift = (ip_j - myp_j) * obsgrd(ictype)%ngrd_j + obsgrd(ictype)%ngrdsch_j
2102 
2103  do j = jmin2, jmax2
2104  ns_ext = obsgrd(ictype)%ac_ext(imin2+ishift-1,j+jshift) + 1
2105  ne_ext = obsgrd(ictype)%ac_ext(imax2+ishift ,j+jshift)
2106  if (ns_ext > ne_ext) cycle
2107 
2108  ns_bufr = dspr(ip+1) + obsgrd(ictype)%ac(imin2-1,j,ip) + 1
2109  ne_bufr = dspr(ip+1) + obsgrd(ictype)%ac(imax2 ,j,ip)
2110 
2111  obsda_sort%set(ns_ext:ne_ext) = obsbufr%set(ns_bufr:ne_bufr)
2112  obsda_sort%idx(ns_ext:ne_ext) = obsbufr%idx(ns_bufr:ne_bufr)
2113  obsda_sort%val(ns_ext:ne_ext) = obsbufr%val(ns_bufr:ne_bufr)
2114  obsda_sort%tm(ns_ext:ne_ext) = obsbufr%tm(ns_bufr:ne_bufr)
2115  if (nensobs_part > 0) then
2116  obsda_sort%ensval(im_obs_1:im_obs_2,ns_ext:ne_ext) = obsbufr%ensval(1:nensobs_part,ns_bufr:ne_bufr)
2117  end if
2118  obsda_sort%qc(ns_ext:ne_ext) = obsbufr%qc(ns_bufr:ne_bufr)
2119  end do
2120  end do
2121  end do
2122 
2123  ! Save the keys of observations within the subdomain (excluding the localization buffer area)
2124  obsda_sort%nobs_in_key = 0
2125  do ictype = 1, nctype
2126  imin1 = obsgrd(ictype)%ngrdsch_i + 1
2127  imax1 = obsgrd(ictype)%ngrdsch_i + obsgrd(ictype)%ngrd_i
2128  jmin1 = obsgrd(ictype)%ngrdsch_j + 1
2129  jmax1 = obsgrd(ictype)%ngrdsch_j + obsgrd(ictype)%ngrd_j
2130  call obs_choose_ext(ictype, imin1, imax1, jmin1, jmax1, obsda_sort%nobs_in_key, obsda_sort%key)
2131 
2132  deallocate (obsgrd(ictype)%n)
2133  deallocate (obsgrd(ictype)%ac)
2134  deallocate (obsgrd(ictype)%n_ext)
2135  end do
2136 
2137  if (nctype > 0) then
2138  call obs_da_value_deallocate(obsbufr)
2139  end if
2140 
2141  ! 4) For variables with an ensemble dimension (ensval),
2142  ! ALLREDUCE among the ensemble dimension to obtain data of all members
2143  !-----------------------------------------------------------------------------
2144  if (nprc_ens > 1) then
2145  call mpi_allreduce(mpi_in_place, obsda_sort%ensval, nensobs*nobstotal, datatype, mpi_sum, comm_ens, ierr)
2146  end if
2147 
2148  if( letkf_debug_log ) then
2149  log_info("LETKF_debug",'(1x,A,I6,A)') 'OBSERVATION COUNTS (GLOABL AND IN THIS SUBDOMAIN #', rank_lcl, '):'
2150  log_info("LETKF_debug",'(1x,A)') '====================================================================='
2151  log_info("LETKF_debug",'(1x,A)') 'TYPE VAR GLOBAL GLOBAL SUBDOMAIN SUBDOMAIN EXT_SUBDOMAIN'
2152  log_info("LETKF_debug",'(1x,A)') ' before QC after QC before QC after QC after QC'
2153  log_info("LETKF_debug",'(1x,A)') '---------------------------------------------------------------------'
2154  do ictype = 1, nctype
2155  ityp = typ_ctype(ictype)
2156  ielm_u = elm_u_ctype(ictype)
2157  log_info("LETKF_debug",'(1x,A6,1x,A3,1x,4I11,I14)') obtypelist(ityp), obelmlist(ielm_u), &
2158  obsgrd(ictype)%tot_g(i_before_qc), &
2159  obsgrd(ictype)%tot_g(i_after_qc), &
2160  obsgrd(ictype)%tot_sub(i_before_qc), &
2161  obsgrd(ictype)%tot_sub(i_after_qc), &
2162  obsgrd(ictype)%tot_ext
2163  end do
2164  log_info("LETKF_debug",'(1x,A)') '---------------------------------------------------------------------'
2165  log_info("LETKF_debug",'(1x,A,5x,4I11,I14)') 'TOTAL ', nobs_g(i_before_qc), nobs_g(i_after_qc), nobs_sub(i_before_qc), nobs_sub(i_after_qc)
2166  log_info("LETKF_debug",'(1x,A)') '====================================================================='
2167  end if
2168 
2169  return
2170  end subroutine letkf_obs_initialize
2171 
2172  !-----------------------------------------------------------------------
2173  ! Data Assimilation
2174  !-----------------------------------------------------------------------
2175  subroutine letkf_system( &
2176  OBS_IN_NUM, & ! [IN]
2177  OBS_IN_FORMAT, & ! [IN]
2178  U, & ! [INOUT]
2179  V, & ! [INOUT]
2180  W, & ! [INOUT]
2181  TEMP, & ! [INOUT]
2182  PRES, & ! [INOUT]
2183  QV, & ! [INOUT]
2184  QC, & ! [INOUT]
2185  QR, & ! [INOUT]
2186  QI, & ! [INOUT]
2187  QS, & ! [INOUT]
2188  QG ) ! [INOUT]
2189  use scale_prc, only: &
2190  prc_abort
2191  use scale_const, only: &
2192  undef => const_undef
2193  use scale_statistics, only: &
2194  average => statistics_average
2195  use scale_matrix, only: &
2196  matrix_solver_eigenvalue_decomposition
2197  use scale_random, only: &
2198  knuth_shuffle => random_knuth_shuffle
2199  implicit none
2200 
2201  integer, intent(in) :: obs_in_num
2202  character(len=H_LONG), intent(in) :: obs_in_format(:)
2203 
2204  real(rp), intent(inout) :: u (nlev,nlon,nlat)
2205  real(rp), intent(inout) :: v (nlev,nlon,nlat)
2206  real(rp), intent(inout) :: w (nlev,nlon,nlat)
2207  real(rp), intent(inout) :: temp(nlev,nlon,nlat)
2208  real(rp), intent(inout) :: pres(nlev,nlon,nlat)
2209  real(rp), intent(inout) :: qv (nlev,nlon,nlat)
2210  real(rp), intent(inout) :: qc (nlev,nlon,nlat)
2211  real(rp), intent(inout) :: qr (nlev,nlon,nlat)
2212  real(rp), intent(inout) :: qi (nlev,nlon,nlat)
2213  real(rp), intent(inout) :: qs (nlev,nlon,nlat)
2214  real(rp), intent(inout) :: qg (nlev,nlon,nlat)
2215 
2216  real(rp) :: gues3d(nij1,nlev,nens+1,nv3d) ! background ensemble
2217  real(rp) :: gues2d(nij1, nens+1,nv2d) ! background ensemble
2218 
2219  real(rp) :: anal3d(nij1,nlev,nens+1,nv3d) ! analysis ensemble
2220  real(rp) :: anal2d(nij1, nens+1,nv2d) ! analysis ensemble
2221 
2222  real(rp) :: addi3d(nij1,nlev,nens+1,nv3d)
2223  real(rp) :: addi2d(nij1, nens+1,nv2d)
2224 
2225  real(rp) :: v3dg(nlev,nlon,nlat,nv3d)
2226  real(rp) :: v2dg( nlon,nlat,nv2d)
2227 
2228  real(rp) :: work3d(nij1,nlev,nv3d)
2229  real(rp) :: work2d(nij1, nv2d)
2230  real(rp), allocatable :: work3da(:,:,:) !GYL
2231  real(rp), allocatable :: work2da(:,:) !GYL
2232  real(rp), allocatable :: work3dn(:,:,:,:) !GYL
2233  real(rp), allocatable :: work2dn(:,:,:) !GYL
2234  real(rp), allocatable :: work3dg(:,:,:,:)
2235  real(rp), allocatable :: work2dg(:,:,:)
2236 
2237  real(rp), allocatable :: hdxf(:,:)
2238  real(rp), allocatable :: rdiag(:)
2239  real(rp), allocatable :: rloc(:)
2240  real(rp), allocatable :: dep(:)
2241  real(rp), allocatable :: depd(:) !GYL
2242 
2243  integer :: ctype_merge(nid_obs,nobtype)
2244 
2245  integer :: var_local_n2nc_max
2246  integer :: var_local_n2nc(nv3d+nv2d)
2247  integer :: var_local_n2n(nv3d+nv2d)
2248  logical :: var_local_n2n_found
2249  integer :: n2n, n2nc
2250 
2251  real(rp) :: parm
2252  real(rp), allocatable :: trans(:,:,:)
2253  real(rp), allocatable :: transm(:,:)
2254  real(rp), allocatable :: transmd(:,:)
2255  real(rp), allocatable :: pa(:,:,:)
2256  real(rp) :: transrlx(nmem,nmem)
2257  logical :: trans_done(nv3d+nv2d)
2258 
2259  integer :: ij,ilev,n,m,i,j,k,nobsl
2260  integer :: nobsl_t(nid_obs,nobtype) !GYL
2261  real(rp) :: cutd_t(nid_obs,nobtype) !GYL
2262  real(rp) :: beta !GYL
2263  real(rp) :: tmpinfl !GYL
2264  real(rp) :: q_mean,q_sprd !GYL
2265  real(rp) :: q_anal(nmem) !GYL
2266 
2267  integer :: mshuf,ierr !GYL
2268  integer :: ishuf(nmem) !GYL
2269  real(rp), allocatable :: addinfl_weight(:) !GYL
2270  real(rp) :: rdx,rdy,rdxy,ref_min_dist !GYL
2271  integer :: ic,ic2,iob !GYL
2272 
2273  integer, allocatable :: search_q0(:,:,:)
2274 
2275  log_progress(*) 'data-assimilation / LETKF / system'
2276 
2277  ! -- prepare the first-guess data
2278  do j = 1, nlat
2279  do i = 1, nlon
2280  do k = 1, nlev
2281  v3dg(k,i,j,iv3d_u ) = u(k,i,j)
2282  v3dg(k,i,j,iv3d_v ) = v(k,i,j)
2283  v3dg(k,i,j,iv3d_w ) = w(k,i,j)
2284  v3dg(k,i,j,iv3d_t ) = temp(k,i,j)
2285  v3dg(k,i,j,iv3d_p ) = pres(k,i,j)
2286  v3dg(k,i,j,iv3d_q ) = qv(k,i,j)
2287  v3dg(k,i,j,iv3d_qc) = qc(k,i,j)
2288  v3dg(k,i,j,iv3d_qr) = qr(k,i,j)
2289  v3dg(k,i,j,iv3d_qi) = qi(k,i,j)
2290  v3dg(k,i,j,iv3d_qs) = qs(k,i,j)
2291  v3dg(k,i,j,iv3d_qg) = qg(k,i,j)
2292  end do
2293  end do
2294  end do
2295  do j = 1, nlat
2296  do i = 1, nlon
2297  v2dg(i,j,:) = undef ! tentative
2298  end do
2299  end do
2300 
2301  if( letkf_debug_log ) then
2302  call monit_obs_mpi( obs_in_num, obs_in_format, v3dg, v2dg, monit_step=1 )
2303  endif
2304 
2305  call scatter_grd_mpi_all2all( 1, nens, v3dg, v2dg, gues3d(:,:,1:nens,:), gues2d(:,1:nens,:) )
2306 
2307  ! -- obtain the ensemble mean
2308  do n = 1, nv3d
2309  do k = 1, nlev
2310  do ij = 1, nij1
2311  gues3d(ij,k,mmean,n) = average( nmem, gues3d(ij,k,1:nmem,n), undef )
2312  end do
2313  end do
2314  end do
2315  do n = 1, nv2d
2316  do ij = 1, nij1
2317  gues2d(ij,mmean,n) = average( nmem, gues2d(ij,1:nmem,n), undef )
2318  end do
2319  end do
2320 
2321  !
2322  ! Variable localization
2323  !
2324  var_local(:,1) = var_local_uv(:)
2325  var_local(:,2) = var_local_t(:)
2326  var_local(:,3) = var_local_q(:)
2327  var_local(:,4) = var_local_ps(:)
2328  var_local(:,5) = var_local_rain(:)
2329  var_local(:,6) = var_local_tc(:)
2330  var_local(:,7) = var_local_radar_ref(:)
2331  var_local(:,8) = var_local_radar_vr(:)
2332 
2333  var_local_n2nc_max = 1
2334  var_local_n2nc(1) = 1
2335  var_local_n2n(1) = 1
2336 
2337  do n = 2, nv3d+nv2d
2338  var_local_n2n_found = .false.
2339  do i = 1, var_local_n2nc_max
2340  !if (maxval(abs(var_local(var_local_n2nc(i),:) - var_local(n,:))) < tiny(var_local(1,1))) then
2341  if (all(var_local(var_local_n2nc(i),:) == var_local(n,:))) then
2342  var_local_n2nc(n) = var_local_n2nc(i)
2343  var_local_n2n(n) = var_local_n2n(var_local_n2nc(n))
2344  var_local_n2n_found = .true.
2345  exit
2346  end if
2347  end do
2348  if( .NOT. var_local_n2n_found ) then
2349  var_local_n2nc_max = var_local_n2nc_max + 1
2350  var_local_n2nc(n) = var_local_n2nc_max
2351  var_local_n2n(n) = n
2352  end if
2353  end do
2354 
2355  !
2356  ! Observation number limit (*to be moved to namelist*)
2357  !
2358  ctype_merge(:,:) = 0
2359  ctype_merge(uid_obs(id_radar_ref_obs),22) = 1
2360  ctype_merge(uid_obs(id_radar_ref_zero_obs),22) = 1
2361 
2362  allocate (n_merge(nctype))
2363  allocate (ic_merge(nid_obs*nobtype,nctype))
2364  n_merge(:) = 1
2365  do ic = 1, nctype
2366  if (n_merge(ic) > 0) then
2367  ic_merge(1,ic) = ic
2368  if (ctype_merge(elm_u_ctype(ic),typ_ctype(ic)) > 0) then
2369  do ic2 = ic+1, nctype
2370  if (ctype_merge(elm_u_ctype(ic2),typ_ctype(ic2)) == ctype_merge(elm_u_ctype(ic),typ_ctype(ic))) then
2371  n_merge(ic) = n_merge(ic) + 1
2372  ic_merge(n_merge(ic),ic) = ic2
2373  n_merge(ic2) = 0
2374  end if
2375  end do
2376  end if
2377  end if
2378  end do
2379  n_merge_max = maxval(n_merge)
2380 
2381  allocate (search_q0(nctype,nv3d+1,nij1))
2382  search_q0(:,:,:) = 1
2383 
2384  radar_only = .true.
2385  do ic = 1, nctype
2386  if (obtypelist(typ_ctype(ic)) /= 'PHARAD') then
2387  radar_only = .false.
2388  exit
2389  end if
2390  end do
2391  !
2392  ! FCST PERTURBATIONS
2393  !
2394  ! .... this has been done by write_ensmean in letkf.f90
2395  ! CALL ensmean_grd(nens,nij1,gues3d,gues2d,mean3d,mean2d)
2396  DO n=1,nv3d
2397  DO m=1,nmem
2398  DO k=1,nlev
2399  DO i=1,nij1
2400  gues3d(i,k,m,n) = gues3d(i,k,m,n) - gues3d(i,k,mmean,n)
2401  END DO
2402  END DO
2403  END DO
2404  END DO
2405  DO n=1,nv2d
2406  DO m=1,nmem
2407  DO i=1,nij1
2408  gues2d(i,m,n) = gues2d(i,m,n) - gues2d(i,mmean,n)
2409  END DO
2410  END DO
2411  END DO
2412 
2413  !
2414  ! multiplicative inflation
2415  !
2416  IF(infl_mul > 0.0d0) THEN ! fixed multiplicative inflation parameter
2417  work3d = infl_mul
2418  work2d = infl_mul
2419  ELSE ! 3D parameter values are read-in
2420  log_error("LETKF_system",*) 'This system has not been implemented yet. INFL_MUL must be greather than 0.0.'
2421  call prc_abort
2422  ! not used now (TODO)
2423  ! allocate (work3dg(nlon,nlat,nlev,nv3d))
2424  ! allocate (work2dg(nlon,nlat,nv2d))
2425  ! IF(myrank_e == mmean_rank_e) THEN
2426  ! call read_restart(INFL_MUL_IN_BASENAME,work3dg,work2dg)
2427  ! END IF
2428  !
2429  ! CALL scatter_grd_mpi(mmean_rank_e,work3dg,work2dg,work3d,work2d)
2430  !
2431  END IF
2432  IF(infl_mul_min > 0.0d0) THEN
2433  work3d = max(work3d, infl_mul_min)
2434  work2d = max(work2d, infl_mul_min)
2435  END IF
2436 
2437  ! This loop cannot use OpenMP on FUGAKU (T. Honda, as of 10/16/2020)
2438  allocate( hdxf( nobstotal, nmem ) )
2439  allocate (rdiag(nobstotal))
2440  allocate (rloc(nobstotal))
2441  allocate (dep(nobstotal))
2442  if( ens_with_mdet ) then
2443  allocate (depd(nobstotal))
2444  end if
2445  allocate (trans(nmem,nmem,var_local_n2nc_max))
2446  allocate (transm(nmem, var_local_n2nc_max))
2447  allocate (transmd(nmem, var_local_n2nc_max))
2448  allocate (pa(nmem,nmem,var_local_n2nc_max))
2449 
2450  !
2451  ! MAIN ASSIMILATION LOOP
2452  !
2453  DO ilev=1,nlev
2454  DO ij=1,nij1
2455 
2456  trans_done(:) = .false. !GYL
2457 
2458  ! weight parameter based on grid locations (not for covariance inflation purpose)
2459  ! if the weight is zero, no analysis update is needed
2460  call relax_beta(rig1(ij),rjg1(ij),hgt1(ij,ilev),beta)
2461 
2462  if (beta == 0.0d0) then
2463  do n = 1, nv3d
2464  do m = 1, nmem
2465  anal3d(ij,ilev,m,n) = gues3d(ij,ilev,mmean,n) + gues3d(ij,ilev,m,n)
2466  end do
2467  if (ens_with_mdet) then
2468  anal3d(ij,ilev,mmdet,n) = gues3d(ij,ilev,mmdet,n)
2469  end if
2470  end do
2471  if (ilev == 1) then
2472  do n = 1, nv2d
2473  do m = 1, nmem
2474  anal2d(ij,m,n) = gues2d(ij,mmean,n) + gues2d(ij,m,n)
2475  end do
2476  if (ens_with_mdet) then
2477  anal2d(ij,mmdet,n) = gues2d(ij,mmdet,n)
2478  end if
2479  end do
2480  end if
2481 
2482  cycle
2483  end if
2484 
2485  ! update 3D variables
2486  DO n=1,nv3d
2487 
2488  n2nc = var_local_n2nc(n)
2489  n2n = var_local_n2n(n)
2490 
2491  if (gues3d(ij,ilev,mmean,iv3d_p) < q_update_top .and. n >= iv3d_q .and. n <= iv3d_qg) then !GYL - Upper bound of Q update levels
2492  do m = 1, nmem !GYL
2493  anal3d(ij,ilev,m,n) = gues3d(ij,ilev,mmean,n) + gues3d(ij,ilev,m,n) !GYL
2494  end do !GYL
2495  if (ens_with_mdet) then !GYL
2496  anal3d(ij,ilev,mmdet,n) = gues3d(ij,ilev,mmdet,n) !GYL
2497  end if !GYL
2498 
2499  cycle !GYL
2500  end if !GYL
2501 
2502  if (relax_to_inflated_prior) then
2503  parm = work3d(ij,ilev,n)
2504  else
2505  parm = 1.0d0
2506  end if
2507 
2508  ! calculate mean and perturbation weights
2509  if (trans_done(n2nc)) then
2510  ! if weights already computed for other variables can be re-used(no variable localization), do not need to compute again
2511  if (infl_mul_adaptive) then
2512  work3d(ij,ilev,n) = work3d(ij,ilev,n2n)
2513  end if
2514  if (nobs_out) then
2515  work3dn(:,ij,ilev,n) = work3dn(:,ij,ilev,n2n)
2516  end if
2517 
2518  ELSE
2519  ! compute weights with localized observations
2520  if (ens_with_mdet) then !GYL
2521  CALL obs_local(obs(:),rig1(ij),rjg1(ij),gues3d(ij,ilev,mmean,iv3d_p),hgt1(ij,ilev),n,& !GYL
2522  hdxf,rdiag,rloc,dep,nobsl,depd=depd,nobsl_t=nobsl_t,cutd_t=cutd_t,srch_q0=search_q0(:,n,ij)) !GYL
2523  else !GYL
2524  CALL obs_local(obs(:),rig1(ij),rjg1(ij),gues3d(ij,ilev,mmean,iv3d_p),hgt1(ij,ilev),n,& !GYL
2525  hdxf,rdiag,rloc,dep,nobsl,nobsl_t=nobsl_t,cutd_t=cutd_t,srch_q0=search_q0(:,n,ij)) !GYL
2526  end if !GYL
2527  IF(relax_alpha_spread /= 0.0d0) THEN !GYL
2528  if (ens_with_mdet) then !GYL
2529  CALL letkf_core(nmem,nobstotal,nobsl,hdxf,rdiag,rloc,dep,work3d(ij,ilev,n), & !GYL
2530  trans(:,:,n2nc),transm=transm(:,n2nc),pao=pa(:,:,n2nc), & !GYL
2531  rdiag_wloc=.true.,infl_update=infl_mul_adaptive, & !GYL
2532  depd=depd,transmd=transmd(:,n2nc)) !GYL
2533  else !GYL
2534  CALL letkf_core(nmem,nobstotal,nobsl,hdxf,rdiag,rloc,dep,work3d(ij,ilev,n), & !GYL
2535  trans(:,:,n2nc),transm=transm(:,n2nc),pao=pa(:,:,n2nc), & !GYL
2536  rdiag_wloc=.true.,infl_update=infl_mul_adaptive) !GYL
2537  end if !GYL
2538  ELSE !GYL
2539  if (ens_with_mdet) then !GYL
2540  CALL letkf_core(nmem,nobstotal,nobsl,hdxf,rdiag,rloc,dep,work3d(ij,ilev,n), & !GYL
2541  trans(:,:,n2nc),transm=transm(:,n2nc), & !GYL
2542  rdiag_wloc=.true.,infl_update=infl_mul_adaptive, & !GYL
2543  depd=depd,transmd=transmd(:,n2nc)) !GYL
2544  else !GYL
2545  CALL letkf_core(nmem,nobstotal,nobsl,hdxf,rdiag,rloc,dep,work3d(ij,ilev,n), & !GYL
2546  trans(:,:,n2nc),transm=transm(:,n2nc), & !GYL
2547  rdiag_wloc=.true.,infl_update=infl_mul_adaptive) !GYL
2548  end if !GYL
2549  END IF !GYL
2550  trans_done(n2nc) = .true. !GYL
2551  IF(nobs_out) THEN !GYL
2552  work3dn(:,ij,ilev,n) = real(sum(nobsl_t, dim=1),rp) !GYL !!! NOBS: sum over all variables for each report type
2553  work3dn(nobtype+1,ij,ilev,n) = real(nobsl_t(9,22),rp) !GYL !!! NOBS: ref
2554  work3dn(nobtype+2,ij,ilev,n) = real(nobsl_t(10,22),rp) !GYL !!! NOBS: re0
2555  work3dn(nobtype+3,ij,ilev,n) = real(nobsl_t(11,22),rp) !GYL !!! NOBS: vr
2556  work3dn(nobtype+4,ij,ilev,n) = real(cutd_t(9,22),rp) !GYL !!! CUTOFF_DIST: ref
2557  work3dn(nobtype+5,ij,ilev,n) = real(cutd_t(10,22),rp) !GYL !!! CUTOFF_DIST: re0
2558  work3dn(nobtype+6,ij,ilev,n) = real(cutd_t(11,22),rp) !GYL !!! CUTOFF_DIST: vr
2559  END IF !GYL
2560 
2561  END IF
2562 
2563  ! relaxation via LETKF weight
2564  IF(relax_alpha /= 0.0d0) THEN !GYL - RTPP method (Zhang et al. 2004)
2565  CALL weight_rtpp(trans(:,:,n2nc),parm,transrlx) !GYL
2566  ELSE IF(relax_alpha_spread /= 0.0d0) THEN !GYL - RTPS method (Whitaker and Hamill 2012)
2567  IF(relax_spread_out) THEN !GYL
2568  CALL weight_rtps(trans(:,:,n2nc),pa(:,:,n2nc),gues3d(ij,ilev,:,n), & !GYL
2569  parm,transrlx,work3da(ij,ilev,n)) !GYL
2570  ELSE !GYL
2571  CALL weight_rtps(trans(:,:,n2nc),pa(:,:,n2nc),gues3d(ij,ilev,:,n), & !GYL
2572  parm,transrlx,tmpinfl) !GYL
2573  END IF !GYL
2574  ELSE !GYL
2575  transrlx = trans(:,:,n2nc) !GYL - No relaxation
2576  END IF !GYL
2577 
2578  ! total weight matrix
2579  do m = 1, nmem
2580  do k = 1, nmem
2581  transrlx(k,m) = (transrlx(k,m) + transm(k,n2nc)) * beta
2582  end do
2583  transrlx(m,m) = transrlx(m,m) + (1.0_rp-beta)
2584  end do
2585  ! analysis update of members
2586  do m = 1, nmem
2587  anal3d(ij,ilev,m,n) = gues3d(ij,ilev,mmean,n)
2588  do k = 1, nmem
2589  anal3d(ij,ilev,m,n) = anal3d(ij,ilev,m,n) + gues3d(ij,ilev,k,n) * transrlx(k,m)
2590  end do
2591  end do
2592 
2593  if( ens_with_mdet ) then
2594  ! analysis update of deterministic run
2595  anal3d(ij,ilev,mmdet,n) = 0.0_rp
2596  do k = 1, nmem
2597  anal3d(ij,ilev,mmdet,n) = anal3d(ij,ilev,mmdet,n) + gues3d(ij,ilev,k,n) * transmd(k,n2nc)
2598  end do
2599  anal3d(ij,ilev,mmdet,n) = gues3d(ij,ilev,mmdet,n) + anal3d(ij,ilev,mmdet,n) * beta
2600  end if
2601 
2602  ! limit q spread
2603  IF(q_sprd_max > 0.0d0 .and. n == iv3d_q) THEN !GYL
2604  q_mean = sum(anal3d(ij,ilev,1:nmem,n)) / real(nmem,rp) !GYL
2605  q_sprd = 0.0d0 !GYL
2606  DO m=1,nmem !GYL
2607  q_anal(m) = anal3d(ij,ilev,m,n) - q_mean !GYL
2608  q_sprd = q_sprd + q_anal(m)**2 !GYL
2609  END DO !GYL
2610 
2611  if ( q_mean > 0.0_rp ) then
2612  q_sprd = sqrt(q_sprd / real(nmem-1,rp)) / q_mean !GYL
2613  IF(q_sprd > q_sprd_max) THEN !GYL
2614  DO m=1,nmem !GYL
2615  anal3d(ij,ilev,m,n) = q_mean + q_anal(m) * q_sprd_max / q_sprd !GYL
2616  END DO !GYL
2617  END IF !GYL
2618  endif
2619  END IF !GYL
2620 
2621  END DO ! [ n=1,nv3d ]
2622 
2623  ! update 2D variables at ilev = 1
2624  IF(ilev == 1) THEN
2625 
2626  DO n=1,nv2d
2627 
2628  n2nc = var_local_n2nc(nv3d+n)
2629  n2n = var_local_n2n(nv3d+n)
2630 
2631  if (relax_to_inflated_prior) then
2632  parm = work2d(ij,n)
2633  else
2634  parm = 1.0d0
2635  end if
2636 
2637  ! calculate mean and perturbation weights
2638  if (trans_done(n2nc)) then
2639  ! if weights already computed for other variables can be re-used(no variable localization), do not need to compute again
2640  IF(n2n <= nv3d) then
2641  if (infl_mul_adaptive) then
2642  work2d(ij,n) = work3d(ij,ilev,n2n)
2643  end if
2644  if (nobs_out) then
2645  work2dn(:,ij,n) = work3dn(:,ij,ilev,n2n)
2646  end if
2647  else
2648  if (infl_mul_adaptive) then
2649  work2d(ij,n) = work2d(ij,n2n-nv3d)
2650  end if
2651  if (nobs_out) then
2652  work2dn(:,ij,n) = work2dn(:,ij,n2n-nv3d)
2653  end if
2654  end if
2655 
2656  ELSE
2657  ! compute weights with localized observations
2658  if (ens_with_mdet) then !GYL
2659  CALL obs_local(obs(:),rig1(ij),rjg1(ij),gues3d(ij,ilev,mmean,iv3d_p),hgt1(ij,ilev),nv3d+n,hdxf,rdiag,rloc,dep,nobsl,depd=depd,nobsl_t=nobsl_t,cutd_t=cutd_t,srch_q0=search_q0(:,nv3d+1,ij))
2660  else !GYL
2661  CALL obs_local(obs(:),rig1(ij),rjg1(ij),gues3d(ij,ilev,mmean,iv3d_p),hgt1(ij,ilev),nv3d+n,hdxf,rdiag,rloc,dep,nobsl,nobsl_t=nobsl_t,cutd_t=cutd_t,srch_q0=search_q0(:,nv3d+1,ij))
2662  end if !GYL
2663  IF(relax_alpha_spread /= 0.0d0) THEN !GYL
2664  if (ens_with_mdet) then !GYL
2665  CALL letkf_core(nmem,nobstotal,nobsl,hdxf,rdiag,rloc,dep,work2d(ij,n), & !GYL
2666  trans(:,:,n2nc),transm=transm(:,n2nc),pao=pa(:,:,n2nc), & !GYL
2667  rdiag_wloc=.true.,infl_update=infl_mul_adaptive, & !GYL
2668  depd=depd,transmd=transmd(:,n2nc)) !GYL
2669  else !GYL
2670  CALL letkf_core(nmem,nobstotal,nobsl,hdxf,rdiag,rloc,dep,work2d(ij,n), & !GYL
2671  trans(:,:,n2nc),transm=transm(:,n2nc),pao=pa(:,:,n2nc), & !GYL
2672  rdiag_wloc=.true.,infl_update=infl_mul_adaptive) !GYL
2673  end if !GYL
2674  ELSE !GYL
2675  if (ens_with_mdet) then !GYL
2676  CALL letkf_core(nmem,nobstotal,nobsl,hdxf,rdiag,rloc,dep,work2d(ij,n), & !GYL
2677  trans(:,:,n2nc),transm=transm(:,n2nc), & !GYL
2678  rdiag_wloc=.true.,infl_update=infl_mul_adaptive, & !GYL
2679  depd=depd,transmd=transmd(:,n2nc)) !GYL
2680  else !GYL
2681  CALL letkf_core(nmem,nobstotal,nobsl,hdxf,rdiag,rloc,dep,work2d(ij,n), & !GYL
2682  trans(:,:,n2nc),transm=transm(:,n2nc), & !GYL
2683  rdiag_wloc=.true.,infl_update=infl_mul_adaptive) !GYL
2684  end if !GYL
2685  END IF !GYL
2686  trans_done(n2nc) = .true. !GYL
2687  IF(nobs_out) THEN !GYL
2688  work2dn(:,ij,n) = real(sum(nobsl_t,dim=1),rp) !GYL !!! NOBS: sum over all variables for each report type
2689  END IF !GYL
2690 
2691  END IF
2692 
2693  ! relaxation via LETKF weight
2694  IF(relax_alpha /= 0.0d0) THEN !GYL - RTPP method (Zhang et al. 2004)
2695  CALL weight_rtpp(trans(:,:,n2nc),parm,transrlx) !GYL
2696  ELSE IF(relax_alpha_spread /= 0.0d0) THEN !GYL - RTPS method (Whitaker and Hamill 2012)
2697  IF(relax_spread_out) THEN !GYL
2698  CALL weight_rtps(trans(:,:,n2nc),pa(:,:,n2nc),gues2d(ij,:,n), & !GYL
2699  parm,transrlx,work2da(ij,n)) !GYL
2700  ELSE !GYL
2701  CALL weight_rtps(trans(:,:,n2nc),pa(:,:,n2nc),gues2d(ij,:,n), & !GYL
2702  parm,transrlx,tmpinfl) !GYL
2703  END IF !GYL
2704  ELSE !GYL
2705  transrlx = trans(:,:,n2nc) !GYL - No relaxation
2706  END IF !GYL
2707 
2708  ! total weight matrix
2709  do m = 1, nmem
2710  do k = 1, nmem
2711  transrlx(k,m) = (transrlx(k,m) + transm(k,n2nc)) * beta
2712  end do
2713  transrlx(m,m) = transrlx(m,m) + (1.0_rp-beta)
2714  end do
2715 
2716  ! analysis update of members
2717  do m = 1, nmem
2718  anal2d(ij,m,n) = gues2d(ij,mmean,n)
2719  do k = 1, nmem
2720  anal2d(ij,m,n) = anal2d(ij,m,n) + gues2d(ij,k,n) * transrlx(k,m)
2721  end do
2722  end do
2723 
2724  ! analysis update of deterministic run
2725  if (ens_with_mdet) then
2726  anal2d(ij,mmdet,n) = 0.0_rp
2727  do k = 1, nmem
2728  anal2d(ij,mmdet,n) = anal2d(ij,mmdet,n) + gues2d(ij,k,n) * transmd(k,n2nc)
2729  end do
2730  anal2d(ij,mmdet,n) = gues2d(ij,mmdet,n) + anal2d(ij,mmdet,n) * beta
2731  end if
2732 
2733  END DO
2734  END IF
2735  END DO
2736  END DO ! [ ilev=1,nlev ]
2737 
2738  deallocate (hdxf,rdiag,rloc,dep)
2739  if (ens_with_mdet) then
2740  deallocate (depd)
2741  end if
2742  deallocate (trans,transm,transmd,pa)
2743 
2744  deallocate (n_merge,ic_merge)
2745  deallocate (search_q0)
2746 
2747  IF (allocated(work3dg)) deallocate (work3dg)
2748  IF (allocated(work2dg)) deallocate (work2dg)
2749 
2750  !
2751  ! Additive inflation
2752  !
2753  IF(infl_add > 0.0d0) THEN
2754 
2755  if (infl_add_q_ratio) then
2756  work3d(:,:,:) = gues3d(:,:,mmean,:)
2757  else
2758  work3d(:,:,:) = 1.0d0
2759  end if
2760 
2761  allocate (addinfl_weight(nij1))
2762  if (infl_add_ref_only) then
2763  addinfl_weight(:) = 0.0d0
2764  ic = ctype_elmtyp(uid_obs(id_radar_ref_obs), 22)
2765  if (ic > 0) then
2766  do ij = 1, nij1
2767  ref_min_dist = 1.0d33
2768  !!!!!! save this (ref_min_dist) information when doing DA
2769  do iob = obsgrd(ic)%ac_ext(0, 1) + 1, obsgrd(ic)%ac_ext(obsgrd(ic)%ngrdext_i, obsgrd(ic)%ngrdext_j)
2770  rdx = (rig1(ij) - obs(obsda_sort%set(iob))%ri(obsda_sort%idx(iob))) * dx
2771  rdy = (rjg1(ij) - obs(obsda_sort%set(iob))%rj(obsda_sort%idx(iob))) * dy
2772  rdxy = rdx*rdx + rdy*rdy
2773  if (rdxy < ref_min_dist) then
2774  ref_min_dist = rdxy
2775  end if
2776  end do
2777 
2778  ref_min_dist = ref_min_dist / (hori_loc_ctype(ic) * hori_loc_ctype(ic))
2779  if (ref_min_dist <= dist_zero_fac_square) then
2780  addinfl_weight(ij) = exp(-0.5d0 * ref_min_dist)
2781  end if
2782  end do
2783  end if
2784  else
2785  addinfl_weight(:) = 1.0d0
2786  end if
2787 
2788  log_info("LETKF_system",*) 'Additive covariance inflation, parameter:', infl_add
2789  if (infl_add_shuffle) then
2790  if (rank_ens== 0) then
2791  call knuth_shuffle(nens, ishuf)
2792  end if
2793  call mpi_bcast(ishuf, nens, mpi_integer, 0, comm_ens, ierr)
2794  log_info("LETKF_system",*) 'shuffle members: on'
2795  log_info("LETKF_system",*) 'shuffle sequence:', ishuf
2796  end if
2797 
2798  DO n=1,nv3d
2799  DO m=1,nens
2800  if (infl_add_shuffle) then
2801  mshuf = ishuf(m)
2802  else
2803  mshuf = m
2804  end if
2805  if (n == iv3d_q .or. n == iv3d_qc .or. n == iv3d_qr .or. n == iv3d_qi .or. n == iv3d_qs .or. n == iv3d_qg) then
2806  DO k=1,nlev
2807  DO i=1,nij1
2808  anal3d(i,k,m,n) = anal3d(i,k,m,n) &
2809  & + addi3d(i,k,mshuf,n) * infl_add * addinfl_weight(i) * work3d(i,k,n)
2810  END DO
2811  END DO
2812  else
2813  DO k=1,nlev
2814  DO i=1,nij1
2815  anal3d(i,k,m,n) = anal3d(i,k,m,n) &
2816  & + addi3d(i,k,mshuf,n) * infl_add * addinfl_weight(i)
2817  END DO
2818  END DO
2819  end if
2820  END DO
2821  END DO
2822  DO n=1,nv2d
2823  DO m=1,nens
2824  if (infl_add_shuffle) then
2825  mshuf = ishuf(m)
2826  else
2827  mshuf = m
2828  end if
2829  DO i=1,nij1
2830  anal2d(i,m,n) = anal2d(i,m,n) + addi2d(i,mshuf,n) * infl_add * addinfl_weight(i)
2831  END DO
2832  END DO
2833  END DO
2834 
2835  deallocate (addinfl_weight)
2836 
2837  END IF
2838 
2839  ! -- prepare the output values
2840  call gather_grd_mpi_all2all( 1, nens, anal3d(:,:,1:nens,:), anal2d(:,1:nens,:), v3dg, v2dg )
2841 
2842  do j = 1, nlat
2843  do i = 1, nlon
2844  do k = 1, nlev
2845  u(k,i,j) = v3dg(k,i,j,iv3d_u )
2846  v(k,i,j) = v3dg(k,i,j,iv3d_v )
2847  w(k,i,j) = v3dg(k,i,j,iv3d_w )
2848  temp(k,i,j) = v3dg(k,i,j,iv3d_t )
2849  pres(k,i,j) = v3dg(k,i,j,iv3d_p )
2850  qv(k,i,j) = v3dg(k,i,j,iv3d_q )
2851  qc(k,i,j) = v3dg(k,i,j,iv3d_qc)
2852  qr(k,i,j) = v3dg(k,i,j,iv3d_qr)
2853  qi(k,i,j) = v3dg(k,i,j,iv3d_qi)
2854  qs(k,i,j) = v3dg(k,i,j,iv3d_qs)
2855  qg(k,i,j) = v3dg(k,i,j,iv3d_qg)
2856  end do
2857  end do
2858  end do
2859 
2860  if( letkf_debug_log ) then
2861  call monit_obs_mpi( obs_in_num, obs_in_format, v3dg, v2dg, monit_step=2 )
2862  endif
2863 
2864  return
2865  end subroutine letkf_system
2866 
2867  !-----------------------------------------------------------------------
2868  ! Data Assimilation (Parameter estmation for global constant parameters)
2869  !-----------------------------------------------------------------------
2870  subroutine letkf_param_estimation_system( &
2871  PEST_PMAX, &
2872  PEST_VAR0 )
2873  use scale_const, only: &
2874  undef => const_undef
2875  use scale_statistics, only: &
2876  average => statistics_average
2877  implicit none
2878 
2879  integer, intent(in) :: pest_pmax
2880 
2881  real(rp), intent(inout) :: pest_var0(nens,pest_pmax)
2882 
2883  real(rp) :: gues0d(nens+1,pest_pmax)
2884  real(rp) :: anal0d(nens+1,pest_pmax)
2885 
2886  real(rp) :: work0d(pest_pmax)
2887 
2888  real(rp),allocatable :: hdxf(:,:)
2889  real(rp),allocatable :: rdiag(:)
2890  real(rp),allocatable :: rloc(:)
2891  real(rp),allocatable :: dep(:)
2892  real(rp),allocatable :: depd(:) !gyl
2893 
2894  real(rp) :: parm
2895  real(rp),allocatable :: trans(:,:)
2896  real(rp),allocatable :: transm(:)
2897  real(rp),allocatable :: transmd(:)
2898  real(rp),allocatable :: pa(:,:)
2899  real(rp) :: transrlx(nmem,nmem)
2900 
2901  integer :: n,m,k,nobsl
2902  real(rp) :: beta !gyl
2903  real(rp) :: tmpinfl !gyl
2904  integer :: ierr
2905 
2906  log_progress(*) 'data-assimilation / LETKF / parameter estimation'
2907 
2908  ! -- prepare the first-guess data
2909  do n = 1, pest_pmax
2910  do m = 1, nens
2911  gues0d(m,n) = pest_var0(m,n)
2912  end do
2913  end do
2914 
2915  ! -- obtain the ensemble mean
2916  do n = 1, pest_pmax
2917  gues0d(mmean,n) = average( nmem, gues0d(1:nmem,n), undef )
2918  end do
2919 
2920  !
2921  ! No variable localization
2922  !
2923 
2924  !
2925  ! FCST PERTURBATIONS
2926  !
2927 
2928  do n = 1, pest_pmax
2929  do m = 1, nmem
2930  gues0d(m,n) = gues0d(m,n) - gues0d(mmean,n)
2931  end do
2932  end do
2933 
2934  allocate (hdxf(nobstotal,nmem))
2935  allocate (rdiag(nobstotal))
2936  allocate (rloc(nobstotal))
2937  allocate (dep(nobstotal))
2938  if (ens_with_mdet) then
2939  allocate (depd(nobstotal))
2940  allocate (transmd(nmem))
2941  end if
2942  allocate (trans(nmem,nmem))
2943  allocate (transm(nmem))
2944  allocate (pa(nmem,nmem))
2945 
2946  !
2947  ! MAIN ASSIMILATION LOOP
2948  !
2949  parm = 1.0_rp
2950  beta = 1.0_rp
2951 
2952  work0d = 1.0_rp
2953 
2954  DO n = 1, pest_pmax
2955  ! calculate mean and perturbation weights
2956  ! compute weights with localized observations
2957  if (ens_with_mdet) then
2958  CALL obs_pest_etkf(hdxf, rdiag, rloc, dep, nobsl, depd=depd)
2959  else
2960  CALL obs_pest_etkf(hdxf, rdiag, rloc, dep, nobsl)
2961  end if
2962 
2963  if (ens_with_mdet) then
2964  CALL letkf_core(nmem,nobstotal,nobsl,hdxf,rdiag,rloc,dep,work0d(n), &
2965  trans(:,:),transm=transm(:),pao=pa(:,:), &
2966  rdiag_wloc=.true.,&
2967  depd=depd,transmd=transmd(:))
2968  else
2969  CALL letkf_core(nmem,nobstotal,nobsl,hdxf,rdiag,rloc,dep,work0d(n), &
2970  trans(:,:),transm=transm(:),pao=pa(:,:), &
2971  rdiag_wloc=.true.)
2972  end if
2973 
2974  ! relaxation via LETKF weight
2975  CALL weight_rtps_const(trans(:,:),pa(:,:),gues0d(:,n),transrlx,tmpinfl)
2976 
2977  ! total weight matrix
2978  do m = 1, nmem
2979  do k = 1, nmem
2980  transrlx(k,m) = (transrlx(k,m) + transm(k)) * beta
2981  end do
2982  transrlx(m,m) = transrlx(m,m) + (1.0_rp-beta)
2983  end do
2984 
2985  ! analysis update of members
2986  do m = 1, nmem
2987  anal0d(m,n) = gues0d(mmean,n)
2988  do k = 1, nmem
2989  anal0d(m,n) = anal0d(m,n) + gues0d(k,n) * transrlx(k,m)
2990  end do
2991  end do
2992 
2993  ! analysis update of deterministic run
2994  if (ens_with_mdet) then
2995  anal0d(mmdet,n) = 0.0_rp
2996  do k = 1, nmem
2997  anal0d(mmdet,n) = anal0d(mmdet,n) + gues0d(k,n) * transmd(k)
2998  end do
2999  anal0d(mmdet,n) = gues0d(mmdet,n) + anal0d(mmdet,n) * beta
3000  end if
3001 
3002  enddo
3003 
3004  do n = 1, pest_pmax
3005  do m = 1, nens
3006  pest_var0(m,n) = anal0d(m,n)
3007  end do
3008  end do
3009 
3010  deallocate (hdxf,rdiag,rloc,dep)
3011  if (ens_with_mdet) then
3012  deallocate (depd,transmd)
3013  end if
3014  deallocate (trans,transm,pa)
3015 
3016  return
3017  end subroutine letkf_param_estimation_system
3018 
3019  !-----------------------------------------------------------------------
3020  ! Setup of additive inflation
3021  !-----------------------------------------------------------------------
3022  subroutine letkf_add_inflation_setup( &
3023  addi3d, &
3024  addi2d )
3025  implicit none
3026 
3027  real(rp), intent(out) :: addi3d(:,:,:,:)
3028  real(rp), intent(out) :: addi2d(:,:,:)
3029  integer :: i, k, m, n
3030 
3031  call read_ens_mpi_addiinfl(addi3d, addi2d)
3032 
3033  call ensmean_grd(nens, nens, nij1, addi3d, addi2d)
3034 
3035  do n = 1, nv3d
3036  do m = 1, nens
3037  do k = 1, nlev
3038  do i = 1, nij1
3039  addi3d(i,k,m,n) = addi3d(i,k,m,n) - addi3d(i,k,mmean,n)
3040  end do
3041  end do
3042  end do
3043  end do
3044 
3045  do n = 1, nv2d
3046  do m = 1, nens
3047  do i = 1, nij1
3048  addi2d(i,m,n) = addi2d(i,m,n) - addi2d(i,mmean,n)
3049  end do
3050  end do
3051  end do
3052 
3053  return
3054  end subroutine letkf_add_inflation_setup
3055 
3056  ! =======================================================================
3057  ! Main Subroutine of LETKF Core
3058  ! INPUT
3059  ! ne : ensemble size !GYL
3060  ! nobs : array size, but only first nobsl elements are used
3061  ! nobsl : total number of observation assimilated at the point
3062  ! hdxb(nobs,ne) : obs operator times fcst ens perturbations
3063  ! rdiag(nobs) : observation error variance
3064  ! rloc(nobs) : localization weighting function
3065  ! dep(nobs) : observation departure (yo-Hxb)
3066  ! parm_infl : covariance inflation parameter
3067  ! rdiag_wloc : (optional) flag indicating that rdiag = rdiag / rloc !GYL
3068  ! infl_update : (optional) flag to return updated inflation parameter !GYL
3069  ! depd(nobs) : observation departure (yo-Hxb) for deterministic run !GYL
3070  ! OUTPUT
3071  ! parm_infl : updated covariance inflation parameter
3072  ! trans(ne,ne) : transformation matrix
3073  ! transm(ne) : (optional) transformation matrix mean !GYL
3074  ! pao(ne,ne) : (optional) analysis covariance matrix in ensemble space !GYL
3075  ! transmd(ne) : (optional) transformation matrix mean for deterministic run !GYL
3076  ! =======================================================================
3077  !
3078  ! [PURPOSE:] Local Ensemble Transform Kalman Filtering (LETKF)
3079  ! Model Independent Core Module
3080  !
3081  ! [REFERENCES:]
3082  ! [1] Ott et al., 2004: A local ensemble Kalman filter for atmospheric
3083  ! data assimilation. Tellus, 56A, 415-428.
3084  ! [2] Hunt et al., 2007: Efficient Data Assimilation for Spatiotemporal
3085  ! Chaos: A Local Ensemble Transform Kalman Filter. Physica D, 230,
3086  ! 112-126.
3087  !
3088  ! [HISTORY:]
3089  ! 01/21/2009 Takemasa Miyoshi Created at U. of Maryland, College Park
3090  !
3091  ! =======================================================================
3092  subroutine letkf_core(ne,nobs,nobsl,hdxb,rdiag,rloc,dep,parm_infl,trans,transm,pao,rdiag_wloc,infl_update,depd,transmd)
3093  use scale_sort, only: &
3094  sort_quickselect_desc_arg, &
3095  sort_quickselect_arg
3096  use scale_matrix, only: &
3097  matrix_solver_eigenvalue_decomposition
3098  implicit none
3099  INTEGER,INTENT(IN) :: ne !GYL
3100  INTEGER,INTENT(IN) :: nobs
3101  INTEGER,INTENT(IN) :: nobsl
3102  REAL(rp),INTENT(IN) :: hdxb(1:nobs,1:ne)
3103  REAL(rp),INTENT(IN) :: rdiag(1:nobs)
3104  REAL(rp),INTENT(IN) :: rloc(1:nobs)
3105  REAL(rp),INTENT(IN) :: dep(1:nobs)
3106  REAL(rp),INTENT(INOUT) :: parm_infl
3107  REAL(rp),INTENT(OUT) :: trans(ne,ne)
3108  REAL(rp),INTENT(OUT),OPTIONAL :: transm(ne)
3109  REAL(rp),INTENT(OUT),OPTIONAL :: pao(ne,ne)
3110  LOGICAL,INTENT(IN),OPTIONAL :: rdiag_wloc !GYL
3111  LOGICAL,INTENT(IN),OPTIONAL :: infl_update !GYL
3112  REAL(rp),INTENT(IN),OPTIONAL :: depd(1:nobs) !GYL
3113  REAL(rp),INTENT(OUT),OPTIONAL :: transmd(ne) !GYL
3114 
3115  REAL(rp) :: hdxb_rinv(nobsl,ne)
3116  REAL(rp) :: eivec(ne,ne)
3117  REAL(rp) :: eival(ne)
3118  REAL(rp) :: pa(ne,ne)
3119  REAL(rp) :: work1(ne,ne)
3120  REAL(rp) :: work2(ne)
3121  REAL(rp) :: work2d(ne)
3122  REAL(rp) :: work3(ne)
3123  REAL(rp) :: rho
3124  REAL(rp) :: parm(4),sigma_o,gain
3125  REAL(rp),PARAMETER :: sigma_b = 0.04d0 !error stdev of parm_infl
3126  LOGICAL :: rdiag_wloc_
3127  LOGICAL :: infl_update_
3128  INTEGER :: i,j,k
3129 
3130  real(rp) :: work1_evp(ne,ne)
3131  real(rp) :: eivec_evp(ne,ne)
3132  real(rp) :: eival_evp(ne)
3133 
3134 #ifdef DA
3135  rdiag_wloc_ = .false. !GYL
3136  IF(present(rdiag_wloc)) rdiag_wloc_ = rdiag_wloc !GYL
3137  infl_update_ = .false. !GYL
3138  IF(present(infl_update)) infl_update_ = infl_update !GYL
3139 
3140  IF(nobsl == 0) THEN
3141  trans = 0.0
3142  DO i=1,ne
3143  trans(i,i) = sqrt(parm_infl)
3144  END DO
3145  IF (PRESENT(transm)) THEN
3146  transm = 0.0
3147  END IF
3148  IF (PRESENT(transmd)) THEN
3149  transmd = 0.0
3150  END IF
3151  IF (PRESENT(pao)) THEN
3152  pao = 0.0
3153  DO i=1,ne
3154  pao(i,i) = parm_infl / real(ne-1,kind=rp)
3155  END DO
3156  END IF
3157  RETURN
3158  END IF
3159  !-----------------------------------------------------------------------
3160  ! Rinv hdxb
3161  !-----------------------------------------------------------------------
3162  IF(rdiag_wloc_) THEN !GYL
3163  DO j=1,ne !GYL
3164  DO i=1,nobsl !GYL
3165  hdxb_rinv(i,j) = hdxb(i,j) / rdiag(i) !GYL
3166  END DO !GYL
3167  END DO !GYL
3168  ELSE !GYL
3169  DO j=1,ne
3170  DO i=1,nobsl
3171  hdxb_rinv(i,j) = hdxb(i,j) / rdiag(i) * rloc(i)
3172  END DO
3173  END DO
3174  END IF !GYL
3175 
3176  !-----------------------------------------------------------------------
3177  ! hdxb^T Rinv hdxb
3178  !-----------------------------------------------------------------------
3179  if( rp == sp ) then
3180  CALL sgemm('t','n',ne,ne,nobsl,1.0e0,hdxb_rinv,nobsl,hdxb(1:nobsl,:),nobsl,0.0e0,work1,ne)
3181  else
3182  CALL dgemm('t','n',ne,ne,nobsl,1.0d0,hdxb_rinv,nobsl,hdxb(1:nobsl,:),nobsl,0.0d0,work1,ne)
3183  end if
3184  ! DO j=1,ne
3185  ! DO i=1,ne
3186  ! work1(i,j) = hdxb_rinv(1,i) * hdxb(1,j)
3187  ! DO k=2,nobsl
3188  ! work1(i,j) = work1(i,j) + hdxb_rinv(k,i) * hdxb(k,j)
3189  ! END DO
3190  ! END DO
3191  ! END DO
3192  !-----------------------------------------------------------------------
3193  ! hdxb^T Rinv hdxb + (m-1) I / rho (covariance inflation)
3194  !-----------------------------------------------------------------------
3195  rho = 1.0d0 / parm_infl
3196  DO i=1,ne
3197  work1(i,i) = work1(i,i) + real(ne-1,kind=rp) * rho
3198  END DO
3199  !-----------------------------------------------------------------------
3200  ! eigenvalues and eigenvectors of [ hdxb^T Rinv hdxb + (m-1) I ]
3201  !-----------------------------------------------------------------------
3202  work1_evp = real( work1, kind=rp )
3203  call matrix_solver_eigenvalue_decomposition( ne, work1_evp, eival_evp, eivec_evp )
3204  eival = real( eival_evp, kind=rp )
3205  eivec = real( eivec_evp, kind=rp )
3206  !-----------------------------------------------------------------------
3207  ! Pa = [ hdxb^T Rinv hdxb + (m-1) I ]inv
3208  !-----------------------------------------------------------------------
3209  DO j=1,ne
3210  DO i=1,ne
3211  work1(i,j) = eivec(i,j) / eival(j)
3212  END DO
3213  END DO
3214  if( rp == sp ) then
3215  CALL sgemm('n','t',ne,ne,ne,1.0e0,work1,ne,eivec,ne,0.0e0,pa,ne)
3216  else
3217  CALL dgemm('n','t',ne,ne,ne,1.0d0,work1,ne,eivec,ne,0.0d0,pa,ne)
3218  end if
3219  ! DO j=1,ne
3220  ! DO i=1,ne
3221  ! pa(i,j) = work1(i,1) * eivec(j,1)
3222  ! DO k=2,ne
3223  ! pa(i,j) = pa(i,j) + work1(i,k) * eivec(j,k)
3224  ! END DO
3225  ! END DO
3226  ! END DO
3227  !-----------------------------------------------------------------------
3228  ! hdxb_rinv^T dep
3229  !-----------------------------------------------------------------------
3230  if( rp == sp ) then
3231  CALL sgemv('t',nobsl,ne,1.0e0,hdxb_rinv,nobsl,dep,1,0.0e0,work2,1)
3232  else
3233  CALL dgemv('t',nobsl,ne,1.0d0,hdxb_rinv,nobsl,dep,1,0.0d0,work2,1)
3234  end if
3235  ! DO i=1,ne
3236  ! work2(i) = hdxb_rinv(1,i) * dep(1)
3237  ! DO j=2,nobsl
3238  ! work2(i) = work2(i) + hdxb_rinv(j,i) * dep(j)
3239  ! END DO
3240  ! END DO
3241  IF (PRESENT(depd) .AND. PRESENT(transmd)) THEN
3242  if( rp == sp ) then
3243  CALL sgemv('t',nobsl,ne,1.0e0,hdxb_rinv,nobsl,depd,1,0.0e0,work2d,1)
3244  else
3245  CALL dgemv('t',nobsl,ne,1.0d0,hdxb_rinv,nobsl,depd,1,0.0d0,work2d,1)
3246  end if
3247  ! DO i=1,ne
3248  ! work2d(i) = hdxb_rinv(1,i) * depd(1)
3249  ! DO j=2,nobsl
3250  ! work2d(i) = work2d(i) + hdxb_rinv(j,i) * depd(j)
3251  ! END DO
3252  ! END DO
3253  END IF
3254  !-----------------------------------------------------------------------
3255  ! Pa hdxb_rinv^T dep
3256  !-----------------------------------------------------------------------
3257  if( rp == sp ) then
3258  CALL sgemv('n',ne,ne,1.0e0,pa,ne,work2,1,0.0e0,work3,1)
3259  else
3260  CALL dgemv('n',ne,ne,1.0d0,pa,ne,work2,1,0.0d0,work3,1)
3261  end if
3262  ! DO i=1,ne
3263  ! work3(i) = 0.0_RP
3264  ! end DO
3265  ! !$omp parallel do reduction(+:work3)
3266  ! DO j=1,ne
3267  ! DO i=1,ne
3268  ! work3(i) = work3(i) + pa(i,j) * work2(j)
3269  ! END DO
3270  ! END DO
3271  IF (PRESENT(depd) .AND. PRESENT(transmd)) THEN
3272  if( rp == sp ) then
3273  CALL sgemv('n',ne,ne,1.0e0,pa,ne,work2d,1,0.0e0,transmd,1)
3274  else
3275  CALL dgemv('n',ne,ne,1.0d0,pa,ne,work2d,1,0.0d0,transmd,1)
3276  end if
3277  ! DO i=1,ne
3278  ! transmd(i) = 0.0_RP
3279  ! end DO
3280  ! !$omp parallel do reduction(+:transmd)
3281  ! DO j=1,ne
3282  ! DO i=1,ne
3283  ! transmd(i) = transmd(i) + pa(i,j) * work2d(j)
3284  ! END DO
3285  ! END DO
3286  END IF
3287 
3288  !!$!-----------------------------------------------------------------------
3289  !!$! Pa hdxb_rinv^T
3290  !!$!-----------------------------------------------------------------------
3291  !!$#ifdef SINGLELETKF
3292  !!$ CALL sgemm('n','t',ne,nobsl,ne,1.0e0,pa,ne,hdxb_rinv,&
3293  !!$ & nobsl,0.0e0,work2,ne)
3294  !!$#else
3295  !!$ CALL dgemm('n','t',ne,nobsl,ne,1.0d0,pa,ne,hdxb_rinv,&
3296  !!$ & nobsl,0.0d0,work2,ne)
3297  !!$#endif
3298  !!$! DO j=1,nobsl
3299  !!$! DO i=1,ne
3300  !!$! work2(i,j) = pa(i,1) * hdxb_rinv(j,1)
3301  !!$! DO k=2,ne
3302  !!$! work2(i,j) = work2(i,j) + pa(i,k) * hdxb_rinv(j,k)
3303  !!$! END DO
3304  !!$! END DO
3305  !!$! END DO
3306  !!$!-----------------------------------------------------------------------
3307  !!$! Pa hdxb_rinv^T dep
3308  !!$!-----------------------------------------------------------------------
3309  !!$ DO i=1,ne
3310  !!$ work3(i) = work2(i,1) * dep(1)
3311  !!$ DO j=2,nobsl
3312  !!$ work3(i) = work3(i) + work2(i,j) * dep(j)
3313  !!$ END DO
3314  !!$ END DO
3315  !!$ IF (PRESENT(depd) .AND. PRESENT(transmd)) THEN !GYL
3316  !!$ DO i=1,ne !GYL
3317  !!$ transmd(i) = work2(i,1) * depd(1) !GYL
3318  !!$ DO j=2,nobsl !GYL
3319  !!$ transmd(i) = transmd(i) + work2(i,j) * depd(j) !GYL
3320  !!$ END DO !GYL
3321  !!$ END DO !GYL
3322  !!$ END IF !GYL
3323  !-----------------------------------------------------------------------
3324  ! T = sqrt[(m-1)Pa]
3325  !-----------------------------------------------------------------------
3326  DO j=1,ne
3327  rho = sqrt( real(ne-1,kind=rp) / eival(j) )
3328  DO i=1,ne
3329  work1(i,j) = eivec(i,j) * rho
3330  END DO
3331  END DO
3332  if( rp == sp ) then
3333  CALL sgemm('n','t',ne,ne,ne,1.0e0,work1,ne,eivec,ne,0.0e0,trans,ne)
3334  else
3335  CALL dgemm('n','t',ne,ne,ne,1.0d0,work1,ne,eivec,ne,0.0d0,trans,ne)
3336  end if
3337  ! DO j=1,ne
3338  ! DO i=1,ne
3339  ! trans(i,j) = work1(i,1) * eivec(j,1)
3340  ! DO k=2,ne
3341  ! trans(i,j) = trans(i,j) + work1(i,k) * eivec(j,k)
3342  ! END DO
3343  ! END DO
3344  ! END DO
3345  !-----------------------------------------------------------------------
3346  ! T + Pa hdxb_rinv^T dep
3347  !-----------------------------------------------------------------------
3348  IF (PRESENT(transm)) THEN !GYL - if transm is present,
3349  transm = work3 !GYL - return both trans and transm without adding them
3350  ELSE !GYL
3351  DO j=1,ne
3352  DO i=1,ne
3353  trans(i,j) = trans(i,j) + work3(i)
3354  END DO
3355  END DO
3356  END IF !GYL
3357  IF (PRESENT(pao)) pao = pa !GYL
3358 
3359  IF (.NOT. infl_update_) RETURN !GYL - skip the following if no inflation update is required
3360  !-----------------------------------------------------------------------
3361  ! Inflation estimation
3362  !-----------------------------------------------------------------------
3363  parm = 0.0d0
3364  IF(rdiag_wloc_) THEN !GYL
3365  DO i=1,nobsl !GYL
3366  parm(1) = parm(1) + dep(i)*dep(i)/rdiag(i) !GYL
3367  END DO !GYL
3368  ELSE !GYL
3369  DO i=1,nobsl
3370  parm(1) = parm(1) + dep(i)*dep(i)/rdiag(i) * rloc(i)
3371  END DO
3372  END IF !GYL
3373  DO j=1,ne
3374  DO i=1,nobsl
3375  parm(2) = parm(2) + hdxb_rinv(i,j) * hdxb(i,j)
3376  END DO
3377  END DO
3378  parm(2) = parm(2) / real(ne-1,kind=rp)
3379  parm(3) = sum(rloc(1:nobsl))
3380  parm(4) = (parm(1)-parm(3))/parm(2) - parm_infl
3381  ! sigma_o = 1.0d0/REAL(nobsl,kind=RP)/MAXVAL(rloc(1:nobsl))
3382  sigma_o = 2.0d0/parm(3)*((parm_infl*parm(2)+parm(3))/parm(2))**2
3383  gain = sigma_b**2 / (sigma_o + sigma_b**2)
3384  parm_infl = parm_infl + gain * parm(4)
3385 #endif
3386 
3387  return
3388  end subroutine letkf_core
3389 
3390  !-----------------------------------------------------------------------
3391  ! Basic modules for observation input
3392  !-----------------------------------------------------------------------
3393  subroutine get_nobs(cfile,nrec,nn)
3394  implicit none
3395 
3396  character(*),intent(in) :: cfile
3397  integer,intent(in) :: nrec
3398  integer,intent(out) :: nn
3399  integer :: iunit
3400  logical :: ex
3401  integer :: sz
3402 
3403  nn = 0
3404  iunit = io_get_available_fid()
3405 
3406  inquire(file=cfile,exist=ex)
3407  if(ex) then
3408  open(unit=iunit,file=cfile,form='unformatted',access='stream')
3409  inquire(unit=iunit, size=sz)
3410  if (mod(sz, sp * (nrec+2) ) /= 0) then
3411  log_error('get_nobs',*) ': reading error -- skipped: ', cfile
3412  close(unit=iunit)
3413  return
3414  end if
3415  nn = sz / (sp * (nrec+2) )
3416  close(unit=iunit)
3417  else
3418  log_info('get_nobs',*) 'file not found -- skipped: ', cfile
3419  end if
3420 
3421  return
3422  end subroutine get_nobs
3423 
3424  subroutine get_nobs_radar(cfile,nn,radarlon,radarlat,radarz)
3425  implicit none
3426  character(*),intent(in) :: cfile
3427  integer,intent(out) :: nn
3428  real(rp),intent(out) :: radarlon,radarlat,radarz
3429  integer :: nrec
3430  real(sp) :: tmp
3431  integer :: ios
3432  integer :: iunit
3433  logical :: ex
3434  integer :: sz
3435 
3436  if(radar_obs_4d) then
3437  nrec = 8
3438  else
3439  nrec = 7
3440  end if
3441  nn = 0
3442  iunit = io_get_available_fid()
3443 
3444  radarlon = 0.0
3445  radarlat = 0.0
3446  radarz = 0.0
3447 
3448  inquire(file=cfile,exist=ex)
3449  if(ex) then
3450  open(unit=iunit,file=cfile,form='unformatted',access='stream')
3451  read(unit=iunit,iostat=ios) tmp ! dummy
3452  read(unit=iunit,iostat=ios) tmp
3453  if(ios /= 0) then
3454  log_error('get_nobs_radar',*) ': reading error -- skipped: ', cfile
3455  close(unit=iunit)
3456  return
3457  end if
3458  radarlon = real(tmp,kind=rp)
3459  read(unit=iunit,iostat=ios) tmp ! dummy
3460  read(unit=iunit,iostat=ios) tmp ! dummy
3461  read(unit=iunit,iostat=ios) tmp
3462  if(ios /= 0) then
3463  log_error('get_nobs_radar',*) ': reading error -- skipped: ', cfile
3464  close(unit=iunit)
3465  return
3466  end if
3467  radarlat = real(tmp,kind=rp)
3468  read(unit=iunit,iostat=ios) tmp ! dummy
3469  read(unit=iunit,iostat=ios) tmp ! dummy
3470  read(unit=iunit,iostat=ios) tmp
3471  if(ios /= 0) then
3472  log_error('get_nobs_radar',*) ': reading error -- skipped: ', cfile
3473  close(unit=iunit)
3474  return
3475  end if
3476  radarz = real(tmp,kind=rp)
3477  read(unit=iunit,iostat=ios) tmp ! dummy
3478 
3479  ! get file size by INQUIRE statement... may not work for some older fortran compilers
3480  inquire(unit=iunit, size=sz)
3481  sz = sz - sp * (1+2) * 3 ! substract the radar data header
3482  if (mod(sz, sp * (nrec+2)) /= 0) then
3483  log_error('get_nobs_radar',*) ': reading error -- skipped: ', cfile
3484  close(unit=iunit)
3485  return
3486  end if
3487  nn = sz / (sp * (nrec+2))
3488 
3489  close(unit=iunit)
3490  else
3491  log_info('get_nobs_radar',*) 'file not found -- skipped: ', cfile
3492  end if
3493 
3494  return
3495  end subroutine get_nobs_radar
3496 
3497  subroutine read_obs(cfile,obs)
3498  use scale_const, only: &
3499  pi => const_pi
3500  use scale_mapprojection, only: &
3501  mapprojection_lonlat2xy
3502  implicit none
3503 
3504  character(*),intent(in) :: cfile
3505  type(obs_info),intent(inout) :: obs
3506  real(sp) :: wk(8)
3507  real(rp) :: x_rp, y_rp
3508  real(sp) :: tmp
3509  integer :: n,iunit
3510 
3511  iunit = io_get_available_fid()
3512  open(unit=iunit,file=cfile,form='unformatted',access='stream')
3513  do n = 1, obs%nobs
3514  read(unit=iunit) tmp
3515  read(unit=iunit) wk(:)
3516  read(unit=iunit) tmp
3517  select case(nint(wk(1)))
3518  case(id_u_obs)
3519  wk(4) = wk(4) * 100.0 ! hpa -> pa
3520  case(id_v_obs)
3521  wk(4) = wk(4) * 100.0 ! hpa -> pa
3522  case(id_t_obs)
3523  wk(4) = wk(4) * 100.0 ! hpa -> pa
3524  case(id_tv_obs)
3525  wk(4) = wk(4) * 100.0 ! hpa -> pa
3526  case(id_q_obs)
3527  wk(4) = wk(4) * 100.0 ! hpa -> pa
3528  case(id_ps_obs)
3529  wk(5) = wk(5) * 100.0 ! hpa -> pa
3530  wk(6) = wk(6) * 100.0 ! hpa -> pa
3531  case(id_rh_obs)
3532  wk(4) = wk(4) * 100.0 ! hpa -> pa
3533  wk(5) = wk(5) * 0.01 ! percent input
3534  wk(6) = wk(6) * 0.01 ! percent input
3535  case(id_tcmip_obs)
3536  wk(4) = wk(4) * 100.0 ! hpa -> pa
3537  wk(5) = wk(5) * 100.0 ! hpa -> pa
3538  wk(6) = real( obserr_tcp,kind=sp )
3539  case(id_tclon_obs)
3540  call mapprojection_lonlat2xy( real(wk(2),kind=rp)*pi/180.0_rp,&
3541  real(wk(3),kind=rp)*pi/180.0_rp,&
3542  x_rp, y_rp )
3543  wk(4) = wk(4) * 100.0 ! hpa -> pa
3544  wk(5) = real( x_rp, kind=sp )
3545  wk(6) = real( obserr_tcx, kind=sp )
3546  case(id_tclat_obs)
3547  call mapprojection_lonlat2xy( real(wk(2),kind=rp)*pi/180.0_rp,&
3548  real(wk(3),kind=rp)*pi/180.0_rp,&
3549  x_rp, y_rp )
3550  wk(4) = wk(4) * 100.0 ! hpa -> pa
3551  wk(5) = real( y_rp, kind=sp )
3552  wk(6) = real( obserr_tcy, kind=sp )
3553  end select
3554  obs%elm(n) = nint( wk(1) )
3555  obs%lon(n) = real( wk(2), kind=rp )
3556  obs%lat(n) = real( wk(3), kind=rp )
3557  obs%lev(n) = real( wk(4), kind=rp )
3558  obs%dat(n) = real( wk(5), kind=rp )
3559  obs%err(n) = real( wk(6), kind=rp )
3560  obs%typ(n) = nint( wk(7) )
3561  obs%dif(n) = real( wk(8), kind=rp )
3562  end do
3563  close(unit=iunit)
3564 
3565  return
3566  end subroutine read_obs
3567 
3568  subroutine read_obs_radar(cfile,obs)
3569  implicit none
3570  character(*),intent(in) :: cfile
3571  type(obs_info),intent(inout) :: obs
3572  real(sp) :: wk(8)
3573  integer :: nrec
3574  real(sp) :: tmp
3575  integer :: n,iunit,ios
3576 
3577  if(radar_obs_4d) then
3578  nrec = 8
3579  else
3580  nrec = 7
3581  end if
3582  iunit = io_get_available_fid()
3583  open(unit=iunit,file=cfile,form='unformatted',access='stream')
3584  read(unit=iunit,iostat=ios) tmp ! dummy
3585  read(unit=iunit,iostat=ios) tmp ! radarlon
3586  read(unit=iunit,iostat=ios) tmp ! dummy
3587  read(unit=iunit,iostat=ios) tmp ! dummy
3588  read(unit=iunit,iostat=ios) tmp ! radarlat
3589  read(unit=iunit,iostat=ios) tmp ! dummy
3590  read(unit=iunit,iostat=ios) tmp ! dummy
3591  read(unit=iunit,iostat=ios) tmp ! radarz
3592  read(unit=iunit,iostat=ios) tmp ! dummy
3593  do n = 1, obs%nobs
3594  read(unit=iunit) tmp ! dummy
3595  read(unit=iunit) wk(1:nrec)
3596  read(unit=iunit) tmp ! dummy
3597  obs%elm(n) = nint(wk(1))
3598  obs%lon(n) = real(wk(2),kind=rp)
3599  obs%lat(n) = real(wk(3),kind=rp)
3600  obs%lev(n) = real(wk(4),kind=rp)
3601  obs%dat(n) = real(wk(5),kind=rp)
3602  obs%err(n) = real(wk(6),kind=rp)
3603  obs%typ(n) = 22
3604  if(radar_obs_4d) then
3605  obs%dif(n) = real(wk(8),kind=rp)
3606  else
3607  obs%dif(n) = 0.0
3608  end if
3609  end do
3610  close(unit=iunit)
3611 
3612  return
3613  end subroutine read_obs_radar
3614 
3615  subroutine read_obs_radar_toshiba_pawr( obs, cfile )
3616  use iso_c_binding
3617  use scale_da_read_pawr_toshiba, only: &
3618  read_toshiba => da_read_pawr_toshiba, &
3619  c_pawr_header, &
3620  rdim, &
3621  azdim, &
3622  eldim
3623  implicit none
3624 
3625  character(len=*), intent(in) :: cfile
3626  type(obs_info), intent(out) :: obs
3627 
3628  type(obs_info) :: obs_ref
3629 
3630  integer, parameter :: n_type = 3
3631  character(len=4), parameter :: file_type_sfx(n_type) = &
3632  (/'.ze ', '.vr ', '.qcf'/)
3633  logical, parameter :: input_is_dbz = .true.
3634 
3635  type(c_pawr_header) :: hd(n_type)
3636  real(kind=c_float), allocatable, save :: rtdat(:, :, :, :)
3637  real(kind=c_float), allocatable, save :: az(:, :, :)
3638  real(kind=c_float), allocatable, save :: el(:, :, :)
3639  integer :: j, ierr, ierr2
3640  character(len=3) :: fname
3641  integer, save::i=0
3642 
3643  real(rp), allocatable :: ze(:, :, :), vr(:, :, :), qcflag(:, :, :), attenuation(:, :, :), rrange(:)
3644  real(rp), allocatable :: radlon(:, :, :), radlat(:, :, :), radz(:, :, :)
3645  real(rp), allocatable :: lon(:), lat(:), z(:)
3646  integer(8), allocatable :: grid_index(:), grid_count_ze(:), grid_count_vr(:)
3647  real(rp), allocatable :: grid_ze(:), grid_vr(:)
3648  real(rp), allocatable :: grid_lon_ze(:), grid_lat_ze(:), grid_z_ze(:)
3649  real(rp), allocatable :: grid_lon_vr(:), grid_lat_vr(:), grid_z_vr(:)
3650 
3651  character(len=1024) :: input_fname(n_type)
3652  integer ia, ir, ie
3653  real(rp) :: dlon, dlat
3654  integer(8) nobs_sp
3655 
3656  integer,save :: na, nr, ne
3657  real(rp),save :: lon0, lat0, z0
3658  real(rp),save :: missing
3659  integer,save :: range_res
3660 
3661  real(rp) :: max_obs_ze , min_obs_ze , max_obs_vr , min_obs_vr
3662  integer :: nobs_ze, nobs_vr
3663  integer(8) :: idx, n, n_ref
3664  integer :: pos
3665  integer, parameter :: int1 = selected_int_kind(1) !1-BYTE INT
3666  integer(kind = int1) :: tmp_qcf, valid_qcf
3667 
3668  integer,parameter :: qcf_mask(8)=(/ 0, 1, 1, 1, 1, 0, 0, 0 /) !! valid, shadow, clutter possible, clutter certain, interference, range sidelobe /
3669 
3670  integer::qcf_count(0:255)
3671 
3672  character(len=90) :: plotname
3673  character(len=19) :: timelabel
3674 
3675  integer :: ii, jj, kk
3676 
3677  real(sp), allocatable :: ref3d(:,:,:)
3678  real(sp), allocatable :: vr3d(:,:,:)
3679  character(len=255) :: filename
3680  integer :: irec, iunit, iolen
3681  integer :: k
3682 
3683  integer :: nlon, nlat, nlev
3684 
3685  radar_so_size_hori = max( real( dx, kind=rp ), radar_so_size_hori )
3686  radar_so_size_hori = max( real( dy, kind=rp ), radar_so_size_hori )
3687 
3688  if( .not. allocated(rtdat) ) allocate(rtdat(rdim, azdim, eldim, n_type))
3689  if( .not. allocated(az) ) allocate(az(azdim, eldim, n_type))
3690  if( .not. allocated(el) ) allocate(el(azdim, eldim, n_type))
3691 
3692  do j = 1, n_type
3693  input_fname(j) = trim(cfile)
3694  call str_replace(input_fname(j), '.<type>', trim(file_type_sfx(j)), pos)
3695  ierr = read_toshiba( input_fname(j), hd(j), az(:,:,j), el(:,:,j), rtdat(:,:,:,j) )
3696  if( ierr /= 0 ) then
3697  log_info("LETKF_obs_readfile",*) 'Warning: File (',trim(input_fname(j)),') cannot be read. Skip.'
3698  obs%nobs = 0
3699  return
3700  endif
3701  end do
3702 
3703  ! Set obs information
3704  lon0 = hd(1)%longitude
3705  lat0 = hd(1)%latitude
3706  z0 = hd(1)%altitude
3707 
3708  missing = real( hd(1)%mesh_offset, kind=rp )
3709  range_res = hd(1)%range_res
3710 
3711  nr = hd(1)%range_num
3712  na = hd(1)%sector_num
3713  ne = hd(1)%el_num
3714 
3715  call jst2utc( hd(1)%s_yr, hd(1)%s_mn, hd(1)%s_dy, hd(1)%s_hr, hd(1)%s_mi, hd(1)%s_sc, 0.0_dp, utime_obs )
3716 
3717  allocate( ze(na, nr, ne) )
3718  allocate( vr(na, nr, ne) )
3719  allocate( qcflag(na, nr, ne) )
3720  allocate( attenuation(na, nr, ne) )
3721 
3722  valid_qcf = 0
3723  do j = 1, 8
3724  if(qcf_mask(j) > 0) valid_qcf = ibset(valid_qcf, j - 1)
3725  end do
3726 
3727  do ie = 1, ne
3728  do ir = 1, nr
3729  do ia = 1, na
3730  ze(ia,ir,ie) = rtdat(ir,ia,ie,1)
3731  vr(ia,ir,ie) = rtdat(ir,ia,ie,2)
3732 
3733  if( vr(ia,ir,ie) > radar_max_abs_vr .or. vr(ia,ir,ie) < -radar_max_abs_vr ) vr(ia,ir,ie) = missing
3734 
3735  tmp_qcf = int(rtdat(ir, ia, ie, 3), int1)
3736  if(iand(valid_qcf, tmp_qcf) == 0) then
3737  qcflag(ia, ir, ie) = 0.0_rp !valid
3738  else
3739  qcflag(ia, ir, ie) = 1000.0_rp !invalid
3740  end if
3741  attenuation(ia, ir, ie) = 1.0_rp !not implemented yet
3742  end do
3743  end do
3744  end do
3745  deallocate(rtdat)
3746 
3747  allocate(rrange(nr))
3748  do ir = 1, nr
3749  rrange(ir) = (dble(ir) - 0.5_rp) * range_res
3750  end do
3751 
3752  allocate( radlon(na, nr, ne) )
3753  allocate( radlat(na, nr, ne) )
3754  allocate( radz(na, nr, ne) )
3755 
3756  call radar_georeference( lon0, lat0, z0, na, nr, ne, & ! input
3757  real( az(:, 1, 1), kind=rp ), & ! input (assume ordinary scan strategy)
3758  rrange, & ! input (assume ordinary scan strategy)
3759  real( el(1, :, 1), kind=rp ), & ! input (assume ordinary scan strategy)
3760  radlon, radlat, radz ) ! output
3761 
3762  call define_grid( lon0, lat0, nr, rrange, rrange(nr), radar_zmax, & ! input
3763  radar_so_size_hori, radar_so_size_hori, radar_so_size_vert, & ! input
3764  dlon, dlat, nlon, nlat, nlev, lon, lat, z ) ! output
3765 
3766  call radar_superobing( na, nr, ne, radlon, radlat, radz, ze, vr, & ! input spherical
3767  qcflag, attenuation, & ! input spherical
3768  nlon, nlat, nlev, lon, lat, z, dlon, dlat, radar_so_size_vert, & ! input cartesian
3769  missing, input_is_dbz, & ! input param
3770  lon0, lat0, &
3771  nobs_sp, grid_index, & ! output array info
3772  grid_ze, grid_lon_ze, grid_lat_ze, grid_z_ze, grid_count_ze, & ! output ze
3773  grid_vr, grid_lon_vr, grid_lat_vr, grid_z_vr, grid_count_vr ) ! output vr
3774 
3775  if( allocated( ze ) ) deallocate(ze)
3776  if( allocated( vr ) ) deallocate(vr)
3777  if( allocated( qcflag ) ) deallocate(qcflag)
3778  if( allocated( attenuation ) ) deallocate(attenuation)
3779  if( allocated( rrange ) ) deallocate(rrange)
3780 
3781  obs%meta(1) = lon0
3782  obs%meta(2) = lat0
3783  obs%meta(3) = z0
3784 
3785  obs%nobs = 0
3786  obs_ref%nobs = 0
3787 
3788  do idx = 1, nobs_sp
3789  ! Thinning
3790  ii = nint( ( grid_lon_ze(idx) - lon(1) ) / dlon ) + 1
3791  jj = nint( ( grid_lat_ze(idx) - lat(1) ) / dlat ) + 1
3792  kk = nint( ( grid_z_ze(idx) - z(1) ) / radar_so_size_vert ) + 1
3793 
3794  if ( mod(ii, radar_thin_hori) /= 0 .or. mod(jj, radar_thin_hori) /= 0 .or. &
3795  mod(kk, radar_thin_vert) /= 0 ) cycle
3796 
3797  if (grid_count_ze(idx) > 0) then
3798  obs%nobs = obs%nobs + 1
3799 
3800  ! Count refrectivity obs ( > MIN_RADAR_REF ) below RADAR_ZMAX
3801  if ( grid_ze(idx) > min_radar_ref .and. grid_z_ze(idx) < radar_zmax ) then
3802  obs_ref%nobs = obs_ref%nobs + 1
3803  end if
3804  end if
3805  if (grid_count_vr(idx) > 0) then
3806  obs%nobs = obs%nobs + 1
3807  end if
3808  end do
3809 
3810  call obs_info_allocate( obs, extended=.true. )
3811  call obs_info_allocate( obs_ref, extended=.true. )
3812 
3813  n = 0
3814  n_ref = 0
3815  nobs_ze = 0
3816  nobs_vr = 0
3817  min_obs_ze = huge(1.0_rp)
3818  max_obs_ze = -huge(1.0_rp)
3819  min_obs_vr = huge(1.0_rp)
3820  max_obs_vr = -huge(1.0_rp)
3821 
3822  do idx = 1, nobs_sp
3823  ii = nint( ( grid_lon_ze(idx) - lon(1) ) / dlon ) + 1
3824  jj = nint( ( grid_lat_ze(idx) - lat(1) ) / dlat ) + 1
3825  kk = nint( ( grid_z_ze(idx) - z(1) ) / radar_so_size_vert ) + 1
3826 
3827  ! Thinning
3828  if ( mod(ii, radar_thin_hori) /= 0 .or. mod(jj, radar_thin_hori) /= 0 .or. &
3829  mod(kk, radar_thin_vert) /= 0 ) cycle
3830 
3831  if (grid_count_ze(idx) > 0) then
3832  n = n + 1
3833  obs%elm(n) = id_radar_ref_obs
3834  obs%lon(n) = grid_lon_ze(idx)
3835  obs%lat(n) = grid_lat_ze(idx)
3836  obs%lev(n) = grid_z_ze(idx)
3837  obs%dat(n) = grid_ze(idx)
3838  ! Add RADAR_BIAS_CONST_DBZ in dBZ
3839  if ( radar_bias_cor_rain .and. grid_ze(idx) > min_radar_ref ) then
3840  obs%dat(n) = grid_ze(idx) * radar_bias_rain_const
3841  elseif ( radar_bias_cor_clr .and. grid_ze(idx) < min_radar_ref ) then
3842  obs%dat(n) = grid_ze(idx) * radar_bias_clr_const
3843  endif
3844  obs%err(n) = obserr_radar_ref
3845  obs%typ(n) = 22
3846  obs%dif(n) = 0.0d0
3847  nobs_ze = nobs_ze + 1
3848  if (grid_ze(idx) > max_obs_ze) max_obs_ze = grid_ze(idx)
3849  if (grid_ze(idx) < min_obs_ze) min_obs_ze = grid_ze(idx)
3850 
3851  if ( grid_ze(idx) > min_radar_ref .and. grid_z_ze(idx) < radar_zmax ) then
3852  n_ref = n_ref + 1
3853  obs_ref%elm(n_ref) = id_radar_ref_obs
3854  obs_ref%lon(n_ref) = grid_lon_ze(idx)
3855  obs_ref%lat(n_ref) = grid_lat_ze(idx)
3856  obs_ref%lev(n_ref) = grid_z_ze(idx)
3857  if ( radar_bias_cor_rain ) then
3858  ! Add RADAR_BIAS_CONST_DBZ in dBZ
3859  obs_ref%dat(n_ref) = grid_ze(idx) * radar_bias_rain_const
3860  else
3861  obs_ref%dat(n_ref) = grid_ze(idx)
3862  end if
3863  end if
3864  end if
3865 
3866  if (grid_count_vr(idx) > 0) then
3867  n = n + 1
3868  obs%elm(n) = id_radar_vr_obs
3869  obs%lon(n) = grid_lon_ze(idx)
3870  obs%lat(n) = grid_lat_ze(idx)
3871  obs%lev(n) = grid_z_ze(idx)
3872  obs%dat(n) = grid_vr(idx)
3873  obs%err(n) = obserr_radar_vr
3874  obs%typ(n) = 22
3875  obs%dif(n) = 0.0d0
3876  nobs_vr = nobs_vr + 1
3877  if (grid_vr(idx) > max_obs_vr) max_obs_vr = grid_vr(idx)
3878  if (grid_vr(idx) < min_obs_vr) min_obs_vr = grid_vr(idx)
3879  end if
3880  end do
3881 
3882  if( allocated(radlon) ) deallocate(radlon)
3883  if( allocated(radlat) ) deallocate(radlat)
3884  if( allocated(radz ) ) deallocate(radz)
3885  deallocate(az, el)
3886 
3887  call obs_info_deallocate( obs_ref )
3888 
3889  if( allocated( grid_index ) ) deallocate(grid_index)
3890  if( allocated( grid_ze ) ) deallocate(grid_ze)
3891  if( allocated( grid_lon_ze ) ) deallocate(grid_lon_ze)
3892  if( allocated( grid_lat_ze ) ) deallocate(grid_lat_ze)
3893  if( allocated( grid_z_ze ) ) deallocate(grid_z_ze)
3894  if( allocated( grid_count_ze ) ) deallocate(grid_count_ze)
3895  if( allocated( grid_vr ) ) deallocate(grid_vr)
3896  if( allocated( grid_lon_vr ) ) deallocate(grid_lon_vr)
3897  if( allocated( grid_lat_vr ) ) deallocate(grid_lat_vr)
3898  if( allocated( grid_z_vr ) ) deallocate(grid_z_vr)
3899  if( allocated( grid_count_vr ) ) deallocate(grid_count_vr)
3900 
3901  return
3902  end subroutine read_obs_radar_toshiba_pawr
3903 
3904  subroutine read_obs_radar_toshiba_mp_pawr( obs, cfile, maskfile )
3905  use iso_c_binding
3906  use scale_da_read_mp_pawr_toshiba, only: &
3907  read_toshiba_mpr => da_read_mp_pawr_toshiba, &
3908  c_mppawr_header, &
3909  rdim, &
3910  azdim, &
3911  eldim
3912  implicit none
3913 
3914  character(len=*), intent(in) :: cfile
3915  character(len=*), intent(in) :: maskfile
3916  type(obs_info), intent(out) :: obs
3917 
3918  type(obs_info) :: obs_ref
3919 
3920  integer, parameter :: n_type = 2
3921  character(len=4), parameter :: file_type_sfx(n_type) = (/'.ze', '.vr'/)
3922  logical, parameter :: input_is_dbz = .true.
3923  integer, parameter :: opt_verbose = 0 !!! for MP-PAWR toshiba format
3924 
3925  integer :: access !FILE INQUIRY
3926  integer :: ios
3927  integer(4), save :: shadow_na, shadow_ne
3928  integer(4), allocatable, save :: tmpshadow(:)
3929  integer(2), allocatable, save :: shadow(:,:)
3930  real(8),save :: shadow_del_az
3931 
3932  type(c_mppawr_header) :: hd(n_type)
3933  real(kind=c_float), allocatable, save :: rtdat(:, :, :, :)
3934  real(kind=c_float), allocatable, save :: az(:, :, :)
3935  real(kind=c_float), allocatable, save :: el(:, :, :)
3936  integer :: j, ierr, ierr2
3937  character(len=3) :: fname
3938  integer, save::i=0
3939 
3940  real(rp), allocatable :: ze(:, :, :), vr(:, :, :), qcflag(:, :, :), attenuation(:, :, :), rrange(:)
3941  real(rp), allocatable :: radlon(:, :, :), radlat(:, :, :), radz(:, :, :)
3942  real(rp), allocatable :: lon(:), lat(:), z(:)
3943  integer(8), allocatable :: grid_index(:), grid_count_ze(:), grid_count_vr(:)
3944  real(rp), allocatable :: grid_ze(:), grid_vr(:)
3945  real(rp), allocatable :: grid_lon_ze(:), grid_lat_ze(:), grid_z_ze(:)
3946  real(rp), allocatable :: grid_lon_vr(:), grid_lat_vr(:), grid_z_vr(:)
3947 
3948  character(len=1024) :: input_fname(n_type)
3949  integer ia, ir, ie
3950  real(rp) :: dlon, dlat
3951  integer(8) nobs_sp
3952 
3953  integer,save :: na, nr, ne
3954  real(rp),save :: lon0, lat0, z0
3955  real(rp),save :: missing
3956  integer,save :: range_res
3957 
3958  real(rp) :: max_obs_ze , min_obs_ze , max_obs_vr , min_obs_vr
3959  integer :: nobs_ze, nobs_vr
3960  integer(8) :: idx, n, n_ref
3961  integer :: pos
3962  integer, parameter :: int1 = selected_int_kind(1) !1-BYTE INT
3963  integer(kind = int1) :: tmp_qcf, valid_qcf
3964 
3965  integer,parameter :: qcf_mask(8)=(/ 0, 1, 1, 1, 1, 0, 0, 0 /) !! valid, shadow, clutter possible, clutter certain, interference, range sidelobe /
3966 
3967  integer::qcf_count(0:255)
3968 
3969  character(len=90) :: plotname
3970  character(len=19) :: timelabel
3971 
3972  integer :: ii, jj, kk
3973 
3974  real(sp), allocatable :: ref3d(:,:,:)
3975  real(sp), allocatable :: vr3d(:,:,:)
3976  character(len=255) :: filename
3977  integer :: irec, iunit, iolen
3978  integer :: k
3979 
3980  integer :: nlon, nlat, nlev
3981 
3982  radar_so_size_hori = max( real( dx, kind=rp ), radar_so_size_hori )
3983  radar_so_size_hori = max( real( dy, kind=rp ), radar_so_size_hori )
3984 
3985  if( .not. allocated(rtdat) ) allocate(rtdat(rdim, azdim, eldim, n_type))
3986  if( .not. allocated(az) ) allocate(az(azdim, eldim, n_type))
3987  if( .not. allocated(el) ) allocate(el(azdim, eldim, n_type))
3988 
3989  if( trim(maskfile) /= '' .and. .NOT. allocated( shadow ) ) then
3990  iunit = io_get_available_fid()
3991  open(iunit, file=trim(maskfile), status="old", access="stream", form="unformatted")
3992  read(iunit,iostat=ios) shadow_na, shadow_ne
3993  allocate( shadow( shadow_na, shadow_ne ) )
3994  if ( ios == 0 )then
3995  read(iunit,iostat=ios) shadow
3996  close(iunit)
3997  else
3998  write(6,'(3A)') 'file ',trim(maskfile) ,' not found or unsupported format.'
3999  stop 1
4000  end if
4001  end if
4002 
4003  do j = 1, n_type
4004  input_fname(j) = trim(cfile)
4005  call str_replace(input_fname(j), '.<type>', trim(file_type_sfx(j)), pos)
4006  ierr = read_toshiba_mpr( input_fname(j), opt_verbose, hd(j), az(:,:,j), el(:,:,j), rtdat(:,:,:,j) )
4007  if( ierr /= 0 ) then
4008  log_info("LETKF_obs_readfile",*) 'Warning: File (',trim(input_fname(j)),') cannot be read. Skip.'
4009  obs%nobs = 0
4010  return
4011  endif
4012  end do
4013 
4014  ! Set obs information
4015  lon0 = hd(1)%longitude
4016  lat0 = hd(1)%latitude
4017  z0 = hd(1)%altitude
4018 
4019  missing = real( hd(1)%mesh_offset, kind=rp )
4020  range_res = hd(1)%range_res
4021 
4022  nr = hd(1)%range_num
4023  na = hd(1)%ray_num
4024  ne = hd(1)%el_num
4025 
4026  call jst2utc( hd(1)%s_yr, hd(1)%s_mn, hd(1)%s_dy, hd(1)%s_hr, hd(1)%s_mi, hd(1)%s_sc, 0.0_dp, utime_obs )
4027 
4028  allocate( ze(na, nr, ne) )
4029  allocate( vr(na, nr, ne) )
4030  allocate( qcflag(na, nr, ne) )
4031  allocate( attenuation(na, nr, ne) )
4032 
4033  shadow_del_az = 360.0_rp / shadow_na
4034  if ( trim(maskfile) /= '' .and. .not. allocated(tmpshadow) ) then
4035  allocate(tmpshadow(na))
4036  end if
4037 
4038  do ie = 1, ne
4039  do ir = 1, nr
4040  do ia = 1, na
4041  ze(ia,ir,ie) = rtdat(ir,ia,ie,1)
4042  vr(ia,ir,ie) = rtdat(ir,ia,ie,2)
4043 
4044  if( vr(ia,ir,ie) > radar_max_abs_vr .or. vr(ia,ir,ie) < -radar_max_abs_vr ) vr(ia,ir,ie) = missing
4045  end do
4046  end do
4047 
4048  do ir = 1, nr
4049  do ia = 1, na
4050  qcflag(ia,ir,ie) = 0.0_rp !valid
4051  end do
4052  end do
4053  if( trim(maskfile) /= '' .and. allocated(shadow) ) then
4054  if( ie <= shadow_ne ) then
4055  do ia = 1, na
4056  tmpshadow(ia) = shadow( min(shadow_na,nint(az(ia, ie, 1) / shadow_del_az) + 1), ie )
4057  end do
4058  do ir = 1, nr
4059  do ia = 1, na
4060  if( tmpshadow(ia) /= 0 .and. ir >= tmpshadow(ia) ) then
4061  qcflag(ia, ir, ie) = 1000.0_rp !invalid
4062  end if
4063  end do
4064  end do
4065  end if
4066  end if
4067 
4068  do ir = 1, nr
4069  do ia = 1, na
4070  attenuation(ia, ir, ie) = 1.0_rp !not implemented yet
4071  end do
4072  end do
4073  end do
4074  deallocate(rtdat)
4075 
4076  allocate(rrange(nr))
4077  do ir = 1, nr
4078  rrange(ir) = (dble(ir) - 0.5_rp) * range_res
4079  end do
4080 
4081  allocate( radlon(na, nr, ne) )
4082  allocate( radlat(na, nr, ne) )
4083  allocate( radz(na, nr, ne) )
4084 
4085  call radar_georeference( lon0, lat0, z0, na, nr, ne, & ! input
4086  real( az(:, 1, 1), kind=rp ), & ! input (assume ordinary scan strategy)
4087  rrange, & ! input (assume ordinary scan strategy)
4088  real( el(1, :, 1), kind=rp ), & ! input (assume ordinary scan strategy)
4089  radlon, radlat, radz ) ! output
4090 
4091  call define_grid( lon0, lat0, nr, rrange, rrange(nr), radar_zmax, & ! input
4092  radar_so_size_hori, radar_so_size_hori, radar_so_size_vert, & ! input
4093  dlon, dlat, nlon, nlat, nlev, lon, lat, z ) ! output
4094 
4095  call radar_superobing( na, nr, ne, radlon, radlat, radz, ze, vr, & ! input spherical
4096  qcflag, attenuation, & ! input spherical
4097  nlon, nlat, nlev, lon, lat, z, dlon, dlat, radar_so_size_vert, & ! input cartesian
4098  missing, input_is_dbz, & ! input param
4099  lon0, lat0, &
4100  nobs_sp, grid_index, & ! output array info
4101  grid_ze, grid_lon_ze, grid_lat_ze, grid_z_ze, grid_count_ze, & ! output ze
4102  grid_vr, grid_lon_vr, grid_lat_vr, grid_z_vr, grid_count_vr ) ! output vr
4103 
4104  if( allocated( ze ) ) deallocate(ze)
4105  if( allocated( vr ) ) deallocate(vr)
4106  if( allocated( qcflag ) ) deallocate(qcflag)
4107  if( allocated( attenuation ) ) deallocate(attenuation)
4108  if( allocated( rrange ) ) deallocate(rrange)
4109 
4110  obs%meta(1) = lon0
4111  obs%meta(2) = lat0
4112  obs%meta(3) = z0
4113 
4114  obs%nobs = 0
4115  obs_ref%nobs = 0
4116 
4117  do idx = 1, nobs_sp
4118  ! Thinning
4119  ii = nint( ( grid_lon_ze(idx) - lon(1) ) / dlon ) + 1
4120  jj = nint( ( grid_lat_ze(idx) - lat(1) ) / dlat ) + 1
4121  kk = nint( ( grid_z_ze(idx) - z(1) ) / radar_so_size_vert ) + 1
4122 
4123  if ( mod(ii, radar_thin_hori) /= 0 .or. mod(jj, radar_thin_hori) /= 0 .or. &
4124  mod(kk, radar_thin_vert) /= 0 ) cycle
4125 
4126  if (grid_count_ze(idx) > 0) then
4127  obs%nobs = obs%nobs + 1
4128 
4129  ! Count refrectivity obs ( > MIN_RADAR_REF ) below RADAR_ZMAX
4130  if ( grid_ze(idx) > min_radar_ref .and. grid_z_ze(idx) < radar_zmax ) then
4131  obs_ref%nobs = obs_ref%nobs + 1
4132  end if
4133  end if
4134  if (grid_count_vr(idx) > 0) then
4135  obs%nobs = obs%nobs + 1
4136  end if
4137  end do
4138 
4139  call obs_info_allocate( obs, extended=.true. )
4140  call obs_info_allocate( obs_ref, extended=.true. )
4141 
4142  n = 0
4143  n_ref = 0
4144  nobs_ze = 0
4145  nobs_vr = 0
4146  min_obs_ze = huge(1.0_rp)
4147  max_obs_ze = -huge(1.0_rp)
4148  min_obs_vr = huge(1.0_rp)
4149  max_obs_vr = -huge(1.0_rp)
4150 
4151  do idx = 1, nobs_sp
4152  ii = nint( ( grid_lon_ze(idx) - lon(1) ) / dlon ) + 1
4153  jj = nint( ( grid_lat_ze(idx) - lat(1) ) / dlat ) + 1
4154  kk = nint( ( grid_z_ze(idx) - z(1) ) / radar_so_size_vert ) + 1
4155 
4156  ! Thinning
4157  if ( mod(ii, radar_thin_hori) /= 0 .or. mod(jj, radar_thin_hori) /= 0 .or. &
4158  mod(kk, radar_thin_vert) /= 0 ) cycle
4159 
4160  if (grid_count_ze(idx) > 0) then
4161  n = n + 1
4162  obs%elm(n) = id_radar_ref_obs
4163  obs%lon(n) = grid_lon_ze(idx)
4164  obs%lat(n) = grid_lat_ze(idx)
4165  obs%lev(n) = grid_z_ze(idx)
4166  obs%dat(n) = grid_ze(idx)
4167  ! Add RADAR_BIAS_CONST_DBZ in dBZ
4168  if ( radar_bias_cor_rain .and. grid_ze(idx) > min_radar_ref ) then
4169  obs%dat(n) = grid_ze(idx) * radar_bias_rain_const
4170  elseif ( radar_bias_cor_clr .and. grid_ze(idx) < min_radar_ref ) then
4171  obs%dat(n) = grid_ze(idx) * radar_bias_clr_const
4172  endif
4173  obs%err(n) = obserr_radar_ref
4174  obs%typ(n) = 22
4175  obs%dif(n) = 0.0d0
4176  nobs_ze = nobs_ze + 1
4177  if (grid_ze(idx) > max_obs_ze) max_obs_ze = grid_ze(idx)
4178  if (grid_ze(idx) < min_obs_ze) min_obs_ze = grid_ze(idx)
4179 
4180  if ( grid_ze(idx) > min_radar_ref .and. grid_z_ze(idx) < radar_zmax ) then
4181  n_ref = n_ref + 1
4182  obs_ref%elm(n_ref) = id_radar_ref_obs
4183  obs_ref%lon(n_ref) = grid_lon_ze(idx)
4184  obs_ref%lat(n_ref) = grid_lat_ze(idx)
4185  obs_ref%lev(n_ref) = grid_z_ze(idx)
4186  if ( radar_bias_cor_rain ) then
4187  ! Add RADAR_BIAS_CONST_DBZ in dBZ
4188  obs_ref%dat(n_ref) = grid_ze(idx) * radar_bias_rain_const
4189  else
4190  obs_ref%dat(n_ref) = grid_ze(idx)
4191  end if
4192  end if
4193  end if
4194 
4195  if (grid_count_vr(idx) > 0) then
4196  n = n + 1
4197  obs%elm(n) = id_radar_vr_obs
4198  obs%lon(n) = grid_lon_ze(idx)
4199  obs%lat(n) = grid_lat_ze(idx)
4200  obs%lev(n) = grid_z_ze(idx)
4201  obs%dat(n) = grid_vr(idx)
4202  obs%err(n) = obserr_radar_vr
4203  obs%typ(n) = 22
4204  obs%dif(n) = 0.0d0
4205  nobs_vr = nobs_vr + 1
4206  if (grid_vr(idx) > max_obs_vr) max_obs_vr = grid_vr(idx)
4207  if (grid_vr(idx) < min_obs_vr) min_obs_vr = grid_vr(idx)
4208  end if
4209  end do
4210 
4211  if( allocated(radlon) ) deallocate(radlon)
4212  if( allocated(radlat) ) deallocate(radlat)
4213  if( allocated(radz ) ) deallocate(radz)
4214  deallocate(az, el)
4215 
4216  call obs_info_deallocate( obs_ref )
4217 
4218  if( allocated( grid_index ) ) deallocate(grid_index)
4219  if( allocated( grid_ze ) ) deallocate(grid_ze)
4220  if( allocated( grid_lon_ze ) ) deallocate(grid_lon_ze)
4221  if( allocated( grid_lat_ze ) ) deallocate(grid_lat_ze)
4222  if( allocated( grid_z_ze ) ) deallocate(grid_z_ze)
4223  if( allocated( grid_count_ze ) ) deallocate(grid_count_ze)
4224  if( allocated( grid_vr ) ) deallocate(grid_vr)
4225  if( allocated( grid_lon_vr ) ) deallocate(grid_lon_vr)
4226  if( allocated( grid_lat_vr ) ) deallocate(grid_lat_vr)
4227  if( allocated( grid_z_vr ) ) deallocate(grid_z_vr)
4228  if( allocated( grid_count_vr ) ) deallocate(grid_count_vr)
4229 
4230  return
4231  end subroutine read_obs_radar_toshiba_mp_pawr
4232 
4233  !-------------------------------------------------------------------------------
4234  ! Replace the first occurrence of 'oldsub' in 'str' with 'newsub';
4235  ! note that 'str' will be left-adjusted no matter whether 'oldsub' is found
4236  !-------------------------------------------------------------------------------
4237  ! [INPUT]
4238  ! str : input string
4239  ! oldsub : old substring to be replaced
4240  ! newsub : new substring
4241  ! [OUTPUT]
4242  ! str : output string with substring replaced
4243  ! pos : the start position of the replaced substring; if not found, return 0
4244  !-------------------------------------------------------------------------------
4245  subroutine str_replace(str, oldsub, newsub, pos)
4246  use scale_prc, only: &
4247  prc_abort
4248  implicit none
4249  character(len=*), intent(inout) :: str
4250  character(len=*), intent(in) :: oldsub
4251  character(len=*), intent(in) :: newsub
4252  integer, intent(out) :: pos
4253  integer :: str_lent, oldsub_len, newsub_len, shift
4254 
4255  str = adjustl(str)
4256  str_lent = len_trim(str)
4257  oldsub_len = len(oldsub)
4258  newsub_len = len(newsub)
4259 
4260  pos = index(str, oldsub)
4261  if (pos >= 1) then
4262  shift = newsub_len - oldsub_len
4263  if (shift > 0) then
4264  if (str_lent+shift > len(str)) then
4265  log_error('str_replace', *) "The length of 'str' string is not enough for substitution."
4266  call prc_abort
4267  end if
4268  str(pos+oldsub_len:str_lent+shift) = adjustr(str(pos+oldsub_len:str_lent+shift))
4269  else if (shift < 0) then
4270  str(pos+newsub_len:pos+oldsub_len-1) = repeat(' ', 0-shift)
4271  str(pos+newsub_len:str_lent) = adjustl(str(pos+newsub_len:str_lent))
4272  end if
4273  str(pos:pos+newsub_len-1) = newsub
4274  end if
4275 
4276  return
4277  end subroutine str_replace
4278 
4279  subroutine jst2utc(jyear, jmonth, jday, jhour, jminute, jsecond, jtime_ms, utime)
4280  use scale_calendar, only: &
4281  calendar_date2daysec, &
4282  calendar_daysec2date, &
4283  calendar_adjust_daysec
4284  implicit none
4285 
4286  integer, intent(in) :: jyear, jmonth, jday
4287  integer, intent(in) :: jhour, jminute, jsecond
4288  real(dp) :: jtime_ms
4289  integer, intent(out) :: utime(6)
4290  integer :: jtime(6)
4291  integer :: absday
4292  real(dp) :: abssec, utime_ms
4293 
4294  jtime(1) = jyear
4295  jtime(2) = jmonth
4296  jtime(3) = jday
4297  jtime(4) = jhour
4298  jtime(5) = jminute
4299  jtime(6) = jsecond
4300 
4301  call calendar_date2daysec( absday, & ! [OUT]
4302  abssec, & ! [OUT]
4303  jtime, & ! [IN]
4304  jtime_ms, & ! [IN]
4305  0 ) ! [IN]
4306 
4307  abssec = abssec - real(3600*9, kind=dp)
4308 
4309  call calendar_adjust_daysec( absday, & ! [INOUT]
4310  abssec ) ! [INOUT]
4311 
4312  call calendar_daysec2date( utime, & ! [OUT]
4313  utime_ms, & ! [OUT]
4314  absday, & ! [IN]
4315  abssec, & ! [IN]
4316  0 ) ! [IN]
4317 
4318  return
4319  end subroutine jst2utc
4320 
4321  !=======================================================================
4322  !
4323  ! [PURPOSE:] Thinning of radar data
4324  !
4325  ! [HISTORY:] This version produce a superobing of the observations but
4326  ! the data is stored in azimuth , range , elevation. Conversion to the
4327  ! lat , lon , z is performed by the observation operator.
4328  !
4329  ! Modified to produce 1D list of superobservations with lon, lat, z
4330  !
4331  !=======================================================================
4332  subroutine radar_georeference(lon0, lat0, z0, na, nr, ne, azimuth, rrange, elevation, radlon, radlat, radz)
4333  use scale_const, only: &
4334  radius => const_radius, &
4335  d2r => const_d2r, &
4336  r2d => const_r2d
4337  implicit none
4338 
4339  real(rp), parameter :: ke = 4.0_rp / 3.0_rp ! factor for the effective radius of the earth
4340 
4341  real(rp) :: ke_re ! effective radius of the earth [m]
4342 
4343  real(rp), intent(in) :: lon0, lat0, z0
4344  integer, intent(in) :: na, nr, ne
4345  real(rp), intent(in) :: azimuth(na), rrange(nr), elevation(ne)
4346  real(rp), intent(out) :: radlon(na, nr, ne), radlat(na, nr, ne)
4347  real(rp), intent(out) :: radz(na, nr, ne)
4348 
4349  real(rp) sin_elev_ke_re_2, cos_elev_div_ke_re, tmpdist
4350  real(rp) cdist, sdist, sinll1, cosll1, sinll1_cdist, cosll1_sdist, cosll1_cdist, sinll1_sdist
4351  real(rp) :: azimuth_rad, sin_azim(na), cos_azim(na)
4352  integer :: ia, ir, ie
4353 
4354  ke_re = ke * radius
4355 
4356  ! This code is copied from juan ruiz's qc code and modified
4357  sinll1 = sin(lat0 * d2r)
4358  cosll1 = cos(lat0 * d2r)
4359  do ia = 1, na
4360  azimuth_rad = azimuth(ia) * d2r
4361  sin_azim(ia) = sin(azimuth_rad)
4362  cos_azim(ia) = cos(azimuth_rad)
4363  end do
4364 
4365  do ie = 1, ne
4366  sin_elev_ke_re_2 = sin(elevation(ie) * d2r) * ke_re * 2
4367  cos_elev_div_ke_re = cos(elevation(ie) * d2r) / ke_re
4368  do ir = 1, nr
4369  ! Perform standard height beam heigth computation.
4370  radz(:, ir, ie) = z0 + sqrt(rrange(ir) * (rrange(ir) + sin_elev_ke_re_2) + ke_re * ke_re) - ke_re
4371  tmpdist = ke * asin(rrange(ir) * cos_elev_div_ke_re)
4372  if (tmpdist .eq. 0d0) then
4373  radlon(1:na, ir, ie) = lon0
4374  radlat(1:na, ir, ie) = lat0
4375  else
4376  cdist = cos(tmpdist)
4377  sdist = sin(tmpdist)
4378  sinll1_cdist = sinll1 * cdist
4379  cosll1_sdist = cosll1 * sdist
4380  cosll1_cdist = cosll1 * cdist
4381  sinll1_sdist = sinll1 * sdist
4382  do ia = 1, na
4383  radlat(ia, ir, ie) = asin(sinll1_cdist + cosll1_sdist * cos_azim(ia)) * r2d
4384  radlon(ia, ir, ie) = lon0 + atan2(sdist * sin_azim(ia), cosll1_cdist - sinll1_sdist * cos_azim(ia)) * r2d
4385  end do
4386  end if
4387  end do
4388  end do
4389 
4390  return
4391  end subroutine radar_georeference
4392 
4393  !-----------------------------------------------------------------------
4394  ! Main superobing routine
4395  !-----------------------------------------------------------------------
4396  subroutine radar_superobing(na, nr, ne, radlon, radlat, radz, ze, vr, & ! input spherical
4397  & qcflag, attenuation, & ! input spherical 2
4398  & nlon, nlat, nlev, lon, lat, z, dlon, dlat, dz, & ! input cartesian
4399  & missing, input_is_dbz, & ! input param
4400  & lon0, lat0, & ! input param
4401  & nobs_sp, grid_index, & ! output array info
4402  & grid_ref, grid_lon_ref, grid_lat_ref, grid_z_ref, grid_count_ref, & ! output ze
4403  & grid_vr, grid_lon_vr, grid_lat_vr, grid_z_vr, grid_count_vr ) ! output vr
4404  use scale_sort, only: &
4405  sort_uniq_int_sorted
4406  implicit none
4407 
4408  integer, intent(in) :: na, nr, ne ! array size of the spherical grid
4409  real(RP), intent(in), dimension(na, nr, ne) :: radlon, radlat, radz ! georeference
4410  real(RP), intent(in) :: ze(na, nr, ne), vr(na, nr, ne) ! main data
4411  real(RP), intent(in) :: qcflag(na, nr, ne), attenuation(na, nr, ne) ! additional info
4412  integer, intent(in) :: nlon, nlat, nlev ! array size of the cartesian grid
4413  real(RP), intent(in) :: lon(nlon), lat(nlat), z(nlev)
4414  real(RP), intent(in) :: dlon, dlat, dz, missing
4415  logical, intent(in) :: input_is_dbz
4416  real(RP), intent(in) :: lon0, lat0
4417 
4418  integer(8), intent(out) :: nobs_sp
4419  integer(8), allocatable, intent(out) :: grid_index(:), grid_count_ref(:), grid_count_vr(:)
4420  REAL(RP), allocatable, intent(out) :: grid_ref(:), grid_vr(:)
4421  REAL(RP), allocatable, intent(out) :: grid_lon_ref(:), grid_lat_ref(:), grid_z_ref(:) !Lat, Lon and Z weighted by the observations.
4422  REAL(RP), allocatable, intent(out) :: grid_lon_vr(:), grid_lat_vr(:), grid_z_vr(:) !Lat, Lon and Z weighted by the observations.
4423 
4424  REAL(RP), ALLOCATABLE :: grid_w_vr(:)
4425  REAL(RP), ALLOCATABLE :: grid_meanvr(:), grid_stdvr(:) !Non weighted radial velocity and its dispersion within each box.
4426 
4427  integer(8), allocatable :: packed_grid(:), pack2uniq(:), nobs_each_elev(:)
4428  real(RP), allocatable :: packed_data(:, :)
4429  logical, allocatable :: packed_attn(:)
4430 
4431  REAL(RP) :: count_inv, tmpstdvr, tmpmeanvr
4432  integer(8) :: idx, jdx, nobs, sidx(ne), eidx(ne)
4433 
4434  integer :: i
4435  !integer i, e0, e1, ne_mpi
4436  !integer, allocatable :: j_mpi(:, :), sendcount(:), recvcount(:), recvoffset(:)
4437  !integer(8), allocatable :: sendbuf(:), nobs_each_mpi(:)
4438  !integer(8), allocatable :: packed_grid_mpi(:)
4439  !real(RP), allocatable :: packed_data_mpi(:, :)
4440  !logical, allocatable :: packed_attn_mpi(:)
4441 
4442  integer :: ierr
4443 
4444  !allocate(sendcount(0:(mpiprocs - 1)), recvcount(0:(mpiprocs - 1)), recvoffset(0:(mpiprocs - 1)))
4445  !allocate(j_mpi(2, 0:(mpiprocs - 1)))
4446  !call set_mpi_div(j_mpi, mpiprocs, int(ne, 8))
4447  !e0 = j_mpi(1, myrank)
4448  !e1 = j_mpi(2, myrank)
4449  !ne_mpi = e1 - e0 + 1
4450 
4451  ! AVERAGE DATA AND INCLUDE OBSERVATIONA ERROR.
4452  ! We will compute the i,j,k for each radar grid point and box average the
4453  ! data.
4454 
4455  ! QC, Indexing, and packing simultaneously
4456  allocate(nobs_each_elev(ne))
4457  !if(mpiprocs > 1) then
4458  ! allocate(packed_grid_mpi(na * nr * ne_mpi), &
4459  ! & packed_data_mpi(5, na * nr * ne_mpi), &
4460  ! & packed_attn_mpi(na * nr * ne_mpi), &
4461  ! & nobs_each_mpi(e0:e1))
4462  ! call qc_indexing_and_packing( &
4463  ! & na, nr, ne_mpi, ze(:, :, e0:e1), vr(:, :, e0:e1), & ! input spherical
4464  ! & radlon(:, :, e0:e1), radlat(:, :, e0:e1), radz(:, :, e0:e1), & ! input spherical
4465  ! & qcflag(:, :, e0:e1), input_is_dbz, attenuation(:, :, e0:e1), & ! input spherical
4466  ! & nlon, nlat, nlev, lon, lat, z, dlon, dlat, dz, & ! input cartesian
4467  ! & missing, & ! input param
4468  ! & lon0, lat0, &
4469  ! & nobs_each_mpi, packed_grid_mpi, packed_data_mpi, packed_attn_mpi) ! output
4470 
4471  ! sendcount(:) = ne_mpi
4472  ! recvcount(0:(mpiprocs - 1)) = j_mpi(2, 0:(mpiprocs - 1)) - j_mpi(1, 0:(mpiprocs - 1)) + 1
4473  ! recvoffset = j_mpi(1, :) - 1 !START FROM 0
4474  ! call MPI_Allgatherv(nobs_each_mpi, sendcount(0), MPI_INTEGER8, &
4475  ! & nobs_each_elev, recvcount, recvoffset, MPI_INTEGER8, &
4476  ! & comm, ierr)
4477  ! deallocate(nobs_each_mpi)
4478  !else
4479  allocate(packed_grid(na * nr * ne), &
4480  & packed_data(5, na * nr * ne), &
4481  & packed_attn(na * nr * ne))
4482  call qc_indexing_and_packing( &
4483  & na, nr, ne, ze, vr, radlon, radlat, radz, & ! input spherical
4484  & qcflag, input_is_dbz, attenuation, & ! input spherical
4485  & nlon, nlat, nlev, lon, lat, z, dlon, dlat, dz, & ! input cartesian
4486  & missing, & ! input param
4487  & lon0, lat0, &
4488  & nobs_each_elev, packed_grid, packed_data, packed_attn) ! output
4489  !end if
4490  nobs = sum(nobs_each_elev)
4491  sidx(1) = 1
4492  do i = 1, ne - 1
4493  sidx(i + 1) = sidx(i) + nobs_each_elev(i)
4494  end do !i
4495  eidx = sidx + nobs_each_elev - 1
4496  deallocate(nobs_each_elev)
4497  !! MPI packed data
4498  !if(mpiprocs > 1) then
4499  ! sendcount = eidx(e1) - sidx(e0) + 1
4500  ! do i = 0, mpiprocs - 1
4501  ! recvoffset(i) = sidx(j_mpi(1, i)) - 1 !START FROM 0
4502  ! recvcount(i) = eidx(j_mpi(2, i)) - sidx(j_mpi(1, i)) + 1
4503  ! end do
4504  ! allocate(packed_grid(nobs), packed_data(5, nobs), packed_attn(nobs))
4505  ! ! NEEDED BY ALL
4506  ! call MPI_Allgatherv(packed_grid_mpi, sendcount(0), MPI_INTEGER8, &
4507  ! & packed_grid, recvcount, recvoffset, MPI_INTEGER8, &
4508  ! & comm, ierr)
4509  ! ! ONLY NEEDED BY ROOT
4510  ! call MPI_Gatherv(packed_attn_mpi, sendcount(0), MPI_LOGICAL, &
4511  ! & packed_attn, recvcount, recvoffset, MPI_LOGICAL, &
4512  ! & 0, comm, ierr)
4513  ! call MPI_Gatherv(packed_data_mpi, sendcount(0) * 5, datatype, &
4514  ! & packed_data, recvcount * 5, recvoffset * 5, datatype, &
4515  ! & 0, comm, ierr)
4516  ! deallocate(packed_grid_mpi, packed_data_mpi, packed_attn_mpi)
4517 
4518  !end if
4519 
4520  ! Sort index array
4521  allocate(grid_index(nobs))
4522  do idx = 1, nobs
4523  grid_index(idx) = packed_grid(idx)
4524  end do
4525  !if(mpiprocs > 1) then
4526  ! call merge_sort_mpi(nobs, grid_index, comm) !ONLY RANK 0 RETURNS DATA
4527  ! call MPI_Bcast(grid_index, int(nobs), MPI_INTEGER8, 0, comm, ierr)
4528  !else
4529  call merge_sort_parallel(nobs, grid_index)
4530  !end if
4531 
4532  ! Unique superobs (nobs_sp)
4533  call sort_uniq_int_sorted(nobs, grid_index, nobs_sp)
4534 
4535  ! Inverted indexing
4536  allocate(pack2uniq(nobs))
4537  !call set_mpi_div(j_mpi, mpiprocs, nobs)
4538  !allocate(sendbuf(j_mpi(2, myrank) - j_mpi(1, myrank) + 1))
4539  !do idx = j_mpi(1, myrank), j_mpi(2, myrank)
4540  ! sendbuf(idx - j_mpi(1, myrank) + 1) = binary_search_i8(nobs_sp, grid_index, packed_grid(idx))
4541  do idx = 1, nobs
4542  pack2uniq(idx) = binary_search_i8(nobs_sp, grid_index, packed_grid(idx))
4543  end do
4544  !sendcount(:) = j_mpi(2, myrank) - j_mpi(1, myrank) + 1
4545  !recvcount(0:(mpiprocs - 1)) = j_mpi(2, 0:(mpiprocs - 1)) - j_mpi(1, 0:(mpiprocs - 1)) + 1
4546  !recvoffset = j_mpi(1, :) - 1
4547  !! ONLY NEEDED BY ROOT
4548  !call MPI_Gatherv(sendbuf, sendcount(0), MPI_INTEGER8, &
4549  ! & pack2uniq, recvcount, recvoffset, MPI_INTEGER8, &
4550  ! & 0, comm, ierr)
4551  !deallocate(j_mpi, sendbuf, sendcount, recvcount, recvoffset) !END OF MPI
4552 
4553  ! Allocate output arrays
4554  allocate(grid_ref(nobs_sp), grid_vr(nobs_sp))
4555  allocate(grid_count_ref(nobs_sp), grid_count_vr(nobs_sp))
4556  allocate(grid_lon_ref(nobs_sp), grid_lat_ref(nobs_sp), grid_z_ref(nobs_sp))
4557  allocate(grid_lon_vr(nobs_sp) , grid_lat_vr(nobs_sp) , grid_z_vr(nobs_sp))
4558  allocate(grid_w_vr(nobs_sp))
4559  allocate(grid_meanvr(nobs_sp), grid_stdvr(nobs_sp))
4560 
4561  !if(myrank > 0) return !ONLY RANK 0 DOES THE REMAINING WORK
4562 
4563  !Initialize arrays
4564  do idx = 1, nobs_sp
4565  grid_count_ref(idx) = 0
4566  grid_count_vr(idx) = 0
4567  grid_ref(idx) = 0.0d0
4568  grid_vr(idx) = 0.0d0
4569  grid_w_vr(idx) = 0.0d0
4570  grid_lon_ref(idx) = 0.0d0
4571  grid_lat_ref(idx) = 0.0d0
4572  grid_z_ref(idx) = 0.0d0
4573  grid_lon_vr(idx) = 0.0d0
4574  grid_lat_vr(idx) = 0.0d0
4575  grid_z_vr(idx) = 0.0d0
4576  grid_meanvr(idx) = 0.0d0
4577  grid_stdvr(idx) = 0.0d0
4578  end do
4579 
4580  do jdx = 1, nobs
4581  idx = pack2uniq(jdx)
4582  ! PROCESS REFLECITIVITY
4583  ! use attenuation estimates / ignore estimates
4584  if(packed_attn(jdx)) then
4585  grid_ref(idx) = grid_ref(idx) + packed_data(1, jdx)
4586  grid_count_ref(idx) = grid_count_ref(idx) + 1
4587  grid_lon_ref(idx) = grid_lon_ref(idx) + packed_data(3, jdx)
4588  grid_lat_ref(idx) = grid_lat_ref(idx) + packed_data(4, jdx)
4589  grid_z_ref(idx) = grid_z_ref(idx) + packed_data(5, jdx)
4590  ENDIF
4591 
4592  ! CONSIDER THE RADIAL VELOCITY
4593  ! Wind will be averaged using an average weighted by returned power.
4594  ! (this should reduce noise).
4595  IF(packed_data(2, jdx) .GT. missing) THEN !PROCESS WIND
4596  grid_w_vr(idx) = grid_w_vr(idx) + packed_data(1, jdx)
4597  grid_count_vr(idx) = grid_count_vr(idx) + 1
4598  grid_meanvr(idx) = grid_meanvr(idx) + packed_data(2, jdx)
4599  grid_stdvr(idx) = grid_stdvr(idx) + packed_data(2, jdx) ** 2
4600  grid_vr(idx) = grid_vr(idx) + packed_data(2, jdx) * packed_data(1, jdx)
4601  grid_lon_vr(idx) = grid_lon_vr(idx) + packed_data(3, jdx) * packed_data(1, jdx)
4602  grid_lat_vr(idx) = grid_lat_vr(idx) + packed_data(4, jdx) * packed_data(1, jdx)
4603  grid_z_vr(idx) = grid_z_vr(idx) + packed_data(5, jdx) * packed_data(1, jdx)
4604  ENDIF
4605  ENDDO !jdx
4606 
4607  ! Average data and write observation file (FOR LETKF)
4608  DO idx = 1, nobs_sp
4609  IF(grid_count_ref(idx) > 0) THEN !Process reflectivity
4610  count_inv = 1.0d0 / dble(grid_count_ref(idx))
4611  grid_ref(idx) = grid_ref(idx) * count_inv
4612  grid_lon_ref(idx) = grid_lon_ref(idx) * count_inv
4613  grid_lat_ref(idx) = grid_lat_ref(idx) * count_inv
4614  grid_z_ref(idx) = grid_z_ref(idx) * count_inv
4615  ENDIF
4616 
4617  IF(grid_count_vr(idx) > 0) THEN
4618  count_inv = 1.0d0 / grid_w_vr(idx)
4619  grid_vr(idx) = grid_vr(idx) * count_inv
4620  grid_lon_vr(idx) = grid_lon_vr(idx) * count_inv
4621  grid_lat_vr(idx) = grid_lat_vr(idx) * count_inv
4622  grid_z_vr(idx) = grid_z_vr(idx) * count_inv
4623 
4624  ! If variability within a box is big then we may have:
4625  ! -small scale strong phenomena (tornado!)
4626  ! -noise in the data.
4627  ! In any case averaging the data is not a god idea so this data
4628  ! can be rejected a priori.
4629  IF( radar_use_vr_std ) THEN
4630  count_inv = 1.0d0 / dble(grid_count_vr(idx))
4631  tmpmeanvr = grid_meanvr(idx) * count_inv
4632  tmpstdvr = grid_stdvr(idx) * count_inv
4633  tmpstdvr = sqrt(tmpstdvr - (tmpmeanvr ** 2))
4634  IF(tmpstdvr > vr_std_threshold) grid_count_vr(idx) = 0 !Reject the observation.
4635  ENDIF
4636  end IF
4637  end do
4638 
4639  return
4640  end SUBROUTINE radar_superobing
4641 
4642  !-----------------------------------------------------------------------
4643  ! Define grid
4644  !-----------------------------------------------------------------------
4645  subroutine define_grid(lon0, lat0, nr, rrange, maxrange, maxz, dx, dy, dz, & ! input
4646  & dlon, dlat, nlon, nlat, nlev, lon, lat, z) ! output
4647  use scale_const, only: &
4648  radius => const_radius, &
4649  d2r => const_d2r, &
4650  r2d => const_r2d
4651  implicit none
4652  real(RP), intent(in) :: lon0, lat0
4653  integer, intent(in) :: nr
4654  real(RP), intent(in) :: rrange(nr)
4655  real(RP), intent(in) :: maxrange, maxz, dx, dy, dz
4656  real(RP), intent(out) :: dlon, dlat
4657  integer, intent(out) :: nlon, nlat, nlev
4658  real(RP), allocatable, intent(out) :: lon(:), lat(:), z(:)
4659  real(RP) :: tmpmaxrange
4660 
4661  integer :: i, j, k
4662 
4663  ! Translate DX into an appropiate DLON and DLAT.
4664  ! Hopefully nobody will put a radar at the pole.
4665  dlon = r2d * dx / (cos(lat0 * d2r) * radius)
4666  dlat = r2d * dx / radius
4667 
4668  ! Compute possible value for NLON in order to cover the maximum radar range.
4669  tmpmaxrange = maxrange
4670  tmpmaxrange = min(tmpmaxrange, rrange(nr))
4671  tmpmaxrange = 2.0 * tmpmaxrange
4672  nlon = ceiling(tmpmaxrange / dx)
4673  nlat = ceiling(tmpmaxrange / dy)
4674  nlev = ceiling(maxz / dz)
4675 
4676  allocate(lon(nlon), lat(nlat), z(nlev))
4677 
4678  ! Force grid dimensions to be odd
4679  IF( mod(nlon,2) == 0 ) nlon = nlon + 1
4680  IF( mod(nlat,2) == 0 ) nlat = nlat + 1
4681 
4682  do i = 1, nlon
4683  lon(i) = lon0 + dlon * (-1.0 - (nlon - 1.0) / 2.0 + i)
4684  end do
4685 
4686  do j = 1, nlat
4687  lat(j) = lat0 + dlat * (-1.0 - (nlat - 1.0) / 2.0 + j)
4688  end DO
4689 
4690  do k = 1, nlev
4691  z(k) = dz * (k - 1)
4692  end do
4693 
4694  end subroutine define_grid
4695 
4696  !-----------------------------------------------------------------------
4697  ! Compute radar reflectivity and radial wind.
4698  ! Radial wind computations for certain methods depend on model reflectivity
4699  ! so both functions has been merged into a single one.
4700  ! First reflectivity is computed, and the the radial velocity is computed.
4701  !-----------------------------------------------------------------------
4702  subroutine calc_ref_vr(qv,qc,qr,qci,qs,qg,u,v,w,t,p,az,elev,ref,vr)
4703  use scale_const, only: &
4704  pi => const_pi, &
4705  grav => const_grav, &
4706  d2r => const_d2r, &
4707  r2d => const_r2d, &
4708  rdry => const_rdry
4709  implicit none
4710  real(RP), intent(in) :: qv !Water vapor
4711  real(RP), intent(in) :: qc,qr !Cloud and rain water
4712  real(RP), intent(in) :: qci,qs,qg !Cloud ice, snow and graupel
4713  real(RP), intent(in) :: t,p !Temperature and pressure.
4714  real(RP), intent(in) :: u,v,w !velocities with respecto to earth.
4715  real(RP), intent(inout) :: ref !Reflectivity.
4716  real(RP) :: ro
4717  real(RP), intent(in) :: az !Azimuth respect to the radar.
4718  real(RP), intent(in) :: elev !Elevation angle respect to the surface.
4719  real(RP), intent(inout) :: vr !Radial velocity.
4720  real(RP) :: qms , qmg !Melting species concentration (METHOD_REF_CALC 3)
4721  real(RP) :: qt !Total condensate mixing ratio (METHOD_REF_CALC 1)
4722  real(RP) :: zr , zs , zg !Rain, snow and graupel's reflectivities.
4723  real(RP) :: wr , ws , wg !Rain, snow and graupel's mean terminal velocities.
4724  real(RP) :: wt !Total mean terminal velocity.
4725  real(RP) :: nor, nos, nog !Rain, snow and graupel's intercepting parameters.
4726  real(RP) :: ror, ros, rog , roi !Rain, snow and graupel, ice densities.
4727  real(RP) :: a,b,c,d,Cd !Constant for fall speed computations.
4728  real(RP) :: cr_t08,cs_t08,cg_t08,dr_t08,ds_t08,dg_t08 !Constant for fall speed computations (Tomita2008)
4729  real(RP) :: cf, pip , roo
4730  real(RP) :: ki2 , kr2
4731  real(RP) :: lr , ls , lg
4732  real(RP) :: tmp_factor , rofactor
4733  real(RP) :: p0
4734  real(RP) :: Fs, Fg , zms , zmg , fws , fwg !METHOD_REF_CALC 3
4735  real(RP) :: qrp , qsp , qgp
4736  real(RP) :: maxf !Maximum mixture relative concentration. (METHOD_REF_CALC 3)
4737 
4738  real(RP) , parameter :: qeps = 1.0d-20 !Avoid overflow
4739 
4740  real(RP) , parameter :: as_RS14 = 6.9d-2
4741  real(RP) :: tc , MOMs_0bs
4742 
4743  !Note: While equivalent reflectivity is assumed to be independent of the radar, in
4744  !practice short wavelengths as those associated with K band radars migh frequently
4745  !experience Mie scattering. In that case, the equivalent reflectivity is not longer
4746  !radar independent and an appropiate relationship between the forecasted concentrations
4747  !and the reflectivity should be used.
4748 
4749  !This model reflectivity won't be lower than this value.
4750 
4751  !Initialize reflectivities
4752  zr=0.0d0
4753  zs=0.0d0
4754  zg=0.0d0
4755  zms=0.0d0
4756  zmg=0.0d0
4757  ref=0.0d0
4758 
4759  !Compute air density (all methods use this)
4760 
4761  ro = p / ( rdry * t)
4762 
4763 
4764  !Begin computation of reflectivity and vr
4765 
4766  if (method_ref_calc == 1) then
4767 
4768  !WRF method: See for example Sugimoto et al. Evaluation of the Performance of Ra
4769  !dial Velocity Assimilation with WRF-3DVAR System and Simulated Multiple-Doppler
4770  !Radar Data
4771  !Only rain is used to estimate the terminal velocity of hidrometeors.
4772  !Only rain is used to compute equivalent reflectivity.
4773  !Marshall-Palmer distributions are assumed to find the relationship bestween
4774  !concentration and equivalent reflectivity.
4775  ! Sun and Crook 1997 , 1998.
4776  !Derived for C-band radars.
4777  !Attenuation is not computed.
4778 
4779  !Reflectivity
4780  nor=8.0d6 ![m^-4]
4781  ror=1000.0d0 ![Kg/m3]
4782  pip= pi ** 1.75 !factor
4783  cf =10.0d18 * 72 !factor
4784  p0=1.0d5 !Reference pressure.
4785 
4786  qt=qr + qs + qg !Assume that the total condensate is rain water
4787  !But ignore cloud ice and cloud water
4788 
4789  IF( qt .GT. qeps )THEN
4790  ref = cf * ( ( ro * qt )**1.75 )
4791  ref = ref / ( pip * ( nor ** 0.75 ) * ( ror ** 1.75 ) )
4792  !ref= 2.04d4 *( ( ro * qt * 1.0d3 ) ** 1.75 ) !Original Sun and Crook expresion.
4793  ELSE
4794  ref=0.0d0
4795  ENDIF
4796 
4797  !Radial wind
4798 
4799  IF ( qt .GT. qeps )THEN
4800  a=(p0/p)**0.4
4801  wt = 5.40d0 * a * ( qt ** 0.125 )
4802  ELSE
4803  wt=0d0
4804  ENDIF
4805 
4806 
4807  else if (method_ref_calc == 2) then
4808  !Observation operator from Tong and Xue 2006, 2008 a and b.
4809  !Based on Smith et al 1975.
4810  !It includes reflectivity contribution by all the microphisical species.
4811  !is assumes Marshall and Palmer distributions.
4812  !Based on C band radars.
4813  !Attenuation is not computed.
4814  nor=8.0d6 ![m^-4]
4815  nos=3.0d6 ![m^-4]
4816  nog=4.0d4 ![m^-4]
4817  ror=1000.0d0 ![Kg/m3]
4818  ros=100.0d0 ![Kg/m3]
4819  rog=913.0d0 ![Kg/m3]
4820  roi=917.0d0 ![Kg/m3]
4821  roo=1.0d0 ![Kg/m3] Surface air density.
4822  ki2=0.176d0 !Dielectric factor for ice.
4823  kr2=0.930d0 !Dielectric factor for water.
4824  pip= pi ** 1.75 !factor
4825  cf =1.0d18 * 720 !factor
4826 
4827  IF( qr .GT. qeps )THEN
4828  zr= cf * ( ( ro * qr )**1.75 )
4829  zr= zr / ( pip * ( nor ** 0.75 ) * ( ror ** 1.75 ) )
4830  ENDIF
4831  !The contribution of snow depends on temperature (bright band effect)
4832  IF( qs .GT. qeps )THEN
4833  IF ( t <= 273.16 )THEN
4834  zs = cf * ki2 * ( ros ** 0.25 ) * ( ( ro * qs ) ** 1.75 )
4835  zs = zs / ( pip * kr2 * ( nos ** 0.75 ) * ( roi ** 2 ) )
4836  ELSE
4837  !WARNING: This formulation has to be checked the paper says that
4838  !ros instead of roi should be used in thes expresion, but that
4839  !leads to unrealistic jumps in the model derived reflectivity.
4840  zs = cf * ( ( ro * qs ) ** 1.75 )
4841  zs = zs / ( pip * ( nos ** 0.75 ) * ( roi ** 1.75 ) )
4842  ENDIF
4843  ENDIF
4844 
4845  !Only dry graupel contribution is ussed.
4846  IF( qg .GT. qeps )THEN
4847  zg= ( cf / ( pip * ( nog ** 0.75) * ( rog ** 1.75 ) ) ) ** 0.95
4848  zg= zg * ( ( ro * qg ) ** 1.6625 )
4849  ENDIF
4850 
4851  ref = zr + zs + zg
4852 
4853  !Compute reflectivity weigthed terminal velocity.
4854  !Lin et al 1983.
4855  IF( ref > 0.0d0 )THEN
4856  !There are hidrometeors, compute their terminal velocity.
4857  !Change units to be consistent with Lin et al 1983 and
4858  !to obtain wt in m/s
4859  nor=nor*1e-3 ![cm^-4]
4860  nos=nos*1e-3 ![cm^-4]
4861  nog=nog*1e-3 ![cm^-4]
4862  ror=ror*1e-3 ![g/cm3]
4863  ros=ros*1e-3 ![g/cm3]
4864  rog=rog*1e-3 ![g/cm3]
4865  roo=roo*1e-3 ![g/cm3] Surface air density.
4866  ro= ro*1e-3
4867 
4868  a=2115d0 ![cm**1-b / s]
4869  b=0.8d0
4870  c=152.93d0 ![cm**1-b / s]
4871  d=0.25d0
4872  cd=0.6d0
4873 
4874  rofactor= ( roo / ro ) ** 0.25
4875  if(qr > qeps )then
4876  CALL com_gamma( 4.0_rp + b , tmp_factor )
4877  lr= ( pi * ror * nor / ( ro * qr ) ) ** 0.25
4878  wr= a * tmp_factor / ( 6.0d0 * ( lr ** b ) )
4879  wr= 1.0d-2*wr * rofactor
4880  else
4881  wr = 0.0d0
4882  endif
4883 
4884  if(qs > qeps )then
4885  CALL com_gamma( 4.0_rp + d , tmp_factor )
4886  ls= ( pi * ros * nos / ( ro * qs ) ) ** 0.25
4887  ws= c * tmp_factor / ( 6.0d0 * ( ls ** d ) )
4888  ws= 1.0d-2*ws * rofactor
4889  else
4890  ws = 0.0d0
4891  endif
4892 
4893  if(qg > qeps )then
4894  CALL com_gamma( 4.5_rp , tmp_factor )
4895  lg= ( pi * rog * nog / ( ro * qg ) ) ** 0.25
4896  wg= tmp_factor * ( ( ( 4.0d0 * grav * 100.0d0 * rog )/( 3.0d0 * cd * ro ) ) ** 0.5 )
4897  wg= 1.0d-2*wg / ( 6.0d0 * ( lg ** 0.5 ) )
4898  else
4899  wg = 0.0d0
4900  endif
4901 
4902  !Reflectivity weighted terminal velocity.
4903  wt = ( wr * zr + ws * zs + wg * zg )/ ( zr + zs + zg )
4904 
4905  ELSE
4906 
4907  wt=0.0d0
4908 
4909  ENDIF
4910 
4911  else if (method_ref_calc == 3) then
4912  !Observation operator from Xue et al 2007
4913  !Asumes power law between Z and mass concentration of different
4914  !hydrometeor categories.
4915  !Derived for X-Band radars tacking into account Mie scattering.
4916  !Includes a computation of the attenuation. (k)
4917 
4918  maxf=0.5d0
4919 
4920  !First we need to compute the mixtures between rain, snow and hail
4921  !Following Jung et al 2007 eq (2) and (3)
4922  fg=0.0d0
4923  fs=0.0d0
4924  fwg=0.0d0
4925  fws=0.0d0
4926  IF( qr .GT. qeps .AND. qg .GT. qeps)THEN
4927  fg=maxf * ( min( qr/qg , qg/qr ) )**(1.0d0/3.0d0)
4928  fwg= qr / ( qr + qg )
4929  ENDIF
4930  IF( qr .GT. qeps .AND. qs .GT. qeps)THEN
4931  fs=maxf * ( min( qr/qs , qs/qr ) )**(1.0d0/3.0d0)
4932  fws= qr / ( qr + qs )
4933  ENDIF
4934 
4935  if ( .not. use_method3_ref_melt ) then
4936  fs = 0.0_rp
4937  fg = 0.0_rp
4938  endif
4939 
4940  !Correct the rain, snow and hail mixing ratios assuming
4941  !that we have a mixture due to melting.
4942 
4943  qrp=(1.0d0-fs-fg)*qr
4944 
4945  qsp=(1.0d0-fs)*qs
4946 
4947  qgp=(1.0d0-fg)*qg
4948 
4949  !Compute the new species resulting from melting.
4950 
4951  qms=fs * (qr + qs) !Melting snow concentration.
4952 
4953  qmg=fg * (qr + qg) !Melting hail concentration.
4954 
4955  !Compute reflectivities for each species including the melting species.
4956 
4957  IF( qrp .GT. qeps)THEN
4958  zr= 2.53d4 * ( ro * qrp * 1.0d3 )**1.84
4959  ENDIF
4960  IF( qsp .GT. qeps)THEN
4961  zs= 3.48d3 * ( ro * qsp * 1.0d3 )**1.66
4962  ENDIF
4963  IF( qgp .GT. qeps)THEN
4964  zg= 5.54d3 * ( ro * qgp * 1.0d3 )**1.70 !!! graupel (A.Amemiya 2019)
4965  ENDIF
4966  IF( qms .GT. qeps )THEN
4967  zms=( 0.00491 + 5.75*fws - 5.588*(fws**2) )*1.0d5
4968  zms= zms * ( ro * qms * 1.0d3 )**( 1.67 - 0.202*fws + 0.398*(fws**2) )
4969 
4970  ENDIF
4971  IF( qmg .GT. qeps )THEN
4972  zmg=( 0.0358 + 5.27*fwg -9.51*(fwg**2) + 4.68 *(fwg**3) )*1.0d5
4973  zmg= zmg * ( ro * qmg * 1.0d3 )**( 1.70 + 0.020*fwg + 0.287 * (fwg**2) - 0.186*(fwg**3) ) !!! graupel (A. Amemiya 2020)
4974  ENDIF
4975 
4976  ref = zr + zg + zs + zms + zmg
4977 
4978  !Compute reflectivity weigthed terminal velocity.
4979  !Lin et al 1983. (The distribution parameters are
4980  !consistent with the work of Jung et al 2007)
4981 
4982  !!! graupel paramters and terminal velocity equations are modified to be
4983  !!! consistent with Tomita2008 default settings
4984 
4985  IF( ref > 0.0d0 )THEN
4986  !There are hidrometeors, compute their terminal velocity.
4987  !Units according to Lin et al 1983.
4988  nor=8.0d-2 ![cm^-4]
4989  nos=3.0d-2 ![cm^-4]
4990  nog=4.0d-2 ![cm^-4] !!!!! Tomita 2008
4991  ror=1.0d0 ![g/cm3]
4992  ros=0.1d0 ![g/cm3]
4993  rog=0.400d0 ![g/cm3] !!!!! Tomita 2008
4994  roo=1.28 * 0.001d0 ![g/cm3] Surface air density. !!! Tomita 2008
4995  ro=1.0d-3 * ro
4996  cd=0.6d0 !!!!! drag_g in SCALE
4997 
4998  cr_t08=130.0d0 ![m**1-b / s] !!! SCALE default
4999  dr_t08=0.5d0
5000  cs_t08=4.84d0 ![m**1-b / s]
5001  ds_t08=0.25d0
5002  dg_t08=0.5d0 !!! SCALE default
5003 
5004 
5005  rofactor= ( roo / ro ) ** 0.5
5006 
5007  IF ( qr .GT. qeps )THEN
5008  lr= ( pi * ror * nor / ( ro * qr ) ) ** 0.25 !!! [cm ^-1]
5009  CALL com_gamma( 4.0_rp + dr_t08 , tmp_factor )
5010  wr= cr_t08 * tmp_factor / ( 6.0d0 * ( ( lr * 1.0e2 ) ** dr_t08 ) ) !!! [m/s]
5011  wr= wr * rofactor
5012  ELSE
5013  wr=0.0d0
5014  ENDIF
5015 
5016  IF( qs .GT. qeps )THEN
5017  IF ( use_t08_rs2014 ) then
5018  tc=min(-0.1_rp, t-273.15_rp)
5019  moms_0bs = exp(log(10.0_rp) * loga_(tc,2.0_rp) + log(ro * qs / as_rs14) * b_(tc,2.0_rp) )
5020  ws = cs_t08 * rofactor * exp(log(10.0_rp) * loga_(tc,2.25_rp) + log(ro * qs / as_rs14) * b_(tc,2.25_rp) ) / moms_0bs
5021  ELSE
5022  ls= ( pi * ros * nos / ( ro * qs ) ) ** 0.25 !!! [cm ^-1]
5023  CALL com_gamma( 4.0_rp + ds_t08 , tmp_factor )
5024  ws= cs_t08 * tmp_factor / ( 6.0d0 * ( ( ls * 1.0e2 ) ** ds_t08 ) ) !!! [m/s]
5025  ws= ws * rofactor
5026  ENDIF
5027  ELSE
5028  ws=0.0d0
5029  ENDIF
5030 
5031 
5032  IF ( qg .GT. qeps )THEN
5033  lg= ( pi * rog * nog / ( ro * qg ) ) ** 0.25
5034  CALL com_gamma( 4.0_rp + dg_t08 , tmp_factor )
5035  wg = tmp_factor * ( ( ( 4.0d0 * grav * rog )/( 3.0d0 * cd * roo ) ) ** 0.5 ) !!! fixed 2021.5.14
5036  wg = wg / ( 6.0d0 * ( ( lg * 1.0e2 ) ** dg_t08 ) ) !!! [m/s]
5037  wg= wg * rofactor
5038  ELSE
5039  wg=0.0d0
5040  ENDIF
5041 
5042  !Reflectivity weighted terminal velocity.
5043  !The melting species are assumed to fail as their non-melting counterparts.
5044  !however this might not be the case for melting snow.
5045  wt = ( wr * zr + ws * zs + ws * zms + wg * zg + wg * zmg ) / ( zr + zs + zg + zms + zmg )
5046 
5047  ELSE
5048 
5049  wt=0.0d0
5050 
5051  ENDIF
5052 
5053  else !IF OVER DIFFERENT OPTIONS
5054 
5055  WRITE(6,*)'[Error] Not recognized method for radar reflectivity and wind computation'
5056  stop
5057 
5058  end if ! [METHOD_REF_CALC == ?]
5059 
5060 
5061  !Compute radial velocity
5062  !WRITE(6,*)'ICRV',u,v,w,wt,az,elev
5063  vr = u * cos(elev*d2r) * sin(az*d2r)
5064  vr = vr + v * cos(elev*d2r) * cos(az*d2r)
5065  IF( use_terminal_velocity )THEN
5066  vr = vr + (w - wt)*sin(elev*d2r)
5067  ELSE
5068  vr = vr + (w)*sin(elev*d2r)
5069  ENDIF
5070 
5071  !!! NaN check
5072  if (.not.(abs(vr) .lt. 1.0e20)) then
5073  write(*,*) '***ERROR*** vr is NaN'
5074  write(*,*) vr
5075  write(*,*) wr,wg,ws
5076  write(*,*) lr,lg,ls
5077  write(*,*) zr,zg,zs,zms,zmg
5078  write(*,*) u,v,w,wt
5079  WRITE(6,*) elev , az , d2r
5080  stop
5081  elseif (.not. (abs(ref) .lt. 1.0e20)) then
5082  write(*,*) '***ERROR*** ref is NaN'
5083  write(*,*) ref
5084  write(*,*) zr, zg, zs, zms, zmg
5085  stop
5086  elseif (ref < 0.0) then
5087  write(*,*) '***ERROR*** ref is negative'
5088  write(*,*) ref
5089  write(*,*) zr, zg, zs, zms, zmg
5090  stop
5091  end if
5092 
5093  return
5094 
5095  contains
5096  !-----------------------------------------------------------------------
5097  ! GAMMA FUNCTION
5098  !-----------------------------------------------------------------------
5099  !==================================================
5100  ! Purpose: Compute the gamma function $BC"(B(x)
5101  ! Input : x --- Argument of $BC"(B(x)
5102  ! ( x is not equal to 0,-1,-2,$BC:C:C:(B )
5103  ! Output: GA --- $BC"(B(x)
5104  !==================================================
5105  ! Proff. Jianming Jin
5106  ! Department of Electrical and Computer Engineering
5107  ! University of Illinois
5108  subroutine com_gamma(x,ga)
5109  implicit none
5110  real(RP) :: x , ga
5111  real(RP) :: g(26)
5112  real(RP) :: z , r , gr
5113  integer :: m1, k , m
5114 
5115  !dimension g(26)
5116  if (x.eq.int(x)) then
5117  if (x.gt.0.0d0) then
5118  ga=1.0d0
5119  m1=x-1
5120  do k=2,m1
5121  ga=ga*k
5122  end do
5123  else
5124  ga=huge(1.0_rp)
5125  endif
5126  else
5127 
5128  if (abs(x).gt.1.0_rp) then
5129  z=abs(x)
5130  m=int(z)
5131  r=1.0_rp
5132  do k=1,m
5133  r=r*(z-k)
5134  end do
5135  z=z-m
5136  else
5137  z=x
5138  endif
5139  g(:) = (/ &
5140  1.0, &
5141  0.5772156649015329e0, &
5142  -0.6558780715202538e0, &
5143  -0.420026350340952e-1, &
5144  0.1665386113822915e0, &
5145  -0.421977345555443e-1, &
5146  -0.96219715278770e-2, &
5147  0.72189432466630e-2, &
5148  -0.11651675918591e-2, &
5149  -0.2152416741149e-3, &
5150  0.1280502823882e-3, &
5151  -0.201348547807e-4, &
5152  -0.12504934821e-5, &
5153  0.11330272320e-5, &
5154  -0.2056338417e-6, &
5155  0.61160950e-8, &
5156  0.50020075e-8, &
5157  -0.11812746e-8, &
5158  0.1043427e-9, &
5159  0.77823e-11, &
5160  -0.36968e-11, &
5161  0.51e-12, &
5162  -0.206e-13, &
5163  -0.54e-14, &
5164  0.14e-14, &
5165  0.1e-15 /)
5166  gr=g(26)
5167  do k=25,1,-1
5168  gr=gr*z+g(k)
5169  end do
5170  ga=1.0d0/(gr*z)
5171  if (abs(x).gt.1.0_rp) then
5172  ga=ga*r
5173  if (x.lt.0.0_rp) ga=-pi/(x*ga*sin(pi*x))
5174  endif
5175  endif
5176 
5177  return
5178  end subroutine com_gamma
5179 
5180  function loga_(tems, nm)
5181  real(RP) :: loga_
5182  real(RP) :: tems
5183  real(RP) :: nm
5184  real(RP), parameter :: coef_a01 = 5.065339_rp
5185  real(RP), parameter :: coef_a02 = -0.062659_rp
5186  real(RP), parameter :: coef_a03 = -3.032362_rp
5187  real(RP), parameter :: coef_a04 = 0.029469_rp
5188  real(RP), parameter :: coef_a05 = -0.000285_rp
5189  real(RP), parameter :: coef_a06 = 0.31255_rp
5190  real(RP), parameter :: coef_a07 = 0.000204_rp
5191  real(RP), parameter :: coef_a08 = 0.003199_rp
5192  real(RP), parameter :: coef_a09 = 0.0_rp
5193  real(RP), parameter :: coef_a10 = -0.015952_rp
5194  real(RP) :: coef_at(4)
5195 
5196  coef_at(1) = coef_a01 + tems * ( coef_a02 + tems * ( coef_a05 + tems * coef_a09 ) )
5197  coef_at(2) = coef_a03 + tems * ( coef_a04 + tems * coef_a07 )
5198  coef_at(3) = coef_a06 + tems * coef_a08
5199  coef_at(4) = coef_a10
5200  loga_ = coef_at(1) + nm * ( coef_at(2) + nm * ( coef_at(3) + nm * coef_at(4) ) )
5201 
5202  end function loga_
5203 
5204  function b_(tems, nm)
5205  real(RP) :: b_
5206  real(RP) :: tems
5207  real(RP) :: nm
5208  real(RP), parameter :: coef_b01 = 0.476221_rp
5209  real(RP), parameter :: coef_b02 = -0.015896_rp
5210  real(RP), parameter :: coef_b03 = 0.165977_rp
5211  real(RP), parameter :: coef_b04 = 0.007468_rp
5212  real(RP), parameter :: coef_b05 = -0.000141_rp
5213  real(RP), parameter :: coef_b06 = 0.060366_rp
5214  real(RP), parameter :: coef_b07 = 0.000079_rp
5215  real(RP), parameter :: coef_b08 = 0.000594_rp
5216  real(RP), parameter :: coef_b09 = 0.0_rp
5217  real(RP), parameter :: coef_b10 = -0.003577_rp
5218  real(RP) :: coef_bt(4)
5219 
5220  coef_bt(1) = coef_b01 + tems * ( coef_b02 + tems * ( coef_b05 + tems * coef_b09 ) )
5221  coef_bt(2) = coef_b03 + tems * ( coef_b04 + tems * coef_b07 )
5222  coef_bt(3) = coef_b06 + tems * coef_b08
5223  coef_bt(4) = coef_b10
5224  b_ = coef_bt(1) + nm * ( coef_bt(2) + nm * ( coef_bt(3) + nm * coef_bt(4) ) )
5225 
5226  end function b_
5227 
5228  end subroutine calc_ref_vr
5229 
5230  !-------------------------------------------------------------------------------
5231  ! Find local observations to be used for a targeted grid
5232  !-------------------------------------------------------------------------------
5233  ! [INPUT]
5234  ! ri : horizontal i-grid cooridnate of the targeted grid
5235  ! rj : horizontal j-grid cooridnate of the targeted grid
5236  ! rlev : vertical pressure of the targeted grid
5237  ! rz : vertical height of the targeted grid
5238  ! nvar : variable index of the targeted grid
5239  ! srch_q0 : (optional) first guess of the multiplier of incremental search distances
5240  ! [OUT]
5241  ! hdxf : fcstast ensemble perturbations in the observation space
5242  ! rdiag : localization-weighted observation error variances
5243  ! rloc : localization weights
5244  ! dep : observation departure
5245  ! nobsl : number of valid observations (in hdxf, rdiag, rloc, dep)
5246  ! depd : (optional) observation departure for the deterministic run
5247  ! nobsl_t : (optional) number of assimilated observations wrt. observation variables/types
5248  ! cutd_t : (optional) cutoff distance of assimilated observations wrt. observation variables/types
5249  ! srch_q0 : (optional) revised first guess of the multiplier of incremental search distances for the next call
5250  !-------------------------------------------------------------------------------
5251  subroutine obs_local(obs, ri, rj, rlev, rz, nvar, hdxf, rdiag, rloc, dep, nobsl, depd, nobsl_t, cutd_t, srch_q0)
5252  use scale_sort, only: &
5253  sort_quickselect_desc_arg, &
5254  sort_quickselect_arg
5255  implicit none
5256 
5257  type(obs_info), intent(in) :: obs(:)
5258  real(RP), intent(in) :: ri, rj, rlev, rz
5259  integer, intent(in) :: nvar
5260  real(RP), intent(out) :: hdxf(nobstotal,nmem)
5261  real(RP), intent(out) :: rdiag(nobstotal)
5262  real(RP), intent(out) :: rloc(nobstotal)
5263  real(RP), intent(out) :: dep(nobstotal)
5264  integer, intent(out) :: nobsl
5265  real(RP), intent(out), optional :: depd(nobstotal)
5266  integer, intent(out), optional :: nobsl_t(nid_obs,nobtype)
5267  real(RP), intent(out), optional :: cutd_t(nid_obs,nobtype)
5268  integer, intent(inout), optional :: srch_q0(nctype)
5269 
5270  integer, allocatable :: nobs_use(:)
5271  integer, allocatable :: nobs_use2(:)
5272  real(RP), allocatable :: dist_tmp(:)
5273  real(RP), allocatable :: rloc_tmp(:)
5274  real(RP), allocatable :: rdiag_tmp(:)
5275 
5276  real(RP) :: nrloc, nrdiag
5277  real(RP) :: ndist_dummy
5278  integer :: iob, ityp, ielm
5279  integer :: imin, imax, jmin, jmax
5280  integer :: ic, ic2, icm
5281  integer :: n, nn, nn_prev
5282  integer :: nobsl_prev, nobsl_incr
5283  integer :: nobsl_max_master
5284  integer :: ielm_u_master, ityp_master
5285 
5286  integer :: q
5287  logical :: loop
5288  integer :: nn_steps(n_merge_max+1)
5289  logical :: reach_cutoff
5290  integer :: imin_cutoff(n_merge_max), imax_cutoff(n_merge_max)
5291  integer :: jmin_cutoff(n_merge_max), jmax_cutoff(n_merge_max)
5292  real(RP) :: search_incr(n_merge_max)
5293  real(RP) :: search_incr_i(n_merge_max), search_incr_j(n_merge_max)
5294  real(RP) :: dist_cutoff_fac, dist_cutoff_fac_square
5295 
5296  real(RP) :: cutd
5297  integer :: nobsl_cm(n_merge_max)
5298 
5299  !-----------------------------------------------------------------------------
5300  ! Initialize
5301  !-----------------------------------------------------------------------------
5302 
5303  nobsl = 0
5304  if (present(nobsl_t)) then
5305  nobsl_t(:,:) = 0
5306  end if
5307  if (present(cutd_t)) then
5308  cutd_t(:,:) = 0.0d0
5309  if (max_nobs_per_grid_criterion == 1) then
5310  do ic = 1, nctype
5311  cutd_t(elm_u_ctype(ic),typ_ctype(ic)) = hori_loc_ctype(ic) * dist_zero_fac
5312  end do
5313  end if
5314  end if
5315 
5316  if (nobstotal == 0) then
5317  return
5318  end if
5319 
5320  if (maxval(max_nobs_per_grid(:)) > 0) then
5321  allocate (nobs_use(nobstotal))
5322  allocate (nobs_use2(nobstotal))
5323  allocate (rloc_tmp(nobstotal))
5324  allocate (rdiag_tmp(nobstotal))
5325  if (max_nobs_per_grid_criterion == 1) then
5326  allocate (dist_tmp(nobstotal))
5327  end if
5328  ! dist_tmp(:) = -1.0d6
5329  rloc_tmp(:) = -1.0d6
5330  ! rdiag_tmp(:) = -1.0d6
5331  else
5332  allocate (nobs_use(maxnobs_per_ctype))
5333  end if
5334 
5335  !-----------------------------------------------------------------------------
5336  ! For each observation type,
5337  ! do rough data search by a rectangle using the sorting mesh, and then
5338  ! do precise data search by normalized 3D distance and variable localization.
5339  !-----------------------------------------------------------------------------
5340 
5341  do ic = 1, nctype
5342  if (n_merge(ic) == 0) then
5343  if (present(cutd_t)) then
5344  cutd_t(elm_u_ctype(ic),typ_ctype(ic)) = 0.0d0
5345  end if
5346  cycle
5347  end if
5348 
5349  nobsl_max_master = max_nobs_per_grid(typ_ctype(ic)) ! Use the number limit setting of the "master" obs type for all group of obs types
5350  ielm_u_master = elm_u_ctype(ic) ! Count observation numbers at the "master" obs type for all group of obs types
5351  ityp_master = typ_ctype(ic) !
5352 
5353  if (nobsl_max_master <= 0) then
5354  !---------------------------------------------------------------------------
5355  ! When obs number limit is not enabled,
5356  ! directly prepare (hdxf, dep, depd, rdiag, rloc) output.
5357  !---------------------------------------------------------------------------
5358 
5359  nobsl_prev = nobsl
5360 
5361  do icm = 1, n_merge(ic)
5362  ic2 = ic_merge(icm,ic)
5363  ielm = elm_ctype(ic2)
5364  ityp = typ_ctype(ic2)
5365 
5366  if (obsgrd(ic2)%tot_ext > 0) then
5367  nn = 0
5368  call obs_local_range(ic2, ri, rj, imin, imax, jmin, jmax)
5369  call obs_choose_ext(ic2, imin, imax, jmin, jmax, nn, nobs_use)
5370 
5371  do n = 1, nn
5372  iob = nobs_use(n)
5373 
5374  call obs_local_cal(obs(:),ri, rj, rlev, rz, nvar, iob, ic2, ndist_dummy, nrloc, nrdiag)
5375  if (nrloc == 0.0d0) cycle
5376 
5377  nobsl = nobsl + 1
5378  hdxf(nobsl,:) = obsda_sort%ensval(1:nmem,iob)
5379  rdiag(nobsl) = nrdiag
5380  rloc(nobsl) = nrloc
5381  dep(nobsl) = obsda_sort%val(iob)
5382  if (present(depd)) then
5383  depd(nobsl) = obsda_sort%ensval(mmdetobs,iob)
5384  end if
5385  end do ! [ n = 1, nn ]
5386  end if ! [ obsgrd(ic2)%tot_ext > 0 ]
5387 
5388  if (present(nobsl_t)) then
5389  nobsl_t(elm_u_ctype(ic2),ityp) = nobsl - nobsl_prev
5390  end if
5391  end do ! [ do icm = 1, n_merge(ic) ]
5392 
5393  !---------------------------------------------------------------------------
5394  else if (max_nobs_per_grid_criterion == 1) then
5395  !---------------------------------------------------------------------------
5396  ! When obs number limit is enabled and the sorting criterion is simply distance,
5397  ! try the incremental observation location search
5398  ! (within the localization cutoff area) before conduct selection.
5399  !---------------------------------------------------------------------------
5400 
5401  nn = 0
5402  do icm = 1, n_merge(ic)
5403  ic2 = ic_merge(icm,ic)
5404 
5405  if (obsgrd(ic2)%tot_ext > 0) then
5406  call obs_local_range(ic2, ri, rj, imin, imax, jmin, jmax)
5407  call obs_choose_ext(ic2, imin, imax, jmin, jmax, nn, nobs_use)
5408  end if ! [ obsgrd(ic2)%tot_ext > 0 ]
5409  end do ! [ do icm = 1, n_merge(ic) ]
5410 
5411  if (nn == 0) cycle
5412 
5413  ! Determine the search_incr based on the master obs ctype:
5414  ! (zero-weight distance) / (# of search increment), but not smaller than the sorting mesh size
5415  search_incr(1) = hori_loc_ctype(ic) * dist_zero_fac / real(n_search_incr, rp) ! (unit: m)
5416  search_incr(1) = max(search_incr(1), obsgrd(ic)%grdspc_i, obsgrd(ic)%grdspc_j) ! (unit: m)
5417 
5418  do icm = 1, n_merge(ic)
5419  ic2 = ic_merge(icm,ic)
5420  ! Determine the search_incr of the other obs ctypes based on its horizontal localization scale
5421  ! relative to that of the master obs ctype
5422  if (icm > 1) then
5423  search_incr(icm) = search_incr(1) / hori_loc_ctype(ic) * hori_loc_ctype(ic2)
5424  end if
5425  search_incr_i(icm) = search_incr(icm) / dx ! (unit: x-grid)
5426  search_incr_j(icm) = search_incr(icm) / dy ! (unit: y-grid)
5427  call obs_local_range(ic2, ri, rj, imin_cutoff(icm), imax_cutoff(icm), jmin_cutoff(icm), jmax_cutoff(icm))
5428  end do
5429 
5430  nobsl_incr = 0
5431  if (present(srch_q0)) then
5432  q = srch_q0(ic) - 1
5433  else
5434  q = 0
5435  end if
5436  loop = .true.
5437 
5438  do while (loop)
5439  q = q + 1
5440  nn = 0
5441  reach_cutoff = .true.
5442 
5443  do icm = 1, n_merge(ic)
5444  ic2 = ic_merge(icm,ic)
5445  nn_steps(icm) = nn
5446 
5447  if (obsgrd(ic2)%tot_ext > 0) then
5448  call ij_obsgrd_ext(ic2, ri-search_incr_i(icm)*q, rj-search_incr_j(icm)*q, imin, jmin)
5449  call ij_obsgrd_ext(ic2, ri+search_incr_i(icm)*q, rj+search_incr_j(icm)*q, imax, jmax)
5450 
5451  if (imin <= imin_cutoff(icm) .and. imax >= imax_cutoff(icm) .and. &
5452  jmin <= jmin_cutoff(icm) .and. jmax >= jmax_cutoff(icm)) then
5453  imin = imin_cutoff(icm)
5454  imax = imax_cutoff(icm)
5455  jmin = jmin_cutoff(icm)
5456  jmax = jmax_cutoff(icm)
5457  else
5458  reach_cutoff = .false.
5459  end if
5460 
5461  call obs_choose_ext(ic2, imin, imax, jmin, jmax, nn, nobs_use)
5462  end if ! [ obsgrd(ic2)%tot_ext > 0 ]
5463  end do ! [ do icm = 1, n_merge(ic) ]
5464 
5465  nn_steps(n_merge(ic)+1) = nn
5466 
5467  if ((.not. reach_cutoff) .and. nn < nobsl_max_master) cycle
5468  if (reach_cutoff) then
5469  loop = .false.
5470  if (nn == 0) exit
5471  end if
5472 
5473  nobsl_incr = 0
5474 
5475  ! Determine the cutoff fraction in this incremental search,
5476  ! which should be the same for all obs ctypes based on its definition
5477  dist_cutoff_fac = search_incr(1) * q / hori_loc_ctype(ic)
5478  dist_cutoff_fac_square = dist_cutoff_fac * dist_cutoff_fac
5479 
5480  do icm = 1, n_merge(ic)
5481  ic2 = ic_merge(icm,ic)
5482 
5483  if (nn_steps(icm+1) > nn_steps(icm)) then
5484  do n = nn_steps(icm)+1, nn_steps(icm+1)
5485  iob = nobs_use(n)
5486 
5487  if (rloc_tmp(iob) == 0.0d0) cycle
5488 
5489  if (rloc_tmp(iob) < 0.0d0) then
5490  call obs_local_cal(obs(:),ri, rj, rlev, rz, nvar, iob, ic2, dist_tmp(iob), rloc_tmp(iob), rdiag_tmp(iob))
5491  if (rloc_tmp(iob) == 0.0d0) cycle
5492  end if
5493 
5494  if (.not. reach_cutoff) then
5495  if (dist_tmp(iob) > dist_cutoff_fac_square) cycle
5496  end if
5497 
5498  nobsl_incr = nobsl_incr + 1
5499  nobs_use2(nobsl_incr) = iob
5500  end do
5501  end if ! [ nn_steps(icm+1) > nn_steps(icm) ]
5502  end do ! [ do icm = 1, n_merge(ic) ]
5503 
5504  if (nobsl_incr >= nobsl_max_master) loop = .false.
5505  end do ! [ loop ]
5506 
5507  if (present(srch_q0)) then
5508  if (q == srch_q0(ic) .and. nobsl_incr > nobsl_max_master * 3) then ! when (nobsl_incr >= nobsl_max_master) too soon, decrease srch_q0
5509  srch_q0(ic) = q - 1
5510  else if (q > srch_q0(ic)) then ! when (nobsl_incr >= nobsl_max_master) too late, increase srch_q0
5511  srch_q0(ic) = q
5512  end if
5513  end if
5514 
5515  if (nobsl_incr == 0) cycle
5516 
5517  if (nobsl_incr > nobsl_max_master) then
5518  call sort_quickselect_arg(dist_tmp, nobs_use2, 1, nobsl_incr, nobsl_max_master)
5519  nobsl_incr = nobsl_max_master
5520  end if
5521 
5522  do n = 1, nobsl_incr
5523  nobsl = nobsl + 1
5524  iob = nobs_use2(n)
5525  hdxf(nobsl,:) = obsda_sort%ensval(1:nmem,iob)
5526  rdiag(nobsl) = rdiag_tmp(iob)
5527  rloc(nobsl) = rloc_tmp(iob)
5528  dep(nobsl) = obsda_sort%val(iob)
5529  if (present(depd)) then
5530  depd(nobsl) = obsda_sort%ensval(mmdetobs,iob)
5531  end if
5532  end do
5533 
5534  if (present(nobsl_t)) then
5535  nobsl_t(ielm_u_master,ityp_master) = nobsl_incr
5536  end if
5537  if (present(cutd_t)) then
5538  if (nobsl_incr == nobsl_max_master) then
5539  cutd_t(ielm_u_master,ityp_master) = hori_loc_ctype(ic) * sqrt(dist_tmp(nobs_use2(nobsl_incr)))
5540  end if
5541  end if
5542 
5543  !---------------------------------------------------------------------------
5544  else
5545  !---------------------------------------------------------------------------
5546  ! When obs number limit is enabled and the sorting criterion is NOT distance,
5547  ! conduct selection to all observations within the localization cutoff area.
5548  !---------------------------------------------------------------------------
5549 
5550  nn = 0
5551  nobsl_incr = 0
5552 
5553  do icm = 1, n_merge(ic)
5554  ic2 = ic_merge(icm,ic)
5555 
5556  if (obsgrd(ic2)%tot_ext > 0) then
5557  nn_prev = nn
5558  call obs_local_range(ic2, ri, rj, imin, imax, jmin, jmax)
5559  call obs_choose_ext(ic2, imin, imax, jmin, jmax, nn, nobs_use)
5560 
5561  do n = nn_prev+1, nn
5562  iob = nobs_use(n)
5563 
5564  call obs_local_cal(obs(:),ri, rj, rlev, rz, nvar, iob, ic2, ndist_dummy, rloc_tmp(iob), rdiag_tmp(iob))
5565  if (rloc_tmp(iob) == 0.0d0) cycle
5566 
5567  nobsl_incr = nobsl_incr + 1
5568  nobs_use2(nobsl_incr) = iob
5569  end do
5570  end if ! [ obsgrd(ic2)%tot_ext > 0 ]
5571  end do ! [ do icm = 1, n_merge(ic) ]
5572 
5573  if (nobsl_incr == 0) cycle
5574 
5575  if (nobsl_incr > nobsl_max_master) then
5576  if (max_nobs_per_grid_criterion == 2) then
5577  call sort_quickselect_desc_arg(rloc_tmp, nobs_use2, 1, nobsl_incr, nobsl_max_master)
5578  else if (max_nobs_per_grid_criterion == 3) then
5579  call sort_quickselect_arg(rdiag_tmp, nobs_use2, 1, nobsl_incr, nobsl_max_master)
5580  else
5581  write (6, '(A,I6)') "[Error] Unsupported 'MAX_NOBS_PER_GRID_CRITERION':", max_nobs_per_grid_criterion
5582  stop 99
5583  end if
5584  nobsl_incr = nobsl_max_master
5585  end if
5586 
5587  do n = 1, nobsl_incr
5588  nobsl = nobsl + 1
5589  iob = nobs_use2(n)
5590  hdxf(nobsl,:) = obsda_sort%ensval(1:nmem,iob)
5591  rdiag(nobsl) = rdiag_tmp(iob)
5592  rloc(nobsl) = rloc_tmp(iob)
5593  dep(nobsl) = obsda_sort%val(iob)
5594  if (present(depd)) then
5595  depd(nobsl) = obsda_sort%ensval(mmdetobs,iob)
5596  end if
5597  end do
5598 
5599  if (present(nobsl_t)) then
5600  nobsl_t(ielm_u_master,ityp_master) = nobsl_incr
5601  end if
5602  if (present(cutd_t)) then
5603  if (nobsl_incr == nobsl_max_master) then
5604  if (max_nobs_per_grid_criterion == 2) then
5605  cutd_t(ielm_u_master,ityp_master) = rloc_tmp(nobs_use2(nobsl_incr))
5606  else if (max_nobs_per_grid_criterion == 3) then
5607  cutd_t(ielm_u_master,ityp_master) = rdiag_tmp(nobs_use2(nobsl_incr))
5608  end if
5609  end if
5610  end if
5611 
5612  !---------------------------------------------------------------------------
5613  end if
5614 
5615  end do ! [ ic = 1, nctype ]
5616 
5617  !-----------------------------------------------------------------------------
5618  ! Finalize
5619  !-----------------------------------------------------------------------------
5620 
5621  deallocate (nobs_use)
5622  if (maxval(max_nobs_per_grid(:)) > 0) then
5623  deallocate (nobs_use2)
5624  deallocate (rloc_tmp)
5625  deallocate (rdiag_tmp)
5626  if (max_nobs_per_grid_criterion == 1) then
5627  deallocate (dist_tmp)
5628  end if
5629  end if
5630 
5631  return
5632  end subroutine obs_local
5633 
5634  !-------------------------------------------------------------------------------
5635  ! Calculate the range of the rectangle that covers the (horizontal) localization
5636  ! cut-off length in the extended subdomain, given the observation type
5637  !-------------------------------------------------------------------------------
5638  subroutine obs_local_range(ctype, ri, rj, imin, imax, jmin, jmax)
5639  implicit none
5640  integer, intent(in) :: ctype
5641  real(RP), intent(in) :: ri, rj
5642  integer, intent(out) :: imin, imax, jmin, jmax
5643 
5644  real(RP) :: dist_zero_i, dist_zero_j
5645 
5646 
5647  if (nlon==1) then !!! 2-D
5648  dist_zero_i = 0.0_rp
5649  else
5650  dist_zero_i = hori_loc_ctype(ctype) * dist_zero_fac / dx
5651  end if
5652  dist_zero_j = hori_loc_ctype(ctype) * dist_zero_fac / dy
5653  call ij_obsgrd_ext(ctype, ri - dist_zero_i, rj - dist_zero_j, imin, jmin)
5654  call ij_obsgrd_ext(ctype, ri + dist_zero_i, rj + dist_zero_j, imax, jmax)
5655 
5656  return
5657  end subroutine obs_local_range
5658 
5659  !-------------------------------------------------------------------------------
5660  ! Subroutine for main calculation of obs_local
5661  !-------------------------------------------------------------------------------
5662  subroutine obs_local_cal(obs, ri, rj, rlev, rz, nvar, iob, ic, ndist, nrloc, nrdiag)
5663  implicit none
5664  type(obs_info), intent(in) :: obs(:)
5665  real(RP), intent(in) :: ri, rj, rlev, rz ! coordinate of the targeted model grid
5666  integer, intent(in) :: nvar ! index of targeted model variable
5667  integer, intent(in) :: iob ! index of observation in obsda_sort
5668  integer, intent(in) :: ic ! observation combined type
5669  real(RP), intent(out) :: ndist ! normalized 3D distance SQUARE (in case of rejected obs: -1.)
5670  real(RP), intent(out) :: nrloc ! localization weight (in case of rejected obs: 0.)
5671  real(RP), intent(out) :: nrdiag ! weighted observation error variance (in case of rejected obs: -1.)
5672 
5673  integer :: obelm ! observation variable type
5674  integer :: obtyp ! observation report type
5675  integer :: obset
5676  integer :: obidx
5677  real(RP) :: rdx, rdy, rdz
5678  real(RP) :: nd_h, nd_v ! normalized horizontal/vertical distances
5679 
5680  integer :: di, dj, dk
5681 
5682  nrloc = 0.0d0
5683  nrdiag = -1.0d0
5684  ndist = -1.0d0
5685 
5686  obelm = elm_ctype(ic)
5687  obtyp = typ_ctype(ic)
5688  obset = obsda_sort%set(iob)
5689  obidx = obsda_sort%idx(iob)
5690  !
5691  ! Calculate variable localization
5692  !
5693  if (nvar > 0) then ! use variable localization only when nvar > 0
5694  nrloc = var_local(nvar,uid_obs_varlocal(obelm))
5695 
5696  !--- reject obs by variable localization
5697  if (nrloc < tiny(var_local)) then
5698  nrloc = 0.0d0
5699  return
5700  end if
5701  end if
5702  !
5703  ! Calculate normalized vertical distances
5704  !
5705  if (vert_loc_ctype(ic) == 0.0d0) then
5706  nd_v = 0.0d0 ! no vertical localization
5707  else if (obelm == id_ps_obs) then
5708  nd_v = abs(log(obs(obset)%dat(obidx)) - log(rlev)) / vert_loc_ctype(ic) ! for ps, use observed ps value for the base of vertical localization
5709  else if (obelm == id_rain_obs) then
5710  nd_v = abs(log(vert_local_rain_base) - log(rlev)) / vert_loc_ctype(ic) ! for rain, use VERT_LOCAL_RAIN_BASE for the base of vertical localization
5711  else if (obtyp == 22) then ! obtypelist(obtyp) == 'PHARAD'
5712  nd_v = abs(obs(obset)%lev(obidx) - rz) / vert_loc_ctype(ic) ! for PHARAD, use z-coordinate for vertical localization
5713  else
5714  nd_v = abs(log(obs(obset)%lev(obidx)) - log(rlev)) / vert_loc_ctype(ic)
5715  end if
5716 
5717  !--- reject obs by normalized vertical distance
5718  ! (do this first because there is large possibility to reject obs by the vertical distrance)
5719  if (nd_v > dist_zero_fac) then
5720  nrloc = 0.0d0
5721  return
5722  end if
5723  !
5724  ! Calculate normalized horizontal distances
5725  !
5726  rdx = (ri - obs(obset)%ri(obidx)) * dx
5727  rdy = (rj - obs(obset)%rj(obidx)) * dy
5728  nd_h = sqrt(rdx*rdx + rdy*rdy) / hori_loc_ctype(ic)
5729 
5730  !--- reject obs by normalized horizontal distance
5731  if (nd_h > dist_zero_fac) then
5732  nrloc = 0.0d0
5733  return
5734  end if
5735  !
5736  ! Calculate (normalized 3D distances)^2
5737  !
5738  ndist = nd_h * nd_h + nd_v * nd_v
5739 
5740  !--- reject obs by normalized 3D distance
5741  if (ndist > dist_zero_fac_square) then
5742  nrloc = 0.0d0
5743  ndist = -1.0d0
5744  return
5745  end if
5746 
5747  if ( obtyp == 22 .and. ( radar_thin_letkf_method > 0 ) ) then ! obtypelist(obtyp) == 'PHARAD'
5748  rdz = obs(obset)%lev(obidx) - rz
5749 
5750 
5751  select case( radar_thin_letkf_method )
5752  case( 1 )
5753  ! Pick up nearest 8 obs (2x2x2)
5754  ! and then choose every HGRID/VGRID
5755  di = int( abs( rdx / radar_so_size_hori ) )
5756  dj = int( abs( rdy / radar_so_size_hori ) )
5757  dk = int( abs( obs(obset)%lev(obidx) - rz ) / radar_so_size_vert )
5758 
5759  if ( ( mod( di, radar_thin_letkf_hgrid ) /= 0 .or. &
5760  mod( dj, radar_thin_letkf_hgrid ) /= 0 .or. &
5761  mod( dk, radar_thin_letkf_vgrid ) /= 0 ) .and. &
5762  ( ( di >= radar_thin_letkf_hnear ) .or. &
5763  ( dj >= radar_thin_letkf_hnear ) .or. &
5764  ( dk >= radar_thin_letkf_vnear ) ) ) then
5765  nrloc = 0.0d0
5766  ndist = -1.0d0
5767  return
5768  endif
5769  case( 2 )
5770  ! Pick up nearest 1 obs
5771  ! and then choose every HGRID/VGRID
5772  di = nint( rdx / radar_so_size_hori )
5773  dj = nint( rdy / radar_so_size_hori )
5774  dk = nint( obs(obset)%lev(obidx) - rz ) / radar_so_size_vert
5775 
5776  if ( mod( di, radar_thin_letkf_hgrid ) /= 0 .or. &
5777  mod( dj, radar_thin_letkf_hgrid ) /= 0 .or. &
5778  mod( dk, radar_thin_letkf_vgrid ) /= 0 ) then
5779  nrloc = 0.0d0
5780  ndist = -1.0d0
5781  return
5782  endif
5783 
5784  case default
5785  ! No thinning
5786  end select
5787 
5788  endif
5789 
5790 
5791  !
5792  ! Calculate observational localization
5793  !
5794  nrloc = nrloc * exp(-0.5d0 * ndist)
5795  !
5796  ! Calculate (observation variance / localization)
5797  !
5798  nrdiag = obs(obset)%err(obidx) * obs(obset)%err(obidx) / nrloc
5799  if ( radar_pqv .and. obelm == id_radar_ref_obs .and. obsda_sort%tm(iob) < 0.0d0 ) then
5800  nrdiag = obserr_pq**2 / nrloc
5801  endif
5802 
5803  return
5804  end subroutine obs_local_cal
5805 
5806  !-------------------------------------------------------------------------------
5807  ! Find local observations to be used for a targeted grid
5808  !-------------------------------------------------------------------------------
5809  ! [INPUT]
5810  ! srch_q0 : (optional) first guess of the multiplier of incremental search distances
5811  ! [OUT]
5812  ! hdxf : fcstast ensemble perturbations in the observation space
5813  ! rdiag : localization-weighted observation error variances
5814  ! rloc : localization weights
5815  ! dep : observation departure
5816  ! nobsl : number of valid observations (in hdxf, rdiag, rloc, dep)
5817  ! depd : (optional) observation departure for the deterministic run
5818  !-------------------------------------------------------------------------------
5819  subroutine obs_pest_etkf(hdxf, rdiag, rloc, dep, nobsl, depd)
5820  implicit none
5821 
5822  real(RP), intent(out) :: hdxf(nobstotal,nmem)
5823  real(RP), intent(out) :: rdiag(nobstotal)
5824  real(RP), intent(out) :: rloc(nobstotal)
5825  real(RP), intent(out) :: dep(nobstotal)
5826  integer, intent(out) :: nobsl
5827  real(RP), intent(out), optional :: depd(nobstotal)
5828 
5829  integer :: obset
5830  integer :: obidx
5831 
5832  real(RP) :: nrloc, nrdiag
5833  integer :: iob
5834  integer :: n, nn
5835 
5836  !-----------------------------------------------------------------------------
5837  ! For each observation type,
5838  ! do rough data search by a rectangle using the sorting mesh, and then
5839  ! do precise data search by normalized 3D distance and variable localization.
5840  !-----------------------------------------------------------------------------
5841 
5842  nobsl = 0
5843  nrloc = 1.0 ! ETKF ! No localization
5844  nn = obsda_sort%nobs ! obsda_sort%nobs = nobstotal
5845 
5846  do n = 1, nn
5847  iob = n
5848  obset = obsda_sort%set(n)
5849  obidx = obsda_sort%idx(n)
5850  nrdiag = obs(obset)%err(obidx) * obs(obset)%err(obidx) / nrloc
5851  if (nrloc == 0.0) cycle
5852 
5853  nobsl = nobsl + 1
5854  hdxf(nobsl,:) = obsda_sort%ensval(1:nmem,iob)
5855  rdiag(nobsl) = nrdiag
5856  rloc(nobsl) = nrloc
5857  dep(nobsl) = obsda_sort%val(iob)
5858  if (present(depd)) then
5859  depd(nobsl) = obsda_sort%ensval(mmdetobs,iob)
5860  end if
5861  end do
5862 
5863  return
5864  end subroutine obs_pest_etkf
5865 
5866  !-------------------------------------------------------------------------------
5867  ! Relaxation parameter based on grid locations (not for covariance inflation purpose)
5868  !-------------------------------------------------------------------------------
5869  subroutine relax_beta(ri, rj, rz, beta)
5870  implicit none
5871  real(RP), intent(in) :: ri, rj, rz
5872  real(RP), intent(out) :: beta
5873  real(RP) :: dist_bdy
5874 
5875  beta = 1.0d0
5876  !
5877  ! Upper bound of updates when RADAR_ZMAX is set and only radar observations are assimilated
5878  !
5879  if (radar_only .and. rz > radar_zmax + max(vert_local(22), vert_local_radar_vr) * dist_zero_fac) then
5880  beta = 0.0d0
5881  return
5882  end if
5883  !
5884  ! Boundary buffer
5885  !
5886  if (boundary_buffer_width > 0.0d0) then
5887  dist_bdy = min(min(ri-xhalo, nlong+xhalo+1-ri) * dx, &
5888  min(rj-yhalo, nlatg+yhalo+1-rj) * dy) / boundary_buffer_width
5889  if (dist_bdy < 1.0d0) then
5890  beta = max(dist_bdy, 0.0_rp)
5891  end if
5892  end if
5893 
5894  return
5895  end subroutine relax_beta
5896 
5897  !-------------------------------------------------------------------------------
5898  ! Relaxation via LETKF weight - RTPP method
5899  !-------------------------------------------------------------------------------
5900  subroutine weight_rtpp(w, infl, wrlx)
5901  implicit none
5902  real(RP), intent(in) :: w(nmem,nmem)
5903  real(RP), intent(in) :: infl
5904  real(RP), intent(out) :: wrlx(nmem,nmem)
5905  integer :: m
5906 
5907  wrlx = (1.0d0 - relax_alpha) * w
5908  do m = 1, nmem
5909  wrlx(m,m) = wrlx(m,m) + relax_alpha * sqrt(infl)
5910  end do
5911 
5912  return
5913  end subroutine weight_rtpp
5914 
5915  !-------------------------------------------------------------------------------
5916  ! Relaxation via LETKF weight - RTPS method
5917  !-------------------------------------------------------------------------------
5918  subroutine weight_rtps(w, pa, xb, infl, wrlx, infl_out)
5919  implicit none
5920  real(RP), intent(in) :: w(nmem,nmem)
5921  real(RP), intent(in) :: pa(nmem,nmem)
5922  real(RP), intent(in) :: xb(nmem)
5923  real(RP), intent(in) :: infl
5924  real(RP), intent(out) :: wrlx(nmem,nmem)
5925  real(RP), intent(out) :: infl_out
5926  real(RP) :: var_g, var_a
5927  integer :: m, k
5928 
5929  var_g = 0.0d0
5930  var_a = 0.0d0
5931  do m = 1, nmem
5932  var_g = var_g + xb(m) * xb(m)
5933  do k = 1, nmem
5934  var_a = var_a + xb(k) * pa(k,m) * xb(m)
5935  end do
5936  end do
5937  if (var_g > 0.0d0 .and. var_a > 0.0d0) then
5938  infl_out = relax_alpha_spread * sqrt(var_g * infl / (var_a * real(nmem-1,rp))) & ! Whitaker and Hamill 2012
5939  - relax_alpha_spread + 1.0d0 !
5940  wrlx = w * infl_out
5941  else
5942  wrlx = w
5943  infl_out = 1.0d0
5944  end if
5945 
5946  return
5947  end subroutine weight_rtps
5948 
5949  !-------------------------------------------------------------------------------
5950  ! Relaxation via LETKF weight - RTPS method for parameter estimation (alpha = 1.0)
5951  !-------------------------------------------------------------------------------
5952  subroutine weight_rtps_const(w, pa, xb, wrlx, infl_out)
5953  implicit none
5954  real(RP), intent(in) :: w(nmem,nmem)
5955  real(RP), intent(in) :: pa(nmem,nmem)
5956  real(RP), intent(in) :: xb(nmem)
5957  real(RP), intent(out) :: wrlx(nmem,nmem)
5958  real(RP), intent(out) :: infl_out
5959  real(RP) :: var_g, var_a
5960  integer :: m, k
5961 
5962  real(RP), parameter :: RTPS_const = 1.0d0
5963 
5964  var_g = 0.0d0
5965  var_a = 0.0d0
5966  do m = 1, nmem
5967  var_g = var_g + xb(m) * xb(m)
5968  do k = 1, nmem
5969  var_a = var_a + xb(k) * pa(k,m) * xb(m)
5970  end do
5971  end do
5972  if (var_g > 0.0d0 .and. var_a > 0.0d0) then
5973  infl_out = rtps_const * sqrt(var_g * 1.0d0 / (var_a * real(nmem-1,kind=rp))) & ! Whitaker and Hamill 2012
5974  - rtps_const + 1.0d0 !
5975  wrlx = w * infl_out
5976  else
5977  wrlx = w
5978  infl_out = 1.0d0
5979  end if
5980 
5981  return
5982  end subroutine weight_rtps_const
5983 
5984  !-----------------------------------------------------------------------
5985  ! DISTANCE BETWEEN TWO POINTS (LONa,LATa)-(LONb,LATb)
5986  !-----------------------------------------------------------------------
5987  subroutine com_distll_1(alon,alat,blon,blat,dist)
5988  use scale_const, only: &
5989  pi => const_pi, &
5990  re => const_radius
5991  implicit none
5992  real(RP), intent(in) :: alon
5993  real(RP), intent(in) :: alat
5994  real(RP), intent(in) :: blon
5995  real(RP), intent(in) :: blat
5996  real(RP), intent(out) :: dist
5997  real(RP), parameter :: r180 = 1.0_rp/180.0_rp
5998  real(RP) :: lon1,lon2,lat1,lat2
5999  real(RP) :: cosd
6000 
6001  lon1 = alon * pi * r180
6002  lon2 = blon * pi * r180
6003  lat1 = alat * pi * r180
6004  lat2 = blat * pi * r180
6005 
6006  cosd = sin(lat1)*sin(lat2) + cos(lat1)*cos(lat2)*cos(lon2-lon1)
6007  cosd = min( 1._rp,cosd)
6008  cosd = max(-1._rp,cosd)
6009 
6010  dist = acos( cosd ) * re
6011 
6012  return
6013  end subroutine com_distll_1
6014 
6015  !-------------------------------------------------------------------------------
6016  ! Calculate ensemble mean (on scattered grids)
6017  !-------------------------------------------------------------------------------
6018  ! [INPUT]
6019  ! mem : ensemble size
6020  ! nens : ensemble demension of state variables
6021  ! nij : scattered grid numbers
6022  ! v3d(nij,nlev,nens,nv3d) : 3D ensemble state variables (on scattered grids)
6023  ! inputted by (:,:,1..mem,:)
6024  ! v2d(nij, nens,nv3d) : 2D ensemble state variables (on scattered grids)
6025  ! inputted by (:, 1..mem,:)
6026  ! [OUTPUT]
6027  ! v3d(nij,nlev,nens,nv3d) : ensemble mean of 3D state variables (on scattered grids)
6028  ! outputted by (:,:,mem+1,:)
6029  ! v2d(nij, nens,nv3d) : ensemble mean of 2D state variables (on scattered grids)
6030  ! outputted by (: ,mem+1,:)
6031  !-------------------------------------------------------------------------------
6032  subroutine ensmean_grd(mem, nens, nij, v3d, v2d)
6033  implicit none
6034  integer, intent(in) :: mem
6035  integer, intent(in) :: nens
6036  integer, intent(in) :: nij
6037  real(RP), intent(inout) :: v3d(nij,nlev,nens,nv3d)
6038  real(RP), intent(inout) :: v2d(nij,nens,nv2d)
6039 
6040  integer :: i, k, m, n, mmean
6041  !---------------------------------------------------------------------
6042 
6043  mmean = mem + 1
6044 
6045  do n = 1, nv3d
6046  do k = 1, nlev
6047  do i = 1, nij
6048  v3d(i,k,mmean,n) = v3d(i,k,1,n)
6049  do m = 2, mem
6050  v3d(i,k,mmean,n) = v3d(i,k,mmean,n) + v3d(i,k,m,n)
6051  end do
6052  v3d(i,k,mmean,n) = v3d(i,k,mmean,n) / real(mem, kind=rp)
6053  end do
6054  end do
6055  end do
6056  do n = 1, nv2d
6057  do i = 1, nij
6058  v2d(i,mmean,n) = v2d(i,1,n)
6059  do m = 2, mem
6060  v2d(i,mmean,n) = v2d(i,mmean,n) + v2d(i,m,n)
6061  end do
6062  v2d(i,mmean,n) = v2d(i,mmean,n) / real(mem, kind=rp)
6063  end do
6064  end do
6065 
6066  return
6067  end subroutine ensmean_grd
6068 
6069  !-----------------------------------------------------------------------
6070  ! Transformation from model variables to an observation
6071  !
6072  ! stggrd: grid type of u and v
6073  ! 0: non-staggered grid
6074  ! 1: staggered grid
6075  !-----------------------------------------------------------------------
6076  subroutine trans_xtoy(elm,ri,rj,rk,lon,lat,v3d,v2d,yobs,qc,stggrd)
6077  use scale_const, only: &
6078  undef => const_undef, &
6079  fvirt => const_epstvap
6080  implicit none
6081  integer, intent(in) :: elm
6082  real(RP), intent(in) :: ri,rj,rk
6083  real(RP), intent(in) :: lon,lat
6084  real(RP), intent(in) :: v3d(:,:,:,:)
6085  real(RP), intent(in) :: v2d( :,:,:)
6086  real(RP), intent(out) :: yobs
6087  integer, intent(out) :: qc
6088  integer, intent(in), optional :: stggrd
6089  real(RP) :: u,v,t,q,topo
6090 
6091  integer :: stggrd_ = 0
6092  if (present(stggrd)) stggrd_ = stggrd
6093 
6094  yobs = undef
6095  qc = iqc_good
6096 
6097  select case (elm)
6098  case(id_u_obs,id_v_obs) ! U,V
6099  if (stggrd_ == 1) then
6100  call itpl_3d(v3d(:,:,:,iv3dd_u),rk,ri-0.5_rp,rj,u) !###### should modity itpl_3d to prevent '1.0' problem....??
6101  call itpl_3d(v3d(:,:,:,iv3dd_v),rk,ri,rj-0.5_rp,v) !######
6102  else
6103  call itpl_3d(v3d(:,:,:,iv3dd_u),rk,ri,rj,u)
6104  call itpl_3d(v3d(:,:,:,iv3dd_v),rk,ri,rj,v)
6105  end if
6106  if (elm == id_u_obs) then
6107  yobs = u
6108  else
6109  yobs = v
6110  end if
6111  case(id_t_obs) ! T
6112  call itpl_3d(v3d(:,:,:,iv3dd_t),rk,ri,rj,yobs)
6113  case(id_tv_obs) ! Tv
6114  call itpl_3d(v3d(:,:,:,iv3dd_t),rk,ri,rj,yobs)
6115  call itpl_3d(v3d(:,:,:,iv3dd_q),rk,ri,rj,q)
6116  yobs = yobs * (1.0d0 + fvirt * q)
6117  case(id_q_obs) ! Q
6118  call itpl_3d(v3d(:,:,:,iv3dd_q),rk,ri,rj,yobs)
6119  case(id_ps_obs) ! PS
6120  call itpl_2d(v2d(:,:,iv2dd_t2m),ri,rj,t)
6121  call itpl_2d(v2d(:,:,iv2dd_q2m),ri,rj,q)
6122  call itpl_2d(v2d(:,:,iv2dd_topo),ri,rj,topo)
6123  call itpl_2d(v2d(:,:,iv2dd_ps),ri,rj,yobs)
6124  call prsadj(yobs,rk-topo,t,q)
6125  if( abs(rk-topo) > ps_adjust_thres ) then
6126  qc = iqc_ps_ter
6127  end if
6128  case(id_rh_obs) ! RH
6129  call itpl_3d(v3d(:,:,:,iv3dd_rh),rk,ri,rj,yobs)
6130  case default
6131  qc = iqc_otype
6132  end select
6133 
6134  return
6135  end subroutine trans_xtoy
6136 
6137  subroutine trans_xtoy_radar(elm,radar_lon,radar_lat,radar_z,ri,rj,rk,lon,lat,lev,v3d,v2d,yobs,qc,stggrd)
6138  use scale_const, only: &
6139  undef => const_undef, &
6140  d2r => const_d2r, &
6141  r2d => const_r2d
6142  use scale_mapprojection, only: &
6143  mapprojection_rotcoef
6144  implicit none
6145 
6146  integer, intent(in) :: elm
6147  real(RP), intent(in) :: ri,rj,rk,radar_lon,radar_lat,radar_z !!!!! Use only, ri, rj, rk eventually... (radar_lon,lat,z in ri,rj,rk)
6148  real(RP), intent(in) :: lon,lat,lev
6149  real(RP), intent(in) :: v3d(:,:,:,:)
6150  real(RP), intent(in) :: v2d(:,:,:)
6151  real(RP), intent(out) :: yobs
6152  integer, intent(out) :: qc
6153  integer, intent(in), optional :: stggrd
6154 
6155  integer :: stggrd_ = 0
6156 
6157  real(RP) :: qvr,qcr,qrr,qir,qsr,qgr,ur,vr,wr,tr,pr !,rhr
6158  real(RP) :: dist , dlon , dlat , az , elev , radar_ref,radar_rv
6159 
6160  real(RP) :: utmp, vtmp
6161  real(RP) :: rotc(1,1,2)
6162  real(RP) :: lon_tmp(1,1),lat_tmp(1,1)
6163 
6164  if (present(stggrd)) stggrd_ = stggrd
6165 
6166  yobs = undef
6167  qc = iqc_good
6168 
6169  if (stggrd_ == 1) then
6170  CALL itpl_3d(v3d(:,:,:,iv3dd_u),rk,ri-0.5_rp,rj,ur) !###### should modity itpl_3d to prevent '1.0' problem....??
6171  CALL itpl_3d(v3d(:,:,:,iv3dd_v),rk,ri,rj-0.5_rp,vr) !######
6172  CALL itpl_3d(v3d(:,:,:,iv3dd_w),rk-0.5_rp,ri,rj,wr) !######
6173  else
6174  CALL itpl_3d(v3d(:,:,:,iv3dd_u),rk,ri,rj,ur)
6175  CALL itpl_3d(v3d(:,:,:,iv3dd_v),rk,ri,rj,vr)
6176  CALL itpl_3d(v3d(:,:,:,iv3dd_w),rk,ri,rj,wr)
6177  end if
6178  CALL itpl_3d(v3d(:,:,:,iv3dd_t),rk,ri,rj,tr)
6179  CALL itpl_3d(v3d(:,:,:,iv3dd_p),rk,ri,rj,pr)
6180  CALL itpl_3d(v3d(:,:,:,iv3dd_q),rk,ri,rj,qvr)
6181  CALL itpl_3d(v3d(:,:,:,iv3dd_qc),rk,ri,rj,qcr)
6182  CALL itpl_3d(v3d(:,:,:,iv3dd_qr),rk,ri,rj,qrr)
6183  CALL itpl_3d(v3d(:,:,:,iv3dd_qi),rk,ri,rj,qir)
6184  CALL itpl_3d(v3d(:,:,:,iv3dd_qs),rk,ri,rj,qsr)
6185  CALL itpl_3d(v3d(:,:,:,iv3dd_qg),rk,ri,rj,qgr)
6186 
6187  ! Compute az and elevation for the current observation.
6188  ! Simple approach (TODO: implement a more robust computation)
6189 
6190  ! Azimuth
6191  dlon = lon-radar_lon
6192  dlat = lat-radar_lat
6193  if ( dlon == 0.0_rp .and. dlat == 0.0_rp )then
6194  qc = iqc_out_h
6195  return
6196  else
6197  az = r2d*atan2(dlon*cos(radar_lat*d2r),dlat)
6198  endif
6199  if( az < 0 ) az = 360.0_rp + az
6200  ! elevation
6201  call com_distll_1(lon,lat,radar_lon,radar_lat,dist)
6202  elev = r2d*atan2(lev-radar_z,dist)
6203 
6204  lon_tmp(1,1) = lon*d2r
6205  lat_tmp(1,1) = lat*d2r
6206  call mapprojection_rotcoef(1, 1, 1, 1, 1, 1, &
6207  lon_tmp(:,:),lat_tmp(:,:),rotc(:,:,1),rotc(:,:,2))
6208 
6209  utmp = ur
6210  vtmp = vr
6211  ur = utmp * rotc(1,1,1) - vtmp * rotc(1,1,2)
6212  vr = utmp * rotc(1,1,2) + vtmp * rotc(1,1,1)
6213 
6214  ! Check that the azimuth and elevation angles are within the expected range.
6215  ! Some grid points may be at the radar location.
6216 
6217  CALL calc_ref_vr(qvr,qcr,qrr,qir,qsr,qgr,ur,vr,wr,tr,pr,az,elev,radar_ref,radar_rv)
6218 
6219  select case (elm)
6220  case(id_radar_ref_obs,id_radar_ref_zero_obs)
6221  if (radar_ref < min_radar_ref) then
6222  qc = iqc_ref_low
6223  yobs = min_radar_ref_dbz + low_ref_shift !!! even if the above qc is bad, still return the value
6224  else
6225  yobs = 10.0_rp * log10(radar_ref)
6226  end if
6227  case(id_radar_vr_obs)
6228  if (radar_ref < min_radar_ref) then
6229  qc = iqc_ref_low
6230  end if
6231  yobs = radar_rv !!! even if the above qc is bad, still return the value
6232  case default
6233  qc = iqc_otype
6234  end select
6235 
6236  return
6237  end subroutine trans_xtoy_radar
6238 
6239  !-----------------------------------------------------------------------
6240  ! Pressure adjustment for a different height level
6241  !-----------------------------------------------------------------------
6242  subroutine prsadj(p,dz,t,q)
6243  use scale_const, only: &
6244  gg => const_grav, &
6245  rd => const_rdry
6246  implicit none
6247  real(RP), intent(inout) :: p
6248  real(RP), intent(in) :: dz ! height difference (target - original) [m]
6249  real(RP), intent(in) :: t ! temperature [K] at original level
6250  real(RP), intent(in) :: q ! humidity [kg/kg] at original level
6251  real(RP), parameter :: gamma=5.0d-3 ! lapse rate [K/m]
6252  real(RP) :: tv
6253 
6254  if(dz /= 0) then
6255  tv = t * (1.0d0 + 0.608d0 * q)
6256  p = p * ((-gamma*dz+tv)/tv)**(gg/(gamma*rd)) !tv is at original level
6257  end if
6258 
6259  return
6260  end subroutine prsadj
6261 
6262  !-----------------------------------------------------------------------
6263  ! Coordinate conversion (find rk in pressure levels)
6264  !
6265  ! rk = 0.0d0 : surface observation
6266  !-----------------------------------------------------------------------
6267  subroutine phys2ijk(p_full,elem,ri,rj,rlev,rk,qc)
6268  use scale_const, only: &
6269  undef => const_undef
6270  implicit none
6271 
6272  real(RP), intent(in) :: p_full(:,:,:)
6273  integer, intent(in) :: elem
6274  real(RP), intent(in) :: ri
6275  real(RP), intent(in) :: rj
6276  real(RP), intent(in) :: rlev ! pressure levels (for 3D variable only)
6277  real(RP), intent(out) :: rk
6278  integer, intent(out) :: qc
6279 
6280  real(RP) :: ak
6281  real(RP) :: lnps(nlevh,nlonh,nlath)
6282  real(RP) :: plev(nlevh)
6283  real(RP) :: ptmp
6284  integer :: i,j,k, ii, jj, ks
6285 
6286  qc = iqc_good
6287  !
6288  ! rlev -> rk
6289  !
6290  if( ri < 1.0_rp .or. ri > nlonh .or. rj < 1.0_rp .or. rj > nlath ) then
6291  rk = undef
6292  qc = iqc_out_h
6293  return ! [Warning] observation is outside of the horizontal domain
6294  end if
6295  !
6296  if(elem > 9999) then ! surface observation
6297  rk = rlev
6298  else
6299  !
6300  ! horizontal interpolation
6301  !
6302  i = ceiling(ri)
6303  j = ceiling(rj)
6304  !
6305  ! Find the lowest valid level
6306  !
6307  ks = 1+zhalo
6308  do jj = j-1, j
6309  do ii = max(i-1,1), min(i,nlong+xhalo)
6310  do k=1+zhalo,nlev+zhalo
6311  if( p_full(k,ii,jj) >= 0.0_rp ) exit
6312  end do
6313  if (k > ks) ks = k
6314  end do
6315  end do
6316 
6317  lnps(:,i-1:i,j-1:j) = log(p_full(:,i-1:i,j-1:j))
6318  call itpl_2d_column(lnps,ri,rj,plev)
6319  !
6320  ! Log pressure
6321  !
6322  rk = log(rlev)
6323  !
6324  ! determine if rk is within bound.
6325  !
6326  if(rk < plev(nlev+zhalo)) then
6327  call itpl_2d(p_full(nlev+zhalo,:,:),ri,rj,ptmp)
6328  rk = undef
6329  qc = iqc_out_vhi
6330  return ! [Warning] observation is too high: ptop=', ptmp, ', lev=', rlev, ', elem=', elem
6331  end if
6332  if(rk > plev(ks)) then
6333  call itpl_2d(p_full(ks,:,:),ri,rj,ptmp)
6334  rk = undef
6335  qc = iqc_out_vlo
6336  return ! '[Warning] observation is too low: pbottom=', ptmp, ', lev=', rlev, ', elem=', elem
6337  end if
6338  !
6339  ! find rk
6340  !
6341  do k=ks+1,nlev+zhalo
6342  if(plev(k) < rk) exit ! assuming descending order of plev
6343  end do
6344 
6345  if (k == nlev+zhalo+1) then
6346  ak = 0.99
6347  rk = real(k-2,kind=rp) + ak
6348  else
6349  ak = (rk - plev(k-1)) / (plev(k) - plev(k-1))
6350  rk = real(k-1,kind=rp) + ak
6351  end if
6352  end if
6353 
6354  return
6355  end subroutine phys2ijk
6356 
6357  !-----------------------------------------------------------------------
6358  ! Coordinate conversion (find rk in height levels)
6359  !
6360  ! rk = 0.0d0 : surface observation
6361  !-----------------------------------------------------------------------
6362  subroutine phys2ijkz(z_full,ri,rj,rlev,rk,qc)
6363  use scale_const, only: &
6364  undef => const_undef
6365  implicit none
6366 
6367  real(RP), intent(in) :: z_full(:,:,:)
6368  real(RP), intent(in) :: ri
6369  real(RP), intent(in) :: rj
6370  real(RP), intent(in) :: rlev ! height levels
6371  real(RP), intent(out) :: rk
6372  integer, intent(out) :: qc
6373 
6374  real(RP) :: ak
6375  real(RP) :: zlev(nlevh)
6376  real(RP) :: ztmp
6377  integer :: i,j,k, ii, jj, ks
6378 
6379  qc = iqc_good
6380  !
6381  ! rlev -> rk
6382  !
6383  if( ri < 1.0_rp .or. ri > nlonh .or. rj < 1.0_rp .or. rj > nlath ) then
6384  rk = undef
6385  qc = iqc_out_h
6386  return ! '[Warning] observation is outside of the horizontal domain'
6387  end if
6388  !
6389  ! horizontal interpolation
6390  !
6391  i = ceiling(ri)
6392  j = ceiling(rj)
6393  !
6394  ! Find the lowest valid level
6395  !
6396  ks = 1+zhalo
6397  do jj = j-1, j
6398  do ii = max(i-1,1), min(i,nlong+xhalo)
6399  do k=1+zhalo,nlev+zhalo
6400  if( z_full(k,ii,jj) > -300.0_rp .and. z_full(k,ii,jj) < 10000.0_rp ) exit
6401  end do
6402  if (k > ks) ks = k
6403  end do
6404  end do
6405 
6406  call itpl_2d_column(z_full,ri,rj,zlev)
6407 
6408  !
6409  ! determine if rlev is within bound.
6410  !
6411  if( rlev > zlev(nlev+zhalo) ) then
6412  call itpl_2d(z_full(nlev+zhalo,:,:),ri,rj,ztmp)
6413  rk = undef
6414  qc = iqc_out_vhi
6415  return ! '[Warning] observation is too high: ztop=', ztmp, ', lev=', rlev
6416  end if
6417  if(rlev < zlev(ks)) then
6418  call itpl_2d(z_full(ks,:,:),ri,rj,ztmp)
6419  rk = undef
6420  qc = iqc_out_vlo
6421  return ! '[Warning] observation is too low: zbottom=', ztmp, ', lev=', rlev
6422  end if
6423  !
6424  ! find rk
6425  !
6426  do k=ks+1,nlev+zhalo
6427  if(zlev(k) > rlev) exit ! assuming ascending order of zlev
6428  end do
6429 
6430  if (k == nlev+zhalo+1) then
6431  ak = 0.99
6432  rk = real(k-2,kind=rp) + ak
6433  else
6434  ak = (rlev - zlev(k-1)) / (zlev(k) - zlev(k-1))
6435  rk = real(k-1,kind=rp) + ak
6436  end if
6437 
6438  return
6439  end subroutine phys2ijkz
6440 
6441  !-----------------------------------------------------------------------
6442  ! Coordinate conversion
6443  !-----------------------------------------------------------------------
6444  subroutine phys2ij(rlon,rlat,rig,rjg)
6445  use scale_const, only: &
6446  pi => const_pi
6447  use scale_atmos_grid_cartesc, only: &
6448  cxg => atmos_grid_cartesc_cxg, &
6449  cyg => atmos_grid_cartesc_cyg
6450  use scale_mapprojection, only: &
6451  mapprojection_lonlat2xy
6452  implicit none
6453  real(RP), intent(in) :: rlon
6454  real(RP), intent(in) :: rlat
6455  real(RP), intent(out) :: rig
6456  real(RP), intent(out) :: rjg
6457  real(RP) :: rig_RP
6458  real(RP) :: rjg_RP
6459  !
6460  ! rlon,rlat -> ri,rj
6461  !
6462  call mapprojection_lonlat2xy( real(rlon*pi/180.0_rp, kind=rp), &
6463  real(rlat*PI/180.0_RP, kind=rp), rig_rp, rjg_rp )
6464  rig = real((rig_rp - cxg(1)) / dx, kind=rp) + 1.0_rp
6465  rjg = real((rjg_rp - cyg(1)) / dy, kind=rp) + 1.0_rp
6466 
6467  if (nlonh==1) then !!! adjustment : ideal 2-D case
6468  rig = 1.0_rp
6469  end if
6470 
6471  return
6472  end subroutine phys2ij
6473 
6474  !-----------------------------------------------------------------------
6475  ! Interpolation
6476  !-----------------------------------------------------------------------
6477  subroutine itpl_2d(var,ri,rj,var5)
6478  implicit none
6479  real(RP), intent(in) :: var(:,:)
6480  real(RP), intent(in) :: ri
6481  real(RP), intent(in) :: rj
6482  real(RP), intent(out) :: var5
6483  real(RP) :: ai,aj
6484  integer :: i,j
6485 
6486  i = ceiling(ri)
6487  ai = ri - real(i-1,kind=rp)
6488  j = ceiling(rj)
6489  aj = rj - real(j-1,kind=rp)
6490 
6491  if (nlonh==1) then
6492  var5 = var(i ,j-1) * (1-aj) &
6493  & + var(i ,j ) * aj
6494  else
6495  var5 = var(i-1,j-1) * (1-ai) * (1-aj) &
6496  & + var(i ,j-1) * ai * (1-aj) &
6497  & + var(i-1,j ) * (1-ai) * aj &
6498  & + var(i ,j ) * ai * aj
6499  end if
6500 
6501  return
6502  end subroutine itpl_2d
6503 
6504  subroutine itpl_2d_column(var,ri,rj,var5)
6505  implicit none
6506  real(RP), intent(in) :: var(:,:,:)
6507  real(RP), intent(in) :: ri
6508  real(RP), intent(in) :: rj
6509  real(RP), intent(out) :: var5(:)
6510 
6511  real(RP) :: ai,aj
6512  integer :: i,j
6513 
6514  i = ceiling(ri)
6515  ai = ri - real(i-1,kind=rp)
6516  j = ceiling(rj)
6517  aj = rj - real(j-1,kind=rp)
6518 
6519  if (nlonh==1) then
6520  var5(:) = var(:,i ,j-1) * (1-aj) &
6521  & + var(:,i ,j ) * aj
6522  else
6523  var5(:) = var(:,i-1,j-1) * (1-ai) * (1-aj) &
6524  & + var(:,i ,j-1) * ai * (1-aj) &
6525  & + var(:,i-1,j ) * (1-ai) * aj &
6526  & + var(:,i ,j ) * ai * aj
6527  end if
6528 
6529  return
6530  end subroutine itpl_2d_column
6531 
6532  subroutine itpl_3d(var,rk,ri,rj,var5)
6533  implicit none
6534  real(RP), intent(in) :: var(:,:,:)
6535  real(RP), intent(in) :: ri
6536  real(RP), intent(in) :: rj
6537  real(RP), intent(in) :: rk
6538  real(RP), intent(out) :: var5
6539  real(RP) :: ai,aj,ak
6540  integer :: i,j,k
6541 
6542  i = ceiling(ri)
6543  ai = ri - real(i-1,kind=rp)
6544  j = ceiling(rj)
6545  aj = rj - real(j-1,kind=rp)
6546  k = ceiling(rk)
6547  ak = rk - real(k-1,kind=rp)
6548 
6549  if (nlonh==1) then
6550  var5 = var(k-1,i ,j-1) * (1-aj) * (1-ak) &
6551  & + var(k-1,i ,j ) * aj * (1-ak) &
6552  & + var(k, i ,j-1) * (1-aj) * ak &
6553  & + var(k, i ,j ) * aj * ak
6554  else
6555  var5 = var(k-1,i-1,j-1) * (1-ai) * (1-aj) * (1-ak) &
6556  & + var(k-1,i ,j-1) * ai * (1-aj) * (1-ak) &
6557  & + var(k-1,i-1,j ) * (1-ai) * aj * (1-ak) &
6558  & + var(k-1,i ,j ) * ai * aj * (1-ak) &
6559  & + var(k, i-1,j-1) * (1-ai) * (1-aj) * ak &
6560  & + var(k, i ,j-1) * ai * (1-aj) * ak &
6561  & + var(k, i-1,j ) * (1-ai) * aj * ak &
6562  & + var(k, i ,j ) * ai * aj * ak
6563  end if
6564 
6565  return
6566  end subroutine itpl_3d
6567 
6568  subroutine merge_sort_parallel(n, array)
6569  use omp_lib
6570  integer(8), intent(in) :: n
6571  integer(8), intent(inout) :: array(n)
6572  logical omp_nested
6573  integer maxnest
6574 
6575 #ifdef DA
6576  omp_nested = omp_get_nested()
6577  maxnest = floor(log(dble(omp_get_max_threads())) / log(2.0d0))
6578  call omp_set_nested(.true.)
6579  call merge_sort_2threads(n, array, 0, maxnest)
6580  call omp_set_nested(omp_nested)
6581 #endif
6582 
6583  end subroutine merge_sort_parallel
6584 
6585  recursive subroutine merge_sort_2threads(n, array, nest, maxnest)
6586  use scale_sort, only: &
6587  sort_quicksort
6588  implicit none
6589  integer(8), intent(in) :: n
6590  integer, intent(in) :: nest, maxnest
6591  integer(8), intent(inout) :: array(n)
6592  integer(8) :: asize(2)
6593  integer(8), allocatable :: tmpary(:)
6594  integer, parameter:: nmin = 4
6595 
6596  asize = n / 2
6597  if(mod(n,2_8) .ne. 0) asize(1) = asize(1) + 1
6598 
6599  if(nest < maxnest) then
6600  allocate(tmpary(n))
6601  tmpary(1:asize(1)) = array(1:asize(1))
6602  if(asize(1) > nmin) then
6603  call merge_sort_2threads(asize(1), tmpary(1:asize(1)), nest + 1, maxnest)
6604  else
6605  call sort_quicksort(asize(1), tmpary(1:asize(1)))
6606  end if
6607  tmpary((asize(1) + 1):n) = array((asize(1) + 1):n)
6608  if(asize(2) > nmin) then
6609  call merge_sort_2threads(asize(2), tmpary((asize(1) + 1):n), nest + 1, maxnest)
6610  else
6611  call sort_quicksort(asize(2), tmpary((asize(1) + 1):n))
6612  end if
6613  call merge_2threads(asize(1), tmpary(1:asize(1)), asize(2), tmpary((asize(1) + 1):n), n, array, nest, maxnest)
6614  else
6615  allocate(tmpary(n))
6616  tmpary = array
6617  call sort_quicksort(asize(1), tmpary(1:asize(1)))
6618  call sort_quicksort(asize(2), tmpary((asize(1) + 1):n))
6619  call merge(asize(1), tmpary(1:asize(1)), asize(2), tmpary((asize(1) + 1):n), n, array)
6620  end if
6621  end subroutine merge_sort_2threads
6622 
6623  recursive subroutine merge_2threads(n1, ary1, n2, ary2, n3, ary3, nest, maxnest)
6624  integer(8), intent(in) :: n1, ary1(n1), n2, ary2(n2), n3
6625  integer, intent(in) :: nest, maxnest
6626  integer(8), intent(inout) :: ary3(n3)
6627  integer(8) k, m
6628  integer, parameter :: threshold = 10
6629 
6630  if(nest >= maxnest .or. n1 < threshold .or. n2 < threshold) then
6631  call merge(n1, ary1, n2, ary2, n3, ary3)
6632  return
6633  end if
6634 
6635  k = n1 / 2
6636  m = binary_search_i8(n2, ary2, ary1(k))
6637  call merge_2threads(k, ary1(1:k), m, ary2(1:m), k + m, ary3(1:(k + m)), nest + 1, maxnest)
6638  call merge_2threads(n1 - k, ary1((k + 1):n1), n2 - m, ary2((m + 1):n2), n3 - (k + m), ary3((k + m + 1):n3), nest + 1, maxnest)
6639 
6640  end subroutine merge_2threads
6641 
6642  subroutine merge(n1, ary1, n2, ary2, n3, ary3)
6643  integer(8), intent(in) :: n1, ary1(n1), n2, ary2(n2), n3
6644  integer(8), intent(inout) :: ary3(n3)
6645  integer(8) i, j, k
6646  i = 1
6647  j = 1
6648  do k = 1, n3
6649  if(ary1(i) < ary2(j)) then
6650  ary3(k) = ary1(i)
6651  if(i == n1) then
6652  ary3((k + 1):n3) = ary2(j:n2)
6653  exit
6654  end if
6655  i = i + 1
6656  else
6657  ary3(k) = ary2(j)
6658  if(j == n2) then
6659  ary3((k + 1):n3) = ary1(i:n1)
6660  exit
6661  end if
6662  j = j + 1
6663  end if
6664  end do
6665  end subroutine merge
6666 
6667  recursive subroutine merge_sort_mpi(n, array, comm)
6668  use scale_sort, only: &
6669  sort_quicksort
6670  implicit none
6671  !ONLY RANK 0 RETURNS RESULT
6672  integer(8), intent(in) :: n
6673  integer, intent(in) :: comm
6674  integer(8), intent(inout) :: array(n)
6675  integer(8) :: asize(2)
6676  integer(8), allocatable :: tmpary(:)
6677  integer :: parent, child, procs(2), newcomm, tag, nprocs, rank
6678  integer :: ierr
6679 
6680  call mpi_comm_size(comm, nprocs, ierr)
6681  call mpi_comm_rank(comm, rank, ierr)
6682 
6683  procs(1) = nprocs / 2
6684  procs(2) = nprocs - procs(1)
6685  parent = 0
6686  child = parent + procs(1)
6687 
6688  asize = n / 2
6689  if(mod(n,2_8) .ne. 0) asize(1) = asize(1) + 1
6690 
6691  allocate(tmpary(n))
6692  if(rank < child) then
6693  call mpi_comm_split(comm, 0, rank, newcomm, ierr)
6694  tmpary(1:asize(1)) = array(1:asize(1))
6695  if(procs(1) > 1) then
6696  call merge_sort_mpi(asize(1), tmpary(1:asize(1)), newcomm)
6697  else
6698  call sort_quicksort(asize(1), tmpary(1:asize(1)))
6699  end if
6700  else
6701  call mpi_comm_split(comm, 1, rank, newcomm, ierr)
6702  tmpary((asize(1) + 1):n) = array((asize(1) + 1):n)
6703  if(procs(2) > 1) then
6704  call merge_sort_mpi(asize(2), tmpary((asize(1) + 1):n), newcomm)
6705  else
6706  call sort_quicksort(asize(2), tmpary((asize(1) + 1):n))
6707  end if
6708  end if
6709 
6710  call merge_mpi_no_nest(asize(1), tmpary(1:asize(1)), asize(2), tmpary((asize(1) + 1):n), n, array, parent, child, comm)
6711 
6712  end subroutine merge_sort_mpi
6713 
6714  recursive subroutine merge_mpi(n1, ary1, n2, ary2, n3, ary3, parent, child, nprocs, comm)
6715  implicit none
6716 
6717  integer(8), intent(in) :: n1, ary1(n1), n2, ary2(n2), n3
6718  integer, intent(in) :: parent, child, nprocs, comm
6719  integer(8), intent(inout) :: ary3(n3)
6720  integer(8) k, m, pivot
6721  integer, parameter :: threshold = 10
6722  integer procs(2), grandchild1, grandchild2, rank, newcomm
6723  integer, parameter :: tag_p2c = 12345
6724  integer, parameter :: tag_p2g = 23451
6725  integer, parameter :: tag_c2g = 34512
6726  integer, parameter :: tag_p2h = 45123
6727  integer, parameter :: tag_c2h = 51234
6728 
6729  integer :: ierr
6730 
6731  call mpi_comm_rank(comm, rank, ierr)
6732  procs(1) = child - parent
6733  procs(2) = nprocs - procs(1)
6734 
6735  k = n1 / 2
6736  if(rank == parent) pivot = ary1(k)
6737  call mpi_bcast(pivot, 1, mpi_integer8, parent, comm, ierr)
6738  if(rank == child) m = binary_search_i8(n2, ary2, pivot)
6739  call mpi_bcast(m, 1, mpi_integer8, child, comm, ierr)
6740 
6741  if(procs(1) > 1 .and. n1 >= threshold) then
6742  grandchild1 = parent + (procs(1) / 2)
6743  else
6744  grandchild1 = parent
6745  end if
6746  if(procs(2) > 1 .and. n2 >= threshold) then
6747  grandchild2 = child + (procs(2) / 2)
6748  else
6749  grandchild2 = child
6750  end if
6751 
6752  if(rank >= parent .and. rank < child) then
6753  call mpi_comm_split(comm, 0, rank, newcomm, ierr)
6754 
6755  if(rank == parent) then
6756  if(rank == grandchild1) then
6757  call mpi_sendrecv(ary1((k + 1):n1), int(n1 - k), mpi_integer8, grandchild2, tag_p2h, &
6758  & ary2(1:m), int(m), mpi_integer8, child, tag_c2g, &
6759  & comm, mpi_status_ignore, ierr)
6760  else
6761  call mpi_send(ary1((k + 1):n1), int(n1 - k,4), mpi_integer8, grandchild2, &
6762  & tag_p2h, comm, ierr)
6763  end if
6764  else if(rank == grandchild1) then
6765  call mpi_recv(ary2(1:m), int(m), mpi_integer8, child, &
6766  & tag_c2g, comm, mpi_status_ignore, ierr)
6767  end if
6768 
6769  if(procs(1) > 1 .and. n1 >= threshold) then
6770  call merge_mpi(k, ary1(1:k), m, ary2(1:m), k + m, ary3(1:(k + m)), 0, grandchild1 - parent, procs(1), newcomm)
6771  else
6772  call merge(k, ary1(1:k), m, ary2(1:m), k + m, ary3(1:(k + m)))
6773  end if
6774  if(rank == parent) then
6775  call mpi_recv(ary3((k + m + 1):n3), int(n3 - (k + m)), mpi_integer8, child, &
6776  & tag_p2c, comm, mpi_status_ignore, ierr)
6777  end if
6778  else if(rank >= child .and. rank < parent + nprocs) then
6779  call mpi_comm_split(comm, 1, rank, newcomm, ierr)
6780 
6781  if(rank == child) then
6782  if(rank == grandchild2) then
6783  call mpi_sendrecv(ary2(1:m), int(m), mpi_integer8, grandchild1, tag_c2g, &
6784  & ary1((k + 1):n1), int(n1 - k), mpi_integer8, parent, tag_p2h, &
6785  & comm, mpi_status_ignore, ierr)
6786  else
6787  call mpi_send(ary2(1:m), int(m,4), mpi_integer8, grandchild1, &
6788  & tag_c2g, comm, ierr)
6789  end if
6790  else if(rank == grandchild2) then
6791  call mpi_recv(ary1((k + 1):n1), int(n1 - k), mpi_integer8, parent, &
6792  & tag_p2h, comm, mpi_status_ignore, ierr)
6793  end if
6794 
6795  if(procs(2) > 1 .and. n2 >= threshold) then
6796  call merge_mpi(n2 - m, ary2((m + 1):n2), n1 - k, ary1((k + 1):n1), & !NOTE: FLIP SIDE
6797  & n3 - (k + m), ary3((k + m + 1):n3), 0, grandchild2 - child, procs(2), newcomm)
6798  else
6799  call merge(n1 - k, ary1((k + 1):n1), n2 - m, ary2((m + 1):n2), &
6800  & n3 - (k + m), ary3((k + m + 1):n3))
6801  end if
6802  if(rank == child) then
6803  call mpi_send(ary3((k + m + 1):n3), int(n3 - (k + m)), mpi_integer8, parent, &
6804  & tag_p2c, comm, ierr)
6805  end if
6806  else
6807  call mpi_comm_split(comm, 3, rank, newcomm, ierr) !SHOULD NOT HAPPEN (BUG)
6808  write(*, *) "something wrong in merge_mpi"
6809  end if
6810  end subroutine merge_mpi
6811 
6812  recursive subroutine merge_mpi_no_nest(n1, ary1, n2, ary2, n3, ary3, parent, child, comm)
6813  implicit none
6814 
6815  integer(8), intent(in) :: n1, ary1(n1), n2, ary2(n2), n3
6816  integer, intent(in) :: parent, child, comm
6817  integer(8), intent(inout) :: ary3(n3)
6818  integer(8) k, m, pivot
6819  integer, parameter :: threshold = 10
6820  integer rank
6821  integer, parameter :: tag_p2c = 12345
6822 
6823  integer(8) pivot_dummy
6824 
6825  integer :: ierr
6826 
6827  pivot_dummy=10
6828 
6829  call mpi_comm_rank(comm, rank, ierr)
6830 
6831  k = n1 / 2
6832  if(rank == parent) then
6833  pivot = ary1(k)
6834 
6835  call mpi_send(pivot, 1, mpi_integer8, child, tag_p2c, comm, ierr)
6836 
6837  call mpi_recv(m, 1, mpi_integer8, child, tag_p2c, comm, mpi_status_ignore, ierr)
6838  call mpi_sendrecv(ary1((k + 1):n1), int(n1 - k), mpi_integer8, child, tag_p2c, &
6839  & ary2(1:m), int(m), mpi_integer8, child, tag_p2c, &
6840  & comm, mpi_status_ignore, ierr)
6841  call merge(k, ary1(1:k), m, ary2(1:m), k + m, ary3(1:(k + m)))
6842  call mpi_recv(ary3((k + m + 1):n3), int(n3 - (k + m)), mpi_integer8, child, &
6843  & tag_p2c, comm, mpi_status_ignore, ierr)
6844  else if(rank == child) then
6845  call mpi_recv(pivot, 1, mpi_integer8, parent, tag_p2c, comm, mpi_status_ignore, ierr)
6846  m = binary_search_i8(n2, ary2, pivot)
6847  call mpi_send(m, 1, mpi_integer8, parent, tag_p2c, comm, ierr)
6848  call mpi_sendrecv(ary2(1:m), int(m), mpi_integer8, parent, tag_p2c, &
6849  & ary1((k + 1):n1), int(n1 - k), mpi_integer8, parent, tag_p2c, &
6850  & comm, mpi_status_ignore, ierr)
6851  call merge(n1 - k, ary1((k + 1):n1), n2 - m, ary2((m + 1):n2), &
6852  & n3 - (k + m), ary3((k + m + 1):n3))
6853  call mpi_send(ary3((k + m + 1):n3), int(n3 - (k + m)), mpi_integer8, parent, &
6854  & tag_p2c, comm, ierr)
6855  end if
6856  end subroutine merge_mpi_no_nest
6857 
6858  !-------------------------------------------------------------------------------
6859  ! Scatter gridded data to processes (nrank -> all)
6860  !-------------------------------------------------------------------------------
6861  subroutine scatter_grd_mpi(nrank,v3dg,v2dg,v3d,v2d)
6862  integer,intent(in) :: nrank
6863  real(RP),intent(in) :: v3dg(nlev,nlon,nlat,nv3d)
6864  real(RP),intent(in) :: v2dg(nlon,nlat,nv2d)
6865  real(RP),intent(out) :: v3d(nij1,nlev,nv3d)
6866  real(RP),intent(out) :: v2d(nij1,nv2d)
6867  real(RP) :: bufs(nij1max,nlevall,NPRC_ENS)
6868  real(RP) :: bufr(nij1max,nlevall)
6869  integer :: j,k,n,ierr,ns,nr
6870 
6871  ns = nij1max * nlevall
6872  nr = ns
6873  if( rank_ens == nrank ) then
6874  j=0
6875  do n=1,nv3d
6876  do k=1,nlev
6877  j = j+1
6878  call grd_to_buf( nprc_ens, v3dg(k,:,:,n), bufs(:,j,:) )
6879  end do
6880  end do
6881 
6882  do n=1,nv2d
6883  j = j+1
6884  call grd_to_buf( nprc_ens, v2dg(:,:,n),bufs(:,j,:) )
6885  end do
6886  end if
6887 
6888  CALL mpi_scatter( bufs, ns, datatype, bufr, nr, datatype, nrank, comm_ens, ierr )
6889 
6890  j=0
6891  do n=1,nv3d
6892  do k=1,nlev
6893  j = j+1
6894  v3d(:,k,n) = real( bufr(1:nij1,j), kind=rp )
6895  end do
6896  end do
6897 
6898  do n=1,nv2d
6899  j = j+1
6900  v2d(:,n) = real( bufr(1:nij1,j), kind=rp )
6901  end do
6902 
6903  return
6904  end subroutine scatter_grd_mpi
6905 
6906  !-------------------------------------------------------------------------------
6907  ! Scatter gridded data using MPI_ALLTOALL(V) (mstart~mend -> all)
6908  !-------------------------------------------------------------------------------
6909  subroutine scatter_grd_mpi_all2all(mstart,mend,v3dg,v2dg,v3d,v2d)
6910  integer,intent(in) :: mstart,mend
6911  real(RP),intent(in) :: v3dg(nlev,nlon,nlat,nv3d)
6912  real(RP),intent(in) :: v2dg(nlon,nlat,nv2d)
6913  real(RP),intent(inout) :: v3d(nij1,nlev,nens,nv3d)
6914  real(RP),intent(inout) :: v2d(nij1,nens,nv2d)
6915  real(RP) :: bufs(nij1max,nlevall,NPRC_ENS)
6916  real(RP) :: bufr(nij1max,nlevall,NPRC_ENS)
6917  integer :: k,n,j,m,mcount,ierr
6918  integer :: ns(NPRC_ENS),nst(NPRC_ENS),nr(NPRC_ENS),nrt(NPRC_ENS)
6919 
6920  mcount = mend - mstart + 1
6921 
6922  if(rank_ens < mcount) then
6923  j = 0
6924  do n = 1, nv3d
6925  do k = 1, nlev
6926  j = j+1
6927  call grd_to_buf(nprc_ens,v3dg(k,:,:,n),bufs(:,j,:))
6928  end do
6929  end do
6930  do n = 1, nv2d
6931  j = j+1
6932  call grd_to_buf(nprc_ens,v2dg(:,:,n),bufs(:,j,:))
6933  end do
6934  end if
6935 
6936  if(mcount == nprc_ens) then
6937  call mpi_alltoall(bufs, nij1max*nlevall, datatype, &
6938  bufr, nij1max*nlevall, datatype, comm_ens, ierr)
6939  else
6940  call set_all2allv_counts(mcount,nij1max*nlevall,nprc_ens,nr,nrt,ns,nst)
6941  call mpi_alltoallv(bufs, ns, nst, datatype, &
6942  bufr, nr, nrt, datatype, comm_ens, ierr)
6943  end if
6944 
6945  do m = mstart, mend
6946  j = 0
6947  do n = 1, nv3d
6948  do k = 1, nlev
6949  j = j+1
6950  v3d(:,k,m,n) = real(bufr(1:nij1,j,m-mstart+1),kind=rp)
6951  end do
6952  end do
6953  do n = 1, nv2d
6954  j = j+1
6955  v2d(:,m,n) = real(bufr(1:nij1,j,m-mstart+1),kind=rp)
6956  end do
6957  end do
6958 
6959  return
6960  end subroutine scatter_grd_mpi_all2all
6961 
6962  !-------------------------------------------------------------------------------
6963  ! Gather gridded data using MPI_ALLTOALL(V) (all -> mstart~mend)
6964  !-------------------------------------------------------------------------------
6965  subroutine gather_grd_mpi_all2all(mstart,mend,v3d,v2d,v3dg,v2dg)
6966  integer,intent(in) :: mstart,mend
6967  real(RP),intent(in) :: v3d(nij1,nlev,nens,nv3d)
6968  real(RP),intent(in) :: v2d(nij1,nens,nv2d)
6969  real(RP),intent(out) :: v3dg(nlev,nlon,nlat,nv3d)
6970  real(RP),intent(out) :: v2dg(nlon,nlat,nv2d)
6971  real(RP) :: bufs(nij1max,nlevall,NPRC_ENS)
6972  real(RP) :: bufr(nij1max,nlevall,NPRC_ENS)
6973  integer :: k,n,j,m,mcount,ierr
6974  integer :: ns(NPRC_ENS),nst(NPRC_ENS),nr(NPRC_ENS),nrt(NPRC_ENS)
6975 
6976  mcount = mend - mstart + 1
6977 
6978  do m = mstart, mend
6979  j = 0
6980  do n = 1, nv3d
6981  do k = 1, nlev
6982  j = j+1
6983  bufs(1:nij1,j,m-mstart+1) = real(v3d(:,k,m,n),kind=rp)
6984  end do
6985  end do
6986  do n=1,nv2d
6987  j = j+1
6988  bufs(1:nij1,j,m-mstart+1) = real(v2d(:,m,n),kind=rp)
6989  end do
6990  end do
6991 
6992  if(mcount == nprc_ens) then
6993  call mpi_alltoall(bufs, nij1max*nlevall, datatype, &
6994  bufr, nij1max*nlevall, datatype, comm_ens, ierr)
6995  else
6996  call set_all2allv_counts(mcount,nij1max*nlevall,nprc_ens,ns,nst,nr,nrt)
6997  call mpi_alltoallv(bufs, ns, nst, datatype, &
6998  bufr, nr, nrt, datatype, comm_ens, ierr)
6999  end if
7000 
7001  if(rank_ens < mcount) then
7002  j = 0
7003  do n = 1, nv3d
7004  do k = 1, nlev
7005  j = j+1
7006  call buf_to_grd(nprc_ens,bufr(:,j,:),v3dg(k,:,:,n))
7007  end do
7008  end do
7009  do n = 1, nv2d
7010  j = j+1
7011  call buf_to_grd(nprc_ens,bufr(:,j,:),v2dg(:,:,n))
7012  end do
7013  end if
7014 
7015  return
7016  end subroutine gather_grd_mpi_all2all
7017 
7018  !-------------------------------------------------------------------------------
7019  ! Set the send/recieve counts of MPI_ALLTOALLV
7020  !-------------------------------------------------------------------------------
7021  subroutine set_all2allv_counts(mcount,ngpblock,np,n_ens,nt_ens,n_mem,nt_mem)
7022  integer,intent(in) :: mcount,ngpblock
7023  integer,intent(in) :: np
7024  integer,intent(out) :: n_ens(np),nt_ens(np),n_mem(np),nt_mem(np)
7025  integer :: p
7026 
7027  n_ens = 0
7028  nt_ens = 0
7029  n_mem = 0
7030  nt_mem = 0
7031  do p = 1, mcount
7032  n_ens(p) = ngpblock
7033  if(rank_ens+1 == p) then
7034  n_mem(:) = ngpblock
7035  end if
7036  end do
7037  do p = 2, np
7038  nt_ens(p) = nt_ens(p-1) + n_ens(p-1)
7039  nt_mem(p) = nt_mem(p-1) + n_mem(p-1)
7040  end do
7041 
7042  return
7043  end subroutine set_all2allv_counts
7044 
7045  !-------------------------------------------------------------------------------
7046  ! gridded data -> buffer
7047  !-------------------------------------------------------------------------------
7048  subroutine grd_to_buf(np,grd,buf)
7049  use scale_const, only: &
7050  undef => const_undef
7051  integer,intent(in) :: np
7052  real(RP),intent(in) :: grd(nlon,nlat)
7053  real(RP),intent(out) :: buf(nij1max,np)
7054  integer :: i,j,m,ilon,ilat
7055 
7056  do m = 1, np
7057  do i = 1, nij1node(m)
7058  j = m-1 + np * (i-1)
7059  ilon = mod(j,nlon) + 1
7060  ilat = (j-ilon+1) / nlon + 1
7061 
7062  buf(i,m) = grd(ilon,ilat)
7063  end do
7064  end do
7065 
7066  do m = 1,np
7067  if( nij1node(m) < nij1max ) buf(nij1max,m) = undef
7068  end do
7069 
7070  return
7071  end subroutine grd_to_buf
7072 
7073  !-------------------------------------------------------------------------------
7074  ! buffer -> gridded data
7075  !-------------------------------------------------------------------------------
7076  subroutine buf_to_grd(np,buf,grd)
7077  integer,intent(in) :: np
7078  real(RP),intent(in) :: buf(nij1max,np)
7079  real(RP),intent(out) :: grd(nlon,nlat)
7080  integer :: i,j,m,ilon,ilat
7081 
7082  do m = 1,np
7083  do i = 1,nij1node(m)
7084  j = m-1 + np * (i-1)
7085  ilon = mod(j,nlon) + 1
7086  ilat = (j-ilon+1) / nlon + 1
7087  grd(ilon,ilat) = buf(i,m)
7088  end do
7089  end do
7090 
7091  return
7092  end subroutine buf_to_grd
7093 
7094  !-------------------------------------------------------------------------------
7095  ! Calculate 3D height coordinate given the topography height (on scattered grids)
7096  !-------------------------------------------------------------------------------
7097  ! [INPUT]
7098  ! nij : scattered grid numbers
7099  ! topo(nij) : topography height (on scattered grids)
7100  ! [OUTPUT]
7101  ! z(nij,nlev) : 3D height coordinate (on scattered grids)
7102  !-------------------------------------------------------------------------------
7103  subroutine calc_z_grd(nij, topo, z)
7104  use scale_atmos_grid_cartesc, only: &
7105  atmos_grid_cartesc_cz, &
7106  atmos_grid_cartesc_fz
7107  use scale_atmos_grid_cartesc_index, only: &
7108  khalo, ks, ke
7109  implicit none
7110 
7111  integer, intent(in) :: nij
7112  real(RP), intent(in) :: topo(nij)
7113  real(RP), intent(out) :: z(nij,nlev)
7114  real(RP) :: ztop
7115  integer :: k, i
7116 
7117  ztop = atmos_grid_cartesc_fz(ke) - atmos_grid_cartesc_fz(ks-1)
7118  do k = 1, nlev
7119  do i = 1, nij
7120  z(i,k) = (ztop - topo(i)) / ztop * atmos_grid_cartesc_cz(k+khalo) + topo(i)
7121  end do
7122  end do
7123 
7124  return
7125  end subroutine calc_z_grd
7126 
7127  subroutine qc_indexing_and_packing(&
7128  & na, nr, ne, ze, vr, radlon, radlat, radz, & ! input spherical
7129  & qcflag, input_is_dbz, attenuation, & ! input spherical
7130  & nlon, nlat, nlev, lon, lat, z, dlon, dlat, dz, & ! input cartesian
7131  & missing, & ! input param
7132  & lon0, lat0, & ! input param
7133  & nobs_each_elev, packed_grid, packed_data, packed_attn) ! output
7134  use scale_const, only: &
7135  radius => const_radius, &
7136  d2r => const_d2r
7137  implicit none
7138 
7139  integer, intent(in) :: na, nr, ne ! array size of the spherical grid
7140  real(RP), intent(in) :: ze(na * nr, ne), vr(na * nr, ne) ! main data
7141  real(RP), intent(in), dimension(na * nr, ne) :: radlon, radlat, radz ! georeference
7142  real(RP), intent(in) :: qcflag(na * nr, ne) ! additional info
7143  logical, intent(in) :: input_is_dbz
7144  real(RP), intent(in) :: lon0, lat0
7145  real(RP), intent(in), dimension(na * nr, ne) :: attenuation
7146  integer, intent(in) :: nlon, nlat, nlev ! array size of the cartesian grid
7147  real(RP), intent(in) :: lon(nlon), lat(nlat), z(nlev)
7148  real(RP), intent(in) :: dlon, dlat, dz, missing
7149  integer(8), intent(out) :: nobs_each_elev(ne)
7150  integer(8), intent(out) :: packed_grid(na * nr * ne) !MAX DATA SIZE
7151  real(RP), intent(out) :: packed_data(5, na * nr * ne) !MAX DATA SIZE
7152  logical, intent(out) :: packed_attn(na * nr * ne) !MAX DATA SIZE
7153  REAL(RP) :: ri, rj, rk, dlon_inv, dlat_inv, dz_inv, qced_ze, qced_vr
7154  INTEGER :: i, ie
7155  integer(8) :: idx
7156 
7157  real(RP) :: lon_coef, lat_coef, dist_i, dist_j
7158  real(RP) :: vr_min_dist_square
7159 
7160  lon_coef = d2r * (cos(lat0 * d2r) * radius)
7161  lat_coef = d2r * radius
7162  vr_min_dist_square = vr_min_dist * vr_min_dist
7163 
7164  dlon_inv = 1.0d0 / dlon
7165  dlat_inv = 1.0d0 / dlat
7166  dz_inv = 1.0d0 / dz
7167 
7168  nobs_each_elev = 0
7169  idx = 1
7170  do ie = 1, ne
7171  do i = 1, na * nr
7172  !QC
7173  qced_ze = ze(i, ie)
7174  qced_vr = vr(i, ie)
7175 
7176  ! We will work with reflectivity (not in dbz) if we have dbz as input
7177  ! then transform it
7178  IF(input_is_dbz .and. (qced_ze .ne. missing)) qced_ze = 10.0d0 ** (qced_ze * 0.1d0)
7179 
7180  ! Missing values not associated with clutter will be asigned a minimum
7181  ! reflectivity value.
7182  if(qced_ze .LE. missing) then
7183  qced_ze = minz
7184  qced_vr = missing !added by Otsuka
7185  end if
7186  if(qced_ze .LT. minz) then
7187  qced_ze = minz
7188  end if
7189  if(qced_ze .LT. min_radar_ref_vr) then
7190  qced_vr = missing !added by Otsuka
7191  end if
7192 
7193  ! If dealing with qced real data it will be a good idea to remove all
7194  ! values detected as non weather echoes in the qc algorithm.
7195  ! This can also be useful to deal with simulated tophographyc shading
7196  ! in OSSES.
7197  ! We need reflectivity to average vr observations. Remove vr
7198  ! observations where the reflectivity is missing.
7199  if(use_qcflag .and. (qcflag(i, ie) .GE. 900.0d0)) then
7200  qced_ze = missing
7201  qced_vr = missing
7202  endif
7203 
7204  if(qced_ze == missing) cycle
7205 
7206  ! Get i,j,k very simple approach since we are assuming a regular
7207  ! lat/lon/z grid.
7208  ri = (radlon(i, ie) - lon(1)) * dlon_inv
7209  rj = (radlat(i, ie) - lat(1)) * dlat_inv
7210  rk = (radz(i, ie) - z(1) ) * dz_inv
7211 
7212  if(ri < 0 .or. ri >= nlon .or. rj < 0 .or. rj >= nlat .or. rk < 0 .or. rk >= nlev) cycle
7213 
7214  if (qced_vr > missing) then
7215  if (radz(i, ie) < radar_zmin) then
7216  qced_vr = missing
7217  else
7218  dist_i = (radlon(i, ie) - lon0) * lon_coef
7219  dist_j = (radlat(i, ie) - lat0) * lat_coef
7220  if (dist_i * dist_i + dist_j * dist_j < vr_min_dist_square) then
7221  qced_vr = missing
7222  end if
7223  end if
7224  end if
7225 
7226  packed_grid(idx) = aint(ri) + (aint(rj) + aint(rk) * nlat) * nlon + 1
7227  packed_data(1, idx) = qced_ze
7228  packed_data(2, idx) = qced_vr
7229  packed_data(3, idx) = radlon(i, ie)
7230  packed_data(4, idx) = radlat(i, ie)
7231  packed_data(5, idx) = radz(i, ie)
7232  packed_attn(idx) = ((.not. use_attenuation) .or. &
7233  & (attenuation(i, ie) > attenuation_threshold)) !seems wrong but not yet confirmed
7234  idx = idx + 1
7235  nobs_each_elev(ie) = nobs_each_elev(ie) + 1
7236 
7237  end do ! i
7238  end do ! ie
7239  end subroutine qc_indexing_and_packing
7240 
7241  !-----------------------------------------------------------------------
7242  ! Convert a raw obsID to a sequential obsID (1 - nid_obs)
7243  !-----------------------------------------------------------------------
7244  integer function uid_obs(id_obs)
7245  implicit none
7246  integer, intent(in) :: id_obs
7247  !---------------------------------------------------------------------
7248 
7249  select case(id_obs)
7250  case(id_u_obs)
7251  uid_obs = 1
7252  case(id_v_obs)
7253  uid_obs = 2
7254  case(id_t_obs)
7255  uid_obs = 3
7256  case(id_tv_obs)
7257  uid_obs = 4
7258  case(id_q_obs)
7259  uid_obs = 5
7260  case(id_rh_obs)
7261  uid_obs = 6
7262  case(id_ps_obs)
7263  uid_obs = 7
7264  case(id_rain_obs)
7265  uid_obs = 8
7266  case(id_radar_ref_obs)
7267  uid_obs = 9
7268  case(id_radar_ref_zero_obs)
7269  uid_obs = 10
7270  case(id_radar_vr_obs)
7271  uid_obs = 11
7272  case(id_radar_prh_obs)
7273  uid_obs = 12
7274  case(id_h08ir_obs) ! H08
7275  uid_obs = 13 ! H08
7276  case(id_tclon_obs)
7277  uid_obs = 14
7278  case(id_tclat_obs)
7279  uid_obs = 15
7280  case(id_tcmip_obs)
7281  uid_obs = 16
7282  case default
7283  uid_obs = -1 ! error
7284  end select
7285 
7286  return
7287  end function uid_obs
7288 
7289  !-----------------------------------------------------------------------
7290  ! Convert a raw obsID to a sequential obsID for variable localization (1 - nid_obs_verlocal)
7291  !-----------------------------------------------------------------------
7292  integer function uid_obs_varlocal(id_obs)
7293  implicit none
7294  integer, intent(in) :: id_obs
7295  !---------------------------------------------------------------------
7296 
7297  select case(id_obs)
7298  case(id_u_obs, id_v_obs)
7299  uid_obs_varlocal = 1
7300  case(id_t_obs, id_tv_obs)
7301  uid_obs_varlocal = 2
7302  case(id_q_obs, id_rh_obs)
7303  uid_obs_varlocal = 3
7304  case(id_ps_obs)
7305  uid_obs_varlocal = 4
7306  case(id_rain_obs)
7307  uid_obs_varlocal = 5
7308  case(id_tclon_obs, id_tclat_obs, id_tcmip_obs)
7309  uid_obs_varlocal = 6
7310  case(id_radar_ref_obs, id_radar_ref_zero_obs, id_radar_prh_obs)
7311  uid_obs_varlocal = 7
7312  case(id_radar_vr_obs)
7313  uid_obs_varlocal = 8
7314  case(id_h08ir_obs) ! H08
7315  uid_obs_varlocal = 9 ! H08
7316  case default
7317  uid_obs_varlocal = -1 ! error
7318  end select
7319  end function uid_obs_varlocal
7320 
7321  function binary_search_i8(n, ary, val)
7322  integer(8) binary_search_i8
7323  integer(8), intent(in) :: n
7324  integer(8), intent(in) :: ary(n), val
7325  integer(8) pivot, nmax, nmin
7326  nmin = 1
7327  nmax = n
7328 
7329  if(ary(1) < ary(n)) then
7330  do while(nmax > nmin + 1)
7331  pivot = nmin + (nmax - nmin) / 2
7332  if(val == ary(pivot)) then
7333  nmin = pivot
7334  exit
7335  else if(val < ary(pivot)) then
7336  nmax = pivot
7337  else
7338  nmin = pivot
7339  end if
7340  end do
7341  else
7342  do while(nmax > nmin + 1)
7343  pivot = nmin + (nmax - nmin) / 2
7344  if(val == ary(pivot)) then
7345  nmin = pivot
7346  exit
7347  else if(val > ary(pivot)) then
7348  nmax = pivot
7349  else
7350  nmin = pivot
7351  end if
7352  end do
7353  end if
7354  binary_search_i8 = nmin
7355  end function binary_search_i8
7356 
7357  !-------------------------------------------------------------------------------
7358  ! Convert 1D rank of process to 2D rank
7359  !-------------------------------------------------------------------------------
7360  subroutine rank_1d_2d(rank, rank_i, rank_j)
7361  use scale_prc_cartesc, only: prc_2drank
7362  implicit none
7363  integer, intent(in) :: rank
7364  integer, intent(out) :: rank_i, rank_j
7365  !---------------------------------------------------------------------
7366 
7367  rank_i = prc_2drank(rank,1)
7368  rank_j = prc_2drank(rank,2)
7369 
7370  return
7371  end subroutine rank_1d_2d
7372 
7373  !-------------------------------------------------------------------------------
7374  ! Convert 2D rank of process to 1D rank
7375  !-------------------------------------------------------------------------------
7376  subroutine rank_2d_1d(rank_i, rank_j, rank)
7377  implicit none
7378  integer, intent(in) :: rank_i, rank_j
7379  integer, intent(out) :: rank
7380 
7381  rank = rank_j * nproc_x + rank_i
7382 
7383  return
7384  end subroutine rank_2d_1d
7385 
7386  !-------------------------------------------------------------------------------
7387  ! Given <real> global grid coordinates (i,j), return the 1D rank of process
7388  ! * HALO grids are used
7389  !-------------------------------------------------------------------------------
7390  ! [INPUT]
7391  ! ig, jg : global grid coordinates
7392  ! [OUTPUT]
7393  ! rank : the 1D rank of process where the grid resides;
7394  ! * return -1 if the grid is outside of the global domain
7395  !-------------------------------------------------------------------------------
7396  subroutine rij_rank(ig, jg, rank)
7397  implicit none
7398  real(RP), intent(in) :: ig
7399  real(RP), intent(in) :: jg
7400  integer, intent(out) :: rank
7401  integer :: rank_i, rank_j
7402 
7403  if (ig < real(start_x,kind=rp) .or. ig > real(nlon*nproc_x+xhalo,kind=rp) .or. &
7404  jg < real(start_y,kind=rp) .or. jg > real(nlat*nproc_y+yhalo,kind=rp)) then
7405  !!! exception : 2-D ideal case
7406  if (.not.(start_x == end_x .and. (ig < real(start_x,kind=rp) .or. ig > real(nlong+xhalo,kind=rp) ))) then
7407  rank = -1
7408  return
7409  end if
7410  rank = -1
7411  return
7412  end if
7413 
7414  rank_i = ceiling((ig-real(xhalo,kind=rp)-0.5_rp) / real(nlon,kind=rp)) - 1
7415  rank_j = ceiling((jg-real(yhalo,kind=rp)-0.5_rp) / real(nlat,kind=rp)) - 1
7416  call rank_2d_1d(rank_i, rank_j, rank)
7417 
7418  return
7419  end subroutine rij_rank
7420 
7421  !-------------------------------------------------------------------------------
7422  ! Convert <real> global grid coordinates (i,j) to local given the 1D rank of process
7423  !-------------------------------------------------------------------------------
7424  subroutine rij_g2l(rank, ig, jg, il, jl)
7425  implicit none
7426  integer, intent(in) :: rank
7427  real(RP), intent(in) :: ig
7428  real(RP), intent(in) :: jg
7429  real(RP), intent(out) :: il
7430  real(RP), intent(out) :: jl
7431 
7432  integer :: rank_i, rank_j
7433  !---------------------------------------------------------------------
7434 
7435  call rank_1d_2d( rank, rank_i, rank_j )
7436  il = ig - real(rank_i * nlon, kind=rp)
7437  jl = jg - real(rank_j * nlat, kind=rp)
7438 
7439  return
7440  end subroutine rij_g2l
7441 
7442  !-----------------------------------------------------------------------
7443  ! Convert grid (i,j) values to obsgrid (ogi, ogj) sorting mesh
7444  !-----------------------------------------------------------------------
7445  subroutine ij_obsgrd( ctype, ri, rj, ogi, ogj )
7446  implicit none
7447  integer, intent(in) :: ctype
7448  real(RP), intent(in) :: ri, rj
7449  integer, intent(out) :: ogi, ogj
7450  real(RP) :: ril, rjl
7451 
7452  call rij_g2l( rank_lcl, ri, rj, ril, rjl )
7453  ogi = ceiling( ( ril - real( xhalo, kind=rp ) - 0.5 ) * real( obsgrd(ctype)%ngrd_i, kind=rp ) / real( nlon, kind=rp ) )
7454  ogj = ceiling( ( rjl - real( yhalo, kind=rp ) - 0.5 ) * real( obsgrd(ctype)%ngrd_j, kind=rp ) / real( nlat, kind=rp ) )
7455 
7456  return
7457  end subroutine ij_obsgrd
7458 
7459  !-----------------------------------------------------------------------
7460  ! Convert grid (i,j) values to obsgrid (ogi, ogj) sorting mesh in the extended subdomain
7461  !-----------------------------------------------------------------------
7462  subroutine ij_obsgrd_ext( ctype, ri, rj, ogi, ogj )
7463  implicit none
7464  integer, intent(in) :: ctype
7465  real(RP), intent(in) :: ri, rj
7466  integer, intent(out) :: ogi, ogj
7467 
7468  real(RP) :: ril, rjl
7469  !---------------------------------------------------------------------
7470 
7471  call rij_g2l( rank_lcl, ri, rj, ril, rjl )
7472  ogi = ceiling( ( ril - real( xhalo, kind=rp ) - 0.5 ) * real( obsgrd(ctype)%ngrd_i, kind=rp ) / real( nlon, kind=rp ) ) &
7473  + obsgrd(ctype)%ngrdsch_i
7474  ogj = ceiling( ( rjl - real( yhalo, kind=rp ) - 0.5 ) * real( obsgrd(ctype)%ngrd_j, kind=rp ) / real( nlat, kind=rp ) ) &
7475  + obsgrd(ctype)%ngrdsch_j
7476 
7477  return
7478  end subroutine ij_obsgrd_ext
7479 
7480  !-----------------------------------------------------------------------
7481  ! Choose observations in a rectangle using the bucket sort results
7482  !-----------------------------------------------------------------------
7483  subroutine obs_choose(ctype, proc, imin, imax, jmin, jmax, nn, nobs_use)
7484  implicit none
7485  integer, intent(in) :: ctype
7486  integer, intent(in) :: proc
7487  integer, intent(in) :: imin, imax, jmin, jmax
7488  integer, intent(inout) :: nn
7489  integer, intent(inout), optional :: nobs_use(:)
7490  integer :: n, j
7491 
7492  if (imin > imax .or. jmin > jmax) return
7493  if (obsgrd(ctype)%tot(proc) == 0) return
7494 
7495  do j = jmin, jmax
7496  if (present(nobs_use)) then
7497  do n = obsgrd(ctype)%ac(imin-1,j,proc)+1, obsgrd(ctype)%ac(imax,j,proc)
7498  nn = nn + 1
7499  nobs_use(nn) = n
7500  end do
7501  else
7502  nn = nn + obsgrd(ctype)%ac(imax,j,proc) - obsgrd(ctype)%ac(imin-1,j,proc)
7503  end if
7504  end do
7505 
7506  return
7507  end subroutine obs_choose
7508 
7509  !-----------------------------------------------------------------------
7510  ! Choose observations in a rectangle using the bucket sort results in the extended subdomain
7511  !-----------------------------------------------------------------------
7512  subroutine obs_choose_ext(ctype, imin, imax, jmin, jmax, nn, nobs_use)
7513  implicit none
7514  integer, intent(in) :: ctype
7515  integer, intent(in) :: imin, imax, jmin, jmax
7516  integer, intent(inout) :: nn
7517  integer, intent(out), optional :: nobs_use(:)
7518 
7519  integer :: n, j
7520  !---------------------------------------------------------------------
7521 
7522  if (imin > imax .or. jmin > jmax) return
7523  if (obsgrd(ctype)%tot_ext == 0) return
7524 
7525  do j = jmin, jmax
7526  if (present(nobs_use)) then
7527  do n = obsgrd(ctype)%ac_ext(imin-1,j)+1, obsgrd(ctype)%ac_ext(imax,j)
7528  nn = nn + 1
7529  nobs_use(nn) = n
7530  end do
7531  else
7532  nn = nn + obsgrd(ctype)%ac_ext(imax,j) - obsgrd(ctype)%ac_ext(imin-1,j)
7533  end if
7534  end do
7535 
7536  return
7537  end subroutine obs_choose_ext
7538 
7539  subroutine obs_info_allocate(obs, extended)
7540  implicit none
7541  type(obs_info),intent(inout) :: obs
7542  logical, optional, intent(in) :: extended
7543 
7544  call obs_info_deallocate(obs)
7545 
7546  allocate( obs%elm (obs%nobs) )
7547  allocate( obs%lon (obs%nobs) )
7548  allocate( obs%lat (obs%nobs) )
7549  allocate( obs%lev (obs%nobs) )
7550  allocate( obs%dat (obs%nobs) )
7551  allocate( obs%err (obs%nobs) )
7552  allocate( obs%typ (obs%nobs) )
7553  allocate( obs%dif (obs%nobs) )
7554 
7555  obs%elm = 0
7556  obs%lon = 0.0d0
7557  obs%lat = 0.0d0
7558  obs%lev = 0.0d0
7559  obs%dat = 0.0d0
7560  obs%err = 0.0d0
7561  obs%typ = 0
7562  obs%dif = 0.0d0
7563 
7564  if (present(extended)) then
7565  if (extended) then
7566  allocate( obs%ri (obs%nobs) )
7567  allocate( obs%rj (obs%nobs) )
7568  allocate( obs%rank (obs%nobs) )
7569 
7570  obs%ri = 0.0d0
7571  obs%rj = 0.0d0
7572  obs%rank = -1
7573  end if
7574  end if
7575 
7576  return
7577  end subroutine obs_info_allocate
7578 
7579  subroutine obs_info_deallocate(obs)
7580  implicit none
7581  type(obs_info),intent(inout) :: obs
7582 
7583  if( allocated(obs%elm) ) deallocate(obs%elm)
7584  if( allocated(obs%lon) ) deallocate(obs%lon)
7585  if( allocated(obs%lat) ) deallocate(obs%lat)
7586  if( allocated(obs%lev) ) deallocate(obs%lev)
7587  if( allocated(obs%dat) ) deallocate(obs%dat)
7588  if( allocated(obs%err) ) deallocate(obs%err)
7589  if( allocated(obs%typ) ) deallocate(obs%typ)
7590  if( allocated(obs%dif) ) deallocate(obs%dif)
7591  if( allocated(obs%ri ) ) deallocate(obs%ri)
7592  if( allocated(obs%rj ) ) deallocate(obs%rj)
7593  if( allocated(obs%rank)) deallocate(obs%rank)
7594 
7595  return
7596  end subroutine obs_info_deallocate
7597 
7598  subroutine obs_da_value_allocate( obsda, member )
7599  implicit none
7600  type(obs_da_value), intent(inout) :: obsda
7601  integer, intent(in) :: member
7602 
7603  call obs_da_value_deallocate( obsda )
7604 
7605  allocate( obsda%set (obsda%nobs) )
7606  allocate( obsda%idx (obsda%nobs) )
7607  allocate( obsda%key (obsda%nobs) )
7608  allocate( obsda%val (obsda%nobs) )
7609  allocate( obsda%qc (obsda%nobs) )
7610 
7611  allocate( obsda%tm (obsda%nobs) )
7612  allocate( obsda%pm (obsda%nobs) )
7613  allocate( obsda%qv (obsda%nobs) )
7614 
7615  obsda%nobs_in_key = 0
7616  obsda%idx = 0
7617  obsda%key = 0
7618  obsda%val = 0.0d0
7619  obsda%qc = 0
7620 
7621  obsda%tm = 0.0d0
7622  obsda%pm = 0.0d0
7623  obsda%qv = 0.0d0
7624 
7625  if (member > 0) then
7626  allocate( obsda%ensval(member,obsda%nobs) )
7627  obsda%ensval = 0.0d0
7628 
7629  allocate( obsda%eqv(member,obsda%nobs) )
7630  obsda%eqv = 0.0d0
7631  end if
7632 
7633  return
7634  end subroutine obs_da_value_allocate
7635 
7636  subroutine obs_da_value_deallocate( obsda )
7637  implicit none
7638  type(obs_da_value), intent(inout) :: obsda
7639 
7640  obsda%nobs_in_key = 0
7641 
7642  if( allocated(obsda%set ) ) deallocate(obsda%set )
7643  if( allocated(obsda%idx ) ) deallocate(obsda%idx )
7644  if( allocated(obsda%key ) ) deallocate(obsda%key )
7645  if( allocated(obsda%val ) ) deallocate(obsda%val )
7646  if( allocated(obsda%ensval) ) deallocate(obsda%ensval)
7647  if( allocated(obsda%qc ) ) deallocate(obsda%qc )
7648 
7649  if( allocated(obsda%tm ) ) deallocate(obsda%tm)
7650  if( allocated(obsda%pm ) ) deallocate(obsda%pm)
7651  if( allocated(obsda%eqv ) ) deallocate(obsda%eqv)
7652  if( allocated(obsda%qv ) ) deallocate(obsda%qv)
7653 
7654  return
7655  end subroutine obs_da_value_deallocate
7656 
7657  subroutine obs_da_value_allreduce( obsda )
7658  implicit none
7659  type(obs_da_value), intent(inout) :: obsda
7660 
7661  real(RP), allocatable :: ensval_bufs(:,:)
7662  real(RP), allocatable :: ensval_bufr(:,:)
7663  real(RP), allocatable :: ensval_bufs2(:,:)
7664  real(RP), allocatable :: ensval_bufr2(:,:)
7665  integer :: cnts
7666  integer :: cntr(NPRC_ENS)
7667  integer :: dspr(NPRC_ENS)
7668  integer :: current_shape(2)
7669  integer :: ie, it, im, imb, ierr
7670 
7671  if( obsda%nobs <= 0 ) then
7672  return
7673  end if
7674 
7675  ! variables with an ensemble dimension
7676  cntr(:) = 0
7677  do ie = 1, nprc_ens
7678  cntr(ie) = cntr(ie) + 1
7679  end do
7680  allocate( ensval_bufs(obsda%nobs, cntr(rank_ens+1)) )
7681  allocate( ensval_bufr(obsda%nobs, nprc_ens) )
7682  allocate( ensval_bufs2(obsda%nobs, cntr(rank_ens+1)) )
7683  allocate( ensval_bufr2(obsda%nobs, nprc_ens) )
7684 
7685  do im = 1, cntr(rank_ens+1)
7686  ensval_bufs(:,im) = obsda%ensval(im,:)
7687  ensval_bufs2(:,im) = obsda%eqv(im,:)
7688  end do
7689 
7690  cntr(:) = cntr(:) * obsda%nobs
7691  cnts = cntr(rank_ens+1)
7692  dspr(1) = 0
7693  do ie = 2, nprc_ens
7694  dspr(ie) = dspr(ie-1) + cntr(ie-1)
7695  end do
7696 
7697  call mpi_allgatherv( ensval_bufs, cnts, datatype, ensval_bufr, cntr, dspr, datatype, comm_ens, ierr )
7698  call mpi_allgatherv( ensval_bufs2, cnts, datatype, ensval_bufr2, cntr, dspr, datatype, comm_ens, ierr )
7699 
7700  current_shape = shape(obsda%ensval)
7701  if (current_shape(1) < nprc_ens) then
7702  deallocate (obsda%ensval)
7703  allocate (obsda%ensval(nprc_ens, obsda%nobs))
7704  deallocate (obsda%eqv)
7705  allocate (obsda%eqv(nprc_ens, obsda%nobs))
7706  end if
7707 
7708  do ie = 1, nprc_ens
7709  obsda%ensval(ie,:) = ensval_bufr(:,ie)
7710  obsda%eqv(ie,:) = ensval_bufr2(:,ie)
7711  end do
7712  deallocate(ensval_bufs, ensval_bufr)
7713  deallocate(ensval_bufs2, ensval_bufr2)
7714 
7715  ! variables without an ensemble dimension
7716  if( nprc_ens > 1 ) then
7717  call mpi_allreduce( mpi_in_place, obsda%qc(:), obsda%nobs, mpi_integer, mpi_max, comm_ens, ierr )
7718  call mpi_allreduce( mpi_in_place, obsda%tm(:), obsda%nobs, datatype, mpi_sum, comm_ens, ierr )
7719  call mpi_allreduce( mpi_in_place, obsda%pm(:), obsda%nobs, datatype, mpi_sum, comm_ens, ierr )
7720  end if
7721  obsda%tm = obsda%tm / real( nprc_ens, kind=rp )
7722  obsda%pm = obsda%pm / real( nprc_ens, kind=rp )
7723 
7724  return
7725  end subroutine obs_da_value_allreduce
7726 
7727  subroutine obs_da_value_partial_reduce_iter(obsda, iter, nstart, nobs, ensval, qc, eqv, tm, pm )
7728  implicit none
7729  type(obs_da_value), intent(inout) :: obsda
7730  integer, intent(in) :: iter
7731  integer, intent(in) :: nstart
7732  integer, intent(in) :: nobs
7733  real(RP), intent(in) :: ensval(nobs)
7734  integer, intent(in) :: qc(nobs)
7735  real(RP), intent(in) :: eqv(nobs)
7736  real(RP), intent(in) :: tm(nobs)
7737  real(RP), intent(in) :: pm(nobs)
7738 
7739  integer :: nend
7740 
7741  if (nobs <= 0) then
7742  return
7743  end if
7744  nend = nstart + nobs - 1
7745 
7746  ! variables with an ensemble dimension
7747  obsda%ensval(iter,nstart:nend) = ensval
7748  obsda%eqv(iter,nstart:nend) = eqv
7749 
7750  ! variables without an ensemble dimension
7751  obsda%qc(nstart:nend) = max(obsda%qc(nstart:nend), qc)
7752  ! only consider tm & pm from members, not from the mean
7753  obsda%tm(nstart:nend) = obsda%tm(nstart:nend) + tm
7754  obsda%pm(nstart:nend) = obsda%pm(nstart:nend) + pm
7755 
7756  return
7757  end subroutine obs_da_value_partial_reduce_iter
7758 
7759  !-------------------------------------------------------------------------------
7760  ! Read ensemble additive inflation parameter and distribute to processes
7761  !-------------------------------------------------------------------------------
7762  subroutine read_ens_mpi_addiinfl(v3d, v2d)
7763  implicit none
7764  real(RP), intent(out) :: v3d(:,:,:,:)
7765  real(RP), intent(out) :: v2d(:,:,:)
7766 
7767  character(len=H_LONG) :: filename
7768  real(RP) :: v3dg(nlev,nlon,nlat,nv3d)
7769  real(RP) :: v2dg(nlon,nlat,nv2d)
7770  integer :: it, im, mstart, mend
7771  !---------------------------------------------------------------------
7772 
7773  ! [TODO]: restructure this subroutine
7774  v3d = 0.0_rp
7775  v2d = 0.0_rp
7776  !
7777  !do it = 1, nitmax
7778  ! im = myrank_to_mem(it)
7779 
7780  ! ! Note: read all members
7781  ! if (im >= 1 .and. im <= MEMBER) then
7782  ! filename = INFL_ADD_IN_BASENAME
7783  ! call filename_replace_mem(filename, im)
7784  ! call read_restart(filename, v3dg, v2dg)
7785  ! end if
7786 
7787  ! mstart = 1 + (it-1)*nprocs_e
7788  ! mend = min(it*nprocs_e, MEMBER)
7789  ! if (mstart <= mend) then
7790  ! call scatter_grd_mpi_alltoall(mstart, mend, v3dg, v2dg, v3d, v2d)
7791  ! end if
7792  !end do
7793 
7794  return
7795  end subroutine read_ens_mpi_addiinfl
7796 
7797  !-----------------------------------------------------------------------
7798  ! Monitor observation departure by giving the v3dg,v2dg data
7799  !-----------------------------------------------------------------------
7800  subroutine monit_obs( OBS_IN_NUM, OBS_IN_FORMAT, v3dg, v2dg, nobs, bias, rmse, monit_type, use_key, step )
7801  use scale_const, only: &
7802  undef => const_undef
7803  use scale_prc, only: &
7804  prc_myrank
7805  implicit none
7806 
7807  integer, intent(in) :: OBS_IN_NUM
7808  character(len=H_LONG), intent(in) :: OBS_IN_FORMAT(:)
7809 
7810  real(RP), intent(in) :: v3dg(nlev,nlon,nlat,nv3d)
7811  real(RP), intent(in) :: v2dg(nlon,nlat,nv2d)
7812  integer, intent(out) :: nobs(nid_obs)
7813  real(RP), intent(out) :: bias(nid_obs)
7814  real(RP), intent(out) :: rmse(nid_obs)
7815  logical, intent(out) :: monit_type(nid_obs)
7816  logical, intent(in) :: use_key
7817  integer, intent(in) :: step
7818 
7819  real(RP) :: v3dgh(nlevh,nlonh,nlath,nv3dd)
7820  real(RP) :: v2dgh(nlonh,nlath,nv2dd)
7821  integer :: nnobs
7822  integer :: n,nn
7823  integer :: iset,iidx
7824  real(RP) :: ril,rjl,rk,rkz
7825 
7826  real(RP), allocatable :: oelm(:)
7827  real(RP), allocatable :: ohx(:)
7828  integer, allocatable :: oqc(:)
7829 
7830  call state_to_history(v3dg, v2dg, v3dgh, v2dgh)
7831 
7832  if (use_key) then
7833  nnobs = obsda_sort%nobs_in_key
7834  else
7835  nnobs = obsda_sort%nobs
7836  end if
7837 
7838  allocate (oelm(nnobs))
7839  allocate (ohx(nnobs))
7840  allocate (oqc(nnobs))
7841 
7842  if (step == 1) then
7843  obsdep_nobs = nnobs
7844  allocate (obsdep_set(obsdep_nobs))
7845  allocate (obsdep_idx(obsdep_nobs))
7846  allocate (obsdep_qc(obsdep_nobs))
7847  allocate (obsdep_omb(obsdep_nobs))
7848  allocate (obsdep_oma(obsdep_nobs))
7849  end if
7850 
7851  oqc = -1
7852 
7853  do n = 1, nnobs
7854 
7855  if (use_key) then
7856  nn = obsda_sort%key(n)
7857  else
7858  nn = n
7859  end if
7860 
7861  iset = obsda_sort%set(nn)
7862  iidx = obsda_sort%idx(nn)
7863 
7864  if (step == 1) then
7865  obsdep_set(n) = iset
7866  obsdep_idx(n) = iidx
7867  end if
7868 
7869  oelm(n) = obs(iset)%elm(iidx)
7870  call rij_g2l(prc_myrank, obs(iset)%ri(iidx), obs(iset)%rj(iidx), ril, rjl)
7871 
7872  if (departure_stat_t_range <= 0.0d0 .or. &
7873  abs(obs(iset)%dif(iidx)) <= departure_stat_t_range) then
7874 
7875  oqc(n) = iqc_otype
7876 
7877  select case (obs_in_format(iset))
7878  !=========================================================================
7879  case ( 'PREPBUFR' )
7880  !-------------------------------------------------------------------------
7881  call phys2ijk(v3dgh(:,:,:,iv3dd_p),obs(iset)%elm(iidx), &
7882  ril,rjl,obs(iset)%lev(iidx),rk,oqc(n))
7883  if (oqc(n) == iqc_good) then
7884  call trans_xtoy(obs(iset)%elm(iidx),ril,rjl,rk, &
7885  obs(iset)%lon(iidx),obs(iset)%lat(iidx), &
7886  v3dgh,v2dgh,ohx(n),oqc(n),stggrd=1)
7887  end if
7888  !=========================================================================
7889  case ( 'RADAR', 'PAWR_TOSHIBA', 'MP_PAWR_TOSHIBA', 'PAWR_JRC', 'HIMAWARI8' )
7890  !-------------------------------------------------------------------------
7891  if (departure_stat_radar) then
7892  call phys2ijkz(v3dgh(:,:,:,iv3dd_hgt),ril,rjl,obs(iset)%lev(iidx),rkz,oqc(n))
7893  if (oqc(n) == iqc_good) then
7894  call trans_xtoy_radar(obs(iset)%elm(iidx),obs(iset)%meta(1), &
7895  obs(iset)%meta(2),obs(iset)%meta(3),ril,rjl,rkz, &
7896  obs(iset)%lon(iidx),obs(iset)%lat(iidx), &
7897  obs(iset)%lev(iidx),v3dgh,v2dgh,ohx(n),oqc(n),stggrd=1)
7898  if (oqc(n) == iqc_ref_low) oqc(n) = iqc_good ! when process the observation operator, we don't care if reflectivity is 350
7899  end if
7900  end if
7901  !=========================================================================
7902  end select
7903 
7904  if (oqc(n) == iqc_good) then
7905  ohx(n) = obs(iset)%dat(iidx) - ohx(n)
7906  else
7907  ohx(n) = undef
7908  end if
7909 
7910  if (step == 1) then
7911  obsdep_qc(n) = oqc(n)
7912  obsdep_omb(n) = ohx(n)
7913  else if (step == 2) then
7914  if (obsdep_qc(n) == iqc_good) then ! Use the QC value of y_a only if the QC of y_b is good
7915  obsdep_qc(n) = oqc(n) !
7916  end if !
7917  obsdep_oma(n) = ohx(n)
7918  end if
7919 
7920  end if ! [ DEPARTURE_STAT_T_RANGE <= 0.0d0 .or. &
7921  ! abs(obs(iset)%dif(iidx)) <= DEPARTURE_STAT_T_RANGE ]
7922 
7923  end do ! [ n = 1, nnobs ]
7924 
7925 
7926  call monit_dep(nnobs,oelm,ohx,oqc,nobs,bias,rmse)
7927 
7928  monit_type = .false.
7929  monit_type(uid_obs(id_u_obs)) = .true.
7930  monit_type(uid_obs(id_v_obs)) = .true.
7931  monit_type(uid_obs(id_t_obs)) = .true.
7932  monit_type(uid_obs(id_tv_obs)) = .true.
7933  monit_type(uid_obs(id_q_obs)) = .true.
7934  monit_type(uid_obs(id_rh_obs)) = .true.
7935  monit_type(uid_obs(id_ps_obs)) = .true.
7936  if (departure_stat_radar) then
7937  monit_type(uid_obs(id_radar_ref_obs)) = .true.
7938  monit_type(uid_obs(id_radar_ref_zero_obs)) = .true.
7939  monit_type(uid_obs(id_radar_vr_obs)) = .true.
7940  end if
7941 
7942  deallocate (oelm)
7943  deallocate (ohx)
7944  deallocate (oqc)
7945 
7946  return
7947  end subroutine monit_obs
7948 
7949  !-------------------------------------------------------------------------------
7950  ! MPI driver for monitoring observation departure statistics
7951  !-------------------------------------------------------------------------------
7952  subroutine monit_obs_mpi( OBS_IN_NUM, OBS_IN_FORMAT, v3dg, v2dg, monit_step, timelabel )
7953  use scale_const, only: &
7954  undef => const_undef
7955  implicit none
7956 
7957  integer, intent(in) :: OBS_IN_NUM
7958  character(len=H_LONG), intent(in) :: OBS_IN_FORMAT(:)
7959 
7960  real(RP), intent(in) :: v3dg(nlev,nlon,nlat,nv3d)
7961  real(RP), intent(in) :: v2dg(nlon,nlat,nv2d)
7962  integer, intent(in) :: monit_step
7963  character(15), intent(in), optional :: timelabel
7964 
7965  integer :: nobs(nid_obs)
7966  integer :: nobs_g(nid_obs)
7967  real(RP) :: bias(nid_obs)
7968  real(RP) :: bias_g(nid_obs)
7969  real(RP) :: rmse(nid_obs)
7970  real(RP) :: rmse_g(nid_obs)
7971  logical :: monit_type(nid_obs)
7972  integer :: obsdep_g_nobs
7973  integer, allocatable :: obsdep_g_set(:)
7974  integer, allocatable :: obsdep_g_idx(:)
7975  integer, allocatable :: obsdep_g_qc(:)
7976  real(RP), allocatable :: obsdep_g_omb(:)
7977  real(RP), allocatable :: obsdep_g_oma(:)
7978  integer :: cnts
7979  integer :: cntr(NPRC_LCL)
7980  integer :: dspr(NPRC_LCL)
7981  integer :: i, ip, ierr
7982 
7983  if( rank_ens == 0 ) then
7984  call monit_obs( obs_in_num, obs_in_format, v3dg, v2dg, nobs, bias, rmse, monit_type, .true., monit_step )
7985 
7986  do i = 1, nid_obs
7987  if (monit_type(i)) then
7988  nobs_g(i) = nobs(i)
7989  if (nobs(i) == 0) then
7990  bias_g(i) = 0.0d0
7991  rmse_g(i) = 0.0d0
7992  else
7993  bias_g(i) = bias(i) * real( nobs(i), kind=rp )
7994  rmse_g(i) = rmse(i) * rmse(i) * real( nobs(i), kind=rp )
7995  end if
7996  end if
7997  end do
7998 
7999  if( nprc_lcl > 1 ) then
8000  call mpi_allreduce(mpi_in_place, nobs_g, nid_obs, mpi_integer, mpi_sum, comm_lcl, ierr)
8001  call mpi_allreduce(mpi_in_place, bias_g, nid_obs, datatype, mpi_sum, comm_lcl, ierr)
8002  call mpi_allreduce(mpi_in_place, rmse_g, nid_obs, datatype, mpi_sum, comm_lcl, ierr)
8003  end if
8004 
8005  do i = 1, nid_obs
8006  if (monit_type(i)) then
8007  if (nobs_g(i) == 0) then
8008  bias_g(i) = undef
8009  rmse_g(i) = undef
8010  else
8011  bias_g(i) = bias_g(i) / real(nobs_g(i),kind=rp)
8012  rmse_g(i) = sqrt(rmse_g(i) / real(nobs_g(i),kind=rp))
8013  end if
8014  else
8015  nobs_g(i) = -1
8016  bias_g(i) = undef
8017  rmse_g(i) = undef
8018  end if
8019  end do
8020 
8021  if (monit_step == 2) then
8022  cnts = obsdep_nobs
8023  cntr = 0
8024  cntr(rank_lcl+1) = cnts
8025  call mpi_allreduce( mpi_in_place, cntr, nprc_lcl, mpi_integer, mpi_sum, comm_lcl, ierr )
8026  dspr = 0
8027  do ip = 1, nprc_lcl-1
8028  dspr(ip+1) = dspr(ip) + cntr(ip)
8029  end do
8030 
8031  obsdep_g_nobs = dspr(nprc_lcl) + cntr(nprc_lcl)
8032  allocate (obsdep_g_set(obsdep_g_nobs))
8033  allocate (obsdep_g_idx(obsdep_g_nobs))
8034  allocate (obsdep_g_qc(obsdep_g_nobs))
8035  allocate (obsdep_g_omb(obsdep_g_nobs))
8036  allocate (obsdep_g_oma(obsdep_g_nobs))
8037 
8038  if (obsdep_g_nobs > 0) then
8039  call mpi_gatherv(obsdep_set, cnts, mpi_integer, obsdep_g_set, cntr, dspr, mpi_integer, 0, comm_lcl, ierr)
8040  call mpi_gatherv(obsdep_idx, cnts, mpi_integer, obsdep_g_idx, cntr, dspr, mpi_integer, 0, comm_lcl, ierr)
8041  call mpi_gatherv(obsdep_qc, cnts, mpi_integer, obsdep_g_qc, cntr, dspr, mpi_integer, 0, comm_lcl, ierr)
8042  call mpi_gatherv(obsdep_omb, cnts, datatype, obsdep_g_omb, cntr, dspr, datatype, 0, comm_lcl, ierr)
8043  call mpi_gatherv(obsdep_oma, cnts, datatype, obsdep_g_oma, cntr, dspr, datatype, 0, comm_lcl, ierr)
8044  end if
8045 
8046  deallocate (obsdep_g_set)
8047  deallocate (obsdep_g_idx)
8048  deallocate (obsdep_g_qc )
8049  deallocate (obsdep_g_omb)
8050  deallocate (obsdep_g_oma)
8051 
8052  end if ! [ OBSDEP_OUT .and. monit_step == 2 ]
8053 
8054  if (monit_step == 2) then
8055  deallocate (obsdep_set)
8056  deallocate (obsdep_idx)
8057  deallocate (obsdep_qc )
8058  deallocate (obsdep_omb)
8059  deallocate (obsdep_oma)
8060  end if
8061  end if ! [ myrank_e == mmean_rank_e ]
8062 
8063  call mpi_bcast(nobs, nid_obs, mpi_integer, 0, comm_ens, ierr)
8064  call mpi_bcast(bias, nid_obs, datatype, 0, comm_ens, ierr)
8065  call mpi_bcast(rmse, nid_obs, datatype, 0, comm_ens, ierr)
8066  call mpi_bcast(nobs_g, nid_obs, mpi_integer, 0, comm_ens, ierr)
8067  call mpi_bcast(bias_g, nid_obs, datatype, 0, comm_ens, ierr)
8068  call mpi_bcast(rmse_g, nid_obs, datatype, 0, comm_ens, ierr)
8069  call mpi_bcast(monit_type, nid_obs, mpi_logical, 0, comm_ens, ierr)
8070 
8071  if( monit_step == 1 ) then
8072  log_info("LETKF_debug",'(1x,A)') 'OBSERVATIONAL DEPARTURE STATISTICS [GUESS] (IN THIS SUBDOMAIN):'
8073  else if (monit_step == 2) then
8074  log_info("LETKF_debug",'(1x,A)') 'OBSERVATIONAL DEPARTURE STATISTICS [ANALYSIS] (IN THIS SUBDOMAIN):'
8075  end if
8076  call monit_print(nobs, bias, rmse, monit_type)
8077 
8078  if (monit_step == 1) then
8079  log_info("LETKF_debug",'(1x,A)') 'OBSERVATIONAL DEPARTURE STATISTICS [GUESS] (GLOBAL):'
8080  else if (monit_step == 2) then
8081  log_info("LETKF_debug",'(1x,A)') 'OBSERVATIONAL DEPARTURE STATISTICS [ANALYSIS] (GLOBAL):'
8082  end if
8083  call monit_print(nobs_g, bias_g, rmse_g, monit_type)
8084 
8085  return
8086  end subroutine monit_obs_mpi
8087 
8088  !
8089  ! monit_obs is ported into obs/obs_tools.f90
8090  !
8091  SUBROUTINE monit_dep(nn,elm,dep,qc,nobs,bias,rmse)
8092  use scale_const, only: &
8093  undef => const_undef
8094  IMPLICIT NONE
8095  INTEGER,INTENT(IN) :: nn
8096  REAL(RP),INTENT(IN) :: elm(nn)
8097  REAL(RP),INTENT(IN) :: dep(nn)
8098  INTEGER,INTENT(IN) :: qc(nn)
8099  INTEGER,INTENT(OUT) :: nobs(nid_obs)
8100  REAL(RP),INTENT(OUT) :: bias(nid_obs)
8101  REAL(RP),INTENT(OUT) :: rmse(nid_obs)
8102  INTEGER :: n,i,ielm
8103 
8104  nobs = 0
8105  bias = 0.0d0
8106  rmse = 0.0d0
8107 
8108  DO n=1,nn
8109  IF(qc(n) /= iqc_good) cycle
8110 
8111  ielm = nint(elm(n))
8112  if (ielm == id_tv_obs) then ! compute Tv as T
8113  ielm = id_t_obs
8114  end if
8115  if (ielm == id_radar_ref_zero_obs) then ! compute RE0 as REF
8116  ielm = id_radar_ref_obs
8117  end if
8118 
8119  i = uid_obs(ielm)
8120  nobs(i) = nobs(i) + 1
8121  bias(i) = bias(i) + dep(n)
8122  rmse(i) = rmse(i) + dep(n)**2
8123  END DO
8124 
8125  DO i = 1, nid_obs
8126  IF(nobs(i) == 0) THEN
8127  bias(i) = undef
8128  rmse(i) = undef
8129  ELSE
8130  bias(i) = bias(i) / real(nobs(i),kind=rp)
8131  rmse(i) = sqrt(rmse(i) / real(nobs(i),kind=rp))
8132  END IF
8133  END DO
8134 
8135  RETURN
8136  END SUBROUTINE monit_dep
8137 
8138  !-----------------------------------------------------------------------
8139  ! Monitor departure
8140  !-----------------------------------------------------------------------
8141  SUBROUTINE monit_print(nobs,bias,rmse,monit_type)
8142  IMPLICIT NONE
8143  INTEGER,INTENT(IN) :: nobs(nid_obs)
8144  REAL(RP),INTENT(IN) :: bias(nid_obs)
8145  REAL(RP),INTENT(IN) :: rmse(nid_obs)
8146  LOGICAL,INTENT(IN),OPTIONAL :: monit_type(nid_obs)
8147 
8148  character(12) :: var_show(nid_obs)
8149  character(12) :: nobs_show(nid_obs)
8150  character(12) :: bias_show(nid_obs)
8151  character(12) :: rmse_show(nid_obs)
8152 
8153  integer :: i, n
8154  character(4) :: nstr
8155 
8156  logical :: monit_type_(nid_obs)
8157 
8158  monit_type_ = .true.
8159  if (present(monit_type)) monit_type_ = monit_type
8160 
8161  n = 0
8162  do i = 1, nid_obs
8163  if (monit_type_(i) .and. i /= uid_obs(id_tv_obs) .and. i /= uid_obs(id_radar_ref_zero_obs)) then
8164  n = n + 1
8165  write(var_show(n),'(A12)') obelmlist(i)
8166  write(nobs_show(n),'(I12)') nobs(i)
8167  if (nobs(i) > 0) then
8168  write(bias_show(n),'(ES12.3)') bias(i)
8169  write(rmse_show(n),'(ES12.3)') rmse(i)
8170  else
8171  write(bias_show(n),'(A12)') 'N/A'
8172  write(rmse_show(n),'(A12)') 'N/A'
8173  end if
8174  end if
8175  end do
8176  write(nstr, '(I4)') n
8177 
8178  log_info("LETKF_debug",'(1x,A,' // trim(nstr) // "('============'))") '======'
8179  log_info("LETKF_debug",'(1x,A,' // trim(nstr) // 'A)' ) ' ', var_show(1:n)
8180  log_info("LETKF_debug",'(1x,A,' // trim(nstr) // "('------------'))") '------'
8181  log_info("LETKF_debug",'(1x,A,' // trim(nstr) // 'A)' ) 'BIAS ', bias_show(1:n)
8182  log_info("LETKF_debug",'(1x,A,' // trim(nstr) // 'A)' ) 'RMSE ', rmse_show(1:n)
8183  log_info("LETKF_debug",'(1x,A,' // trim(nstr) // 'A)' ) 'NUMBER', nobs_show(1:n)
8184  log_info("LETKF_debug",'(1x,A,' // trim(nstr) // "('============'))") '======'
8185 
8186  RETURN
8187  END SUBROUTINE monit_print
8188 
8189  !-------------------------------------------------------------------------------
8190  ! Transform the LETKF state variables to the variables in SCALE history files
8191  ! (with HALO), so that they can be used for observation operator calculation
8192  !-------------------------------------------------------------------------------
8193  ! [INPUT]
8194  ! v3dg, v2dg : 3D, 2D state variables
8195  ! topo : topography
8196  ! [OUTPUT]
8197  ! v3dgh, v2dgh : 3D, 2D SCALE history variables
8198  !-------------------------------------------------------------------------------
8199  subroutine state_to_history(v3dg, v2dg, v3dgh, v2dgh)
8200  use scale_comm_cartesc, only: &
8201  comm_vars8, &
8202  comm_wait
8203  use scale_atmos_grid_cartesc_metric, only: &
8204  rotc => atmos_grid_cartesc_metric_rotc
8205  use scale_atmos_grid_cartesc_real, only: &
8206  real_cz => atmos_grid_cartesc_real_cz
8207  use scale_const, only: &
8208  undef => const_undef, &
8209  rdry => const_rdry, &
8210  rvap => const_rvap
8211  use scale_atmos_saturation, only: &
8212  atmos_saturation_psat_all
8213  implicit none
8214 
8215  real(RP), intent(in) :: v3dg(nlev,nlon,nlat,nv3d)
8216  real(RP), intent(in) :: v2dg(nlon,nlat,nv2d)
8217  real(RP), intent(out) :: v3dgh(nlevh,nlonh,nlath,nv3dd)
8218  real(RP), intent(out) :: v2dgh(nlonh,nlath,nv2dd)
8219  real(RP) :: v3dgh_RP(nlevh,nlonh,nlath,nv3dd)
8220  real(RP) :: v2dgh_RP(nlonh,nlath,nv2dd)
8221 
8222  integer :: i, j, k, iv3d, iv2d
8223 
8224  real(RP) :: utmp, vtmp
8225  real(RP) :: qdry, Rtot
8226  real(RP) :: psat(nlevh,nlonh,nlath)
8227 
8228  ! Variables that can be directly copied
8229  !---------------------------------------------------------
8230  v3dgh_rp(:,:,:,:) = undef
8231  v2dgh_rp(:,:,:) = undef
8232 
8233  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_u) = v3dg(:,:,:,iv3d_u)
8234  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_v) = v3dg(:,:,:,iv3d_v)
8235  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_w) = v3dg(:,:,:,iv3d_w)
8236  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_t) = v3dg(:,:,:,iv3d_t)
8237  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_p) = v3dg(:,:,:,iv3d_p)
8238  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_q) = v3dg(:,:,:,iv3d_q)
8239  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_qc) = v3dg(:,:,:,iv3d_qc)
8240  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_qr) = v3dg(:,:,:,iv3d_qr)
8241  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_qi) = v3dg(:,:,:,iv3d_qi)
8242  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_qs) = v3dg(:,:,:,iv3d_qs)
8243  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_qg) = v3dg(:,:,:,iv3d_qg)
8244 
8245  ! Rotate U/V (model coord. wind) and obtain Umet/Vmet (true zonal/meridional wind)
8246  !-------------
8247  do j = start_y, end_y
8248  do i = start_x, end_x
8249  do k = start_z, end_z
8250  utmp = v3dgh_rp(k,i,j,iv3d_u)
8251  vtmp = v3dgh_rp(k,i,j,iv3d_v)
8252 
8253  v3dgh_rp(k,i,j,iv3d_u) = utmp * rotc(i,j,1) - vtmp * rotc(i,j,2)
8254  v3dgh_rp(k,i,j,iv3d_v) = utmp * rotc(i,j,2) + vtmp * rotc(i,j,1)
8255  enddo
8256  enddo
8257  enddo
8258 
8259  ! RH
8260  !---------------------------------------------------------
8261 
8262  call atmos_saturation_psat_all( nlevh, start_z, end_z, & ! (in)
8263  nlonh, start_x, end_x, & ! (in)
8264  nlath, start_y, end_y, & ! (in)
8265  v3dgh_rp(:,:,:,iv3dd_t), & ! (in)
8266  psat(:,:,:) ) ! (out)
8267 
8268  !$omp parallel do private(k,i,j,qdry,Rtot) schedule(static) collapse(2)
8269  do j = start_y, end_y
8270  do i = start_x, end_x
8271  do k = start_z, end_z
8272  qdry = 1.0
8273  do iv3d = iv3dd_q, iv3dd_qg ! loop over all moisture variables
8274  qdry = qdry - v3dgh_rp(k,i,j,iv3d)
8275  enddo
8276  rtot = rdry * qdry + rvap * v3dgh_rp(k,i,j,iv3dd_q)
8277 
8278  v3dgh_rp(k,i,j,iv3dd_rh) = v3dgh_rp(k,i,j,iv3dd_q) * v3dgh_rp(k,i,j,iv3dd_p) / psat(k,i,j) * rvap / rtot
8279  end do
8280  end do
8281  end do
8282 
8283  ! Calculate height based the the topography and vertical coordinate
8284  !---------------------------------------------------------
8285 
8286  v3dgh_rp(start_z:end_z,start_x:end_x,start_y:end_y,iv3dd_hgt) = real_cz(start_z:end_z,start_x:end_x,start_y:end_y)
8287 
8288  ! Surface variables: use the 1st level as the surface (although it is not)
8289  !---------------------------------------------------------
8290 
8291  v2dgh_rp(start_x:end_x,start_y:end_y,iv2dd_topo) = real_cz(start_z,start_x:end_x,start_y:end_y)
8292 
8293  v2dgh_rp(start_x:end_x,start_y:end_y,iv2dd_ps) = v3dg(1,1:nlon,1:nlat,iv3d_p)
8294  v2dgh_rp(start_x:end_x,start_y:end_y,iv2dd_u10m) = v3dg(1,1:nlon,1:nlat,iv3d_u)
8295  v2dgh_rp(start_x:end_x,start_y:end_y,iv2dd_v10m) = v3dg(1,1:nlon,1:nlat,iv3d_v)
8296  v2dgh_rp(start_x:end_x,start_y:end_y,iv2dd_t2m) = v3dg(1,1:nlon,1:nlat,iv3d_t)
8297  v2dgh_rp(start_x:end_x,start_y:end_y,iv2dd_q2m) = v3dg(1,1:nlon,1:nlat,iv3d_q)
8298 
8299  !v2dgh_RP(start_x:end_x,start_y:end_y,iv2dd_rain) = [[No way]]
8300 
8301  v2dgh_rp(start_x:end_x,start_y:end_y,iv2dd_ps) = v3dg(1,:,:,iv3d_p)
8302  v2dgh_rp(start_x:end_x,start_y:end_y,iv2dd_u10m) = v3dg(1,:,:,iv3d_u)
8303  v2dgh_rp(start_x:end_x,start_y:end_y,iv2dd_v10m) = v3dg(1,:,:,iv3d_v)
8304  v2dgh_rp(start_x:end_x,start_y:end_y,iv2dd_t2m) = v3dg(1,:,:,iv3d_t)
8305  v2dgh_rp(start_x:end_x,start_y:end_y,iv2dd_q2m) = v3dg(1,:,:,iv3d_q)
8306 
8307  !v2dgh_RP(start_x:end_x,start_y:end_y,iv2dd_rain) = [[No way]]
8308 
8309  do iv3d = 1, nv3dd
8310  do j = start_y, end_y
8311  do i = start_x, end_x
8312  v3dgh_rp( 1:start_z-1,i,j,iv3d) = v3dgh_rp(start_z,i,j,iv3d)
8313  v3dgh_rp(end_z+1:nlevh ,i,j,iv3d) = v3dgh_rp(end_z ,i,j,iv3d)
8314  end do
8315  end do
8316  end do
8317 
8318  ! Communicate the lateral halo areas
8319  !---------------------------------------------------------
8320 
8321  do iv3d = 1, nv3dd
8322  call comm_vars8( v3dgh_rp(:,:,:,iv3d), iv3d )
8323  end do
8324  do iv3d = 1, nv3dd
8325  call comm_wait ( v3dgh_rp(:,:,:,iv3d), iv3d )
8326  end do
8327 
8328  do iv2d = 1, nv2dd
8329  call comm_vars8( v2dgh_rp(:,:,iv2d), iv2d )
8330  end do
8331  do iv2d = 1, nv2dd
8332  call comm_wait ( v2dgh_rp(:,:,iv2d), iv2d )
8333  end do
8334 
8335  v3dgh = real(v3dgh_rp, kind=rp)
8336  v2dgh = real(v2dgh_rp, kind=rp)
8337 
8338  return
8339  end subroutine state_to_history
8340 
8341 end module scale_letkf
scale_const::const_grav
real(rp), public const_grav
standard acceleration of gravity [m/s2]
Definition: scale_const.F90:49
scale_statistics
module Statistics
Definition: scale_statistics.F90:11
scale_prc::prc_universal_ismaster
logical, public prc_universal_ismaster
master process in universal communicator?
Definition: scale_prc.F90:75
scale_precision::sp
integer, parameter, public sp
Definition: scale_precision.F90:31
scale_da_read_pawr_toshiba::eldim
integer, parameter eldim
Definition: scale_da_read_pawr_toshiba.F90:6
scale_letkf::nid_obs
integer, parameter, public nid_obs
Definition: scale_letkf.F90:49
scale_atmos_grid_cartesc_index::ke
integer, public ke
end point of inner domain: z, local
Definition: scale_atmos_grid_cartesC_index.F90:52
scale_prc::prc_abort
subroutine, public prc_abort
Abort Process.
Definition: scale_prc.F90:350
scale_letkf::i_before_qc
integer, parameter, public i_before_qc
Definition: scale_letkf.F90:54
scale_const::const_epstvap
real(rp), public const_epstvap
1 / epsilon - 1
Definition: scale_const.F90:76
scale_atmos_grid_cartesc_real::atmos_grid_cartesc_real_cz
real(rp), dimension(:,:,:), allocatable, public atmos_grid_cartesc_real_cz
geopotential height [m] (zxy)
Definition: scale_atmos_grid_cartesC_real.F90:39
scale_calendar::calendar_daysec2date
subroutine, public calendar_daysec2date(ymdhms, subsec, absday, abssec, offset_year)
Convert from gregorian date to absolute day/second.
Definition: scale_calendar.F90:255
scale_sort::sort_quickselect_desc_arg
recursive subroutine, public sort_quickselect_desc_arg(A, X, left, right, K)
Definition: scale_sort.F90:403
scale_precision
module PRECISION
Definition: scale_precision.F90:14
com_gamma
subroutine com_gamma(x, ga)
Definition: scale_letkf.F90:5109
scale_sort
module SORT
Definition: scale_sort.F90:11
scale_const::const_rvap
real(rp), parameter, public const_rvap
specific gas constant (water vapor) [J/kg/K]
Definition: scale_const.F90:68
scale_da_read_mp_pawr_toshiba::azdim
integer, parameter azdim
Definition: scale_da_read_mp_pawr_toshiba.F90:5
scale_da_read_pawr_toshiba::rdim
integer, parameter rdim
Definition: scale_da_read_pawr_toshiba.F90:4
scale_letkf::nv2d
integer, parameter, public nv2d
Definition: scale_letkf.F90:48
read_toshiba
int read_toshiba(char *fname, pawr_header *hd, float az[ELDIM][AZDIM], float el[ELDIM][AZDIM], float rtdat[ELDIM][AZDIM][RDIM])
Definition: read_toshiba.c:63
scale_letkf::letkf_obs_operator
subroutine, public letkf_obs_operator(OBS_IN_NUM, OBS_IN_FORMAT, U, V, W, TEMP, PRES, QV, QC, QR, QI, QS, QG, RH, HGT, TOPO, PS, RAIN, U10M, V10M, T2M, Q2M, nobs_extern)
Definition: scale_letkf.F90:1061
scale_da_read_mp_pawr_toshiba::c_mppawr_header
Definition: scale_da_read_mp_pawr_toshiba.F90:8
scale_letkf::nv3d
integer, parameter, public nv3d
Definition: scale_letkf.F90:47
scale_letkf::letkf_obs_readfile
subroutine, public letkf_obs_readfile(OBS_IN_NUM, OBS_IN_FORMAT, OBS_IN_BASENAME, OBS_IN_MASKFILE)
Definition: scale_letkf.F90:906
scale_atmos_grid_cartesc_metric
module Atmosphere Grid CartesianC metirc
Definition: scale_atmos_grid_cartesC_metric.F90:12
scale_letkf
module LETKF for Data-Assimilation
Definition: scale_letkf.F90:12
scale_random::random_knuth_shuffle
subroutine, public random_knuth_shuffle(num, a)
Definition: scale_random.F90:240
scale_da_read_pawr_toshiba::da_read_pawr_toshiba
integer function da_read_pawr_toshiba(fname, hd, az, el, rtdat)
Definition: scale_da_read_pawr_toshiba.F90:41
scale_prc::prc_myrank
integer, public prc_myrank
process num in local communicator
Definition: scale_prc.F90:91
scale_letkf::n_search_incr
integer, parameter n_search_incr
Definition: scale_letkf.F90:183
scale_random
module RANDOM
Definition: scale_random.F90:11
scale_atmos_grid_cartesc_index::khalo
integer, parameter, public khalo
Definition: scale_atmos_grid_cartesC_index.F90:43
scale_io::io_get_available_fid
integer function, public io_get_available_fid()
search & get available file ID
Definition: scale_io.F90:373
scale_da_read_pawr_toshiba::c_pawr_header
Definition: scale_da_read_pawr_toshiba.F90:8
scale_calendar
module CALENDAR
Definition: scale_calendar.F90:13
scale_letkf::letkf_obs_initialize
subroutine, public letkf_obs_initialize(OBS_IN_NUM, nobs_extern)
Definition: scale_letkf.F90:1453
scale_atmos_grid_cartesc_real
module Atmosphere GRID CartesC Real(real space)
Definition: scale_atmos_grid_cartesC_real.F90:11
scale_letkf::obs_grid_type
Definition: scale_letkf.F90:88
scale_letkf::obs_da_value
Definition: scale_letkf.F90:73
scale_matrix::matrix_solver_eigenvalue_decomposition
subroutine, public matrix_solver_eigenvalue_decomposition(n, a, eival, eivec, simdlen)
Definition: scale_matrix.F90:879
scale_da_read_mp_pawr_toshiba
Definition: scale_da_read_mp_pawr_toshiba.F90:1
scale_prc
module PROCESS
Definition: scale_prc.F90:11
scale_precision::rp
integer, parameter, public rp
Definition: scale_precision.F90:41
scale_mapprojection
module Map projection
Definition: scale_mapprojection.F90:12
scale_io
module STDIO
Definition: scale_io.F90:10
scale_atmos_grid_cartesc::atmos_grid_cartesc_cxg
real(rp), dimension(:), allocatable, public atmos_grid_cartesc_cxg
center coordinate [m]: x, global
Definition: scale_atmos_grid_cartesC.F90:76
scale_atmos_grid_cartesc_index
module atmosphere / grid / cartesC index
Definition: scale_atmos_grid_cartesC_index.F90:12
scale_const
module CONSTANT
Definition: scale_const.F90:11
scale_da_read_pawr_toshiba::azdim
integer, parameter azdim
Definition: scale_da_read_pawr_toshiba.F90:5
scale_letkf::max_obs_info_meta
integer, parameter, public max_obs_info_meta
Definition: scale_letkf.F90:52
scale_da_read_mp_pawr_toshiba::da_read_mp_pawr_toshiba
integer function da_read_mp_pawr_toshiba(fname, verbose, hd, az, el, rtdat)
Definition: scale_da_read_mp_pawr_toshiba.F90:39
scale_letkf::letkf_finalize
subroutine, public letkf_finalize()
Definition: scale_letkf.F90:881
scale_prc_cartesc::prc_2drank
integer, dimension(:,:), allocatable, public prc_2drank
node index in 2D topology
Definition: scale_prc_cartesC.F90:45
scale_prc_cartesc
module process / cartesC
Definition: scale_prc_cartesC.F90:11
scale_letkf::i_after_qc
integer, parameter, public i_after_qc
Definition: scale_letkf.F90:55
scale_calendar::calendar_date2daysec
subroutine, public calendar_date2daysec(absday, abssec, ymdhms, subsec, offset_year)
Convert from gregorian date to absolute day/second.
Definition: scale_calendar.F90:192
scale_letkf::letkf_param_estimation_system
subroutine, public letkf_param_estimation_system(PEST_PMAX, PEST_VAR0)
Definition: scale_letkf.F90:2873
scale_prof
module profiler
Definition: scale_prof.F90:11
scale_calendar::calendar_adjust_daysec
subroutine, public calendar_adjust_daysec(absday, abssec)
Adjust day and second.
Definition: scale_calendar.F90:442
scale_precision::dp
integer, parameter, public dp
Definition: scale_precision.F90:32
scale_time
module TIME
Definition: scale_time.F90:11
scale_sort::sort_quickselect_arg
recursive subroutine, public sort_quickselect_arg(A, X, left, right, K)
Definition: scale_sort.F90:352
scale_const::const_pi
real(rp), parameter, public const_pi
pi
Definition: scale_const.F90:32
scale_da_read_mp_pawr_toshiba::eldim
integer, parameter eldim
Definition: scale_da_read_mp_pawr_toshiba.F90:6
read_toshiba_mpr
int read_toshiba_mpr(char *in_file, int opt_verbose, mppawr_header *hd, float az[ELDIM][AZDIM], float el[ELDIM][AZDIM], float rtdat[ELDIM][AZDIM][RDIM])
Definition: read_toshiba_mpr.c:109
scale_atmos_grid_cartesc_index::ks
integer, public ks
start point of inner domain: z, local
Definition: scale_atmos_grid_cartesC_index.F90:51
scale_const::const_tem00
real(rp), parameter, public const_tem00
temperature reference (0C) [K]
Definition: scale_const.F90:99
scale_sort::sort_quicksort
recursive subroutine, public sort_quicksort(n, array)
Definition: scale_sort.F90:219
scale_atmos_grid_cartesc::atmos_grid_cartesc_fz
real(rp), dimension(:), allocatable, public atmos_grid_cartesc_fz
face coordinate [m]: z, local
Definition: scale_atmos_grid_cartesC.F90:42
scale_letkf::radar_superobing
subroutine radar_superobing(na, nr, ne, radlon, radlat, radz, ze, vr, qcflag, attenuation, nlon, nlat, nlev, lon, lat, z, dlon, dlat, dz, missing, input_is_dbz, lon0, lat0, nobs_sp, grid_index, grid_ref, grid_lon_ref, grid_lat_ref, grid_z_ref, grid_count_ref, grid_vr, grid_lon_vr, grid_lat_vr, grid_z_vr, grid_count_vr)
Definition: scale_letkf.F90:4404
scale_time::time_gettimelabel
subroutine, public time_gettimelabel(timelabel)
generate time label
Definition: scale_time.F90:93
scale_comm_cartesc
module COMMUNICATION
Definition: scale_comm_cartesC.F90:11
scale_atmos_grid_cartesc::atmos_grid_cartesc_cyg
real(rp), dimension(:), allocatable, public atmos_grid_cartesc_cyg
center coordinate [m]: y, global
Definition: scale_atmos_grid_cartesC.F90:77
scale_const::const_radius
real(rp), public const_radius
radius of the planet [m]
Definition: scale_const.F90:47
scale_matrix
module MATRIX
Definition: scale_matrix.F90:17
scale_const::const_rdry
real(rp), public const_rdry
specific gas constant (dry air) [J/kg/K]
Definition: scale_const.F90:59
scale_const::const_d2r
real(rp), public const_d2r
degree to radian
Definition: scale_const.F90:33
scale_letkf::letkf_setup
subroutine, public letkf_setup(OBS_IN_NUM, ensemble_comm, ensemble_nprocs, ensemble_myrank, local_comm, local_nprocs, local_myrank, PRC_NUM_X, PRC_NUM_Y, KA, KS, KE, IA, IS, IE, JA, JS, JE, KMAX, IMAX, JMAX, KHALO, IHALO, JHALO, delta_x, delta_y, Zsfc)
Setup.
Definition: scale_letkf.F90:615
scale_const::const_r2d
real(rp), public const_r2d
radian to degree
Definition: scale_const.F90:34
scale_letkf::n_qc_steps
integer, parameter, public n_qc_steps
Definition: scale_letkf.F90:53
scale_da_read_pawr_toshiba
Definition: scale_da_read_pawr_toshiba.F90:1
scale_atmos_grid_cartesc
module atmosphere / grid / cartesC
Definition: scale_atmos_grid_cartesC.F90:12
scale_atmos_grid_cartesc::atmos_grid_cartesc_cz
real(rp), dimension(:), allocatable, public atmos_grid_cartesc_cz
center coordinate [m]: z, local
Definition: scale_atmos_grid_cartesC.F90:41
scale_letkf::letkf_system
subroutine, public letkf_system(OBS_IN_NUM, OBS_IN_FORMAT, U, V, W, TEMP, PRES, QV, QC, QR, QI, QS, QG)
Definition: scale_letkf.F90:2189
scale_letkf::nobtype
integer, parameter, public nobtype
Definition: scale_letkf.F90:50
scale_const::const_undef
real(rp), public const_undef
Definition: scale_const.F90:43
scale_letkf::letkf_obs_clear
subroutine, public letkf_obs_clear(OBS_IN_NUM)
Definition: scale_letkf.F90:1016
scale_atmos_saturation
module atmosphere / saturation
Definition: scale_atmos_saturation.F90:12
scale_letkf::letkf_add_inflation_setup
subroutine, public letkf_add_inflation_setup(addi3d, addi2d)
Definition: scale_letkf.F90:3025
scale_io::io_fid_conf
integer, public io_fid_conf
Config file ID.
Definition: scale_io.F90:57
scale_da_read_mp_pawr_toshiba::rdim
integer, parameter rdim
Definition: scale_da_read_mp_pawr_toshiba.F90:4
scale_letkf::obs_info
Definition: scale_letkf.F90:57
scale_sort::sort_uniq_int_sorted
subroutine, public sort_uniq_int_sorted(n, ary, c)
Definition: scale_sort.F90:200
scale_atmos_grid_cartesc_metric::atmos_grid_cartesc_metric_rotc
real(rp), dimension(:,:,:), allocatable, public atmos_grid_cartesc_metric_rotc
rotation coefficient
Definition: scale_atmos_grid_cartesC_metric.F90:36
Generated by   doxygen 1.8.17