From 52b085a7e2b04b4b9b4ae8f53ce57e5bac4a7811 Mon Sep 17 00:00:00 2001 From: Yorck Ewerdwalbesloh Date: Fri, 24 Oct 2025 16:06:03 +0200 Subject: [PATCH 01/32] Backward-compatible OMI implementation --- .../running_tsmp_pdaf/input_cmd.md | 9 + interface/framework/Makefile | 7 +- interface/framework/assimilate_pdaf.F90 | 47 +- interface/framework/callback_obs_pdafomi.F90 | 225 +++ interface/framework/init_pdaf.F90 | 3 + interface/framework/init_pdaf_parse.F90 | 39 +- interface/framework/mod_assimilation.F90 | 22 + interface/framework/mod_read_obs.F90 | 498 +++++ interface/framework/next_observation_pdaf.F90 | 81 +- interface/framework/obs_GRACE_pdafomi.F90 | 829 ++++++++ interface/framework/obs_SM_pdafomi.F90 | 1070 ++++++++++ interface/model/common/enkf.h | 9 + interface/model/common/read_enkfpar.c | 9 + interface/model/eclm/enkf_clm_5.F90 | 9 + interface/model/eclm/enkf_clm_mod_5.F90 | 1785 ++++++++++++++--- interface/model/eclm/print_update_clm_5.F90 | 295 +++ interface/model/wrapper_tsmp.c | 10 +- src/PDAFomi_obs_f.F90 | 1 + 18 files changed, 4683 insertions(+), 265 deletions(-) create mode 100644 interface/framework/callback_obs_pdafomi.F90 create mode 100644 interface/framework/obs_GRACE_pdafomi.F90 create mode 100644 interface/framework/obs_SM_pdafomi.F90 diff --git a/docs/users_guide/running_tsmp_pdaf/input_cmd.md b/docs/users_guide/running_tsmp_pdaf/input_cmd.md index 17862f935..c9a097688 100644 --- a/docs/users_guide/running_tsmp_pdaf/input_cmd.md +++ b/docs/users_guide/running_tsmp_pdaf/input_cmd.md @@ -51,6 +51,15 @@ Details: `subtype` (integer) Parameter subtype, different options for each filter. See [](cmd:command-line-examples). +## use_omi ## + +`use_omi` (logical) Controls whether to use OMI interface. + +- `.true.`: OMI interface is used +- `.false.`: OMI interface is not used + +See [](cmd:command-line-examples). + ## obs_filename ## `obs_filename` (string) Prefix for observation files. diff --git a/interface/framework/Makefile b/interface/framework/Makefile index ea27c0e5c..2a1018286 100644 --- a/interface/framework/Makefile +++ b/interface/framework/Makefile @@ -79,6 +79,11 @@ MOD_ASSIM = mod_parallel_pdaf.o \ OBJ_MODEL_PDAF =pdaf_terrsysmp.o\ integrate_pdaf.o +# Routines of observation handling (PDAF-OMI) +OBJ_USER_PDAFOMI = obs_GRACE_pdafomi.o \ + obs_SM_pdafomi.o \ + callback_obs_pdafomi.o + # Interface to PDAF - model sided OBJ_PDAF_INT = init_parallel_pdaf.o \ finalize_pdaf.o \ @@ -121,7 +126,7 @@ OBJ_USER_LOCAL = init_n_domains_pdaf.o \ localize_covar_pdaf.o # Full list of user-supplied routines for online modes -OBJ_PDAF_USER = $(OBJ_USER_GEN) $(OBJ_USER_SEIK) $(OBJ_USER_ENKF) $(OBJ_USER_LOCAL) +OBJ_PDAF_USER = $(OBJ_USER_GEN) $(OBJ_USER_SEIK) $(OBJ_USER_ENKF) $(OBJ_USER_LOCAL) $(OBJ_USER_PDAFOMI) ###################################################### diff --git a/interface/framework/assimilate_pdaf.F90 b/interface/framework/assimilate_pdaf.F90 index 5e754b7df..ffc36a9b6 100644 --- a/interface/framework/assimilate_pdaf.F90 +++ b/interface/framework/assimilate_pdaf.F90 @@ -45,7 +45,10 @@ SUBROUTINE assimilate_pdaf() ONLY: abort_parallel, mype_world USE mod_assimilation, & ! Variables for assimilation ONLY: filtertype - ! USE PDAF_interfaces_module ! Check consistency of PDAF calls + USE mod_assimilation, ONLY: use_omi + USE PDAF_interfaces_module, & ! Check consistency of PDAF calls + ONLY: PDAFomi_assimilate_local, PDAFomi_assimilate_global, & + PDAFomi_assimilate_lenkf, PDAF_get_localfilter IMPLICIT NONE @@ -57,6 +60,7 @@ SUBROUTINE assimilate_pdaf() ! Local variables INTEGER :: status_pdaf ! PDAF status flag + INTEGER :: localfilter ! Flag for domain-localized filter (1=true) ! ! External subroutines @@ -102,6 +106,15 @@ SUBROUTINE assimilate_pdaf() ! EXTERNAL :: likelihood_hyb_l_pdaf, & ! Compute local likelihood awith hybrid weight for an ensemble member ! prodRinvA_hyb_l_pdaf ! Provide product R^-1 A for some matrix A including hybrid weight + ! Interface to PDAF-OMI for local and global filters + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + localize_covar_pdafomi ! Apply localization to covariance matrix in LEnKF + + + + ! *** Switch on debug output *** ! *** for main process *** #ifdef PDAF_DEBUG @@ -112,6 +125,36 @@ SUBROUTINE assimilate_pdaf() ! *** Call assimilation routine *** ! ********************************* + OMI: IF (use_omi) THEN + CALL PDAF_get_localfilter(localfilter) + + IF (localfilter == 1) THEN + + CALL PDAFomi_assimilate_local(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_ens_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + next_observation_pdaf, status_pdaf) + + ELSE + + IF (filtertype == 8) THEN + ! LEnKF has its own OMI interface routine + CALL PDAFomi_assimilate_lenkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_ens_pdaf, & + localize_covar_pdafomi, next_observation_pdaf, status_pdaf) + + ELSE + + CALL PDAFomi_assimilate_global(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_ens_pdaf, & + next_observation_pdaf, status_pdaf) + + ENDIF + + ENDIF + + ELSE OMI + ! IF (filtertype == 1) THEN ! CALL PDAF_assimilate_seik(collect_state_pdaf, distribute_state_pdaf, & ! init_dim_obs_pdaf, obs_op_pdaf, init_obs_pdaf, prepoststep_ens_pdaf, & @@ -182,6 +225,8 @@ SUBROUTINE assimilate_pdaf() ! likelihood_pdaf, next_observation_pdaf, status_pdaf) END IF + END IF OMI + ! Check for errors during execution of PDAF IF (status_pdaf /= 0) THEN diff --git a/interface/framework/callback_obs_pdafomi.F90 b/interface/framework/callback_obs_pdafomi.F90 new file mode 100644 index 000000000..bd2a834dd --- /dev/null +++ b/interface/framework/callback_obs_pdafomi.F90 @@ -0,0 +1,225 @@ +!> callback_obs_pdafomi +!! +!! This file provides interface routines between the call-back routines +!! of PDAF and the observation-specific routines in PDAF-OMI. This structure +!! collects all calls to observation-specific routines in this single file +!! to make it easier to find the routines that need to be adapted. +!! +!! The routines here are mainly pure pass-through routines. Thus they +!! simply call one of the routines from PDAF-OMI. Partly some addtional +!! variable is required, e.g. to specify the offset of an observation +!! in the observation vector containing all observation types. These +!! cases are described in the routines. +!! +!! **Adding an observation type:** +!! When adding an observation type, one has to add one module +!! obs_OBSTYPE_pdafomi (based on the template obs_OBSTYPE_pdafomi_TEMPLATE.F90). +!! In addition one has to add a call to the different routines include +!! in this file. It is recommended to keep the order of the calls +!! consistent over all files. +!! +!! __Revision history:__ +!! * 2019-12 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! +!------------------------------------------------------------------------------- + +!> Call-back routine for init_dim_obs +!! +!! This routine calls the observation-specific +!! routines init_dim_obs_TYPE. +!! +SUBROUTINE init_dim_obs_pdafomi(step, dim_obs) + + use enkf_clm_mod, only: clmupdate_swc, clmupdate_tws + + ! Include functions for different observations + USE obs_GRACE_pdafomi, ONLY: assim_GRACE, init_dim_obs_GRACE + USE obs_SM_pdafomi, ONLY: assim_SM, init_dim_obs_SM + !USE obs_ST_pdafomi, ONLY: assim_C, init_dim_obs_C + + use mod_assimilation, only: screen + USE mod_parallel_pdaf, only: mype_world + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: step !< Current time step + INTEGER, INTENT(out) :: dim_obs !< Dimension of full observation vector + + ! *** Local variables *** + INTEGER :: dim_obs_GRACE ! Observation dimensions + INTEGER :: dim_obs_SM ! Observation dimensions + !INTEGER :: dim_obs_C ! Observation dimensions + + + ! ********************************************* + ! *** Initialize full observation dimension *** + ! ********************************************* + + ! Initialize number of observations + dim_obs_GRACE = 0 + dim_obs_SM = 0 + !dim_obs_C = 0 + + + assim_SM = .true. + assim_GRACE = .true. + + + + ! Call observation-specific routines + ! The routines are independent, so it is not relevant + ! in which order they are called + + if (mype_world==0 .and. screen > 2) then + write(*,*)'Call dimension initialization' + end if + + IF (assim_GRACE) CALL init_dim_obs_GRACE(step, dim_obs_GRACE) + IF (assim_SM) CALL init_dim_obs_SM(step, dim_obs_SM) + !IF (assim_C) CALL init_dim_obs_C(step, dim_obs_C) + + dim_obs = dim_obs_GRACE + dim_obs_SM! + dim_obs_C + + END SUBROUTINE init_dim_obs_pdafomi + + + + !------------------------------------------------------------------------------- + !> Call-back routine for obs_op + !! + !! This routine calls the observation-specific + !! routines obs_op_TYPE. + !! + SUBROUTINE obs_op_pdafomi(step, dim_p, dim_obs, state_p, ostate) + + ! Include functions for different observations + USE obs_GRACE_pdafomi, ONLY: obs_op_GRACE + USE obs_SM_pdafomi, ONLY: obs_op_SM + !USE obs_C_pdafomi, ONLY: obs_op_C + + use mod_assimilation, only: screen + USE mod_parallel_pdaf, only: mype_world + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: step !< Current time step + INTEGER, INTENT(in) :: dim_p !< PE-local state dimension + INTEGER, INTENT(in) :: dim_obs !< Dimension of full observed state + REAL, INTENT(in) :: state_p(dim_p) !< PE-local model state + REAL, INTENT(inout) :: ostate(dim_obs) !< PE-local full observed state + + + ! ****************************************************** + ! *** Apply observation operator H on a state vector *** + ! ****************************************************** + + ! The order of these calls is not relevant as the setup + ! of the overall observation vector is defined by the + ! order of the calls in init_dim_obs_pdafomi + + if (mype_world==0 .and. screen > 2) then + write(*,*)'Call observation operators' + end if + + CALL obs_op_GRACE(dim_p, dim_obs, state_p, ostate) + CALL obs_op_SM(dim_p, dim_obs, state_p, ostate) + !CALL obs_op_C(dim_p, dim_obs, state_p, ostate) + + END SUBROUTINE obs_op_pdafomi + + + + !------------------------------------------------------------------------------- + !> Call-back routine for init_dim_obs_l + !! + !! This routine calls the routine PDAFomi_init_dim_obs_l + !! for each observation type + !! + SUBROUTINE init_dim_obs_l_pdafomi(domain_p, step, dim_obs, dim_obs_l) + + ! Include functions for different observations + USE obs_GRACE_pdafomi, ONLY: init_dim_obs_l_GRACE + USE obs_SM_pdafomi, ONLY: init_dim_obs_l_SM + !USE obs_C_pdafomi, ONLY: init_dim_obs_l_C + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: domain_p !< Index of current local analysis domain + INTEGER, INTENT(in) :: step !< Current time step + INTEGER, INTENT(in) :: dim_obs !< Full dimension of observation vector + INTEGER, INTENT(out) :: dim_obs_l !< Local dimension of observation vector + + + ! ********************************************** + ! *** Initialize local observation dimension *** + ! ********************************************** + + ! Call init_dim_obs_l specific for each observation + + CALL init_dim_obs_l_GRACE(domain_p, step, dim_obs, dim_obs_l) + CALL init_dim_obs_l_SM(domain_p, step, dim_obs, dim_obs_l) + !CALL init_dim_obs_l_C(domain_p, step, dim_obs, dim_obs_l) + + END SUBROUTINE init_dim_obs_l_pdafomi + + + + !------------------------------------------------------------------------------- + !> Call-back routine for localize_covar + !! + !! This routine calls the routine PDAFomi_localize_covar + !! for each observation type to apply covariance + !! localization in the LEnKF. + !! + SUBROUTINE localize_covar_pdafomi(dim_p, dim_obs, HP_p, HPH) + + ! Include functions for different observations + USE obs_GRACE_pdafomi, ONLY: localize_covar_GRACE + USE obs_SM_pdafomi, ONLY: localize_covar_SM + !USE obs_C_pdafomi, ONLY: localize_covar_C + + ! Include information on model grid + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: dim_p !< PE-local state dimension + INTEGER, INTENT(in) :: dim_obs !< number of observations + REAL, INTENT(inout) :: HP_p(dim_obs, dim_p) !< PE local part of matrix HP + REAL, INTENT(inout) :: HPH(dim_obs, dim_obs) !< Matrix HPH + + ! *** local variables *** + INTEGER :: i, j, cnt ! Counters + REAL, ALLOCATABLE :: coords_p(:,:) ! Coordinates of PE-local state vector entries + + + ! ********************** + ! *** INITIALIZATION *** + ! ********************** + + ! Initialize coordinate array + + ALLOCATE(coords_p(2, dim_p)) + + + ! ************************************* + ! *** Apply covariance localization *** + ! ************************************* + + ! Call localize_covar specific for each observation + + CALL localize_covar_GRACE(dim_p, dim_obs, HP_p, HPH, coords_p) + CALL localize_covar_SM(dim_p, dim_obs, HP_p, HPH, coords_p) + !CALL localize_covar_C(dim_p, dim_obs, HP_p, HPH, coords_p) + + + ! **************** + ! *** Clean up *** + ! **************** + + DEALLOCATE(coords_p) + + END SUBROUTINE localize_covar_pdafomi diff --git a/interface/framework/init_pdaf.F90 b/interface/framework/init_pdaf.F90 index 20fc01e84..0b01dd9d7 100644 --- a/interface/framework/init_pdaf.F90 +++ b/interface/framework/init_pdaf.F90 @@ -80,6 +80,7 @@ SUBROUTINE init_pdaf() type_winf, limit_winf, & type_hyb, hyb_gamma, hyb_kappa, & pf_res_type, pf_noise_type, pf_noise_amp + USE mod_assimilation, ONLY: use_omi USE mod_tsmp, & ONLY: pf_statevecsize, nprocpf, tag_model_parflow, tag_model_clm, nprocclm, pf_statevec, pf_statevec_fortran, & idx_map_subvec2state, idx_map_subvec2state_fortran, model @@ -251,6 +252,8 @@ SUBROUTINE init_pdaf() type_sqrt = 0 ! SEIK/LSEIK/ESTKF/LESTKF: Type of transform matrix square-root incremental = 0 ! SEIK/LSEIK: (1) to perform incremental updating + use_omi = .false. ! Default: Do not use OMI interface + !EnKF rank_analysis_enkf = 0 ! EnKF: rank to be considered for inversion of HPH in analysis step diff --git a/interface/framework/init_pdaf_parse.F90 b/interface/framework/init_pdaf_parse.F90 index 92c2dab4a..3972b6f2a 100644 --- a/interface/framework/init_pdaf_parse.F90 +++ b/interface/framework/init_pdaf_parse.F90 @@ -52,7 +52,15 @@ SUBROUTINE init_pdaf_parse() rms_obs, model_error, model_err_amp, incremental, type_forget, & forget, rank_analysis_enkf, locweight, cradius, & sradius, filename, type_trans, dim_obs, & - type_sqrt, obs_filename, dim_lag + type_sqrt, obs_filename, dim_lag, temp_mean_filename + USE mod_assimilation, ONLY: use_omi + + use mod_assimilation,& + only: cradius_GRACE, sradius_GRACE, & + cradius_SM, sradius_SM + + use obs_GRACE_pdafomi, only: rms_obs_GRACE + use obs_SM_pdafomi, only: rms_obs_SM IMPLICIT NONE @@ -82,6 +90,15 @@ SUBROUTINE init_pdaf_parse() CALL parse(handle, toffset) handle = 'rms_obs' ! Assumed uniform RMS error of the observations CALL parse(handle, rms_obs) + + rms_obs_GRACE = rms_obs ! backward compatibility + handle = 'rms_obs_GRACE' ! RMS error for GRACE observations + CALL parse(handle, rms_obs_GRACE) + rms_obs_SM = rms_obs ! backward compatibility + handle = 'rms_obs_SM' ! RMS error for SM observations + CALL parse(handle, rms_obs_SM) + + handle = 'dim_obs' ! Number of observations CALL parse(handle, dim_obs) @@ -96,6 +113,8 @@ SUBROUTINE init_pdaf_parse() CALL parse(handle, subtype) handle = 'incremental' ! Set whether to use incremental updating CALL parse(handle, incremental) + handle = 'use_omi' ! Set whether to use OMI interface + CALL parse(handle, use_omi) ! Filter-specific settings handle = 'type_trans' ! Type of ensemble transformation in SEIK/ETKF/LSEIK/LETKF @@ -123,6 +142,20 @@ SUBROUTINE init_pdaf_parse() ! for 5th-order polynomial or radius for 1/e in exponential weighting CALL parse(handle, sradius) + ! Settings for different observation types + cradius_GRACE = cradius ! For backward compatibility + handle = 'cradius_GRACE' ! Set cut-off radius for GRACE observations + call parse(handle, cradius_GRACE) + sradius_GRACE = sradius ! For backward compatibility + handle = 'sradius_GRACE' ! Set support radius for GRACE observations + call parse(handle, sradius_GRACE) + cradius_SM = cradius ! For backward compatibility + handle = 'cradius_SM' ! Set cut-off radius for SM observations + call parse(handle, cradius_SM) + sradius_SM = sradius ! For backward compatibility + handle = 'sradius_SM' ! Set support radius for SM observations + call parse(handle, sradius_SM) + ! Setting for file output handle = 'filename' ! Set name of output file CALL parse(handle, filename) @@ -131,6 +164,10 @@ SUBROUTINE init_pdaf_parse() handle = 'obs_filename' call parse(handle, obs_filename) + ! *** Yorck: user defined filename for temporal mean of TWS to be subtracted in observation operator *** ! + handle = 'temp_mean_filename' + call parse(handle, temp_mean_filename) + !kuw: add smoother support handle = 'smoother_lag' call parse(handle, dim_lag) diff --git a/interface/framework/mod_assimilation.F90 b/interface/framework/mod_assimilation.F90 index 170b26175..b37a1dd80 100755 --- a/interface/framework/mod_assimilation.F90 +++ b/interface/framework/mod_assimilation.F90 @@ -96,6 +96,17 @@ MODULE mod_assimilation INTEGER, ALLOCATABLE :: obs_nc2pdaf(:) ! index for mapping mstate to local domain !kuw end + + ! Yorck + + REAL :: da_interval_variable ! interval until next observation, used by next_observation_pdaf.F90, better solution for next assimilation time step + ! has to be read from observation file --> no empty observation files have to be written + REAL, ALLOCATABLE :: obscov(:,:) ! observation covariance matrix + REAL, ALLOCATABLE :: obscov_inv(:,:) ! inverse of the observation covariance matrix + character (len = 110) :: temp_mean_filename ! User defined filename of temporal mean + + ! END Yorck + ! Multi-scale DA ! store the maximum and minimum limits for remote sensing data with @@ -134,6 +145,10 @@ MODULE mod_assimilation ! ! Settings for observations - available as command line options INTEGER :: delt_obs ! time step interval between assimilation steps REAL :: rms_obs ! RMS error size for observation generation + + REAL :: rms_obs_GRACE + REAL :: rms_obs_SM + INTEGER :: dim_obs ! Number of observations ! ! General control of PDAF - available as command line options @@ -198,6 +213,7 @@ MODULE mod_assimilation ! (6) hybrid 3D-Var using LESTKF for ensemble update ! (7) hybrid 3D-Var using ESTKF for ensemble update INTEGER :: incremental ! Perform incremental updating in LSEIK + LOGICAL :: use_omi ! Set whether OMI interface is used INTEGER :: dim_lag ! Number of time instances for smoother ! ! Filter settings - available as command line options @@ -251,6 +267,12 @@ MODULE mod_assimilation ! (2) 5th-order polynomial weight function REAL :: sradius ! Support radius for 5th order polynomial ! or radius for 1/e for exponential weighting + + + REAL :: cradius_GRACE + REAL :: sradius_GRACE + REAL :: cradius_SM + REAL :: sradius_SM ! ! SEIK-subtype4/LSEIK-subtype4/ESTKF/LESTKF INTEGER :: type_sqrt ! Type of the transform matrix square-root ! (0) symmetric square root diff --git a/interface/framework/mod_read_obs.F90 b/interface/framework/mod_read_obs.F90 index 9c202acda..d0128c8e8 100755 --- a/interface/framework/mod_read_obs.F90 +++ b/interface/framework/mod_read_obs.F90 @@ -68,6 +68,149 @@ module mod_read_obs real, allocatable :: dampfac_param_time_dependent_in(:) contains + + !> @author Yorck Ewerdwalbesloh + !> @date 17.03.2025 + !> @brief Read NetCDF observation file for different observation types to be able to use one full observation files with several types + !> @param[in] Name of observation file, Name of observation type + !> @param[inout] Full observation dimension, full observation vector, uncertainty information, coordinates (lon and lat) + !> @details + !> This subroutine reads the observation file and return the data + + subroutine read_obs_nc_type(current_observation_filename, current_observation_type, dim_obs_g, obs_g, lon_obs_g, lat_obs_g, layer_obs_g, dr_obs_g, obserr_g, obscov_g) + use netcdf + use mod_assimilation, only: screen + implicit none + + integer :: ncid + integer :: dimid, status + integer :: haserr + + character (len = *), intent(in) :: current_observation_filename + character (len = *), intent(in) :: current_observation_type + INTEGER, INTENT(inout) :: dim_obs_g !< Dimension of full observation vector + REAL, allocatable, INTENT(inout) :: obs_g(:) + REAL, allocatable, INTENT(inout) :: lon_obs_g(:) + REAL, allocatable, INTENT(inout) :: lat_obs_g(:) + INTEGER, allocatable, INTENT(inout) :: layer_obs_g(:) + REAL, allocatable, INTENT(inout) :: dr_obs_g(:) + REAL, allocatable, INTENT(inout) :: obserr_g(:) + REAL, allocatable, INTENT(inout) :: obscov_g(:,:) + + integer :: clmobs_varid, dr_varid, clmobs_lon_varid, clmobs_lat_varid, & + clmobs_layer_varid, clmobserr_varid, clmobscov_varid, obstype_varid + + character (len = *), parameter :: dim_name = "dim_obs" + character (len = *), parameter :: obs_name = "obs_clm" + character (len = *), parameter :: dr_name = "dr" + character (len = *), parameter :: lon_name = "lon" + character (len = *), parameter :: lat_name = "lat" + character (len = *), parameter :: layer_name = "layer" + character (len = *), parameter :: obserr_name = "obserr_clm" + character (len = *), parameter :: obscov_name = "obscov_clm" + character (len = *), parameter :: type_name = "type_clm" + character(len = nf90_max_name) :: RecordDimName + + character(len=20), allocatable :: obs_type(:) + integer, allocatable :: indices(:) + + integer :: has_obs_clm, dim_obs + + + + call check( nf90_open(current_observation_filename, nf90_nowrite, ncid) ) + call check(nf90_inq_dimid(ncid, dim_name, dimid)) + call check(nf90_inquire_dimension(ncid, dimid, recorddimname, dim_obs)) + + has_obs_clm = nf90_inq_varid(ncid, obs_name, clmobs_varid) + + if(has_obs_clm == nf90_noerr) then + + if(allocated(obs_type)) deallocate(obs_type) + allocate(obs_type(dim_obs)) + + call check(nf90_inq_varid(ncid, type_name, obstype_varid)) + call check(nf90_get_var(ncid, obstype_varid, obs_type)) + + if (trim(obs_type(1)) /= trim(current_observation_type)) then + + dim_obs_g = 0 + + if(allocated(obs_g)) deallocate(obs_g) + allocate(obs_g(dim_obs_g)) + + if(allocated(lon_obs_g)) deallocate(lon_obs_g) + allocate(lon_obs_g(dim_obs_g)) + + if(allocated(lat_obs_g)) deallocate(lat_obs_g) + allocate(lat_obs_g(dim_obs_g)) + + if(allocated(layer_obs_g)) deallocate(layer_obs_g) + allocate(layer_obs_g(dim_obs_g)) + + if(allocated(dr_obs_g)) deallocate(dr_obs_g) + allocate(dr_obs_g(dim_obs_g)) + + else + + if(allocated(obs_g)) deallocate(obs_g) + allocate(obs_g(dim_obs)) + + if(allocated(lon_obs_g)) deallocate(lon_obs_g) + allocate(lon_obs_g(dim_obs)) + + if(allocated(lat_obs_g)) deallocate(lat_obs_g) + allocate(lat_obs_g(dim_obs)) + + if(allocated(layer_obs_g)) deallocate(layer_obs_g) + allocate(layer_obs_g(dim_obs)) + + if(allocated(dr_obs_g)) deallocate(dr_obs_g) + allocate(dr_obs_g(dim_obs)) + + call check(nf90_get_var(ncid, clmobs_varid, obs_g)) + + call check( nf90_inq_varid(ncid, lon_name, clmobs_lon_varid) ) + call check( nf90_get_var(ncid, clmobs_lon_varid, lon_obs_g) ) + + call check( nf90_inq_varid(ncid, lat_name, clmobs_lat_varid) ) + call check( nf90_get_var(ncid, clmobs_lat_varid, lat_obs_g) ) + + haserr = nf90_inq_varid(ncid, layer_name, clmobs_layer_varid) + if (haserr == nf90_noerr) then + call check( nf90_get_var(ncid, clmobs_layer_varid, layer_obs_g) ) + else + layer_obs_g(:) = 1 + end if + + call check( nf90_inq_varid(ncid, dr_name, dr_varid) ) + call check( nf90_get_var(ncid, dr_varid, dr_obs_g) ) + + haserr = nf90_inq_varid(ncid, obserr_name, clmobserr_varid) + + if(haserr == nf90_noerr) then + + multierr = 1 + + if(allocated(obserr_g)) deallocate(obserr_g) + allocate(obserr_g(dim_obs)) + + call check(nf90_get_var(ncid, clmobserr_varid, obserr_g)) + + end if + + dim_obs_g = dim_obs + + end if + + end if + + end subroutine read_obs_nc_type + + + + + !> @author Wolfgang Kurtz, Guowei He, Mukund Pondkule !> @date 03.03.2023 !> @brief Read NetCDF observation file @@ -665,4 +808,359 @@ subroutine check(status) end subroutine check + ! !> @author Yorck Ewerdwalbesloh + ! !> @date 11.09.2023 + ! !> @brief Return data assimilation interval from file + ! !> @param[in] fn Filename of the observation file + ! !> @param[out] nn number of hours until next assimilation time step + ! !> @details + ! !> Reads the content of the variable name `da_interval_variable` from NetCDF + ! !> file `fn` using subroutines from the NetCDF module. + ! !> The result is returned in `nn`. + ! !> + ! !> The result is used to decide if the next observation file is + ! !> used or not. + ! subroutine check_n_observationfile_da_interval(fn,nn) + ! use shr_kind_mod, only: r8 => shr_kind_r8 + ! use netcdf, only: nf90_max_name, nf90_open, nf90_nowrite, & + ! nf90_inq_varid, nf90_get_var, nf90_close, nf90_noerr + ! use clm_varcon, only: ispval + ! use clm_time_manager, only : get_step_size + + ! implicit none + + ! character(len=*),intent(in) :: fn + ! real, intent(out) :: nn + + + ! integer :: ncid, varid, status !,dimid + ! character (len = *), parameter :: varname = "da_interval_variable" + ! real(r8) :: dtime ! land model time step (sec) + + ! !character (len = *), parameter :: dim_name = "dim_obs" + ! !character(len = nf90_max_name) :: recorddimname + + ! dtime = get_step_size() + + ! call check(nf90_open(fn, nf90_nowrite, ncid)) + ! !call check(nf90_inq_dimid(ncid, dim_name, dimid)) + ! !call check(nf90_inquire_dimension(ncid, dimid, recorddimname, nn)) + ! status = nf90_inq_varid(ncid, varname, varid) + ! if (status == nf90_noerr) then + ! call check(nf90_inq_varid(ncid, varname, varid)) + ! call check( nf90_get_var(ncid, varid, nn) ) + ! call check(nf90_close(ncid)) + ! ! at this point: half hourly time steps, this is adjusted here. In the GRACE files, da_interval is set up as hours + ! ! --> is adjusted using information from inside CLM + ! nn = nn*INT(3600/dtime) + ! else + ! nn = ispval + ! end if + + ! end subroutine check_n_observationfile_da_interval + + + + !> @author Yorck Ewerdwalbesloh + !> @date 04.12.2023 + !> @brief Return set zero interval for running mean of model variables from file + !> @param[in] fn Filename of the observation file + !> @param[out] nn number of hours until setting zero + !> @details + !> Reads the content of the variable name `set_zero` from NetCDF + !> file `fn` using subroutines from the NetCDF module. + !> The result is returned in `nn`. + !> + !> The result is used to reset the running average of state variables. + subroutine check_n_observationfile_set_zero(fn,nn) + use shr_kind_mod, only: r8 => shr_kind_r8 + use netcdf, only: nf90_max_name, nf90_open, nf90_nowrite, & + nf90_inq_varid, nf90_get_var, nf90_close, nf90_noerr + use clm_varcon, only: ispval + use clm_time_manager, only : get_step_size + + implicit none + + character(len=*),intent(in) :: fn + integer, intent(out) :: nn + + integer :: ncid, varid, status !,dimid + character (len = *), parameter :: varname = "set_zero" + real(r8) :: dtime ! land model time step (sec) + + !character (len = *), parameter :: dim_name = "dim_obs" + !character(len = nf90_max_name) :: recorddimname + + dtime = get_step_size() + + call check(nf90_open(fn, nf90_nowrite, ncid)) + !call check(nf90_inq_dimid(ncid, dim_name, dimid)) + !call check(nf90_inquire_dimension(ncid, dimid, recorddimname, nn)) + status = nf90_inq_varid(ncid, varname, varid) + if (status == nf90_noerr) then + call check(nf90_inq_varid(ncid, varname, varid)) + call check( nf90_get_var(ncid, varid, nn) ) + call check(nf90_close(ncid)) + ! at this point: half hourly time steps, this is adjusted here. In the GRACE files, set_zero is set up as hours + ! --> is adjusted using information from inside CLM + if (nn/=ispval) then + nn = nn*INT(3600/dtime) + end if + else + nn = ispval + end if + + end subroutine check_n_observationfile_set_zero + + + subroutine check_n_observationfile_next_type(fn, obs_type_str) + use netcdf + use mod_assimilation, only: screen + implicit none + + character(len=*), intent(in) :: fn + character(len=*), intent(out) :: obs_type_str + + integer :: ncid, status, obstype_varid, dimid + integer :: dim_obs + character (len = *), parameter :: dim_name = "dim_obs" + character (len = *), parameter :: type_name = "type_clm" + character(len=20), allocatable :: obs_type_lok(:) + character(len = nf90_max_name) :: RecordDimName + + + call check( nf90_open(fn, nf90_nowrite, ncid) ) + call check(nf90_inq_dimid(ncid, dim_name, dimid)) + call check(nf90_inquire_dimension(ncid, dimid, recorddimname, dim_obs)) + + if(allocated(obs_type_lok)) deallocate(obs_type_lok) + allocate(obs_type_lok(dim_obs)) + + obs_type_str = '' + + status = nf90_inq_varid(ncid, "type_clm", obstype_varid) + if (status == nf90_noerr) then + call check(nf90_inq_varid(ncid, "type_clm", obstype_varid)) + call check(nf90_get_var(ncid, obstype_varid, obs_type_lok)) + obs_type_str = trim(obs_type_lok(1)) + end if + call check(nf90_close(ncid)) + + if(allocated(obs_type_lok)) deallocate(obs_type_lok) + + end subroutine check_n_observationfile_next_type + + + subroutine update_obs_type(obs_type_str) + use enkf_clm_mod, only: clmupdate_tws, clmupdate_swc, clmupdate_T, clmupdate_texture + use mod_parallel_pdaf, only: abort_parallel + implicit none + + character(len=*), intent(in) :: obs_type_str + + select case (trim(adjustl(obs_type_str))) + case ('GRACE') + clmupdate_tws = 1 + clmupdate_swc = 0 + clmupdate_T = 0 + clmupdate_texture = 0 + + case ('SM') + clmupdate_tws = 0 + clmupdate_swc = 1 + clmupdate_T = 0 + clmupdate_texture = 0 + + case default + write(*,*) 'ERROR: Unknown obs_type_str in update_obs_type:', trim(obs_type_str) + call abort_parallel() + end select + end subroutine update_obs_type + + + + + subroutine domain_def_clm(lon_clmobs, lat_clmobs, dim_obs, & + longxy, latixy, longxy_obs, latixy_obs) + + use spmdMod, only : npes, iam + use domainMod, only : ldomain, lon1d, lat1d + use decompMod, only : get_proc_total, get_proc_bounds, ldecomp + use GridcellType, only: grc + use shr_kind_mod, only: r8 => shr_kind_r8 + use enkf_clm_mod, only: hactiveg_levels, num_hactiveg + !USE mod_parallel_pdaf, & + ! ONLY: mpi_2integer, mpi_minloc + USE mod_parallel_pdaf, & + ONLY: comm_filter, npes_filter, abort_parallel, & + mpi_integer, mpi_double_precision, mpi_in_place, mpi_sum, & + mype_world, mpi_2integer, mpi_minloc, mype_filter + real, intent(in) :: lon_clmobs(:) + real, intent(in) :: lat_clmobs(:) + integer, intent(in) :: dim_obs + integer, allocatable, intent(inout) :: longxy(:) + integer, allocatable, intent(inout) :: latixy(:) + integer, allocatable, intent(inout) :: longxy_obs(:) + integer, allocatable, intent(inout) :: latixy_obs(:) + integer :: ni, nj, ii, jj, kk, cid, ier, ncells, nlunits, & + ncols, npatches, ncohorts, counter, i, g, ll + real :: minlon, minlat, maxlon, maxlat + real(r8), pointer :: lon(:) + real(r8), pointer :: lat(:) + + real(r8), allocatable :: longxy_obs_lokal(:), latixy_obs_lokal(:) + + INTEGER, allocatable :: in_mpi_(:,:), out_mpi_(:,:) + + integer :: begg, endg ! per-proc gridcell ending gridcell indices + + real(r8) :: lat1, lon1, lat2, lon2, a, c, R, pi + + real(r8) :: dist + real(r8), allocatable :: min_dist(:) + integer, allocatable :: min_g(:) + + integer :: ierror + + integer :: lok_lon, lok_lat + + + + lon => grc%londeg + lat => grc%latdeg + + + ni = ldomain%ni + nj = ldomain%nj + + ! get total number of gridcells, landunits, + ! columns, patches and cohorts on processor + + call get_proc_total(iam, ncells, nlunits, ncols, npatches, ncohorts) + + ! beg and end gridcell + call get_proc_bounds(begg=begg, endg=endg) + + if (allocated(longxy)) deallocate(longxy) + if (allocated(latixy)) deallocate(latixy) + allocate(longxy(num_hactiveg), stat=ier) + allocate(latixy(num_hactiveg), stat=ier) + + + longxy(:) = 0 + latixy(:) = 0 + + + counter = 1 + do ii = 1, nj + do jj = 1, ni + cid = (ii-1)*ni + jj + do ll = 1, num_hactiveg + kk = hactiveg_levels(ll,1) + if(cid == ldecomp%gdc2glo(kk)) then + latixy(counter) = ii + longxy(counter) = jj + counter = counter + 1 + end if + end do + end do + end do + + if (allocated(min_dist)) deallocate(min_dist) + allocate(min_dist(dim_obs)) + min_dist(:) = huge(1.0d0) + + if (allocated(min_g)) deallocate(min_g) + allocate(min_g(dim_obs)) + + R = 6371.0 + pi = 3.14159265358979323846 + do i = 1, dim_obs + do g = begg, endg + + ! check distance from each grid point to observation location --> take the coordinate in local system that equals + ! the one of the closest coordinate + lat1 = lat(g) * pi / 180.0 + lon1 = lon(g) * pi / 180.0 + lat2 = lat_clmobs(i) * pi / 180.0 + lon2 = lon_clmobs(i) * pi / 180.0 + + a = sin((lat2 - lat1) / 2)**2 + cos(lat1) * cos(lat2) * sin((lon2 - lon1) / 2)**2 + c = 2 * atan2(sqrt(a), sqrt(1 - a)) + dist = R * c + + if (dist < min_dist(i)) then + min_dist(i) = dist + min_g(i) = g + end if + end do + end do + + + IF (ALLOCATED(in_mpi_)) DEALLOCATE(in_mpi_) + ALLOCATE(in_mpi_(2,dim_obs)) + IF (ALLOCATED(out_mpi_)) DEALLOCATE(out_mpi_) + ALLOCATE(out_mpi_(2,dim_obs)) + + in_mpi_(1,:) = int(ceiling(min_dist)) + in_mpi_(2,:) = min_g + + if (allocated(longxy_obs_lokal)) deallocate(longxy_obs_lokal) + if (allocated(latixy_obs_lokal)) deallocate(latixy_obs_lokal) + + allocate(longxy_obs_lokal(dim_obs)) + allocate(latixy_obs_lokal(dim_obs)) + + do i =1, dim_obs + outer: do ii = 1, nj + do jj = 1, ni + cid = (ii-1)*ni + jj + do kk = begg, endg + if (kk == in_mpi_(2,i)) then + if(cid == ldecomp%gdc2glo(kk)) then + if (min_dist(i)<30) then + latixy_obs_lokal(i) = ii + longxy_obs_lokal(i) = jj + else + longxy_obs_lokal(i) = -9999 + latixy_obs_lokal(i) = -9999 + end if + exit outer + end if + end if + end do + end do + end do outer + end do + + + if (allocated(longxy_obs)) deallocate(longxy_obs) + if (allocated(latixy_obs)) deallocate(latixy_obs) + allocate(longxy_obs(dim_obs), stat=ier) + allocate(latixy_obs(dim_obs), stat=ier) + + in_mpi_(2,:) = longxy_obs_lokal + call mpi_allreduce(in_mpi_,out_mpi_, dim_obs, mpi_2integer, mpi_minloc, comm_filter, ierror) + longxy_obs(:) = out_mpi_(2,:) + + in_mpi_(2,:) = latixy_obs_lokal + call mpi_allreduce(in_mpi_,out_mpi_, dim_obs, mpi_2integer, mpi_minloc, comm_filter, ierror) + latixy_obs(:) = out_mpi_(2,:) + + deallocate(longxy_obs_lokal) + deallocate(latixy_obs_lokal) + deallocate(in_mpi_) + deallocate(out_mpi_) + deallocate(min_dist) + deallocate(min_g) + + + if (mype_filter == 0) then + print*, "longxy_obs = ", longxy_obs + print*, "latixy_obs = ", latixy_obs + end if + + end subroutine domain_def_clm + + end module mod_read_obs diff --git a/interface/framework/next_observation_pdaf.F90 b/interface/framework/next_observation_pdaf.F90 index 37b78f8a4..0d69d2ad6 100644 --- a/interface/framework/next_observation_pdaf.F90 +++ b/interface/framework/next_observation_pdaf.F90 @@ -52,7 +52,7 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) ! ! !USES: USE mod_assimilation, & - ONLY: delt_obs, toffset, screen + ONLY: delt_obs, toffset, screen, da_interval_variable USE mod_parallel_pdaf, & ONLY: mype_world USE mod_tsmp, & @@ -62,9 +62,15 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) USE mod_tsmp, ONLY: flexible_da_interval USE mod_assimilation, & ONLY: obs_filename + USE mod_assimilation, ONLY: use_omi use mod_read_obs, & - only: check_n_observationfile - use mod_read_obs, ONLY: check_n_observationfile_da_interval + only: check_n_observationfile, check_n_observationfile_da_interval, check_n_observationfile_set_zero, & + check_n_observationfile_next_type, update_obs_type + use clm_time_manager, & + only: get_nstep + use enkf_clm_mod, & + only: da_interval + use clm_varcon, only: set_averaging_to_zero, ispval IMPLICIT NONE ! !ARGUMENTS: @@ -80,7 +86,9 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) !kuw: local variables integer :: counter integer :: no_obs + integer :: nstep character (len = 110) :: fn + character(len=32) :: obs_type_str !kuw end REAL :: da_interval_new @@ -89,6 +97,7 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) time = 0.0 ! Not used in fully-parallel implementation variant doexit = 0 + NOOMI:if (.not. use_omi) then !kuw: implementation for at least 1 existing observation per observation file !!print *, "stepnow", stepnow !write(*,*)'stepnow (in next_observation_pdaf):',stepnow @@ -185,6 +194,7 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) + end if NOOMI ! IF (stepnow + nsteps <= total_steps) THEN ! if (2<1) then @@ -213,6 +223,71 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) ! doexit = ?? !print *, "next_observation_pdaf finished" +#ifdef CLMSA +#ifdef CLMFIVE + OMI:if (use_omi) then + nstep = get_nstep() + nsteps = delt_obs + + if (mype_world==0 .and. screen > 2) then + write(*,*) 'TSMP-PDAF (in next_observation_pdaf.F90) total_steps: ',total_steps + end if + + ! Read steps until next observation from current observation file + if (stepnow==toffset) then + set_averaging_to_zero = 0 + if (mype_world==0 .and. screen > 2) then + write(*,*)'next_observation_pdaf: da_interval from enkfpf.par' + end if + else + write(fn, '(a, i5.5)') trim(obs_filename)//'.', stepnow + call check_n_observationfile_da_interval(fn,da_interval_variable) + if (da_interval_variable/=ispval) then + da_interval = da_interval_variable + end if + call check_n_observationfile_set_zero(fn, set_averaging_to_zero) + end if + + if (mype_world==0 .and. screen > 2) then + write(fn, '(a, i5.5)') trim(obs_filename)//'.', stepnow + write(*,*)'next_observation_pdaf: fn = ', fn + write(*,*)'da_interval (in next_observation_pdaf):',da_interval + end if + + if (set_averaging_to_zero/=ispval) then + set_averaging_to_zero = set_averaging_to_zero+nstep + end if + + if (mype_world==0 .and. screen > 2) then + write(*,*) 'set_averaging_to_zero (in next_observation_pdaf):',set_averaging_to_zero + end if + + if (stepnow==toffset) then + if (mype_world==0 .and. screen > 2) then + write(*,*)'next_observation_pdaf: observation type from enkfpf.par' + end if + else + ! update observation type with next file + write(fn, '(a, i5.5)') trim(obs_filename)//'.', stepnow + delt_obs + if (mype_world==0 .and. screen > 2) then + write(*,*)'next_observation_pdaf: fn = ', fn + write(*,*)'Call check_n_observationfile_next_type' + end if + call check_n_observationfile_next_type(fn, obs_type_str) + if (trim(obs_type_str) /= '') then + call update_obs_type(obs_type_str) + end if + + if (mype_world==0 .and. screen > 2) then + write(*,*)'next_type (in next_observation_pdaf):',trim(obs_type_str) + end if + + end if + end if OMI +#endif +#endif + END SUBROUTINE next_observation_pdaf + diff --git a/interface/framework/obs_GRACE_pdafomi.F90 b/interface/framework/obs_GRACE_pdafomi.F90 new file mode 100644 index 000000000..b73cfe9fb --- /dev/null +++ b/interface/framework/obs_GRACE_pdafomi.F90 @@ -0,0 +1,829 @@ +!> PDAF-OMI observation module for type GRACE observations +!! +!! This module handles operations for one data type (called 'module-type' below): +!! OBSTYPE = GRACE +!! +!! __Observation type GRACE:__ +!! The observation type GRACE are TWSA observations (gridded) +!! +!! The subroutines in this module are for the particular handling of +!! a single observation type. +!! The routines are called by the different call-back routines of PDAF +!! usually by callback_obs_pdafomi.F90 +!! Most of the routines are generic so that in practice only 2 routines +!! need to be adapted for a particular data type. These are the routines +!! for the initialization of the observation information (init_dim_obs) +!! and for the observation operator (obs_op). +!! +!! The module and the routines are named according to the observation type. +!! This allows to distinguish the observation type and the routines in this +!! module from other observation types. +!! +!! The module uses two derived data types (obs_f and obs_l), which contain +!! all information about the full and local observations. Only variables +!! of the type obs_f need to be initialized in this module. The variables +!! in the type obs_l are initilized by the generic routines from PDAFomi. +!! +!! +!! These 2 routines need to be adapted for the particular observation type: +!! * init_dim_obs_OBSTYPE \n +!! Count number of process-local and full observations; +!! initialize vector of observations and their inverse variances; +!! initialize coordinate array and index array for indices of +!! observed elements of the state vector. +!! * obs_op_OBSTYPE \n +!! observation operator to get full observation vector of this type. Here +!! one has to choose a proper observation operator or implement one. +!! +!! In addition, there are two optional routines, which are required if filters +!! with localization are used: +!! * init_dim_obs_l_OBSTYPE \n +!! Only required if domain-localized filters (e.g. LESTKF, LETKF) are used: +!! Count number of local observations of module-type according to +!! their coordinates (distance from local analysis domain). Initialize +!! module-internal distances and index arrays. +!! * localize_covar_OBSTYPE \n +!! Only required if the localized EnKF is used: +!! Apply covariance localization in the LEnKF. +!! +!! __Revision history:__ +!! * 2019-06 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! +MODULE obs_GRACE_pdafomi + + USE mod_parallel_pdaf, & + ONLY: mype_filter ! Rank of filter process + USE PDAFomi, & + ONLY: obs_f, obs_l ! Declaration of observation data types + + IMPLICIT NONE + SAVE + + PUBLIC + + ! Variables which are inputs to the module (usually set in init_pdaf) + LOGICAL :: assim_GRACE !< Whether to assimilate this data type + REAL :: rms_obs_GRACE !< Observation error standard deviation (for constant errors) + logical, allocatable :: vec_useObs(:) + integer, allocatable :: vec_numPoints_global(:) ! vector of number of points for each GRACE observation, same dimension as observation vector + logical, allocatable :: vec_useObs_global(:) ! vector that tells if an observation of used (1) or not (0), same dimension as observation vector, global + + real, allocatable :: tws_temp_mean(:,:) ! temporal mean for TWS + real, allocatable :: tws_temp_mean_d(:) ! temporal mean for TWS, vectorized with the same bounds as local process + real, allocatable :: lon_temp_mean(:,:) ! corresponding longitude + real, allocatable :: lat_temp_mean(:,:) ! corresponding latitude + + INTEGER, ALLOCATABLE :: longxy(:), latixy(:), longxy_obs(:), latixy_obs(:) ! longitude and latitude of grid cells and observation cells + + ! One can declare further variables, e.g. for file names which can + ! be use-included in init_pdaf() and initialized there. + + + ! ********************************************************* + ! *** Data type obs_f defines the full observations by *** + ! *** internally shared variables of the module *** + ! ********************************************************* + + ! Relevant variables that can be modified by the user: + ! TYPE obs_f + ! ---- Mandatory variables to be set in INIT_DIM_OBS ---- + ! INTEGER :: doassim ! Whether to assimilate this observation type + ! INTEGER :: disttype ! Type of distance computation to use for localization + ! ! (0) Cartesian, (1) Cartesian periodic + ! ! (2) simplified geographic, (3) geographic haversine function + ! INTEGER :: ncoord ! Number of coordinates use for distance computation + ! INTEGER, ALLOCATABLE :: id_obs_p(:,:) ! Indices of observed field in state vector (process-local) + ! + ! ---- Optional variables - they can be set in INIT_DIM_OBS ---- + ! REAL, ALLOCATABLE :: icoeff_p(:,:) ! Interpolation coefficients for obs. operator + ! REAL, ALLOCATABLE :: domainsize(:) ! Size of domain for periodicity (<=0 for no periodicity) + ! + ! ---- Variables with predefined values - they can be changed in INIT_DIM_OBS ---- + ! INTEGER :: obs_err_type=0 ! Type of observation error: (0) Gauss, (1) Laplace + ! INTEGER :: use_global_obs=1 ! Whether to use (1) global full obs. + ! ! or (0) obs. restricted to those relevant for a process domain + ! REAL :: inno_omit=0.0 ! Omit obs. if squared innovation larger this factor times + ! ! observation variance + ! REAL :: inno_omit_ivar=1.0e-12 ! Value of inverse variance to omit observation + ! END TYPE obs_f + + ! Data type obs_l defines the local observations by internally shared variables of the module + + ! *********************************************************************** + + ! Declare instances of observation data types used here + ! We use generic names here, but one could rename the variables + TYPE(obs_f), TARGET, PUBLIC :: thisobs ! full observation + TYPE(obs_l), TARGET, PUBLIC :: thisobs_l ! local observation + + !$OMP THREADPRIVATE(thisobs_l) + + + !------------------------------------------------------------------------------- + + CONTAINS + + !> Initialize information on the module-type observation + !! + !! The routine is called by each filter process. + !! at the beginning of the analysis step before + !! the loop through all local analysis domains. + !! + !! It has to count the number of observations of the + !! observation type handled in this module according + !! to the current time step for all observations + !! required for the analyses in the loop over all local + !! analysis domains on the PE-local state domain. + !! + !! The following four variables have to be initialized in this routine + !! * thisobs\%doassim - Whether to assimilate this type of observations + !! * thisobs\%disttype - type of distance computation for localization with this observaton + !! * thisobs\%ncoord - number of coordinates used for distance computation + !! * thisobs\%id_obs_p - array with indices of module-type observation in process-local state vector + !! + !! Optional is the use of + !! * thisobs\%icoeff_p - Interpolation coefficients for obs. operator (only if interpolation is used) + !! * thisobs\%domainsize - Size of domain for periodicity for disttype=1 (<0 for no periodicity) + !! * thisobs\%obs_err_type - Type of observation errors for particle filter and NETF (default: 0=Gaussian) + !! * thisobs\%use_global obs - Whether to use global observations or restrict the observations to the relevant ones + !! (default: 1=use global full observations) + !! * thisobs\%inno_omit - Omit obs. if squared innovation larger this factor times observation variance + !! (default: 0.0, omission is active if >0) + !! * thisobs\%inno_omit_ivar - Value of inverse variance to omit observation + !! (default: 1.0e-12, change this if this value is not small compared to actual obs. error) + !! + !! Further variables are set when the routine PDAFomi_gather_obs is called. + !! + SUBROUTINE init_dim_obs_GRACE(step, dim_obs) + + USE PDAFomi, & + ONLY: PDAFomi_gather_obs + USE mod_assimilation, & + ONLY: filtertype, cradius_GRACE, obs_filename, temp_mean_filename, screen + + use mod_read_obs, only: read_obs_nc_type, domain_def_clm, multierr + + use enkf_clm_mod, only: num_layer, hactiveg_levels + + use mod_parallel_pdaf, & + only: mpi_integer, mpi_sum, mpi_2integer, mpi_maxloc, comm_filter + + use shr_kind_mod, only: r8 => shr_kind_r8 + + use GridcellType, only: grc + + use clm_varcon, only: spval + + USE mod_parallel_pdaf, & + ONLY: mype_world + + use decompMod , only : get_proc_bounds + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: step !< Current time step + INTEGER, INTENT(inout) :: dim_obs !< Dimension of full observation vector + + ! *** Local variables *** + INTEGER :: i, j, count_points, c, l, k ! Counters + INTEGER :: cnt, cnt0 ! Counters + INTEGER :: dim_obs_p ! Number of process-local observations + REAL, ALLOCATABLE :: obs_field(:,:) ! Observation field read from file + REAL, ALLOCATABLE :: obs_p(:) ! PE-local observation vector + REAL, ALLOCATABLE :: obs_g(:) ! Global observation vector + REAL, ALLOCATABLE :: ivar_obs_p(:) ! PE-local inverse observation error variance + REAL, ALLOCATABLE :: ocoord_p(:,:) ! PE-local observation coordinates + CHARACTER(len=2) :: stepstr ! String for time step + character (len = 110) :: current_observation_filename + + + character(len=20) :: obs_type_name ! name of observation type (e.g. GRACE, SM, ST, ...) + + integer :: numPoints ! minimum number of points so that the GRACE observation is used + integer, allocatable :: vec_numPoints(:) ! number of model grid cells that are in a radius of dr around the GRACE observation + INTEGER, allocatable :: in_mpi(:,:), out_mpi(:,:) + REAL, ALLOCATABLE :: lon_obs(:) + REAL, ALLOCATABLE :: lat_obs(:) + INTEGER, ALLOCATABLE :: layer_obs(:) + REAL, ALLOCATABLE :: dr_obs(:) + REAL, ALLOCATABLE :: obserr(:) + REAL, ALLOCATABLE :: obscov(:,:) + + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + + real(r8), pointer :: lon(:) + real(r8), pointer :: lat(:) + + real(r8) :: pi + + integer :: ierror, cnt_p + + real :: deltax, deltay + + + + ! ********************************************* + ! *** Initialize full observation dimension *** + ! ********************************************* + + !IF (mype_filter==0) & + IF (mype_filter==0) & + WRITE (*,*) 'Assimilate observations - obs type GRACE' + + ! Store whether to assimilate this observation type (used in routines below) + + IF (assim_GRACE) thisobs%doassim = 1 + ! Specify type of distance computation + thisobs%disttype = 0 ! 0=Cartesian + + ! Number of coordinates used for distance computation + ! The distance compution starts from the first row + thisobs%ncoord = 2 + + + ! ********************************** + ! *** Read PE-local observations *** + ! ********************************** + + ! read observations from nc file --> call function in mod_read_obs. Idea: when you have multiple observation types in one file, + ! also pass the observation type, here 'GRACE' to the function. You have to give each observation in the file an information which type + ! it is. This way, the output in this function is only the GRACE observation (or soil moisture,...; dependent on what you want to implement) + + + obs_type_name = 'GRACE' + + ! now call function to get observations + + if (mype_filter==0 .and. screen > 2) then + write(*,*)'load observations from type GRACE' + end if + write(current_observation_filename, '(a, i5.5)') trim(obs_filename)//'.', step + call read_obs_nc_type(current_observation_filename, obs_type_name, dim_obs, obs_g, lon_obs, lat_obs, layer_obs, dr_obs, obserr, obscov) + if (mype_filter==0 .and. screen > 2) then + write(*,*)'Done: load observations from type GRACE' + end if + + if (dim_obs == 0) then + if (mype_filter==0 .and. screen > 2) then + write(*,*)'TSMP-PDAF mype(w) =', mype_world, ': No observations of type GRACE found in file ', trim(current_observation_filename) + end if + dim_obs_p = 0 + ALLOCATE(obs_p(1)) + ALLOCATE(ivar_obs_p(1)) + ALLOCATE(ocoord_p(2, 1)) + ALLOCATE(thisobs%id_obs_p(1, 1)) + thisobs%infile=0 + CALL PDAFomi_gather_obs(thisobs, dim_obs_p, obs_p, ivar_obs_p, ocoord_p, & + thisobs%ncoord, cradius_GRACE, dim_obs) + return + end if + thisobs%infile=1 + + ! *********************************************************** + ! *** Count available observations for the process domain *** + ! *** and initialize index and coordinate arrays. *** + ! *********************************************************** + + call domain_def_clm(lon_obs, lat_obs, dim_obs, longxy, latixy, longxy_obs, latixy_obs) + + IF (ALLOCATED(vec_useObs)) DEALLOCATE(vec_useObs) + ALLOCATE(vec_useObs(dim_obs)) + IF (ALLOCATED(vec_numPoints)) DEALLOCATE(vec_numPoints) + ALLOCATE(vec_numPoints(dim_obs)) + vec_numPoints=0 + IF (ALLOCATED(vec_numPoints_global)) DEALLOCATE(vec_numPoints_global) + ALLOCATE(vec_numPoints_global(dim_obs)) + IF (ALLOCATED(vec_useObs_global)) DEALLOCATE(vec_useObs_global) + ALLOCATE(vec_useObs_global(dim_obs)) + vec_useObs_global = .true. + IF (ALLOCATED(in_mpi)) DEALLOCATE(in_mpi) + ALLOCATE(in_mpi(2,dim_obs)) + IF (ALLOCATED(out_mpi)) DEALLOCATE(out_mpi) + ALLOCATE(out_mpi(2,dim_obs)) + + + ! additions for GRACE assimilation, it can be the case that not enough CLM gridpoints lie in the neighborhood of a GRACE observation + ! if this is the case, the GRACE observations cannot be reproduced in a satisfactory manner and is not used in the assimilation + ! count grdicells that are in a certain radius. This effect is especially present when the applied GRACE resolution is high or for + ! observation lying directly at the coast + + lon => grc%londeg + lat => grc%latdeg + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + + do i = 1, dim_obs + + count_points = 0 + + do c = 1, num_layer(1) + + j = hactiveg_levels(c,1) + deltax = abs(longxy(c)-longxy_obs(i)) + deltay = abs(latixy(c)-latixy_obs(i)) + + if((sqrt(real(deltax)**2 + real(deltay)**2)) < dr_obs(1)/0.11) then + count_points = count_points+1 + end if + + end do + + vec_numPoints(i) = count_points + + end do + + ! get vec_numPoints from all processes and add them up together via mpi_allreduce + ! then we have for each observation the number of all points that lie within their neighborhood, not only from one process + + call mpi_allreduce(vec_numPoints,vec_numPoints_global, dim_obs, mpi_integer, mpi_sum, comm_filter, ierror) + + ! only observations should be used that "see" enough gridcells + pi = 3.14159265358979323846 + numPoints = int(ceiling((pi*(dr_obs(1)/0.11)**2)/2)) + if (screen > 2) then + if (mype_filter==0) then + print *, "Minimum number of points for using one observation is ", numPoints + end if + end if + + vec_useObs_global = merge(vec_useObs_global,.false.,vec_numPoints_global>=numPoints) + vec_useObs = vec_useObs_global + + if (screen > 2) then + if (mype_filter==0) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_f_pdaf: vec_useObs_global=", vec_useObs_global + print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_f_pdaf: vec_numPoints_global=", vec_numPoints_global + end if + end if + + ! The observation should be reproduced by the process that has the most grid points inside the observation radius + ! However, in the observation operator, all points will be used by using mpi + + in_mpi(1,:) = vec_numPoints + in_mpi(2,:) = mype_filter + + call mpi_allreduce(in_mpi,out_mpi, dim_obs, mpi_2integer, mpi_maxloc, comm_filter, ierror) + + vec_useObs = merge(vec_useObs,.false.,out_mpi(2,:)==mype_filter) + + IF (ALLOCATED(in_mpi)) DEALLOCATE(in_mpi) + IF (ALLOCATED(out_mpi)) DEALLOCATE(out_mpi) + + dim_obs_p = count(vec_useObs) + + if(allocated(thisobs%id_obs_p)) deallocate(thisobs%id_obs_p) + ALLOCATE(thisobs%id_obs_p(1, begg:endg)) + thisobs%id_obs_p(1, :) = 0 + + do i = 1, dim_obs + + if (vec_useObs_global(i)) then + + do c = 1, num_layer(1) + + j = hactiveg_levels(c,1) + deltax = abs(longxy(c)-longxy_obs(i)) + deltay = abs(latixy(c)-latixy_obs(i)) + + if((sqrt(real(deltax)**2 + real(deltay)**2))<=dr_obs(1)/0.11) then + thisobs%id_obs_p(1, j) = i + end if + + end do + + end if + + end do + + + + IF (ALLOCATED(obs_p)) DEALLOCATE(obs_p) + ALLOCATE(obs_p(dim_obs_p)) + + IF (ALLOCATED(ivar_obs_p)) DEALLOCATE(ivar_obs_p) + ALLOCATE(ivar_obs_p(dim_obs_p)) + + IF (ALLOCATED(ocoord_p)) DEALLOCATE(ocoord_p) + ALLOCATE(ocoord_p(2, dim_obs_p)) + + + if (multierr==1) ivar_obs_p = pack(1/obserr, vec_useObs) + + cnt_p = 1 + do i = 1, dim_obs + if (vec_useObs(i)) then + obs_p(cnt_p) = obs_g(i) + ocoord_p(1,cnt_p) = longxy_obs(i) + ocoord_p(2,cnt_p) = latixy_obs(i) + cnt_p = cnt_p+1 + end if + end do + + dim_obs = count(vec_useObs_global) + ! **************************************** + ! *** Gather global observation arrays *** + ! **************************************** + + CALL PDAFomi_gather_obs(thisobs, dim_obs_p, obs_p, ivar_obs_p, ocoord_p, & + thisobs%ncoord, cradius_GRACE, dim_obs) + + ! ******************** + ! *** Finishing up *** + ! ******************** + + ! load temporal mean of TWS and vectorize for process from begg to endg --> only has to be done once as the process does not change bounds + + if (.not. allocated(tws_temp_mean_d)) then + call read_temp_mean_model(temp_mean_filename) + + if (allocated(tws_temp_mean_d)) DEALLOCATE(tws_temp_mean_d) + ALLOCATE(tws_temp_mean_d(begg:endg)) + tws_temp_mean_d(:) = spval + + do j = begg,endg + outer: do l = 1,size(lon_temp_mean,1) + do k=1,size(lon_temp_mean,2) + if (lon_temp_mean(l,k)==lon(j) .and. lat_temp_mean(l,k)==lat(j)) then + tws_temp_mean_d(j) = tws_temp_mean(l,k) + exit outer + end if + end do + end do outer + + if (lon(j)/=lon_temp_mean(l,k) .or. lat(j)/=lat_temp_mean(l,k)) then + print *, "Attention: distributing model mean to clumps does not work properly" + print *, "idx_lon= ",l, "idx_lat= ",k + print *, "lon(j)= ", lon(j),"lon_temp_mean(idx_lon)= ",lon_temp_mean(l,k) + print *, "lat(j)= ", lat(j),"lat_temp_mean(idx_lat)= ",lat_temp_mean(l,k) + stop + end if + end do + + deallocate(tws_temp_mean) + deallocate(lon_temp_mean) + deallocate(lat_temp_mean) + + end if + + ! Deallocate all local arrays + DEALLOCATE(obs_g) + DEALLOCATE(obs_p, ocoord_p, ivar_obs_p) + + END SUBROUTINE init_dim_obs_GRACE + + + + !------------------------------------------------------------------------------- + !> Implementation of observation operator + !! + !! This routine applies the full observation operator + !! for the type of observations handled in this module. + !! + !! One can choose a proper observation operator from + !! PDAFOMI_OBS_OP or add one to that module or + !! implement another observation operator here. + !! + !! The routine is called by all filter processes. + !! + SUBROUTINE obs_op_GRACE(dim_p, dim_obs, state_p, ostate) + + use enkf_clm_mod, & + only: clm_varsize_tws, state_setup, num_layer, hactiveg_levels + + use mod_parallel_pdaf, & + only: comm_filter, mpi_double_precision, mpi_sum + + use clm_varpar , only : nlevsoi + + use decompMod , only : get_proc_bounds + + use clm_varcon, only: spval + + use shr_kind_mod, only: r8 => shr_kind_r8 + + use mod_assimilation, only: screen + + use PDAFomi_obs_f, only: PDAFomi_gather_obsstate + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: dim_p !< PE-local state dimension + INTEGER, INTENT(in) :: dim_obs !< Dimension of full observed state (all observed fields) + REAL, INTENT(in) :: state_p(dim_p) !< PE-local model state + REAL, INTENT(inout) :: ostate(dim_obs) !< Full observed state + + REAL, allocatable :: tws_from_statevector(:) + real, allocatable :: ostate_p(:) + + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: ierror + integer :: obs_point ! which observation is seen by which point? + + REAL:: m_state_sum(size(vec_useObs_global)) + REAL:: m_state_sum_global(size(vec_useObs_global)) + + integer :: count, j, g + + ! ****************************************************** + ! *** Apply observation operator H on a state vector *** + ! ****************************************************** + + IF (thisobs%dim_obs_p>0) THEN + if (allocated(ostate_p)) deallocate(ostate_p) + ALLOCATE(ostate_p(thisobs%dim_obs_p)) + ELSE + if (allocated(ostate_p)) deallocate(ostate_p) + ALLOCATE(ostate_p(1)) + + END IF + + if (thisobs%infile == 1) then ! as I need also tasks with dim_obs_p==0 to reproduce GRACE observations + ! I do not check whether dim_obs_p>0 but if I want to assimilate GRACE. A check still has to be included, + ! else there will be segmentation faults + + m_state_sum(:) = 0 + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + if (allocated(tws_from_statevector)) deallocate(tws_from_statevector) + allocate(tws_from_statevector(begg:endg)) + + tws_from_statevector(begg:endg) = spval + + select case(state_setup) + case(0) ! all compartments included in state vector + + do j = 1,nlevsoi + do count = 1, num_layer(j) + g = hactiveg_levels(count,j) + if (j==1) then + tws_from_statevector(g) = 0._r8 + end if + if (j==1) then + ! liq + ice + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count) + ! snow + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)) + !surface water + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)+ clm_varsize_tws(3)) + else + ! liq + ice + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count+sum(num_layer(1:j-1))) + end if + end do + end do + + ! do count = 1, num_hactiveg_patch + ! g = hactiveg_patch(count) + ! ! canopy water + ! tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)+ clm_varsize_tws(3)+ clm_varsize_tws(4)) + ! end do + + + case(1) ! TWS in statevector + + do count = 1, num_layer(1) + g = hactiveg_levels(count,1) + tws_from_statevector(g) = state_p(count) + end do + + case(2) ! snow and soil moisture aggregated over surface, root zone and deep soil moisture in state vector + + do count = 1,num_layer(1) + g = hactiveg_levels(count,1) + tws_from_statevector(g) = state_p(count) + ! snow added for first layer + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3)) + end do + + do count = 1,num_layer(4) + g = hactiveg_levels(count,4) + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1)) + end do + + do count = 1,num_layer(13) + g = hactiveg_levels(count,13) + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)) + end do + + end select + + + + ! subtract mean TWS to obtain TWSA model values + do count = 1, num_layer(1) + g = hactiveg_levels(count,1) + obs_point = thisobs%id_obs_p(1, g) + if (obs_point /= 0) then + if (tws_temp_mean_d(g)/=spval .and. tws_from_statevector(g)/=spval) then + m_state_sum(obs_point) = m_state_sum(obs_point) + tws_from_statevector(g)-tws_temp_mean_d(g) + else if (tws_temp_mean_d(g)==spval .and. .not. tws_from_statevector(g)==spval) then + print*, "error, tws temporal mean is spval and reproduced values is not spval for g = ", g + print*, "reproduced = ", tws_from_statevector(g) + stop + else if (.not. tws_temp_mean_d(g)==spval .and. tws_from_statevector(g)==spval) then + print*, "error, tws temporal mean is not spval and reproduced values is spval for g = ", g + print*, "temp_mean = ", tws_temp_mean_d(g) + stop + end if + end if + end do + + ! now get the sum of m_state_sum (sum over all TWSA values for the gridcells for one process) over all processes + call mpi_allreduce(m_state_sum, m_state_sum_global, size(vec_useObs_global), mpi_double_precision, mpi_sum, comm_filter, ierror) + m_state_sum_global = m_state_sum_global/vec_numPoints_global + + ostate_p = pack(m_state_sum_global, vec_useObs) + + end if + + ! *** Global: Gather full observed state vector + CALL PDAFomi_gather_obsstate(thisobs, ostate_p, ostate) + deallocate(ostate_p) + if (screen>2 .and. mype_filter==0 .and. thisobs%dim_obs_f>0) then + write(*,*)'m_state_sum_global = ', m_state_sum_global + end if + + END SUBROUTINE obs_op_GRACE + + + + !------------------------------------------------------------------------------- + !> Initialize local information on the module-type observation + !! + !! The routine is called during the loop over all local + !! analysis domains. It has to initialize the information + !! about local observations of the module type. It returns + !! number of local observations of the module type for the + !! current local analysis domain in DIM_OBS_L and the full + !! and local offsets of the observation in the overall + !! observation vector. + !! + !! This routine calls the routine PDAFomi_init_dim_obs_l + !! for each observation type. The call allows to specify a + !! different localization radius and localization functions + !! for each observation type and local analysis domain. + !! + SUBROUTINE init_dim_obs_l_GRACE(domain_p, step, dim_obs, dim_obs_l) + + ! Include PDAFomi function + USE PDAFomi, ONLY: PDAFomi_init_dim_obs_l + + ! Include localization radius and local coordinates + USE mod_assimilation, & + ONLY: cradius_GRACE, locweight, sradius_GRACE + + use clm_varcon, only: spval + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: domain_p !< Index of current local analysis domain + INTEGER, INTENT(in) :: step !< Current time step + INTEGER, INTENT(in) :: dim_obs !< Full dimension of observation vector + INTEGER, INTENT(inout) :: dim_obs_l !< Local dimension of observation vector + + REAL :: coords_l(2) ! Coordinates of local analysis domain + + + ! ********************************************** + ! *** Initialize local observation dimension *** + ! ********************************************** + ! count observations within a radius + + if (thisobs%infile==1) then + + ! get coords_l --> coordinates of local analysis domain, I can just set this to the rotated CLM coordinates + coords_l(1) = longxy(domain_p) + coords_l(2) = latixy(domain_p) + + else + coords_l(1) = spval + coords_l(2) = spval + end if + + CALL PDAFomi_init_dim_obs_l(thisobs_l, thisobs, coords_l, & + locweight, cradius_GRACE, sradius_GRACE, dim_obs_l) + + END SUBROUTINE init_dim_obs_l_GRACE + + + + !------------------------------------------------------------------------------- + !> Perform covariance localization for local EnKF on the module-type observation + !! + !! The routine is called in the analysis step of the localized + !! EnKF. It has to apply localization to the two matrices + !! HP and HPH of the analysis step for the module-type + !! observation. + !! + !! This routine calls the routine PDAFomi_localize_covar + !! for each observation type. The call allows to specify a + !! different localization radius and localization functions + !! for each observation type. + !! + SUBROUTINE localize_covar_GRACE(dim_p, dim_obs, HP_p, HPH, coords_p) + + ! Include PDAFomi function + USE PDAFomi, ONLY: PDAFomi_localize_covar + + ! Include localization radius and local coordinates + USE mod_assimilation, & + ONLY: cradius_GRACE, locweight, sradius_GRACE + + use enkf_clm_mod, only: gridcell_state + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: dim_p !< PE-local state dimension + INTEGER, INTENT(in) :: dim_obs !< Dimension of observation vector + REAL, INTENT(inout) :: HP_p(dim_obs, dim_p) !< PE local part of matrix HP + REAL, INTENT(inout) :: HPH(dim_obs, dim_obs) !< Matrix HPH + REAL, INTENT(inout) :: coords_p(:,:) !< Coordinates of state vector elements + + integer :: i + + + ! ************************************* + ! *** Apply covariance localization *** + ! ************************************* + + do i = 1,dim_p + coords_p(1,i) = longxy(gridcell_state(i)) + coords_p(2,i) = latixy(gridcell_state(i)) + end do + + + + CALL PDAFomi_localize_covar(thisobs, dim_p, locweight, cradius_GRACE, sradius_GRACE, & + coords_p, HP_p, HPH) + + END SUBROUTINE localize_covar_GRACE + + + + subroutine read_temp_mean_model(temp_mean_filename) + + use netcdf, only: nf90_open + use netcdf, only: nf90_inq_dimid + use netcdf, only: nf90_inquire_dimension + use netcdf, only: nf90_inq_varid + use netcdf, only: nf90_get_var + use netcdf, only: nf90_close + use mod_read_obs, only: check + + implicit none + integer :: ncid, dim_lon, dim_lat, lon_varid, lat_varid, tws_varid + character (len = *), parameter :: dim_lon_name = "lsmlon" + character (len = *), parameter :: dim_lat_name = "lsmlat" + character (len = *), parameter :: lon_name = "longitude" + character (len = *), parameter :: lat_name = "latitude" + character (len = *), parameter :: tws_name = "TWS" + character(len = nf90_max_name) :: RecordDimName + integer :: dimid_lon, dimid_lat, status + integer :: haserr + character (len = *), intent(in) :: temp_mean_filename + + call check(nf90_open(temp_mean_filename, nf90_nowrite, ncid)) + call check(nf90_inq_dimid(ncid, dim_lon_name, dimid_lon)) + call check(nf90_inq_dimid(ncid, dim_lat_name, dimid_lat)) + call check(nf90_inquire_dimension(ncid, dimid_lon, recorddimname, dim_lon)) + call check(nf90_inquire_dimension(ncid, dimid_lat, recorddimname, dim_lat)) + + if(allocated(lon_temp_mean))deallocate(lon_temp_mean) + if(allocated(lat_temp_mean))deallocate(lat_temp_mean) + if(allocated(tws_temp_mean))deallocate(tws_temp_mean) + + allocate(tws_temp_mean(dim_lon,dim_lat)) + allocate(lon_temp_mean(dim_lon,dim_lat)) + allocate(lat_temp_mean(dim_lon,dim_lat)) + + call check( nf90_inq_varid(ncid, lon_name, lon_varid)) + call check(nf90_get_var(ncid, lon_varid, lon_temp_mean)) + + call check( nf90_inq_varid(ncid, lat_name, lat_varid)) + call check(nf90_get_var(ncid, lat_varid, lat_temp_mean)) + + call check( nf90_inq_varid(ncid, tws_name, tws_varid)) + call check(nf90_get_var(ncid, tws_varid, tws_temp_mean)) + + call check( nf90_close(ncid) ) + + end subroutine read_temp_mean_model + + END MODULE obs_GRACE_pdafomi + + + + diff --git a/interface/framework/obs_SM_pdafomi.F90 b/interface/framework/obs_SM_pdafomi.F90 new file mode 100644 index 000000000..78b4371ea --- /dev/null +++ b/interface/framework/obs_SM_pdafomi.F90 @@ -0,0 +1,1070 @@ +!> PDAF-OMI observation module for type SM observations +!! +!! This module handles operations for one data type (called 'module-type' below): +!! OBSTYPE = SM +!! +!! __Observation type SM:__ +!! The observation type SM are soil moisture observations +!! +!! The subroutines in this module are for the particular handling of +!! a single observation type. +!! The routines are called by the different call-back routines of PDAF +!! usually by callback_obs_pdafomi.F90 +!! Most of the routines are generic so that in practice only 2 routines +!! need to be adapted for a particular data type. These are the routines +!! for the initialization of the observation information (init_dim_obs) +!! and for the observation operator (obs_op). +!! +!! The module and the routines are named according to the observation type. +!! This allows to distinguish the observation type and the routines in this +!! module from other observation types. +!! +!! The module uses two derived data types (obs_f and obs_l), which contain +!! all information about the full and local observations. Only variables +!! of the type obs_f need to be initialized in this module. The variables +!! in the type obs_l are initilized by the generic routines from PDAFomi. +!! +!! +!! These 2 routines need to be adapted for the particular observation type: +!! * init_dim_obs_OBSTYPE \n +!! Count number of process-local and full observations; +!! initialize vector of observations and their inverse variances; +!! initialize coordinate array and index array for indices of +!! observed elements of the state vector. +!! * obs_op_OBSTYPE \n +!! observation operator to get full observation vector of this type. Here +!! one has to choose a proper observation operator or implement one. +!! +!! In addition, there are two optional routines, which are required if filters +!! with localization are used: +!! * init_dim_obs_l_OBSTYPE \n +!! Only required if domain-localized filters (e.g. LESTKF, LETKF) are used: +!! Count number of local observations of module-type according to +!! their coordinates (distance from local analysis domain). Initialize +!! module-internal distances and index arrays. +!! * localize_covar_OBSTYPE \n +!! Only required if the localized EnKF is used: +!! Apply covariance localization in the LEnKF. +!! +!! __Revision history:__ +!! * 2019-06 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! +MODULE obs_SM_pdafomi + + USE mod_parallel_pdaf, & + ONLY: mype_filter ! Rank of filter process + USE PDAFomi, & + ONLY: obs_f, obs_l ! Declaration of observation data types + + IMPLICIT NONE + SAVE + + PUBLIC + + ! Variables which are inputs to the module (usually set in init_pdaf) + LOGICAL :: assim_SM !< Whether to assimilate this data type + REAL :: rms_obs_SM !< Observation error standard deviation (for constant errors) + + INTEGER, ALLOCATABLE :: longxy(:), latixy(:), longxy_obs(:), latixy_obs(:) ! longitude and latitude of grid cells and observation cells + + ! One can declare further variables, e.g. for file names which can + ! be use-included in init_pdaf() and initialized there. + + + ! ********************************************************* + ! *** Data type obs_f defines the full observations by *** + ! *** internally shared variables of the module *** + ! ********************************************************* + + ! Relevant variables that can be modified by the user: + ! TYPE obs_f + ! ---- Mandatory variables to be set in INIT_DIM_OBS ---- + ! INTEGER :: doassim ! Whether to assimilate this observation type + ! INTEGER :: disttype ! Type of distance computation to use for localization + ! ! (0) Cartesian, (1) Cartesian periodic + ! ! (2) simplified geographic, (3) geographic haversine function + ! INTEGER :: ncoord ! Number of coordinates use for distance computation + ! INTEGER, ALLOCATABLE :: id_obs_p(:,:) ! Indices of observed field in state vector (process-local) + ! + ! ---- Optional variables - they can be set in INIT_DIM_OBS ---- + ! REAL, ALLOCATABLE :: icoeff_p(:,:) ! Interpolation coefficients for obs. operator + ! REAL, ALLOCATABLE :: domainsize(:) ! Size of domain for periodicity (<=0 for no periodicity) + ! + ! ---- Variables with predefined values - they can be changed in INIT_DIM_OBS ---- + ! INTEGER :: obs_err_type=0 ! Type of observation error: (0) Gauss, (1) Laplace + ! INTEGER :: use_global_obs=1 ! Whether to use (1) global full obs. + ! ! or (0) obs. restricted to those relevant for a process domain + ! REAL :: inno_omit=0.0 ! Omit obs. if squared innovation larger this factor times + ! ! observation variance + ! REAL :: inno_omit_ivar=1.0e-12 ! Value of inverse variance to omit observation + ! END TYPE obs_f + + ! Data type obs_l defines the local observations by internally shared variables of the module + + ! *********************************************************************** + + ! Declare instances of observation data types used here + ! We use generic names here, but one could rename the variables + TYPE(obs_f), TARGET, PUBLIC :: thisobs ! full observation + TYPE(obs_l), TARGET, PUBLIC :: thisobs_l ! local observation + + !$OMP THREADPRIVATE(thisobs_l) + + + !------------------------------------------------------------------------------- + + CONTAINS + + !> Initialize information on the module-type observation + !! + !! The routine is called by each filter process. + !! at the beginning of the analysis step before + !! the loop through all local analysis domains. + !! + !! It has to count the number of observations of the + !! observation type handled in this module according + !! to the current time step for all observations + !! required for the analyses in the loop over all local + !! analysis domains on the PE-local state domain. + !! + !! The following four variables have to be initialized in this routine + !! * thisobs\%doassim - Whether to assimilate this type of observations + !! * thisobs\%disttype - type of distance computation for localization with this observaton + !! * thisobs\%ncoord - number of coordinates used for distance computation + !! * thisobs\%id_obs_p - array with indices of module-type observation in process-local state vector + !! + !! Optional is the use of + !! * thisobs\%icoeff_p - Interpolation coefficients for obs. operator (only if interpolation is used) + !! * thisobs\%domainsize - Size of domain for periodicity for disttype=1 (<0 for no periodicity) + !! * thisobs\%obs_err_type - Type of observation errors for particle filter and NETF (default: 0=Gaussian) + !! * thisobs\%use_global obs - Whether to use global observations or restrict the observations to the relevant ones + !! (default: 1=use global full observations) + !! * thisobs\%inno_omit - Omit obs. if squared innovation larger this factor times observation variance + !! (default: 0.0, omission is active if >0) + !! * thisobs\%inno_omit_ivar - Value of inverse variance to omit observation + !! (default: 1.0e-12, change this if this value is not small compared to actual obs. error) + !! + !! Further variables are set when the routine PDAFomi_gather_obs is called. + !! + SUBROUTINE init_dim_obs_SM(step, dim_obs) + + USE mod_parallel_pdaf, & + ONLY: mype_filter, comm_filter, npes_filter, abort_parallel, & + mpi_integer, mpi_double_precision, mpi_in_place, mpi_sum, & + mype_world + + USE mod_assimilation, & + ONLY: obs_index_p, obs_filename, & + obs_interp_indices_p, & + obs_interp_weights_p, & + obs_pdaf2nc, obs_nc2pdaf, & + local_dims_obs, & + local_disp_obs, & + ! dim_obs_p, & + longxy_obs_floor, latixy_obs_floor, & + screen, cradius_SM + + + USE PDAFomi, & + ONLY: PDAFomi_gather_obs, pi + USE mod_assimilation, & + ONLY: obs_filename, screen + + Use mod_read_obs, & + only: multierr, read_obs_nc_type + + use enkf_clm_mod, only: clmstatevec_allcol, clmstatevec_only_active, clmstatevec_max_layer, state_clm2pdaf_p + + use enkf_clm_mod, only: domain_def_clm + + use mod_parallel_pdaf, & + only: abort_parallel + + use shr_kind_mod, only: r8 => shr_kind_r8 + + use GridcellType, only: grc + + use clm_varcon, only: spval + + USE mod_parallel_pdaf, & + ONLY: mype_world + + use decompMod , only : get_proc_bounds, get_proc_global + + use ColumnType , only : col + + use mod_tsmp, only: obs_interp_switch + + use enkf_clm_mod, only: get_interp_idx + + use mod_tsmp, only: point_obs + + use mod_tsmp, only: da_print_obs_index + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: step !< Current time step + INTEGER, INTENT(inout) :: dim_obs !< Dimension of full observation vector + + ! *** Local variables *** + INTEGER :: i, j, c, g, cg ! Counters + INTEGER :: cnt ! Counters + INTEGER :: cnt_interp + INTEGER :: dim_obs_p ! Number of process-local observations + REAL, ALLOCATABLE :: obs_p(:) ! PE-local observation vector + REAL, ALLOCATABLE :: obs_g(:) ! Global observation vector + REAL, ALLOCATABLE :: ivar_obs_p(:) ! PE-local inverse observation error variance + REAL, ALLOCATABLE :: ocoord_p(:,:) ! PE-local observation coordinates + character (len = 110) :: current_observation_filename + + + character(len=20) :: obs_type_name ! name of observation type (e.g. GRACE, SM, ST, ...) + + REAL, ALLOCATABLE :: lon_obs(:) + REAL, ALLOCATABLE :: lat_obs(:) + INTEGER, ALLOCATABLE :: layer_obs(:) + REAL, ALLOCATABLE :: dr_obs(:) + REAL, ALLOCATABLE :: obserr(:) + REAL, ALLOCATABLE :: obscov(:,:) + + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + + integer :: numg ! total number of gridcells across all processors + integer :: numl ! total number of landunits across all processors + integer :: numc ! total number of columns across all processors + integer :: nump ! total number of pfts across all processors + + real(r8), pointer :: lon(:) + real(r8), pointer :: lat(:) + integer, pointer :: mycgridcell(:) + + integer :: ierror, cnt_p + + real :: deltax, deltay + + logical :: is_use_dr + logical :: obs_snapped !Switch for checking multiple observation counts + logical :: newgridcell + + INTEGER :: sum_dim_obs_p + + real :: sum_interp_weights + + character (len = 27) :: fn !TSMP-PDAF: function name for obs_index_p output + + + + ! ********************************************* + ! *** Initialize full observation dimension *** + ! ********************************************* + + IF (mype_filter==0) & + WRITE (*,*) 'Assimilate observations - obs type soil moisture' + + ! Store whether to assimilate this observation type (used in routines below) + + IF (assim_SM) thisobs%doassim = 1 + ! Specify type of distance computation + + thisobs%disttype = 3 ! 0=Cartesian, 3=geographic, distance computed with haversine formula + + ! Number of coordinates used for distance computation + ! The distance compution starts from the first row + thisobs%ncoord = 2 + + + ! ********************************** + ! *** Read PE-local observations *** + ! ********************************** + + + obs_type_name = 'SM' + + ! now call function to get observations + + if (mype_filter==0 .and. screen > 2) then + write(*,*)'load observations from type SM' + end if + write(current_observation_filename, '(a, i5.5)') trim(obs_filename)//'.', step + + + if (mype_filter == 0) then + call read_obs_nc_type(current_observation_filename, obs_type_name, dim_obs, obs_g, lon_obs, lat_obs, layer_obs, dr_obs, obserr, obscov) + end if + + call mpi_bcast(dim_obs, 1, MPI_INTEGER, 0, comm_filter, ierror) + + ! check if file contains observations from type SM + + if (dim_obs == 0) then + if (mype_filter==0 .and. screen > 2) then + write(*,*)'TSMP-PDAF mype(w) =', mype_world, ': No observations of type SM found in file ', trim(current_observation_filename) + end if + dim_obs_p = 0 + ALLOCATE(obs_p(1)) + ALLOCATE(ivar_obs_p(1)) + ALLOCATE(ocoord_p(2, 1)) + ALLOCATE(thisobs%id_obs_p(1, 1)) + thisobs%infile=0 + CALL PDAFomi_gather_obs(thisobs, dim_obs_p, obs_p, ivar_obs_p, ocoord_p, & + thisobs%ncoord, cradius_SM, dim_obs) + return + end if + + call mpi_bcast(multierr, 1, MPI_INTEGER, 0, comm_filter, ierror) + + ! Allocate observation arrays for non-root procs + ! ---------------------------------------------- + if (mype_filter /= 0) then ! for all non-master proc + if(allocated(obs_g)) deallocate(obs_g) + allocate(obs_g(dim_obs)) + if(allocated(lon_obs)) deallocate(lon_obs) + allocate(lon_obs(dim_obs)) + if(allocated(lat_obs)) deallocate(lat_obs) + allocate(lat_obs(dim_obs)) + if(allocated(dr_obs)) deallocate(dr_obs) + allocate(dr_obs(dim_obs)) + if(allocated(layer_obs)) deallocate(layer_obs) + allocate(layer_obs(dim_obs)) + if(multierr==1) then + if(allocated(obserr)) deallocate(obserr) + allocate(obserr(dim_obs)) + end if + end if + + call mpi_bcast(obs_g, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) + if(multierr==1) call mpi_bcast(obserr, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) + call mpi_bcast(lon_obs, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) + call mpi_bcast(lat_obs, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) + call mpi_bcast(dr_obs, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) + call mpi_bcast(layer_obs, dim_obs, MPI_INTEGER, 0, comm_filter, ierror) + + + + if (mype_filter==0 .and. screen > 2) then + write(*,*)'Done: load observations from type SM' + end if + + + thisobs%infile = 1 + call domain_def_clm(lon_obs, lat_obs, dim_obs, longxy, latixy, longxy_obs, latixy_obs) + + ! Interpolation of measured states: Save the indices of the + ! nearest grid points + if (obs_interp_switch == 1) then + ! Get the floored values for latitudes and longitudes + call get_interp_idx(lon_obs, lat_obs, dim_obs, longxy_obs_floor, latixy_obs_floor) + end if + +#ifdef CLMFIVE + ! Obtain CLM lon/lat information + lon => grc%londeg + lat => grc%latdeg + ! Obtain CLM column-gridcell information + mycgridcell => col%gridcell +#else + lon => clm3%g%londeg + lat => clm3%g%latdeg + mycgridcell => clm3%g%l%c%gridcell +#endif + + + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + call get_proc_global(numg, numl, numc, nump) + + dim_obs_p = 0 + + is_use_dr = .true. + + if(allocated(thisobs%id_obs_p)) deallocate(thisobs%id_obs_p) + allocate(thisobs%id_obs_p(1,endg-begg+1)) + thisobs%id_obs_p(1, :) = 0 + + cnt = 1 + + do i = 1, dim_obs + obs_snapped = .false. + do g = begg, endg + + newgridcell = .true. + + do c = begc,endc + + cg = mycgridcell(c) + + if(cg == g) then + + if(newgridcell) then + + if(is_use_dr) then + if (lon(g)>180) then + deltax = abs(lon(g)-lon_obs(i)-360) + else + deltax = abs(lon(g)-lon_obs(i)) + end if + deltay = abs(lat(g)-lat_obs(i)) + end if + + ! Assigning observations to grid cells according to + ! snapping distance or index arrays + if(((is_use_dr).and.(deltax<=dr_obs(1)).and.(deltay<=dr_obs(1))).or.((.not. is_use_dr).and.(longxy_obs(i) == longxy(cnt)) .and. (latixy_obs(i) == latixy(cnt)))) then + + dim_obs_p = dim_obs_p + 1 + ! Use index array for setting the correct state vector index in `obs_id_p` + thisobs%id_obs_p(1,state_clm2pdaf_p(c,layer_obs(i))) = i + + if (obs_snapped) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": ERROR Observation snapped at multiple grid cells." + print *, "i=", i + if (is_use_dr) then + print *, "lon_obs(i)=", lon_obs(i) + print *, "lat_obs(i)=", lat_obs(i) + end if + call abort_parallel() + end if + + ! Set observation as counted + obs_snapped = .true. + newgridcell = .false. + + cnt=cnt+1 + end if + end if + end if + end do + end do + end do + + if (screen > 2) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_pdaf: dim_obs_p=", dim_obs_p + end if + + + ! initalize OMI arrays + + IF (ALLOCATED(ivar_obs_p)) DEALLOCATE(ivar_obs_p) + ALLOCATE(ivar_obs_p(dim_obs_p)) + + IF (ALLOCATED(ocoord_p)) DEALLOCATE(ocoord_p) + ALLOCATE(ocoord_p(2, dim_obs_p)) + + + ! Dimension of full observation vector + ! ------------------------------------ + + ! add and broadcast size of PE-local observation dimensions using mpi_allreduce + call mpi_allreduce(dim_obs_p, sum_dim_obs_p, 1, MPI_INTEGER, MPI_SUM, & + comm_filter, ierror) + + ! Check sum of dimensions of PE-local observation vectors against + ! dimension of full observation vector + if (.not. sum_dim_obs_p == dim_obs) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": ERROR Sum of PE-local observation dimensions" + print *, "sum_dim_obs_p=", sum_dim_obs_p + print *, "dim_obs=", dim_obs + call abort_parallel() + end if + + ! Gather PE-local observation dimensions and displacements in arrays + ! ---------------------------------------------------------------- + + ! Allocate array of PE-local observation dimensions + IF (ALLOCATED(local_dims_obs)) DEALLOCATE(local_dims_obs) + ALLOCATE(local_dims_obs(npes_filter)) + + ! Gather array of PE-local observation dimensions + call mpi_allgather(dim_obs_p, 1, MPI_INTEGER, local_dims_obs, 1, MPI_INTEGER, & + comm_filter, ierror) + + ! Allocate observation displacement array local_disp_obs + IF (ALLOCATED(local_disp_obs)) DEALLOCATE(local_disp_obs) + ALLOCATE(local_disp_obs(npes_filter)) + + ! Set observation displacement array local_disp_obs + local_disp_obs(1) = 0 + do i = 2, npes_filter + local_disp_obs(i) = local_disp_obs(i-1) + local_dims_obs(i-1) + end do + + if (mype_filter==0 .and. screen > 2) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_pdaf: local_disp_obs=", local_disp_obs + end if + + + ! Write index mapping array NetCDF->PDAF + ! -------------------------------------- + ! Set index mapping `obs_pdaf2nc` between observation order in + ! NetCDF input and observation order in pdaf as determined by domain + ! decomposition. + + ! Use-case: Correct index order in loops over NetCDF-observation + ! file input arrays. + + ! Trivial example: The order in the NetCDF file corresponds exactly + ! to the order in the domain decomposition in PDAF, e.g. for a + ! single PE per component model run. + + ! Non-trivial example: The first observation in the NetCDF file is + ! not located in the domain/subgrid of the first PE. Rather, the + ! second observation in the NetCDF file (`i=2`) is the only + ! observation (`cnt = 1`) in the subgrid of the first PE + ! (`mype_filter = 0`). This leads to a non-trivial index mapping, + ! e.g. `obs_pdaf2nc(1)==2`: + ! + ! i = 2 + ! cnt = 1 + ! mype_filter = 0 + ! + ! obs_pdaf2nc(local_disp_obs(mype_filter+1)+cnt) = i + !-> obs_pdaf2nc(local_disp_obs(1)+1) = 2 + !-> obs_pdaf2nc(1) = 2 + + + if (allocated(obs_pdaf2nc)) deallocate(obs_pdaf2nc) + allocate(obs_pdaf2nc(dim_obs)) + obs_pdaf2nc = 0 + if (allocated(obs_nc2pdaf)) deallocate(obs_nc2pdaf) + allocate(obs_nc2pdaf(dim_obs)) + obs_nc2pdaf = 0 + + + if (point_obs==1) then + + cnt = 1 + do i = 1, dim_obs + ! Many processes may not contain the observation / do not need + ! to snap it, so default true + obs_snapped = .true. + + do g = begg,endg + newgridcell = .true. + do c = begc,endc + cg = mycgridcell(c) + if(cg == g) then + if(newgridcell) then + + if(is_use_dr) then + if (lon(g)>180) then + deltax = abs(lon(g)-lon_obs(i)-360) + else + deltax = abs(lon(g)-lon_obs(i)) + end if + deltay = abs(lat(g)-lat_obs(i)) + end if + + if(((is_use_dr).and.(deltax<=dr_obs(1)).and.(deltay<=dr_obs(1))).or.((.not. is_use_dr).and.(longxy_obs(i) == longxy(g-begg+1)) .and. (latixy_obs(i) == latixy(g-begg+1)))) then +#ifdef CLMFIVE + if(state_clm2pdaf_p(c,1)==ispval) then + ! `ispval`: column not in state vector, most likely + ! because it is hydrologically inactive + + ! Observation not snapped, even though location is + ! right! + obs_snapped = .false. + + ! Do not use this column for snapping an + ! observation, instead cycle to next column + cycle + end if +#endif + obs_pdaf2nc(local_disp_obs(mype_filter+1)+cnt) = i + obs_nc2pdaf(i) = local_disp_obs(mype_filter+1)+cnt + cnt = cnt + 1 + + ! Observation snapped at location (possibly + ! overwriting a false from inactive column before) + obs_snapped = .true. + end if + + newgridcell = .false. + + end if + end if + end do + end do + + ! Warning, when an observation has not been snapped to any + ! active gridcell. + if(.not. obs_snapped) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": ERROR observations exist at non-active gridcells." + print *, "Consider removing the following observation from the observation files." + print *, "Observation-index in NetCDF-file: i=", i + call abort_parallel() + end if + end do + + end if + + ! collect values from all PEs, by adding all PE-local arrays (works + ! since only the subsection belonging to a specific PE is non-zero) + call mpi_allreduce(MPI_IN_PLACE,obs_pdaf2nc,dim_obs,MPI_INTEGER,MPI_SUM,comm_filter,ierror) + call mpi_allreduce(MPI_IN_PLACE,obs_nc2pdaf,dim_obs,MPI_INTEGER,MPI_SUM,comm_filter,ierror) + + if (mype_filter==0 .and. screen > 2) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_pdaf: obs_pdaf2nc=", obs_pdaf2nc + end if + + ! Write process-local observation arrays + ! -------------------------------------- + IF (ALLOCATED(obs_p)) DEALLOCATE(obs_p) + ALLOCATE(obs_p(dim_obs_p)) + IF (ALLOCATED(obs_index_p)) DEALLOCATE(obs_index_p) + ALLOCATE(obs_index_p(dim_obs_p)) + if(obs_interp_switch == 1) then + ! Array for storing indices from states that are interpolated to observation locations + IF (ALLOCATED(obs_interp_indices_p)) DEALLOCATE(obs_interp_indices_p) + ALLOCATE(obs_interp_indices_p(dim_obs_p, 4)) ! Later 8 for 3D / ParFlow + IF (ALLOCATED(obs_interp_weights_p)) DEALLOCATE(obs_interp_weights_p) + ALLOCATE(obs_interp_weights_p(dim_obs_p, 4)) ! Later 8 for 3D / ParFlow + end if + + + cnt = 1 + + do i = 1, dim_obs + + do g = begg,endg + newgridcell = .true. + + do c = begc,endc + + cg = mycgridcell(c) + + if(cg == g) then + + if(newgridcell) then + + if(is_use_dr) then + if (lon(g)>180) then + deltax = abs(lon(g)-lon_obs(i)-360) + else + deltax = abs(lon(g)-lon_obs(i)) + end if + deltay = abs(lat(g)-lat_obs(i)) + end if + + if(((is_use_dr).and.(deltax<=dr_obs(1)).and.(deltay<=dr_obs(1))).or.((.not. is_use_dr).and.(longxy_obs(i) == longxy(g-begg+1)) .and. (latixy_obs(i) == latixy(g-begg+1)))) then + if (thisobs%disttype/=3) then ! if haversine formula in distance calculation, the coordinates have to be converted to radians + ocoord_p(1,cnt) = lon_obs(i) + ocoord_p(2,cnt) = lat_obs(i) + else + ocoord_p(1,cnt) = lon_obs(i) * pi / 180.0 + ocoord_p(2,cnt) = lat_obs(i) * pi / 180.0 + end if + + ! Different settings of observation-location-index in + ! state vector depending on the method of state + ! vector assembling. + if(clmstatevec_allcol==1) then +#ifdef CLMFIVE + if(clmstatevec_only_active==1) then + + ! Error if observation deeper than clmstatevec_max_layer + if(layer_obs(i) > min(clmstatevec_max_layer, col%nbedrock(c))) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": ERROR observation layer deeper than clmstatevec_max_layer or bedrock." + print *, "i=", i + print *, "c=", c + print *, "layer_obs(i)=", layer_obs(i) + print *, "col%nbedrock(c)=", col%nbedrock(c) + print *, "clmstatevec_max_layer=", clmstatevec_max_layer + call abort_parallel() + end if + obs_index_p(cnt) = state_clm2pdaf_p(c,layer_obs(i)) + else + obs_index_p(cnt) = c-begc+1 + ((endc-begc+1) * (layer_obs(i)-1)) + end if +#else + obs_index_p(cnt) = c-begc+1 + ((endc-begc+1) * (clmobs_layer(i)-1)) +#endif + else +#ifdef CLMFIVE + if(clmstatevec_only_active==1) then + obs_index_p(cnt) = state_clm2pdaf_p(c,layer_obs(i)) + else + obs_index_p(cnt) = g-begg+1 + ((endg-begg+1) * (layer_obs(i)-1)) + end if +#else + obs_index_p(cnt) = g-begg+1 + ((endg-begg+1) * (clmobs_layer(i)-1)) +#endif + end if + + !write(*,*) 'obs_index_p(',cnt,') is',obs_index_p(cnt) + obs_p(cnt) = obs_g(i) + if(multierr==1) ivar_obs_p(cnt) = 1/(obserr(i)*obserr(i)) + if(multierr==0) ivar_obs_p(cnt) = 1/(rms_obs_SM*rms_obs_SM) + cnt = cnt + 1 + end if + + newgridcell = .false. + + end if + + end if + + end do + end do + + end do + + if(obs_interp_switch==1) then + ! loop over all obs and save the indices of the nearest grid + ! points to array obs_interp_indices_p and save the distance + ! weights to array obs_interp_weights_p (later normalized) + cnt = 1 + do i = 1, dim_obs + cnt_interp = 0 + do g = begg,endg + ! First: latitude and longitude smaller than observation location + if((longxy_obs_floor(i) == longxy(g-begg+1)) .and. (latixy_obs_floor(i) == latixy(g-begg+1))) then + + obs_interp_indices_p(cnt, 1) = g-begg+1 + ((endg-begg+1) * (layer_obs(i)-1)) + obs_interp_weights_p(cnt, 1) = sqrt(abs(lon(g)-lon_obs(i)) * abs(lon(g)-lon_obs(i)) + abs(lat(g)-lat_obs(i)) * abs(lat(g)-lat_obs(i))) + cnt_interp = cnt_interp + 1 + end if + ! Second: latitude larger than observation location, longitude smaller than observation location + if((longxy_obs(i) == longxy(g-begg+1)) .and. (latixy_obs_floor(i) == latixy(g-begg+1))) then + obs_interp_indices_p(cnt, 2) = g-begg+1 + ((endg-begg+1) * (layer_obs(i)-1)) + obs_interp_weights_p(cnt, 2) =sqrt(abs(lon(g)-lon_obs(i)) * abs(lon(g)-lon_obs(i)) + abs(lat(g)-lat_obs(i)) * abs(lat(g)-lat_obs(i))) + cnt_interp = cnt_interp + 1 + end if + ! Third: latitude smaller than observation location, longitude larger than observation location + if((longxy_obs_floor(i) == longxy(g-begg+1)) .and. (latixy_obs(i) == latixy(g-begg+1))) then + obs_interp_indices_p(cnt, 3) = g-begg+1 + ((endg-begg+1) * (layer_obs(i)-1)) + obs_interp_weights_p(cnt, 3) = sqrt(abs(lon(g)-lon_obs(i)) * abs(lon(g)-lon_obs(i)) + abs(lat(g)-lat_obs(i)) * abs(lat(g)-lat_obs(i))) + cnt_interp = cnt_interp + 1 + end if + ! Fourth: latitude and longitude larger than observation location + if((longxy_obs(i) == longxy(g-begg+1)) .and. (latixy_obs(i) == latixy(g-begg+1))) then + obs_interp_indices_p(cnt, 4) = g-begg+1 + ((endg-begg+1) * (layer_obs(i)-1)) + obs_interp_weights_p(cnt, 4) = sqrt(abs(lon(g)-lon_obs(i)) * abs(lon(g)-lon_obs(i)) + abs(lat(g)-lat_obs(i)) * abs(lat(g)-lat_obs(i))) + cnt_interp = cnt_interp + 1 + end if + ! Check if all four corners are found + if(cnt_interp == 4) then + cnt = cnt + 1 + ! exit + end if + end do + end do + + do i = 1, dim_obs + + ! Sum of distance weights + sum_interp_weights = sum(obs_interp_weights_p(i, :)) + + do j = 1, 4 + ! Normalize distance weights + obs_interp_weights_p(i, j) = obs_interp_weights_p(i, j) / sum_interp_weights + end do + end do + + end if + +#ifdef PDAF_DEBUG + IF (da_print_obs_index > 0) THEN + ! TSMP-PDAF: For debug runs, output the state vector in files + WRITE(fn, "(a,i5.5,a,i5.5,a)") "obs_index_p_", mype_world, ".", step, ".txt" + OPEN(unit=71, file=fn, action="write") + DO i = 1, dim_obs_p + WRITE (71,"(i10)") obs_index_p(i) + END DO + CLOSE(71) + END IF +#endif + + + ! **************************************** + ! *** Gather global observation arrays *** + ! **************************************** + + CALL PDAFomi_gather_obs(thisobs, dim_obs_p, obs_p, ivar_obs_p, ocoord_p, & + thisobs%ncoord, cradius_SM, dim_obs) + + ! ******************** + ! *** Finishing up *** + ! ******************** + + ! Deallocate all local arrays + DEALLOCATE(obs_g) + DEALLOCATE(obs_p, ocoord_p, ivar_obs_p) + + END SUBROUTINE init_dim_obs_SM + + + + !------------------------------------------------------------------------------- + !> Implementation of observation operator + !! + !! This routine applies the full observation operator + !! for the type of observations handled in this module. + !! + !! One can choose a proper observation operator from + !! PDAFOMI_OBS_OP or add one to that module or + !! implement another observation operator here. + !! + !! The routine is called by all filter processes. + !! + SUBROUTINE obs_op_SM(dim_p, dim_obs, state_p, ostate) + + use mod_assimilation, only: obs_index_p + + use PDAFomi_obs_f, only: PDAFomi_gather_obsstate + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: dim_p !< PE-local state dimension + INTEGER, INTENT(in) :: dim_obs !< Dimension of full observed state (all observed fields) + REAL, INTENT(in) :: state_p(dim_p) !< PE-local model state + REAL, INTENT(inout) :: ostate(dim_obs) !< Full observed state + + real, allocatable :: ostate_p(:) + + integer :: i + + + + ! ****************************************************** + ! *** Apply observation operator H on a state vector *** + ! ****************************************************** + + IF (thisobs%dim_obs_p>0) THEN + if (allocated(ostate_p)) deallocate(ostate_p) + ALLOCATE(ostate_p(thisobs%dim_obs_p)) + ELSE + if (allocated(ostate_p)) deallocate(ostate_p) + ALLOCATE(ostate_p(1)) + END IF + + + DO i = 1, thisobs%dim_obs_p + ostate_p(i) = state_p(obs_index_p(i)) + END DO + + ! *** Global: Gather full observed state vector + CALL PDAFomi_gather_obsstate(thisobs, ostate_p, ostate) + + deallocate(ostate_p) + + + END SUBROUTINE obs_op_SM + + + + !------------------------------------------------------------------------------- + !> Initialize local information on the module-type observation + !! + !! The routine is called during the loop over all local + !! analysis domains. It has to initialize the information + !! about local observations of the module type. It returns + !! number of local observations of the module type for the + !! current local analysis domain in DIM_OBS_L and the full + !! and local offsets of the observation in the overall + !! observation vector. + !! + !! This routine calls the routine PDAFomi_init_dim_obs_l + !! for each observation type. The call allows to specify a + !! different localization radius and localization functions + !! for each observation type and local analysis domain. + !! + SUBROUTINE init_dim_obs_l_SM(domain_p, step, dim_obs, dim_obs_l) + + ! Include PDAFomi function + USE PDAFomi, ONLY: PDAFomi_init_dim_obs_l, pi + + ! Include localization radius and local coordinates + USE mod_assimilation, & + ONLY: cradius_SM, locweight, sradius_SM, screen + + USE enkf_clm_mod, ONLY: state_loc2clm_c_p, clmstatevec_allcol, clmstatevec_only_active + + use shr_kind_mod, only: r8 => shr_kind_r8 + + use decompMod , only : get_proc_bounds + + +#ifdef CLMFIVE + USE GridcellType, ONLY: grc + USE ColumnType, ONLY : col +#else + USE clmtype, ONLY : clm3 +#endif + use clm_varcon, only: spval + + use mod_parallel_pdaf, & + ONLY: mype_world + + + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: domain_p !< Index of current local analysis domain + INTEGER, INTENT(in) :: step !< Current time step + INTEGER, INTENT(in) :: dim_obs !< Full dimension of observation vector + INTEGER, INTENT(inout) :: dim_obs_l !< Local dimension of observation vector + + REAL :: coords_l(2) ! Coordinates of local analysis domain + + real(r8), pointer :: lon(:) + real(r8), pointer :: lat(:) + integer, pointer :: mycgridcell(:) !Pointer for CLM3.5/CLM5.0 col->gridcell index arrays + +#ifdef CLMFIVE + ! Obtain CLM lon/lat information + lon => grc%londeg + lat => grc%latdeg + ! Obtain CLM column-gridcell information + mycgridcell => col%gridcell +#else + lon => clm3%g%londeg + lat => clm3%g%latdeg + mycgridcell => clm3%g%l%c%gridcell +#endif + + + ! ********************************************** + ! *** Initialize local observation dimension *** + ! ********************************************** + ! count observations within a radius + + if (thisobs%infile==1) then + + + if (clmstatevec_allcol==0 .and. clmstatevec_only_active==0) then + if (lon(state_loc2clm_c_p(domain_p))>180) then + coords_l(1) = lon(state_loc2clm_c_p(domain_p)) - 360.0 + else + coords_l(1) = lon(state_loc2clm_c_p(domain_p)) + end if + + else + + ! get coords_l --> coordinates of local analysis domain + if (lon(mycgridcell(state_loc2clm_c_p(domain_p)))>180) then + ! if SM should be assimilated. Else, state_loc2clm_c_p is not allocated + coords_l(1) = lon(mycgridcell(state_loc2clm_c_p(domain_p))) - 360.0 + else + coords_l(1) = lon(mycgridcell(state_loc2clm_c_p(domain_p))) + end if + coords_l(2) = lat(mycgridcell(state_loc2clm_c_p(domain_p))) + + end if + + if (thisobs%disttype==3) then ! if haversine formula in distance calculation, the coordinates have to be converted to radians + coords_l(1) = coords_l(1) * pi / 180.0 + coords_l(2) = coords_l(2) * pi / 180.0 + end if + + else + + coords_l(1) = spval + coords_l(2) = spval + + end if + + ! for disttype=3, the cradius and sradius have to passed in meters, so I multiply by 1000 to be able to put it in km in the input file + + if (thisobs%disttype==3) then + CALL PDAFomi_init_dim_obs_l(thisobs_l, thisobs, coords_l, & + locweight, cradius_SM*1000.0, sradius_SM*1000.0, dim_obs_l) + else + CALL PDAFomi_init_dim_obs_l(thisobs_l, thisobs, coords_l, & + locweight, cradius_SM, sradius_SM, dim_obs_l) + end if + + + END SUBROUTINE init_dim_obs_l_SM + + + + !------------------------------------------------------------------------------- + !> Perform covariance localization for local EnKF on the module-type observation + !! + !! The routine is called in the analysis step of the localized + !! EnKF. It has to apply localization to the two matrices + !! HP and HPH of the analysis step for the module-type + !! observation. + !! + !! This routine calls the routine PDAFomi_localize_covar + !! for each observation type. The call allows to specify a + !! different localization radius and localization functions + !! for each observation type. + !! + SUBROUTINE localize_covar_SM(dim_p, dim_obs, HP_p, HPH, coords_p) + + ! Include PDAFomi function + USE PDAFomi, ONLY: PDAFomi_localize_covar + + ! Include localization radius and local coordinates + USE mod_assimilation, & + ONLY: cradius_SM, locweight, sradius_SM + + use enkf_clm_mod, only: state_pdaf2clm_c_p + + use shr_kind_mod, only: r8 => shr_kind_r8 + + USE GridcellType, ONLY: grc + USE ColumnType, ONLY : col + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: dim_p !< PE-local state dimension + INTEGER, INTENT(in) :: dim_obs !< Dimension of observation vector + REAL, INTENT(inout) :: HP_p(dim_obs, dim_p) !< PE local part of matrix HP + REAL, INTENT(inout) :: HPH(dim_obs, dim_obs) !< Matrix HPH + REAL, INTENT(inout) :: coords_p(:,:) !< Coordinates of state vector elements + + integer :: i + + real(r8), pointer :: lon(:) + real(r8), pointer :: lat(:) + integer, pointer :: mycgridcell(:) !Pointer for CLM3.5/CLM5.0 col->gridcell index arrays + +#ifdef CLMFIVE + ! Obtain CLM lon/lat information + lon => grc%londeg + lat => grc%latdeg + ! Obtain CLM column-gridcell information + mycgridcell => col%gridcell +#else + lon => clm3%g%londeg + lat => clm3%g%latdeg + mycgridcell => clm3%g%l%c%gridcell +#endif + + + ! ************************************* + ! *** Apply covariance localization *** + ! ************************************* + + do i = 1,dim_p + if (lon(mycgridcell(state_pdaf2clm_c_p(i)))>180) then + coords_p(1,i) = lon(mycgridcell(state_pdaf2clm_c_p(i))) - 360.0 + else + coords_p(1,i) = lon(mycgridcell(state_pdaf2clm_c_p(i))) + end if + coords_p(2,i) = lat(mycgridcell(state_pdaf2clm_c_p(i))) + end do + + + + CALL PDAFomi_localize_covar(thisobs, dim_p, locweight, cradius_SM, sradius_SM, & + coords_p, HP_p, HPH) + + END SUBROUTINE localize_covar_SM + + + END MODULE obs_SM_pdafomi + + + + + diff --git a/interface/model/common/enkf.h b/interface/model/common/enkf.h index f943ad903..d6aebe11d 100755 --- a/interface/model/common/enkf.h +++ b/interface/model/common/enkf.h @@ -43,6 +43,7 @@ extern void clm_advance(int *ntstep, int *tstartcycle, int *mype); extern void update_clm(int *tstartcycle, int *mype); #if defined CLMSA extern void print_update_clm(int *ts, int *ttot); +extern void print_inc_clm(); #endif extern void write_clm_statistics(int *ts, int *ttot); extern void clm_finalize(); @@ -59,6 +60,7 @@ GLOBAL char pfoutfile_stat[500]; GLOBAL char pfproblemname[100]; GLOBAL char clminfile[100*2]; GLOBAL char outdir[100]; +GLOBAL char mean_filename[100]; /* integers */ GLOBAL int nprocpf; @@ -88,6 +90,7 @@ GLOBAL int nx_local,ny_local,nz_local; GLOBAL int clmupdate_swc; GLOBAL int clmupdate_T; GLOBAL int clmupdate_texture; +GLOBAL int clmupdate_tws; GLOBAL int clmprint_swc; GLOBAL int clmprint_et; GLOBAL int clmstatevec_allcol; @@ -108,6 +111,11 @@ GLOBAL int pf_aniso_use_parflow; GLOBAL int is_dampfac_state_time_dependent; GLOBAL int is_dampfac_param_time_dependent; GLOBAL int pf_dampswitch_sm; +GLOBAL int TWS_smoother; +GLOBAL int state_setup; +GLOBAL int update_snow; +GLOBAL int remove_mean; +GLOBAL int exclude_greenland; GLOBAL int crns_flag; GLOBAL int da_print_obs_index; extern int model; @@ -139,3 +147,4 @@ GLOBAL double dampfac_state_time_dependent; GLOBAL double dampfac_param_time_dependent; GLOBAL double da_crns_depth_tol; GLOBAL double clmcrns_bd; +GLOBAL double max_inc; diff --git a/interface/model/common/read_enkfpar.c b/interface/model/common/read_enkfpar.c index b2bfec287..5bc93865e 100755 --- a/interface/model/common/read_enkfpar.c +++ b/interface/model/common/read_enkfpar.c @@ -87,6 +87,7 @@ void read_enkfpar(char *parname) clmt_printensemble = iniparser_getint(pardict,"CLM:t_printensemble",-1); clmwatmin_switch = iniparser_getint(pardict,"CLM:watmin_switch",0); clmswc_mask_snow = iniparser_getint(pardict,"CLM:swc_mask_snow",0); + clmupdate_tws = iniparser_getint(pardict,"CLM:update_tws",0); /* get settings for COSMO */ nproccosmo = iniparser_getint(pardict,"COSMO:nprocs",0); @@ -104,6 +105,14 @@ void read_enkfpar(char *parname) screen_wrapper = iniparser_getint(pardict,"DA:screen_wrapper",1); point_obs = iniparser_getint(pardict,"DA:point_obs",1); obs_interp_switch = iniparser_getint(pardict,"DA:obs_interp_switch",0); + + max_inc = iniparser_getdouble(pardict,"DA:max_inc",1.0); + TWS_smoother = iniparser_getint(pardict,"DA:TWS_smoother",0); + state_setup = iniparser_getint(pardict,"DA:state_setup",0); + update_snow = iniparser_getint(pardict,"DA:update_snow",0); + remove_mean = iniparser_getint(pardict,"DA:remove_mean",0); + exclude_greenland = iniparser_getint(pardict,"DA:exclude_greenland",0); + crns_flag = iniparser_getint(pardict,"DA:crns_flag",0); da_crns_depth_tol = iniparser_getdouble(pardict,"DA:da_crns_depth_tol",0.01); clmcrns_bd = iniparser_getdouble(pardict, "DA:crns_bd", -1.0); diff --git a/interface/model/eclm/enkf_clm_5.F90 b/interface/model/eclm/enkf_clm_5.F90 index 873c9722a..a309d4690 100644 --- a/interface/model/eclm/enkf_clm_5.F90 +++ b/interface/model/eclm/enkf_clm_5.F90 @@ -72,6 +72,7 @@ subroutine clm_init(finname, pdaf_id, pdaf_max, mype) bind(C,name="clm_init") #if defined CLMSA use enkf_clm_mod, only: define_clm_statevec #endif + use clm_varcon, only: averaging_var !!<< TSMP PDAF addition end implicit none @@ -185,6 +186,7 @@ subroutine clm_init(finname, pdaf_id, pdaf_max, mype) bind(C,name="clm_init") callcount=0) #if defined CLMSA + averaging_var=0 call define_clm_statevec(mype) #endif @@ -216,6 +218,13 @@ subroutine clm_advance(ntstep, tstartcycle, mype) bind(C,name="clm_advance") call cime_run(ntstep) #if defined CLMSA + ! TODO: Get the use_omi information here as IF-condition + call cleanup_clm_statevec() ! cleanup before defining statevec + call define_clm_statevec(mype) ! call define statevec not in the beginning + ! but here as we can define the statevec for each obs type + + ! maybe I have to cleanup before defining, check later + ! Calling PDAF Function to set state vector before assimiliation call set_clm_statevec(tstartcycle, mype) #endif diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index 259e2238f..9e3d53aaf 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -55,6 +55,41 @@ module enkf_clm_mod integer(c_int),bind(C,name="clmupdate_T") :: clmupdate_T ! by hcp integer(c_int),bind(C,name="clmupdate_texture") :: clmupdate_texture integer(c_int),bind(C,name="clmprint_swc") :: clmprint_swc + + ! Yorck + integer(c_int),bind(C,name="clmupdate_tws") :: clmupdate_tws + integer(c_int),bind(C,name="exclude_greenland") :: exclude_greenland + real(r8),bind(C,name="da_interval") :: da_interval + integer, dimension(1:5) :: clm_varsize_tws + real(r8),bind(C,name="max_inc") :: max_inc + integer(c_int),bind(C,name="TWS_smoother") :: TWS_smoother + integer(c_int),bind(C,name="state_setup") :: state_setup + integer, allocatable :: num_layer(:) + integer, allocatable :: num_layer_columns(:) + integer :: num_hactiveg, num_hactivec + + integer, allocatable :: hactiveg_levels(:,:) ! hydrolocial active filter for all levels (gridcell) + integer, allocatable :: hactivec_levels(:,:) ! hydrolocial active filter for all levels (column) + integer, allocatable :: gridcell_state(:) + + + ! OMI --> I want to update the observation type after each observation comes in. + ! problem: the observation type is updated before the update of the assimilation + ! this causes the wrong observation type to be used in the update + + ! idea: the state vector is newly initilized for each assimilation time step for the current variable + ! use a new variable, e.g. obs_type_update_tws, and make it equal to clmupdate_tws at the beginning of the initialization + ! this variable is then used in the update of the state vector + + integer :: obs_type_update_swc = 0 + integer :: obs_type_update_tws = 0 + integer :: obs_type_update_T = 0 + integer :: obs_type_update_texture = 0 + + + + ! end Yorck + #endif integer(c_int),bind(C,name="clmprint_et") :: clmprint_et integer(c_int),bind(C,name="clmstatevec_allcol") :: clmstatevec_allcol @@ -89,7 +124,112 @@ module enkf_clm_mod #if defined CLMSA subroutine define_clm_statevec(mype) - use shr_kind_mod, only: r8 => shr_kind_r8 + use decompMod , only : get_proc_bounds + use clm_varpar , only : nlevsoi + + implicit none + + integer,intent(in) :: mype + + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + clm_begg = begg + clm_endg = endg + clm_begc = begc + clm_endc = endc + clm_begp = begp + clm_endp = endp + + clm_statevecsize = 0 + clm_varsize = 0 + + ! check which observation type should be assimilated and design the state vector accordingly + ! I will introduce functions for each observation type so that other types can easily be included + + ! make update variable equal to the clmupdate variable + obs_type_update_swc = clmupdate_swc + obs_type_update_tws = clmupdate_tws + obs_type_update_T = clmupdate_T + obs_type_update_texture = clmupdate_texture + + ! soil water content observations - case 1 + if(clmupdate_swc==1) then + call define_clm_statevec_swc + end if + + ! soil water content observations - case 2 + if(clmupdate_swc==2) then + error stop "Not implemented: clmupdate_swc.eq.2" + end if + + ! texture observations - case 1 + if(clmupdate_texture==1) then + clm_statevecsize = clm_statevecsize + 2*((endg-begg+1)*nlevsoi) + end if + + ! texture observations - case 2 + if(clmupdate_texture==2) then + clm_statevecsize = clm_statevecsize + 3*((endg-begg+1)*nlevsoi) + end if + + ! soil temperature observations --> Visakh can add his stuff here + if(clmupdate_T==1) then + error stop "Not implemented: clmupdate_T.eq.1" + end if + + ! TWS observations + if (clmupdate_tws==1) then + call define_clm_statevec_tws + end if + + ! + + ! Include your own state vector definitions here for different variables (ET, LAI, etc.) + + ! + +#ifdef PDAF_DEBUG + ! Debug output of clm_statevecsize + WRITE(*, '(a,x,a,i5,x,a,i10)') "TSMP-PDAF-debug", "mype(w)=", mype, "define_clm_statevec: clm_statevecsize=", clm_statevecsize +#endif + + if ((clmupdate_swc/=0) .or. (clmupdate_T/=0) .or. (clmupdate_texture/=0) .or. (clmupdate_tws/=0)) then + !hcp added condition + allocate(clm_statevec(clm_statevecsize)) + end if + + + ! Allocate statevector-duplicate for saving original column mean + ! values used in computing increments during updating the state + ! vector in column-mean-mode. + IF (allocated(clm_statevec_orig)) deallocate(clm_statevec_orig) + if ( (clmupdate_swc/=0 .and. clmstatevec_colmean/=0) .or. clmupdate_tws/=0 ) then + allocate(clm_statevec_orig(clm_statevecsize)) + end if + + !write(*,*) 'clm_paramsize is ',clm_paramsize + if (allocated(clm_paramarr)) deallocate(clm_paramarr) !hcp + if ((clmupdate_T/=0)) then !hcp + error stop "Not implemented clmupdate_T.NE.0" + end if + + if (allocated(gridcell_state)) deallocate(gridcell_state) + allocate(gridcell_state(clm_statevecsize)) + + + end subroutine define_clm_statevec + + + + + + subroutine define_clm_statevec_swc() use decompMod , only : get_proc_bounds use clm_varpar , only : nlevsoi use clm_varcon , only : ispval @@ -100,13 +240,9 @@ subroutine define_clm_statevec(mype) integer,intent(in) :: mype integer :: i - integer :: j - integer :: jj integer :: c integer :: g - integer :: cg integer :: cc - integer :: cccheck integer :: begp, endp ! per-proc beginning and ending pft indices integer :: begc, endc ! per-proc beginning and ending column indices @@ -130,15 +266,14 @@ subroutine define_clm_statevec(mype) clm_endp = endp ! Soil Moisture DA: State vector index arrays - if(clmupdate_swc==1) then ! 1) COL/GRC: CLM->PDAF IF (allocated(state_clm2pdaf_p)) deallocate(state_clm2pdaf_p) - allocate(state_clm2pdaf_p(begc:endc,nlevsoi)) + allocate(state_clm2pdaf_p(clm_begc:clm_endc,nlevsoi)) do i=1,nlevsoi do c=clm_begc,clm_endc ! Default: inactive - state_clm2pdaf_p = ispval + state_clm2pdaf_p(c,i) = ispval end do end do @@ -283,53 +418,222 @@ subroutine define_clm_statevec(mype) #endif end do - endif + end subroutine define_clm_statevec_swc - if(clmupdate_swc==2) then - error stop "Not implemented: clmupdate_swc.eq.2" - endif - if(clmupdate_texture==1) then - clm_statevecsize = clm_statevecsize + 2*((endg-begg+1)*nlevsoi) - endif + subroutine define_clm_statevec_tws() + use shr_kind_mod, only: r8 => shr_kind_r8 + use decompMod , only : get_proc_bounds + use clm_varpar , only : nlevsoi + use ColumnType , only : col + use PatchType, only: patch + use GridcellType, only: grc - if(clmupdate_texture==2) then - clm_statevecsize = clm_statevecsize + 3*((endg-begg+1)*nlevsoi) - endif + implicit none - !hcp LST DA - if(clmupdate_T==1) then - error stop "Not implemented: clmupdate_T.eq.1" - endif - !end hcp + integer :: i + integer :: j + integer :: c + integer :: g + integer :: cc + + integer :: fa, fg + + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + + logical, allocatable :: found(:) + + real(r8), pointer :: lon(:) + real(r8), pointer :: lat(:) + + lon => grc%londeg + lat => grc%latdeg + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) #ifdef PDAF_DEBUG - ! Debug output of clm_statevecsize - WRITE(*, '(a,x,a,i5,x,a,i10)') "TSMP-PDAF-debug", "mype(w)=", mype, "define_clm_statevec: clm_statevecsize=", clm_statevecsize + WRITE(*,"(a,i5,a,i10,a,i10,a,i10,a,i10,a,i10,a,i10,a,i10,a,i10,a)") & + "TSMP-PDAF mype(w)=", mype, " define_clm_statevec, CLM5-bounds (g,l,c,p)----",& + begg,",",endg,",",begl,",",endl,",",begc,",",endc,",",begp,",",endp," -------" #endif - !write(*,*) 'clm_statevecsize is ',clm_statevecsize - IF (allocated(clm_statevec)) deallocate(clm_statevec) - if ((clmupdate_swc/=0) .or. (clmupdate_T/=0) .or. (clmupdate_texture/=0)) then - !hcp added condition - allocate(clm_statevec(clm_statevecsize)) - end if + clm_begg = begg + clm_endg = endg + clm_begc = begc + clm_endc = endc + clm_begp = begp + clm_endp = endp - ! Allocate statevector-duplicate for saving original column mean - ! values used in computing increments during updating the state - ! vector in column-mean-mode. - IF (allocated(clm_statevec_orig)) deallocate(clm_statevec_orig) - if (clmupdate_swc/=0 .and. clmstatevec_colmean/=0) then - allocate(clm_statevec_orig(clm_statevecsize)) - end if - !write(*,*) 'clm_paramsize is ',clm_paramsize - if (allocated(clm_paramarr)) deallocate(clm_paramarr) !hcp - if ((clmupdate_T/=0)) then !hcp - error stop "Not implemented clmupdate_T.NE.0" - end if + ! first we build a filter to determine which columns are active / are not active + ! we also build a gridcell filter for gridcell averges + + num_hactiveg = 0 + num_hactivec = 0 + + if (allocated(found)) deallocate(found) + allocate(found(clm_begg:clm_endg)) + found(clm_begg:clm_endg) = .false. + + if (allocated(num_layer)) deallocate(num_layer) + allocate(num_layer(1:nlevsoi)) + num_layer(1:nlevsoi) = 0 + + if (allocated(num_layer_columns)) deallocate(num_layer_columns) + allocate(num_layer_columns(1:nlevsoi)) + num_layer_columns(1:nlevsoi) = 0 + + do c = clm_begc, clm_endc ! find hydrological active cells + + g = col%gridcell(c) ! gridcell of column + + if ((exclude_greenland==0) .or. (.not.(lon(g)<330 .and. lon(g)>180 .and. lat(g)>55))) then ! greenland can be excluded from the statevector + + if (col%hydrologically_active(c)) then ! if the column is hydrologically active, add it, if the corresponding gridcell is not found before, add also the gridcell + + if (.not. found(g)) then ! if the gridcell is not found before + + found(g) = .true. + + do j = 1,nlevsoi ! add gridcell for each layer until bedrock + ! get number in layers + + if (j<=col%nbedrock(c)) then + num_layer(j) = num_layer(j) + 1 + end if + + end do + + num_hactiveg = num_hactiveg + 1 + + end if + + do j = 1,nlevsoi ! add column for each layer until bedrock + ! get number in layers + + if (j<=col%nbedrock(c)) then + num_layer_columns(j) = num_layer_columns(j) + 1 + end if + + end do + + num_hactivec = num_hactivec + 1 + + end if + end if + end do + + + ! allocate matrices that will hold the index of each hydrologically active component (gridcell, column, patch) in each depth + if (allocated(hactiveg_levels)) deallocate(hactiveg_levels) + if (allocated(hactivec_levels)) deallocate(hactivec_levels) + allocate(hactiveg_levels(1:num_hactiveg,1:nlevsoi)) + allocate(hactivec_levels(1:num_hactivec,1:nlevsoi)) + + ! now we fill these things with the columns and gridcells so that we can access all active things later on + + do j = 1,nlevsoi + + found(clm_begg:clm_endg) = .false. ! has to be inside the for lopp, else, the hactiveg_levels is only filled for the first level + fa = 0 + fg = 0 + + do c = clm_begc, clm_endc + g = col%gridcell(c) ! gridcell of column + + if ((exclude_greenland==0) .or. (.not.(lon(g)<330 .and. lon(g)>180 .and. lat(g)>55))) then + + if (col%hydrologically_active(c)) then + + if (.not. found(g)) then ! if the gridcell is not found before + + found(g) = .true. + + if (j<=col%nbedrock(c)) then + fg = fg+1 + hactiveg_levels(fg,j) = g + end if + + end if + + if (j<=col%nbedrock(c)) then + fa = fa + 1 + hactivec_levels(fa,j) = c + end if + + end if + + end if + + end do + end do + + + if (allocated(found)) deallocate(found) + + ! now we have an array for the columns and gridcells of interest that we can use when we fill the statevector and distribute the update + ! now lets find out the dimension of the state vector + + clm_varsize_tws(:) = 0 + + clm_statevecsize = 0 + + select case (state_setup) + case(0) + ! all compartments in state vector, liq and ice added up to not run into balancing errors due to different partioning + ! in different ensemble members in these variables even if the total amount of water is similar + + do j = 1,nlevsoi + clm_varsize_tws(1) = clm_varsize_tws(1) + num_layer(j) + clm_statevecsize = clm_statevecsize + num_layer(j) + + clm_varsize_tws(2) = 0 ! as liq + ice is added up, we do not need another variable for ice + clm_statevecsize = clm_statevecsize + 0 + end do + + ! snow + clm_varsize_tws(3) = num_layer(1) + clm_statevecsize = clm_statevecsize + num_layer(1) + + ! surface water + clm_varsize_tws(4) = num_layer(1) + clm_statevecsize = clm_statevecsize + num_layer(1) + + ! canopy water + clm_varsize_tws(5) = 0 + clm_statevecsize = clm_statevecsize + 0 + + case(1) ! TWS in statevector + + clm_varsize_tws(1) = num_layer(1) + clm_statevecsize = clm_statevecsize + num_layer(1) + clm_varsize_tws(2) = 0 + clm_varsize_tws(3) = 0 + clm_varsize_tws(4) = 0 + clm_varsize_tws(5) = 0 + + case(2) ! snow and soil moisture aggregated over surface, root zone and deep soil moisture in state vector + + clm_varsize_tws(1) = num_layer(1) + clm_statevecsize = clm_statevecsize + num_layer(1) + + clm_varsize_tws(2) = num_layer(4) + clm_statevecsize = clm_statevecsize + num_layer(4) + + clm_varsize_tws(3) = num_layer(13) + clm_statevecsize = clm_statevecsize + num_layer(13) + + ! one variable for snow + clm_varsize_tws(4) = num_layer(1) + clm_statevecsize = clm_statevecsize + num_layer(1) + + end select + + end subroutine define_clm_statevec_tws - end subroutine define_clm_statevec subroutine cleanup_clm_statevec() @@ -340,6 +644,7 @@ subroutine cleanup_clm_statevec() IF (allocated(state_pdaf2clm_c_p)) deallocate(state_pdaf2clm_c_p) IF (allocated(state_pdaf2clm_j_p)) deallocate(state_pdaf2clm_j_p) IF (allocated(state_clm2pdaf_p)) deallocate(state_clm2pdaf_p) + IF (allocated(clm_statevec_orig)) deallocate(clm_statevec_orig) end subroutine cleanup_clm_statevec @@ -384,31 +689,93 @@ subroutine set_clm_statevec(tstartcycle, mype) END IF #endif + if(clmupdate_swc==1) then + call set_clm_statevec_swc + end if + ! calculate shift when CRP data are assimilated if(clmupdate_swc==2) then error stop "Not implemented clmupdate_swc.eq.2" endif - if(clmupdate_swc/=0) then - ! write swc values to state vector - if (clmstatevec_colmean==1) then - - do cc = 1, clm_statevecsize - - clm_statevec(cc) = 0.0 - n_c = 0 + !hcp LAI + if(clmupdate_T==1) then + error stop "Not implemented: clmupdate_T.eq.1" + endif + !end hcp LAI - ! Get gridcell and layer - g = col%gridcell(state_pdaf2clm_c_p(cc)) - j = state_pdaf2clm_j_p(cc) + ! write average swc to state vector (CRP assimilation) + if(clmupdate_swc==2) then + error stop "Not implemented: clmupdate_swc.eq.2" + endif - ! Loop over all columns - do c=clm_begc,clm_endc - ! Select columns in gridcell g - if(col%gridcell(c)==g) then - ! Select hydrologically active columns - if(col%hydrologically_active(c)) then - ! Add active column to swc-sum + ! write texture values to state vector (if desired) + if(clmupdate_texture/=0) then + cc = 1 + do i=1,nlevsoi + do j=clm_begg,clm_endg + clm_statevec(cc+1*clm_varsize+offset) = psand(j,i) + clm_statevec(cc+2*clm_varsize+offset) = pclay(j,i) + if(clmupdate_texture==2) then + !incl. organic matter values + clm_statevec(cc+3*clm_varsize+offset) = porgm(j,i) + end if + cc = cc + 1 + end do + end do + endif + + if (clmupdate_tws==1) then + call set_clm_statevec_tws + end if + +#ifdef PDAF_DEBUG + IF(clmt_printensemble == tstartcycle + 1 .OR. clmt_printensemble < 0) THEN + ! TSMP-PDAF: For debug runs, output the state vector in files + WRITE(fn, "(a,i5.5,a,i5.5,a)") "clmstate_", mype, ".integrate.", tstartcycle + 1, ".txt" + OPEN(unit=71, file=fn, action="write") + DO i = 1, clm_statevecsize + WRITE (71,"(es22.15)") clm_statevec(i) + END DO + CLOSE(71) + END IF +#endif + + end subroutine set_clm_statevec + + + + subroutine set_clm_statevec_swc() + use clm_instMod, only : soilstate_inst, waterstate_inst + use clm_varpar , only : nlevsoi + use ColumnType , only : col + use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none + real(r8), pointer :: swc(:,:) + integer :: j,g,cc=0,c + integer :: n_c + + swc => waterstate_inst%h2osoi_vol_col + + ! write swc values to state vector + if (clmstatevec_colmean==1) then + + do cc = 1, clm_statevecsize + + clm_statevec(cc) = 0.0 + n_c = 0 + + ! Get gridcell and layer + g = col%gridcell(state_pdaf2clm_c_p(cc)) + j = state_pdaf2clm_j_p(cc) + + ! Loop over all columns + do c=clm_begc,clm_endc + ! Select columns in gridcell g + if(col%gridcell(c)==g) then + ! Select hydrologically active columns + if(col%hydrologically_active(c)) then + ! Add active column to swc-sum clm_statevec(cc) = clm_statevec(cc) + swc(c,j) n_c = n_c + 1 end if @@ -436,91 +803,296 @@ subroutine set_clm_statevec(tstartcycle, mype) clm_statevec(cc) = swc(state_pdaf2clm_c_p(cc), state_pdaf2clm_j_p(cc)) end do end if - endif - !hcp LAI - if(clmupdate_T==1) then - error stop "Not implemented: clmupdate_T.eq.1" - endif - !end hcp LAI + end subroutine set_clm_statevec_swc - ! write average swc to state vector (CRP assimilation) - if(clmupdate_swc==2) then - error stop "Not implemented: clmupdate_swc.eq.2" - endif - ! write texture values to state vector (if desired) - if(clmupdate_texture/=0) then - cc = 1 - do i=1,nlevsoi - do j=clm_begg,clm_endg - clm_statevec(cc+1*clm_varsize+offset) = psand(j,i) - clm_statevec(cc+2*clm_varsize+offset) = pclay(j,i) - if(clmupdate_texture==2) then - !incl. organic matter values - clm_statevec(cc+3*clm_varsize+offset) = porgm(j,i) - end if + subroutine set_clm_statevec_tws() + use clm_instMod, only : soilstate_inst, waterstate_inst + use clm_varpar , only : nlevsoi + use ColumnType , only : col + use shr_kind_mod, only: r8 => shr_kind_r8 + use PatchType, only: patch + use GridcellType, only: grc + implicit none + + integer :: j,g,cc=0,count,c,count_c + integer :: n_c + real(r8) :: avg_sum + + real(r8), pointer :: liq(:,:) ! liquid water (kg/m2) + real(r8), pointer :: ice(:,:) ! ice lens (kg/m2) + real(r8), pointer :: snow(:) ! snow water (mm) + real(r8), pointer :: sfc(:) ! surface water + real(r8), pointer :: can(:) ! canopy water + real(r8), pointer :: TWS(:) ! TWS + + real(r8), pointer :: tws_state(:) + real(r8), pointer :: liq_state(:,:) + real(r8), pointer :: ice_state(:,:) + real(r8), pointer :: snow_state(:) + + tws_state => waterstate_inst%tws_state_before + liq_state => waterstate_inst%h2osoi_liq_state_before + ice_state => waterstate_inst%h2osoi_ice_state_before + snow_state => waterstate_inst%h2osno_state_before + + select case (TWS_smoother) + + case(0) ! instantaneous values + liq => waterstate_inst%h2osoi_liq_col + ice => waterstate_inst%h2osoi_ice_col + snow => waterstate_inst%h2osno_col + sfc => waterstate_inst%h2osfc_col + can => waterstate_inst%h2ocan_patch + TWS => waterstate_inst%tws_hactive + case(1) ! monthly means + liq => waterstate_inst%h2osoi_liq_col_mean + ice => waterstate_inst%h2osoi_ice_col_mean + snow => waterstate_inst%h2osno_col_mean + sfc => waterstate_inst%h2osfc_col_mean + can => waterstate_inst%h2ocan_patch_mean + TWS => waterstate_inst%tws_hactive_mean + end select + + select case (state_setup) + case(0) ! all compartments in state vector + cc = 1 + do j = 1,nlevsoi + do count = 1, num_layer(j) + g = hactiveg_levels(count,j) + + clm_statevec(cc) = 0.0 + n_c = 0 + + do count_c = 1,num_layer_columns(j) ! get average over liq+ice for all columns in gridcell g + c = hactivec_levels(count_c,j) + if (g==col%gridcell(c)) then + clm_statevec(cc) = clm_statevec(cc) + liq(c,j) + ice(c,j) + n_c = n_c + 1 + end if + end do + + clm_statevec(cc) = clm_statevec(cc) / real(n_c, r8) + clm_statevec_orig(cc) = clm_statevec(cc) + + liq_state(g,j) = clm_statevec(cc) + + gridcell_state(cc) = g + + if (j==1) then ! for the first layer, we can fill the other compartments + + ! snow + clm_statevec(cc+sum(clm_varsize_tws(1:2))) = 0.0 + n_c = 0 + + do count_c = 1,num_layer_columns(j) + c = hactivec_levels(count_c,j) + if (g==col%gridcell(c)) then + clm_statevec(cc+sum(clm_varsize_tws(1:2))) = clm_statevec(cc+sum(clm_varsize_tws(1:2))) + snow(c) + n_c = n_c + 1 + end if + end do + + clm_statevec(cc+sum(clm_varsize_tws(1:2))) = clm_statevec(cc+sum(clm_varsize_tws(1:2))) / real(n_c, r8) + clm_statevec_orig(cc+sum(clm_varsize_tws(1:2))) = clm_statevec(cc+sum(clm_varsize_tws(1:2))) + + snow_state(g) = clm_statevec(cc+sum(clm_varsize_tws(1:2))) + gridcell_state(cc+sum(clm_varsize_tws(1:2))) = g + + ! surface water + clm_statevec(cc+sum(clm_varsize_tws(1:3))) = 0.0 + n_c = 0 + + do count_c = 1,num_layer_columns(j) + c = hactivec_levels(count_c,j) + if (g==col%gridcell(c)) then + clm_statevec(cc+sum(clm_varsize_tws(1:3))) = clm_statevec(cc+sum(clm_varsize_tws(1:3))) + sfc(c) + n_c = n_c + 1 + end if + + end do + + clm_statevec(cc+sum(clm_varsize_tws(1:3))) = clm_statevec(cc+sum(clm_varsize_tws(1:3))) / real(n_c, r8) + clm_statevec_orig(cc+sum(clm_varsize_tws(1:3))) = clm_statevec(cc+sum(clm_varsize_tws(1:3))) + gridcell_state(cc+sum(clm_varsize_tws(1:3))) = g + end if + + cc = cc+1 + end do + end do + + case(1) ! TWS in state vector + + cc = 1 + + do count = 1, num_layer(1) + g = hactiveg_levels(count,1) + clm_statevec(cc) = TWS(g) + clm_statevec_orig(cc) = TWS(g) + tws_state(g) = clm_statevec(cc) + gridcell_state(cc) = g + cc = cc+1 + end do + + case(2) ! snow and soil moisture aggregated over surface, root zone and deep soil moisture in state vector + + cc = 1 + + ! surface soil moisture + do count = 1, num_layer(1) + clm_statevec(cc) = 0 + g = hactiveg_levels(count,1) + + do j = 1, 3 ! surface SM + avg_sum = 0 + n_c = 0 + do count_c = 1,num_layer_columns(j) + c = hactivec_levels(count_c,j) + if (g==col%gridcell(c)) then + avg_sum = avg_sum + liq(c,j) + ice(c,j) + n_c = n_c+1 + end if + + end do + + if (n_c/=0) then + + clm_statevec(cc) = clm_statevec(cc) + avg_sum / real(n_c, r8) + + end if + + end do + + clm_statevec_orig(cc) = clm_statevec(cc) + liq_state(g,1) = clm_statevec(cc) + + gridcell_state(cc) = g + cc = cc + 1 + end do - end do - endif -#ifdef PDAF_DEBUG - IF(clmt_printensemble == tstartcycle + 1 .OR. clmt_printensemble < 0) THEN - ! TSMP-PDAF: For debug runs, output the state vector in files - WRITE(fn, "(a,i5.5,a,i5.5,a)") "clmstate_", mype, ".integrate.", tstartcycle + 1, ".txt" - OPEN(unit=71, file=fn, action="write") - DO i = 1, clm_statevecsize - WRITE (71,"(es22.15)") clm_statevec(i) - END DO - CLOSE(71) - END IF -#endif + cc = 1 + + ! root zone soil moisture + do count = 1, num_layer(4) + clm_statevec(cc+clm_varsize_tws(1)) = 0 + g = hactiveg_levels(count,4) + do j = 4, 12 + avg_sum = 0 + n_c = 0 + do count_c = 1,num_layer_columns(j) + c = hactivec_levels(count_c,j) + if (g==col%gridcell(c)) then + avg_sum = avg_sum + liq(c,j) + ice(c,j) + n_c = n_c+1 + end if + end do + + if (n_c/=0) then + + clm_statevec(cc+clm_varsize_tws(1)) = clm_statevec(cc+clm_varsize_tws(1)) + avg_sum / real(n_c, r8) + + end if + + end do + + clm_statevec_orig(cc+clm_varsize_tws(1)) = clm_statevec(cc+clm_varsize_tws(1)) + liq_state(g,2) = clm_statevec(cc+clm_varsize_tws(1)) + gridcell_state(cc+clm_varsize_tws(1)) = g + + cc = cc + 1 + + end do + + cc = 1 + + ! deep soil moisture + do count = 1, num_layer(13) + clm_statevec(cc+sum(clm_varsize_tws(1:2))) = 0 + g = hactiveg_levels(count,13) + do j = 13, nlevsoi + avg_sum = 0 + n_c = 0 + do count_c = 1,num_layer_columns(j) + c = hactivec_levels(count_c,j) + if (g==col%gridcell(c)) then + avg_sum = avg_sum + liq(c,j) + ice(c,j) + n_c = n_c+1 + end if + end do + + if (n_c/=0) then + + clm_statevec(cc+sum(clm_varsize_tws(1:2))) = clm_statevec(cc+sum(clm_varsize_tws(1:2))) + avg_sum / real(n_c, r8) + + end if + + end do + + clm_statevec_orig(cc+sum(clm_varsize_tws(1:2))) = clm_statevec(cc+sum(clm_varsize_tws(1:2))) + liq_state(g,3) = clm_statevec(cc+sum(clm_varsize_tws(1:2))) + gridcell_state(cc+sum(clm_varsize_tws(1:2))) = g + + cc = cc + 1 + + end do + + cc = 1 + + ! snow + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + clm_statevec(cc+sum(clm_varsize_tws(1:3))) = 0 + n_c = 0 + do count_c = 1,num_layer_columns(1) + c = hactivec_levels(count_c,1) + if (g==col%gridcell(c)) then + clm_statevec(cc+sum(clm_varsize_tws(1:3))) = clm_statevec(cc+sum(clm_varsize_tws(1:3))) + snow(c) + n_c = n_c+1 + end if + end do + + clm_statevec(cc+sum(clm_varsize_tws(1:3))) = clm_statevec(cc+sum(clm_varsize_tws(1:3))) / real(n_c, r8) + clm_statevec_orig(cc+sum(clm_varsize_tws(1:3))) = clm_statevec(cc+sum(clm_varsize_tws(1:3))) + + snow_state(g) = clm_statevec(cc+sum(clm_varsize_tws(1:3))) + gridcell_state(cc+sum(clm_varsize_tws(1:3))) = g + + cc = cc+1 + + end do + + end select + + + end subroutine set_clm_statevec_tws + + - end subroutine set_clm_statevec subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") - use clm_varpar , only : nlevsoi use clm_time_manager , only : update_DA_nstep use shr_kind_mod , only : r8 => shr_kind_r8 - use ColumnType , only : col - use clm_instMod, only : soilstate_inst, waterstate_inst - use clm_varcon , only : denh2o, denice, watmin - use clm_varcon , only : ispval - use clm_varcon , only : spval + use clm_instMod, only : waterstate_inst implicit none integer,intent(in) :: tstartcycle integer,intent(in) :: mype - real(r8), pointer :: swc(:,:) - real(r8), pointer :: watsat(:,:) - real(r8), pointer :: psand(:,:) - real(r8), pointer :: pclay(:,:) - real(r8), pointer :: porgm(:,:) - - real(r8), pointer :: dz(:,:) ! layer thickness depth (m) real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) real(r8), pointer :: h2osoi_ice(:,:) - real(r8), pointer :: snow_depth(:) - real(r8) :: rliq,rice - real(r8) :: watmin_check ! minimum soil moisture for checking clm_statevec (mm) - real(r8) :: watmin_set ! minimum soil moisture for setting swc (mm) - real(r8) :: swc_update ! updated SWC in loop - integer :: i,j,jj,g,cc,offset - character (len = 31) :: fn !TSMP-PDAF: function name for state vector outpu - character (len = 31) :: fn2 !TSMP-PDAF: function name for state vector outpu - character (len = 32) :: fn3 !TSMP-PDAF: function name for state vector outpu - character (len = 32) :: fn4 !TSMP-PDAF: function name for state vector outpu + integer :: i character (len = 32) :: fn5 !TSMP-PDAF: function name for state vector outpu character (len = 32) :: fn6 !TSMP-PDAF: function name for state vector outpu logical :: swc_zero_before_update - cc = 0 - offset = 0 swc_zero_before_update = .false. #ifdef PDAF_DEBUG @@ -535,22 +1107,13 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") END IF #endif - swc => waterstate_inst%h2osoi_vol_col - watsat => soilstate_inst%watsat_col - psand => soilstate_inst%cellsand_col - pclay => soilstate_inst%cellclay_col - porgm => soilstate_inst%cellorg_col - - snow_depth => waterstate_inst%snow_depth_col ! snow height of snow covered area (m) - - dz => col%dz h2osoi_liq => waterstate_inst%h2osoi_liq_col h2osoi_ice => waterstate_inst%h2osoi_ice_col #ifdef PDAF_DEBUG IF(clmt_printensemble == tstartcycle .OR. clmt_printensemble < 0) THEN - IF(clmupdate_swc/=0) THEN + IF(obs_type_update_swc/=0) THEN ! TSMP-PDAF: For debug runs, output the state vector in files WRITE(fn5, "(a,i5.5,a,i5.5,a)") "h2osoi_liq", mype, ".bef_up.", tstartcycle, ".txt" OPEN(unit=71, file=fn5, action="write") @@ -568,7 +1131,7 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") #endif ! calculate shift when CRP data are assimilated - if(clmupdate_swc==2) then + if(obs_type_update_swc==2) then error stop "Not implemented: clmupdate_swc.eq.2" endif @@ -578,7 +1141,76 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") call update_DA_nstep() ! write updated swc back to CLM - if(clmupdate_swc/=0) then + if(obs_type_update_swc/=0) then + call update_swc(tstartcycle, mype) + endif + + !hcp: TG, TV + if(obs_type_update_T==1) then + error stop "Not implemented: clmupdate_T.eq.1" + endif + ! end hcp TG, TV + + ! write updated texture back to CLM + if(obs_type_update_texture/=0) then + call update_texture(tstartcycle, mype) + endif + + if (obs_type_update_tws==1) then + call clm_update_tws + end if + + + + end subroutine update_clm + + + subroutine update_swc(tstartcycle, mype) + use clm_varpar , only : nlevsoi + use shr_kind_mod , only : r8 => shr_kind_r8 + use ColumnType , only : col + use clm_instMod, only : soilstate_inst, waterstate_inst + use clm_varcon , only : denh2o, denice, watmin + use clm_varcon , only : ispval + use clm_varcon , only : spval + + implicit none + + integer,intent(in) :: tstartcycle + integer,intent(in) :: mype + + real(r8), pointer :: swc(:,:) + real(r8), pointer :: watsat(:,:) + + real(r8), pointer :: dz(:,:) ! layer thickness depth (m) + real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) + real(r8), pointer :: h2osoi_ice(:,:) + real(r8), pointer :: snow_depth(:) + real(r8), pointer :: liq_inc(:,:), ice_inc(:,:), snow_inc(:) + real(r8) :: rliq,rice + real(r8) :: watmin_check ! minimum soil moisture for checking clm_statevec (mm) + real(r8) :: watmin_set ! minimum soil moisture for setting swc (mm) + real(r8) :: swc_update ! updated SWC in loop + + integer :: i,j,cc=0 + character (len = 31) :: fn2 !TSMP-PDAF: function name for state vector outpu + character (len = 32) :: fn3 !TSMP-PDAF: function name for state vector outpu + character (len = 32) :: fn4 !TSMP-PDAF: function name for state vector outpu + + logical :: swc_zero_before_update = .false. + + swc => waterstate_inst%h2osoi_vol_col + watsat => soilstate_inst%watsat_col + dz => col%dz + h2osoi_liq => waterstate_inst%h2osoi_liq_col + h2osoi_ice => waterstate_inst%h2osoi_ice_col + + snow_depth => waterstate_inst%snow_depth_col ! snow height of snow covered area (m) + + liq_inc => waterstate_inst%h2osoi_liq_col_inc + ice_inc => waterstate_inst%h2osoi_ice_col_inc + snow_inc => waterstate_inst%h2osno_col_inc + ! Set minimum soil moisture for checking the state vector and ! for setting minimum swc for CLM @@ -596,6 +1228,19 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") watmin_set = 0.0 end if + do i = 1,nlevsoi + do j = clm_begc,clm_endc + + liq_inc(j,i) = h2osoi_liq(j,i) + ice_inc(j,i) = h2osoi_ice(j,i) + + if (i==1) then + snow_inc(j) = waterstate_inst%h2osno_col(j) + end if + + end do + end do + ! cc = 0 do i=1,nlevsoi ! CLM3.5: iterate over grid cells @@ -603,149 +1248,555 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") ! do j=clm_begg,clm_endg do j=clm_begc,clm_endc - ! If snow is masked, update only, when snow depth is less than 1mm - if( (.not. clmswc_mask_snow) .or. snow_depth(j) < 0.001 ) then - ! Update only those SWCs that are not excluded by ispval - if(state_clm2pdaf_p(j,i) /= ispval) then + ! If snow is masked, update only, when snow depth is less than 1mm + if( (.not. clmswc_mask_snow) .or. snow_depth(j) < 0.001 ) then + ! Update only those SWCs that are not excluded by ispval + if(state_clm2pdaf_p(j,i) /= ispval) then + + if(swc(j,i)==0.0) then + swc_zero_before_update = .true. + + ! Zero-SWC leads to zero denominator in computation of + ! rliq/rice, therefore setting rliq/rice to special + ! value + rliq = spval + rice = spval + else + swc_zero_before_update = .false. + + rliq = h2osoi_liq(j,i)/(dz(j,i)*denh2o*swc(j,i)) + rice = h2osoi_ice(j,i)/(dz(j,i)*denice*swc(j,i)) + !h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) + end if + + if (clmstatevec_colmean==1) then + ! If there is no significant increment, do not + ! implement any update / check. + ! + ! Note: Computing the absolute difference here, + ! because the whole state vector should be soil + ! moistures. For variables with very small values in + ! the state vector, this would have to be adapted + ! (e.g. to relative difference). + if( abs(clm_statevec(state_clm2pdaf_p(j,i)) - clm_statevec_orig(state_clm2pdaf_p(j,i))) <= 1.0e-7) then + cycle + end if + + ! Update SWC column value with the increment-factor + ! of the state vector update (state vector updates + ! are means of cols in grc) + swc_update = swc(j,i) * clm_statevec(state_clm2pdaf_p(j,i)) / clm_statevec_orig(state_clm2pdaf_p(j,i)) + else + ! Update SWC with updated state vector + swc_update = clm_statevec(state_clm2pdaf_p(j,i)) + end if + + if(swc_update<=watmin_check) then + swc(j,i) = watmin_set + else if(swc_update>=watsat(j,i)) then + swc(j,i) = watsat(j,i) + else + swc(j,i) = swc_update + endif + + if (isnan(swc(j,i))) then + swc(j,i) = watmin_set + print *, "WARNING: swc at j,i is nan: ", j, i + endif + + if(swc_zero_before_update) then + ! This case should not appear for hydrologically + ! active columns/layers, where always: swc > watmin + ! + ! If you want to make sure that no zero SWCs appear in + ! the code, comment out the error stop + +#ifdef PDAF_DEBUG + ! error stop "ERROR: Update of zero-swc" + print *, "WARNING: Update of zero-swc" + print *, "WARNING: Any new H2O added to h2osoi_liq(j,i) with j,i = ", j, i +#endif + h2osoi_liq(j,i) = swc(j,i) * dz(j,i)*denh2o + h2osoi_ice(j,i) = 0.0 + else + ! update liquid water content + h2osoi_liq(j,i) = swc(j,i) * dz(j,i)*denh2o*rliq + ! update ice content + h2osoi_ice(j,i) = swc(j,i) * dz(j,i)*denice*rice + end if + + end if + end if + ! cc = cc + 1 + end do + end do + +#ifdef PDAF_DEBUG + IF(clmt_printensemble == tstartcycle .OR. clmt_printensemble < 0) THEN + + ! TSMP-PDAF: For debug runs, output the state vector in files + WRITE(fn3, "(a,i5.5,a,i5.5,a)") "h2osoi_liq", mype, ".update.", tstartcycle, ".txt" + OPEN(unit=71, file=fn3, action="write") + WRITE (71,"(es22.15)") h2osoi_liq(:,:) + CLOSE(71) + + ! TSMP-PDAF: For debug runs, output the state vector in files + WRITE(fn4, "(a,i5.5,a,i5.5,a)") "h2osoi_ice", mype, ".update.", tstartcycle, ".txt" + OPEN(unit=71, file=fn4, action="write") + WRITE (71,"(es22.15)") h2osoi_ice(:,:) + CLOSE(71) + + ! TSMP-PDAF: For debug runs, output the state vector in files + WRITE(fn2, "(a,i5.5,a,i5.5,a)") "swcstate_", mype, ".update.", tstartcycle, ".txt" + OPEN(unit=71, file=fn2, action="write") + WRITE (71,"(es22.15)") swc(:,:) + CLOSE(71) + + END IF +#endif + + do i = 1,nlevsoi + do j=clm_begc,clm_endc + + liq_inc(j,i) = h2osoi_liq(j,i)-liq_inc(j,i) + ice_inc(j,i) = h2osoi_ice(j,i)-ice_inc(j,i) + + if (i==1) then + snow_inc(j) = waterstate_inst%h2osno_col(j)-snow_inc(j) + end if + + end do + end do + + end subroutine update_swc + + + + subroutine update_texture(tstartcycle, mype) + use clm_varpar , only : nlevsoi + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_instMod, only : soilstate_inst + + implicit none + + integer,intent(in) :: tstartcycle + integer,intent(in) :: mype + + integer :: i,j,cc=0,offset=0 + + real(r8), pointer :: psand(:,:) + real(r8), pointer :: pclay(:,:) + real(r8), pointer :: porgm(:,:) + + psand => soilstate_inst%cellsand_col + pclay => soilstate_inst%cellclay_col + porgm => soilstate_inst%cellorg_col + + cc = 1 + do i=1,nlevsoi + do j=clm_begg,clm_endg + psand(j,i) = clm_statevec(cc+1*clm_varsize+offset) + pclay(j,i) = clm_statevec(cc+2*clm_varsize+offset) + if(clmupdate_texture==2) then + ! incl. organic matter + porgm(j,i) = clm_statevec(cc+3*clm_varsize+offset) + end if + cc = cc + 1 + end do + end do + call clm_correct_texture + call clm_texture_to_parameters + + end subroutine update_texture + + + + subroutine clm_update_tws() + + use clm_varpar , only : nlevsoi, nlevsno + use shr_kind_mod, only: r8 => shr_kind_r8 + use clm_varcon, only: watmin, denh2o, denice, averaging_var + use ColumnType, only : col + use clm_instMod, only : soilstate_inst, waterstate_inst + + implicit none + + integer :: c, j + + real(r8), pointer :: liq(:,:), ice(:,:), swc(:,:) + real(r8), pointer :: dz(:,:), zi(:,:), z(:,:) + real(r8), pointer :: watsat(:,:), snow(:), snow_depth(:) + integer, pointer :: snl(:) + + real(r8), pointer :: liq_mean(:,:), ice_mean(:,:), snow_mean(:) + real(r8), pointer :: liq_inc(:,:), ice_inc(:,:), snow_inc(:) + real(r8), pointer :: TWS(:) + + ! Pointer declarations + call assign_pointers() + + ! set averaging factor to zero + averaging_var = 0 + + ! Initialize increments + call initialize_increments() + + select case (state_setup) + case(0) ! all compartments in state vector + call update_state_0() + case(1) ! TWS in state vector + call update_state_1() + case(2) ! snow and soil moisture aggregated over surface, root zone and deep soil moisture in state vector + call update_state_2() + end select + + call finalize_increments() + + contains + + subroutine assign_pointers() + + liq => waterstate_inst%h2osoi_liq_col + ice => waterstate_inst%h2osoi_ice_col + swc => waterstate_inst%h2osoi_vol_col + dz => col%dz + zi => col%zi + z => col%z + watsat => soilstate_inst%watsat_col + snow => waterstate_inst%h2osno_col + snow_depth => waterstate_inst%snow_depth_col + snl => col%snl + + select case (TWS_smoother) + case(0) + liq_mean => waterstate_inst%h2osoi_liq_col + ice_mean => waterstate_inst%h2osoi_ice_col + snow_mean => waterstate_inst%h2osno_col + case default + liq_mean => waterstate_inst%h2osoi_liq_col_mean + ice_mean => waterstate_inst%h2osoi_ice_col_mean + snow_mean => waterstate_inst%h2osno_col_mean + end select + + liq_inc => waterstate_inst%h2osoi_liq_col_inc + ice_inc => waterstate_inst%h2osoi_ice_col_inc + snow_inc => waterstate_inst%h2osno_col_inc + + TWS => waterstate_inst%tws_hactive + + end subroutine assign_pointers + + subroutine initialize_increments() + integer :: j, count, c + ! set increment values for inc output file to old values, then they can be updated with new values + liq_inc(:,:) = 0.0 + ice_inc(:,:) = 0.0 + snow_inc(:) = 0.0 + do j = 1,nlevsoi + do count = 1,num_layer_columns(j) + c = hactivec_levels(count,j) + + liq_inc(c,j) = liq(c,j) + ice_inc(c,j) = ice(c,j) + + if (j==1) then + snow_inc(c) = snow(c) + end if + end do + end do + end subroutine initialize_increments + + subroutine finalize_increments() + integer :: j, count, c + do j = 1,nlevsoi + do count = 1,num_layer_columns(j) + c = hactivec_levels(count,j) + + liq_inc(c,j) = liq(c,j)-liq_inc(c,j) + ice_inc(c,j) = ice(c,j)-ice_inc(c,j) + + if (j==1) then + snow_inc(c) = snow(c)-snow_inc(c) + end if + end do + end do + end subroutine finalize_increments + + + + + subroutine update_state_0() + real(r8) :: inc + integer :: c, j, count, g, cc, count_c + + ! Update soil + cc = 1 + do j = 1,nlevsoi + do count = 1, num_layer(j) + g = hactiveg_levels(count,j) + inc = clm_statevec(cc)-clm_statevec_orig(cc) + + if (abs(inc)>1.e-10_r8) then + do count_c = 1, num_layer_columns(j) + c = hactivec_levels(count_c,j) + if (col%gridcell(c)==g) then + + call update_soil_layer(c, j, inc, liq_mean(c,j), ice_mean(c,j), clm_statevec_orig(cc)) + + end if + end do + end if + cc = cc+1 + end do + end do + + ! update snow + cc = 1 + do count = 1, num_layer(1) + g = hactiveg_levels(count,1) + inc = clm_statevec(cc+sum(clm_varsize_tws(1:2))) - clm_statevec_orig(cc+sum(clm_varsize_tws(1:2))) + if (abs(inc)>1.e-10_r8) then + do count_c = 1, num_layer_columns(1) + c = hactivec_levels(count_c,1) + if (col%gridcell(c)==g) then + + if (snl(c) < 0) then + call scale_snow(c, inc*snow_mean(c)/clm_statevec_orig(cc+sum(clm_varsize_tws(1:2)))) + end if + + if (snow(c) < 0._r8) then ! close snow layers if snow is negative + call zero_snow_layers(c) + end if + + end if + end do + end if + cc = cc+1 + end do + + end subroutine update_state_0 + + + + subroutine update_state_1() + real(r8) :: inc + integer :: c, j, count, g, cc, count_c + + cc = 1 + + do count = 1, num_layer(1) + g = hactiveg_levels(count,1) + inc = clm_statevec(cc)-clm_statevec_orig(cc) + + if (abs(inc)>1.e-10_r8) then + ! update soil water + do j = 1,nlevsoi + + do count_c = 1,num_layer_columns(j) + c = hactivec_levels(count_c,j) + if (col%gridcell(c)==g) then + call update_soil_layer(c, j, inc, liq_mean(c,j), ice_mean(c,j), clm_statevec_orig(cc)) + end if + end do + + end do + + ! update snow + + do count_c = 1,num_layer_columns(1) + c = hactivec_levels(count_c,1) + if (col%gridcell(c)==g) then + if (snl(c) < 0) then ! snow layers in the column + call scale_snow(c, inc*snow_mean(c)/clm_statevec_orig(cc)) + end if + if (snow(c) < 0._r8) then ! close snow layers if snow is negative + call zero_snow_layers(c) + end if + end if + end do + end if + + cc = cc+1 - if(swc(j,i)==0.0) then - swc_zero_before_update = .true. + end do - ! Zero-SWC leads to zero denominator in computation of - ! rliq/rice, therefore setting rliq/rice to special - ! value - rliq = spval - rice = spval - else - swc_zero_before_update = .false. + end subroutine update_state_1 - rliq = h2osoi_liq(j,i)/(dz(j,i)*denh2o*swc(j,i)) - rice = h2osoi_ice(j,i)/(dz(j,i)*denice*swc(j,i)) - !h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) - end if - if (clmstatevec_colmean==1) then - ! If there is no significant increment, do not - ! implement any update / check. - ! - ! Note: Computing the absolute difference here, - ! because the whole state vector should be soil - ! moistures. For variables with very small values in - ! the state vector, this would have to be adapted - ! (e.g. to relative difference). - if( abs(clm_statevec(state_clm2pdaf_p(j,i)) - clm_statevec_orig(state_clm2pdaf_p(j,i))) <= 1.0e-7) then - cycle - end if + subroutine update_state_2() + real(r8) :: inc + integer :: c, j, count, g, cc, count_c - ! Update SWC column value with the increment-factor - ! of the state vector update (state vector updates - ! are means of cols in grc) - swc_update = swc(j,i) * clm_statevec(state_clm2pdaf_p(j,i)) / clm_statevec_orig(state_clm2pdaf_p(j,i)) - else - ! Update SWC with updated state vector - swc_update = clm_statevec(state_clm2pdaf_p(j,i)) - end if + ! surface soil moisture + cc = 1 + do count = 1, num_layer(1) + g = hactiveg_levels(count,1) + inc = clm_statevec(cc)-clm_statevec_orig(cc) + if (abs(inc)>1.e-10_r8) then + do j = 1,3 + do count_c = 1,num_layer_columns(j) + c = hactivec_levels(count_c,j) + if (col%gridcell(c)==g) then - if(swc_update<=watmin_check) then - swc(j,i) = watmin_set - else if(swc_update>=watsat(j,i)) then - swc(j,i) = watsat(j,i) - else - swc(j,i) = swc_update - endif + call update_soil_layer(c, j, inc, liq_mean(c,j), ice_mean(c,j), clm_statevec_orig(cc)) - if (isnan(swc(j,i))) then - swc(j,i) = watmin_set - print *, "WARNING: swc at j,i is nan: ", j, i - endif + end if + end do + end do + end if + cc = cc+1 + end do - if(swc_zero_before_update) then - ! This case should not appear for hydrologically - ! active columns/layers, where always: swc > watmin - ! - ! If you want to make sure that no zero SWCs appear in - ! the code, comment out the error stop + ! root zone soil moisture + cc = 1 + do count = 1, num_layer(4) + g = hactiveg_levels(count,4) + inc = clm_statevec(cc+clm_varsize_tws(1))-clm_statevec_orig(cc+clm_varsize_tws(1)) + if (abs(inc)>1.e-10_r8) then + do j = 4,12 + do count_c = 1,num_layer_columns(j) + c = hactivec_levels(count_c,j) + if (col%gridcell(c)==g) then -#ifdef PDAF_DEBUG - ! error stop "ERROR: Update of zero-swc" - print *, "WARNING: Update of zero-swc" - print *, "WARNING: Any new H2O added to h2osoi_liq(j,i) with j,i = ", j, i -#endif - h2osoi_liq(j,i) = swc(j,i) * dz(j,i)*denh2o - h2osoi_ice(j,i) = 0.0 - else - ! update liquid water content - h2osoi_liq(j,i) = swc(j,i) * dz(j,i)*denh2o*rliq - ! update ice content - h2osoi_ice(j,i) = swc(j,i) * dz(j,i)*denice*rice - end if + call update_soil_layer(c, j, inc, liq_mean(c,j), ice_mean(c,j), clm_statevec_orig(cc+clm_varsize_tws(1))) end if + end do + end do + end if + cc = cc+1 + end do + + ! deep soil moisture + cc = 1 + do count = 1, num_layer(13) + g = hactiveg_levels(count,13) + inc = clm_statevec(cc+sum(clm_varsize_tws(1:2)))-clm_statevec_orig(cc+sum(clm_varsize_tws(1:2))) + if (abs(inc)>1.e-10_r8) then + do j = 13,nlevsoi + do count_c = 1,num_layer_columns(j) + c = hactivec_levels(count_c,j) + if (col%gridcell(c)==g) then + + call update_soil_layer(c, j, inc, liq_mean(c,j), ice_mean(c,j), clm_statevec_orig(cc+sum(clm_varsize_tws(1:2)))) + end if - ! cc = cc + 1 end do - end do + end do + end if + cc = cc+1 + end do -#ifdef PDAF_DEBUG - IF(clmt_printensemble == tstartcycle .OR. clmt_printensemble < 0) THEN + ! update snow + cc = 1 + do count = 1, num_layer(1) + g = hactiveg_levels(count,1) + inc = clm_statevec(cc+sum(clm_varsize_tws(1:3))) - clm_statevec_orig(cc+sum(clm_varsize_tws(1:3))) + if (abs(inc)>1.e-10_r8) then + do count_c = 1, num_layer_columns(1) + c = hactivec_levels(count_c,1) + if (col%gridcell(c)==g) then + + if (snl(c) < 0) then + call scale_snow(c, inc*snow_mean(c)/clm_statevec_orig(cc+sum(clm_varsize_tws(1:3)))) + end if - IF(clmupdate_swc/=0) THEN - ! TSMP-PDAF: For debug runs, output the state vector in files - WRITE(fn3, "(a,i5.5,a,i5.5,a)") "h2osoi_liq", mype, ".update.", tstartcycle, ".txt" - OPEN(unit=71, file=fn3, action="write") - WRITE (71,"(es22.15)") h2osoi_liq(:,:) - CLOSE(71) + if (snow(c) < 0._r8) then ! close snow layers if snow is negative + call zero_snow_layers(c) + end if - ! TSMP-PDAF: For debug runs, output the state vector in files - WRITE(fn4, "(a,i5.5,a,i5.5,a)") "h2osoi_ice", mype, ".update.", tstartcycle, ".txt" - OPEN(unit=71, file=fn4, action="write") - WRITE (71,"(es22.15)") h2osoi_ice(:,:) - CLOSE(71) + end if + end do + end if + cc = cc+1 + end do - ! TSMP-PDAF: For debug runs, output the state vector in files - WRITE(fn2, "(a,i5.5,a,i5.5,a)") "swcstate_", mype, ".update.", tstartcycle, ".txt" - OPEN(unit=71, file=fn2, action="write") - WRITE (71,"(es22.15)") swc(:,:) - CLOSE(71) - END IF + end subroutine update_state_2 - END IF -#endif - endif - !hcp: TG, TV - if(clmupdate_T==1) then - error stop "Not implemented: clmupdate_T.eq.1" - endif - ! end hcp TG, TV + subroutine update_soil_layer(c, j, inc, liq_mean_cj, ice_mean_cj, vec_orig) + real(r8), intent(in) :: inc, liq_mean_cj, ice_mean_cj, vec_orig + integer, intent(in) :: c, j + real(r8) :: inc_col, var_temp - !! update liquid water content - !do j=clm_begg,clm_endg - ! do i=1,nlevsoi - ! h2osoi_liq(j,i) = swc(j,i) * dz(j,i)*denh2o - ! end do - !end do + inc_col = inc * liq_mean_cj / vec_orig + if (inc_col /= inc_col) inc_col = 0.0_r8 + if (abs(inc_col) > max_inc * liq(c,j)) inc_col = sign(max_inc * liq(c,j), inc_col) + liq(c,j) = max(watmin, liq(c,j) + inc_col) - ! write updated texture back to CLM - if(clmupdate_texture/=0) then - cc = 1 - do i=1,nlevsoi - do j=clm_begg,clm_endg - psand(j,i) = clm_statevec(cc+1*clm_varsize+offset) - pclay(j,i) = clm_statevec(cc+2*clm_varsize+offset) - if(clmupdate_texture==2) then - ! incl. organic matter - porgm(j,i) = clm_statevec(cc+3*clm_varsize+offset) + inc_col = inc * ice_mean_cj / vec_orig + if (inc_col /= inc_col) inc_col = 0.0_r8 + if (abs(inc_col) > max_inc * ice(c,j)) inc_col = sign(max_inc * ice(c,j), inc_col) + ice(c,j) = max(0._r8, ice(c,j) + inc_col) + + swc(c,j) = liq(c,j)/(dz(c,j)*denh2o) + ice(c,j)/(dz(c,j)*denice) + + if (j > 1 .and. swc(c,j) - watsat(c,j) > 0.00001_r8) then + var_temp = watsat(c,j) / swc(c,j) + liq(c,j) = max(watmin, liq(c,j) * var_temp) + ice(c,j) = max(0._r8, watsat(c,j)*dz(c,j)*denice - liq(c,j)*denice/denh2o) + swc(c,j) = watsat(c,j) + if (abs(ice(c,j)) < 1.e-10_r8) ice(c,j) = 0._r8 + end if + end subroutine update_soil_layer + + + subroutine scale_snow(c, inc) + integer, intent(in) :: c + real(r8), intent(in) :: inc + real(r8) :: scale, inc_col + integer :: j + + inc_col=inc + if (inc_col /= inc_col) inc_col = 0.0 + + if (abs(inc_col)>max_inc*snow(c)) inc_col = sign(max_inc*snow(c),inc_col) + inc_col = snow(c) + inc_col + scale = inc_col / snow(c) + snow(c) = inc_col + do j = 0, snl(c)+1, -1 + liq(c,j) = liq(c,j)*scale + ice(c,j) = ice(c,j)*scale + dz(c,j) = dz(c,j)*scale + zi(c,j) = zi(c,j)*scale + z(c,j) = z(c,j)*scale + end do + + zi(c,snl(c)) = zi(c,snl(c))*scale + snow_depth(c) = snow_depth(c)*scale + end subroutine scale_snow + + + subroutine zero_snow_layers(c) + integer, intent(in) :: c + integer :: j + + if (snl(c) < 0) then + do j = 0, snl(c)+1, -1 + liq(c,j) = 0.0_r8 + ice(c,j) = 1.e-8_r8 + dz(c,j) = 1.e-8_r8 + zi(c,j-1) = sum(dz(c,j:0)) * -1._r8 + if (j == 0) then + z(c,j) = zi(c,j-1) / 2._r8 + else + z(c,j) = sum(zi(c,j-1:j)) / 2._r8 end if - cc = cc + 1 end do - end do - call clm_correct_texture - call clm_texture_to_parameters - endif + else + liq(c,0) = 0.0_r8 + ice(c,0) = 1.e-8_r8 + dz(c,0) = 1.e-8_r8 + zi(c,-1) = dz(c,0) * -1._r8 + z(c,0) = zi(c,-1) / 2._r8 + end if - end subroutine update_clm + snow_depth(c) = sum(dz(c,-nlevsno+1:0)) + snow(c) = sum(ice(c,-nlevsno+1:0)) + end subroutine zero_snow_layers + + end subroutine clm_update_tws subroutine clm_correct_texture() @@ -1144,7 +2195,7 @@ subroutine get_interp_idx(lon_clmobs, lat_clmobs, dim_obs, longxy_obs_floor, lat end subroutine get_interp_idx #if defined CLMSA - !> @author Johannes Keller + !> @author Johannes Keller, adaptations by Yorck Ewerdwalbesloh !> @date 24.04.2025 !> @brief Set number of local analysis domains N_DOMAINS_P !> @details @@ -1154,6 +2205,7 @@ subroutine init_n_domains_clm(n_domains_p) use decompMod, only : get_proc_bounds use clm_varcon , only : ispval use ColumnType , only : col + use GridcellType , only : grc implicit none @@ -1166,6 +2218,12 @@ subroutine init_n_domains_clm(n_domains_p) integer :: c integer :: cc + real(r8), pointer :: lon(:) + real(r8), pointer :: lat(:) + + lon => grc%londeg + lat => grc%latdeg + ! TODO: remove unnecessary calls of get_proc_bounds (use clm_begg, ! clm_endg, etc) call get_proc_bounds(begg=begg, endg=endg, begc=begc, endc=endc) @@ -1180,12 +2238,14 @@ subroutine init_n_domains_clm(n_domains_p) ! -> DIM_L: number of layers in gridcell n_domains_p = endg - begg + 1 end if - else + elseif (clmupdate_tws/=1) then ! Process-local number of gridcells Default, possibly not tested ! for other updates except SWC n_domains_p = endg - begg + 1 end if + NOGRACE: if (clmupdate_tws/=1) then + ! If only_active: Use clm2pdaf to check which columsn/gridcells ! are inside. Possibly: number of columns/gridcells reduced by ! hydrologically inactive columns/gridcells. @@ -1268,6 +2328,12 @@ subroutine init_n_domains_clm(n_domains_p) ! Possibly: Warning when final n_domains_p actually excludes ! hydrologically inactive gridcells + else NOGRACE + + n_domains_p = num_hactiveg + + end if NOGRACE + end subroutine init_n_domains_clm @@ -1286,6 +2352,8 @@ subroutine init_dim_l_clm(domain_p, dim_l) integer, intent(out) :: dim_l integer :: nshift + integer :: g, i, count + if(clmupdate_swc==1) then if(clmstatevec_only_active == 1) then ! Compare nlevsoi to clmstatevec_max_layer and bedrock if @@ -1312,6 +2380,49 @@ subroutine init_dim_l_clm(domain_p, dim_l) dim_l = 3*nlevsoi + nshift endif + if (clmupdate_tws==1) then + dim_l = 0 + g = hactiveg_levels(domain_p,1) + + select case(state_setup) + case(0) ! subdivided setup + do i = 1,nlevsoi + do count = 1, num_layer(i) + if (g==hactiveg_levels(count,i)) then + dim_l = dim_l+1 ! I could also check with col%nbedrock but then I would need the column index and not the gridcell index + end if + end do + end do + + ! snow and surface water + dim_l = dim_l+2 + + if (clm_varsize_tws(5)/=0) then + dim_l = dim_l+1 + end if + + case(1) ! only TWS in statevector + + dim_l=1 + + case(2) ! aggregated setup + + dim_l=2 + + do count = 1, num_layer(4) + if (g==hactiveg_levels(count,4)) then + dim_l = dim_l+1 + end if + end do + + do count = 1, num_layer(13) + if (g==hactiveg_levels(count,13)) then + dim_l = dim_l+1 + end if + end do + end select + endif + end subroutine init_dim_l_clm !> @author Wolfgang Kurtz, Johannes Keller @@ -1323,6 +2434,8 @@ end subroutine init_dim_l_clm !> Source is STATE_P, the global (PE-local) state vector. subroutine g2l_state_clm(domain_p, dim_p, state_p, dim_l, state_l) + use ColumnType , only : col + implicit none INTEGER, INTENT(in) :: domain_p ! Current local analysis domain @@ -1335,19 +2448,96 @@ subroutine g2l_state_clm(domain_p, dim_p, state_p, dim_l, state_l) INTEGER :: n_domain INTEGER :: nshift_p + integer :: sub, g, j + ! call init_n_domains_clm(n_domain) ! DO i = 0, dim_l-1 ! nshift_p = domain_p + i * n_domain ! state_l(i+1) = state_p(nshift_p) ! ENDDO - + NOGRACE: if (clmupdate_tws/=1) then ! Column index inside gridcell index domain_p DO i = 1, dim_l ! Column index from DOMAIN_P via STATE_LOC2CLM_C_P ! Layer index: i state_l(i) = state_p(state_clm2pdaf_p(state_loc2clm_c_p(domain_p),i)) END DO + else NOGRACE + + if (clm_varsize_tws(5)/=0) then + sub=3 + else + sub=2 + end if + + select case (state_setup) + case(0) ! all compartmens in state vector + g = hactiveg_levels(domain_p,1) + do i = 1, dim_l-sub + do j = 1, num_layer(i) + if (g==hactiveg_levels(j,i)) then + if (i == 1) then + state_l(i) = state_p(j) + else + state_l(i) = state_p(j + sum(num_layer(1:i-1))) + end if + end if + end do + end do + + do j = 1, num_layer(1) + if (g==hactiveg_levels(j,1)) then + if (sub==3) then + state_l(dim_l-2) = state_p(j + sum(clm_varsize_tws(1:2))) + state_l(dim_l-1) = state_p(j + sum(clm_varsize_tws(1:3))) + state_l(dim_l) = state_p(j + sum(clm_varsize_tws(1:4))) + else + state_l(dim_l-1) = state_p(j + sum(clm_varsize_tws(1:2))) + state_l(dim_l) = state_p(j + sum(clm_varsize_tws(1:3))) + end if + end if + end do + + case(1) ! only TWS in statevector + + g = hactiveg_levels(domain_p,1) + do j = 1, num_layer(1) + if (g==hactiveg_levels(j,1)) then + state_l(1) = state_p(j) + end if + end do + + case(2) ! ! snow and soil moisture aggregated over surface, root zone and deep soil moisture in state vector + + g = hactiveg_levels(domain_p,1) + + do j = 1, num_layer(1) + if (g==hactiveg_levels(j,1)) then + state_l(1) = state_p(j) ! surface SM + state_l(dim_l) = state_p(j + sum(clm_varsize_tws(1:3))) ! snow, same indexing as clm_varsize_tws(2:3) = 0 when only surface layers present + end if + end do + + if (dim_l>=3) then + do j = 1, num_layer(4) + if (g==hactiveg_levels(j,4)) then + state_l(2) = state_p(j + clm_varsize_tws(1)) ! root zone SM + end if + end do + end if + + if (dim_l>=4) then + do j = 1, num_layer(13) + if (g==hactiveg_levels(j,13)) then + state_l(3) = state_p(j + sum(clm_varsize_tws(1:2))) ! deep SM + end if + end do + end if + + end select + + end if NOGRACE end subroutine g2l_state_clm @@ -1360,6 +2550,8 @@ end subroutine g2l_state_clm !> Source is STATE_L, the local vector. subroutine l2g_state_clm(domain_p, dim_l, state_l, dim_p, state_p) + use ColumnType , only : col + implicit none INTEGER, INTENT(in) :: domain_p ! Current local analysis domain @@ -1372,6 +2564,8 @@ subroutine l2g_state_clm(domain_p, dim_l, state_l, dim_p, state_p) INTEGER :: n_domain INTEGER :: nshift_p + integer :: sub, j, g + ! ! beg and end gridcell for atm ! call init_n_domains_clm(n_domain) @@ -1379,13 +2573,92 @@ subroutine l2g_state_clm(domain_p, dim_l, state_l, dim_p, state_p) ! nshift_p = domain_p + i * n_domain ! state_p(nshift_p) = state_l(i+1) ! ENDDO - + NOGRACE: if (clmupdate_tws==0) then ! Column index inside gridcell index domain_p DO i = 1, dim_l ! Column index from DOMAIN_P via STATE_LOC2CLM_C_P ! Layer index i state_p(state_clm2pdaf_p(state_loc2clm_c_p(domain_p),i)) = state_l(i) END DO + else NOGRACE + + if (clm_varsize_tws(5)/=0) then + sub=3 + else + sub=2 + end if + + select case (state_setup) + case(0) ! all compartments in state vector + g = hactiveg_levels(domain_p,1) + do i = 1, dim_l-sub + do j = 1, num_layer(i) ! i is the layer that we are in right now + if (g==hactiveg_levels(j,i)) then ! if the counter is the gridcell of the local domain, we know the position in the statevector + if (i == 1) then ! if first layer + state_p(j) = state_l(i) ! first liquid water as it is first in the statevector + else + state_p(j + sum(num_layer(1:i-1))) = state_l(i) + end if + end if + end do + end do + + do j = 1, num_layer(1) + if (g==hactiveg_levels(j,1)) then + + if (sub==3) then + state_p(j + sum(clm_varsize_tws(1:2))) = state_l(dim_l-2) + state_p(j + sum(clm_varsize_tws(1:3))) = state_l(dim_l-1) + state_p(j + sum(clm_varsize_tws(1:4))) = state_l(dim_l) + else + state_p(j + sum(clm_varsize_tws(1:2))) = state_l(dim_l-1) + state_p(j + sum(clm_varsize_tws(1:3))) = state_l(dim_l) + end if + + end if + end do + + case(1) ! TWS in statevector + + g = hactiveg_levels(domain_p,1) + do j = 1, num_layer(1) + if (g==hactiveg_levels(j,1)) then + state_p(j) = state_l(1) + end if + end do + + case(2) ! snow and soil moisture aggregated over surface, root zone and deep soil moisture in state vector + + g = hactiveg_levels(domain_p,1) + + do j = 1, num_layer(1) + if (g==hactiveg_levels(j,1)) then + + state_p(j) = state_l(1) + state_p(j + sum(clm_varsize_tws(1:3))) = state_l(dim_l) + + end if + end do + + do j = 1, num_layer(4) + if (g==hactiveg_levels(j,4)) then + + state_p(j + clm_varsize_tws(1)) = state_l(2) + + end if + end do + + do j = 1, num_layer(13) + if (g==hactiveg_levels(j,13)) then + + state_p(j + sum(clm_varsize_tws(1:2))) = state_l(3) + + end if + end do + + end select + + endif NOGRACE end subroutine l2g_state_clm #endif diff --git a/interface/model/eclm/print_update_clm_5.F90 b/interface/model/eclm/print_update_clm_5.F90 index 09dbc6810..c0bae0638 100644 --- a/interface/model/eclm/print_update_clm_5.F90 +++ b/interface/model/eclm/print_update_clm_5.F90 @@ -219,6 +219,282 @@ subroutine print_update_clm(ts,ttot) bind(C,name="print_update_clm") ! deallocate(clmstate_tmp_local) end subroutine print_update_clm + +subroutine print_inc_clm() bind(C,name="print_inc_clm") + + use iso_c_binding + use shr_kind_mod , only : r8 => shr_kind_r8 + use domainMod , only : ldomain + use clm_varpar , only : nlevsoi + use clm_varcon , only : nameg, spval + use decompmod , only : get_proc_global, get_proc_bounds, ldecomp, get_proc_total + use spmdmod , only : masterproc, npes, mpicom, iam + use clm_time_manager , only : get_nstep + use clm_instMod, only : soilhydrology_inst, waterstate_inst, atm2lnd_inst + use netcdf + use cime_comp_mod + use ColumnType , only : col + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use mpi + + implicit none + + ! local variables + + integer :: numg ! total number of gridcells across all processors + integer :: numl ! total number of landunits across all processors + integer :: numc ! total number of columns across all processors + integer :: nump ! total number of pfts across all processors + integer :: begg,endg ! local beg/end gridcells gdc + integer :: begl,endl ! local beg/end landunits + integer :: begc,endc ! local beg/end columns + integer :: begp,endp ! local beg/end pfts + integer :: ncells ! total number of gridcells on the processor + integer :: nlunits ! total number of landunits on the processor + integer :: ncols ! total number of columns on the processor + integer :: npfts ! total number of pfts on the processor + integer :: ncohorts + + integer :: isec, info, jn, jj, ji, g1, jx, c, l, j, g, index, p, count, count2 ! temporary integer + real(r8), pointer :: h2osoi_liq(:,:) + real(r8), pointer :: h2osoi_ice(:,:) + real(r8), pointer :: h2osno(:) + real(r8), pointer :: clmstate_tmp_local(:,:) + real(r8), pointer :: clmstate_tmp_global(:) + real(r8), allocatable :: clmstate_out(:,:,:) + integer ,dimension(3) :: dimids + integer ,dimension(2) :: dimids_1level + integer ,dimension(1) :: il_var_id + integer :: il_file_id, ncvarid(4), status + character(len = 300) :: inc_filename + integer :: nerror + integer :: ndlon,ndlat + + integer :: ier !return code + integer :: beg !temporary + integer :: numrecvv(0:npes-1) !vector of items to be received + integer :: displsv(0:npes-1) !displacement vector + integer :: numsend !number of items to be sent + integer :: pid ! processor id + integer :: count_columns + real(r8) :: sum_columns + real(r8), allocatable :: tws_inc(:) + + h2osoi_liq => waterstate_inst%h2osoi_liq_col_inc + h2osoi_ice => waterstate_inst%h2osoi_ice_col_inc + h2osno => waterstate_inst%h2osno_col_inc + + call get_proc_global(ng=numg,nl=numl,nc=numc,np=nump) + call get_proc_bounds(begg,endg,begl,endl,begc,endc,begp,endp) + allocate(clmstate_tmp_local(begg:endg,1:nlevsoi), stat=nerror) + allocate(tws_inc(begg:endg), stat=nerror) + tws_inc(begg:endg) = 0._r8 + + ndlon = ldomain%ni + ndlat = ldomain%nj + + if (masterproc) then + + allocate(clmstate_tmp_global(1:numg), stat=nerror) + allocate(clmstate_out(ndlon,ndlat,nlevsoi), stat=nerror) + clmstate_out(:,:,:) = nan + + end if + + call get_proc_total(iam, ncells, nlunits, ncols, npfts, ncohorts) + + numsend = ncells + + do pid = 0,npes-1 + call get_proc_total(pid, ncells, nlunits, ncols, npfts, ncohorts) + numrecvv(pid) = ncells + end do + beg = begg + displsv(0) = 0 + do pid = 1,npes-1 + displsv(pid) = displsv(pid-1) + numrecvv(pid-1) + end do + + if(masterproc) then + call get_inc_filename(inc_filename) + status = nf90_create(inc_filename, NF90_CLOBBER, il_file_id) + status = nf90_def_dim(il_file_id, "lon", ndlon, dimids(1)) + status = nf90_def_dim(il_file_id, "lat", ndlat, dimids(2)) + status = nf90_def_dim(il_file_id, "z", nlevsoi, dimids(3)) + + dimids_1level = [ dimids(1), dimids(2) ] + status = nf90_def_var(il_file_id, "SOILLIQ", NF90_FLOAT, dimids, ncvarid(1)) + status = nf90_def_var(il_file_id, "SOILICE", NF90_FLOAT, dimids, ncvarid(2)) + status = nf90_def_var(il_file_id, "H2OSNO", NF90_FLOAT, dimids_1level, ncvarid(3)) + status = nf90_def_var(il_file_id, "TWS", NF90_FLOAT, dimids_1level, ncvarid(3)) + status = nf90_enddef(il_file_id) + end if + + clmstate_tmp_local(begg:endg,:) = 0._r8 + + do j = 1, nlevsoi + do g = begg,endg + count_columns = 0 + sum_columns = 0 + do c=begc,endc + if (g==col%gridcell(c) .and. col%hydrologically_active(c).and.j<=col%nbedrock(c)) then + sum_columns = sum_columns+h2osoi_liq(c,j) + count_columns = count_columns+1 + end if + end do + if (count_columns == 0) then + !clmstate_tmp_local(g,j) = spval + else + clmstate_tmp_local(g,j) = sum_columns/count_columns + end if + if (j==1) then + tws_inc(g) = clmstate_tmp_local(g,j) + else + if (clmstate_tmp_local(g,j) /= spval) then + tws_inc(g) = tws_inc(g) + clmstate_tmp_local(g,j) + end if + end if + end do + end do + do jn = 1, nlevsoi + if (masterproc) then + call mpi_gatherv (clmstate_tmp_local(beg,jn), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (clmstate_tmp_local(beg,jn), numsend , MPI_REAL8, 0._r8, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + end if + if(masterproc) then + do g1 = 1, numg + ji = mod(ldecomp%gdc2glo(g1)-1,ldomain%ni) + 1 + jj = (ldecomp%gdc2glo(g1) - 1)/ldomain%ni + 1 + clmstate_out(ji,jj,jn) = clmstate_tmp_global(g1) + end do + end if + end do + if (masterproc) then + status = nf90_inq_varid(il_file_id, "SOILLIQ" , ncvarid(1)) + status = nf90_put_var( il_file_id, ncvarid(1), clmstate_out(:,:,:), & + start = [ 1, 1, 1 ], count = [ ndlon, ndlat, nlevsoi ] ) + end if + + + clmstate_tmp_local(begg:endg,:) = 0._r8 + + do j = 1, nlevsoi + do g=begg,endg + count_columns = 0 + sum_columns = 0 + do c=begc,endc + if (g==col%gridcell(c).and.col%hydrologically_active(c).and.j<=col%nbedrock(c)) then + sum_columns = sum_columns+h2osoi_ice(c,j) + count_columns = count_columns+1 + end if + end do + if (count_columns == 0) then + !clmstate_tmp_local(g,j) = spval + else + clmstate_tmp_local(g,j) = sum_columns/count_columns + end if + if (clmstate_tmp_local(g,j) /= spval) then + tws_inc(g) = tws_inc(g) + clmstate_tmp_local(g,j) + end if + end do + end do + do jn = 1, nlevsoi + if (masterproc) then + call mpi_gatherv (clmstate_tmp_local(beg,jn), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (clmstate_tmp_local(beg,jn), numsend , MPI_REAL8, 0._r8, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + end if + if(masterproc) then + do g1 = 1, numg + ji = mod(ldecomp%gdc2glo(g1)-1,ldomain%ni) + 1 + jj = (ldecomp%gdc2glo(g1) - 1)/ldomain%ni + 1 + clmstate_out(ji,jj,jn) = clmstate_tmp_global(g1) + end do + end if + end do + if (masterproc) then + status = nf90_inq_varid(il_file_id, "SOILICE" , ncvarid(2)) + status = nf90_put_var( il_file_id, ncvarid(2), clmstate_out(:,:,:), & + start = [ 1, 1, 1 ], count = [ ndlon, ndlat, nlevsoi ] ) + end if + + + + + clmstate_tmp_local(begg:endg,:) = 0._r8 + do g=begg,endg + count_columns = 0 + sum_columns = 0 + do c=begc,endc + if (g==col%gridcell(c).and.col%hydrologically_active(c)) then + sum_columns = sum_columns+h2osno(c) + count_columns = count_columns+1 + end if + end do + if (count_columns == 0) then + !clmstate_tmp_local(g,1) = spval + else + clmstate_tmp_local(g,1) = sum_columns/count_columns + tws_inc(g) = tws_inc(g) + clmstate_tmp_local(g,1) + end if + end do + + + if (masterproc) then + call mpi_gatherv (clmstate_tmp_local(beg,1), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (clmstate_tmp_local(beg,1), numsend , MPI_REAL8, 0._r8, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + end if + if(masterproc) then + do g1 = 1, numg + ji = mod(ldecomp%gdc2glo(g1)-1,ldomain%ni) + 1 + jj = (ldecomp%gdc2glo(g1) - 1)/ldomain%ni + 1 + clmstate_out(ji,jj,1) = clmstate_tmp_global(g1) + end do + + end if + if (masterproc) then + status = nf90_inq_varid(il_file_id, "H2OSNO" , ncvarid(3)) + status = nf90_put_var( il_file_id, ncvarid(3), clmstate_out(:,:,1), & + start = [ 1, 1 ], count = [ ndlon, ndlat ] ) + end if + + + + if (masterproc) then + call mpi_gatherv (tws_inc(beg), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (tws_inc(beg), numsend , MPI_REAL8, 0._r8, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + end if + if(masterproc) then + do g1 = 1, numg + ji = mod(ldecomp%gdc2glo(g1)-1,ldomain%ni) + 1 + jj = (ldecomp%gdc2glo(g1) - 1)/ldomain%ni + 1 + clmstate_out(ji,jj,1) = clmstate_tmp_global(g1) + end do + end if + if (masterproc) then + status = nf90_inq_varid(il_file_id, "TWS" , ncvarid(4)) + status = nf90_put_var( il_file_id, ncvarid(4), clmstate_out(:,:,1), & + start = [ 1, 1 ], count = [ ndlon, ndlat ] ) + end if + + + + if(masterproc) then + status = nf90_close(il_file_id) + deallocate(clmstate_out) + deallocate(clmstate_tmp_global) + end if + deallocate(tws_inc) + deallocate(clmstate_tmp_local) + + + + + +end subroutine print_inc_clm #endif subroutine get_update_filename (iofile) @@ -243,3 +519,22 @@ subroutine get_update_filename (iofile) iofile = trim(caseid)//".update."//trim(cdate)//".nc" !iofile = trim(caseid)//".update.nc" end subroutine get_update_filename + +subroutine get_inc_filename (iofile) + use clm_varctl, only : caseid, inst_suffix + use clm_time_manager, only : get_curr_date, get_prev_date + ! !ARGUMENTS: + implicit none + character(len=300),intent(inout) :: iofile + ! LOCAL VARIABLES: + character(len=256) :: cdate !date char string + integer :: day !day (1 -> 31) + integer :: mon !month (1 -> 12) + integer :: yr !year (0 -> ...) + integer :: sec !seconds into current day + !----------------------------------------------------------------------- + call get_prev_date (yr, mon, day, sec) + write(cdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr,mon,day,sec + iofile = trim(caseid)//".inc"//trim(inst_suffix)//"."//trim(cdate)//".nc" + +end subroutine get_inc_filename diff --git a/interface/model/wrapper_tsmp.c b/interface/model/wrapper_tsmp.c index 56687e032..20118096f 100644 --- a/interface/model/wrapper_tsmp.c +++ b/interface/model/wrapper_tsmp.c @@ -198,10 +198,14 @@ void integrate_tsmp() { void update_tsmp(){ #if defined CLMSA - if((model == tag_model_clm) && ((clmupdate_swc != 0) || (clmupdate_T != 0))){ + if((model == tag_model_clm) && ((clmupdate_swc != 0) || (clmupdate_T != 0) || (clmupdate_tws != 0))){ update_clm(&tstartcycle, &mype_world); - if(clmprint_swc == 1 || clmupdate_texture == 1 || clmupdate_texture == 2){ - print_update_clm(&tcycle, &total_steps); + /* if(clmprint_swc == 1 || clmupdate_texture == 1 || clmupdate_texture == 2){ */ + /* print_update_clm(&tcycle, &total_steps); */ + /* } */ + /* TODO: enkfpf.par input switch "CLM:print_inc" */ + if ((clmupdate_tws != 0) || (clmupdate_swc != 0)){ + print_inc_clm(); } } #endif diff --git a/src/PDAFomi_obs_f.F90 b/src/PDAFomi_obs_f.F90 index a86eba2ab..1c86c9fbc 100644 --- a/src/PDAFomi_obs_f.F90 +++ b/src/PDAFomi_obs_f.F90 @@ -110,6 +110,7 @@ MODULE PDAFomi_obs_f INTEGER :: off_obs_f !< Offset of this observation in overall full obs. vector INTEGER :: off_obs_g !< Offset of this observation in overall global obs. vector INTEGER :: obsid !< Index of observation over all assimilated observations + INTEGER :: infile !< Yorck addition for mutliple observations REAL, ALLOCATABLE :: obs_f(:) !< Full observed field REAL, ALLOCATABLE :: ocoord_f(:,:) !< Coordinates of full observation vector REAL, ALLOCATABLE :: ivar_obs_f(:) !< Inverse variance of full observations From e8ef120de352aa7938f470a23c788d9784810569 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Fri, 24 Oct 2025 20:50:47 +0200 Subject: [PATCH 02/32] fortitude changes --- interface/framework/mod_read_obs.F90 | 19 ++++++++++++++++-- interface/model/eclm/enkf_clm_mod_5.F90 | 22 +++++++++++++++------ interface/model/eclm/print_update_clm_5.F90 | 19 ++++++++++++++---- 3 files changed, 48 insertions(+), 12 deletions(-) diff --git a/interface/framework/mod_read_obs.F90 b/interface/framework/mod_read_obs.F90 index d0128c8e8..02be3d32f 100755 --- a/interface/framework/mod_read_obs.F90 +++ b/interface/framework/mod_read_obs.F90 @@ -78,7 +78,14 @@ module mod_read_obs !> This subroutine reads the observation file and return the data subroutine read_obs_nc_type(current_observation_filename, current_observation_type, dim_obs_g, obs_g, lon_obs_g, lat_obs_g, layer_obs_g, dr_obs_g, obserr_g, obscov_g) - use netcdf + use netcdf, only: nf90_max_name + use netcdf, only: nf90_open + use netcdf, only: nf90_nowrite + use netcdf, only: nf90_inq_dimid + use netcdf, only: nf90_inquire_dimension + use netcdf, only: nf90_inq_varid + use netcdf, only: nf90_noerr + use netcdf, only: nf90_get_var use mod_assimilation, only: screen implicit none @@ -914,7 +921,15 @@ end subroutine check_n_observationfile_set_zero subroutine check_n_observationfile_next_type(fn, obs_type_str) - use netcdf + use netcdf, only: nf90_max_name + use netcdf, only: nf90_open + use netcdf, only: nf90_nowrite + use netcdf, only: nf90_inq_dimid + use netcdf, only: nf90_inquire_dimension + use netcdf, only: nf90_inq_varid + use netcdf, only: nf90_noerr + use netcdf, only: nf90_get_var + use netcdf, only: nf90_close use mod_assimilation, only: screen implicit none diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index 9e3d53aaf..a3140e50f 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -752,9 +752,11 @@ subroutine set_clm_statevec_swc() use shr_kind_mod, only: r8 => shr_kind_r8 implicit none real(r8), pointer :: swc(:,:) - integer :: j,g,cc=0,c + integer :: j,g,cc,c integer :: n_c + cc = 0 + swc => waterstate_inst%h2osoi_vol_col ! write swc values to state vector @@ -816,7 +818,7 @@ subroutine set_clm_statevec_tws() use GridcellType, only: grc implicit none - integer :: j,g,cc=0,count,c,count_c + integer :: j,g,cc,count,c,count_c integer :: n_c real(r8) :: avg_sum @@ -832,6 +834,8 @@ subroutine set_clm_statevec_tws() real(r8), pointer :: ice_state(:,:) real(r8), pointer :: snow_state(:) + cc = 0 + tws_state => waterstate_inst%tws_state_before liq_state => waterstate_inst%h2osoi_liq_state_before ice_state => waterstate_inst%h2osoi_ice_state_before @@ -1192,12 +1196,15 @@ subroutine update_swc(tstartcycle, mype) real(r8) :: watmin_set ! minimum soil moisture for setting swc (mm) real(r8) :: swc_update ! updated SWC in loop - integer :: i,j,cc=0 + integer :: i,j,cc character (len = 31) :: fn2 !TSMP-PDAF: function name for state vector outpu character (len = 32) :: fn3 !TSMP-PDAF: function name for state vector outpu character (len = 32) :: fn4 !TSMP-PDAF: function name for state vector outpu - logical :: swc_zero_before_update = .false. + logical :: swc_zero_before_update + + cc = 0 + swc_zero_before_update = .false. swc => waterstate_inst%h2osoi_vol_col watsat => soilstate_inst%watsat_col @@ -1333,7 +1340,7 @@ subroutine update_swc(tstartcycle, mype) #ifdef PDAF_DEBUG IF(clmt_printensemble == tstartcycle .OR. clmt_printensemble < 0) THEN - + ! TSMP-PDAF: For debug runs, output the state vector in files WRITE(fn3, "(a,i5.5,a,i5.5,a)") "h2osoi_liq", mype, ".update.", tstartcycle, ".txt" OPEN(unit=71, file=fn3, action="write") @@ -1382,12 +1389,15 @@ subroutine update_texture(tstartcycle, mype) integer,intent(in) :: tstartcycle integer,intent(in) :: mype - integer :: i,j,cc=0,offset=0 + integer :: i,j,cc,offset real(r8), pointer :: psand(:,:) real(r8), pointer :: pclay(:,:) real(r8), pointer :: porgm(:,:) + cc = 0 + offset = 0 + psand => soilstate_inst%cellsand_col pclay => soilstate_inst%cellclay_col porgm => soilstate_inst%cellorg_col diff --git a/interface/model/eclm/print_update_clm_5.F90 b/interface/model/eclm/print_update_clm_5.F90 index c0bae0638..1b794fbbc 100644 --- a/interface/model/eclm/print_update_clm_5.F90 +++ b/interface/model/eclm/print_update_clm_5.F90 @@ -222,7 +222,7 @@ end subroutine print_update_clm subroutine print_inc_clm() bind(C,name="print_inc_clm") - use iso_c_binding + ! use iso_c_binding use shr_kind_mod , only : r8 => shr_kind_r8 use domainMod , only : ldomain use clm_varpar , only : nlevsoi @@ -231,11 +231,22 @@ subroutine print_inc_clm() bind(C,name="print_inc_clm") use spmdmod , only : masterproc, npes, mpicom, iam use clm_time_manager , only : get_nstep use clm_instMod, only : soilhydrology_inst, waterstate_inst, atm2lnd_inst - use netcdf - use cime_comp_mod + use netcdf, only : nf90_create + use netcdf, only : NF90_CLOBBER + use netcdf, only : nf90_def_dim + use netcdf, only : nf90_def_var + use netcdf, only : NF90_FLOAT + use netcdf, only : nf90_enddef + use netcdf, only : nf90_open + use netcdf, only : NF90_WRITE + use netcdf, only : nf90_inq_varid + use netcdf, only : nf90_put_var + use netcdf, only : nf90_close + ! use cime_comp_mod use ColumnType , only : col use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use mpi + use mpi, only: mpi_gatherv + use mpi, only: mpi_real8 implicit none From 27c22a3dac3b1191988634f16177fdbd4db943b9 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Fri, 24 Oct 2025 21:05:19 +0200 Subject: [PATCH 03/32] README: PDAF-OMI --- README.md | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/README.md b/README.md index bf9145238..a27a50e76 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,17 @@ +# PDAF_omi + +PDAF-OMI for multivariate data assimiliaton. +It is design to handle different observation types (currently soil moisture and TWS) automatically. +Additional to current observation files, the observation type has to be included (SM, GRACE). + +See also create observation script for details: https://icg4geo.icg.kfa-juelich.de/ExternalRepos/tsmp-pdaf/tsmp-pdaf-observation-scripts/-/tree/main/omi_obs_data?ref_type=heads + +Both global and local filters can be used. To enable multi-scale data assimilation, different localization radii for different observation types can be passed. Note that the localization radius for SM is currently in km and for GRACE in #gridcells. + +The framework generates a state vector for each type individually before the assimilation, some things would need to be adapted when mutliple observation types are assimilated at the same timestep. Currently, one observation file only consists of one observation type. As SM observations are usually assimilated at noon and GRACE observations are assimilated at the end of the month at midnight, this should not provide any problems. + +If questions arise contact ewerdwalbesloh@geod.uni-bonn.de + # TSMP-PDAF: Pre-patched PDAF This fork of PDAF contains the PDAF changes ("patches") for using it From 85a3b04acbcbace80b46cb9deb1411875fc60f0f Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Mon, 27 Oct 2025 13:06:23 +0100 Subject: [PATCH 04/32] compilation fixes --- interface/model/eclm/enkf_clm_mod_5.F90 | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index a3140e50f..8a6b2df8d 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -160,7 +160,7 @@ subroutine define_clm_statevec(mype) ! soil water content observations - case 1 if(clmupdate_swc==1) then - call define_clm_statevec_swc + call define_clm_statevec_swc(mype) end if ! soil water content observations - case 2 @@ -185,7 +185,7 @@ subroutine define_clm_statevec(mype) ! TWS observations if (clmupdate_tws==1) then - call define_clm_statevec_tws + call define_clm_statevec_tws(mype) end if ! @@ -229,7 +229,7 @@ end subroutine define_clm_statevec - subroutine define_clm_statevec_swc() + subroutine define_clm_statevec_swc(mype) use decompMod , only : get_proc_bounds use clm_varpar , only : nlevsoi use clm_varcon , only : ispval @@ -421,7 +421,7 @@ subroutine define_clm_statevec_swc() end subroutine define_clm_statevec_swc - subroutine define_clm_statevec_tws() + subroutine define_clm_statevec_tws(mype) use shr_kind_mod, only: r8 => shr_kind_r8 use decompMod , only : get_proc_bounds use clm_varpar , only : nlevsoi @@ -431,6 +431,8 @@ subroutine define_clm_statevec_tws() implicit none + integer,intent(in) :: mype + integer :: i integer :: j integer :: c @@ -1092,6 +1094,7 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") real(r8), pointer :: h2osoi_ice(:,:) integer :: i + character (len = 31) :: fn !TSMP-PDAF: function name for state vector output character (len = 32) :: fn5 !TSMP-PDAF: function name for state vector outpu character (len = 32) :: fn6 !TSMP-PDAF: function name for state vector outpu From 25a29c7cb7de9426a1794c08cfa09af7761e9d87 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Mon, 27 Oct 2025 13:46:07 +0100 Subject: [PATCH 05/32] compilation fix --- interface/framework/mod_read_obs.F90 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/interface/framework/mod_read_obs.F90 b/interface/framework/mod_read_obs.F90 index 02be3d32f..f428e34fe 100755 --- a/interface/framework/mod_read_obs.F90 +++ b/interface/framework/mod_read_obs.F90 @@ -998,6 +998,13 @@ end subroutine update_obs_type subroutine domain_def_clm(lon_clmobs, lat_clmobs, dim_obs, & longxy, latixy, longxy_obs, latixy_obs) + use mpi, only: MPI_INTEGER + use mpi, only: MPI_DOUBLE_PRECISION + use mpi, only: MPI_IN_PLACE + use mpi, only: MPI_SUM + use mpi, only: MPI_2INTEGER + use mpi, only: MPI_MINLOC + use spmdMod, only : npes, iam use domainMod, only : ldomain, lon1d, lat1d use decompMod, only : get_proc_total, get_proc_bounds, ldecomp @@ -1008,8 +1015,7 @@ subroutine domain_def_clm(lon_clmobs, lat_clmobs, dim_obs, & ! ONLY: mpi_2integer, mpi_minloc USE mod_parallel_pdaf, & ONLY: comm_filter, npes_filter, abort_parallel, & - mpi_integer, mpi_double_precision, mpi_in_place, mpi_sum, & - mype_world, mpi_2integer, mpi_minloc, mype_filter + mype_world, mype_filter real, intent(in) :: lon_clmobs(:) real, intent(in) :: lat_clmobs(:) integer, intent(in) :: dim_obs From 3e403448fbe94f9eeaf861bef8852b8b846b9cf9 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Mon, 27 Oct 2025 14:31:12 +0100 Subject: [PATCH 06/32] Makefile: distinguish OMI-modules and OMI-subroutines modules are compiled first --- interface/framework/Makefile | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/interface/framework/Makefile b/interface/framework/Makefile index 2a1018286..f59705553 100644 --- a/interface/framework/Makefile +++ b/interface/framework/Makefile @@ -75,14 +75,16 @@ MOD_ASSIM = mod_parallel_pdaf.o \ parser_mpi.o \ mod_read_obs.o +# Routines of observation handling (PDAF-OMI) +MOD_USER_PDAFOMI = obs_GRACE_pdafomi.o \ + obs_SM_pdafomi.o + # Model routines used with PDAF OBJ_MODEL_PDAF =pdaf_terrsysmp.o\ integrate_pdaf.o # Routines of observation handling (PDAF-OMI) -OBJ_USER_PDAFOMI = obs_GRACE_pdafomi.o \ - obs_SM_pdafomi.o \ - callback_obs_pdafomi.o +OBJ_USER_PDAFOMI = callback_obs_pdafomi.o # Interface to PDAF - model sided OBJ_PDAF_INT = init_parallel_pdaf.o \ @@ -148,9 +150,11 @@ info: $(PROG) : $(LIBMODEL) libpdaf-d.a \ - $(MODULES) $(MOD_ASSIM) $(OBJ_MODEL_PDAF) $(OBJ_PDAF_INT) $(OBJ_PDAF_USER) + $(MODULES) $(MOD_ASSIM) $(MOD_USER_PDAFOMI) \ + $(OBJ_MODEL_PDAF) $(OBJ_PDAF_INT) $(OBJ_PDAF_USER) $(PREP_C) $(LD) $(OPT_LNK) -o $@ \ - $(MODULES) $(MOD_ASSIM) $(OBJ_MODEL_PDAF) $(OBJ_PDAF_INT) $(OBJ_PDAF_USER) \ + $(MODULES) $(MOD_ASSIM) $(MOD_USER_PDAFOMI) \ + $(OBJ_MODEL_PDAF) $(OBJ_PDAF_INT) $(OBJ_PDAF_USER) \ -L$(BASEDIR)/lib -lpdaf-d $(LIBMODEL) $(LIBS) $(LINK_LIBS) ###################################################### From 2b1392e91c9f0a92eab7a2525a9efd26985a7304 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Mon, 27 Oct 2025 14:32:27 +0100 Subject: [PATCH 07/32] use `da_interval` from `mod_tsmp` independent of component model --- interface/framework/next_observation_pdaf.F90 | 2 -- interface/model/eclm/enkf_clm_mod_5.F90 | 1 - 2 files changed, 3 deletions(-) diff --git a/interface/framework/next_observation_pdaf.F90 b/interface/framework/next_observation_pdaf.F90 index 0d69d2ad6..61b5b6c09 100644 --- a/interface/framework/next_observation_pdaf.F90 +++ b/interface/framework/next_observation_pdaf.F90 @@ -68,8 +68,6 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) check_n_observationfile_next_type, update_obs_type use clm_time_manager, & only: get_nstep - use enkf_clm_mod, & - only: da_interval use clm_varcon, only: set_averaging_to_zero, ispval IMPLICIT NONE diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index 8a6b2df8d..6ab20319e 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -59,7 +59,6 @@ module enkf_clm_mod ! Yorck integer(c_int),bind(C,name="clmupdate_tws") :: clmupdate_tws integer(c_int),bind(C,name="exclude_greenland") :: exclude_greenland - real(r8),bind(C,name="da_interval") :: da_interval integer, dimension(1:5) :: clm_varsize_tws real(r8),bind(C,name="max_inc") :: max_inc integer(c_int),bind(C,name="TWS_smoother") :: TWS_smoother From 8ca7b0393c189921d0039a39267ff4d8d7e19336 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Mon, 27 Oct 2025 14:32:57 +0100 Subject: [PATCH 08/32] fix missing use statements --- interface/model/eclm/enkf_clm_5.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/interface/model/eclm/enkf_clm_5.F90 b/interface/model/eclm/enkf_clm_5.F90 index a309d4690..b90de6d1b 100644 --- a/interface/model/eclm/enkf_clm_5.F90 +++ b/interface/model/eclm/enkf_clm_5.F90 @@ -203,6 +203,8 @@ end subroutine clm_init !-------------------------------------------------------------------------- subroutine clm_advance(ntstep, tstartcycle, mype) bind(C,name="clm_advance") use cime_comp_mod, only : cime_run + use enkf_clm_mod, only : cleanup_clm_statevec + use enkf_clm_mod, only : define_clm_statevec use enkf_clm_mod, only : set_clm_statevec use iso_C_binding, only : c_int From b84fdc39d0f3ba65299b99db755ac69f4a0a5763 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Mon, 27 Oct 2025 14:33:18 +0100 Subject: [PATCH 09/32] fix use statements in OMI modules --- interface/framework/obs_GRACE_pdafomi.F90 | 14 ++++++++++++-- interface/framework/obs_SM_pdafomi.F90 | 7 ++++++- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/interface/framework/obs_GRACE_pdafomi.F90 b/interface/framework/obs_GRACE_pdafomi.F90 index b73cfe9fb..c53c843d1 100644 --- a/interface/framework/obs_GRACE_pdafomi.F90 +++ b/interface/framework/obs_GRACE_pdafomi.F90 @@ -157,6 +157,11 @@ MODULE obs_GRACE_pdafomi !! SUBROUTINE init_dim_obs_GRACE(step, dim_obs) + USE mpi, ONLY: MPI_INTEGER + USE mpi, ONLY: MPI_SUM + USE mpi, ONLY: MPI_2INTEGER + USE mpi, ONLY: MPI_MAXLOC + USE PDAFomi, & ONLY: PDAFomi_gather_obs USE mod_assimilation, & @@ -167,7 +172,7 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) use enkf_clm_mod, only: num_layer, hactiveg_levels use mod_parallel_pdaf, & - only: mpi_integer, mpi_sum, mpi_2integer, mpi_maxloc, comm_filter + only: comm_filter use shr_kind_mod, only: r8 => shr_kind_r8 @@ -493,11 +498,14 @@ END SUBROUTINE init_dim_obs_GRACE !! SUBROUTINE obs_op_GRACE(dim_p, dim_obs, state_p, ostate) + use mpi, only: MPI_DOUBLE_PRECISION + use mpi, only: MPI_SUM + use enkf_clm_mod, & only: clm_varsize_tws, state_setup, num_layer, hactiveg_levels use mod_parallel_pdaf, & - only: comm_filter, mpi_double_precision, mpi_sum + only: comm_filter use clm_varpar , only : nlevsoi @@ -775,7 +783,9 @@ END SUBROUTINE localize_covar_GRACE subroutine read_temp_mean_model(temp_mean_filename) + use netcdf, only: nf90_max_name use netcdf, only: nf90_open + use netcdf, only: nf90_nowrite use netcdf, only: nf90_inq_dimid use netcdf, only: nf90_inquire_dimension use netcdf, only: nf90_inq_varid diff --git a/interface/framework/obs_SM_pdafomi.F90 b/interface/framework/obs_SM_pdafomi.F90 index 78b4371ea..883df2fc0 100644 --- a/interface/framework/obs_SM_pdafomi.F90 +++ b/interface/framework/obs_SM_pdafomi.F90 @@ -149,9 +149,13 @@ MODULE obs_SM_pdafomi !! SUBROUTINE init_dim_obs_SM(step, dim_obs) + USE mpi, ONLY: MPI_INTEGER + USE mpi, ONLY: MPI_DOUBLE_PRECISION + USE mpi, ONLY: MPI_IN_PLACE + USE mpi, ONLY: MPI_SUM + USE mod_parallel_pdaf, & ONLY: mype_filter, comm_filter, npes_filter, abort_parallel, & - mpi_integer, mpi_double_precision, mpi_in_place, mpi_sum, & mype_world USE mod_assimilation, & @@ -186,6 +190,7 @@ SUBROUTINE init_dim_obs_SM(step, dim_obs) use GridcellType, only: grc use clm_varcon, only: spval + use clm_varcon, only: ispval USE mod_parallel_pdaf, & ONLY: mype_world From 5739180a45344c27b70cb8b22b7b8dad5e1d4875 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Mon, 27 Oct 2025 20:06:55 +0100 Subject: [PATCH 10/32] docs: add PDAF-OMI information to manual --- README.md | 14 -------------- docs/_toc.yml | 1 + docs/users_guide/running_tsmp_pdaf/input_cmd.md | 2 +- .../users_guide/running_tsmp_pdaf/tsmp_pdaf_omi.md | 14 ++++++++++++++ 4 files changed, 16 insertions(+), 15 deletions(-) create mode 100644 docs/users_guide/running_tsmp_pdaf/tsmp_pdaf_omi.md diff --git a/README.md b/README.md index a27a50e76..bf9145238 100644 --- a/README.md +++ b/README.md @@ -1,17 +1,3 @@ -# PDAF_omi - -PDAF-OMI for multivariate data assimiliaton. -It is design to handle different observation types (currently soil moisture and TWS) automatically. -Additional to current observation files, the observation type has to be included (SM, GRACE). - -See also create observation script for details: https://icg4geo.icg.kfa-juelich.de/ExternalRepos/tsmp-pdaf/tsmp-pdaf-observation-scripts/-/tree/main/omi_obs_data?ref_type=heads - -Both global and local filters can be used. To enable multi-scale data assimilation, different localization radii for different observation types can be passed. Note that the localization radius for SM is currently in km and for GRACE in #gridcells. - -The framework generates a state vector for each type individually before the assimilation, some things would need to be adapted when mutliple observation types are assimilated at the same timestep. Currently, one observation file only consists of one observation type. As SM observations are usually assimilated at noon and GRACE observations are assimilated at the end of the month at midnight, this should not provide any problems. - -If questions arise contact ewerdwalbesloh@geod.uni-bonn.de - # TSMP-PDAF: Pre-patched PDAF This fork of PDAF contains the PDAF changes ("patches") for using it diff --git a/docs/_toc.yml b/docs/_toc.yml index 19e344131..3d53c18d1 100644 --- a/docs/_toc.yml +++ b/docs/_toc.yml @@ -28,6 +28,7 @@ parts: - file: users_guide/running_tsmp_pdaf/input_cmd - file: users_guide/running_tsmp_pdaf/input_obs - file: users_guide/running_tsmp_pdaf/input_enkfpf + - file: users_guide/running_tsmp_pdaf/tsmp_pdaf_omi - file: users_guide/debugging_tsmp_pdaf/README title: Debugging TSMP-PDAF diff --git a/docs/users_guide/running_tsmp_pdaf/input_cmd.md b/docs/users_guide/running_tsmp_pdaf/input_cmd.md index c9a097688..9940e0a92 100644 --- a/docs/users_guide/running_tsmp_pdaf/input_cmd.md +++ b/docs/users_guide/running_tsmp_pdaf/input_cmd.md @@ -58,7 +58,7 @@ filter. See [](cmd:command-line-examples). - `.true.`: OMI interface is used - `.false.`: OMI interface is not used -See [](cmd:command-line-examples). +See [](omi:tsmp-pdaf-with-pdaf-omi). ## obs_filename ## diff --git a/docs/users_guide/running_tsmp_pdaf/tsmp_pdaf_omi.md b/docs/users_guide/running_tsmp_pdaf/tsmp_pdaf_omi.md new file mode 100644 index 000000000..f7dbfb3b5 --- /dev/null +++ b/docs/users_guide/running_tsmp_pdaf/tsmp_pdaf_omi.md @@ -0,0 +1,14 @@ +(omi:tsmp-pdaf-with-pdaf-omi)= +# TSMP-PDAF with PDAF-OMI + +PDAF-OMI for multivariate data assimiliaton. +It is design to handle different observation types (currently soil moisture and TWS) automatically. +Additional to current observation files, the observation type has to be included (SM, GRACE). + +See also create observation script for details: https://icg4geo.icg.kfa-juelich.de/ExternalRepos/tsmp-pdaf/tsmp-pdaf-observation-scripts/-/tree/main/omi_obs_data?ref_type=heads + +Both global and local filters can be used. To enable multi-scale data assimilation, different localization radii for different observation types can be passed. Note that the localization radius for SM is currently in km and for GRACE in #gridcells. + +The framework generates a state vector for each type individually before the assimilation, some things would need to be adapted when mutliple observation types are assimilated at the same timestep. Currently, one observation file only consists of one observation type. As SM observations are usually assimilated at noon and GRACE observations are assimilated at the end of the month at midnight, this should not provide any problems. + +If questions arise contact ewerdwalbesloh@geod.uni-bonn.de From ad94003b3ecdb60b48c9dbd4cd73cdc64af17449 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Mon, 27 Oct 2025 23:08:45 +0100 Subject: [PATCH 11/32] ensure backward compatibility with CLM3.5 by introducing `#ifdef CLMFIVE` constructs --- interface/framework/assimilate_pdaf.F90 | 5 ++++- interface/framework/callback_obs_pdafomi.F90 | 2 ++ interface/framework/init_pdaf_parse.F90 | 5 ++++- interface/framework/mod_read_obs.F90 | 3 ++- interface/framework/next_observation_pdaf.F90 | 5 ++++- interface/framework/obs_GRACE_pdafomi.F90 | 3 ++- interface/framework/obs_SM_pdafomi.F90 | 7 ++----- interface/model/wrapper_tsmp.c | 2 ++ 8 files changed, 22 insertions(+), 10 deletions(-) diff --git a/interface/framework/assimilate_pdaf.F90 b/interface/framework/assimilate_pdaf.F90 index ffc36a9b6..f7663024b 100644 --- a/interface/framework/assimilate_pdaf.F90 +++ b/interface/framework/assimilate_pdaf.F90 @@ -46,9 +46,11 @@ SUBROUTINE assimilate_pdaf() USE mod_assimilation, & ! Variables for assimilation ONLY: filtertype USE mod_assimilation, ONLY: use_omi +#ifdef CLMFIVE USE PDAF_interfaces_module, & ! Check consistency of PDAF calls ONLY: PDAFomi_assimilate_local, PDAFomi_assimilate_global, & PDAFomi_assimilate_lenkf, PDAF_get_localfilter +#endif IMPLICIT NONE @@ -126,6 +128,7 @@ SUBROUTINE assimilate_pdaf() ! ********************************* OMI: IF (use_omi) THEN +#ifdef CLMFIVE CALL PDAF_get_localfilter(localfilter) IF (localfilter == 1) THEN @@ -152,7 +155,7 @@ SUBROUTINE assimilate_pdaf() ENDIF ENDIF - +#endif ELSE OMI ! IF (filtertype == 1) THEN diff --git a/interface/framework/callback_obs_pdafomi.F90 b/interface/framework/callback_obs_pdafomi.F90 index bd2a834dd..df2a6f9df 100644 --- a/interface/framework/callback_obs_pdafomi.F90 +++ b/interface/framework/callback_obs_pdafomi.F90 @@ -29,6 +29,7 @@ !! This routine calls the observation-specific !! routines init_dim_obs_TYPE. !! +#ifdef CLMFIVE SUBROUTINE init_dim_obs_pdafomi(step, dim_obs) use enkf_clm_mod, only: clmupdate_swc, clmupdate_tws @@ -223,3 +224,4 @@ SUBROUTINE localize_covar_pdafomi(dim_p, dim_obs, HP_p, HPH) DEALLOCATE(coords_p) END SUBROUTINE localize_covar_pdafomi +#endif diff --git a/interface/framework/init_pdaf_parse.F90 b/interface/framework/init_pdaf_parse.F90 index 3972b6f2a..af8869f48 100644 --- a/interface/framework/init_pdaf_parse.F90 +++ b/interface/framework/init_pdaf_parse.F90 @@ -59,8 +59,10 @@ SUBROUTINE init_pdaf_parse() only: cradius_GRACE, sradius_GRACE, & cradius_SM, sradius_SM +#ifdef CLMFIVE use obs_GRACE_pdafomi, only: rms_obs_GRACE use obs_SM_pdafomi, only: rms_obs_SM +#endif IMPLICIT NONE @@ -91,13 +93,14 @@ SUBROUTINE init_pdaf_parse() handle = 'rms_obs' ! Assumed uniform RMS error of the observations CALL parse(handle, rms_obs) +#ifdef CLMFIVE rms_obs_GRACE = rms_obs ! backward compatibility handle = 'rms_obs_GRACE' ! RMS error for GRACE observations CALL parse(handle, rms_obs_GRACE) rms_obs_SM = rms_obs ! backward compatibility handle = 'rms_obs_SM' ! RMS error for SM observations CALL parse(handle, rms_obs_SM) - +#endif handle = 'dim_obs' ! Number of observations CALL parse(handle, dim_obs) diff --git a/interface/framework/mod_read_obs.F90 b/interface/framework/mod_read_obs.F90 index f428e34fe..839d77858 100755 --- a/interface/framework/mod_read_obs.F90 +++ b/interface/framework/mod_read_obs.F90 @@ -966,6 +966,7 @@ subroutine check_n_observationfile_next_type(fn, obs_type_str) end subroutine check_n_observationfile_next_type +#ifdef CLMFIVE subroutine update_obs_type(obs_type_str) use enkf_clm_mod, only: clmupdate_tws, clmupdate_swc, clmupdate_T, clmupdate_texture use mod_parallel_pdaf, only: abort_parallel @@ -994,7 +995,6 @@ end subroutine update_obs_type - subroutine domain_def_clm(lon_clmobs, lat_clmobs, dim_obs, & longxy, latixy, longxy_obs, latixy_obs) @@ -1182,6 +1182,7 @@ subroutine domain_def_clm(lon_clmobs, lat_clmobs, dim_obs, & end if end subroutine domain_def_clm +#endif end module mod_read_obs diff --git a/interface/framework/next_observation_pdaf.F90 b/interface/framework/next_observation_pdaf.F90 index 61b5b6c09..dae5f5fc3 100644 --- a/interface/framework/next_observation_pdaf.F90 +++ b/interface/framework/next_observation_pdaf.F90 @@ -65,10 +65,13 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) USE mod_assimilation, ONLY: use_omi use mod_read_obs, & only: check_n_observationfile, check_n_observationfile_da_interval, check_n_observationfile_set_zero, & - check_n_observationfile_next_type, update_obs_type + check_n_observationfile_next_type +#ifdef CLMFIVE + use mod_read_obs, only: update_obs_type use clm_time_manager, & only: get_nstep use clm_varcon, only: set_averaging_to_zero, ispval +#endif IMPLICIT NONE ! !ARGUMENTS: diff --git a/interface/framework/obs_GRACE_pdafomi.F90 b/interface/framework/obs_GRACE_pdafomi.F90 index c53c843d1..65a4356c9 100644 --- a/interface/framework/obs_GRACE_pdafomi.F90 +++ b/interface/framework/obs_GRACE_pdafomi.F90 @@ -50,6 +50,7 @@ !! * 2019-06 - Lars Nerger - Initial code !! * Later revisions - see repository log !! +#ifdef CLMFIVE MODULE obs_GRACE_pdafomi USE mod_parallel_pdaf, & @@ -833,7 +834,7 @@ subroutine read_temp_mean_model(temp_mean_filename) end subroutine read_temp_mean_model END MODULE obs_GRACE_pdafomi - +#endif diff --git a/interface/framework/obs_SM_pdafomi.F90 b/interface/framework/obs_SM_pdafomi.F90 index 883df2fc0..2682a9b70 100644 --- a/interface/framework/obs_SM_pdafomi.F90 +++ b/interface/framework/obs_SM_pdafomi.F90 @@ -50,6 +50,7 @@ !! * 2019-06 - Lars Nerger - Initial code !! * Later revisions - see repository log !! +#ifdef CLMFIVE MODULE obs_SM_pdafomi USE mod_parallel_pdaf, & @@ -1068,8 +1069,4 @@ END SUBROUTINE localize_covar_SM END MODULE obs_SM_pdafomi - - - - - +#endif diff --git a/interface/model/wrapper_tsmp.c b/interface/model/wrapper_tsmp.c index 20118096f..f3f7edd67 100644 --- a/interface/model/wrapper_tsmp.c +++ b/interface/model/wrapper_tsmp.c @@ -204,9 +204,11 @@ void update_tsmp(){ /* print_update_clm(&tcycle, &total_steps); */ /* } */ /* TODO: enkfpf.par input switch "CLM:print_inc" */ +#ifdef CLMFIVE if ((clmupdate_tws != 0) || (clmupdate_swc != 0)){ print_inc_clm(); } +#endif } #endif From 0baac7ae9e0b5ee73dc161082f6eb349b5a80df2 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Tue, 28 Oct 2025 12:56:01 +0100 Subject: [PATCH 12/32] fortitude: line breaks --- interface/framework/init_dim_obs_f_pdaf.F90 | 3 +- interface/framework/init_dim_obs_pdaf.F90 | 3 +- interface/framework/init_pdaf.F90 | 4 +- interface/framework/mod_assimilation.F90 | 19 ++++--- interface/framework/mod_read_obs.F90 | 8 ++- interface/framework/obs_GRACE_pdafomi.F90 | 57 +++++++++++++++------ interface/framework/obs_SM_pdafomi.F90 | 52 ++++++++++++++----- interface/model/eclm/enkf_clm_mod_5.F90 | 23 ++++++--- interface/model/eclm/print_update_clm_5.F90 | 12 +++-- 9 files changed, 130 insertions(+), 51 deletions(-) diff --git a/interface/framework/init_dim_obs_f_pdaf.F90 b/interface/framework/init_dim_obs_f_pdaf.F90 index a0280f9c6..53ad99e7e 100755 --- a/interface/framework/init_dim_obs_f_pdaf.F90 +++ b/interface/framework/init_dim_obs_f_pdaf.F90 @@ -966,7 +966,8 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) ! Error if observation deeper than clmstatevec_max_layer if(clmobs_layer(i) > min(clmstatevec_max_layer, col%nbedrock(c))) then - print *, "TSMP-PDAF mype(w)=", mype_world, ": ERROR observation layer deeper than clmstatevec_max_layer or bedrock." + print *, "TSMP-PDAF mype(w)=", mype_world, & + ": ERROR observation layer deeper than clmstatevec_max_layer or bedrock." print *, "i=", i print *, "c=", c print *, "clmobs_layer(i)=", clmobs_layer(i) diff --git a/interface/framework/init_dim_obs_pdaf.F90 b/interface/framework/init_dim_obs_pdaf.F90 index 6ce590e63..3631a9352 100755 --- a/interface/framework/init_dim_obs_pdaf.F90 +++ b/interface/framework/init_dim_obs_pdaf.F90 @@ -959,7 +959,8 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) ! Error if observation deeper than clmstatevec_max_layer if(clmobs_layer(i) > min(clmstatevec_max_layer, col%nbedrock(c))) then - print *, "TSMP-PDAF mype(w)=", mype_world, ": ERROR observation layer deeper than clmstatevec_max_layer or bedrock." + print *, "TSMP-PDAF mype(w)=", mype_world, & + ": ERROR observation layer deeper than clmstatevec_max_layer or bedrock." print *, "i=", i print *, "c=", c print *, "clmobs_layer(i)=", clmobs_layer(i) diff --git a/interface/framework/init_pdaf.F90 b/interface/framework/init_pdaf.F90 index 0b01dd9d7..53b52e238 100644 --- a/interface/framework/init_pdaf.F90 +++ b/interface/framework/init_pdaf.F90 @@ -207,7 +207,9 @@ SUBROUTINE init_pdaf() #ifdef PDAF_DEBUG ! Debug output: local state dimension array - if (mype_model == 0) WRITE(*, '(a,x,a,i5,x,a,x)', advance="no") "TSMP-PDAF-debug", "mype(w)=", mype_world, "init_pdaf: dim_state_p_count in modified:" + if (mype_model == 0) WRITE(*, '(a,x,a,i5,x,a,x)', advance="no") & + "TSMP-PDAF-debug", "mype(w)=", mype_world, & + "init_pdaf: dim_state_p_count in modified:" if (mype_model == 0) WRITE(*, *) dim_state_p_count #endif diff --git a/interface/framework/mod_assimilation.F90 b/interface/framework/mod_assimilation.F90 index b37a1dd80..ae1d957d2 100755 --- a/interface/framework/mod_assimilation.F90 +++ b/interface/framework/mod_assimilation.F90 @@ -65,12 +65,15 @@ MODULE mod_assimilation ! *** Variables specific for TSMP-PDAF *** ! gw - INTEGER, ALLOCATABLE :: dim_state_p_count(:) !Vector holding local state vector dimensions for processors of a single model communicator + ! Vector holding local state vector dimensions for processors of a single model communicator + INTEGER, ALLOCATABLE :: dim_state_p_count(:) ! gw end REAL, ALLOCATABLE :: obs(:) ! Vector holding all observations for Global domain INTEGER, ALLOCATABLE :: obs_index_l(:) ! Vector holding local state-vector indices of observations - INTEGER, ALLOCATABLE :: obs_interp_indices_p(:,:) ! Vector holding state-vector indices of grid cells surrounding interpolation for PE-local domain - INTEGER, ALLOCATABLE :: obs_interp_weights_p(:,:) ! Vector holding weights of grid cells surrounding observation for PE-local domain + ! Vector holding state-vector indices of grid cells surrounding interpolation for PE-local domain + INTEGER, ALLOCATABLE :: obs_interp_indices_p(:,:) + ! Vector holding weights of grid cells surrounding observation for PE-local domain + INTEGER, ALLOCATABLE :: obs_interp_weights_p(:,:) INTEGER, ALLOCATABLE :: local_dims_obs(:) ! Array for process-local observation dimensions INTEGER, ALLOCATABLE :: local_disp_obs(:) ! Observation displacement array for gathering. Displacement: #obs before current PE ! pdaf-ordered index: determined by domain-decomposition @@ -88,8 +91,10 @@ MODULE mod_assimilation REAL, ALLOCATABLE :: clm_obserr_p(:) ! Vector holding observation errors for CLM run at each PE-local domain REAL, ALLOCATABLE :: distance(:) ! Localization distance INTEGER, ALLOCATABLE :: global_to_local(:) ! Vector to map global index to local domain index - INTEGER, ALLOCATABLE :: longxy(:), latixy(:), longxy_obs(:), latixy_obs(:) ! longitude and latitude of grid cells and observation cells - INTEGER, ALLOCATABLE :: longxy_obs_floor(:), latixy_obs_floor(:) ! indices of grid cells with smaller lon/lat than observation location + ! longitude and latitude of grid cells and observation cells + INTEGER, ALLOCATABLE :: longxy(:), latixy(:), longxy_obs(:), latixy_obs(:) + ! indices of grid cells with smaller lon/lat than observation location + INTEGER, ALLOCATABLE :: longxy_obs_floor(:), latixy_obs_floor(:) INTEGER, ALLOCATABLE :: var_id_obs(:) ! for remote sensing data the variable identifier to group ! variables distributed over a grid surface area !kuw @@ -99,7 +104,9 @@ MODULE mod_assimilation ! Yorck - REAL :: da_interval_variable ! interval until next observation, used by next_observation_pdaf.F90, better solution for next assimilation time step + ! interval until next observation, used by next_observation_pdaf.F90, + ! better solution for next assimilation time step + REAL :: da_interval_variable ! has to be read from observation file --> no empty observation files have to be written REAL, ALLOCATABLE :: obscov(:,:) ! observation covariance matrix REAL, ALLOCATABLE :: obscov_inv(:,:) ! inverse of the observation covariance matrix diff --git a/interface/framework/mod_read_obs.F90 b/interface/framework/mod_read_obs.F90 index 839d77858..8e7dee836 100755 --- a/interface/framework/mod_read_obs.F90 +++ b/interface/framework/mod_read_obs.F90 @@ -71,13 +71,17 @@ module mod_read_obs !> @author Yorck Ewerdwalbesloh !> @date 17.03.2025 - !> @brief Read NetCDF observation file for different observation types to be able to use one full observation files with several types + !> @brief Read NetCDF observation file for different observation types + !! to be able to use one full observation files with several types !> @param[in] Name of observation file, Name of observation type !> @param[inout] Full observation dimension, full observation vector, uncertainty information, coordinates (lon and lat) !> @details !> This subroutine reads the observation file and return the data - subroutine read_obs_nc_type(current_observation_filename, current_observation_type, dim_obs_g, obs_g, lon_obs_g, lat_obs_g, layer_obs_g, dr_obs_g, obserr_g, obscov_g) + subroutine read_obs_nc_type(current_observation_filename, & + current_observation_type, dim_obs_g, obs_g, & + lon_obs_g, lat_obs_g, layer_obs_g, & + dr_obs_g, obserr_g, obscov_g) use netcdf, only: nf90_max_name use netcdf, only: nf90_open use netcdf, only: nf90_nowrite diff --git a/interface/framework/obs_GRACE_pdafomi.F90 b/interface/framework/obs_GRACE_pdafomi.F90 index 65a4356c9..ee0c041a0 100644 --- a/interface/framework/obs_GRACE_pdafomi.F90 +++ b/interface/framework/obs_GRACE_pdafomi.F90 @@ -67,15 +67,18 @@ MODULE obs_GRACE_pdafomi LOGICAL :: assim_GRACE !< Whether to assimilate this data type REAL :: rms_obs_GRACE !< Observation error standard deviation (for constant errors) logical, allocatable :: vec_useObs(:) - integer, allocatable :: vec_numPoints_global(:) ! vector of number of points for each GRACE observation, same dimension as observation vector - logical, allocatable :: vec_useObs_global(:) ! vector that tells if an observation of used (1) or not (0), same dimension as observation vector, global + ! vector of number of points for each GRACE observation, same dimension as observation vector + integer, allocatable :: vec_numPoints_global(:) + ! vector that tells if an observation of used (1) or not (0), same dimension as observation vector, global + logical, allocatable :: vec_useObs_global(:) real, allocatable :: tws_temp_mean(:,:) ! temporal mean for TWS real, allocatable :: tws_temp_mean_d(:) ! temporal mean for TWS, vectorized with the same bounds as local process real, allocatable :: lon_temp_mean(:,:) ! corresponding longitude real, allocatable :: lat_temp_mean(:,:) ! corresponding latitude - INTEGER, ALLOCATABLE :: longxy(:), latixy(:), longxy_obs(:), latixy_obs(:) ! longitude and latitude of grid cells and observation cells + ! longitude and latitude of grid cells and observation cells + INTEGER, ALLOCATABLE :: longxy(:), latixy(:), longxy_obs(:), latixy_obs(:) ! One can declare further variables, e.g. for file names which can ! be use-included in init_pdaf() and initialized there. @@ -256,9 +259,12 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) ! *** Read PE-local observations *** ! ********************************** - ! read observations from nc file --> call function in mod_read_obs. Idea: when you have multiple observation types in one file, - ! also pass the observation type, here 'GRACE' to the function. You have to give each observation in the file an information which type - ! it is. This way, the output in this function is only the GRACE observation (or soil moisture,...; dependent on what you want to implement) + ! read observations from nc file --> call function in mod_read_obs. + ! Idea: when you have multiple observation types in one file, also pass the + ! observation type, here 'GRACE' to the function. You have to give each + ! observation in the file an information which type it is. This way, the + ! output in this function is only the GRACE observation (or soil moisture, + ! ...; dependent on what you want to implement) obs_type_name = 'GRACE' @@ -269,14 +275,18 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) write(*,*)'load observations from type GRACE' end if write(current_observation_filename, '(a, i5.5)') trim(obs_filename)//'.', step - call read_obs_nc_type(current_observation_filename, obs_type_name, dim_obs, obs_g, lon_obs, lat_obs, layer_obs, dr_obs, obserr, obscov) + call read_obs_nc_type(current_observation_filename, obs_type_name, & + dim_obs, obs_g, lon_obs, lat_obs, layer_obs, & + dr_obs, obserr, obscov) if (mype_filter==0 .and. screen > 2) then write(*,*)'Done: load observations from type GRACE' end if if (dim_obs == 0) then if (mype_filter==0 .and. screen > 2) then - write(*,*)'TSMP-PDAF mype(w) =', mype_world, ': No observations of type GRACE found in file ', trim(current_observation_filename) + write(*,*)'TSMP-PDAF mype(w) =', mype_world, & + ': No observations of type GRACE found in file ', & + trim(current_observation_filename) end if dim_obs_p = 0 ALLOCATE(obs_p(1)) @@ -313,9 +323,12 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) ALLOCATE(out_mpi(2,dim_obs)) - ! additions for GRACE assimilation, it can be the case that not enough CLM gridpoints lie in the neighborhood of a GRACE observation - ! if this is the case, the GRACE observations cannot be reproduced in a satisfactory manner and is not used in the assimilation - ! count grdicells that are in a certain radius. This effect is especially present when the applied GRACE resolution is high or for + ! additions for GRACE assimilation, it can be the case that not enough + ! CLM gridpoints lie in the neighborhood of a GRACE observation + ! if this is the case, the GRACE observations cannot be reproduced in a + ! satisfactory manner and is not used in the assimilation + ! count grdicells that are in a certain radius. This effect is especially + ! present when the applied GRACE resolution is high or for ! observation lying directly at the coast lon => grc%londeg @@ -443,7 +456,8 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) ! *** Finishing up *** ! ******************** - ! load temporal mean of TWS and vectorize for process from begg to endg --> only has to be done once as the process does not change bounds + ! load temporal mean of TWS and vectorize for process from begg to endg + ! --> only has to be done once as the process does not change bounds if (.not. allocated(tws_temp_mean_d)) then call read_temp_mean_model(temp_mean_filename) @@ -582,9 +596,12 @@ SUBROUTINE obs_op_GRACE(dim_p, dim_obs, state_p, ostate) ! liq + ice tws_from_statevector(g) = tws_from_statevector(g) + state_p(count) ! snow - tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)) + tws_from_statevector(g) = tws_from_statevector(g) + & + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)) !surface water - tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)+ clm_varsize_tws(3)) + tws_from_statevector(g) = tws_from_statevector(g) + & + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)+ & + clm_varsize_tws(3)) else ! liq + ice tws_from_statevector(g) = tws_from_statevector(g) + state_p(count+sum(num_layer(1:j-1))) @@ -595,7 +612,9 @@ SUBROUTINE obs_op_GRACE(dim_p, dim_obs, state_p, ostate) ! do count = 1, num_hactiveg_patch ! g = hactiveg_patch(count) ! ! canopy water - ! tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)+ clm_varsize_tws(3)+ clm_varsize_tws(4)) + ! tws_from_statevector(g) = tws_from_statevector(g) + & + ! state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)+ & + ! clm_varsize_tws(3)+ clm_varsize_tws(4)) ! end do @@ -612,7 +631,9 @@ SUBROUTINE obs_op_GRACE(dim_p, dim_obs, state_p, ostate) g = hactiveg_levels(count,1) tws_from_statevector(g) = state_p(count) ! snow added for first layer - tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3)) + tws_from_statevector(g) = tws_from_statevector(g) + & + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2) + & + clm_varsize_tws(3)) end do do count = 1,num_layer(4) @@ -649,7 +670,9 @@ SUBROUTINE obs_op_GRACE(dim_p, dim_obs, state_p, ostate) end do ! now get the sum of m_state_sum (sum over all TWSA values for the gridcells for one process) over all processes - call mpi_allreduce(m_state_sum, m_state_sum_global, size(vec_useObs_global), mpi_double_precision, mpi_sum, comm_filter, ierror) + call mpi_allreduce(m_state_sum, m_state_sum_global, & + size(vec_useObs_global), mpi_double_precision, & + mpi_sum, comm_filter, ierror) m_state_sum_global = m_state_sum_global/vec_numPoints_global ostate_p = pack(m_state_sum_global, vec_useObs) diff --git a/interface/framework/obs_SM_pdafomi.F90 b/interface/framework/obs_SM_pdafomi.F90 index 2682a9b70..e06c94fe6 100644 --- a/interface/framework/obs_SM_pdafomi.F90 +++ b/interface/framework/obs_SM_pdafomi.F90 @@ -67,7 +67,8 @@ MODULE obs_SM_pdafomi LOGICAL :: assim_SM !< Whether to assimilate this data type REAL :: rms_obs_SM !< Observation error standard deviation (for constant errors) - INTEGER, ALLOCATABLE :: longxy(:), latixy(:), longxy_obs(:), latixy_obs(:) ! longitude and latitude of grid cells and observation cells + ! longitude and latitude of grid cells and observation cells + INTEGER, ALLOCATABLE :: longxy(:), latixy(:), longxy_obs(:), latixy_obs(:) ! One can declare further variables, e.g. for file names which can ! be use-included in init_pdaf() and initialized there. @@ -300,7 +301,9 @@ SUBROUTINE init_dim_obs_SM(step, dim_obs) if (mype_filter == 0) then - call read_obs_nc_type(current_observation_filename, obs_type_name, dim_obs, obs_g, lon_obs, lat_obs, layer_obs, dr_obs, obserr, obscov) + call read_obs_nc_type(current_observation_filename, obs_type_name, & + dim_obs, obs_g, lon_obs, lat_obs, layer_obs, & + dr_obs, obserr, obscov) end if call mpi_bcast(dim_obs, 1, MPI_INTEGER, 0, comm_filter, ierror) @@ -309,7 +312,9 @@ SUBROUTINE init_dim_obs_SM(step, dim_obs) if (dim_obs == 0) then if (mype_filter==0 .and. screen > 2) then - write(*,*)'TSMP-PDAF mype(w) =', mype_world, ': No observations of type SM found in file ', trim(current_observation_filename) + write(*,*)'TSMP-PDAF mype(w) =', mype_world, & + ': No observations of type SM found in file ', & + trim(current_observation_filename) end if dim_obs_p = 0 ALLOCATE(obs_p(1)) @@ -419,7 +424,9 @@ SUBROUTINE init_dim_obs_SM(step, dim_obs) ! Assigning observations to grid cells according to ! snapping distance or index arrays - if(((is_use_dr).and.(deltax<=dr_obs(1)).and.(deltay<=dr_obs(1))).or.((.not. is_use_dr).and.(longxy_obs(i) == longxy(cnt)) .and. (latixy_obs(i) == latixy(cnt)))) then + if(((is_use_dr).and.(deltax<=dr_obs(1)).and.(deltay<=dr_obs(1))).or. & + ((.not. is_use_dr).and.(longxy_obs(i) == longxy(cnt)) .and. & + (latixy_obs(i) == latixy(cnt)))) then dim_obs_p = dim_obs_p + 1 ! Use index array for setting the correct state vector index in `obs_id_p` @@ -564,7 +571,9 @@ SUBROUTINE init_dim_obs_SM(step, dim_obs) deltay = abs(lat(g)-lat_obs(i)) end if - if(((is_use_dr).and.(deltax<=dr_obs(1)).and.(deltay<=dr_obs(1))).or.((.not. is_use_dr).and.(longxy_obs(i) == longxy(g-begg+1)) .and. (latixy_obs(i) == latixy(g-begg+1)))) then + if(((is_use_dr).and.(deltax<=dr_obs(1)).and.(deltay<=dr_obs(1))).or. & + ((.not. is_use_dr).and.(longxy_obs(i) == longxy(g-begg+1)) .and. & + (latixy_obs(i) == latixy(g-begg+1)))) then #ifdef CLMFIVE if(state_clm2pdaf_p(c,1)==ispval) then ! `ispval`: column not in state vector, most likely @@ -655,8 +664,11 @@ SUBROUTINE init_dim_obs_SM(step, dim_obs) deltay = abs(lat(g)-lat_obs(i)) end if - if(((is_use_dr).and.(deltax<=dr_obs(1)).and.(deltay<=dr_obs(1))).or.((.not. is_use_dr).and.(longxy_obs(i) == longxy(g-begg+1)) .and. (latixy_obs(i) == latixy(g-begg+1)))) then - if (thisobs%disttype/=3) then ! if haversine formula in distance calculation, the coordinates have to be converted to radians + if(((is_use_dr).and.(deltax<=dr_obs(1)).and.(deltay<=dr_obs(1))).or. & + ((.not. is_use_dr).and.(longxy_obs(i) == longxy(g-begg+1)) .and. & + (latixy_obs(i) == latixy(g-begg+1)))) then + ! if haversine formula in distance calculation, the coordinates have to be converted to radians + if (thisobs%disttype/=3) then ocoord_p(1,cnt) = lon_obs(i) ocoord_p(2,cnt) = lat_obs(i) else @@ -673,7 +685,8 @@ SUBROUTINE init_dim_obs_SM(step, dim_obs) ! Error if observation deeper than clmstatevec_max_layer if(layer_obs(i) > min(clmstatevec_max_layer, col%nbedrock(c))) then - print *, "TSMP-PDAF mype(w)=", mype_world, ": ERROR observation layer deeper than clmstatevec_max_layer or bedrock." + print *, "TSMP-PDAF mype(w)=", mype_world, & + ": ERROR observation layer deeper than clmstatevec_max_layer or bedrock." print *, "i=", i print *, "c=", c print *, "layer_obs(i)=", layer_obs(i) @@ -730,25 +743,37 @@ SUBROUTINE init_dim_obs_SM(step, dim_obs) if((longxy_obs_floor(i) == longxy(g-begg+1)) .and. (latixy_obs_floor(i) == latixy(g-begg+1))) then obs_interp_indices_p(cnt, 1) = g-begg+1 + ((endg-begg+1) * (layer_obs(i)-1)) - obs_interp_weights_p(cnt, 1) = sqrt(abs(lon(g)-lon_obs(i)) * abs(lon(g)-lon_obs(i)) + abs(lat(g)-lat_obs(i)) * abs(lat(g)-lat_obs(i))) + obs_interp_weights_p(cnt, 1) = sqrt(abs(lon(g)-lon_obs(i)) * & + abs(lon(g)-lon_obs(i)) + & + abs(lat(g)-lat_obs(i)) * & + abs(lat(g)-lat_obs(i))) cnt_interp = cnt_interp + 1 end if ! Second: latitude larger than observation location, longitude smaller than observation location if((longxy_obs(i) == longxy(g-begg+1)) .and. (latixy_obs_floor(i) == latixy(g-begg+1))) then obs_interp_indices_p(cnt, 2) = g-begg+1 + ((endg-begg+1) * (layer_obs(i)-1)) - obs_interp_weights_p(cnt, 2) =sqrt(abs(lon(g)-lon_obs(i)) * abs(lon(g)-lon_obs(i)) + abs(lat(g)-lat_obs(i)) * abs(lat(g)-lat_obs(i))) + obs_interp_weights_p(cnt, 2) = sqrt(abs(lon(g)-lon_obs(i)) * & + abs(lon(g)-lon_obs(i)) + & + abs(lat(g)-lat_obs(i)) * & + abs(lat(g)-lat_obs(i))) cnt_interp = cnt_interp + 1 end if ! Third: latitude smaller than observation location, longitude larger than observation location if((longxy_obs_floor(i) == longxy(g-begg+1)) .and. (latixy_obs(i) == latixy(g-begg+1))) then obs_interp_indices_p(cnt, 3) = g-begg+1 + ((endg-begg+1) * (layer_obs(i)-1)) - obs_interp_weights_p(cnt, 3) = sqrt(abs(lon(g)-lon_obs(i)) * abs(lon(g)-lon_obs(i)) + abs(lat(g)-lat_obs(i)) * abs(lat(g)-lat_obs(i))) + obs_interp_weights_p(cnt, 3) = sqrt(abs(lon(g)-lon_obs(i)) * & + abs(lon(g)-lon_obs(i)) + & + abs(lat(g)-lat_obs(i)) * & + abs(lat(g)-lat_obs(i))) cnt_interp = cnt_interp + 1 end if ! Fourth: latitude and longitude larger than observation location if((longxy_obs(i) == longxy(g-begg+1)) .and. (latixy_obs(i) == latixy(g-begg+1))) then obs_interp_indices_p(cnt, 4) = g-begg+1 + ((endg-begg+1) * (layer_obs(i)-1)) - obs_interp_weights_p(cnt, 4) = sqrt(abs(lon(g)-lon_obs(i)) * abs(lon(g)-lon_obs(i)) + abs(lat(g)-lat_obs(i)) * abs(lat(g)-lat_obs(i))) + obs_interp_weights_p(cnt, 4) = sqrt(abs(lon(g)-lon_obs(i)) * & + abs(lon(g)-lon_obs(i)) + & + abs(lat(g)-lat_obs(i)) * & + abs(lat(g)-lat_obs(i))) cnt_interp = cnt_interp + 1 end if ! Check if all four corners are found @@ -975,7 +1000,8 @@ SUBROUTINE init_dim_obs_l_SM(domain_p, step, dim_obs, dim_obs_l) end if - ! for disttype=3, the cradius and sradius have to passed in meters, so I multiply by 1000 to be able to put it in km in the input file + ! for disttype=3, the cradius and sradius have to passed in meters, + ! so I multiply by 1000 to be able to put it in km in the input file if (thisobs%disttype==3) then CALL PDAFomi_init_dim_obs_l(thisobs_l, thisobs, coords_l, & diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index 6ab20319e..fd1c31d49 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -491,9 +491,13 @@ subroutine define_clm_statevec_tws(mype) g = col%gridcell(c) ! gridcell of column - if ((exclude_greenland==0) .or. (.not.(lon(g)<330 .and. lon(g)>180 .and. lat(g)>55))) then ! greenland can be excluded from the statevector + ! greenland can be excluded from the statevector + if ((exclude_greenland==0) .or. & + (.not.(lon(g)<330 .and. lon(g)>180 .and. lat(g)>55))) then - if (col%hydrologically_active(c)) then ! if the column is hydrologically active, add it, if the corresponding gridcell is not found before, add also the gridcell + ! if the column is hydrologically active, add it, if the corresponding + ! gridcell is not found before, add also the gridcell + if (col%hydrologically_active(c)) then if (.not. found(g)) then ! if the gridcell is not found before @@ -538,7 +542,8 @@ subroutine define_clm_statevec_tws(mype) do j = 1,nlevsoi - found(clm_begg:clm_endg) = .false. ! has to be inside the for lopp, else, the hactiveg_levels is only filled for the first level + ! has to be inside the for lopp, else, the hactiveg_levels is only filled for the first level + found(clm_begg:clm_endg) = .false. fa = 0 fg = 0 @@ -575,7 +580,8 @@ subroutine define_clm_statevec_tws(mype) if (allocated(found)) deallocate(found) - ! now we have an array for the columns and gridcells of interest that we can use when we fill the statevector and distribute the update + ! now we have an array for the columns and gridcells of interest that we can + ! use when we fill the statevector and distribute the update ! now lets find out the dimension of the state vector clm_varsize_tws(:) = 0 @@ -2401,7 +2407,8 @@ subroutine init_dim_l_clm(domain_p, dim_l) do i = 1,nlevsoi do count = 1, num_layer(i) if (g==hactiveg_levels(count,i)) then - dim_l = dim_l+1 ! I could also check with col%nbedrock but then I would need the column index and not the gridcell index + ! I could also check with col%nbedrock but then I would need the column index and not the gridcell index + dim_l = dim_l+1 end if end do end do @@ -2527,7 +2534,8 @@ subroutine g2l_state_clm(domain_p, dim_p, state_p, dim_l, state_l) do j = 1, num_layer(1) if (g==hactiveg_levels(j,1)) then state_l(1) = state_p(j) ! surface SM - state_l(dim_l) = state_p(j + sum(clm_varsize_tws(1:3))) ! snow, same indexing as clm_varsize_tws(2:3) = 0 when only surface layers present + ! snow, same indexing as clm_varsize_tws(2:3) = 0 when only surface layers present + state_l(dim_l) = state_p(j + sum(clm_varsize_tws(1:3))) end if end do @@ -2605,7 +2613,8 @@ subroutine l2g_state_clm(domain_p, dim_l, state_l, dim_p, state_p) g = hactiveg_levels(domain_p,1) do i = 1, dim_l-sub do j = 1, num_layer(i) ! i is the layer that we are in right now - if (g==hactiveg_levels(j,i)) then ! if the counter is the gridcell of the local domain, we know the position in the statevector + ! if the counter is the gridcell of the local domain, we know the position in the statevector + if (g==hactiveg_levels(j,i)) then if (i == 1) then ! if first layer state_p(j) = state_l(i) ! first liquid water as it is first in the statevector else diff --git a/interface/model/eclm/print_update_clm_5.F90 b/interface/model/eclm/print_update_clm_5.F90 index 1b794fbbc..5cbefccd0 100644 --- a/interface/model/eclm/print_update_clm_5.F90 +++ b/interface/model/eclm/print_update_clm_5.F90 @@ -369,7 +369,9 @@ subroutine print_inc_clm() bind(C,name="print_inc_clm") end do do jn = 1, nlevsoi if (masterproc) then - call mpi_gatherv (clmstate_tmp_local(beg,jn), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + call mpi_gatherv (clmstate_tmp_local(beg,jn), numsend, MPI_REAL8, & + clmstate_tmp_global, numrecvv, displsv, & + MPI_REAL8, 0, mpicom, ier) else call mpi_gatherv (clmstate_tmp_local(beg,jn), numsend , MPI_REAL8, 0._r8, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) end if @@ -412,7 +414,9 @@ subroutine print_inc_clm() bind(C,name="print_inc_clm") end do do jn = 1, nlevsoi if (masterproc) then - call mpi_gatherv (clmstate_tmp_local(beg,jn), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + call mpi_gatherv (clmstate_tmp_local(beg,jn), numsend, MPI_REAL8, & + clmstate_tmp_global, numrecvv, displsv, & + MPI_REAL8, 0, mpicom, ier) else call mpi_gatherv (clmstate_tmp_local(beg,jn), numsend , MPI_REAL8, 0._r8, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) end if @@ -453,7 +457,9 @@ subroutine print_inc_clm() bind(C,name="print_inc_clm") if (masterproc) then - call mpi_gatherv (clmstate_tmp_local(beg,1), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + call mpi_gatherv (clmstate_tmp_local(beg,1), numsend, MPI_REAL8, & + clmstate_tmp_global, numrecvv, displsv, & + MPI_REAL8, 0, mpicom, ier) else call mpi_gatherv (clmstate_tmp_local(beg,1), numsend , MPI_REAL8, 0._r8, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) end if From e87944ca2b298122ceca2ec21e9004e98059e358 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Tue, 28 Oct 2025 13:31:10 +0100 Subject: [PATCH 13/32] Slight adaptions for facilitating merge --- interface/model/eclm/enkf_clm_mod_5.F90 | 27 ++++++++++++------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index fd1c31d49..0cbce4693 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -138,6 +138,12 @@ subroutine define_clm_statevec(mype) call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) +#ifdef PDAF_DEBUG + WRITE(*,"(a,i5,a,i10,a,i10,a,i10,a,i10,a,i10,a,i10,a,i10,a,i10,a)") & + "TSMP-PDAF mype(w)=", mype, " define_clm_statevec, CLM5-bounds (g,l,c,p)----",& + begg,",",endg,",",begl,",",endl,",",begc,",",endc,",",begp,",",endp," -------" +#endif + clm_begg = begg clm_endg = endg clm_begc = begc @@ -198,6 +204,7 @@ subroutine define_clm_statevec(mype) WRITE(*, '(a,x,a,i5,x,a,i10)') "TSMP-PDAF-debug", "mype(w)=", mype, "define_clm_statevec: clm_statevecsize=", clm_statevecsize #endif + IF (allocated(clm_statevec)) deallocate(clm_statevec) if ((clmupdate_swc/=0) .or. (clmupdate_T/=0) .or. (clmupdate_texture/=0) .or. (clmupdate_tws/=0)) then !hcp added condition allocate(clm_statevec(clm_statevecsize)) @@ -1154,7 +1161,7 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") ! write updated swc back to CLM if(obs_type_update_swc/=0) then - call update_swc(tstartcycle, mype) + call update_clm_swc(tstartcycle, mype) endif !hcp: TG, TV @@ -1165,7 +1172,7 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") ! write updated texture back to CLM if(obs_type_update_texture/=0) then - call update_texture(tstartcycle, mype) + call update_clm_texture(tstartcycle, mype) endif if (obs_type_update_tws==1) then @@ -1177,7 +1184,7 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") end subroutine update_clm - subroutine update_swc(tstartcycle, mype) + subroutine update_clm_swc(tstartcycle, mype) use clm_varpar , only : nlevsoi use shr_kind_mod , only : r8 => shr_kind_r8 use ColumnType , only : col @@ -1383,11 +1390,10 @@ subroutine update_swc(tstartcycle, mype) end do end do - end subroutine update_swc + end subroutine update_clm_swc - - subroutine update_texture(tstartcycle, mype) + subroutine update_clm_texture(tstartcycle, mype) use clm_varpar , only : nlevsoi use shr_kind_mod , only : r8 => shr_kind_r8 use clm_instMod, only : soilstate_inst @@ -1425,7 +1431,7 @@ subroutine update_texture(tstartcycle, mype) call clm_correct_texture call clm_texture_to_parameters - end subroutine update_texture + end subroutine update_clm_texture @@ -2223,7 +2229,6 @@ subroutine init_n_domains_clm(n_domains_p) use decompMod, only : get_proc_bounds use clm_varcon , only : ispval use ColumnType , only : col - use GridcellType , only : grc implicit none @@ -2236,12 +2241,6 @@ subroutine init_n_domains_clm(n_domains_p) integer :: c integer :: cc - real(r8), pointer :: lon(:) - real(r8), pointer :: lat(:) - - lon => grc%londeg - lat => grc%latdeg - ! TODO: remove unnecessary calls of get_proc_bounds (use clm_begg, ! clm_endg, etc) call get_proc_bounds(begg=begg, endg=endg, begc=begc, endc=endc) From c1a480825437f2eecd76feef0f9a1dda4f1f14e4 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Wed, 29 Oct 2025 12:09:10 +0100 Subject: [PATCH 14/32] cmake.h: Read `MODULEOPT` from CMake input needs to change for Intel/Gnu compilers --- make.arch/cmake.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/make.arch/cmake.h b/make.arch/cmake.h index 2d455a6bb..c9ead4575 100644 --- a/make.arch/cmake.h +++ b/make.arch/cmake.h @@ -52,7 +52,7 @@ AR_SPEC = RAN_SPEC = # Specification for directory holding modules (-module for Intel, -J for GNU) -MODULEOPT = -module +MODULEOPT = ${TSMPPDAFMODULEOPT} # Include path for MPI header file MPI_INC = ${TSMPPDAFMPI_INC} From a1ed2e324f02ab8ca9d580c589aefc13da580835 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Wed, 29 Oct 2025 12:18:58 +0100 Subject: [PATCH 15/32] da_interval variable name patch by Yorck --- interface/framework/mod_read_obs.F90 | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/interface/framework/mod_read_obs.F90 b/interface/framework/mod_read_obs.F90 index 8e7dee836..ac0f8eaf1 100755 --- a/interface/framework/mod_read_obs.F90 +++ b/interface/framework/mod_read_obs.F90 @@ -775,6 +775,7 @@ subroutine check_n_observationfile_da_interval(fn,aa) use shr_kind_mod, only: r8 => shr_kind_r8 use netcdf, only: nf90_max_name, nf90_open, nf90_nowrite, & nf90_inq_varid, nf90_get_var, nf90_close, nf90_noerr + use mod_assimilation, only: use_omi implicit none @@ -783,9 +784,19 @@ subroutine check_n_observationfile_da_interval(fn,aa) integer :: ncid, varid, status !,dimid - character (len = *), parameter :: varname = "da_interval" + character (len = nf90_max_name), parameter :: varname real(r8) :: dtime ! land model time step (sec) +#ifdef CLMSA + if (use_omi) then + varname = "da_interval_variable" + else + varname = "da_interval " + end if +#else + varname = "da_interval " +#endif + !character (len = *), parameter :: dim_name = "dim_obs" !character(len = nf90_max_name) :: recorddimname From a1a11fceb97522e082141ee70ed6bd420f1151e0 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Fri, 31 Oct 2025 16:15:16 +0100 Subject: [PATCH 16/32] compilation fix ``` Error: Operand of .not. operator at (1) is INTEGER(4) ``` --- interface/model/eclm/enkf_clm_mod_5.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index 0cbce4693..80f4508f2 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -1271,7 +1271,7 @@ subroutine update_clm_swc(tstartcycle, mype) do j=clm_begc,clm_endc ! If snow is masked, update only, when snow depth is less than 1mm - if( (.not. clmswc_mask_snow) .or. snow_depth(j) < 0.001 ) then + if( (clmswc_mask_snow == 0) .or. snow_depth(j) < 0.001 ) then ! Update only those SWCs that are not excluded by ispval if(state_clm2pdaf_p(j,i) /= ispval) then From 92296689700b4a8ade0d6a8d93969a0d516c8de5 Mon Sep 17 00:00:00 2001 From: s7yoewer <73543094+s7yoewer@users.noreply.github.com> Date: Tue, 4 Nov 2025 10:25:17 +0100 Subject: [PATCH 17/32] Author additions and bugfix in mod_read_obs (#35) * Add Anne as author and bug fix in mod_read_obs.F90 * bug fix in mod_read_obs --- .../introduction_to_tsmp_pdaf/README.md | 1 + interface/framework/callback_obs_pdafomi.F90 | 3 + interface/framework/mod_read_obs.F90 | 91 +++++++------------ interface/framework/obs_GRACE_pdafomi.F90 | 37 +++++++- interface/framework/obs_SM_pdafomi.F90 | 4 + interface/model/eclm/enkf_clm_mod_5.F90 | 19 ++-- 6 files changed, 90 insertions(+), 65 deletions(-) diff --git a/docs/users_guide/introduction_to_tsmp_pdaf/README.md b/docs/users_guide/introduction_to_tsmp_pdaf/README.md index f0761e16e..bee709ae5 100644 --- a/docs/users_guide/introduction_to_tsmp_pdaf/README.md +++ b/docs/users_guide/introduction_to_tsmp_pdaf/README.md @@ -40,6 +40,7 @@ In alphabetic order (to be extended): * Stefan Poll * Mukund Pondkule * Prabhakar Shrestha +* Anne Springer * Lukas Strebel ## About this documentation diff --git a/interface/framework/callback_obs_pdafomi.F90 b/interface/framework/callback_obs_pdafomi.F90 index df2a6f9df..a4e75fc9a 100644 --- a/interface/framework/callback_obs_pdafomi.F90 +++ b/interface/framework/callback_obs_pdafomi.F90 @@ -29,6 +29,9 @@ !! This routine calls the observation-specific !! routines init_dim_obs_TYPE. !! + +! Author: Yorck Ewerdwalbesloh + #ifdef CLMFIVE SUBROUTINE init_dim_obs_pdafomi(step, dim_obs) diff --git a/interface/framework/mod_read_obs.F90 b/interface/framework/mod_read_obs.F90 index ac0f8eaf1..d1328e590 100755 --- a/interface/framework/mod_read_obs.F90 +++ b/interface/framework/mod_read_obs.F90 @@ -72,7 +72,7 @@ module mod_read_obs !> @author Yorck Ewerdwalbesloh !> @date 17.03.2025 !> @brief Read NetCDF observation file for different observation types - !! to be able to use one full observation files with several types + !! to read only those observations that should be read in for the specified type !> @param[in] Name of observation file, Name of observation type !> @param[inout] Full observation dimension, full observation vector, uncertainty information, coordinates (lon and lat) !> @details @@ -758,7 +758,7 @@ subroutine check_n_observationfile(fn,nn) end subroutine check_n_observationfile - !> @author Yorck Ewerdwalbesloh, Johannes Keller + !> @author Anne Springer, Yorck Ewerdwalbesloh, Johannes Keller !> @date 11.09.2023 !> @brief Return data assimilation interval from file !> @param[in] fn Filename of the observation file @@ -784,7 +784,7 @@ subroutine check_n_observationfile_da_interval(fn,aa) integer :: ncid, varid, status !,dimid - character (len = nf90_max_name), parameter :: varname + character (len = nf90_max_name) :: varname real(r8) :: dtime ! land model time step (sec) #ifdef CLMSA @@ -830,60 +830,8 @@ subroutine check(status) end subroutine check - ! !> @author Yorck Ewerdwalbesloh - ! !> @date 11.09.2023 - ! !> @brief Return data assimilation interval from file - ! !> @param[in] fn Filename of the observation file - ! !> @param[out] nn number of hours until next assimilation time step - ! !> @details - ! !> Reads the content of the variable name `da_interval_variable` from NetCDF - ! !> file `fn` using subroutines from the NetCDF module. - ! !> The result is returned in `nn`. - ! !> - ! !> The result is used to decide if the next observation file is - ! !> used or not. - ! subroutine check_n_observationfile_da_interval(fn,nn) - ! use shr_kind_mod, only: r8 => shr_kind_r8 - ! use netcdf, only: nf90_max_name, nf90_open, nf90_nowrite, & - ! nf90_inq_varid, nf90_get_var, nf90_close, nf90_noerr - ! use clm_varcon, only: ispval - ! use clm_time_manager, only : get_step_size - ! implicit none - - ! character(len=*),intent(in) :: fn - ! real, intent(out) :: nn - - - ! integer :: ncid, varid, status !,dimid - ! character (len = *), parameter :: varname = "da_interval_variable" - ! real(r8) :: dtime ! land model time step (sec) - - ! !character (len = *), parameter :: dim_name = "dim_obs" - ! !character(len = nf90_max_name) :: recorddimname - - ! dtime = get_step_size() - - ! call check(nf90_open(fn, nf90_nowrite, ncid)) - ! !call check(nf90_inq_dimid(ncid, dim_name, dimid)) - ! !call check(nf90_inquire_dimension(ncid, dimid, recorddimname, nn)) - ! status = nf90_inq_varid(ncid, varname, varid) - ! if (status == nf90_noerr) then - ! call check(nf90_inq_varid(ncid, varname, varid)) - ! call check( nf90_get_var(ncid, varid, nn) ) - ! call check(nf90_close(ncid)) - ! ! at this point: half hourly time steps, this is adjusted here. In the GRACE files, da_interval is set up as hours - ! ! --> is adjusted using information from inside CLM - ! nn = nn*INT(3600/dtime) - ! else - ! nn = ispval - ! end if - - ! end subroutine check_n_observationfile_da_interval - - - - !> @author Yorck Ewerdwalbesloh + !> @author Anne Springer, adaptation for TSMP2 by Yorck Ewerdwalbesloh !> @date 04.12.2023 !> @brief Return set zero interval for running mean of model variables from file !> @param[in] fn Filename of the observation file @@ -934,7 +882,17 @@ subroutine check_n_observationfile_set_zero(fn,nn) end subroutine check_n_observationfile_set_zero - + !> @author Yorck Ewerdwalbesloh + !> @date 29.10.2025 + !> @brief Return next observation type from next observation file + !> @param[in] fn Filename of the observation file + !> @param[out] obs_type_str next observation type + !> @details + !> Reads the content of the variable name `type_clm` from NetCDF + !> file `fn` using subroutines from the NetCDF module. + !> The first entry of the vector is returned in `obs_type_str`. + !> + !> The result is used to reset the observation type and to initialize the next assimilation cycle. subroutine check_n_observationfile_next_type(fn, obs_type_str) use netcdf, only: nf90_max_name use netcdf, only: nf90_open @@ -982,6 +940,12 @@ end subroutine check_n_observationfile_next_type #ifdef CLMFIVE + !> @author Yorck Ewerdwalbesloh + !> @date 29.10.2025 + !> @brief Update observation type for next assimilation cycle + !> @param[in] obs_type_st next observation type + !> @details + !> Updates the observation type for the next assimilation cycle when using the OMI interface subroutine update_obs_type(obs_type_str) use enkf_clm_mod, only: clmupdate_tws, clmupdate_swc, clmupdate_T, clmupdate_texture use mod_parallel_pdaf, only: abort_parallel @@ -1009,7 +973,18 @@ subroutine update_obs_type(obs_type_str) end subroutine update_obs_type - + !> @author Yorck Ewerdwalbesloh + !> @date 29.10.2025 + !> @brief Defines an index domain for GRACE assimilation + !> @param[in] lon_clmobs longitude of the observations + !> @param[in] lat_clmobs latitude of the observations + !> @param[in] dim_obs number of observations + !> @param[out] longxy local x-indices of the gridcells + !> @param[out] latixy local y-indices of the gridcells + !> @param[out] longxy_obs local x-indices of the observations + !> @param[out] latixy_obs local y-indices of the observations + !> @details + !> Generates an index grid instead of the lon/lat grid subroutine domain_def_clm(lon_clmobs, lat_clmobs, dim_obs, & longxy, latixy, longxy_obs, latixy_obs) diff --git a/interface/framework/obs_GRACE_pdafomi.F90 b/interface/framework/obs_GRACE_pdafomi.F90 index ee0c041a0..5da404a9d 100644 --- a/interface/framework/obs_GRACE_pdafomi.F90 +++ b/interface/framework/obs_GRACE_pdafomi.F90 @@ -159,6 +159,13 @@ MODULE obs_GRACE_pdafomi !! !! Further variables are set when the routine PDAFomi_gather_obs is called. !! + + + !> @author Anne Springer, Yorck Ewerdwalbesloh + !> @date 29.10.2025 + !> @brief Initialized the observation dimension and related arrays for GRACE observations + !> @param[in] step current time step + !> @param[in,out] dim_obs dimension of full observation vector SUBROUTINE init_dim_obs_GRACE(step, dim_obs) USE mpi, ONLY: MPI_INTEGER @@ -511,6 +518,14 @@ END SUBROUTINE init_dim_obs_GRACE !! !! The routine is called by all filter processes. !! + + !> @author Yorck Ewerdwalbesloh, Anne Springer + !> @date 29.10.2025 + !> @brief Observation operator for GRACE observations + !> @param[in] dim_p PE-local state dimension + !> @param[in] dim_obs Dimension of full observation vector + !> @param[in] state_p PE-local model state + !> @param[in,out] ostate Full observed state SUBROUTINE obs_op_GRACE(dim_p, dim_obs, state_p, ostate) use mpi, only: MPI_DOUBLE_PRECISION @@ -706,6 +721,14 @@ END SUBROUTINE obs_op_GRACE !! different localization radius and localization functions !! for each observation type and local analysis domain. !! + + !> @author Yorck Ewerdwalbesloh + !> @date 29.10.2025 + !> @brief Initialize local observation dimension for GRACE observations + !> @param[in] domain_p Index of current local analysis domain + !> @param[in] step Current time step + !> @param[in] dim_obs Full dimension of observation vector + !> @param[in,out] dim_obs_l Local dimension of observation vector SUBROUTINE init_dim_obs_l_GRACE(domain_p, step, dim_obs, dim_obs_l) ! Include PDAFomi function @@ -764,6 +787,15 @@ END SUBROUTINE init_dim_obs_l_GRACE !! different localization radius and localization functions !! for each observation type. !! + + !> @author Yorck Ewerdwalbesloh + !> @date 29.10.2025 + !> @brief Covariance localization for GRACE observations, called only for the EnKF + !> @param[in] dim_p PE-local state dimension + !> @param[in] dim_obs Dimension of full observation vector + !> @param[in,out] HP_p PE-local part of matrix HP + !> @param[in,out] HPH Matrix HPH + !> @param[in,out] coords_p Coordinates of state vector elements SUBROUTINE localize_covar_GRACE(dim_p, dim_obs, HP_p, HPH, coords_p) ! Include PDAFomi function @@ -804,7 +836,10 @@ SUBROUTINE localize_covar_GRACE(dim_p, dim_obs, HP_p, HPH, coords_p) END SUBROUTINE localize_covar_GRACE - + !> @author Anne Springer + !> @date 29.10.2025 + !> @brief Read temporal mean of TWS from NetCDF file + !> @param[in] temp_mean_filename filename of NetCDF file containing temporal mean of TWS subroutine read_temp_mean_model(temp_mean_filename) use netcdf, only: nf90_max_name diff --git a/interface/framework/obs_SM_pdafomi.F90 b/interface/framework/obs_SM_pdafomi.F90 index e06c94fe6..75671609e 100644 --- a/interface/framework/obs_SM_pdafomi.F90 +++ b/interface/framework/obs_SM_pdafomi.F90 @@ -50,6 +50,10 @@ !! * 2019-06 - Lars Nerger - Initial code !! * Later revisions - see repository log !! + +! Author: Yorck Ewerdwalbesloh, adaptations of original implementations of TSMP2-PDAF interface for OMI framework + + #ifdef CLMFIVE MODULE obs_SM_pdafomi diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index 80f4508f2..e472e1780 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -426,7 +426,10 @@ subroutine define_clm_statevec_swc(mype) end subroutine define_clm_statevec_swc - + !> @author Yorck Ewerdwalbesloh, Anne Springer + !> @date 29.10.2025 + !> @brief define the state vector for TWS assimilation + !> @param[in] mype MPI rank subroutine define_clm_statevec_tws(mype) use shr_kind_mod, only: r8 => shr_kind_r8 use decompMod , only : get_proc_bounds @@ -822,7 +825,9 @@ subroutine set_clm_statevec_swc() end subroutine set_clm_statevec_swc - + !> @author Yorck Ewerdwalbesloh, Anne Springer + !> @date 29.10.2025 + !> @brief set the state vector for TWS assimilation subroutine set_clm_statevec_tws() use clm_instMod, only : soilstate_inst, waterstate_inst use clm_varpar , only : nlevsoi @@ -1434,7 +1439,9 @@ subroutine update_clm_texture(tstartcycle, mype) end subroutine update_clm_texture - + !> @author Yorck Ewerdwalbesloh, Anne Springer + !> @date 29.10.2025 + !> @brief update water storages from TWS assimilation subroutine clm_update_tws() use clm_varpar , only : nlevsoi, nlevsno @@ -2354,7 +2361,7 @@ subroutine init_n_domains_clm(n_domains_p) end subroutine init_n_domains_clm - !> @author Wolfgang Kurtz, Johannes Keller + !> @author Wolfgang Kurtz, Johannes Keller, Yorck Ewerdwalbesloh !> @date 20.11.2017 !> @brief Set local state vector dimension DIM_L local PDAF filters !> @details @@ -2443,7 +2450,7 @@ subroutine init_dim_l_clm(domain_p, dim_l) end subroutine init_dim_l_clm - !> @author Wolfgang Kurtz, Johannes Keller + !> @author Wolfgang Kurtz, Johannes Keller, Yorck Ewerdwalbesloh !> @date 20.11.2017 !> @brief Set local state vector STATE_L from global state vector STATE_P !> @details @@ -2560,7 +2567,7 @@ subroutine g2l_state_clm(domain_p, dim_p, state_p, dim_l, state_l) end subroutine g2l_state_clm - !> @author Wolfgang Kurtz, Johannes Keller + !> @author Wolfgang Kurtz, Johannes Keller, Yorck Ewerdwalbesloh !> @date 20.11.2017 !> @brief Update global state vector STATE_P from local state vector STATE_L !> @details From 1b2ee2115830f1bb635201f7bf79464e6ebd9eb9 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Tue, 4 Nov 2025 11:20:38 +0100 Subject: [PATCH 18/32] bugfix, type mismatch from huge-function MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ``` Error: Arithmetic overflow converting REAL(16) to REAL(8) at (1). This check can be disabled with the option ‘-fno-range-check’ ``` --- interface/framework/mod_read_obs.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/interface/framework/mod_read_obs.F90 b/interface/framework/mod_read_obs.F90 index d1328e590..769e639af 100755 --- a/interface/framework/mod_read_obs.F90 +++ b/interface/framework/mod_read_obs.F90 @@ -1079,7 +1079,7 @@ subroutine domain_def_clm(lon_clmobs, lat_clmobs, dim_obs, & if (allocated(min_dist)) deallocate(min_dist) allocate(min_dist(dim_obs)) - min_dist(:) = huge(1.0d0) + min_dist(:) = huge(min_dist) if (allocated(min_g)) deallocate(min_g) allocate(min_g(dim_obs)) From edd474c89d5645856fe965e403552a7cef62cc66 Mon Sep 17 00:00:00 2001 From: ewerdwalbesloh1 Date: Tue, 16 Dec 2025 15:49:04 +0100 Subject: [PATCH 19/32] Adapt da_interval implementation --- interface/framework/mod_read_obs.F90 | 12 +-- interface/framework/next_observation_pdaf.F90 | 80 +++++++------------ 2 files changed, 33 insertions(+), 59 deletions(-) diff --git a/interface/framework/mod_read_obs.F90 b/interface/framework/mod_read_obs.F90 index 769e639af..84a9caa2c 100755 --- a/interface/framework/mod_read_obs.F90 +++ b/interface/framework/mod_read_obs.F90 @@ -787,15 +787,8 @@ subroutine check_n_observationfile_da_interval(fn,aa) character (len = nf90_max_name) :: varname real(r8) :: dtime ! land model time step (sec) -#ifdef CLMSA - if (use_omi) then - varname = "da_interval_variable" - else - varname = "da_interval " - end if -#else varname = "da_interval " -#endif + !character (len = *), parameter :: dim_name = "dim_obs" !character(len = nf90_max_name) :: recorddimname @@ -830,7 +823,7 @@ subroutine check(status) end subroutine check - +#ifdef CLMFIVE !> @author Anne Springer, adaptation for TSMP2 by Yorck Ewerdwalbesloh !> @date 04.12.2023 !> @brief Return set zero interval for running mean of model variables from file @@ -881,6 +874,7 @@ subroutine check_n_observationfile_set_zero(fn,nn) end if end subroutine check_n_observationfile_set_zero +#endif !> @author Yorck Ewerdwalbesloh !> @date 29.10.2025 diff --git a/interface/framework/next_observation_pdaf.F90 b/interface/framework/next_observation_pdaf.F90 index dae5f5fc3..a98efd926 100644 --- a/interface/framework/next_observation_pdaf.F90 +++ b/interface/framework/next_observation_pdaf.F90 @@ -71,6 +71,7 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) use clm_time_manager, & only: get_nstep use clm_varcon, only: set_averaging_to_zero, ispval + use enkf_clm_mod, only: clmupdate_tws #endif IMPLICIT NONE @@ -90,6 +91,7 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) integer :: nstep character (len = 110) :: fn character(len=32) :: obs_type_str + logical :: file_exists !kuw end REAL :: da_interval_new @@ -98,7 +100,6 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) time = 0.0 ! Not used in fully-parallel implementation variant doexit = 0 - NOOMI:if (.not. use_omi) then !kuw: implementation for at least 1 existing observation per observation file !!print *, "stepnow", stepnow !write(*,*)'stepnow (in next_observation_pdaf):',stepnow @@ -195,8 +196,6 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) - end if NOOMI - ! IF (stepnow + nsteps <= total_steps) THEN ! if (2<1) then ! ! *** During the assimilation process *** @@ -227,63 +226,44 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) #ifdef CLMSA #ifdef CLMFIVE OMI:if (use_omi) then - nstep = get_nstep() - nsteps = delt_obs - - if (mype_world==0 .and. screen > 2) then - write(*,*) 'TSMP-PDAF (in next_observation_pdaf.F90) total_steps: ',total_steps - end if - - ! Read steps until next observation from current observation file - if (stepnow==toffset) then - set_averaging_to_zero = 0 - if (mype_world==0 .and. screen > 2) then - write(*,*)'next_observation_pdaf: da_interval from enkfpf.par' - end if - else - write(fn, '(a, i5.5)') trim(obs_filename)//'.', stepnow - call check_n_observationfile_da_interval(fn,da_interval_variable) - if (da_interval_variable/=ispval) then - da_interval = da_interval_variable + if (clmupdate_tws.ne.0) then ! only update set_zero when GRACE is assimilated at the current time step + nstep = get_nstep() + if (stepnow.ne.toffset) then + write(fn, '(a, i5.5)') trim(obs_filename)//'.', stepnow + call check_n_observationfile_set_zero(fn, set_averaging_to_zero) + if (set_averaging_to_zero.ne.ispval) then + set_averaging_to_zero = set_averaging_to_zero+nstep + end if + + if (mype_world==0 .and. screen > 2) then + write(*,*) 'set_averaging_to_zero (in next_observation_pdaf):',set_averaging_to_zero + end if + end if end if - call check_n_observationfile_set_zero(fn, set_averaging_to_zero) - end if - - if (mype_world==0 .and. screen > 2) then - write(fn, '(a, i5.5)') trim(obs_filename)//'.', stepnow - write(*,*)'next_observation_pdaf: fn = ', fn - write(*,*)'da_interval (in next_observation_pdaf):',da_interval - end if - if (set_averaging_to_zero/=ispval) then - set_averaging_to_zero = set_averaging_to_zero+nstep - end if - - if (mype_world==0 .and. screen > 2) then - write(*,*) 'set_averaging_to_zero (in next_observation_pdaf):',set_averaging_to_zero - end if - - if (stepnow==toffset) then - if (mype_world==0 .and. screen > 2) then - write(*,*)'next_observation_pdaf: observation type from enkfpf.par' - end if - else - ! update observation type with next file + ! update observation type with next file write(fn, '(a, i5.5)') trim(obs_filename)//'.', stepnow + delt_obs if (mype_world==0 .and. screen > 2) then write(*,*)'next_observation_pdaf: fn = ', fn write(*,*)'Call check_n_observationfile_next_type' end if - call check_n_observationfile_next_type(fn, obs_type_str) - if (trim(obs_type_str) /= '') then - call update_obs_type(obs_type_str) - end if - if (mype_world==0 .and. screen > 2) then - write(*,*)'next_type (in next_observation_pdaf):',trim(obs_type_str) + inquire(file=fn, exist=file_exists) + if (.not. file_exists) then + if (mype_world == 0 .and. screen > 2) then + write(*,*) 'next_observation_pdaf: skipping setting next observation type as no next file available' + end if + else + call check_n_observationfile_next_type(fn, obs_type_str) + if (trim(obs_type_str) /= '') then + call update_obs_type(obs_type_str) + end if + + if (mype_world==0 .and. screen > 2) then + write(*,*)'next_type (in next_observation_pdaf):',trim(obs_type_str) + end if end if - end if end if OMI #endif #endif From 9126b3a74f12c368fd7b8b882a35d24482f2cabd Mon Sep 17 00:00:00 2001 From: ewerdwalbesloh1 Date: Tue, 16 Dec 2025 15:51:02 +0100 Subject: [PATCH 20/32] Changing size of PDAF internal allocated arrays (state vector size) for multivariate DA --- interface/model/Makefile | 6 ++++-- interface/model/common/enkf.h | 1 + interface/model/common/read_enkfpar.c | 1 + interface/model/eclm/enkf_clm_5.F90 | 2 -- interface/model/eclm/enkf_clm_mod_5.F90 | 21 +++++++++++++++++++++ src/Makefile | 7 ++++--- 6 files changed, 31 insertions(+), 7 deletions(-) diff --git a/interface/model/Makefile b/interface/model/Makefile index 185b906aa..b12bc2c16 100644 --- a/interface/model/Makefile +++ b/interface/model/Makefile @@ -17,6 +17,8 @@ OBJ = dictionary.o\ read_enkfpar.o\ wrapper_tsmp.o\ +OBJ += ${PDAF_SRC}/src/PDAF_reset_dim_p.o + ## clm object files OBJCLM = enkf_clm_mod.o\ mod_clm_statistics.o\ @@ -72,7 +74,7 @@ $(info $$OBJ is [${OBJ}]) all: libmodel.a libmodel.a: $(OBJ) - ar rcs $@ *.o + ar rcs $@ $(OBJ) ranlib $@ mv $@ $(TSMPPDAFLIBDIR) @echo "library compilation suceeded" @@ -93,4 +95,4 @@ wrapper_tsmp.o: $(PREP_C) $(FC) $(OPT) $(FCPP_FLAGS) $(FFLAGS) $(FINCS) -c $< -o $@ clean: - rm -f *.o *.mod $(PROG) libmodel.a + rm -f *.o *.mod $(PROG) libmodel.a diff --git a/interface/model/common/enkf.h b/interface/model/common/enkf.h index d6aebe11d..407f3a7d9 100755 --- a/interface/model/common/enkf.h +++ b/interface/model/common/enkf.h @@ -116,6 +116,7 @@ GLOBAL int state_setup; GLOBAL int update_snow; GLOBAL int remove_mean; GLOBAL int exclude_greenland; +GLOBAL int set_zero_start; GLOBAL int crns_flag; GLOBAL int da_print_obs_index; extern int model; diff --git a/interface/model/common/read_enkfpar.c b/interface/model/common/read_enkfpar.c index 4ed122b75..0a5c68bfd 100755 --- a/interface/model/common/read_enkfpar.c +++ b/interface/model/common/read_enkfpar.c @@ -113,6 +113,7 @@ void read_enkfpar(char *parname) update_snow = iniparser_getint(pardict,"DA:update_snow",0); remove_mean = iniparser_getint(pardict,"DA:remove_mean",0); exclude_greenland = iniparser_getint(pardict,"DA:exclude_greenland",0); + set_zero_start = iniparser_getint(pardict,"DA:set_zero_start",0); crns_flag = iniparser_getint(pardict,"DA:crns_flag",0); da_crns_depth_tol = iniparser_getdouble(pardict,"DA:da_crns_depth_tol",0.01); diff --git a/interface/model/eclm/enkf_clm_5.F90 b/interface/model/eclm/enkf_clm_5.F90 index b90de6d1b..59127e019 100644 --- a/interface/model/eclm/enkf_clm_5.F90 +++ b/interface/model/eclm/enkf_clm_5.F90 @@ -225,8 +225,6 @@ subroutine clm_advance(ntstep, tstartcycle, mype) bind(C,name="clm_advance") call define_clm_statevec(mype) ! call define statevec not in the beginning ! but here as we can define the statevec for each obs type - ! maybe I have to cleanup before defining, check later - ! Calling PDAF Function to set state vector before assimiliation call set_clm_statevec(tstartcycle, mype) #endif diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index fdce97fd1..897dbd3c9 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -64,6 +64,7 @@ module enkf_clm_mod real(r8),bind(C,name="max_inc") :: max_inc integer(c_int),bind(C,name="TWS_smoother") :: TWS_smoother integer(c_int),bind(C,name="state_setup") :: state_setup + integer(c_int),bind(C,name="set_zero_start") :: set_zero_start integer, allocatable :: num_layer(:) integer, allocatable :: num_layer_columns(:) integer :: num_hactiveg, num_hactivec @@ -72,6 +73,8 @@ module enkf_clm_mod integer, allocatable :: hactivec_levels(:,:) ! hydrolocial active filter for all levels (column) integer, allocatable :: gridcell_state(:) + logical :: first_cycle = .TRUE. + ! OMI --> I want to update the observation type after each observation comes in. ! problem: the observation type is updated before the update of the assimilation @@ -126,6 +129,7 @@ module enkf_clm_mod subroutine define_clm_statevec(mype) use decompMod , only : get_proc_bounds use clm_varpar , only : nlevsoi + use clm_varcon, only: set_averaging_to_zero implicit none @@ -201,6 +205,23 @@ subroutine define_clm_statevec(mype) ! + ! reset PDAF dimensions for multivariate assimilation, only not for first call as PDAF did not initalize yet + if (.not. first_cycle) then + call PDAF_reset_dim_p(clm_statevecsize,ierror) + end if + + if (first_cycle) then + ! possibility to assimilate GRACE not in the first month --> enkfpf.par file has information set_zero_start where the running average should be resetted + ! This is usually one month prior to the first GRACE observation. If it is not included in the file, it is resetted when the first GRACE observation + ! is assimilated. Afterwards, the normal set_zero information inside the observation file is used (see next_observation_pdaf for details). + if (set_zero_start.ne.0) then + set_averaging_to_zero = set_zero_start + end if + end if + + first_cycle = .FALSE. + + #ifdef PDAF_DEBUG ! Debug output of clm_statevecsize WRITE(*, '(a,x,a,i5,x,a,i10)') "TSMP-PDAF-debug", "mype(w)=", mype, "define_clm_statevec: clm_statevecsize=", clm_statevecsize diff --git a/src/Makefile b/src/Makefile index f2c766ffc..2196a39f4 100644 --- a/src/Makefile +++ b/src/Makefile @@ -5,7 +5,7 @@ # To choose the architecture set $PDAF_ARCH # ####################################################### -.SUFFIXES: .F90 .f .o +.SUFFIXES: .F90 .f .o ###################################################### @@ -96,7 +96,8 @@ OBJ_PDAF_GEN = PDAF_analysis_utils.o \ PDAF_reset_forget.o \ PDAF_get_ensstats.o \ PDAF_set_debug_flag.o \ - PDAF_set_offline_mode.o + PDAF_set_offline_mode.o \ + PDAF_reset_dim_p.o # Specific PDAF-routines for SEIK OBJ_SEIK = PDAF_seik_init.o \ @@ -380,7 +381,7 @@ OBJ_PDAF = $(OBJ_PDAFOMI) $(OBJ_PDAF_GEN) $(OBJ_SEIK) $(OBJ_LSEIK) $(OBJ_SEEK) $(OBJ_ESTKF) $(OBJ_LESTKF) $(OBJ_LENKF) $(OBJ_NETF) $(OBJ_LNETF) \ $(OBJ_LKNETF) $(OBJ_PF) $(OBJ_OBSGEN) $(OBJ_3DVAR_INI) -OBJ_PDAF_VAR = $(OBJ_PDAF) $(OBJ_3DVAR) +OBJ_PDAF_VAR = $(OBJ_PDAF) $(OBJ_3DVAR) # External optimizer libraries OBJ_OPTIM = ../external/CG+_mpi/cgfam.o ../external/CG+_mpi/cgsearch.o \ From 9d56fc51a270850fbf6181a0dc6e022d6e8d2c9c Mon Sep 17 00:00:00 2001 From: ewerdwalbesloh1 Date: Tue, 16 Dec 2025 16:29:23 +0100 Subject: [PATCH 21/32] Update to PDAF2.3 --- external/SANGOMA/SANGOMA_quicksort.F90 | 273 +++ external/SANGOMA/SANGOMA_quicksort.o | Bin 0 -> 4048 bytes external/mkdepends/mkdepends | 272 +++ .../PDAF_reset_dim_p-checkpoint.F90 | 128 ++ .../PDAF_reset_forget-checkpoint.F90 | 62 + src/Makefile | 130 +- src/PDAF_3dvar_memtime.F90 | 8 +- src/PDAF_assimilate_lknetf_si.F90 | 2 +- src/PDAF_correlation_function.F90 | 127 ++ src/PDAF_diag_crps.F90 | 281 ++- src/PDAF_estkf_analysis.F90 | 50 +- src/PDAF_estkf_analysis_fixed.F90 | 50 +- src/PDAF_etkf_analysis.F90 | 50 +- src/PDAF_etkf_analysis_T.F90 | 49 +- src/PDAF_etkf_analysis_fixed.F90 | 50 +- src/PDAF_interfaces_module.F90 | 1625 +++++++++++----- src/PDAF_lestkf_analysis.F90 | 2 +- src/PDAF_lestkf_memtime.F90 | 9 +- src/PDAF_letkf_memtime.F90 | 9 +- src/PDAF_lknetf_memtime.F90 | 9 +- src/PDAF_lnetf_memtime.F90 | 9 +- src/PDAF_local_weight.F90 | 12 +- src/PDAF_lseik_analysis_trans.F90 | 2 +- src/PDAF_lseik_memtime.F90 | 9 +- src/PDAF_lseik_resample.F90 | 2 +- src/PDAF_mod_filter.F90 | 4 +- src/PDAF_print_version.F90 | 2 +- src/PDAF_seik_analysis.F90 | 50 +- src/PDAF_seik_analysis_newT.F90 | 50 +- src/PDAF_seik_analysis_trans.F90 | 52 +- src/PDAF_seik_resample.F90 | 2 +- src/PDAF_seik_resample_newT.F90 | 2 +- src/PDAF_timer_mpi.F90 | 153 ++ src/PDAFlocal.F90 | 73 + src/PDAFlocal_assimilate_en3dvar_lestkf.F90 | 155 ++ src/PDAFlocal_assimilate_hyb3dvar_lestkf.F90 | 157 ++ src/PDAFlocal_assimilate_lestkf.F90 | 142 ++ src/PDAFlocal_assimilate_lestkf_si.F90 | 88 + src/PDAFlocal_assimilate_letkf.F90 | 142 ++ src/PDAFlocal_assimilate_letkf_si.F90 | 88 + src/PDAFlocal_assimilate_lknetf.F90 | 149 ++ src/PDAFlocal_assimilate_lknetf_si.F90 | 92 + src/PDAFlocal_assimilate_lnetf.F90 | 139 ++ src/PDAFlocal_assimilate_lnetf_si.F90 | 83 + src/PDAFlocal_assimilate_lseik.F90 | 142 ++ src/PDAFlocal_assimilate_lseik_si.F90 | 88 + src/PDAFlocal_clear_increment_weights.F90 | 48 + src/PDAFlocal_g2l_cb.F90 | 69 + src/PDAFlocal_interfaces.F90 | 881 +++++++++ src/PDAFlocal_l2g_cb.F90 | 78 + src/PDAFlocal_put_state_en3dvar_lestkf.F90 | 248 +++ src/PDAFlocal_put_state_hyb3dvar_lestkf.F90 | 250 +++ src/PDAFlocal_put_state_lestkf.F90 | 216 ++ src/PDAFlocal_put_state_lestkf_si.F90 | 82 + src/PDAFlocal_put_state_letkf.F90 | 216 ++ src/PDAFlocal_put_state_letkf_si.F90 | 82 + src/PDAFlocal_put_state_lknetf.F90 | 232 +++ src/PDAFlocal_put_state_lknetf_si.F90 | 86 + src/PDAFlocal_put_state_lnetf.F90 | 204 ++ src/PDAFlocal_put_state_lnetf_si.F90 | 78 + src/PDAFlocal_put_state_lseik.F90 | 214 ++ src/PDAFlocal_put_state_lseik_si.F90 | 82 + src/PDAFlocal_set_increment_weights.F90 | 59 + src/PDAFlocal_set_indices.F90 | 55 + src/PDAFlocalomi_assimilate.F90 | 139 ++ ...PDAFlocalomi_assimilate_en3dvar_lestkf.F90 | 118 ++ ...omi_assimilate_en3dvar_lestkf_nondiagR.F90 | 118 ++ ...DAFlocalomi_assimilate_hyb3dvar_lestkf.F90 | 121 ++ ...mi_assimilate_hyb3dvar_lestkf_nondiagR.F90 | 122 ++ ...DAFlocalomi_assimilate_lknetf_nondiagR.F90 | 116 ++ ...localomi_assimilate_lknetf_nondiagR_si.F90 | 85 + ...PDAFlocalomi_assimilate_lnetf_nondiagR.F90 | 109 ++ ...Flocalomi_assimilate_lnetf_nondiagR_si.F90 | 82 + src/PDAFlocalomi_assimilate_nondiagR.F90 | 130 ++ src/PDAFlocalomi_assimilate_nondiagR_si.F90 | 81 + src/PDAFlocalomi_assimilate_si.F90 | 81 + src/PDAFlocalomi_put_state.F90 | 124 ++ src/PDAFlocalomi_put_state_en3dvar_lestkf.F90 | 109 ++ ...lomi_put_state_en3dvar_lestkf_nondiagR.F90 | 115 ++ ...PDAFlocalomi_put_state_hyb3dvar_lestkf.F90 | 111 ++ ...omi_put_state_hyb3dvar_lestkf_nondiagR.F90 | 119 ++ ...PDAFlocalomi_put_state_lknetf_nondiagR.F90 | 113 ++ ...Flocalomi_put_state_lknetf_nondiagR_si.F90 | 83 + src/PDAFlocalomi_put_state_lnetf_nondiagR.F90 | 106 + ...AFlocalomi_put_state_lnetf_nondiagR_si.F90 | 80 + src/PDAFlocalomi_put_state_nondiagR.F90 | 125 ++ src/PDAFlocalomi_put_state_nondiagR_si.F90 | 79 + src/PDAFlocalomi_put_state_si.F90 | 79 + src/PDAFomi.F90 | 1 + src/PDAFomi_assimilate_3dvar_nondiagR.F90 | 103 + src/PDAFomi_assimilate_en3dvar_estkf.F90 | 9 +- ...Fomi_assimilate_en3dvar_estkf_nondiagR.F90 | 105 + ...omi_assimilate_en3dvar_lestkf_nondiagR.F90 | 119 ++ src/PDAFomi_assimilate_enkf_nondiagR.F90 | 101 + src/PDAFomi_assimilate_enkf_nondiagR_si.F90 | 77 + src/PDAFomi_assimilate_global_nondiagR.F90 | 118 ++ src/PDAFomi_assimilate_global_nondiagR_si.F90 | 76 + ...omi_assimilate_hyb3dvar_estkf_nondiagR.F90 | 109 ++ ...mi_assimilate_hyb3dvar_lestkf_nondiagR.F90 | 123 ++ src/PDAFomi_assimilate_lenkf_nondiagR.F90 | 97 + src/PDAFomi_assimilate_lenkf_nondiagR_si.F90 | 78 + src/PDAFomi_assimilate_lknetf_nondiagR.F90 | 117 ++ src/PDAFomi_assimilate_lknetf_nondiagR_si.F90 | 86 + src/PDAFomi_assimilate_lnetf_nondiagR.F90 | 110 ++ src/PDAFomi_assimilate_lnetf_nondiagR_si.F90 | 83 + src/PDAFomi_assimilate_local_nondiagR.F90 | 131 ++ src/PDAFomi_assimilate_local_nondiagR_si.F90 | 82 + src/PDAFomi_assimilate_nonlin_nondiagR.F90 | 105 + src/PDAFomi_assimilate_nonlin_nondiagR_si.F90 | 76 + src/PDAFomi_dim_obs_l.F90 | 1733 +++++++++++++++++ src/PDAFomi_obs_l.F90 | 194 +- src/PDAFomi_put_state_3dvar.F90 | 1 + src/PDAFomi_put_state_3dvar_nondiagR.F90 | 102 + ...AFomi_put_state_en3dvar_estkf_nondiagR.F90 | 103 + ...Fomi_put_state_en3dvar_lestkf_nondiagR.F90 | 116 ++ src/PDAFomi_put_state_enkf_nondiagR.F90 | 99 + src/PDAFomi_put_state_enkf_nondiagR_si.F90 | 75 + src/PDAFomi_put_state_global_nondiagR.F90 | 116 ++ src/PDAFomi_put_state_global_nondiagR_si.F90 | 74 + ...Fomi_put_state_hyb3dvar_estkf_nondiagR.F90 | 107 + ...omi_put_state_hyb3dvar_lestkf_nondiagR.F90 | 120 ++ src/PDAFomi_put_state_lenkf_nondiagR.F90 | 94 + src/PDAFomi_put_state_lenkf_nondiagR_si.F90 | 76 + src/PDAFomi_put_state_lknetf_nondiagR.F90 | 114 ++ src/PDAFomi_put_state_lknetf_nondiagR_si.F90 | 84 + src/PDAFomi_put_state_lnetf_nondiagR.F90 | 107 + src/PDAFomi_put_state_lnetf_nondiagR_si.F90 | 81 + src/PDAFomi_put_state_local_nondiagR.F90 | 126 ++ src/PDAFomi_put_state_local_nondiagR_si.F90 | 80 + src/PDAFomi_put_state_nonlin_nondiagR.F90 | 101 + src/PDAFomi_put_state_nonlin_nondiagR_si.F90 | 74 + 131 files changed, 15732 insertions(+), 749 deletions(-) create mode 100644 external/SANGOMA/SANGOMA_quicksort.F90 create mode 100644 external/SANGOMA/SANGOMA_quicksort.o create mode 100755 external/mkdepends/mkdepends create mode 100644 src/.ipynb_checkpoints/PDAF_reset_dim_p-checkpoint.F90 create mode 100644 src/.ipynb_checkpoints/PDAF_reset_forget-checkpoint.F90 create mode 100644 src/PDAF_correlation_function.F90 create mode 100644 src/PDAF_timer_mpi.F90 create mode 100644 src/PDAFlocal.F90 create mode 100644 src/PDAFlocal_assimilate_en3dvar_lestkf.F90 create mode 100644 src/PDAFlocal_assimilate_hyb3dvar_lestkf.F90 create mode 100644 src/PDAFlocal_assimilate_lestkf.F90 create mode 100644 src/PDAFlocal_assimilate_lestkf_si.F90 create mode 100644 src/PDAFlocal_assimilate_letkf.F90 create mode 100644 src/PDAFlocal_assimilate_letkf_si.F90 create mode 100644 src/PDAFlocal_assimilate_lknetf.F90 create mode 100644 src/PDAFlocal_assimilate_lknetf_si.F90 create mode 100644 src/PDAFlocal_assimilate_lnetf.F90 create mode 100644 src/PDAFlocal_assimilate_lnetf_si.F90 create mode 100644 src/PDAFlocal_assimilate_lseik.F90 create mode 100644 src/PDAFlocal_assimilate_lseik_si.F90 create mode 100644 src/PDAFlocal_clear_increment_weights.F90 create mode 100644 src/PDAFlocal_g2l_cb.F90 create mode 100644 src/PDAFlocal_interfaces.F90 create mode 100644 src/PDAFlocal_l2g_cb.F90 create mode 100644 src/PDAFlocal_put_state_en3dvar_lestkf.F90 create mode 100644 src/PDAFlocal_put_state_hyb3dvar_lestkf.F90 create mode 100644 src/PDAFlocal_put_state_lestkf.F90 create mode 100644 src/PDAFlocal_put_state_lestkf_si.F90 create mode 100644 src/PDAFlocal_put_state_letkf.F90 create mode 100644 src/PDAFlocal_put_state_letkf_si.F90 create mode 100644 src/PDAFlocal_put_state_lknetf.F90 create mode 100644 src/PDAFlocal_put_state_lknetf_si.F90 create mode 100644 src/PDAFlocal_put_state_lnetf.F90 create mode 100644 src/PDAFlocal_put_state_lnetf_si.F90 create mode 100644 src/PDAFlocal_put_state_lseik.F90 create mode 100644 src/PDAFlocal_put_state_lseik_si.F90 create mode 100644 src/PDAFlocal_set_increment_weights.F90 create mode 100644 src/PDAFlocal_set_indices.F90 create mode 100644 src/PDAFlocalomi_assimilate.F90 create mode 100644 src/PDAFlocalomi_assimilate_en3dvar_lestkf.F90 create mode 100644 src/PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR.F90 create mode 100644 src/PDAFlocalomi_assimilate_hyb3dvar_lestkf.F90 create mode 100644 src/PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR.F90 create mode 100644 src/PDAFlocalomi_assimilate_lknetf_nondiagR.F90 create mode 100644 src/PDAFlocalomi_assimilate_lknetf_nondiagR_si.F90 create mode 100644 src/PDAFlocalomi_assimilate_lnetf_nondiagR.F90 create mode 100644 src/PDAFlocalomi_assimilate_lnetf_nondiagR_si.F90 create mode 100644 src/PDAFlocalomi_assimilate_nondiagR.F90 create mode 100644 src/PDAFlocalomi_assimilate_nondiagR_si.F90 create mode 100644 src/PDAFlocalomi_assimilate_si.F90 create mode 100644 src/PDAFlocalomi_put_state.F90 create mode 100644 src/PDAFlocalomi_put_state_en3dvar_lestkf.F90 create mode 100644 src/PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR.F90 create mode 100644 src/PDAFlocalomi_put_state_hyb3dvar_lestkf.F90 create mode 100644 src/PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR.F90 create mode 100644 src/PDAFlocalomi_put_state_lknetf_nondiagR.F90 create mode 100644 src/PDAFlocalomi_put_state_lknetf_nondiagR_si.F90 create mode 100644 src/PDAFlocalomi_put_state_lnetf_nondiagR.F90 create mode 100644 src/PDAFlocalomi_put_state_lnetf_nondiagR_si.F90 create mode 100644 src/PDAFlocalomi_put_state_nondiagR.F90 create mode 100644 src/PDAFlocalomi_put_state_nondiagR_si.F90 create mode 100644 src/PDAFlocalomi_put_state_si.F90 create mode 100644 src/PDAFomi_assimilate_3dvar_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_en3dvar_estkf_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_en3dvar_lestkf_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_enkf_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_enkf_nondiagR_si.F90 create mode 100644 src/PDAFomi_assimilate_global_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_global_nondiagR_si.F90 create mode 100644 src/PDAFomi_assimilate_hyb3dvar_estkf_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_lenkf_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_lenkf_nondiagR_si.F90 create mode 100644 src/PDAFomi_assimilate_lknetf_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_lknetf_nondiagR_si.F90 create mode 100644 src/PDAFomi_assimilate_lnetf_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_lnetf_nondiagR_si.F90 create mode 100644 src/PDAFomi_assimilate_local_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_local_nondiagR_si.F90 create mode 100644 src/PDAFomi_assimilate_nonlin_nondiagR.F90 create mode 100644 src/PDAFomi_assimilate_nonlin_nondiagR_si.F90 create mode 100644 src/PDAFomi_dim_obs_l.F90 create mode 100644 src/PDAFomi_put_state_3dvar_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_en3dvar_estkf_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_en3dvar_lestkf_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_enkf_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_enkf_nondiagR_si.F90 create mode 100644 src/PDAFomi_put_state_global_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_global_nondiagR_si.F90 create mode 100644 src/PDAFomi_put_state_hyb3dvar_estkf_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_hyb3dvar_lestkf_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_lenkf_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_lenkf_nondiagR_si.F90 create mode 100644 src/PDAFomi_put_state_lknetf_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_lknetf_nondiagR_si.F90 create mode 100644 src/PDAFomi_put_state_lnetf_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_lnetf_nondiagR_si.F90 create mode 100644 src/PDAFomi_put_state_local_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_local_nondiagR_si.F90 create mode 100644 src/PDAFomi_put_state_nonlin_nondiagR.F90 create mode 100644 src/PDAFomi_put_state_nonlin_nondiagR_si.F90 diff --git a/external/SANGOMA/SANGOMA_quicksort.F90 b/external/SANGOMA/SANGOMA_quicksort.F90 new file mode 100644 index 000000000..885688329 --- /dev/null +++ b/external/SANGOMA/SANGOMA_quicksort.F90 @@ -0,0 +1,273 @@ +module SANGOMA_quicksort + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! Time-stamp: <2014-11-19 17:57:23 vetra-carvalho> +!!! +!!! Subsection of subroutines needed for the equivalent weights +!!! particle filter code supplied for SANGOMA project by +!!! Sanita Vetra-Carvalho. +!!! +!!! This code was taken from http://rosettacode.org/wiki/Quicksort#Fortran +!!! and is distributed under GNU Free Documentation License 1.2. +!!! see http://www.gnu.org/licenses/fdl-1.2.html and was modified to also return +!!! sorted index of the original array a. +!!! +!!! Collection of subroutines to sort and return a one-dimensional array +!!! as well as corresponding sorted index of the array a. +!!! Copyright (C) 2014 S. Vetra-Carvalho +!!! +!!! This program is free software: you can redistribute it and/or modify +!!! it under the terms of the GNU General Public License as published by +!!! the Free Software Foundation, either version 3 of the License, or +!!! (at your option) any later version. +!!! +!!! This program is distributed in the hope that it will be useful, +!!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!!! GNU General Public License for more details. +!!! +!!! You should have received a copy of the GNU General Public License +!!! along with this program. If not, see . +!!! +!!! Email: s.vetra-carvalho @ reading.ac.uk +!!! Mail: School of Mathematical and Physical Sciences, +!!! University of Reading, +!!! Reading, UK +!!! RG6 6BB +!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +contains + +!> subroutine to sort using the quicksort algorithm +!! @param[in,out] a, an array of doubles to be sorted +!! @param[in] na, dimension of the array a + + recursive subroutine quicksort_d(a,na) + + implicit none + + ! DUMMY ARGUMENTS + integer, intent(in) :: na ! nr or items to sort + real, dimension(nA), intent(inout) :: a ! vector to be sorted + + ! LOCAL VARIABLES + integer :: left, right, mid + real :: pivot, temp + integer :: marker + + if (nA > 1) then + ! insertion sort limit of 47 seems best for sorting 10 million + ! integers on Intel i7-980X CPU. Derived data types that use + ! more memory are optimized with smaller values - around 20 for a 16 + ! -byte type. + if (nA > 47) then + ! Do quicksort for large groups + ! Get median of 1st, mid, & last points for pivot (helps reduce + ! long execution time on some data sets, such as already + ! sorted data, over simple 1st point pivot) + mid = (nA+1)/2 + if (a(mid) >= a(1)) then + if (a(mid) <= a(nA)) then + pivot = a(mid) + else if (a(nA) > a(1)) then + pivot = a(nA) + else + pivot = a(1) + end if + else if (a(1) <= a(nA)) then + pivot = a(1) + else if (a(nA) > a(mid)) then + pivot = a(nA) + else + pivot = a(mid) + end if + + left = 0 + right = nA + 1 + + do while (left < right) + right = right - 1 + do while (A(right) > pivot) + right = right - 1 + end do + left = left + 1 + do while (A(left) < pivot) + left = left + 1 + end do + if (left < right) then + temp = A(left) + A(left) = A(right) + A(right) = temp + end if + end do + + if (left == right) then + marker = left + 1 + else + marker = left + end if + + call quicksort_d(A(:marker-1),marker-1) + call quicksort_d(A(marker:),nA-marker+1) + + else + call InsertionSort_d(A,nA) ! Insertion sort for small groups is faster than Quicksort + end if + end if + + end subroutine quicksort_d + + +!> subroutine to sort using the insertionsort algorithm and return indecies +!! @param[in,out] a, an array of doubles to be sorted +!! @param[in] na, dimension of the array a + subroutine InsertionSort_d(a,na) + + ! DUMMY ARGUMENTS + integer, intent(in) :: na !< nr or items to sort + real, dimension(nA), intent(inout) :: a !< vector to be sorted + + ! LOCAL VARIABLES + real :: temp + integer :: i, j + + do i = 2, nA + j = i - 1 + temp = A(i) + do + if (j == 0) exit + if (a(j) <= temp) exit + A(j+1) = A(j) + j = j - 1 + end do + a(j+1) = temp + end do + + end subroutine InsertionSort_d + +!--------------------------------------------------------------------------- +!> Quicksort for real and index array vectors +!! + recursive subroutine quicksort_idx_d(a,idx_a,na) + + implicit none + + ! DUMMY ARGUMENTS + integer, intent(in) :: na !< nr or items to sort + real, dimension(nA), intent(inout) :: a !< vector to be sorted + integer, dimension(nA), intent(inout) :: idx_a !< sorted indecies of a + + ! LOCAL VARIABLES + integer :: left, right, mid + real :: pivot, temp + integer :: marker, idx_temp + integer :: i ! counter + + + ! If this is the original call of the quicksort_d function + ! assign indecies to the array that we are sorting + if (sum(idx_a) .eq. 0) then + do i = 1,na + idx_a(i) = 1 + end do + end if + + if (nA > 1) then + ! insertion sort limit of 47 seems best for sorting 10 million + ! integers on Intel i7-980X CPU. Derived data types that use + ! more memory are optimized with smaller values - around 20 for a 16 + ! -byte type. + if (nA > 47) then + ! Do quicksort for large groups + ! Get median of 1st, mid, & last points for pivot (helps reduce + ! long execution time on some data sets, such as already + ! sorted data, over simple 1st point pivot) + mid = (nA+1)/2 + if (a(mid) >= a(1)) then + if (a(mid) <= a(nA)) then + pivot = a(mid) + else if (a(nA) > a(1)) then + pivot = a(nA) + else + pivot = a(1) + end if + else if (a(1) <= a(nA)) then + pivot = a(1) + else if (a(nA) > a(mid)) then + pivot = a(nA) + else + pivot = a(mid) + end if + + left = 0 + right = nA + 1 + + do while (left < right) + right = right - 1 + do while (A(right) > pivot) + right = right - 1 + end do + left = left + 1 + do while (A(left) < pivot) + left = left + 1 + end do + if (left < right) then + temp = A(left) + idx_temp = idx_a(left) + A(left) = A(right) + idx_a(left) = idx_a(right) + A(right) = temp + idx_a(right) = idx_temp + end if + end do + + if (left == right) then + marker = left + 1 + else + marker = left + end if + + call quicksort_idx_d(A(:marker-1),idx_A(:marker-1),marker-1) + call quicksort_idx_d(A(marker:),idx_A(marker:),nA-marker+1) + + else + call InsertionSort_idx_d(A,idx_a,nA) ! Insertion sort for small groups is faster than Quicksort + end if + end if + + end subroutine quicksort_idx_d + + +!> subroutine to sort using the insertionsort algorithm and return indecies +!! @param[in,out] a, an array of doubles to be sorted +!! @param[in,out] idx_a, an array of integers of sorted indecies +!! @param[in] na, dimension of the array a + subroutine InsertionSort_idx_d(a,idx_a,na) + + ! DUMMY ARGUMENTS + integer, intent(in) :: na !< nr or items to sort + real, dimension(nA), intent(inout) :: a !< vector to be sorted + integer, dimension(nA), intent(inout) :: idx_a !< sorted indecies of a + + ! LOCAL VARIABLES + real :: temp + integer :: i, j + + do i = 2, nA + j = i - 1 + temp = A(i) + do + if (j == 0) exit + if (a(j) <= temp) exit + A(j+1) = A(j) + idx_a(j+1) = idx_a(j) + j = j - 1 + end do + a(j+1) = temp + idx_a(j+1) = i + end do + + end subroutine InsertionSort_idx_d + +end module SANGOMA_quicksort diff --git a/external/SANGOMA/SANGOMA_quicksort.o b/external/SANGOMA/SANGOMA_quicksort.o new file mode 100644 index 0000000000000000000000000000000000000000..f9987538030f1282cce56e7670dff96b5ebeda36 GIT binary patch literal 4048 zcmdT`eQaA-6@SlhQ>XK6cM76nm0BQznq?-@f~Z-A@*KN;cYUs^bzS$-VWm#OLcU6D zlZ>)9)k`Z~r7yFlDXS*du}Lr?fdoQGV}Rsm$4%oj4NF+kEK;Mjq@772$*7ta>gI9I z`=}k$0D`}`((}Fdcg{Wc+;h+QU7rXDyDcosn2lw=$>e7y$}sT<^W$1=Sj&`wW~xbR z9_O}R4ecux71r5*#KJHKxkKF3+(GWC1N%kgtIpFYP~fHgEKfh+#gA9hcU;0N3jBUH zz2eC@UzK5acnE-3htn%N+aGvO;+J32EyrC$+GF>fxrQd;Si-eauxpLR48z zgJ!a8VYgIM#(5{5(&G?@AUgsIn}rbtjBa)bbb7v@7Za<$!4UC7$yHTV1JwzhuFijv zxF>@2qhNR(SNNwCUOaE(Rhd^a#49^{eQ1u#gpLsLT8^j*+}S^7BcfuBc)9n{B6mAc z68$|{o>}Xk{R+4yN6u-kT(J>#gr_3{I}^J)9}iTI;{~iak9|_pKcMMP+HfObQqi!z zh}kD~Xi)0X@lR1IT2<$}cC)sDRxEDBe$WM1w@btQ_A`aS~=MHl(aNpuWFQl5{e7KYs6^rxCqY%IY>)g$k z^}E4*S@(W!f&>5C{k)+C?f>O|o=-Wq`5C6qaw_5Mf2RbZPi6k($BL?+i2Bki3yJD+ zj92>Zs&#-DlQ!O)>HKu?+RI*6N1w{;Ca@B7fMfBgd13Uf{iQY}0%>R0SGf zd?n?lA=w3QB6cfJ2)uZ6%c=1g$DbOGexZ7N@aoIYY`_d?ilC9@N&o+}r^sHq!Jv@-pNGPe1(9d8`Bgy4?OA!f03rOfaU>F{FieH`y(pe(kuo8MZ=w2oA zwGD)-LH8`76PO?1x=WbVn8Yczf}7e|W|g|W)^kc7Z9SLUCsjO5)QiAcM9i_VOW9{Z z>)w3=y98;bAYKq$`;Xyt$|GyFjQ z(HASIpy2A9uA%c=jV@h8=`EDPbCHBVjW|yo1Mjk*f&q=^evShmxgTqNCi^DzfohfW z&I7Xz)k*e^z;2t=3?22eAJV5P?7W0O$ZWR>9SqX60H`aibQLokk!nuE6OjwJZwA~s z|04|*E>0cv(}oHg+OU~)w;EOs43zXd70 zRLPR)uYkLWeA7afuLS8Fk>?;umV@pEBL4}JLJISxdZx&p4EZvx<;zR>Mhnw6uCMYeM_bQY@sEHot>?>& zD6~&=eXVD69IZU7%k&rUkiJksp@J)Ox>U~`55rFBAR^VIa%l!^VF9Nrvrqu@Bof+TtK^0k&0>=z2I5 z;HxsQb|eA8;qp1Q_#E4PjvYQn73bK=Icmj?XG*0F{nl4XPFqTX7R0JFIcR~di*wjg z7e_CRooBXyi5|lq{@Y>pIb5Qpq>=><-0O#i>=*DlFqXD|+RX3Rzh<)?CF^g7_V9_t zmNE7!@_mi1pR((Dt=m}d_bv#m%#wOPc?p9-Tib4FQ|np~W)tu|RG^P8WBVn1h~xcW z)9wNKKKKytF}Bd+30R|nCoqQ4v{*v_IDDvobR(ihOrYnD_2>~ki8)AqY%S~HPZ+MF z7`HI>zhc-$F%C`qxpnaEpo0zV7+Y!c8tpfao9FH=!p(F4s0cUDy;y{s=Vm;ejji>b zXk&Mj@w9hD8$EmW9egwrtq->tqQ)0PO`Y{^jf^J}?TpqRf&Qg7>?8H<-|lFu4}CY* z9BzqpbVfsMM?=l+k;cwwb4R-dG&gjI8bbHi%rE;_T5Ik7dt3L@@Pyzf9S!x-dQUhK ztzkSu-G1^|sETQB>aKb&*cFUPgM`+>2qk?!{- z=G^S@n8jy8<(?wHO#{WcpV!wPEv$jU^*f6enEspgkhAZ1ewz{h!t-N{&GqK_9|Np- VZ?yg1Cj4cX%X+7s5%(!x{}1lWQWpRK literal 0 HcmV?d00001 diff --git a/external/mkdepends/mkdepends b/external/mkdepends/mkdepends new file mode 100755 index 000000000..69f2e8442 --- /dev/null +++ b/external/mkdepends/mkdepends @@ -0,0 +1,272 @@ +#!/usr/bin/perl +use Cwd; +use File::Basename; +# +# This script was found in the NCAR HAO TIE-GCM 2.0 +# +# Make dependencies for gmake. This script outputs the file "Depends", +# which is included in the Makefile. (sub mksrcfiles also outputs local +# file Srcfiles, which is also referred to by Makefile) +# +# AC 06.11.2019: regex is case-insensitive for search of 'use' keyword. +# AC 26.10.2021: last argument is build path +# AC 05.06.2024: ignore case in findmember +# +$date = `date`; chop($date); +$cwd = cwd(); +($prog = $0) =~ s!(.*)/!!; +print STDERR "\n"; +# +my $argc = @ARGV; +for (my $i = 0; $i < $argc-1; $i++) { + $dir = @ARGV[$i]; + push(@file_paths,$dir); +} +$build =@ARGV[$argc-1]; +print "build dir is: $build\n"; +# while (@ARGV) { +# +# $dir = shift(); +# push(@file_paths,$dir); +# } +print "$prog: file_paths = "; foreach $dir (@file_paths) { print "$dir"; } +print "\n"; +# +# Make list of source files (returns src list and makes file ./Srcfiles): +# + %src = &mksrcfiles(@file_paths); +# +# Output file: +# +$outfile_depends = "Depends"; +open(DEPENDS, "> $outfile_depends") or + die "$prog: Can't open output file $outfile_depends\n"; +# +# Get list of all modules declared: +# +%modules = (); +foreach $file (sort keys %src) { + $srcfile = "$src{$file}/$file"; # full path + open(SRCFILE,"< $srcfile") || die "Error opening source file $srcfile\n"; + while () { + if (/^\s*(?i)module (.*)/) { + $modules{$srcfile} .= $1 . ' '; + } + } +# print "modules in srcfile $srcfile:\n $modules{$srcfile}\n"; +} +# +# Build dependencies for each source file: +# +foreach $file (sort keys %src) { + $srcdir = $src{$file}; # directory + $srcfile = "$srcdir/$file"; # full path + $object = "$build/$file"; $object =~ s/\.[fF]$/\.o/; + $object =~ s/\.f90$/\.o/; # for freeform *.f90 source files + $object =~ s/\.F90$/\.o/; # for freeform *.F90 source files that need preprocessor + + undef(@module_deps); # module dependencies for each source file + undef(@include_deps); # include dependencies for each source file + undef(@file_deps); # file dependencies for each source file +# +# Read source file, building list of modules used and files included: +# + open(SRCFILE,"< $srcfile") || die "Error opening source file $srcfile\n"; + while () { +# +# Build list of modules used by this source: + if (/^\s*(?i)use (\w*)/) { + $module = $1; + if ($module =~ /(\w*[^,])[,]/) { $module = $1; } + if (&findmember($module,@module_deps) < 0) { + push(@module_deps,$module); + } + } # use statement +# +# Check for include statements: +# +# Fortran style include statement: + if ( /^\s+include\s+[<"'](.*)[>"']/ ) { + $hdrfile = $1; + $hdrfile = "$src{$hdrfile}/$hdrfile"; + if (&findmember($hdrfile,@include_deps) < 0) { + push(@include_deps,$hdrfile); + } + } +# +# cpp style include statement: + if ( /^#include\s+[<"'](.*)[>"']/ ) { + $hdrfile = $1; + $hdrfile = "$src{$hdrfile}/$hdrfile"; + if (&findmember($hdrfile,@include_deps) < 0) { + push(@include_deps,$hdrfile); + } + } + } # while () + +# print "\nmodule_deps for $srcfile:\n"; +# print " @module_deps\n"; +# +# Find file dependencies: +# + push(@file_deps,$srcfile); # first file dep is its own source file +# +# Add object files containing modules used by the source file: +# + if (@module_deps) { + foreach $module (@module_deps) { + undef($filedep); + foreach $filename (sort keys %src) { + $filepath = "$src{$filename}/$filename"; + @modules_in_src = split(' ',$modules{$filepath}); + if (&findmember($module,@modules_in_src) >= 0) { + $filedep = "$build/$filename"; + $filedep =~ s/\.[fF]$/\.o/; + $filedep =~ s/\.F90$/\.o/; # for freeform *.F90 files + $filedep =~ s/\.f90$/\.o/; # for freeform *.f90 files + push(@file_deps,$filedep); + } + } + if (! $filedep) { +# print STDERR "WARNING: could not find module $module (used by source file $filepath)\n"; + } + } + } # if @module_deps +# print "file_deps for srcfile $srcfile:\n @file_deps\n"; +# +# Add included header files to list of file dependencies: +# + if (@include_deps) { + foreach $hdrfile (@include_deps) { + if (-e $hdrfile) { + push(@file_deps,$hdrfile); + } else { +# print STDERR "WARNING: could not find header file $hdrfile (included by source file $srcfile)\n"; + } + } + } + + close($srcfile); +# +# Remove any "self" (redundant) dependencies, +# (i.e., file.o not a dependency of file.o). +# This avoids circular dependency warnings from the compiler. +# + undef(@deps_final); # final file dependencies for each source file + foreach $dep (@file_deps) { + if ($dep ne $object and basename($dep) ne $object) { + push(@deps_final,$dep); + } + } + +# print "----------------------------------------------------------------\n"; +# print "File = $file\n"; +# print "Path = $srcfile\n"; +# print "Object = $object\n"; +# print "\n"; +# print "Include dependencies = @include_deps\n"; +# print "Module dependencies = @module_deps\n"; +# print "File dependencies = @file_deps\n"; + +# +# Write Depends file: + print DEPENDS "$object: @deps_final\n"; +# print "$object: @deps_final\n"; + +} # each source file + +# print STDERR "$prog: Wrote dependency file $outfile_depends\n"; +# +# Write Srcfiles file: +# foreach $file (sort keys %src) { print SRCFILES "$file\n"; } +# print "$prog: Wrote source list file $outfile_srcs\n"; +# print STDERR "\n"; + +exit; + +#------------------------------------------------------------------------- +sub findmember { +# +# Given a string $member, and a list @list, search for $member in @list +# and if found return index of $member in @list, otherwise return -1: +# +# (Note this routine also in $TGCMROOT/bin/util.pl) +# + local ($member,@list) = @_; + local ($offset); + $offset = 0; + foreach $ele (@list) { + if (lc($ele) eq lc($member)) { + return $offset + } + $offset++; + } + $offset = -1; + return $offset; +} +#------------------------------------------------------------------------- +sub usage { +die < $outfile_srcs") or + die "$prog: Can't open output file $outfile_srcs\n"; +# +# Make list of source files (*.F, *.c, *.F90): +# (header files are not included in SRCFILES) +# + %src = (); + foreach $dir (@paths) { + $nfiles = 0; + @filenames = (glob("$dir/*.[Ffc]"), glob("$dir/*.F90"), glob("$dir/*.f90")); + foreach $filename (@filenames) { + $file = basename($filename); + if ($file =~ /^,/) { + print "$prog: Not using comma-prefixed source file $filename\n"; + } else { + $filename =~ s!.*/!!; # remove part before last slash + if (! $src{$filename}) { + $src{$filename} = "$dir"; # use first occurrence + $nfiles = $nfiles+1; + } + } + } + print STDERR "$prog: Found $nfiles source files in $dir\n"; + } + print STDERR "\n"; + foreach $file (sort keys %src) { print SRCFILES "$file\n"; } + close SRCFILES; +# +# Add list of header files (*.h) to %src for the rest of mkdepends: +# + foreach $dir (@paths) { + $nhdrs = 0; + @hdrnames = glob("$dir/*.h"); + foreach $hdrname (@hdrnames) { + $file = basename($hdrname); + if ($file =~ /^,/) { + print "$prog: Not using comma-prefixed header file $hdrname\n"; + } else { + $hdrname =~ s!.*/!!; # remove part before last slash + if (! $src{$hdrname}) { + $src{$hdrname} = "$dir"; # use first occurrence + $nhdrs = $nhdrs+1; + } + } + } + print STDERR "$prog: Found $nhdrs header files in $dir\n"; + } # foreach $dir (@paths) + print STDERR "\n"; + return %src; +} diff --git a/src/.ipynb_checkpoints/PDAF_reset_dim_p-checkpoint.F90 b/src/.ipynb_checkpoints/PDAF_reset_dim_p-checkpoint.F90 new file mode 100644 index 000000000..de7a7324b --- /dev/null +++ b/src/.ipynb_checkpoints/PDAF_reset_dim_p-checkpoint.F90 @@ -0,0 +1,128 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAF_reset_dim_p --- Reset state dimension and re-allocate state and ensemble +! +! !INTERFACE: +SUBROUTINE PDAF_reset_dim_p(dim_p_in, outflag) + +! !DESCRIPTION: +! Reset state dimension and re-allocate the state vector +! and ensemble array. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-02 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE mpi +! USE PDAF_memcounting, & +! ONLY: PDAF_memcount + USE PDAF_mod_filter, & + ONLY: screen, incremental, dim_ens, dim_p, & + state, state_inc, eofV + USE PDAF_mod_filtermpi, & + ONLY: mype, mype_model, filterpe, dim_ens_l, task_id, & + COMM_couple + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(in) :: dim_p_in ! Sub-type of filter + INTEGER, INTENT(inout):: outflag ! Status flag + +! !CALLING SEQUENCE: +! Called by: PDAF_alloc_filters +! Calls: PDAF_memcount +!EOP + +! *** local variables *** + INTEGER :: allocstat ! Status for allocate + + +! ************************************ +! *** Reset state vector dimension *** +! ************************************ + + dim_p = dim_p_in + + +! ********************************* +! *** Re-allocate filter fields *** +! ********************************* + + ! Initialize status flag + outflag = 0 + + on_filterpe: IF (filterpe) THEN + ! Allocate all arrays and full ensemble matrix on Filter-PEs + + IF (ALLOCATED(state)) DEALLOCATE(state) + ALLOCATE(state(dim_p), stat = allocstat) + IF (allocstat /= 0) THEN + WRITE (*,'(5x, a)') 'PDAF-ERROR(20): error in re-allocation of STATE' + outflag = 20 + END IF + + IF (incremental == 1) THEN + IF (ALLOCATED(state_inc)) DEALLOCATE(state_inc) + ALLOCATE(state_inc(dim_p), stat = allocstat) + IF (allocstat /= 0) THEN + WRITE (*,'(5x, a)') 'PDAF-ERROR(20): error in allocation of STATE_INC' + outflag = 20 + END IF + + state_inc = 0.0 + END IF + + ! Allocate full ensemble on filter-PEs + IF (ALLOCATED(eofV)) DEALLOCATE(eofV) + ALLOCATE(eofV(dim_p, dim_ens), stat = allocstat) + IF (allocstat /= 0) THEN + WRITE (*,'(5x, a)') 'PDAF-ERROR(20): error in allocation of eofV' + outflag = 20 + END IF + + IF (screen > 2) WRITE (*,*) 'PDAF: reset_dim_p - re-allocate eofV of size ', & + dim_ens, ' on pe(f) ', mype + + ELSE on_filterpe + ! Model-PEs that are not Filter-PEs only need an array for the local ensemble + ! if they participate in the coupling communication + + ! Allocate partial ensemble on model-only PEs that do coupling communication + IF (COMM_couple /= MPI_COMM_NULL) THEN + IF (ALLOCATED(eofV)) DEALLOCATE(eofV) + ALLOCATE(eofV(dim_p, dim_ens_l), stat = allocstat) + IF (allocstat /= 0) THEN + WRITE (*,'(5x, a)') 'PDAF-ERROR(20): error in allocation of eofV on model-pe' + outflag = 20 + END IF + + IF (screen > 2) WRITE (*,*) 'PDAF: reset_dim_p - re-allocate eofV of size ', & + dim_ens_l, ' on pe(m) ', mype_model, ' of model task ',task_id + END IF + + END IF on_filterpe + +END SUBROUTINE PDAF_reset_dim_p diff --git a/src/.ipynb_checkpoints/PDAF_reset_forget-checkpoint.F90 b/src/.ipynb_checkpoints/PDAF_reset_forget-checkpoint.F90 new file mode 100644 index 000000000..829d7cc2e --- /dev/null +++ b/src/.ipynb_checkpoints/PDAF_reset_forget-checkpoint.F90 @@ -0,0 +1,62 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAF_reset_forget --- Manually reset forgetting factor +! +! !INTERFACE: +SUBROUTINE PDAF_reset_forget(forget_in) + +! !DESCRIPTION: +! Helper routine for PDAF. +! The routine allows to manually set the forgetting +! factor to a new value. Usually this should be called +! in assimilate_pdaf before calling the analysis step +! routine. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2021-05 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, & + ONLY: localfilter, forget, forget_l, inloop + + IMPLICIT NONE + +! !ARGUMENTS: + REAL,INTENT(in) :: forget_in ! New value of forgetting factor +!EOP + +! *** Set forgetting factor *** + + IF (localfilter == 0) THEN + forget = forget_in + ELSE + IF (inloop) THEN + forget_l = forget_in + ELSE + forget = forget_in + END IF + END IF + +END SUBROUTINE PDAF_reset_forget diff --git a/src/Makefile b/src/Makefile index 2196a39f4..d5ab4fa9b 100644 --- a/src/Makefile +++ b/src/Makefile @@ -21,13 +21,14 @@ include ../make.arch/$(PDAF_ARCH).h ###################################################### # Modules used in PDAF -MOD_PDAF = PDAF_timer.o \ +MOD_PDAF = PDAF_timer_mpi.o \ PDAF_memcount.o \ PDAF_mod_filtermpi.o \ PDAF_mod_filter.o # Module file with interface definitions -MOD_INTERFACE = PDAF_interfaces_module.o +MOD_INTERFACE = PDAFlocal_interfaces.o \ + PDAF_interfaces_module.o # Generic routines in PDAF OBJ_PDAF_GEN = PDAF_analysis_utils.o \ @@ -87,18 +88,46 @@ OBJ_PDAF_GEN = PDAF_analysis_utils.o \ PDAF_inflate_weights.o \ PDAFomi_put_state_global.o \ PDAFomi_put_state_global_si.o \ + PDAFomi_put_state_global_nondiagR.o \ + PDAFomi_put_state_global_nondiagR_si.o \ + PDAFomi_put_state_nonlin_nondiagR.o \ + PDAFomi_put_state_nonlin_nondiagR_si.o \ PDAFomi_put_state_local.o \ PDAFomi_put_state_local_si.o \ + PDAFomi_put_state_local_nondiagR.o \ + PDAFomi_put_state_local_nondiagR_si.o \ PDAFomi_assimilate_global.o \ PDAFomi_assimilate_global_si.o \ + PDAFomi_assimilate_global_nondiagR.o \ + PDAFomi_assimilate_global_nondiagR_si.o \ + PDAFomi_assimilate_nonlin_nondiagR.o \ + PDAFomi_assimilate_nonlin_nondiagR_si.o \ PDAFomi_assimilate_local.o \ PDAFomi_assimilate_local_si.o \ + PDAFomi_assimilate_local_nondiagR.o \ + PDAFomi_assimilate_local_nondiagR_si.o \ PDAF_reset_forget.o \ PDAF_get_ensstats.o \ PDAF_set_debug_flag.o \ PDAF_set_offline_mode.o \ + PDAFlocal.o \ + PDAFlocal_set_indices.o \ + PDAFlocal_set_increment_weights.o \ + PDAFlocal_clear_increment_weights.o \ + PDAFlocal_g2l_cb.o \ + PDAFlocal_l2g_cb.o \ + PDAFlocalomi_assimilate.o \ + PDAFlocalomi_assimilate_nondiagR.o \ + PDAFlocalomi_assimilate_nondiagR_si.o \ + PDAFlocalomi_assimilate_si.o \ + PDAFlocalomi_put_state.o \ + PDAFlocalomi_put_state_nondiagR.o \ + PDAFlocalomi_put_state_nondiagR_si.o \ + PDAFlocalomi_put_state_si.o \ + PDAF_correlation_function.o \ PDAF_reset_dim_p.o + # Specific PDAF-routines for SEIK OBJ_SEIK = PDAF_seik_init.o \ PDAF_seik_alloc.o \ @@ -131,7 +160,11 @@ OBJ_LSEIK = PDAF_lseik_init.o \ PDAF_lseik_update.o \ PDAF_lseik_analysis.o \ PDAF_lseik_resample.o \ - PDAF_lseik_analysis_trans.o + PDAF_lseik_analysis_trans.o \ + PDAFlocal_put_state_lseik.o \ + PDAFlocal_put_state_lseik_si.o \ + PDAFlocal_assimilate_lseik.o \ + PDAFlocal_assimilate_lseik_si.o # Specific PDAF-routines for SEEK OBJ_SEEK = PDAF_seek_init.o \ @@ -162,7 +195,11 @@ OBJ_ENKF = PDAF_enkf_init.o \ PDAF_enkf_analysis_rsm.o \ PDAF_enkf_omega.o \ PDAF_enkf_Tleft.o \ - PDAF_smoother_enkf.o + PDAF_smoother_enkf.o \ + PDAFomi_put_state_enkf_nondiagR.o \ + PDAFomi_put_state_enkf_nondiagR_si.o \ + PDAFomi_assimilate_enkf_nondiagR.o \ + PDAFomi_assimilate_enkf_nondiagR_si.o # Specific PDAF-routines for ETKF OBJ_ETKF = PDAF_etkf_init.o \ @@ -192,7 +229,11 @@ OBJ_LETKF = PDAF_letkf_init.o \ PDAF_letkf_update.o \ PDAF_letkf_analysis.o \ PDAF_letkf_analysis_T.o \ - PDAF_letkf_analysis_fixed.o + PDAF_letkf_analysis_fixed.o \ + PDAFlocal_put_state_letkf.o \ + PDAFlocal_put_state_letkf_si.o \ + PDAFlocal_assimilate_letkf.o \ + PDAFlocal_assimilate_letkf_si.o # Specific PDAF-routines for ESTKF OBJ_ESTKF = PDAF_estkf_init.o \ @@ -220,7 +261,11 @@ OBJ_LESTKF = PDAF_lestkf_init.o \ PDAF_assimilate_lestkf_si.o \ PDAF_lestkf_update.o \ PDAF_lestkf_analysis.o \ - PDAF_lestkf_analysis_fixed.o + PDAF_lestkf_analysis_fixed.o \ + PDAFlocal_put_state_lestkf.o \ + PDAFlocal_put_state_lestkf_si.o \ + PDAFlocal_assimilate_lestkf.o \ + PDAFlocal_assimilate_lestkf_si.o # Specific PDAF-routines for LEnKF OBJ_LENKF = PDAF_lenkf_init.o \ @@ -231,10 +276,14 @@ OBJ_LENKF = PDAF_lenkf_init.o \ PDAF_put_state_lenkf_si.o \ PDAFomi_put_state_lenkf.o \ PDAFomi_put_state_lenkf_si.o \ + PDAFomi_put_state_lenkf_nondiagR.o \ + PDAFomi_put_state_lenkf_nondiagR_si.o \ PDAF_assimilate_lenkf.o \ PDAF_assimilate_lenkf_si.o \ PDAFomi_assimilate_lenkf.o \ PDAFomi_assimilate_lenkf_si.o \ + PDAFomi_assimilate_lenkf_nondiagR.o \ + PDAFomi_assimilate_lenkf_nondiagR_si.o \ PDAF_lenkf_update.o \ PDAF_lenkf_analysis_rsm.o # Additional objects used by LEnKF but already specified for EnKF @@ -269,7 +318,19 @@ OBJ_LNETF = PDAF_lnetf_init.o \ PDAF_lnetf_update.o \ PDAF_lnetf_analysis.o \ PDAF_lnetf_smootherT.o \ - PDAF_smoother_lnetf.o + PDAF_smoother_lnetf.o \ + PDAFomi_put_state_lnetf_nondiagR.o \ + PDAFomi_put_state_lnetf_nondiagR_si.o \ + PDAFomi_assimilate_lnetf_nondiagR.o \ + PDAFomi_assimilate_lnetf_nondiagR_si.o \ + PDAFlocal_put_state_lnetf.o \ + PDAFlocal_put_state_lnetf_si.o \ + PDAFlocal_assimilate_lnetf.o \ + PDAFlocal_assimilate_lnetf_si.o \ + PDAFlocalomi_assimilate_lnetf_nondiagR.o \ + PDAFlocalomi_assimilate_lnetf_nondiagR_si.o \ + PDAFlocalomi_put_state_lnetf_nondiagR.o \ + PDAFlocalomi_put_state_lnetf_nondiagR_si.o # Specific PDAF-routines for PF OBJ_PF = PDAF_pf_init.o \ @@ -302,7 +363,19 @@ OBJ_LKNETF = PDAF_lknetf_init.o \ PDAF_lknetf_compute_gamma.o \ PDAF_lknetf_set_gamma.o \ PDAF_lknetf_alpha_neff.o \ - PDAF_lknetf_reset_gamma.o + PDAF_lknetf_reset_gamma.o \ + PDAFomi_put_state_lknetf_nondiagR.o \ + PDAFomi_put_state_lknetf_nondiagR_si.o \ + PDAFomi_assimilate_lknetf_nondiagR.o \ + PDAFomi_assimilate_lknetf_nondiagR_si.o \ + PDAFlocal_put_state_lknetf.o \ + PDAFlocal_put_state_lknetf_si.o \ + PDAFlocal_assimilate_lknetf.o \ + PDAFlocal_assimilate_lknetf_si.o \ + PDAFlocalomi_assimilate_lknetf_nondiagR.o \ + PDAFlocalomi_assimilate_lknetf_nondiagR_si.o \ + PDAFlocalomi_put_state_lknetf_nondiagR.o \ + PDAFlocalomi_put_state_lknetf_nondiagR_si.o # Specific PDAF-routines for generating observations OBJ_OBSGEN = PDAF_genobs_init.o \ @@ -356,22 +429,45 @@ OBJ_3DVAR = PDAF_put_state_3dvar.o \ PDAF_hyb3dvar_optim_cg.o \ PDAF_hyb3dvar_costf_cvt.o \ PDAF_hyb3dvar_costf_cg_cvt.o \ + PDAFlocal_put_state_en3dvar_lestkf.o \ + PDAFlocal_put_state_hyb3dvar_lestkf.o \ + PDAFlocal_assimilate_en3dvar_lestkf.o \ + PDAFlocal_assimilate_hyb3dvar_lestkf.o \ PDAFomi_assimilate_3dvar.o \ PDAFomi_assimilate_en3dvar_estkf.o \ PDAFomi_assimilate_en3dvar_lestkf.o \ PDAFomi_assimilate_hyb3dvar_estkf.o \ PDAFomi_assimilate_hyb3dvar_lestkf.o \ + PDAFomi_assimilate_3dvar_nondiagR.o \ + PDAFomi_assimilate_en3dvar_estkf_nondiagR.o \ + PDAFomi_assimilate_en3dvar_lestkf_nondiagR.o \ + PDAFomi_assimilate_hyb3dvar_estkf_nondiagR.o \ + PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR.o \ + PDAFlocalomi_assimilate_en3dvar_lestkf.o \ + PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR.o \ + PDAFlocalomi_assimilate_hyb3dvar_lestkf.o \ + PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR.o \ PDAFomi_put_state_3dvar.o \ PDAFomi_put_state_en3dvar_estkf.o \ PDAFomi_put_state_en3dvar_lestkf.o \ PDAFomi_put_state_hyb3dvar_estkf.o \ - PDAFomi_put_state_hyb3dvar_lestkf.o + PDAFomi_put_state_hyb3dvar_lestkf.o \ + PDAFomi_put_state_3dvar_nondiagR.o \ + PDAFomi_put_state_en3dvar_estkf_nondiagR.o \ + PDAFomi_put_state_en3dvar_lestkf_nondiagR.o \ + PDAFomi_put_state_hyb3dvar_estkf_nondiagR.o \ + PDAFomi_put_state_hyb3dvar_lestkf_nondiagR.o \ + PDAFlocalomi_put_state_en3dvar_lestkf.o \ + PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR.o \ + PDAFlocalomi_put_state_hyb3dvar_lestkf.o \ + PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR.o # Additional file for 3DVar already specified in OBJ_3DVAR_ini # PDAF_3dvar_memtime.o # Routines for PDAF-OMI OBJ_PDAFOMI = PDAFomi_obs_f.o \ PDAFomi_obs_l.o \ + PDAFomi_dim_obs_l.o \ PDAFomi_obs_op.o \ PDAFomi.o \ PDAFomi_callback.o @@ -383,6 +479,9 @@ OBJ_PDAF = $(OBJ_PDAFOMI) $(OBJ_PDAF_GEN) $(OBJ_SEIK) $(OBJ_LSEIK) $(OBJ_SEEK) OBJ_PDAF_VAR = $(OBJ_PDAF) $(OBJ_3DVAR) +# External Routines for SANGOMA tools +OBJ_SANGOMA = ../external/SANGOMA/SANGOMA_quicksort.o + # External optimizer libraries OBJ_OPTIM = ../external/CG+_mpi/cgfam.o ../external/CG+_mpi/cgsearch.o \ ../external/CG+/cgfam.o ../external/CG+/cgsearch.o \ @@ -391,17 +490,17 @@ OBJ_OPTIM = ../external/CG+_mpi/cgfam.o ../external/CG+_mpi/cgsearch.o \ ###################################################### -../lib/libpdaf-d.a: $(MOD_PDAF) $(MOD_INTERFACE) $(OBJ_PDAF) +../lib/libpdaf-d.a: $(MOD_PDAF) $(OBJ_SANGOMA) $(MOD_INTERFACE) $(OBJ_PDAF) @echo "++++++ Generate Filter library ++++++" $(AR) -r $(AR_SPEC) $@ \ - $(MOD_PDAF) $(MOD_INTERFACE) $(OBJ_PDAF) + $(MOD_PDAF) $(MOD_INTERFACE) $(OBJ_PDAF) $(OBJ_SANGOMA) $(RANLIB) ../lib/libpdaf-d.a @cp *.mod ../include -../lib/libpdaf-var.a: $(MOD_PDAF) $(MOD_INTERFACE) $(OBJ_PDAF_VAR) $(OBJ_OPTIM) +../lib/libpdaf-var.a: $(MOD_PDAF) $(OBJ_SANGOMA) $(MOD_INTERFACE) $(OBJ_PDAF_VAR) $(OBJ_OPTIM) @echo "++++++ Generate Filter library ++++++" $(AR) -r $(AR_SPEC) $@ \ - $(MOD_PDAF) $(MOD_INTERFACE) $(OBJ_PDAF) $(OBJ_PDAF_VAR) $(OBJ_OPTIM) + $(MOD_PDAF) $(MOD_INTERFACE) $(OBJ_PDAF) $(OBJ_PDAF_VAR) $(OBJ_OPTIM) $(OBJ_SANGOMA) $(RANLIB) ../lib/libpdaf-var.a @cp *.mod ../include @@ -410,10 +509,10 @@ pdaf-var: ../lib/libpdaf-var.a .F90.o : - $(FC) $(OPT) $(MPI_INC) $(CPP_DEFS) -c $*.F90 + $(FC) $(OPT) $(MPI_INC) $(CPP_DEFS) -o $*.o -c $*.F90 .f.o : - $(FC) -O3 -o $*.o -c $*.f + $(FC) -O3 $(MPI_INC) -o $*.o -c $*.f # For older compilers one might need to separate the # preprocessing from the compilation as defined below: @@ -427,6 +526,7 @@ pdaf-var: ../lib/libpdaf-var.a clean : rm -f *.o *.mod ../lib/libpdaf-d.a ../lib/libpdaf-var.a ../include/*.mod + cd ../external/SANGOMA; rm -f *.o *.mod; cd - cd ../external/CG+; rm -f *.o; cd - cd ../external/CG+_mpi; rm -f *.o; cd - cd ../external/LBFGS; rm -f *.o; cd - diff --git a/src/PDAF_3dvar_memtime.F90 b/src/PDAF_3dvar_memtime.F90 index 3d8917576..0db4f2e09 100644 --- a/src/PDAF_3dvar_memtime.F90 +++ b/src/PDAF_3dvar_memtime.F90 @@ -45,6 +45,8 @@ SUBROUTINE PDAF_3dvar_memtime(printtype) ONLY: filterpe, mype_world, COMM_pdaf USE PDAFomi, & ONLY: omi_was_used + USE PDAFlocal, & + ONLY: pdaflocal_was_used IMPLICIT NONE @@ -157,8 +159,10 @@ SUBROUTINE PDAF_3dvar_memtime(printtype) WRITE (*, '(a, 12x, a)') 'PDAF', 'Timers in LESTKF only' WRITE (*, '(a, 14x, a, 9x, F11.3, 1x, a)') 'PDAF', 'init_n_domains_pdaf:', pdaf_time_tot(42), 's' WRITE (*, '(a, 14x, a, 13x, F11.3, 1x, a)') 'PDAF', 'init_dim_l_pdaf:', pdaf_time_tot(45), 's' - WRITE (*, '(a, 14x, a, 14x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' - WRITE (*, '(a, 14x, a, 14x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' + IF (.NOT.pdaflocal_was_used) THEN + WRITE (*, '(a, 14x, a, 14x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' + WRITE (*, '(a, 14x, a, 14x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' + END IF END IF END IF diff --git a/src/PDAF_assimilate_lknetf_si.F90 b/src/PDAF_assimilate_lknetf_si.F90 index e8859d4fa..4d00f44f4 100644 --- a/src/PDAF_assimilate_lknetf_si.F90 +++ b/src/PDAF_assimilate_lknetf_si.F90 @@ -40,7 +40,7 @@ SUBROUTINE PDAF_assimilate_lknetf_si(outflag) ! should not be changed by the user ! ! ! !REVISION HISTORY: -! 2013-08 - Lars Nerger - Initial code +! 2017-08 - Lars Nerger - Initial code ! Later revisions - see svn log ! ! !USES: diff --git a/src/PDAF_correlation_function.F90 b/src/PDAF_correlation_function.F90 new file mode 100644 index 000000000..523bc40c5 --- /dev/null +++ b/src/PDAF_correlation_function.F90 @@ -0,0 +1,127 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id: PDAF_set_comm_pdaf.F90 918 2021-12-03 07:42:19Z lnerger $ + + +!> Get value of a correlation function +!! +!! This routine returns the value of the chosen correlation +!! function according to the specified length scale. +!! +!! This is a core routine of PDAF and +!! should not be changed by the user ! +!! +!! __Revision history:__ +!! * 2024-08 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! +SUBROUTINE PDAF_correlation_function(ctype, length, distance, value) + + IMPLICIT NONE + +! *** Arguments *** + INTEGER, INTENT(in) :: ctype !< Type of correlation function + !< (1): Gaussian with f(0)=1.0 + !< (2): 5th-order polynomial (Gaspace/Cohn, 1999) + REAL, INTENT(in) :: length !< Length scale of function + !< (1): standard deviation + !< (2): support length f=0 for distance>length + REAL, INTENT(in) :: distance !< Distance at which the function is evaluated + REAL, INTENT(out) :: value !< Value of the function + + +! *** Local variables *** + REAL :: shalf ! Half of support distance for Gaspari-Cohn + + +! ************************** +! *** Set function value *** +! ************************** + + IF (ctype == 1) THEN + ! ********************************************* + ! *** Gaussian function scaled for f(0)=1.0 *** + ! ********************************************* + + ! Compute weight + IF (length > 0.0) THEN + + value = exp(-distance*distance/ (2.0*length*length)) + + ELSE + + IF (distance > 0.0) THEN + value = 0.0 + ELSE + value = 1.0 + END IF + + END IF + + ELSEIF (ctype == 2) THEN + ! ************************************************************************ + ! *** 5th-order polynomial mimicking Gaussian but with compact support *** + ! *** Equation (4.10) of Gaspari&Cohn, QJRMS125, 723 (1999) *** + ! ************************************************************************ + + shalf = REAL(length) / 2.0 + + ! Evaluate function + cradnull: IF (length > 0.0) THEN + + cutoff: IF (distance <= length) THEN + IF (distance <= length / 2.0) THEN + value = -0.25 * (distance / shalf)**5 & + + 0.5 * (distance / shalf)**4 & + + 5.0 / 8.0 * (distance / shalf)**3 & + - 5.0 / 3.0 * (distance / shalf)**2 + 1.0 + ELSEIF (distance > length / 2.0 .AND. distance < length * 0.9) THEN + value = 1.0 / 12.0 * (distance / shalf)**5 & + - 0.5 * (distance / shalf)**4 & + + 5.0 / 8.0 * (distance / shalf)**3 & + + 5.0 / 3.0 * (distance / shalf)**2 & + - 5.0 * (distance / shalf) & + + 4.0 - 2.0 / 3.0 * shalf / distance + ELSEIF (distance >= length * 0.9 .AND. distance < length) THEN + value = MAX(1.0 / 12.0 * (distance / shalf)**5 & + - 0.5 * (distance / shalf)**4 & + + 5.0 / 8.0 * (distance / shalf)**3 & + + 5.0 / 3.0 * (distance / shalf)**2 & + - 5.0 * (distance / shalf) & + + 4.0 - 2.0 / 3.0 * shalf / distance, 0.0) + ELSE + value = 0.0 + ENDIF + ELSE cutoff + value = 0.0 + END IF cutoff + + ELSE cradnull + + IF (distance > 0.0) THEN + value = 0.0 + ELSE + value = 1.0 + END IF + + END IF cradnull + + END IF + + +END SUBROUTINE PDAF_correlation_function diff --git a/src/PDAF_diag_crps.F90 b/src/PDAF_diag_crps.F90 index dffef5493..0398cb85d 100644 --- a/src/PDAF_diag_crps.F90 +++ b/src/PDAF_diag_crps.F90 @@ -1,4 +1,4 @@ -! Copyright (c) 2012-2024 Lars Nerger, lars.nerger@awi.de +! Copyright (c) 2012-2023 Lars Nerger, lars.nerger@awi.de ! ! This routine is free software: you can redistribute it and/or modify ! it under the terms of the GNU Lesser General Public License @@ -19,19 +19,254 @@ !! !! This routine computes the continuous ranked probability !! score (CRPS) and its decomposition into uncertainty and -!! resolution: CRPS = RELI + RESOL. In addition the uncertainty +!! potential CRPS: CRPS = RELI + pot_CRPS. In addition the uncertainty !! is computed. +!! Resolution can be computed by RESOL = UNCERT - pot_CRPS. !! A perfectly reliable system gives RELI=0. -!! An informative system gives RESOL << UNCERT. +!! An informative system gives RESOL ~ UNCERT or pot_CRPS << UNCERT. !! !! The computation follows H. Hersbach, Weather and Forecasting -!! 15(2000) 599-570. Here, RESOL is equivalent to CPRS_pot. +!! 15(2000) 599-570. !! !! __Revision history:__ !! * 2021-05 - Lars Nerger - Initial code based on sangoma_ComputeCRPS !! * Later revisions - see repository log +!! * 2024-04 - Yumeng Chen - refactor; add domain decomposition support !! -SUBROUTINE PDAF_diag_CRPS(dim, dim_ens, element, oens, obs, & + +!--------------------------------------------------------------------------- +!> CRPS diagnostic routine with original interface +!! +SUBROUTINE PDAF_diag_crps(dim_p, dim_ens, element, oens, obs, & + CRPS, reli, pot_CRPS, uncert, status)! +#include "typedefs.h" + + USE mpi + USE PDAF_mod_filtermpi, & + ONLY: COMM_filter, mype_filter, npes_filter + USE SANGOMA_quicksort + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: dim_p !< PE-local state dimension + INTEGER, INTENT(in) :: dim_ens !< Ensemble size + INTEGER, INTENT(in) :: element !< index of element in full state vector + !< If element=0, mean values over dim_p grid points/cases are computed + REAL, INTENT(in) :: oens(dim_p, dim_ens) !< State ensemble + REAL, INTENT(in) :: obs(dim_p) !< Observation / truth + REAL, INTENT(out) :: CRPS !< CRPS + REAL, INTENT(out) :: reli !< Reliability + REAL, INTENT(out) :: pot_CRPS !< potential CRPS + REAL, INTENT(out) :: uncert !< uncertainty + INTEGER, INTENT(out) :: status !< Status flag (0=success) + + CALL PDAF_diag_crps_mpi(dim_p, dim_ens, element, oens, obs, & + COMM_filter, mype_filter, npes_filter, & + CRPS, reli, pot_CRPS, uncert, status)! + +END SUBROUTINE PDAF_diag_crps + +!--------------------------------------------------------------------------- +!> CRPS diagnostic routine including MPI-settings in interface +!! +SUBROUTINE PDAF_diag_crps_mpi(dim_p, dim_ens, element, oens, obs, & + COMM_filter, mype_filter, npes_filter, & + CRPS, reli, pot_CRPS, uncert, status) +#include "typedefs.h" + + USE mpi + USE SANGOMA_quicksort + + IMPLICIT NONE + + ! *** Arguments *** + INTEGER, INTENT(in) :: dim_p !< PE-local state dimension + INTEGER, INTENT(in) :: dim_ens !< Ensemble size + INTEGER, INTENT(in) :: element !< index of element in full state vector + !< If element=0, mean values over dim_p grid points/cases are computed + INTEGER, INTENT(in) :: COMM_filter !< MPI communicator for filter + INTEGER, INTENT(in) :: mype_filter !< rank of MPI communicator + INTEGER, INTENT(in) :: npes_filter !< size of MPI communicator + REAL, INTENT(in) :: oens(dim_p, dim_ens) !< State ensemble + REAL, INTENT(in) :: obs(dim_p) !< Observation / truth + REAL, INTENT(out) :: CRPS !< CRPS + REAL, INTENT(out) :: reli !< Reliability + REAL, INTENT(out) :: pot_CRPS !< potential CRPS + REAL, INTENT(out) :: uncert !< uncertainty + INTEGER, INTENT(out) :: status !< Status flag (0=success) + + ! *** local variables *** + INTEGER :: i, k ! counter + INTEGER :: istart ! starting index of grid point/case + INTEGER :: imax ! end index of grid point/case + INTEGER :: dim ! dimension of the full state vector + INTEGER :: MPIerr + REAL :: wk ! weight for each grid point/case + REAL :: x_a ! truth / verifying analysis (observation) + REAL :: gi ! The difference between i+1-th ensemble member and i-th member + REAL :: oi + REAL :: o0, one_minus_oN + REAL :: o0_p, one_minus_oN_p + REAL :: pval + INTEGER, ALLOCATABLE :: all_dim_p(:) ! dimensions of the local state vector + INTEGER, ALLOCATABLE :: dis_dim_p(:) ! dimensions of the local state vector + REAL, ALLOCATABLE :: one_case(:) ! ensemble in each case, this is variable x in H. Hersbach (2000) + REAL, ALLOCATABLE :: allobs(:) + REAL, ALLOCATABLE :: alpha_p(:), beta_p(:) + REAL, ALLOCATABLE :: alpha(:), beta(:) + + ! initialise the status flag + status = 0 + + ! initialise crps output + crps = 0.0 + reli = 0.0 + pot_CRPS = 0.0 + uncert = 0.0 + + ! allocate arrays for MPI communication + ALLOCATE( all_dim_p(npes_filter), dis_dim_p(npes_filter) ) + ! gather the dimension of the local state vector to all_dim_p + CALL MPI_Allgather(dim_p, 1, MPI_INTEGER, all_dim_p, 1, MPI_INTEGER, COMM_filter, MPIerr) + ! displacement of the received array used for gatherv + dis_dim_p(1) = 0 + DO i = 2, npes_filter + dis_dim_p(i) = dis_dim_p(i - 1) + all_dim_p(i - 1) + END DO + + ! dimension fo the full state vector + dim = SUM(all_dim_p) + + ! Set number of element over which CPRS is computed + IF (element==0) THEN + istart = 1 + imax = dim_p + ! weight for each grid point/case + wk = 1.0/REAL(dim) + ELSEIF (element<=dim) THEN + ! error handling + IF (element < 0) THEN + status = 100 + WRITE(*, '(a, 5x, a, I4, a)') 'PDAF warning:', & + 'PDAF_diag_crps: element(', element, ') argument must be >= 0.' + RETURN + ENDIF + ! + IF (element <= dis_dim_p(mype_filter + 1) .OR. element > dis_dim_p(mype_filter + 1) + dim_p) THEN + istart = 1 + imax = 0 + ELSE + ! index for + istart = element - dis_dim_p(mype_filter + 1) + imax = istart + wk = 1.0 + END IF + ELSE + istart = 1 + imax = 0 + status = 100 + wk = 1.0 + WRITE(*, '(a, 5x, a, I4, a, I4, a)') 'PDAF warning:', & + 'PDAF_diag_crps: element (', element, ') argument must be <= dim_p (', dim_p, ').' + RETURN + END IF + + ! Calculate uncertainty based on Eq 20 in H. Hersbach (2000) + ! Uncertainty is only meaningful when multiple verifying analysis exists + ! because it is calculated based on the distribution of observations + IF (element == 0) THEN + ALLOCATE( allobs(dim), source=0. ) + ! get observations across PEs + CALL MPI_Allgatherv(obs, dim_p, MPI_REALTYPE, allobs, all_dim_p, dis_dim_p, MPI_REALTYPE, COMM_filter, MPIerr) + CALL quicksort_d(allobs, dim) + pval = 0. + DO k = 1, dim - 1 + pval = pval + wk + uncert = uncert + (allobs(k+1) - allobs(k)) * pval*(1.0-pval) + END DO + DEALLOCATE(allobs) + END IF + + ! allocate arrays for CRPS calculation + ALLOCATE(one_case(dim_ens)) + ALLOCATE(alpha_p(0:dim_ens), source=0.) + ALLOCATE(beta_p(0:dim_ens), source=0.) + + ! initialise values used for summation in the loop + one_minus_oN_p = 0. + o0_p = 0. + + ! Loop over grid points/cases + DO k = istart, imax + ! Get observation for current case + x_a = obs(k) + + ! Get sorted ensemble for current case + DO i = 1, dim_ens + one_case(i) = oens(k, i) + END DO + CALL quicksort_d(one_case, dim_ens) + + ! Outlier cases + IF (x_a < one_case(1)) THEN + ! Case 1: obs < all ensemble members + beta_p(0) = beta_p(0) + wk*(one_case(1) - x_a) + o0_p = o0_p + wk + ELSEIF (x_a > one_case(dim_ens)) THEN + ! Case 2: obs > all ensemble members + alpha_p(dim_ens) = alpha_p(dim_ens) + wk*(x_a - one_case(dim_ens)) + one_minus_oN_p = one_minus_oN_p + wk + END IF + + ! Eq. 29 and Eq. 26 in H. Hersbach (2000) + DO i = 1, dim_ens-1 + alpha_p(i) = alpha_p(i) + wk*MAX( MIN(x_a, one_case(i+1)) - one_case(i), 0.0) + beta_p(i) = beta_p(i) + wk*MAX(one_case(i+1) - MAX(x_a, one_case(i)), 0.0) + END DO + END DO + + ALLOCATE(alpha(0:dim_ens), source=0.) + ALLOCATE(beta(0:dim_ens), source=0.) + ! todo: get full alpha and beta + CALL MPI_Allreduce(alpha_p, alpha, dim_ens, MPI_REALTYPE, MPI_SUM, COMM_filter, MPIerr) + CALL MPI_Allreduce(beta_p, beta, dim_ens, MPI_REALTYPE, MPI_SUM, COMM_filter, MPIerr) + CALL MPI_Allreduce(one_minus_oN_p, one_minus_oN, 1, MPI_REALTYPE, MPI_SUM, COMM_filter, MPIerr) + CALL MPI_Allreduce(o0_p, o0, 1, MPI_REALTYPE, MPI_SUM, COMM_filter, MPIerr) + DEALLOCATE(one_case, alpha_p, beta_p) + + ! Complete computation of CPRS, reliability and potential CPRS + ! modify alpha(0) and beta(dim_ens) to accomodate outliers calculation + ! This is equivalent to Eq. 33 in H. Hersbach (2000) + IF (alpha(0) /= 0.0) alpha(0) = beta(0) * (1.0/o0 - 1.0) + IF (beta(dim_ens) /= 0.0) beta(dim_ens) = alpha(dim_ens) * (1.0/one_minus_oN - 1.0) + + DO i = 0, dim_ens + ! The difference between i+1-th ensemble member and i-th member + gi = alpha(i) + beta(i) + IF (gi /= 0.0) THEN + oi = beta(i) / gi + ELSE + oi = 0.0 + END IF + pval = REAL(i) / REAL(dim_ens) + + crps = crps + alpha(i)*pval*pval + beta(i)*(1.0-pval)*(1.0-pval) + reli = reli + gi * (oi - pval)*(oi - pval) + pot_CRPS = pot_CRPS + gi * oi * (1.0-oi) + END DO + + ! **************** + ! *** Clean up *** + ! **************** + DEALLOCATE(alpha, beta) + +END SUBROUTINE PDAF_diag_crps_mpi + +!-------------------------------------------------------- +!> CRPS routine from PDAF until V2.2.1 without parallelization +!! +SUBROUTINE PDAF_diag_CRPS_nompi(dim, dim_ens, element, oens, obs, & CRPS, reli, resol, uncert, status)! IMPLICIT NONE @@ -60,6 +295,14 @@ SUBROUTINE PDAF_diag_CRPS(dim, dim_ens, element, oens, obs, & REAL, ALLOCATABLE :: c_a(:), c_b(:) +! ****************** +! *** Initialize *** +! ****************** + + ! Initialize status flag + status = 0 + + ! ******************** ! *** Compute CRPS *** ! ******************** @@ -139,7 +382,7 @@ SUBROUTINE PDAF_diag_CRPS(dim, dim_ens, element, oens, obs, & resol = 0.0 oi = 0.0 - DO i = 1, dim_ens + DO i = 0, dim_ens gi = c_a(i) + c_b(i) IF (gi /= 0.0) THEN oi = c_a(i) / gi @@ -168,7 +411,7 @@ SUBROUTINE PDAF_diag_CRPS(dim, dim_ens, element, oens, obs, & DEALLOCATE(oneens, c_a, c_b) -END SUBROUTINE PDAF_diag_CRPS +END SUBROUTINE PDAF_diag_CRPS_nompi !-------------------------------------------------------- @@ -192,24 +435,24 @@ SUBROUTINE PDAF_sisort(n, veca) DO j = 2, n - eflag = .FALSE. + eflag = .FALSE. - tmpa = veca(j) + tmpa = veca(j) - sortloop: DO i = j-1, 1, -1 - k = i + sortloop: DO i = j-1, 1, -1 + k = i - IF(veca(i) <= tmpa) THEN - eflag = .TRUE. - EXIT sortloop - END IF + IF(veca(i) <= tmpa) THEN + eflag = .TRUE. + EXIT sortloop + END IF - veca(i+1) = veca(i) - ENDDO sortloop + veca(i+1) = veca(i) + ENDDO sortloop - IF (.NOT.eflag) k=0 + IF (.NOT.eflag) k=0 - veca(k+1) = tmpa + veca(k+1) = tmpa ENDDO diff --git a/src/PDAF_estkf_analysis.F90 b/src/PDAF_estkf_analysis.F90 index 789e9d381..531b0be74 100644 --- a/src/PDAF_estkf_analysis.F90 +++ b/src/PDAF_estkf_analysis.F90 @@ -293,6 +293,34 @@ SUBROUTINE PDAF_estkf_analysis(step, dim_p, dim_obs_p, dim_ens, rank, & CALL PDAF_timeit(51, 'old') END IF + ELSE IF (dim_obs_p == 0) THEN + + ! For OMI we need to call observation operator also for dim_obs_p=0 + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation include a global communication + IF (.NOT.observe_ens) THEN + IF (omi_n_obstypes>0) THEN + ALLOCATE(HXbar_p(1)) + obs_member = 0 + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, state_p, HXbar_p) + + DEALLOCATE(HXbar_p) + ELSE + ALLOCATE(HL_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HL_p(:, member)) + END DO + DEALLOCATE(HL_p) + END IF + END IF + END IF haveobsB CALL PDAF_timeit(12, 'old') @@ -411,14 +439,20 @@ SUBROUTINE PDAF_estkf_analysis(step, dim_p, dim_obs_p, dim_ens, rank, & ! For OMI we need to call observation operator also for dim_obs_p=0 ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation includes a global communication IF (omi_n_obstypes>0) THEN - ALLOCATE(HL_p(1, 1)) - obs_member = 1 - - ! [Hx_1 ... Hx_N] - CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, 1), HL_p(:, 1)) - - DEALLOCATE(HL_p) + IF (.NOT.observe_ens) THEN + ALLOCATE(HL_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HL_p(:, member)) + END DO + DEALLOCATE(HL_p) + END IF END IF END IF haveobsA @@ -731,7 +765,7 @@ SUBROUTINE PDAF_estkf_analysis(step, dim_p, dim_obs_p, dim_ens, rank, & CALL PDAF_timeit(34, 'new') IF (type_sqrt == 1) THEN ! A = (Omega C^(-1)) by solving Ct A = OmegaT for A - CALL trtrsTYPE('l', 't', 'n', rank, dim_ens, & + CALL trtrsTYPE('L', 'T', 'N', rank, dim_ens, & tmp_Ainv, rank, OmegaT, rank, lib_info) ELSE ! TMP_AINV already contains matrix C (no more inversion) diff --git a/src/PDAF_estkf_analysis_fixed.F90 b/src/PDAF_estkf_analysis_fixed.F90 index 9cebb60f7..c5534f324 100644 --- a/src/PDAF_estkf_analysis_fixed.F90 +++ b/src/PDAF_estkf_analysis_fixed.F90 @@ -268,6 +268,34 @@ SUBROUTINE PDAF_estkf_analysis_fixed(step, dim_p, dim_obs_p, dim_ens, rank, & CALL PDAF_timeit(51, 'old') END IF + ELSE IF (dim_obs_p == 0) THEN + + ! For OMI we need to call observation operator also for dim_obs_p=0 + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation include a global communication + IF (.NOT.observe_ens) THEN + IF (omi_n_obstypes>0) THEN + ALLOCATE(HXbar_p(1)) + obs_member = 0 + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, state_p, HXbar_p) + + DEALLOCATE(HXbar_p) + ELSE + ALLOCATE(HL_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HL_p(:, member)) + END DO + DEALLOCATE(HL_p) + END IF + END IF + END IF haveobsB CALL PDAF_timeit(12, 'old') @@ -385,15 +413,21 @@ SUBROUTINE PDAF_estkf_analysis_fixed(step, dim_p, dim_obs_p, dim_ens, rank, & Ainv_p = 0.0 ! For OMI we need to call observation operator also for dim_obs_p=0 - ! in order to initialize pointer to observation type + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation includes a global communication IF (omi_n_obstypes>0) THEN - ALLOCATE(HL_p(1, 1)) - obs_member = 1 - - ! [Hx_1 ... Hx_N] - CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, 1), HL_p(:, 1)) - - DEALLOCATE(HL_p) + IF (.NOT.observe_ens) THEN + ALLOCATE(HL_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HL_p(:, member)) + END DO + DEALLOCATE(HL_p) + END IF END IF END IF haveobsA diff --git a/src/PDAF_etkf_analysis.F90 b/src/PDAF_etkf_analysis.F90 index 681f27759..f0be4c4fc 100644 --- a/src/PDAF_etkf_analysis.F90 +++ b/src/PDAF_etkf_analysis.F90 @@ -272,6 +272,34 @@ SUBROUTINE PDAF_etkf_analysis(step, dim_p, dim_obs_p, dim_ens, & CALL PDAF_timeit(51, 'old') END IF + ELSE IF (dim_obs_p == 0) THEN + + ! For OMI we need to call observation operator also for dim_obs_p=0 + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation include a global communication + IF (.NOT.observe_ens) THEN + IF (omi_n_obstypes>0) THEN + ALLOCATE(HXbar_p(1)) + obs_member = 0 + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, state_p, HXbar_p) + + DEALLOCATE(HXbar_p) + ELSE + ALLOCATE(HZ_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HZ_p(:, member)) + END DO + DEALLOCATE(HZ_p) + END IF + END IF + END IF haveobsB CALL PDAF_timeit(12, 'old') @@ -384,15 +412,21 @@ SUBROUTINE PDAF_etkf_analysis(step, dim_p, dim_obs_p, dim_ens, & Usqrt = 0.0 ! For OMI we need to call observation operator also for dim_obs_p=0 - ! in order to initialize pointer to observation type + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation includes a global communication IF (omi_n_obstypes>0) THEN - ALLOCATE(HZ_p(1, 1)) - obs_member = 1 - - ! [Hx_1 ... Hx_N] - CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, 1), HZ_p(:, 1)) - - DEALLOCATE(HZ_p) + IF (.NOT.observe_ens) THEN + ALLOCATE(HZ_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HZ_p(:, member)) + END DO + DEALLOCATE(HZ_p) + END IF END IF END IF haveobsA diff --git a/src/PDAF_etkf_analysis_T.F90 b/src/PDAF_etkf_analysis_T.F90 index c13573690..889ae50bd 100644 --- a/src/PDAF_etkf_analysis_T.F90 +++ b/src/PDAF_etkf_analysis_T.F90 @@ -274,6 +274,33 @@ SUBROUTINE PDAF_etkf_analysis_T(step, dim_p, dim_obs_p, dim_ens, & CALL PDAF_timeit(51, 'old') END IF + ELSE IF (dim_obs_p == 0) THEN + + ! For OMI we need to call observation operator also for dim_obs_p=0 + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation include a global communication + IF (.NOT.observe_ens) THEN + IF (omi_n_obstypes>0) THEN + ALLOCATE(HXbar_p(1)) + obs_member = 0 + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, state_p, HXbar_p) + + DEALLOCATE(HXbar_p) + ELSE + ALLOCATE(HZ_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HZ_p(:, member)) + END DO + DEALLOCATE(HZ_p) + END IF + END IF END IF haveobsB CALL PDAF_timeit(12, 'old') @@ -386,15 +413,21 @@ SUBROUTINE PDAF_etkf_analysis_T(step, dim_p, dim_obs_p, dim_ens, & Asqrt = 0.0 ! For OMI we need to call observation operator also for dim_obs_p=0 - ! in order to initialize pointer to observation type + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation includes a global communication IF (omi_n_obstypes>0) THEN - ALLOCATE(HZ_p(1, 1)) - obs_member = 1 - - ! [Hx_1 ... Hx_N] - CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, 1), HZ_p(:, 1)) - - DEALLOCATE(HZ_p) + IF (.NOT.observe_ens) THEN + ALLOCATE(HZ_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HZ_p(:, member)) + END DO + DEALLOCATE(HZ_p) + END IF END IF END IF haveobsA diff --git a/src/PDAF_etkf_analysis_fixed.F90 b/src/PDAF_etkf_analysis_fixed.F90 index 2e7bdf934..cc530e0da 100644 --- a/src/PDAF_etkf_analysis_fixed.F90 +++ b/src/PDAF_etkf_analysis_fixed.F90 @@ -261,6 +261,34 @@ SUBROUTINE PDAF_etkf_analysis_fixed(step, dim_p, dim_obs_p, dim_ens, & CALL PDAF_timeit(51, 'old') END IF + ELSE IF (dim_obs_p == 0) THEN + + ! For OMI we need to call observation operator also for dim_obs_p=0 + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation include a global communication + IF (.NOT.observe_ens) THEN + IF (omi_n_obstypes>0) THEN + ALLOCATE(HXbar_p(1)) + obs_member = 0 + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, state_p, HXbar_p) + + DEALLOCATE(HXbar_p) + ELSE + ALLOCATE(HZ_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HZ_p(:, member)) + END DO + DEALLOCATE(HZ_p) + END IF + END IF + END IF haveobsB CALL PDAF_timeit(12, 'old') @@ -373,15 +401,21 @@ SUBROUTINE PDAF_etkf_analysis_fixed(step, dim_p, dim_obs_p, dim_ens, & Asqrt = 0.0 ! For OMI we need to call observation operator also for dim_obs_p=0 - ! in order to initialize pointer to observation type + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation includes a global communication IF (omi_n_obstypes>0) THEN - ALLOCATE(HZ_p(1, 1)) - obs_member = 1 - - ! [Hx_1 ... Hx_N] - CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, 1), HZ_p(:, 1)) - - DEALLOCATE(HZ_p) + IF (.NOT.observe_ens) THEN + ALLOCATE(HZ_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HZ_p(:, member)) + END DO + DEALLOCATE(HZ_p) + END IF END IF END IF haveobsA diff --git a/src/PDAF_interfaces_module.F90 b/src/PDAF_interfaces_module.F90 index 6a329a53d..68a685966 100644 --- a/src/PDAF_interfaces_module.F90 +++ b/src/PDAF_interfaces_module.F90 @@ -40,6 +40,8 @@ MODULE PDAF_interfaces_module ! (Defines BLAS/LAPACK routines and MPI_REALTYPE) #include "typedefs.h" + USE PDAFlocal_interfaces + INTERFACE SUBROUTINE PDAF_init(filtertype, subtype, stepnull, param_int, dim_pint, & param_real, dim_preal, COMM_model, COMM_filter, COMM_couple, & @@ -590,12 +592,7 @@ SUBROUTINE PDAF_put_state_lnetf(U_collect_state, U_init_dim_obs, U_obs_op, & U_init_obs_l, U_prepoststep, U_likelihood_l, U_init_n_domains_p, & U_init_dim_l, U_init_dim_obs_l, U_g2l_state, U_l2g_state, U_g2l_obs, & outflag) - -! !ARGUMENTS: INTEGER, INTENT(out) :: outflag ! Status flag - -! ! External subroutines -! ! (PDAF-internal names, real names are defined in the call to PDAF) EXTERNAL :: U_collect_state, & ! Routine to collect a state vector U_obs_op, & ! Observation operator U_init_n_domains_p, & ! Provide number of local analysis domains @@ -653,12 +650,7 @@ SUBROUTINE PDAF_put_state_lknetf(U_collect_state, U_init_dim_obs, U_obs_op, & U_init_n_domains_p, & U_init_dim_l, U_init_dim_obs_l, U_g2l_state, U_l2g_state, U_g2l_obs, & U_init_obsvar, U_init_obsvar_l, U_likelihood_l, U_likelihood_hyb_l, outflag) - -! !ARGUMENTS: INTEGER, INTENT(out) :: outflag ! Status flag - -! ! External subroutines -! ! (PDAF-internal names, real names are defined in the call to PDAF) EXTERNAL :: U_collect_state, & ! Routine to collect a state vector U_obs_op, & ! Observation operator U_init_n_domains_p, & ! Provide number of local analysis domains @@ -1050,6 +1042,63 @@ SUBROUTINE PDAF_diag_effsample(dim_sample, weights, effSample) END SUBROUTINE PDAF_diag_effsample END INTERFACE + INTERFACE + SUBROUTINE PDAF_diag_crps(dim_p, dim_ens, element, oens, obs, & + CRPS, reli, pot_CRPS, uncert, status)! + IMPLICIT NONE + INTEGER, INTENT(in) :: dim_p !< PE-local state dimension + INTEGER, INTENT(in) :: dim_ens !< Ensemble size + INTEGER, INTENT(in) :: element !< index of element in full state vector + !< If element=0, mean values over dim_p grid points/cases are computed + REAL, INTENT(in) :: oens(dim_p, dim_ens) !< State ensemble + REAL, INTENT(in) :: obs(dim_p) !< Observation / truth + REAL, INTENT(out) :: CRPS !< CRPS + REAL, INTENT(out) :: reli !< Reliability + REAL, INTENT(out) :: pot_CRPS !< potential CRPS + REAL, INTENT(out) :: uncert !< uncertainty + INTEGER, INTENT(out) :: status !< Status flag (0=success) + END SUBROUTINE PDAF_diag_crps + END INTERFACE + + INTERFACE + SUBROUTINE PDAF_diag_crps_mpi(dim_p, dim_ens, element, oens, obs, & + COMM_filter, mype_filter, npes_filter, & + CRPS, reli, pot_CRPS, uncert, status) + IMPLICIT NONE + INTEGER, INTENT(in) :: dim_p !< PE-local state dimension + INTEGER, INTENT(in) :: dim_ens !< Ensemble size + INTEGER, INTENT(in) :: element !< index of element in full state vector + !< If element=0, mean values over dim_p grid points/cases are computed + INTEGER, INTENT(in) :: COMM_filter !< MPI communicator for filter + INTEGER, INTENT(in) :: mype_filter !< rank of MPI communicator + INTEGER, INTENT(in) :: npes_filter !< size of MPI communicator + REAL, INTENT(in) :: oens(dim_p, dim_ens) !< State ensemble + REAL, INTENT(in) :: obs(dim_p) !< Observation / truth + REAL, INTENT(out) :: CRPS !< CRPS + REAL, INTENT(out) :: reli !< Reliability + REAL, INTENT(out) :: pot_CRPS !< potential CRPS + REAL, INTENT(out) :: uncert !< uncertainty + INTEGER, INTENT(out) :: status !< Status flag (0=success) + END SUBROUTINE PDAF_diag_crps_mpi + END INTERFACE + + INTERFACE + SUBROUTINE PDAF_diag_CRPS_nompi(dim, dim_ens, element, oens, obs, & + CRPS, reli, resol, uncert, status)! + IMPLICIT NONE + INTEGER, INTENT(in) :: dim !< PE-local state dimension + INTEGER, INTENT(in) :: dim_ens !< Ensemble size + INTEGER, INTENT(in) :: element !< ID of element to be used + !< If element=0, mean values over all elements are computed + REAL, INTENT(in) :: oens(dim, dim_ens) !< State ensemble + REAL, INTENT(in) :: obs(dim) !< State ensemble + REAL, INTENT(out) :: CRPS !< CRPS + REAL, INTENT(out) :: reli !< Reliability + REAL, INTENT(out) :: resol !< resolution + REAL, INTENT(out) :: uncert !< uncertainty + INTEGER, INTENT(out) :: status !< Status flag (0=success) + END SUBROUTINE PDAF_diag_CRPS_nompi + END INTERFACE INTERFACE SUBROUTINE PDAF_gather_obs_f(obs_p, obs_f, status) @@ -1092,345 +1141,186 @@ SUBROUTINE PDAF_get_localfilter(lfilter) END SUBROUTINE PDAF_get_localfilter END INTERFACE -! OMI INTERFACES --------------------- - INTERFACE - SUBROUTINE PDAFomi_put_state_global(U_collect_state, U_init_dim_obs, U_obs_op, & - U_prepoststep, flag) - INTEGER, INTENT(out) :: flag ! Status flag + SUBROUTINE PDAF_put_state_3dvar(U_collect_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & + U_prepoststep, outflag) + INTEGER, INTENT(out) :: outflag ! Status flag EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_init_dim_obs, & ! Initialize dimension of observation vector - U_obs_op, & ! Observation operator - U_prepoststep ! User supplied pre/poststep routine - END SUBROUTINE PDAFomi_put_state_global - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_assimilate_global(U_collect_state, U_distribute_state, & - U_init_dim_obs, U_obs_op, U_prepoststep, U_next_observation, flag) - INTEGER, INTENT(out) :: flag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_distribute_state, & ! Routine to distribute a state vector - U_init_dim_obs, & ! Initialize dimension of observation vector - U_obs_op, & ! Observation operator - U_prepoststep, & ! User supplied pre/poststep routine - U_next_observation ! Provide time step and time of next observation - END SUBROUTINE PDAFomi_assimilate_global - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_put_state_local(U_collect_state, U_init_dim_obs, U_obs_op, & - U_prepoststep, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & - U_g2l_state, U_l2g_state, flag) - INTEGER, INTENT(out) :: flag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_obs_op, & ! Observation operator - U_init_n_domains_p, & ! Provide number of local analysis domains - U_init_dim_l, & ! Init state dimension for local ana. domain - U_init_dim_obs, & ! Initialize dimension of observation vector - U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain - U_g2l_state, & ! Get state on local ana. domain from full state - U_l2g_state, & ! Init full state from state on local analysis domain - U_prepoststep ! User supplied pre/poststep routine - END SUBROUTINE PDAFomi_put_state_local - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_assimilate_local(U_collect_state, U_distribute_state, & - U_init_dim_obs, U_obs_op, U_prepoststep, U_init_n_domains_p, U_init_dim_l, & - U_init_dim_obs_l, U_g2l_state, U_l2g_state, U_next_observation, flag) - INTEGER, INTENT(out) :: flag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_distribute_state, & ! Routine to distribute a state vector - U_obs_op, & ! Observation operator - U_init_n_domains_p, & ! Provide number of local analysis domains - U_init_dim_l, & ! Init state dimension for local ana. domain - U_init_dim_obs, & ! Initialize dimension of observation vector - U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain - U_g2l_state, & ! Get state on local ana. domain from full state - U_l2g_state, & ! Init full state from state on local analysis domain - U_prepoststep, & ! User supplied pre/poststep routine - U_next_observation ! Provide time step and time of next observation - END SUBROUTINE PDAFomi_assimilate_local - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_put_state_local_si(flag) - INTEGER, INTENT(out) :: flag ! Status flag - END SUBROUTINE PDAFomi_put_state_local_si + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_cvt, & ! Apply control vector transform matrix to control vector + U_cvt_adj, & ! Apply adjoint control vector transform matrix + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + END SUBROUTINE PDAF_put_state_3dvar END INTERFACE INTERFACE - SUBROUTINE PDAFomi_assimilate_local_si(flag) - INTEGER, INTENT(out) :: flag ! Status flag - END SUBROUTINE PDAFomi_assimilate_local_si + SUBROUTINE PDAF_put_state_en3dvar_estkf(U_collect_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & + U_init_obsvar, U_prepoststep, outflag) + INTEGER, INTENT(out) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_init_obsvar ! Initialize mean observation error variance + END SUBROUTINE PDAF_put_state_en3dvar_estkf END INTERFACE INTERFACE - SUBROUTINE PDAFomi_put_state_global_si(flag) - INTEGER, INTENT(out) :: flag ! Status flag - END SUBROUTINE PDAFomi_put_state_global_si + SUBROUTINE PDAF_put_state_en3dvar_lestkf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_g2l_state, U_l2g_state, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_prepoststep, outflag) + INTEGER, INTENT(out) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_obs_op_f, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_f, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_state, & ! Get state on local ana. domain from full state + U_l2g_state, & ! Init full state from state on local analysis domain + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l ! Provide product R^-1 A on local analysis domain + END SUBROUTINE PDAF_put_state_en3dvar_lestkf END INTERFACE INTERFACE - SUBROUTINE PDAFomi_assimilate_global_si(flag) - INTEGER, INTENT(out) :: flag ! Status flag - END SUBROUTINE PDAFomi_assimilate_global_si + SUBROUTINE PDAF_put_state_hyb3dvar_estkf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_prodRinvA, & + U_cvt, U_cvt_adj, U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & + U_init_obsvar, U_prepoststep, outflag) + INTEGER, INTENT(out) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_cvt, & ! Apply control vector transform matrix to control vector + U_cvt_adj, & ! Apply adjoint control vector transform matrix + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_init_obsvar ! Initialize mean observation error variance + END SUBROUTINE PDAF_put_state_hyb3dvar_estkf END INTERFACE INTERFACE - SUBROUTINE PDAFomi_assimilate_lenkf_si(flag) - INTEGER, INTENT(out) :: flag ! Status flag - END SUBROUTINE PDAFomi_assimilate_lenkf_si + SUBROUTINE PDAF_put_state_hyb3dvar_lestkf(U_collect_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_g2l_state, U_l2g_state, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_prepoststep, outflag) + INTEGER, INTENT(out) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_cvt, & ! Apply control vector transform matrix to control vector + U_cvt_adj, & ! Apply adjoint control vector transform matrix + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_obs_op_f, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_f, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_state, & ! Get state on local ana. domain from full state + U_l2g_state, & ! Init full state from state on local analysis domain + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l ! Provide product R^-1 A on local analysis domain + END SUBROUTINE PDAF_put_state_hyb3dvar_lestkf END INTERFACE INTERFACE - SUBROUTINE PDAFomi_put_state_lenkf_si(flag) - INTEGER, INTENT(out) :: flag ! Status flag - END SUBROUTINE PDAFomi_put_state_lenkf_si + SUBROUTINE PDAF_assimilate_3dvar(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & + U_prepoststep, U_next_observation, outflag) + INTEGER, INTENT(out) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state, & ! Routine to distribute a state vector + U_cvt, & ! Apply control vector transform matrix to control vector + U_cvt_adj, & ! Apply adjoint control vector transform matrix + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + END SUBROUTINE PDAF_assimilate_3dvar END INTERFACE INTERFACE - SUBROUTINE PDAFomi_put_state_lenkf(U_collect_state, U_init_dim_obs, U_obs_op, & - U_prepoststep, U_localize, flag) - INTEGER, INTENT(out) :: flag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_init_dim_obs, & ! Initialize dimension of observation vector - U_obs_op, & ! Observation operator - U_prepoststep, & ! User supplied pre/poststep routine - U_localize ! Apply localization to HP and HPH^T - END SUBROUTINE PDAFomi_put_state_lenkf - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_assimilate_lenkf(U_collect_state, U_distribute_state, & - U_init_dim_obs, U_obs_op, U_prepoststep, U_localize, & - U_next_observation, flag) - INTEGER, INTENT(out) :: flag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_distribute_state, & ! Routine to distribute a state vector - U_init_dim_obs, & ! Initialize dimension of observation vector - U_obs_op, & ! Observation operator - U_prepoststep, & ! User supplied pre/poststep routine - U_localize, & ! Apply localization to HP and HPH^T - U_next_observation ! Provide time step and time of next observation - END SUBROUTINE PDAFomi_assimilate_lenkf - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_put_state_generate_obs(U_collect_state, U_init_dim_obs_f, U_obs_op_f, & - U_get_obs_f, U_prepoststep, flag) - INTEGER, INTENT(out) :: flag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_init_dim_obs_f, & ! Initialize dimension of observation vector - U_obs_op_f, & ! Observation operator - U_get_obs_f, & ! Provide observation vector to user - U_prepoststep ! User supplied pre/poststep routine - END SUBROUTINE PDAFomi_put_state_generate_obs - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_generate_obs(U_collect_state, U_distribute_state, & - U_init_dim_obs_f, U_obs_op_f, U_get_obs_f, U_prepoststep, & - U_next_observation, flag) - INTEGER, INTENT(out) :: flag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_distribute_state, & ! Routine to distribute a state vector - U_init_dim_obs_f, & ! Initialize dimension of observation vector - U_obs_op_f, & ! Observation operator - U_get_obs_f, & ! Provide observation vector to user - U_prepoststep, & ! User supplied pre/poststep routine - U_next_observation ! Provide time step and time of next observation - END SUBROUTINE PDAFomi_generate_obs - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_assimilate_3dvar(collect_state_pdaf, distribute_state_pdaf, & - init_dim_obs_pdaf, obs_op_pdaf, & - cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & - prepoststep_pdaf, next_observation_pdaf, outflag) - INTEGER, INTENT(inout) :: outflag ! Status flag - EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector - distribute_state_pdaf, & ! Routine to distribute a state vector - next_observation_pdaf, & ! Provide time step, time and dimension of next observation - prepoststep_pdaf ! User supplied pre/poststep routine - EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector - obs_op_pdaf, & ! Observation operator - cvt_pdaf, & ! Apply control vector transform matrix to control vector - cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix - obs_op_lin_pdaf, & ! Linearized observation operator - obs_op_adj_pdaf ! Adjoint observation operator - EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector - PDAFomi_prodRinvA_cb ! Provide product R^-1 A - END SUBROUTINE PDAFomi_assimilate_3dvar - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_assimilate_en3dvar_estkf(collect_state_pdaf, distribute_state_pdaf, & - init_dim_obs_pdaf, obs_op_pdaf, & - cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & - prepoststep_pdaf, next_observation_pdaf, outflag) - INTEGER, INTENT(inout) :: outflag ! Status flag - EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector - distribute_state_pdaf, & ! Routine to distribute a state vector - next_observation_pdaf, & ! Provide time step, time and dimension of next observation - prepoststep_pdaf ! User supplied pre/poststep routine - EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector - obs_op_pdaf, & ! Observation operator - cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector - cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix - obs_op_lin_pdaf, & ! Linearized observation operator - obs_op_adj_pdaf ! Adjoint observation operator - EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector - PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance - PDAFomi_init_obscovar_cb, & ! Initialize mean observation error variance - PDAFomi_add_obs_error_cb, & ! Add observation error covariance matrix - PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A - PDAFomi_likelihood_cb ! Compute likelihood - END SUBROUTINE PDAFomi_assimilate_en3dvar_estkf - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_assimilate_en3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & - init_dim_obs_f_pdaf, obs_op_f_pdaf, & - cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & - init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & - g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) - INTEGER, INTENT(inout) :: outflag ! Status flag - EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector - distribute_state_pdaf, & ! Routine to distribute a state vector - next_observation_pdaf, & ! Provide time step, time and dimension of next observation - prepoststep_pdaf ! User supplied pre/poststep routine - EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector - cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix - obs_op_lin_pdaf, & ! Linearized observation operator - obs_op_adj_pdaf ! Adjoint observation operator - EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains - init_dim_l_pdaf, & ! Init state dimension for local ana. domain - g2l_state_pdaf, & ! Get state on local ana. domain from full state - l2g_state_pdaf, & ! Init full state from local state - init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector - obs_op_f_pdaf, & ! Full observation operator - init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector - EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector - PDAFomi_init_obs_l_cb, & ! Initialize local observation vector - PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance - PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance - PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A - PDAFomi_g2l_obs_cb, & ! Restrict full obs. vector to local analysis domain - PDAFomi_prodRinvA_l_cb, & ! Provide product R^-1 A on local analysis domain - PDAFomi_likelihood_l_cb ! Compute likelihood and apply localization - END SUBROUTINE PDAFomi_assimilate_en3dvar_lestkf - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_assimilate_hyb3dvar_estkf(collect_state_pdaf, distribute_state_pdaf, & - init_dim_obs_pdaf, obs_op_pdaf, & - cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & - obs_op_lin_pdaf, obs_op_adj_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) - INTEGER, INTENT(inout) :: outflag ! Status flag - EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector - distribute_state_pdaf, & ! Routine to distribute a state vector - next_observation_pdaf, & ! Provide time step, time and dimension of next observation - prepoststep_pdaf ! User supplied pre/poststep routine - EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector - obs_op_pdaf, & ! Observation operator - cvt_pdaf, & ! Apply control vector transform matrix to control vector - cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix - cvt_ens_pdaf, & ! Apply ensemble control vector transform matrix to control vector - cvt_adj_ens_pdaf, & ! Apply adjoint ensemble control vector transform matrix - obs_op_lin_pdaf, & ! Linearized observation operator - obs_op_adj_pdaf ! Adjoint observation operator - EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector - PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance - PDAFomi_init_obscovar_cb, & ! Initialize mean observation error variance - PDAFomi_add_obs_error_cb, & ! Add observation error covariance matrix - PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A - PDAFomi_likelihood_cb ! Compute likelihood - END SUBROUTINE PDAFomi_assimilate_hyb3dvar_estkf - END INTERFACE - - INTERFACE - SUBROUTINE PDAFomi_assimilate_hyb3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & - init_dim_obs_f_pdaf, obs_op_f_pdaf, & - cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & - init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & - g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) - INTEGER, INTENT(inout) :: outflag ! Status flag - EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector - distribute_state_pdaf, & ! Routine to distribute a state vector - next_observation_pdaf, & ! Provide time step, time and dimension of next observation - prepoststep_pdaf ! User supplied pre/poststep routine - EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector - cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix - cvt_pdaf, & ! Apply control vector transform matrix to control vector - cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix - obs_op_lin_pdaf, & ! Linearized observation operator - obs_op_adj_pdaf ! Adjoint observation operator - EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains - init_dim_l_pdaf, & ! Init state dimension for local ana. domain - g2l_state_pdaf, & ! Get state on local ana. domain from full state - l2g_state_pdaf, & ! Init full state from local state - init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector - obs_op_f_pdaf, & ! Full observation operator - init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector - EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector - PDAFomi_init_obs_l_cb, & ! Initialize local observation vector - PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance - PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance - PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A - PDAFomi_g2l_obs_cb, & ! Restrict full obs. vector to local analysis domain - PDAFomi_prodRinvA_l_cb, & ! Provide product R^-1 A on local analysis domain - PDAFomi_likelihood_l_cb ! Compute likelihood and apply localization - END SUBROUTINE PDAFomi_assimilate_hyb3dvar_lestkf - END INTERFACE - - INTERFACE - SUBROUTINE PDAF_assimilate_3dvar(U_collect_state, U_distribute_state, & - U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & - U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & - U_prepoststep, U_next_observation, outflag) - INTEGER, INTENT(out) :: outflag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_init_dim_obs, & ! Initialize dimension of observation vector - U_obs_op, & ! Observation operator - U_init_obsvar, & ! Initialize mean observation error variance - U_init_obs, & ! Initialize observation vector - U_prepoststep, & ! User supplied pre/poststep routine - U_prodRinvA, & ! Provide product R^-1 A - U_next_observation, & ! Routine to provide time step, time and dimension - ! of next observation - U_distribute_state, & ! Routine to distribute a state vector - U_cvt, & ! Apply control vector transform matrix to control vector - U_cvt_adj, & ! Apply adjoint control vector transform matrix - U_obs_op_lin, & ! Linearized observation operator - U_obs_op_adj ! Adjoint observation operator - END SUBROUTINE PDAF_assimilate_3dvar - END INTERFACE - - INTERFACE - SUBROUTINE PDAF_assimilate_en3dvar_estkf(U_collect_state, U_distribute_state, & - U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & - U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & - U_init_obsvar, U_prepoststep, U_next_observation, outflag) - INTEGER, INTENT(out) :: outflag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_init_dim_obs, & ! Initialize dimension of observation vector - U_obs_op, & ! Observation operator - U_init_obsvar, & ! Initialize mean observation error variance - U_init_obs, & ! Initialize observation vector - U_prepoststep, & ! User supplied pre/poststep routine - U_prodRinvA, & ! Provide product R^-1 A - U_next_observation, & ! Routine to provide time step, time and dimension - ! of next observation - U_distribute_state, & ! Routine to distribute a state vector - U_cvt_ens, & ! Apply control vector transform matrix (ensemble) - U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) - U_cvt, & ! Apply control vector transform matrix to control vector - U_cvt_adj, & ! Apply adjoint control vector transform matrix - U_obs_op_lin, & ! Linearized observation operator - U_obs_op_adj ! Adjoint observation operator - END SUBROUTINE PDAF_assimilate_en3dvar_estkf + SUBROUTINE PDAF_assimilate_en3dvar_estkf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & + U_init_obsvar, U_prepoststep, U_next_observation, outflag) + INTEGER, INTENT(out) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state, & ! Routine to distribute a state vector + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_cvt, & ! Apply control vector transform matrix to control vector + U_cvt_adj, & ! Apply adjoint control vector transform matrix + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + END SUBROUTINE PDAF_assimilate_en3dvar_estkf END INTERFACE INTERFACE @@ -1538,54 +1428,815 @@ SUBROUTINE PDAF_assimilate_hyb3dvar_lestkf(U_collect_state, U_distribute_state, END SUBROUTINE PDAF_assimilate_hyb3dvar_lestkf END INTERFACE + INTERFACE + SUBROUTINE PDAF_set_debug_flag(debugval) + INTEGER, INTENT(in) :: debugval ! Value of debugging flag; print debug information for >0 + END SUBROUTINE PDAF_set_debug_flag + END INTERFACE + + INTERFACE + SUBROUTINE PDAF_set_offline_mode(screen) + INTEGER, INTENT(in) :: screen ! Verbosity flag + END SUBROUTINE PDAF_set_offline_mode + END INTERFACE + INTERFACE - SUBROUTINE PDAFomi_put_state_3dvar(collect_state_pdaf, init_dim_obs_pdaf, obs_op_pdaf, & - cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, prepoststep_pdaf, outflag) - INTEGER, INTENT(inout) :: outflag ! Status flag - EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector - prepoststep_pdaf ! User supplied pre/poststep routine - EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector - obs_op_pdaf, & ! Observation operator - cvt_pdaf, & ! Apply control vector transform matrix to control vector - cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix - obs_op_lin_pdaf, & ! Linearized observation operator - obs_op_adj_pdaf ! Adjoint observation operator - EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector - PDAFomi_prodRinvA_cb ! Provide product R^-1 A - END SUBROUTINE PDAFomi_put_state_3dvar + SUBROUTINE PDAF_g2l(dim_p, dim_l, idx_l_in_p, state_p, state_l) + INTEGER, INTENT(in) :: dim_p !< PE-local full state dimension + INTEGER, INTENT(in) :: dim_l !< Local state dimension + INTEGER, INTENT(in) :: idx_l_in_p(dim_l) !< Index array for projection + REAL, INTENT(in) :: state_p(dim_p) !< PE-local full state vector + REAL, INTENT(out) :: state_l(dim_l) !< State vector on local analysis domain + END SUBROUTINE PDAF_g2l END INTERFACE INTERFACE - SUBROUTINE PDAFomi_put_state_en3dvar_estkf(collect_state_pdaf, & - init_dim_obs_pdaf, obs_op_pdaf, & - cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & - prepoststep_pdaf, outflag) - INTEGER, INTENT(inout) :: outflag ! Status flag - EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector - prepoststep_pdaf ! User supplied pre/poststep routine - EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector - obs_op_pdaf, & ! Observation operator - cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector - cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix - obs_op_lin_pdaf, & ! Linearized observation operator - obs_op_adj_pdaf ! Adjoint observation operator - EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector - PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance - PDAFomi_init_obscovar_cb, & ! Initialize mean observation error variance - PDAFomi_add_obs_error_cb, & ! Add observation error covariance matrix - PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A - PDAFomi_likelihood_cb ! Compute likelihood - END SUBROUTINE PDAFomi_put_state_en3dvar_estkf + SUBROUTINE PDAF_l2g(dim_p, dim_l, idx_l_in_p, state_p, state_l) + INTEGER, INTENT(in) :: dim_p !< PE-local full state dimension + INTEGER, INTENT(in) :: dim_l !< Local state dimension + INTEGER, INTENT(in) :: idx_l_in_p(dim_l) !< Index array for projection + REAL, INTENT(inout) :: state_p(dim_p) !< PE-local full state vector + REAL, INTENT(in) :: state_l(dim_l) !< State vector on local analysis domain + END SUBROUTINE PDAF_l2g END INTERFACE + +! OMI INTERFACES --------------------- + INTERFACE - SUBROUTINE PDAFomi_put_state_en3dvar_lestkf(collect_state_pdaf, & - init_dim_obs_f_pdaf, obs_op_f_pdaf, & - cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & - init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & - g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, outflag) - INTEGER, INTENT(inout) :: outflag ! Status flag - EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + SUBROUTINE PDAFomi_put_state_global(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFomi_put_state_global + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_global_nondiagR(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prodRinvA, U_prepoststep, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_prodRinvA, & ! Provide product R^-1 A + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFomi_put_state_global_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_nonlin_nondiagR(U_collect_state, U_init_dim_obs, U_obs_op, & + U_likelihood, U_prepoststep, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_likelihood, & ! Compute likelihood + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFomi_put_state_nonlin_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_enkf_nondiagR(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, U_add_obs_err, U_init_obs_covar, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_add_obs_err, & ! Add obs error covariance R to HPH in EnKF + U_init_obs_covar, & ! Initialize obs. error cov. matrix R in EnKF + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFomi_put_state_enkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_lenkf_nondiagR(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, U_localize, U_add_obs_err, U_init_obs_covar, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_add_obs_err, & ! Add obs error covariance R to HPH in EnKF + U_init_obs_covar, & ! Initialize obs. error cov. matrix R in EnKF + U_localize, & ! Apply localization to HP and HPH^T + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFomi_put_state_lenkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_global(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prepoststep, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFomi_assimilate_global + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_local(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_state, U_l2g_state, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_g2l_state, & ! Get state on local ana. domain from full state + U_l2g_state, & ! Init full state from state on local analysis domain + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFomi_put_state_local + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_local_nondiagR(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_prodRinvA_l, & + U_g2l_state, U_l2g_state, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_g2l_state, & ! Get state on local ana. domain from full state + U_l2g_state, & ! Init full state from state on local analysis domain + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFomi_put_state_local_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_lnetf_nondiagR(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_likelihood_l, & + U_g2l_state, U_l2g_state, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_likelihood_l, & ! Compute likelihood and apply localization + U_g2l_state, & ! Get state on local ana. domain from full state + U_l2g_state, & ! Init full state from state on local analysis domain + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFomi_put_state_lnetf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_lknetf_nondiagR(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_prodRinvA_l, U_prodRinvA_hyb_l, U_likelihood_l, U_likelihood_hyb_l, & + U_g2l_state, U_l2g_state, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prodRinvA_hyb_l, & ! Product R^-1 A on local analysis domain with hybrid weight + U_likelihood_l, & ! Compute likelihood and apply localization + U_likelihood_hyb_l, & ! Compute likelihood and apply localization with tempering + U_g2l_state, & ! Get state on local ana. domain from full state + U_l2g_state, & ! Init full state from state on local analysis domain + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFomi_put_state_lknetf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_local(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prepoststep, U_init_n_domains_p, U_init_dim_l, & + U_init_dim_obs_l, U_g2l_state, U_l2g_state, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_g2l_state, & ! Get state on local ana. domain from full state + U_l2g_state, & ! Init full state from state on local analysis domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFomi_assimilate_local + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_local_nondiagR(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prepoststep, U_init_n_domains_p, U_init_dim_l, & + U_init_dim_obs_l, U_prodRinvA_l, U_g2l_state, U_l2g_state, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_g2l_state, & ! Get state on local ana. domain from full state + U_l2g_state, & ! Init full state from state on local analysis domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFomi_assimilate_local_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_lnetf_nondiagR(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prepoststep, U_init_n_domains_p, U_init_dim_l, & + U_init_dim_obs_l, U_likelihood_l, U_g2l_state, U_l2g_state, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_likelihood_l, & ! Compute likelihood and apply localization + U_g2l_state, & ! Get state on local ana. domain from full state + U_l2g_state, & ! Init full state from state on local analysis domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFomi_assimilate_lnetf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_lknetf_nondiagR(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prepoststep, U_init_n_domains_p, U_init_dim_l, & + U_init_dim_obs_l, U_prodRinvA_l, U_prodRinvA_hyb_l, U_likelihood_l, U_likelihood_hyb_l, & + U_g2l_state, U_l2g_state, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prodRinvA_hyb_l, & ! Product R^-1 A on local analysis domain with hybrid weight + U_likelihood_l, & ! Compute likelihood and apply localization + U_likelihood_hyb_l, & ! Compute likelihood and apply localization with tempering + U_g2l_state, & ! Get state on local ana. domain from full state + U_l2g_state, & ! Init full state from state on local analysis domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFomi_assimilate_lknetf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_global_nondiagR(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prodRinvA, U_prepoststep, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_prodRinvA, & ! Provide product R^-1 A + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFomi_assimilate_global_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_nonlin_nondiagR(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_likelihood, U_prepoststep, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_likelihood, & ! Compute likelihood + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFomi_assimilate_nonlin_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_enkf_nondiagR(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_add_obs_err, U_init_obs_covar, & + U_prepoststep, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_add_obs_err, & ! Add obs error covariance R to HPH in EnKF + U_init_obs_covar, & ! Initialize obs. error cov. matrix R in EnKF + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFomi_assimilate_enkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_lenkf_nondiagR(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prepoststep, U_localize, & + U_add_obs_error, U_init_obs_covar, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obs_covar, & ! Initialize obs. error cov. matrix R in EnKF + U_prepoststep, & ! User supplied pre/poststep routine + U_localize, & ! Apply localization to HP and HPH^T + U_add_obs_error, & ! Add obs error covariance R to HPH in EnKF + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFomi_assimilate_lenkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_local_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_put_state_local_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_local_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_assimilate_local_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_local_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_assimilate_local_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_global_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_assimilate_global_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_enkf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_assimilate_enkf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_nonlin_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_assimilate_nonlin_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_lenkf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_assimilate_lenkf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_lnetf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_assimilate_lnetf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_lknetf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_assimilate_lknetf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_global_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_put_state_global_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_global_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_assimilate_global_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_lenkf_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_assimilate_lenkf_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_lenkf_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_put_state_lenkf_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_local_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_put_state_local_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_global_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_put_state_global_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_enkf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_put_state_enkf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_nonlin_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_put_state_nonlin_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_lenkf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_put_state_lenkf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_lknetf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_put_state_lknetf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_lnetf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFomi_put_state_lnetf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_lenkf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, U_localize, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_prepoststep, & ! User supplied pre/poststep routine + U_localize ! Apply localization to HP and HPH^T + END SUBROUTINE PDAFomi_put_state_lenkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_lenkf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prepoststep, U_localize, & + U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_prepoststep, & ! User supplied pre/poststep routine + U_localize, & ! Apply localization to HP and HPH^T + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFomi_assimilate_lenkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_generate_obs(U_collect_state, U_init_dim_obs_f, U_obs_op_f, & + U_get_obs_f, U_prepoststep, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_obs_op_f, & ! Observation operator + U_get_obs_f, & ! Provide observation vector to user + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFomi_put_state_generate_obs + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_generate_obs(U_collect_state, U_distribute_state, & + U_init_dim_obs_f, U_obs_op_f, U_get_obs_f, U_prepoststep, & + U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_obs_op_f, & ! Observation operator + U_get_obs_f, & ! Provide observation vector to user + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFomi_generate_obs + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_3dvar(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, & + cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf, & ! Observation operator + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_prodRinvA_cb ! Provide product R^-1 A + END SUBROUTINE PDAFomi_assimilate_3dvar + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_3dvar_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, prodRinvA_pdaf, & + cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf, & ! Observation operator + prodRinvA_pdaf, & ! Provide product R^-1 A + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + END SUBROUTINE PDAFomi_assimilate_3dvar_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_en3dvar_estkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf, & ! Observation operator + cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + END SUBROUTINE PDAFomi_assimilate_en3dvar_estkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_en3dvar_estkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf, & ! Observation operator + prodRinvA_pdaf, & ! Provide product R^-1 A + cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + END SUBROUTINE PDAFomi_assimilate_en3dvar_estkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_en3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf, & ! Init full state from local state + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + END SUBROUTINE PDAFomi_assimilate_en3dvar_lestkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_en3dvar_lestkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prodRinvA_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + prodRinvA_pdaf, & ! Provide product R^-1 A + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf, & ! Init full state from local state + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdaf ! Provide product R^-1 A with localization + END SUBROUTINE PDAFomi_assimilate_en3dvar_lestkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_hyb3dvar_estkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdaf, obs_op_adj_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf, & ! Observation operator + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + cvt_ens_pdaf, & ! Apply ensemble control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint ensemble control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + END SUBROUTINE PDAFomi_assimilate_hyb3dvar_estkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_hyb3dvar_estkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdaf, obs_op_adj_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf, & ! Observation operator + prodRinvA_pdaf, & ! Provide product R^-1 A + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + END SUBROUTINE PDAFomi_assimilate_hyb3dvar_estkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_hyb3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf, & ! Init full state from local state + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + END SUBROUTINE PDAFomi_assimilate_hyb3dvar_lestkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prodRinvA_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + prodRinvA_pdaf, & ! Provide product R^-1 A + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf, & ! Init full state from local state + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdaf ! Provide product R^-1 A with localization + END SUBROUTINE PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_3dvar(collect_state_pdaf, init_dim_obs_pdaf, obs_op_pdaf, & + cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf, & ! Observation operator + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + END SUBROUTINE PDAFomi_put_state_3dvar + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_3dvar_nondiagR(collect_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, prodRinvA_pdaf, & + cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf, & ! Observation operator + prodRinvA_pdaf, & ! Provide product R^-1 A + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + END SUBROUTINE PDAFomi_put_state_3dvar_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_en3dvar_estkf(collect_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf, & ! Observation operator + cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + END SUBROUTINE PDAFomi_put_state_en3dvar_estkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_en3dvar_estkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf, & ! Observation operator + prodRinvA_pdaf, & ! Provide product R^-1 A + cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + END SUBROUTINE PDAFomi_put_state_en3dvar_estkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFomi_put_state_en3dvar_lestkf(collect_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector prepoststep_pdaf ! User supplied pre/poststep routine EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix @@ -1598,17 +2249,34 @@ SUBROUTINE PDAFomi_put_state_en3dvar_lestkf(collect_state_pdaf, & init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector obs_op_f_pdaf, & ! Full observation operator init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector - EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector - PDAFomi_init_obs_l_cb, & ! Initialize local observation vector - PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance - PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance - PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A - PDAFomi_g2l_obs_cb, & ! Restrict full obs. vector to local analysis domain - PDAFomi_prodRinvA_l_cb, & ! Provide product R^-1 A on local analysis domain - PDAFomi_likelihood_l_cb ! Compute likelihood and apply localization END SUBROUTINE PDAFomi_put_state_en3dvar_lestkf END INTERFACE + INTERFACE + SUBROUTINE PDAFomi_put_state_en3dvar_lestkf_nondiagR(collect_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prodRinvA_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + prodRinvA_pdaf, & ! Provide product R^-1 A + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf, & ! Init full state from local state + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdaf ! Provide product R^-1 A with localization + END SUBROUTINE PDAFomi_put_state_en3dvar_lestkf_nondiagR + END INTERFACE + INTERFACE SUBROUTINE PDAFomi_put_state_hyb3dvar_estkf(collect_state_pdaf, & init_dim_obs_pdaf, obs_op_pdaf, & @@ -1625,15 +2293,29 @@ SUBROUTINE PDAFomi_put_state_hyb3dvar_estkf(collect_state_pdaf, & cvt_adj_ens_pdaf, & ! Apply adjoint ensemble control vector transform matrix obs_op_lin_pdaf, & ! Linearized observation operator obs_op_adj_pdaf ! Adjoint observation operator - EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector - PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance - PDAFomi_init_obscovar_cb, & ! Initialize mean observation error variance - PDAFomi_add_obs_error_cb, & ! Add observation error covariance matrix - PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A - PDAFomi_likelihood_cb ! Compute likelihood END SUBROUTINE PDAFomi_put_state_hyb3dvar_estkf END INTERFACE + INTERFACE + SUBROUTINE PDAFomi_put_state_hyb3dvar_estkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdaf, obs_op_adj_pdaf, prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf, & ! Observation operator + prodRinvA_pdaf, & ! Provide product R^-1 A + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + END SUBROUTINE PDAFomi_put_state_hyb3dvar_estkf_nondiagR + END INTERFACE + INTERFACE SUBROUTINE PDAFomi_put_state_hyb3dvar_lestkf(collect_state_pdaf, & init_dim_obs_f_pdaf, obs_op_f_pdaf, & @@ -1656,161 +2338,34 @@ SUBROUTINE PDAFomi_put_state_hyb3dvar_lestkf(collect_state_pdaf, & init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector obs_op_f_pdaf, & ! Full observation operator init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector - EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector - PDAFomi_init_obs_l_cb, & ! Initialize local observation vector - PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance - PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance - PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A - PDAFomi_g2l_obs_cb, & ! Restrict full obs. vector to local analysis domain - PDAFomi_prodRinvA_l_cb, & ! Provide product R^-1 A on local analysis domain - PDAFomi_likelihood_l_cb ! Compute likelihood and apply localization END SUBROUTINE PDAFomi_put_state_hyb3dvar_lestkf END INTERFACE INTERFACE - SUBROUTINE PDAF_put_state_3dvar(U_collect_state, & - U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & - U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & - U_prepoststep, outflag) - INTEGER, INTENT(out) :: outflag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_init_dim_obs, & ! Initialize dimension of observation vector - U_obs_op, & ! Observation operator - U_init_obsvar, & ! Initialize mean observation error variance - U_init_obs, & ! Initialize observation vector - U_prepoststep, & ! User supplied pre/poststep routine - U_prodRinvA, & ! Provide product R^-1 A - U_cvt, & ! Apply control vector transform matrix to control vector - U_cvt_adj, & ! Apply adjoint control vector transform matrix - U_obs_op_lin, & ! Linearized observation operator - U_obs_op_adj ! Adjoint observation operator - END SUBROUTINE PDAF_put_state_3dvar - END INTERFACE - - INTERFACE - SUBROUTINE PDAF_put_state_en3dvar_estkf(U_collect_state, & - U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & - U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & - U_init_obsvar, U_prepoststep, outflag) - INTEGER, INTENT(out) :: outflag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_init_dim_obs, & ! Initialize dimension of observation vector - U_obs_op, & ! Observation operator - U_init_obs, & ! Initialize observation vector - U_prepoststep, & ! User supplied pre/poststep routine - U_prodRinvA, & ! Provide product R^-1 A - U_cvt_ens, & ! Apply control vector transform matrix (ensemble) - U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) - U_obs_op_lin, & ! Linearized observation operator - U_obs_op_adj ! Adjoint observation operator - EXTERNAL :: U_init_obsvar ! Initialize mean observation error variance - END SUBROUTINE PDAF_put_state_en3dvar_estkf - END INTERFACE - - INTERFACE - SUBROUTINE PDAF_put_state_en3dvar_lestkf(U_collect_state, U_init_dim_obs, U_obs_op, & - U_init_obs, U_prodRinvA, & - U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & - U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & - U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_g2l_state, U_l2g_state, & - U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & - U_prepoststep, outflag) - INTEGER, INTENT(out) :: outflag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_init_dim_obs, & ! Initialize dimension of observation vector - U_obs_op, & ! Observation operator - U_init_obs, & ! Initialize observation vector - U_prepoststep, & ! User supplied pre/poststep routine - U_prodRinvA, & ! Provide product R^-1 A - U_cvt_ens, & ! Apply control vector transform matrix (ensemble) - U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) - U_obs_op_lin, & ! Linearized observation operator - U_obs_op_adj ! Adjoint observation operator - EXTERNAL :: U_obs_op_f, & ! Observation operator - U_init_n_domains_p, & ! Provide number of local analysis domains - U_init_dim_l, & ! Init state dimension for local ana. domain - U_init_dim_obs_f, & ! Initialize dimension of observation vector - U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain - U_init_obs_f, & ! Initialize PE-local observation vector - U_init_obs_l, & ! Init. observation vector on local analysis domain - U_init_obsvar, & ! Initialize mean observation error variance - U_init_obsvar_l, & ! Initialize local mean observation error variance - U_g2l_state, & ! Get state on local ana. domain from full state - U_l2g_state, & ! Init full state from state on local analysis domain - U_g2l_obs, & ! Restrict full obs. vector to local analysis domain - U_prodRinvA_l ! Provide product R^-1 A on local analysis domain - END SUBROUTINE PDAF_put_state_en3dvar_lestkf - END INTERFACE - - INTERFACE - SUBROUTINE PDAF_put_state_hyb3dvar_estkf(U_collect_state, U_init_dim_obs, U_obs_op, & - U_init_obs, U_prodRinvA, & - U_cvt, U_cvt_adj, U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & - U_init_obsvar, U_prepoststep, outflag) - INTEGER, INTENT(out) :: outflag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_init_dim_obs, & ! Initialize dimension of observation vector - U_obs_op, & ! Observation operator - U_init_obs, & ! Initialize observation vector - U_prepoststep, & ! User supplied pre/poststep routine - U_prodRinvA, & ! Provide product R^-1 A - U_cvt_ens, & ! Apply control vector transform matrix (ensemble) - U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) - U_cvt, & ! Apply control vector transform matrix to control vector - U_cvt_adj, & ! Apply adjoint control vector transform matrix - U_obs_op_lin, & ! Linearized observation operator - U_obs_op_adj ! Adjoint observation operator - EXTERNAL :: U_init_obsvar ! Initialize mean observation error variance - END SUBROUTINE PDAF_put_state_hyb3dvar_estkf - END INTERFACE - - INTERFACE - SUBROUTINE PDAF_put_state_hyb3dvar_lestkf(U_collect_state, & - U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & - U_cvt_ens, U_cvt_adj_ens, U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & - U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & - U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_g2l_state, U_l2g_state, & - U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & - U_prepoststep, outflag) - INTEGER, INTENT(out) :: outflag ! Status flag - EXTERNAL :: U_collect_state, & ! Routine to collect a state vector - U_init_dim_obs, & ! Initialize dimension of observation vector - U_obs_op, & ! Observation operator - U_init_obs, & ! Initialize observation vector - U_prepoststep, & ! User supplied pre/poststep routine - U_prodRinvA, & ! Provide product R^-1 A - U_cvt_ens, & ! Apply control vector transform matrix (ensemble) - U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) - U_cvt, & ! Apply control vector transform matrix to control vector - U_cvt_adj, & ! Apply adjoint control vector transform matrix - U_obs_op_lin, & ! Linearized observation operator - U_obs_op_adj ! Adjoint observation operator - EXTERNAL :: U_obs_op_f, & ! Observation operator - U_init_n_domains_p, & ! Provide number of local analysis domains - U_init_dim_l, & ! Init state dimension for local ana. domain - U_init_dim_obs_f, & ! Initialize dimension of observation vector - U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain - U_init_obs_f, & ! Initialize PE-local observation vector - U_init_obs_l, & ! Init. observation vector on local analysis domain - U_init_obsvar, & ! Initialize mean observation error variance - U_init_obsvar_l, & ! Initialize local mean observation error variance - U_g2l_state, & ! Get state on local ana. domain from full state - U_l2g_state, & ! Init full state from state on local analysis domain - U_g2l_obs, & ! Restrict full obs. vector to local analysis domain - U_prodRinvA_l ! Provide product R^-1 A on local analysis domain - END SUBROUTINE PDAF_put_state_hyb3dvar_lestkf - END INTERFACE - - INTERFACE - SUBROUTINE PDAF_set_debug_flag(debugval) - INTEGER, INTENT(in) :: debugval ! Value of debugging flag; print debug information for >0 - END SUBROUTINE PDAF_set_debug_flag - END INTERFACE - - INTERFACE - SUBROUTINE PDAF_set_offline_mode(screen) - INTEGER, INTENT(in) :: screen ! Verbosity flag - END SUBROUTINE PDAF_set_offline_mode + SUBROUTINE PDAFomi_put_state_hyb3dvar_lestkf_nondiagR(collect_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prodRinvA_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + prodRinvA_pdaf, & ! Provide product R^-1 A + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf, & ! Init full state from local state + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdaf ! Provide product R^-1 A with localization + END SUBROUTINE PDAFomi_put_state_hyb3dvar_lestkf_nondiagR END INTERFACE END MODULE PDAF_interfaces_module diff --git a/src/PDAF_lestkf_analysis.F90 b/src/PDAF_lestkf_analysis.F90 index d3d582024..3f273abe3 100644 --- a/src/PDAF_lestkf_analysis.F90 +++ b/src/PDAF_lestkf_analysis.F90 @@ -572,7 +572,7 @@ SUBROUTINE PDAF_lestkf_analysis(domain_p, step, dim_l, dim_obs_f, dim_obs_l, & OmegaT = OmegaT_in ! A = (Omega C^(-1)) by solving Ct A = OmegaT for A - CALL trtrsTYPE('l', 't', 'n', rank, dim_ens, & + CALL trtrsTYPE('L', 'T', 'N', rank, dim_ens, & tmp_Ainv_l, rank, OmegaT, rank, lib_info) ELSE ! TEMP_AINV already contains matrix C (no more inversion) diff --git a/src/PDAF_lestkf_memtime.F90 b/src/PDAF_lestkf_memtime.F90 index e87014047..7db57178d 100644 --- a/src/PDAF_lestkf_memtime.F90 +++ b/src/PDAF_lestkf_memtime.F90 @@ -45,6 +45,8 @@ SUBROUTINE PDAF_lestkf_memtime(printtype) ONLY: filterpe, mype_world, COMM_pdaf USE PDAFomi, & ONLY: omi_was_used + USE PDAFlocal, & + ONLY: pdaflocal_was_used IMPLICIT NONE @@ -138,9 +140,10 @@ SUBROUTINE PDAF_lestkf_memtime(printtype) time_omi, 's' WRITE (*, '(a, 12x, a, 11x, F11.3, 1x, a)') 'PDAF', 'init_n_domains_pdaf:', pdaf_time_tot(42), 's' WRITE (*, '(a, 12x, a, 15x, F11.3, 1x, a)') 'PDAF', 'init_dim_l_pdaf:', pdaf_time_tot(45), 's' - WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' - WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' - + IF (.NOT.pdaflocal_was_used) THEN + WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' + WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' + END IF WRITE (*, '(a, 12x, a)') 'PDAF', 'Time in OMI observation module routines ' WRITE (*, '(a, 14x, a, 8x, F11.3, 1x, a)') 'PDAF', 'init_dim_obs_pdafomi:', pdaf_time_tot(43), 's' WRITE (*, '(a, 14x, a, 14x, F11.3, 1x, a)') 'PDAF', 'obs_op_pdafomi:', pdaf_time_tot(44), 's' diff --git a/src/PDAF_letkf_memtime.F90 b/src/PDAF_letkf_memtime.F90 index 4449b285a..8814fb2ce 100644 --- a/src/PDAF_letkf_memtime.F90 +++ b/src/PDAF_letkf_memtime.F90 @@ -45,6 +45,8 @@ SUBROUTINE PDAF_letkf_memtime(printtype) ONLY: filterpe, mype_world, COMM_pdaf USE PDAFomi, & ONLY: omi_was_used + USE PDAFlocal, & + ONLY: pdaflocal_was_used IMPLICIT NONE @@ -138,9 +140,10 @@ SUBROUTINE PDAF_letkf_memtime(printtype) time_omi, 's' WRITE (*, '(a, 12x, a, 11x, F11.3, 1x, a)') 'PDAF', 'init_n_domains_pdaf:', pdaf_time_tot(42), 's' WRITE (*, '(a, 12x, a, 15x, F11.3, 1x, a)') 'PDAF', 'init_dim_l_pdaf:', pdaf_time_tot(45), 's' - WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' - WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' - + IF (.NOT.pdaflocal_was_used) THEN + WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' + WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' + END IF WRITE (*, '(a, 12x, a)') 'PDAF', 'Time in OMI observation module routines ' WRITE (*, '(a, 14x, a, 8x, F11.3, 1x, a)') 'PDAF', 'init_dim_obs_pdafomi:', pdaf_time_tot(43), 's' WRITE (*, '(a, 14x, a, 14x, F11.3, 1x, a)') 'PDAF', 'obs_op_pdafomi:', pdaf_time_tot(44), 's' diff --git a/src/PDAF_lknetf_memtime.F90 b/src/PDAF_lknetf_memtime.F90 index c2c096fd9..a0519414a 100644 --- a/src/PDAF_lknetf_memtime.F90 +++ b/src/PDAF_lknetf_memtime.F90 @@ -45,6 +45,8 @@ SUBROUTINE PDAF_lknetf_memtime(printtype) ONLY: filterpe, mype_world, COMM_pdaf USE PDAFomi, & ONLY: omi_was_used + USE PDAFlocal, & + ONLY: pdaflocal_was_used IMPLICIT NONE @@ -138,9 +140,10 @@ SUBROUTINE PDAF_lknetf_memtime(printtype) time_omi, 's' WRITE (*, '(a, 12x, a, 11x, F11.3, 1x, a)') 'PDAF', 'init_n_domains_pdaf:', pdaf_time_tot(42), 's' WRITE (*, '(a, 12x, a, 15x, F11.3, 1x, a)') 'PDAF', 'init_dim_l_pdaf:', pdaf_time_tot(45), 's' - WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' - WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' - + IF (.NOT.pdaflocal_was_used) THEN + WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' + WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' + END IF WRITE (*, '(a, 12x, a)') 'PDAF', 'Time in OMI observation module routines ' WRITE (*, '(a, 14x, a, 8x, F11.3, 1x, a)') 'PDAF', 'init_dim_obs_pdafomi:', pdaf_time_tot(43), 's' WRITE (*, '(a, 14x, a, 14x, F11.3, 1x, a)') 'PDAF', 'obs_op_pdafomi:', pdaf_time_tot(44), 's' diff --git a/src/PDAF_lnetf_memtime.F90 b/src/PDAF_lnetf_memtime.F90 index 3fe415c54..d2ecdf680 100644 --- a/src/PDAF_lnetf_memtime.F90 +++ b/src/PDAF_lnetf_memtime.F90 @@ -45,6 +45,8 @@ SUBROUTINE PDAF_lnetf_memtime(printtype) ONLY: filterpe, mype_world, COMM_pdaf USE PDAFomi, & ONLY: omi_was_used + USE PDAFlocal, & + ONLY: pdaflocal_was_used IMPLICIT NONE @@ -137,9 +139,10 @@ SUBROUTINE PDAF_lnetf_memtime(printtype) time_omi, 's' WRITE (*, '(a, 12x, a, 11x, F11.3, 1x, a)') 'PDAF', 'init_n_domains_pdaf:', pdaf_time_tot(42), 's' WRITE (*, '(a, 12x, a, 15x, F11.3, 1x, a)') 'PDAF', 'init_dim_l_pdaf:', pdaf_time_tot(45), 's' - WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' - WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' - + IF (.NOT.pdaflocal_was_used) THEN + WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' + WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' + END IF WRITE (*, '(a, 12x, a)') 'PDAF', 'Time in OMI observation module routines ' WRITE (*, '(a, 14x, a, 8x, F11.3, 1x, a)') 'PDAF', 'init_dim_obs_pdafomi:', pdaf_time_tot(43), 's' WRITE (*, '(a, 14x, a, 14x, F11.3, 1x, a)') 'PDAF', 'obs_op_pdafomi:', pdaf_time_tot(44), 's' diff --git a/src/PDAF_local_weight.F90 b/src/PDAF_local_weight.F90 index 54747515c..a7a5cb724 100644 --- a/src/PDAF_local_weight.F90 +++ b/src/PDAF_local_weight.F90 @@ -154,18 +154,26 @@ SUBROUTINE PDAF_local_weight(wtype, rtype, cradius, sradius, distance, & cradnull: IF (cradius > 0.0 .and. sradius > 0.0) THEN cutoff: IF (distance <= cradius) THEN - IF (distance <= sradius / 2) THEN + IF (distance <= sradius / 2.0) THEN weight = -0.25 * (distance / cfaci)**5 & + 0.5 * (distance / cfaci)**4 & + 5.0 / 8.0 * (distance / cfaci)**3 & - 5.0 / 3.0 * (distance / cfaci)**2 + 1.0 - ELSEIF (distance > sradius / 2 .AND. distance < sradius) THEN + ELSEIF (distance > sradius / 2.0 .AND. distance < sradius * 0.9) THEN weight = 1.0 / 12.0 * (distance / cfaci)**5 & - 0.5 * (distance / cfaci)**4 & + 5.0 / 8.0 * (distance / cfaci)**3 & + 5.0 / 3.0 * (distance / cfaci)**2 & - 5.0 * (distance / cfaci) & + 4.0 - 2.0 / 3.0 * cfaci / distance + ELSEIF (distance >= sradius * 0.9 .AND. distance < sradius) THEN + ! Ensure that weight is non-negative + weight = MAX(1.0 / 12.0 * (distance / cfaci)**5 & + - 0.5 * (distance / cfaci)**4 & + + 5.0 / 8.0 * (distance / cfaci)**3 & + + 5.0 / 3.0 * (distance / cfaci)**2 & + - 5.0 * (distance / cfaci) & + + 4.0 - 2.0 / 3.0 * cfaci / distance, 0.0) ELSE weight = 0.0 ENDIF diff --git a/src/PDAF_lseik_analysis_trans.F90 b/src/PDAF_lseik_analysis_trans.F90 index f4e0fadc2..8fe291ce0 100644 --- a/src/PDAF_lseik_analysis_trans.F90 +++ b/src/PDAF_lseik_analysis_trans.F90 @@ -577,7 +577,7 @@ SUBROUTINE PDAF_lseik_analysis_trans(domain_p, step, dim_l, dim_obs_f, dim_obs_l OmegaT = OmegaT_in ! A = (Omega C^(-1)) by solving Ct A = OmegaT for A - CALL trtrsTYPE('l', 't', 'n', rank, dim_ens, & + CALL trtrsTYPE('L', 'T', 'N', rank, dim_ens, & tmp_Uinv_l, rank, OmegaT, rank, lib_info) ELSE ! TEMP_UINV already contains matrix C (no more inversion) diff --git a/src/PDAF_lseik_memtime.F90 b/src/PDAF_lseik_memtime.F90 index f15fac364..8b398b056 100644 --- a/src/PDAF_lseik_memtime.F90 +++ b/src/PDAF_lseik_memtime.F90 @@ -45,6 +45,8 @@ SUBROUTINE PDAF_lseik_memtime(printtype) ONLY: filterpe, mype_world, COMM_pdaf USE PDAFomi, & ONLY: omi_was_used + USE PDAFlocal, & + ONLY: pdaflocal_was_used IMPLICIT NONE @@ -137,9 +139,10 @@ SUBROUTINE PDAF_lseik_memtime(printtype) time_omi, 's' WRITE (*, '(a, 12x, a, 11x, F11.3, 1x, a)') 'PDAF', 'init_n_domains_pdaf:', pdaf_time_tot(42), 's' WRITE (*, '(a, 12x, a, 15x, F11.3, 1x, a)') 'PDAF', 'init_dim_l_pdaf:', pdaf_time_tot(45), 's' - WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' - WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' - + IF (.NOT.pdaflocal_was_used) THEN + WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'g2l_state_pdaf:', pdaf_time_tot(15), 's' + WRITE (*, '(a, 12x, a, 16x, F11.3, 1x, a)') 'PDAF', 'l2g_state_pdaf:', pdaf_time_tot(16), 's' + END IF WRITE (*, '(a, 12x, a)') 'PDAF', 'Time in OMI observation module routines' WRITE (*, '(a, 14x, a, 8x, F11.3, 1x, a)') 'PDAF', 'init_dim_obs_pdafomi:', pdaf_time_tot(43), 's' WRITE (*, '(a, 14x, a, 14x, F11.3, 1x, a)') 'PDAF', 'obs_op_pdafomi:', pdaf_time_tot(44), 's' diff --git a/src/PDAF_lseik_resample.F90 b/src/PDAF_lseik_resample.F90 index 16af312c3..10999029a 100644 --- a/src/PDAF_lseik_resample.F90 +++ b/src/PDAF_lseik_resample.F90 @@ -273,7 +273,7 @@ SUBROUTINE PDAF_lseik_resample(domain_p, subtype, dim_l, dim_ens, & OmegaT = OmegaT_in ! A = (Omega C^(-1)) by solving Ct A = OmegaT for A - CALL trtrsTYPE('l', 't', 'n', rank, dim_ens, & + CALL trtrsTYPE('L', 'T', 'N', rank, dim_ens, & tmpUinv_l, rank, OmegaT, rank, lib_info) ELSE ! TMP_UINV already contains matrix C (no more inversion) diff --git a/src/PDAF_mod_filter.F90 b/src/PDAF_mod_filter.F90 index f4b5fdc07..1bb346b86 100644 --- a/src/PDAF_mod_filter.F90 +++ b/src/PDAF_mod_filter.F90 @@ -100,9 +100,9 @@ MODULE PDAF_mod_filter INTEGER :: step ! Current time step INTEGER :: step_obs ! Time step of next observation INTEGER :: dim_obs ! Dimension of next observation - INTEGER :: screen ! Control verbosity of filter routines + INTEGER :: screen=0 ! Control verbosity of filter routines ! (0) quiet; (1) normal output; (2); plus timings; (3) debug output - INTEGER :: debug ! Debugging flag: print debug information if >0 + INTEGER :: debug=0 ! Debugging flag: print debug information if >0 INTEGER :: incremental=0 ! Whether to perform incremental updating INTEGER :: type_forget=0 ! Type of forgetting factor ! (0): fixed; (1) global adaptive; (2) local adaptive diff --git a/src/PDAF_print_version.F90 b/src/PDAF_print_version.F90 index 08e2655b9..2b587f4d9 100644 --- a/src/PDAF_print_version.F90 +++ b/src/PDAF_print_version.F90 @@ -56,7 +56,7 @@ SUBROUTINE PDAF_print_version() WRITE(*, '(a)') 'PDAF +++ PDAF +++' WRITE(*, '(a)') 'PDAF +++ Parallel Data Assimilation Framework +++' WRITE(*, '(a)') 'PDAF +++ +++' - WRITE(*, '(a)') 'PDAF +++ Version 2.2.1 +++' + WRITE(*, '(a)') 'PDAF +++ Version 2.3 +++' WRITE(*, '(a)') 'PDAF +++ +++' WRITE(*, '(a)') 'PDAF +++ Please cite +++' WRITE(*, '(a)') 'PDAF +++ L. Nerger and W. Hiller, Computers and Geosciences +++' diff --git a/src/PDAF_seik_analysis.F90 b/src/PDAF_seik_analysis.F90 index 5f12713f8..1da78c9c2 100644 --- a/src/PDAF_seik_analysis.F90 +++ b/src/PDAF_seik_analysis.F90 @@ -256,6 +256,34 @@ SUBROUTINE PDAF_seik_analysis(step, dim_p, dim_obs_p, dim_ens, rank, & CALL PDAF_timeit(51, 'old') END IF + ELSE IF (dim_obs_p == 0) THEN + + ! For OMI we need to call observation operator also for dim_obs_p=0 + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation include a global communication + IF (.NOT.observe_ens) THEN + IF (omi_n_obstypes>0) THEN + ALLOCATE(m_state_p(1)) + obs_member = 0 + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, state_p, m_state_p) + + DEALLOCATE(m_state_p) + ELSE + ALLOCATE(HL_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HL_p(:, member)) + END DO + DEALLOCATE(HL_p) + END IF + END IF + END IF haveobsB CALL PDAF_timeit(12, 'old') @@ -369,15 +397,21 @@ SUBROUTINE PDAF_seik_analysis(step, dim_p, dim_obs_p, dim_ens, rank, & Uinv_p = 0.0 ! For OMI we need to call observation operator also for dim_obs_p=0 - ! in order to initialize pointer to observation type + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation includes a global communication IF (omi_n_obstypes>0) THEN - ALLOCATE(HL_p(1, 1)) - obs_member = 1 - - ! [Hx_1 ... Hx_N] - CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, 1), HL_p(:, 1)) - - DEALLOCATE(HL_p) + IF (.NOT.observe_ens) THEN + ALLOCATE(HL_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HL_p(:, member)) + END DO + DEALLOCATE(HL_p) + END IF END IF END IF haveobsA diff --git a/src/PDAF_seik_analysis_newT.F90 b/src/PDAF_seik_analysis_newT.F90 index 3520c2753..1c22d2366 100644 --- a/src/PDAF_seik_analysis_newT.F90 +++ b/src/PDAF_seik_analysis_newT.F90 @@ -257,6 +257,34 @@ SUBROUTINE PDAF_seik_analysis_newT(step, dim_p, dim_obs_p, dim_ens, rank, & CALL PDAF_timeit(51, 'old') END IF + ELSE IF (dim_obs_p == 0) THEN + + ! For OMI we need to call observation operator also for dim_obs_p=0 + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation include a global communication + IF (.NOT.observe_ens) THEN + IF (omi_n_obstypes>0) THEN + ALLOCATE(m_state_p(1)) + obs_member = 0 + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, state_p, m_state_p) + + DEALLOCATE(m_state_p) + ELSE + ALLOCATE(HL_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HL_p(:, member)) + END DO + DEALLOCATE(HL_p) + END IF + END IF + END IF haveobsB CALL PDAF_timeit(12, 'old') @@ -370,15 +398,21 @@ SUBROUTINE PDAF_seik_analysis_newT(step, dim_p, dim_obs_p, dim_ens, rank, & Uinv_p = 0.0 ! For OMI we need to call observation operator also for dim_obs_p=0 - ! in order to initialize pointer to observation type + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation includes a global communication IF (omi_n_obstypes>0) THEN - ALLOCATE(HL_p(1, 1)) - obs_member = 1 - - ! [Hx_1 ... Hx_N] - CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, 1), HL_p(:, 1)) - - DEALLOCATE(HL_p) + IF (.NOT.observe_ens) THEN + ALLOCATE(HL_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HL_p(:, member)) + END DO + DEALLOCATE(HL_p) + END IF END IF END IF haveobsA diff --git a/src/PDAF_seik_analysis_trans.F90 b/src/PDAF_seik_analysis_trans.F90 index d424a2756..25fd47aa4 100644 --- a/src/PDAF_seik_analysis_trans.F90 +++ b/src/PDAF_seik_analysis_trans.F90 @@ -287,6 +287,34 @@ SUBROUTINE PDAF_seik_analysis_trans(step, dim_p, dim_obs_p, dim_ens, rank, & CALL PDAF_timeit(51, 'old') END IF + ELSE IF (dim_obs_p == 0) THEN + + ! For OMI we need to call observation operator also for dim_obs_p=0 + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation include a global communication + IF (.NOT.observe_ens) THEN + IF (omi_n_obstypes>0) THEN + ALLOCATE(HXbar_p(1)) + obs_member = 0 + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, state_p, HXbar_p) + + DEALLOCATE(HXbar_p) + ELSE + ALLOCATE(HL_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HL_p(:, member)) + END DO + DEALLOCATE(HL_p) + END IF + END IF + END IF haveobsB CALL PDAF_timeit(12, 'old') @@ -402,15 +430,21 @@ SUBROUTINE PDAF_seik_analysis_trans(step, dim_p, dim_obs_p, dim_ens, rank, & Uinv_p = 0.0 ! For OMI we need to call observation operator also for dim_obs_p=0 - ! in order to initialize pointer to observation type + ! in order to initialize the pointer to the observation types + ! Further the observation operator has to be executed in cases + ! in which the operation includes a global communication IF (omi_n_obstypes>0) THEN - ALLOCATE(HL_p(1, 1)) - obs_member = 1 - - ! [Hx_1 ... Hx_N] - CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, 1), HL_p(:, 1)) - - DEALLOCATE(HL_p) + IF (.NOT.observe_ens) THEN + ALLOCATE(HL_p(1,1)) + DO member = 1, dim_ens + ! Store member index to make it accessible with PDAF_get_obsmemberid + obs_member = member + + ! [Hx_1 ... Hx_N] + CALL U_obs_op(step, dim_p, dim_obs_p, ens_p(:, member), HL_p(:, member)) + END DO + DEALLOCATE(HL_p) + END IF END IF END IF haveobsA @@ -719,7 +753,7 @@ SUBROUTINE PDAF_seik_analysis_trans(step, dim_p, dim_obs_p, dim_ens, rank, & CALL PDAF_timeit(34, 'new') IF (type_sqrt == 1) THEN ! A = (Omega C^(-1)) by solving Ct A = OmegaT for A - CALL trtrsTYPE('l', 't', 'n', rank, dim_ens, & + CALL trtrsTYPE('L', 'T', 'N', rank, dim_ens, & tmp_Uinv, rank, OmegaT, rank, lib_info) ELSE ! TMP_UINV already contains matrix C (no more inversion) diff --git a/src/PDAF_seik_resample.F90 b/src/PDAF_seik_resample.F90 index acf944033..69f30f8fa 100644 --- a/src/PDAF_seik_resample.F90 +++ b/src/PDAF_seik_resample.F90 @@ -299,7 +299,7 @@ SUBROUTINE PDAF_seik_resample(subtype, dim_p, dim_ens, rank, Uinv, & CALL PDAF_timeit(34, 'new') IF (type_sqrt == 1) THEN ! A = (Omega C^(-1)) by solving Ct A = OmegaT for A - CALL trtrsTYPE('l', 't', 'n', rank, dim_ens, & + CALL trtrsTYPE('L', 'T', 'N', rank, dim_ens, & tempUinv, rank, OmegaT, rank, lib_info) ELSE ! TMP_UINV already contains matrix C (no more inversion) diff --git a/src/PDAF_seik_resample_newT.F90 b/src/PDAF_seik_resample_newT.F90 index 25581ae39..a47cbfb91 100644 --- a/src/PDAF_seik_resample_newT.F90 +++ b/src/PDAF_seik_resample_newT.F90 @@ -315,7 +315,7 @@ SUBROUTINE PDAF_seik_resample_newT(subtype, dim_p, dim_ens, rank, & CALL PDAF_timeit(34, 'new') IF (type_sqrt == 1) THEN ! A = (Omega C^(-1)) by solving Ct A = OmegaT for A - CALL trtrsTYPE('l', 't', 'n', rank, dim_ens, & + CALL trtrsTYPE('L', 'T', 'N', rank, dim_ens, & tempUinv, rank, OmegaT, rank, lib_info) ELSE ! TMP_UINV already contains matrix C (no more inversion) diff --git a/src/PDAF_timer_mpi.F90 b/src/PDAF_timer_mpi.F90 new file mode 100644 index 000000000..c55c5f6ec --- /dev/null +++ b/src/PDAF_timer_mpi.F90 @@ -0,0 +1,153 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !MODULE: +MODULE PDAF_timer + +! !DESCRIPTION: +! This module provides methods to perform timings of +! parts of a program execution. It uses the intrinsic +! function SYSTEM\_CLOCK. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2000-11 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + SAVE + + PUBLIC :: PDAF_timeit, PDAF_time_tot, PDAF_time_temp +!EOP + + PRIVATE + REAL, ALLOCATABLE :: t_start(:), t_end(:) + REAL, ALLOCATABLE :: t_total(:), t_temp(:) + +CONTAINS +!------------------------------------------------------------------------------- +!BOP +! +! !ROUTINE: PDAF_timeit - Initialize Counters and time regions +! +! !INTERFACE: + SUBROUTINE PDAF_timeit(timerID, operation) + +! !DESCRIPTION: +! Subroutine to initialize counters and to perform timing of a region +! specified by timerID. +! Usage:\\ +! CALL PDAF\_timeit(N,'ini') - Allocates and initializes N counters\\ +! CALL PDAF\_timeit(M,'new') - Start timing region for counter M\\ +! CALL PDAF\_timeit(M,'old') - End timing region for counter M\\ +! CALL PDAF\_timeit(M,'fin') - Finalized and deallocates all counters\\ + +! !USES: + USE mpi + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(in) :: timerID ! ID of timer + CHARACTER(len=3), INTENT(in) :: operation ! Requested operation +!EOP + +!$OMP MASTER + ! Initialize timers + IF (operation == 'ini') THEN + IF ( .NOT. (ALLOCATED(t_start))) THEN + ALLOCATE(t_start(timerID), t_end(timerID)) + ALLOCATE(t_total(timerID), t_temp(timerID)) + END IF + + t_total = 0.0 + END IF + + ! Begin timing region + IF (operation == 'new') THEN + t_start(timerID) = MPI_Wtime() + END IF + + ! End timing region + IF (operation == 'old') THEN + t_end(timerID) = MPI_Wtime() + t_temp(timerID) = t_end(timerID) - t_start(timerID) + t_total(timerID) = t_total(timerID) + t_temp(timerID) + END IF + + ! Finalize timers + IF (operation == 'fin') THEN + DEALLOCATE(t_start, t_end) + DEALLOCATE(t_total, t_temp) + END IF +!$OMP END MASTER + + END SUBROUTINE PDAF_timeit + +!------------------------------------------------------------------------------- +!BOP +! +! !FUNCTION: PDAF_time_temp - Read out timers for last timing interval +! +! !INTERFACE: + REAL FUNCTION PDAF_time_temp(timerID) + +! !DESCRIPTION: +! Read out the value of the timer in seconds for the last +! passage of the timing region defined by timerID. + +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(in) :: timerID ! ID of timer +!EOP + + PDAF_time_temp = t_temp(timerID) + + END FUNCTION PDAF_time_temp + +!------------------------------------------------------------------------------- +!BOP +! +! !FUNCTION: PDAF_time_tot - Read out total time of a timing region. +! +! !INTERFACE: + REAL FUNCTION PDAF_time_tot(timerID) + +! !DESCRIPTION: +! Read out the accumulated value of the timer in seconds +! for the timing region define by timerID. + +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(in) :: timerID ! ID of timer +!EOP + + PDAF_time_tot = t_total(timerID) + + END FUNCTION PDAF_time_tot + +END MODULE PDAF_timer diff --git a/src/PDAFlocal.F90 b/src/PDAFlocal.F90 new file mode 100644 index 000000000..7e70fc7a1 --- /dev/null +++ b/src/PDAFlocal.F90 @@ -0,0 +1,73 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! + +!> PDAF-LOCAL routines handling localization +!! +!! This module contains subroutines that handle the localization of +!! the state vector +!! +!! * PDAFlocal_set_indices \n +!! Set indices of elements of lcoal state vector in global state vector +!! * PDAFlocal_set_increment_weights \n +!! Set optional increment weights applied when upating the lobal state vector +!! from the local analysis state vector +!! * PDAFlocal_clear_increment_weights \n +!! Deallocate vector of increment weights. Afterwards l2g_state is applied without weights +!! +!! __Revision history:__ +!! * 2024-08 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! +MODULE PDAFlocal + + USE PDAFlocal_interfaces ! Interface defintions for put_state and assimilate routines + + IMPLICIT NONE + SAVE + + INTEGER, ALLOCATABLE :: id_lstate_in_pstate(:) !< Indices of local state vector in PE-local global state vector + REAL, ALLOCATABLE :: l2g_weights(:) !< Increment weights applied in l2g_state + LOGICAL :: PDAFlocal_was_used = .FALSE. !< Flag whether PDAFlocal was used (set in PDAFlocal_g2l_cb) + +!$OMP THREADPRIVATE(id_lstate_in_pstate, l2g_weights) + +!------------------------------------------------------------------------------- + + INTERFACE + SUBROUTINE PDAFlocal_g2l_cb(step, domain_p, dim_p, state_p, dim_l, state_l) + INTEGER, INTENT(in) :: step !< Current time step + INTEGER, INTENT(in) :: domain_p !< Current local analysis domain + INTEGER, INTENT(in) :: dim_p !< PE-local full state dimension + INTEGER, INTENT(in) :: dim_l !< Local state dimension + REAL, INTENT(in) :: state_p(dim_p) !< PE-local full state vector + REAL, INTENT(out) :: state_l(dim_l) !< State vector on local analysis domain + END SUBROUTINE PDAFlocal_g2l_cb + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_l2g_cb(step, domain_p, dim_l, state_l, dim_p, state_p) + INTEGER, INTENT(in) :: step !< Current time step + INTEGER, INTENT(in) :: domain_p !< Current local analysis domain + INTEGER, INTENT(in) :: dim_l !< Local state dimension + INTEGER, INTENT(in) :: dim_p !< PE-local full state dimension + REAL, INTENT(in) :: state_l(dim_l) !< State vector on local analysis domain + REAL, INTENT(inout) :: state_p(dim_p) !< PE-local full state vector + END SUBROUTINE PDAFlocal_l2g_cb + END INTERFACE + +END MODULE PDAFlocal diff --git a/src/PDAFlocal_assimilate_en3dvar_lestkf.F90 b/src/PDAFlocal_assimilate_en3dvar_lestkf.F90 new file mode 100644 index 000000000..55797a605 --- /dev/null +++ b/src/PDAFlocal_assimilate_en3dvar_lestkf.F90 @@ -0,0 +1,155 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_en3dvar_lestkf --- Interface to PDAF for En3DVAR/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_en3dvar_lestkf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_prepoststep, U_next_observation, outflag) + +! !DESCRIPTION: +! Interface routine called from the model at each time +! step during the forecast of each ensemble state. If +! the time of the next analysis step is reached the +! forecast state is transferred to PDAF and the analysis +! is computed by calling PDAFlocal_put_state_3dvar. Subsequently, +! PDAF_get_state is called to initialize the next forecast +! phase. +! +! The code is very generic. Basically the only +! filter-specific part are the calls to the +! routines PDAF\_put\_state\_X where the analysis +! is computed and PDAF\_get\_state to initialize the next +! forecast phase. The filter-specific call-back subroutines +! are specified in the calls to the two core routines. +! +! Variant for 3DVAR with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2013-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, & + ONLY: cnt_steps, nsteps, assim_flag, use_PDAF_assim + USE PDAF_mod_filtermpi, & + ONLY: mype_world + + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state, & ! Routine to distribute a state vector + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_obs_op_f, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_f, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l ! Provide product R^-1 A on local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_3dvar +! Calls: PDAF_get_state +!EOP + +! Local variables + INTEGER :: steps ! Number of time steps in next forecast phase + INTEGER :: doexit ! Exit flag; not used in this variant + REAL :: time ! Current model time; not used in this variant + + +! ***************************** +! *** At each time step *** +! ***************************** + + ! Set flag for using PDAF_assimilate + use_PDAF_assim = .TRUE. + + ! Increment time step counter + cnt_steps = cnt_steps + 1 + + +! ******************************** +! *** At end of forecast phase *** +! ******************************** + + IF (cnt_steps == nsteps) THEN + + IF (mype_world==0) WRITE(*,'(a, 5x, a)') 'PDAF', 'Perform assimilation with PDAF' + + ! Set flag for assimilation + assim_flag = 1 + + ! *** Call analysis step *** + + CALL PDAFlocal_put_state_en3dvar_lestkf(U_collect_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_prepoststep, outflag) + + ! *** Prepare start of next ensemble forecast *** + + IF (outflag==0) THEN + CALL PDAF_get_state(steps, time, doexit, U_next_observation, U_distribute_state, & + U_prepoststep, outflag) + END IF + + nsteps = steps + + ELSE + assim_flag = 0 + outflag = 0 + END IF + +END SUBROUTINE PDAFlocal_assimilate_en3dvar_lestkf diff --git a/src/PDAFlocal_assimilate_hyb3dvar_lestkf.F90 b/src/PDAFlocal_assimilate_hyb3dvar_lestkf.F90 new file mode 100644 index 000000000..534fcc480 --- /dev/null +++ b/src/PDAFlocal_assimilate_hyb3dvar_lestkf.F90 @@ -0,0 +1,157 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_hyb3dvar_lestkf --- Interface to PDAF for Hyb3DVAR/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_hyb3dvar_lestkf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_prepoststep, U_next_observation, outflag) + +! !DESCRIPTION: +! Interface routine called from the model at each time +! step during the forecast of each ensemble state. If +! the time of the next analysis step is reached the +! forecast state is transferred to PDAF and the analysis +! is computed by calling PDAFlocal_put_state_3dvar. Subsequently, +! PDAF_get_state is called to initialize the next forecast +! phase. +! +! The code is very generic. Basically the only +! filter-specific part are the calls to the +! routines PDAF\_put\_state\_X where the analysis +! is computed and PDAF\_get\_state to initialize the next +! forecast phase. The filter-specific call-back subroutines +! are specified in the calls to the two core routines. +! +! Variant for 3DVAR with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2013-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, & + ONLY: cnt_steps, nsteps, assim_flag, use_PDAF_assim + USE PDAF_mod_filtermpi, & + ONLY: mype_world + + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state, & ! Routine to distribute a state vector + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_cvt, & ! Apply control vector transform matrix to control vector + U_cvt_adj, & ! Apply adjoint control vector transform matrix + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_obs_op_f, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_f, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l ! Provide product R^-1 A on local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_3dvar +! Calls: PDAF_get_state +!EOP + +! Local variables + INTEGER :: steps ! Number of time steps in next forecast phase + INTEGER :: doexit ! Exit flag; not used in this variant + REAL :: time ! Current model time; not used in this variant + + +! ***************************** +! *** At each time step *** +! ***************************** + + ! Set flag for using PDAF_assimilate + use_PDAF_assim = .TRUE. + + ! Increment time step counter + cnt_steps = cnt_steps + 1 + + +! ******************************** +! *** At end of forecast phase *** +! ******************************** + + IF (cnt_steps == nsteps) THEN + + IF (mype_world==0) WRITE(*,'(a, 5x, a)') 'PDAF', 'Perform assimilation with PDAF' + + ! Set flag for assimilation + assim_flag = 1 + + ! *** Call analysis step *** + + CALL PDAFlocal_put_state_hyb3dvar_lestkf(U_collect_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_prepoststep, outflag) + + ! *** Prepare start of next ensemble forecast *** + + IF (outflag==0) THEN + CALL PDAF_get_state(steps, time, doexit, U_next_observation, U_distribute_state, & + U_prepoststep, outflag) + END IF + + nsteps = steps + + ELSE + assim_flag = 0 + outflag = 0 + END IF + +END SUBROUTINE PDAFlocal_assimilate_hyb3dvar_lestkf diff --git a/src/PDAFlocal_assimilate_lestkf.F90 b/src/PDAFlocal_assimilate_lestkf.F90 new file mode 100644 index 000000000..4dd6c5442 --- /dev/null +++ b/src/PDAFlocal_assimilate_lestkf.F90 @@ -0,0 +1,142 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_lestkf --- Interface to PDAF for LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_lestkf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_init_obs_l, U_prepoststep, & + U_prodRinvA_l, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_next_observation, outflag) + +! !DESCRIPTION: +! Interface routine called from the model at each time +! step during the forecast of each ensemble state. If +! the time of the next analysis step is reached the +! forecast state is transferred to PDAF and the analysis +! is computed by calling PDAFlocal_put_state_lestkf. Subsequently, +! PDAF_get_state is called to initialize the next forecast +! phase. +! +! The code is very generic. Basically the only +! filter-specific part are the calls to the +! routines PDAF\_put\_state\_X where the analysis +! is computed and PDAF\_get\_state to initialize the next +! forecast phase. The filter-specific call-back subroutines +! are specified in the calls to the two core routines. +! +! Variant for LESTKF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2013-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, & + ONLY: cnt_steps, nsteps, assim_flag, use_PDAF_assim + USE PDAF_mod_filtermpi, & + ONLY: mype_world + + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state ! Routine to distribute a state vector + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_lestkf +! Calls: PDAF_get_state_lestkf +!EOP + +! Local variables + INTEGER :: steps ! Number of time steps in next forecast phase + INTEGER :: doexit ! Exit flag; not used in this variant + REAL :: time ! Current model time; not used in this variant + + +! ***************************** +! *** At each time step *** +! ***************************** + + ! Set flag for using PDAF_assimilate + use_PDAF_assim = .TRUE. + + ! Increment time step counter + cnt_steps = cnt_steps + 1 + + +! ******************************** +! *** At end of forecast phase *** +! ******************************** + + IF (cnt_steps == nsteps) THEN + + IF (mype_world==0) WRITE(*,'(a, 5x, a)') 'PDAF', 'Perform assimilation with PDAF' + + ! Set flag for assimilation + assim_flag = 1 + + ! *** Call analysis step *** + + CALL PDAFlocal_put_state_lestkf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, outflag) + + ! *** Prepare start of next ensemble forecast *** + + IF (outflag==0) THEN + CALL PDAF_get_state(steps, time, doexit, U_next_observation, U_distribute_state, & + U_prepoststep, outflag) + END IF + + nsteps = steps + + ELSE + assim_flag = 0 + outflag = 0 + END IF + +END SUBROUTINE PDAFlocal_assimilate_lestkf diff --git a/src/PDAFlocal_assimilate_lestkf_si.F90 b/src/PDAFlocal_assimilate_lestkf_si.F90 new file mode 100644 index 000000000..ddf37b626 --- /dev/null +++ b/src/PDAFlocal_assimilate_lestkf_si.F90 @@ -0,0 +1,88 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_lestkf_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_lestkf_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for SEIK with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2013-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + obs_op_f_pdaf, & ! Full observation operator + init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + init_obs_f_pdaf, & ! Initialize full observation vector + init_obs_l_pdaf, & ! Initialize local observation vector + init_obsvar_pdaf, & ! Initialize mean observation error variance + init_obsvar_l_pdaf, & ! Initialize local mean observation error variance + g2l_obs_pdaf, & ! Restrict full obs. vector to local analysis domain + prodRinvA_l_pdaf, & ! Provide product R^-1 A on local analysis domain + prepoststep_pdaf, & ! User supplied pre/poststep routine + next_observation_pdaf ! Routine to provide time step, time and dimension + ! of next observation + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_assimilate_lestkf +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocal_assimilate_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, init_obs_f_pdaf, init_obs_l_pdaf, & + prepoststep_pdaf, prodRinvA_l_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_obs_pdaf, init_obsvar_pdaf, init_obsvar_l_pdaf, next_observation_pdaf, & + outflag) + +END SUBROUTINE PDAFlocal_assimilate_lestkf_si diff --git a/src/PDAFlocal_assimilate_letkf.F90 b/src/PDAFlocal_assimilate_letkf.F90 new file mode 100644 index 000000000..b9aed02fc --- /dev/null +++ b/src/PDAFlocal_assimilate_letkf.F90 @@ -0,0 +1,142 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_letkf --- Interface to PDAF for LETKF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_letkf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_init_obs_l, U_prepoststep, & + U_prodRinvA_l, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_next_observation, outflag) + +! !DESCRIPTION: +! Interface routine called from the model at each time +! step during the forecast of each ensemble state. If +! the time of the next analysis step is reached the +! forecast state is transferred to PDAF and the analysis +! is computed by calling PDAFlocal_put_state_letkf. Subsequently, +! PDAF_get_state is called to initialize the next forecast +! phase. +! +! The code is very generic. Basically the only +! filter-specific part are the calls to the +! routines PDAF\_put\_state\_X where the analysis +! is computed and PDAF\_get\_state to initialize the next +! forecast phase. The filter-specific call-back subroutines +! are specified in the calls to the two core routines. +! +! Variant for LETKF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2013-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, & + ONLY: cnt_steps, nsteps, assim_flag, use_PDAF_assim + USE PDAF_mod_filtermpi, & + ONLY: mype_world + + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state ! Routine to distribute a state vector + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_letkf +! Calls: PDAF_get_state +!EOP + +! Local variables + INTEGER :: steps ! Number of time steps in next forecast phase + INTEGER :: doexit ! Exit flag; not used in this variant + REAL :: time ! Current model time; not used in this variant + + +! ***************************** +! *** At each time step *** +! ***************************** + + ! Set flag for using PDAF_assimilate + use_PDAF_assim = .TRUE. + + ! Increment time step counter + cnt_steps = cnt_steps + 1 + + +! ******************************** +! *** At end of forecast phase *** +! ******************************** + + IF (cnt_steps == nsteps) THEN + + IF (mype_world==0) WRITE(*,'(a, 5x, a)') 'PDAF', 'Perform assimilation with PDAF' + + ! Set flag for assimilation + assim_flag = 1 + + ! *** Call analysis step *** + + CALL PDAFlocal_put_state_letkf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, outflag) + + ! *** Prepare start of next ensemble forecast *** + + IF (outflag==0) THEN + CALL PDAF_get_state(steps, time, doexit, U_next_observation, U_distribute_state, & + U_prepoststep, outflag) + END IF + + nsteps = steps + + ELSE + assim_flag = 0 + outflag = 0 + END IF + +END SUBROUTINE PDAFlocal_assimilate_letkf diff --git a/src/PDAFlocal_assimilate_letkf_si.F90 b/src/PDAFlocal_assimilate_letkf_si.F90 new file mode 100644 index 000000000..74a43c5d3 --- /dev/null +++ b/src/PDAFlocal_assimilate_letkf_si.F90 @@ -0,0 +1,88 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_letkf_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_letkf_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for SEIK with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2013-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + obs_op_f_pdaf, & ! Full observation operator + init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + init_obs_f_pdaf, & ! Initialize full observation vector + init_obs_l_pdaf, & ! Initialize local observation vector + init_obsvar_pdaf, & ! Initialize mean observation error variance + init_obsvar_l_pdaf, & ! Initialize local mean observation error variance + g2l_obs_pdaf, & ! Restrict full obs. vector to local analysis domain + prodRinvA_l_pdaf, & ! Provide product R^-1 A on local analysis domain + prepoststep_pdaf, & ! User supplied pre/poststep routine + next_observation_pdaf ! Routine to provide time step, time and dimension + ! of next observation + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_assimilate_letkf +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocal_assimilate_letkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, init_obs_f_pdaf, init_obs_l_pdaf, & + prepoststep_pdaf, prodRinvA_l_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_obs_pdaf, init_obsvar_pdaf, init_obsvar_l_pdaf, next_observation_pdaf, & + outflag) + +END SUBROUTINE PDAFlocal_assimilate_letkf_si diff --git a/src/PDAFlocal_assimilate_lknetf.F90 b/src/PDAFlocal_assimilate_lknetf.F90 new file mode 100644 index 000000000..e2be00e27 --- /dev/null +++ b/src/PDAFlocal_assimilate_lknetf.F90 @@ -0,0 +1,149 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_lknetf --- Interface to PDAF for LKNETF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_lknetf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_init_obs_l, U_prepoststep, & + U_prodRinvA_l, U_prodRinvA_hyb_l, U_init_n_domains_p, U_init_dim_l, & + U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_likelihood_l, U_likelihood_hyb_l, & + U_next_observation, outflag) + +! !DESCRIPTION: +! Interface routine called from the model at each time +! step during the forecast of each ensemble state. If +! the time of the next analysis step is reached the +! forecast state is transferred to PDAF and the analysis +! is computed by calling PDAFlocal_put_state_lknetf. Subsequently, +! PDAF_get_state is called to initialize the next forecast +! phase. +! +! The code is very generic. Basically the only +! filter-specific part are the calls to the +! routines PDAF\_put\_state\_X where the analysis +! is computed and PDAF\_get\_state to initialize the next +! forecast phase. The filter-specific call-back subroutines +! are specified in the calls to the two core routines. +! +! Variant for LKNETF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2017-08 - Lars Nerger - Initial code based on LETKF +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, & + ONLY: cnt_steps, nsteps, assim_flag, use_PDAF_assim + USE PDAF_mod_filtermpi, & + ONLY: mype_world + + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prodRinvA_hyb_l, & ! Provide product R^-1 A on local analysis domain with hybrid weight + U_likelihood_l, & ! Compute likelihood + U_likelihood_hyb_l, & ! Compute likelihood with hybrid weight + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state ! Routine to distribute a state vector + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_lknetf +! Calls: PDAF_get_state +!EOP + +! Local variables + INTEGER :: steps ! Number of time steps in next forecast phase + INTEGER :: doexit ! Exit flag; not used in this variant + REAL :: time ! Current model time; not used in this variant + + +! ***************************** +! *** At each time step *** +! ***************************** + + ! Set flag for using PDAF_assimilate + use_PDAF_assim = .TRUE. + + ! Increment time step counter + cnt_steps = cnt_steps + 1 + + +! ********************************************** +! *** At observation time - analysis step *** +! ********************************************** + + IF (cnt_steps == nsteps) THEN + + IF (mype_world==0) WRITE(*,'(a, 5x, a)') 'PDAF', 'Perform assimilation with PDAF - LKNETF' + + ! Set flag for assimilation + assim_flag = 1 + + ! *** Call analysis step *** + + CALL PDAFlocal_put_state_lknetf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_prodRinvA_hyb_l, & + U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, U_likelihood_l, U_likelihood_hyb_l, outflag) + + ! *** Prepare start of next ensemble forecast *** + + IF (outflag==0) THEN + CALL PDAF_get_state(steps, time, doexit, U_next_observation, & + U_distribute_state, U_prepoststep, outflag) + END IF + + nsteps = steps + + ELSE + assim_flag = 0 + outflag = 0 + END IF + +END SUBROUTINE PDAFlocal_assimilate_lknetf diff --git a/src/PDAFlocal_assimilate_lknetf_si.F90 b/src/PDAFlocal_assimilate_lknetf_si.F90 new file mode 100644 index 000000000..4e79a202b --- /dev/null +++ b/src/PDAFlocal_assimilate_lknetf_si.F90 @@ -0,0 +1,92 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_lknetf_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_lknetf_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for SEIK with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2017-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + obs_op_f_pdaf, & ! Full observation operator + init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + init_obs_f_pdaf, & ! Initialize full observation vector + init_obs_l_pdaf, & ! Initialize local observation vector + init_obsvar_pdaf, & ! Initialize mean observation error variance + init_obsvar_l_pdaf, & ! Initialize local mean observation error variance + g2l_obs_pdaf, & ! Restrict full obs. vector to local analysis domain + prodRinvA_l_pdaf, & ! Provide product R^-1 A on local analysis domain + prodRinvA_hyb_l_pdaf, & ! Provide product R^-1 A on local analysis domain with hybrid weight + likelihood_l_pdaf, & ! Compute observation likelihood for an ensemble member + likelihood_hyb_l_pdaf, & ! Compute observation likelihood for an ensemble member with hybrid weight + prepoststep_pdaf, & ! User supplied pre/poststep routine + next_observation_pdaf ! Routine to provide time step, time and dimension + ! of next observation + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_assimilate_lknetf +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocal_assimilate_lknetf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, init_obs_f_pdaf, init_obs_l_pdaf, & + prepoststep_pdaf, prodRinvA_l_pdaf, prodRinvA_hyb_l_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_obs_pdaf, init_obsvar_pdaf, init_obsvar_l_pdaf, likelihood_l_pdaf, & + likelihood_hyb_l_pdaf, next_observation_pdaf, & + outflag) + +END SUBROUTINE PDAFlocal_assimilate_lknetf_si diff --git a/src/PDAFlocal_assimilate_lnetf.F90 b/src/PDAFlocal_assimilate_lnetf.F90 new file mode 100644 index 000000000..1e29a1666 --- /dev/null +++ b/src/PDAFlocal_assimilate_lnetf.F90 @@ -0,0 +1,139 @@ +! Copyright (c) 2014-2024 Paul Kirchgessner +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_lnetf --- Interface to PDAF for LNETF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_lnetf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs_l, U_prepoststep, & + U_likelihood_l, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_next_observation, outflag) + +! !DESCRIPTION: +! Interface routine called from the model at each time +! step during the forecast of each ensemble state. If +! the time of the next analysis step is reached the +! forecast state is transferred to PDAF and the analysis +! is computed by calling PDAFlocal_put_state_lnetf. Subsequently, +! PDAF_get_state is called to initialize the next forecast +! phase. +! +! The code is very generic. Basically the only +! filter-specific part are the calls to the +! routines PDAF\_put\_state\_X where the analysis +! is computed and PDAF\_get\_state to initialize the next +! forecast phase. The filter-specific call-back subroutines +! are specified in the calls to the two core routines. +! +! Variant for LNETF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2014-05 - Paul Kirchgessner - Initial code based on ETKF +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, & + ONLY: cnt_steps, nsteps, assim_flag, use_PDAF_assim + USE PDAF_mod_filtermpi, & + ONLY: mype_world + + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_likelihood_l, & ! Compute observation likelihood for an ensemble member + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state ! Routine to distribute a state vector + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_lnetkf +! Calls: PDAF_get_state +!EOP + +! Local variables + INTEGER :: steps ! Number of time steps in next forecast phase + INTEGER :: doexit ! Exit flag; not used in this variant + REAL :: time ! Current model time; not used in this variant + + +! ***************************** +! *** At each time step *** +! ***************************** + + ! Set flag for using PDAF_assimilate + use_PDAF_assim = .TRUE. + + ! Increment time step counter + cnt_steps = cnt_steps + 1 + + +! ********************************************** +! *** At observation time - analysis step *** +! ********************************************** + + IF (cnt_steps == nsteps) THEN + IF (mype_world==0) WRITE(*,'(a, 5x, a)') 'PDAF', 'Perform assimilation with PDAF - LNETF' + + ! Set flag for assimilation + assim_flag = 1 + + ! *** Call analysis step *** + + CALL PDAFlocal_put_state_lnetf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs_l, U_prepoststep, U_likelihood_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + outflag) + + ! *** Prepare start of next ensemble forecast *** + + IF (outflag==0) THEN + CALL PDAF_get_state(steps, time, doexit, U_next_observation, & + U_distribute_state, U_prepoststep, outflag) + END IF + + nsteps = steps + + ELSE + assim_flag = 0 + outflag = 0 + END IF + + +END SUBROUTINE PDAFlocal_assimilate_lnetf diff --git a/src/PDAFlocal_assimilate_lnetf_si.F90 b/src/PDAFlocal_assimilate_lnetf_si.F90 new file mode 100644 index 000000000..af7c8db98 --- /dev/null +++ b/src/PDAFlocal_assimilate_lnetf_si.F90 @@ -0,0 +1,83 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_lnetf_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_lnetf_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for LNETF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2016-11 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + obs_op_f_pdaf, & ! Full observation operator + init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + init_obs_l_pdaf, & ! Initialize local observation vector + g2l_obs_pdaf, & ! Restrict full obs. vector to local analysis domain + likelihood_l_pdaf, & ! Compute observation likelihood for an ensemble member + prepoststep_pdaf, & ! User supplied pre/poststep routine + next_observation_pdaf ! Routine to provide time step, time and dimension + ! of next observation + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_assimilate_lestkf +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocal_assimilate_lnetf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, init_obs_l_pdaf, prepoststep_pdaf, & + likelihood_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_obs_pdaf, next_observation_pdaf, outflag) + +END SUBROUTINE PDAFlocal_assimilate_lnetf_si diff --git a/src/PDAFlocal_assimilate_lseik.F90 b/src/PDAFlocal_assimilate_lseik.F90 new file mode 100644 index 000000000..563e153bf --- /dev/null +++ b/src/PDAFlocal_assimilate_lseik.F90 @@ -0,0 +1,142 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_lseik --- Interface to PDAF for LSEIK +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_lseik(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_init_obs_l, U_prepoststep, & + U_prodRinvA_l, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_next_observation, outflag) + +! !DESCRIPTION: +! Interface routine called from the model at each time +! step during the forecast of each ensemble state. If +! the time of the next analysis step is reached the +! forecast state is transferred to PDAF and the analysis +! is computed by calling PDAFlocal_put_state_lseik. Subsequently, +! PDAF_get_state is called to initialize the next forecast +! phase. +! +! The code is very generic. Basically the only +! filter-specific part are the calls to the +! routines PDAF\_put\_state\_X where the analysis +! is computed and PDAF\_get\_state to initialize the next +! forecast phase. The filter-specific call-back subroutines +! are specified in the calls to the two core routines. +! +! Variant for LSEIK with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2013-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, & + ONLY: cnt_steps, nsteps, assim_flag, use_PDAF_assim + USE PDAF_mod_filtermpi, & + ONLY: mype_world + + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state ! Routine to distribute a state vector + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_lseik +! Calls: PDAF_get_state_lseik +!EOP + +! Local variables + INTEGER :: steps ! Number of time steps in next forecast phase + INTEGER :: doexit ! Exit flag; not used in this variant + REAL :: time ! Current model time; not used in this variant + + +! ***************************** +! *** At each time step *** +! ***************************** + + ! Set flag for using PDAF_assimilate + use_PDAF_assim = .TRUE. + + ! Increment time step counter + cnt_steps = cnt_steps + 1 + + +! ******************************** +! *** At end of forecast phase *** +! ******************************** + + IF (cnt_steps == nsteps) THEN + + IF (mype_world==0) WRITE(*,'(a, 5x, a)') 'PDAF', 'Perform assimilation with PDAF' + + ! Set flag for assimilation + assim_flag = 1 + + ! *** Call analysis step *** + + CALL PDAFlocal_put_state_lseik(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, outflag) + + ! *** Prepare start of next ensemble forecast *** + + IF (outflag==0) THEN + CALL PDAF_get_state(steps, time, doexit, U_next_observation, U_distribute_state, & + U_prepoststep, outflag) + END IF + + nsteps = steps + + ELSE + assim_flag = 0 + outflag = 0 + END IF + +END SUBROUTINE PDAFlocal_assimilate_lseik diff --git a/src/PDAFlocal_assimilate_lseik_si.F90 b/src/PDAFlocal_assimilate_lseik_si.F90 new file mode 100644 index 000000000..459e964bc --- /dev/null +++ b/src/PDAFlocal_assimilate_lseik_si.F90 @@ -0,0 +1,88 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_assimilate_lseik_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_assimilate_lseik_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for SEIK with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2013-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + obs_op_f_pdaf, & ! Full observation operator + init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + init_obs_f_pdaf, & ! Initialize full observation vector + init_obs_l_pdaf, & ! Initialize local observation vector + init_obsvar_pdaf, & ! Initialize mean observation error variance + init_obsvar_l_pdaf, & ! Initialize local mean observation error variance + g2l_obs_pdaf, & ! Restrict full obs. vector to local analysis domain + prodRinvA_l_pdaf, & ! Provide product R^-1 A on local analysis domain + prepoststep_pdaf, & ! User supplied pre/poststep routine + next_observation_pdaf ! Routine to provide time step, time and dimension + ! of next observation + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_assimilate_lseik +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocal_assimilate_lseik(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, init_obs_f_pdaf, init_obs_l_pdaf, & + prepoststep_pdaf, prodRinvA_l_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdaf, & + g2l_obs_pdaf, init_obsvar_pdaf, init_obsvar_l_pdaf, next_observation_pdaf, & + outflag) + +END SUBROUTINE PDAFlocal_assimilate_lseik_si diff --git a/src/PDAFlocal_clear_increment_weights.F90 b/src/PDAFlocal_clear_increment_weights.F90 new file mode 100644 index 000000000..ba86d805f --- /dev/null +++ b/src/PDAFlocal_clear_increment_weights.F90 @@ -0,0 +1,48 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! + +!> Deallocate vector of local increment weights +!! +!! This routine simply deallocates the local increment +!! weight vector if it is allocated. +!! +!! __Revision history:__ +!! * 2024-08 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! +SUBROUTINE PDAFlocal_clear_increment_weights() + + USE PDAF_mod_filter, & + ONLY: debug + USE PDAFlocal, & + ONLY: l2g_weights + + IMPLICIT NONE + + +! ***************************************** +! *** Deallocate increment weight array *** +! ***************************************** + + IF (ALLOCATED(l2g_weights)) DEALLOCATE(l2g_weights) + + IF (debug>0) THEN + WRITE (*,*) '++ PDAF-debug: ', debug, 'PDAFlocal_free_increment_weights -- Unset local increment weights' + END IF + +END SUBROUTINE PDAFlocal_clear_increment_weights diff --git a/src/PDAFlocal_g2l_cb.F90 b/src/PDAFlocal_g2l_cb.F90 new file mode 100644 index 000000000..e4ce65464 --- /dev/null +++ b/src/PDAFlocal_g2l_cb.F90 @@ -0,0 +1,69 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_g2l_cb - Project global to local vector according to index array +! +! !INTERFACE: +SUBROUTINE PDAFlocal_g2l_cb(step, domain_p, dim_p, state_p, dim_l, state_l) + +! !DESCRIPTION: +! Project a global to a local state vector for the localized filters. +! This is the full callback function to be used internally. The mapping +! is done using the index vector id_lstate_in_pstate that is initialize +! in PDAF_local_set_index. +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAFlocal, & + ONLY: id_lstate_in_pstate, PDAFlocal_was_used + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(in) :: step !< Current time step + INTEGER, INTENT(in) :: domain_p !< Current local analysis domain + INTEGER, INTENT(in) :: dim_p !< PE-local full state dimension + INTEGER, INTENT(in) :: dim_l !< Local state dimension + REAL, INTENT(in) :: state_p(dim_p) !< PE-local full state vector + REAL, INTENT(out) :: state_l(dim_l) !< State vector on local analysis domain + +! !CALLING SEQUENCE: +! Called by filter routine +!EOP + +! *** local variables *** + INTEGER :: i ! Counter + + +! ************************************* +! *** Initialize local state vector *** +! ************************************* + + ! Set flag that PDAFlocal was used + PDAFlocal_was_used = .TRUE. + + DO i = 1, dim_l + state_l(i) = state_p(id_lstate_in_pstate(i)) + END DO + +END SUBROUTINE PDAFlocal_g2l_cb diff --git a/src/PDAFlocal_interfaces.F90 b/src/PDAFlocal_interfaces.F90 new file mode 100644 index 000000000..6d045d8e9 --- /dev/null +++ b/src/PDAFlocal_interfaces.F90 @@ -0,0 +1,881 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_interfaces --- Interface definitions for PDAFlocal +! +! !INTERFACE: +MODULE PDAFlocal_interfaces + +! !DESCRIPTION: +! Module providing interface definition of the PDAFlocal routines that +! are called from the model code. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +!EOP +! +! !USES: +! Include definitions for real type of different precision +! (Defines BLAS/LAPACK routines and MPI_REALTYPE) +#include "typedefs.h" + + INTERFACE + SUBROUTINE PDAFlocal_put_state_lseik(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFlocal_put_state_lseik + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_put_state_lseik_si(flag) + INTEGER, INTENT(inout) :: flag ! Status flag + END SUBROUTINE PDAFlocal_put_state_lseik_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_lseik(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_init_obs_l, U_prepoststep, & + U_prodRinvA_l, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFlocal_assimilate_lseik + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_lseik_si(flag) + INTEGER, INTENT(inout) :: flag ! Status flag + END SUBROUTINE PDAFlocal_assimilate_lseik_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_put_state_letkf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFlocal_put_state_letkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_put_state_letkf_si(flag) + INTEGER, INTENT(inout) :: flag ! Status flag + END SUBROUTINE PDAFlocal_put_state_letkf_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_letkf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_init_obs_l, U_prepoststep, & + U_prodRinvA_l, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFlocal_assimilate_letkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_letkf_si(flag) + INTEGER, INTENT(inout) :: flag ! Status flag + END SUBROUTINE PDAFlocal_assimilate_letkf_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_put_state_lestkf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFlocal_put_state_lestkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_put_state_lestkf_si(flag) + INTEGER, INTENT(inout) :: flag ! Status flag + END SUBROUTINE PDAFlocal_put_state_lestkf_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_lestkf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_init_obs_l, U_prepoststep, & + U_prodRinvA_l, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFlocal_assimilate_lestkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_lestkf_si(flag) + INTEGER, INTENT(inout) :: flag ! Status flag + END SUBROUTINE PDAFlocal_assimilate_lestkf_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_put_state_lnetf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs_l, U_prepoststep, U_likelihood_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + outflag) + INTEGER, INTENT(out) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_likelihood_l, & ! Compute observation likelihood for an ensemble member + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFlocal_put_state_lnetf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_put_state_lnetf_si(flag) + INTEGER, INTENT(inout) :: flag ! Status flag + END SUBROUTINE PDAFlocal_put_state_lnetf_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_lnetf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs_l, U_prepoststep, & + U_likelihood_l, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_likelihood_l, & ! Compute observation likelihood for an ensemble member + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFlocal_assimilate_lnetf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_lnetf_si(flag) + INTEGER, INTENT(inout) :: flag ! Status flag + END SUBROUTINE PDAFlocal_assimilate_lnetf_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_put_state_lknetf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_prodRinvA_hyb_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, U_likelihood_l, U_likelihood_hyb_l, outflag) + INTEGER, INTENT(out) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prodRinvA_hyb_l, & ! Provide product R^-1 A on local analysis domain with hybrid weight + U_likelihood_l, & ! Compute likelihood + U_likelihood_hyb_l, & ! Compute likelihood with hybrid weight + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFlocal_put_state_lknetf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_put_state_lknetf_si(flag) + INTEGER, INTENT(inout) :: flag ! Status flag + END SUBROUTINE PDAFlocal_put_state_lknetf_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_lknetf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_init_obs_l, U_prepoststep, & + U_prodRinvA_l, U_prodRinvA_hyb_l, U_init_n_domains_p, U_init_dim_l, & + U_init_dim_obs_l, U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_likelihood_l, U_likelihood_hyb_l, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prodRinvA_hyb_l, & ! Provide product R^-1 A on local analysis domain with hybrid weight + U_likelihood_l, & ! Compute likelihood + U_likelihood_hyb_l, & ! Compute likelihood with hybrid weight + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state ! Routine to distribute a state vector + END SUBROUTINE PDAFlocal_assimilate_lknetf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_lknetf_si(flag) + INTEGER, INTENT(inout) :: flag ! Status flag + END SUBROUTINE PDAFlocal_assimilate_lknetf_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_put_state_en3dvar_lestkf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, U_prepoststep, outflag) + INTEGER, INTENT(out) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_obs_op_f, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_f, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l ! Provide product R^-1 A on local analysis domain + END SUBROUTINE PDAFlocal_put_state_en3dvar_lestkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_en3dvar_lestkf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_prepoststep, U_next_observation, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state, & ! Routine to distribute a state vector + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_cvt, & ! Apply control vector transform matrix to control vector + U_cvt_adj, & ! Apply adjoint control vector transform matrix + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_obs_op_f, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_f, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l ! Provide product R^-1 A on local analysis domain + END SUBROUTINE PDAFlocal_assimilate_en3dvar_lestkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_put_state_hyb3dvar_lestkf(U_collect_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, U_prepoststep, outflag) + INTEGER, INTENT(out) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_cvt, & ! Apply control vector transform matrix to control vector + U_cvt_adj, & ! Apply adjoint control vector transform matrix + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_obs_op_f, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_f, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l ! Provide product R^-1 A on local analysis domain + END SUBROUTINE PDAFlocal_put_state_hyb3dvar_lestkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_assimilate_hyb3dvar_lestkf(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, U_prepoststep, U_next_observation, outflag) + INTEGER, INTENT(out) :: outflag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_next_observation, & ! Routine to provide time step, time and dimension + ! of next observation + U_distribute_state, & ! Routine to distribute a state vector + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_cvt, & ! Apply control vector transform matrix to control vector + U_cvt_adj, & ! Apply adjoint control vector transform matrix + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_obs_op_f, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_f, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l ! Provide product R^-1 A on local analysis domain + END SUBROUTINE PDAFlocal_assimilate_hyb3dvar_lestkf + END INTERFACE + +! PDAFlocal INTERFACES --------------------- + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFlocalomi_put_state + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFlocalomi_put_state_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prepoststep, U_init_n_domains_p, U_init_dim_l, & + U_l2g_state, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFlocalomi_assimilate + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFlocalomi_assimilate_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state_nondiagR(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_prodRinvA_l, & + flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFlocalomi_put_state_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFlocalomi_put_state_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate_nondiagR(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prepoststep, U_init_n_domains_p, U_init_dim_l, & + U_init_dim_obs_l, U_prodRinvA_l, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFlocalomi_assimilate_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFlocalomi_assimilate_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state_lnetf_nondiagR(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, U_likelihood_l, & + flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_likelihood_l, & ! Compute likelihood and apply localization + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFlocalomi_put_state_lnetf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state_lnetf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFlocalomi_put_state_lnetf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate_lnetf_nondiagR(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prepoststep, U_init_n_domains_p, U_init_dim_l, & + U_init_dim_obs_l, U_likelihood_l, U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_likelihood_l, & ! Compute likelihood and apply localization + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFlocalomi_assimilate_lnetf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate_lnetf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFlocalomi_assimilate_lnetf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state_lknetf_nondiagR(U_collect_state, U_init_dim_obs, U_obs_op, & + U_prepoststep, U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_prodRinvA_l, U_prodRinvA_hyb_l, U_likelihood_l, U_likelihood_hyb_l, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prodRinvA_hyb_l, & ! Product R^-1 A on local analysis domain with hybrid weight + U_likelihood_l, & ! Compute likelihood and apply localization + U_likelihood_hyb_l, & ! Compute likelihood and apply localization with tempering + U_prepoststep ! User supplied pre/poststep routine + END SUBROUTINE PDAFlocalomi_put_state_lknetf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state_lknetf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFlocalomi_put_state_lknetf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate_lknetf_nondiagR(U_collect_state, U_distribute_state, & + U_init_dim_obs, U_obs_op, U_prepoststep, U_init_n_domains_p, U_init_dim_l, & + U_init_dim_obs_l, U_prodRinvA_l, U_prodRinvA_hyb_l, U_likelihood_l, U_likelihood_hyb_l, & + U_next_observation, flag) + INTEGER, INTENT(out) :: flag ! Status flag + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_distribute_state, & ! Routine to distribute a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prodRinvA_hyb_l, & ! Product R^-1 A on local analysis domain with hybrid weight + U_likelihood_l, & ! Compute likelihood and apply localization + U_likelihood_hyb_l, & ! Compute likelihood and apply localization with tempering + U_prepoststep, & ! User supplied pre/poststep routine + U_next_observation ! Provide time step and time of next observation + END SUBROUTINE PDAFlocalomi_assimilate_lknetf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate_lknetf_nondiagR_si(flag) + INTEGER, INTENT(out) :: flag ! Status flag + END SUBROUTINE PDAFlocalomi_assimilate_lknetf_nondiagR_si + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state_en3dvar_lestkf(collect_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + END SUBROUTINE PDAFlocalomi_put_state_en3dvar_lestkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate_en3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + END SUBROUTINE PDAFlocalomi_assimilate_en3dvar_lestkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR(collect_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prodRinvA_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + prodRinvA_pdaf, & ! Provide product R^-1 A + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdaf ! Provide product R^-1 A with localization + END SUBROUTINE PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prodRinvA_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + prodRinvA_pdaf, & ! Provide product R^-1 A + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdaf ! Provide product R^-1 A with localization + END SUBROUTINE PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state_hyb3dvar_lestkf(collect_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + END SUBROUTINE PDAFlocalomi_put_state_hyb3dvar_lestkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate_hyb3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + END SUBROUTINE PDAFlocalomi_assimilate_hyb3dvar_lestkf + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR(collect_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prodRinvA_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + prodRinvA_pdaf, & ! Provide product R^-1 A + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdaf ! Provide product R^-1 A with localization + END SUBROUTINE PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, prodRinvA_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + prodRinvA_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, next_observation_pdaf, outflag) + INTEGER, INTENT(inout) :: outflag ! Status flag + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + prodRinvA_pdaf, & ! Provide product R^-1 A + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdaf ! Provide product R^-1 A with localization + END SUBROUTINE PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_set_indices(dim_l, map) + INTEGER, INTENT(in) :: dim_l !< Dimension of local state vector + INTEGER, INTENT(in) :: map(dim_l) !< Index array for mapping + END SUBROUTINE PDAFlocal_set_indices + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_set_increment_weights(dim_l, weights) + INTEGER, INTENT(in) :: dim_l !< Dimension of local state vector + REAL, INTENT(in) :: weights(dim_l) !< Weights array + END SUBROUTINE PDAFlocal_set_increment_weights + END INTERFACE + + INTERFACE + SUBROUTINE PDAFlocal_clear_increment_weights() + END SUBROUTINE PDAFlocal_clear_increment_weights + END INTERFACE + +END MODULE PDAFlocal_interfaces diff --git a/src/PDAFlocal_l2g_cb.F90 b/src/PDAFlocal_l2g_cb.F90 new file mode 100644 index 000000000..c64126f98 --- /dev/null +++ b/src/PDAFlocal_l2g_cb.F90 @@ -0,0 +1,78 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_l2g_cb - Initialize global vector elements from local state vector +! +! !INTERFACE: +SUBROUTINE PDAFlocal_l2g_cb(step, domain_p, dim_l, state_l, dim_p, state_p) + +! !DESCRIPTION: +! Initialize elements of a global state vector from a local state vector. +! This is the full callback function to be used internally. The mapping +! is done using the index vector id_lstate_in_pstate that is initialize +! in PDAF_local_set_index. +! +! To exclude any element of the local state vector from the initialization +! one can set the corresponding index value to 0. +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAFlocal, & + ONLY: id_lstate_in_pstate, l2g_weights + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(in) :: step !< Current time step + INTEGER, INTENT(in) :: domain_p !< Current local analysis domain + INTEGER, INTENT(in) :: dim_l !< Local state dimension + INTEGER, INTENT(in) :: dim_p !< PE-local full state dimension + REAL, INTENT(in) :: state_l(dim_l) !< State vector on local analysis domain + REAL, INTENT(inout) :: state_p(dim_p) !< PE-local full state vector + +! !CALLING SEQUENCE: +! Called by filter routine +!EOP + +! *** local variables *** + INTEGER :: i ! Counter + + +! ************************************************** +! *** Initialize elements of global state vector *** +! ************************************************** + + IF (.NOT.ALLOCATED(l2g_weights)) THEN + ! Initialize global state vector with full updated local state + DO i = 1, dim_l + state_p(id_lstate_in_pstate(i)) = state_l(i) + END DO + ELSE + ! Apply increment weight when initializaing global state vector from local state vector + DO i = 1, dim_l + state_p(id_lstate_in_pstate(i)) = state_p(id_lstate_in_pstate(i)) & + + l2g_weights(i) * (state_l(i) - state_p(id_lstate_in_pstate(i))) + END DO + END IF + +END SUBROUTINE PDAFlocal_l2g_cb diff --git a/src/PDAFlocal_put_state_en3dvar_lestkf.F90 b/src/PDAFlocal_put_state_en3dvar_lestkf.F90 new file mode 100644 index 000000000..f8d27e16c --- /dev/null +++ b/src/PDAFlocal_put_state_en3dvar_lestkf.F90 @@ -0,0 +1,248 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_en3dvar_lestkf --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_en3dvar_lestkf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_prepoststep, outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. For the parallelization +! this involves transfer from model PEs to filter +! PEs.\\ +! During the forecast phase state vectors are +! re-initialized from the forecast model fields +! by U\_collect\_state. +! At the end of a forecast phase (i.e. when all +! ensemble members have been integrated by the model) +! sub-ensembles are gathered from the model tasks. +! Subsequently the filter update is performed. +! +! The code is very generic. Basically the only +! filter-specific part if the call to the +! update-routine PDAF\_X\_update where the analysis +! is computed. The filter-specific subroutines that +! are specified in the call to PDAF\_put\_state\_X +! are passed through to the update routine +! +! Variant for ensemble 3DVAR using LESTKF to +! update the ensemble perturbations. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2021-03 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_communicate_ens, & + ONLY: PDAF_gather_ens + USE PDAF_timer, & + ONLY: PDAF_timeit, PDAF_time_temp + USE PDAF_memcounting, & + ONLY: PDAF_memcount + USE PDAF_mod_filter, & + ONLY: dim_p, dim_obs, dim_ens, local_dim_ens, & + nsteps, step_obs, step, member, member_save, subtype_filter, & + type_forget, incremental, initevol, state, eofV, & + eofU, state_inc, forget, screen, flag, & + dim_cvec_ens, type_opt, offline_mode + USE PDAF_mod_filtermpi, & + ONLY: mype_world, filterpe, & + dim_ens_l, modelpe, filter_no_model + USE PDAFlocal, & + ONLY: PDAFlocal_g2l_cb, & ! Project global to local state vector + PDAFlocal_l2g_cb ! Project local to global state vecto + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_obs_op_f, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_f, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l ! Provide product R^-1 A on local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: U_collect_state +! Calls: PDAF_gather_ens +! Calls: PDAF_3dvar_update +! Calls: PDAF_timeit +!EOP + +! local variables + INTEGER :: i ! Counter + INTEGER, SAVE :: allocflag = 0 ! Flag whether first time allocation is done + + +! ************************************************** +! *** Save forecasted state back to the ensemble *** +! *** Only done on the filter Pes *** +! ************************************************** + + doevol: IF (nsteps > 0 .OR. .NOT.offline_mode) THEN + + CALL PDAF_timeit(41, 'new') + + modelpes: IF (modelpe) THEN + + ! Store member index for PDAF_get_memberid + member_save = member + + IF (subtype_filter /= 2 .AND. subtype_filter /= 3) THEN + ! Save evolved state in ensemble matrix + CALL U_collect_state(dim_p, eofV(1 : dim_p, member)) + ELSE + ! Save evolved ensemble mean state + CALL U_collect_state(dim_p, state(1:dim_p)) + END IF + END IF modelpes + + CALL PDAF_timeit(41, 'old') + + member = member + 1 + ELSE + member = local_dim_ens + 1 + END IF doevol + + IF (filter_no_model .AND. filterpe) THEN + member = local_dim_ens + 1 + END IF + + +! ******************************************************** +! *** When forecast phase is completed *** +! *** - collect forecast sub_ensembles on filter PEs *** +! *** - perform analysis step *** +! *** - re-initialize forecast counters/flags *** +! ******************************************************** + completeforecast: IF (member == local_dim_ens + 1 & + .OR. offline_mode) THEN + + ! *********************************************** + ! *** Collect forecast ensemble on filter PEs *** + ! *********************************************** + + doevolB: IF (nsteps > 0) THEN + + IF (.not.filterpe) THEN + ! Non filter PEs only store a sub-ensemble + CALL PDAF_gather_ens(dim_p, dim_ens_l, eofV, screen) + ELSE + ! On filter PEs, the ensemble array has full size + CALL PDAF_gather_ens(dim_p, dim_ens, eofV, screen) + END IF + + END IF doevolB + + ! *** call timer + CALL PDAF_timeit(2, 'old') + + IF (.NOT.offline_mode .AND. mype_world == 0 .AND. screen > 1) THEN + WRITE (*, '(a, 5x, a, F10.3, 1x, a)') & + 'PDAF', '--- duration of forecast phase:', PDAF_time_temp(2), 's' + END IF + + + ! ************************************** + ! *** Perform analysis on filter PEs *** + ! ************************************** + + ! Screen output + IF (offline_mode .AND. mype_world == 0 .AND. screen > 0) THEN + WRITE (*, '(//a5, 64a)') 'PDAF ',('-', i = 1, 64) + WRITE (*, '(a, 20x, a)') 'PDAF', '+++++ ASSIMILATION +++++' + WRITE (*, '(a5, 64a)') 'PDAF ', ('-', i = 1, 64) + ENDIF + + OnFilterPE: IF (filterpe) THEN + + IF (incremental == 0) THEN + ! Allocate only if no incremental updating is used. + ! With incremental STATE_INC is allocated in PDAF_filter_init. + ALLOCATE(state_inc(dim_p)) + IF (allocflag == 0) THEN + CALL PDAF_memcount(3, 'r', dim_p) + allocflag = 1 + END IF + END IF + + CALL PDAF_en3dvar_update_lestkf(step_obs, dim_p, dim_obs, dim_ens, & + dim_cvec_ens, state, eofU, eofV, state_inc, forget, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, U_prepoststep, & + U_cvt_ens, U_cvt_adj_ens, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, PDAFlocal_g2l_cb, & + PDAFlocal_l2g_cb, U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + screen, subtype_filter, incremental, type_forget, type_opt, & + flag) + + IF (incremental == 0) DEALLOCATE(state_inc) + + END IF OnFilterPE + + + ! *********************************** + ! *** Set forecast counters/flags *** + ! *********************************** + initevol = 1 + member = 1 + step = step_obs + 1 + + END IF completeforecast + + +! ******************** +! *** finishing up *** +! ******************** + + outflag = flag + +END SUBROUTINE PDAFlocal_put_state_en3dvar_lestkf diff --git a/src/PDAFlocal_put_state_hyb3dvar_lestkf.F90 b/src/PDAFlocal_put_state_hyb3dvar_lestkf.F90 new file mode 100644 index 000000000..a59505c49 --- /dev/null +++ b/src/PDAFlocal_put_state_hyb3dvar_lestkf.F90 @@ -0,0 +1,250 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_hyb3dvar_lestkf --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_hyb3dvar_lestkf(U_collect_state, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, & + U_cvt_ens, U_cvt_adj_ens, U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, & + U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + U_prepoststep, outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. For the parallelization +! this involves transfer from model PEs to filter +! PEs.\\ +! During the forecast phase state vectors are +! re-initialized from the forecast model fields +! by U\_collect\_state. +! At the end of a forecast phase (i.e. when all +! ensemble members have been integrated by the model) +! sub-ensembles are gathered from the model tasks. +! Subsequently the filter update is performed. +! +! The code is very generic. Basically the only +! filter-specific part if the call to the +! update-routine PDAF\_X\_update where the analysis +! is computed. The filter-specific subroutines that +! are specified in the call to PDAF\_put\_state\_X +! are passed through to the update routine +! +! Variant for hybrid 3DVAR using LESTKF to +! update the ensemble perturbations. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2021-03 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_communicate_ens, & + ONLY: PDAF_gather_ens + USE PDAF_timer, & + ONLY: PDAF_timeit, PDAF_time_temp + USE PDAF_memcounting, & + ONLY: PDAF_memcount + USE PDAF_mod_filter, & + ONLY: dim_p, dim_obs, dim_ens, local_dim_ens, & + nsteps, step_obs, step, member, member_save, subtype_filter, & + type_forget, incremental, initevol, state, eofV, & + eofU, state_inc, forget, screen, flag, & + dim_cvec, dim_cvec_ens, type_opt, offline_mode + USE PDAF_mod_filtermpi, & + ONLY: mype_world, filterpe, & + dim_ens_l, modelpe, filter_no_model + USE PDAFlocal, & + ONLY: PDAFlocal_g2l_cb, & ! Project global to local state vector + PDAFlocal_l2g_cb ! Project local to global state vector + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_init_dim_obs, & ! Initialize dimension of observation vector + U_obs_op, & ! Observation operator + U_init_obs, & ! Initialize observation vector + U_prepoststep, & ! User supplied pre/poststep routine + U_prodRinvA, & ! Provide product R^-1 A + U_cvt_ens, & ! Apply control vector transform matrix (ensemble) + U_cvt_adj_ens, & ! Apply adjoint control vector transform matrix (ensemble var) + U_cvt, & ! Apply control vector transform matrix to control vector + U_cvt_adj, & ! Apply adjoint control vector transform matrix + U_obs_op_lin, & ! Linearized observation operator + U_obs_op_adj ! Adjoint observation operator + EXTERNAL :: U_obs_op_f, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs_f, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_f, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l ! Provide product R^-1 A on local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: U_collect_state +! Calls: PDAF_gather_ens +! Calls: PDAF_3dvar_update +! Calls: PDAF_timeit +!EOP + +! local variables + INTEGER :: i ! Counter + INTEGER, SAVE :: allocflag = 0 ! Flag whether first time allocation is done + + +! ************************************************** +! *** Save forecasted state back to the ensemble *** +! *** Only done on the filter Pes *** +! ************************************************** + + doevol: IF (nsteps > 0 .OR. .NOT.offline_mode) THEN + + CALL PDAF_timeit(41, 'new') + + modelpes: IF (modelpe) THEN + + ! Store member index for PDAF_get_memberid + member_save = member + + IF (subtype_filter /= 2 .AND. subtype_filter /= 3) THEN + ! Save evolved state in ensemble matrix + CALL U_collect_state(dim_p, eofV(1 : dim_p, member)) + ELSE + ! Save evolved ensemble mean state + CALL U_collect_state(dim_p, state(1:dim_p)) + END IF + END IF modelpes + + CALL PDAF_timeit(41, 'old') + + member = member + 1 + ELSE + member = local_dim_ens + 1 + END IF doevol + + IF (filter_no_model .AND. filterpe) THEN + member = local_dim_ens + 1 + END IF + + +! ******************************************************** +! *** When forecast phase is completed *** +! *** - collect forecast sub_ensembles on filter PEs *** +! *** - perform analysis step *** +! *** - re-initialize forecast counters/flags *** +! ******************************************************** + completeforecast: IF (member == local_dim_ens + 1 & + .OR. offline_mode) THEN + + ! *********************************************** + ! *** Collect forecast ensemble on filter PEs *** + ! *********************************************** + + doevolB: IF (nsteps > 0) THEN + + IF (.not.filterpe) THEN + ! Non filter PEs only store a sub-ensemble + CALL PDAF_gather_ens(dim_p, dim_ens_l, eofV, screen) + ELSE + ! On filter PEs, the ensemble array has full size + CALL PDAF_gather_ens(dim_p, dim_ens, eofV, screen) + END IF + + END IF doevolB + + ! *** call timer + CALL PDAF_timeit(2, 'old') + + IF (.NOT.offline_mode .AND. mype_world == 0 .AND. screen > 1) THEN + WRITE (*, '(a, 5x, a, F10.3, 1x, a)') & + 'PDAF', '--- duration of forecast phase:', PDAF_time_temp(2), 's' + END IF + + + ! ************************************** + ! *** Perform analysis on filter PEs *** + ! ************************************** + + ! Screen output + IF (offline_mode .AND. mype_world == 0 .AND. screen > 0) THEN + WRITE (*, '(//a5, 64a)') 'PDAF ',('-', i = 1, 64) + WRITE (*, '(a, 20x, a)') 'PDAF', '+++++ ASSIMILATION +++++' + WRITE (*, '(a5, 64a)') 'PDAF ', ('-', i = 1, 64) + ENDIF + + OnFilterPE: IF (filterpe) THEN + + IF (incremental == 0) THEN + ! Allocate only if no incremental updating is used. + ! With incremental STATE_INC is allocated in PDAF_filter_init. + ALLOCATE(state_inc(dim_p)) + IF (allocflag == 0) THEN + CALL PDAF_memcount(3, 'r', dim_p) + allocflag = 1 + END IF + END IF + + CALL PDAF_hyb3dvar_update_lestkf(step_obs, dim_p, dim_obs, dim_ens, & + dim_cvec, dim_cvec_ens, state, eofU, eofV, state_inc, forget, & + U_init_dim_obs, U_obs_op, U_init_obs, U_prodRinvA, U_prepoststep, & + U_cvt_ens, U_cvt_adj_ens, U_cvt, U_cvt_adj, U_obs_op_lin, U_obs_op_adj, & + U_init_dim_obs_f, U_obs_op_f, U_init_obs_f, U_init_obs_l, U_prodRinvA_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, PDAFlocal_g2l_cb, & + PDAFlocal_l2g_cb, U_g2l_obs, U_init_obsvar, U_init_obsvar_l, & + screen, subtype_filter, incremental, type_forget, type_opt, & + flag) + + IF (incremental == 0) DEALLOCATE(state_inc) + + END IF OnFilterPE + + + ! *********************************** + ! *** Set forecast counters/flags *** + ! *********************************** + initevol = 1 + member = 1 + step = step_obs + 1 + + END IF completeforecast + + +! ******************** +! *** finishing up *** +! ******************** + + outflag = flag + +END SUBROUTINE PDAFlocal_put_state_hyb3dvar_lestkf diff --git a/src/PDAFlocal_put_state_lestkf.F90 b/src/PDAFlocal_put_state_lestkf.F90 new file mode 100644 index 000000000..7136d4349 --- /dev/null +++ b/src/PDAFlocal_put_state_lestkf.F90 @@ -0,0 +1,216 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! The code is very generic. Basically the only +! filter-specific part if the call to the +! update-routine PDAF\_X\_update where the analysis +! is computed. The filter-specific subroutines that +! are specified in the call to PDAF\_put\_state\_X +! are passed through to the update routine +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_lestkf --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_lestkf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. For the parallelization +! this involves transfer from model PEs to filter +! PEs.\\ +! During the forecast phase state vectors are +! re-initialized from the forecast model fields +! by U\_collect\_state. +! At the end of a forecast phase (i.e. when all +! ensemble members have been integrated by the model) +! sub-ensembles are gathered from the model tasks. +! Subsequently the filter update is performed. +! +! Variant for LESTKF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2011-09 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_communicate_ens, & + ONLY: PDAF_gather_ens + USE PDAF_timer, & + ONLY: PDAF_timeit, PDAF_time_temp + USE PDAF_mod_filter, & + ONLY: dim_p, dim_obs, dim_ens, rank, local_dim_ens, & + nsteps, step_obs, step, member, member_save, subtype_filter, & + type_forget, incremental, initevol, state, eofV, & + eofU, state_inc, screen, flag, & + type_sqrt, sens, dim_lag, cnt_maxlag, offline_mode + USE PDAF_mod_filtermpi, & + ONLY: mype_world, filterpe, dim_ens_l, modelpe, filter_no_model + USE PDAFlocal, & + ONLY: PDAFlocal_g2l_cb, & ! Project global to local state vector + PDAFlocal_l2g_cb ! Project local to global state vecto + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep ! User supplied pre/poststep routine + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: U_collect_state +! Calls: PDAF_gather_ens +! Calls: PDAF_lestkf_update +! Calls: PDAF_timeit +!EOP + +! local variables + INTEGER :: i ! Counter + + +! ************************************************** +! *** Save forecast state back to the ensemble *** +! *** Only done on the filter Pes *** +! ************************************************** + + doevol: IF (nsteps > 0) THEN + + CALL PDAF_timeit(41, 'new') + + modelpes: IF (modelpe) THEN + + ! Store member index for PDAF_get_memberid + member_save = member + + IF (subtype_filter /= 2 .AND. subtype_filter /= 3) THEN + ! Save evolved state in ensemble matrix + CALL U_collect_state(dim_p, eofV(1 : dim_p, member)) + ELSE + ! Save evolved ensemble mean state + CALL U_collect_state(dim_p, state(1 : dim_p)) + END IF + END IF modelpes + + CALL PDAF_timeit(41, 'old') + + member = member + 1 + ELSE + member = local_dim_ens + 1 + END IF doevol + + IF (filter_no_model .AND. filterpe) THEN + member = local_dim_ens + 1 + END IF + + +! ******************************************************** +! *** When forecast phase is completed *** +! *** - collect forecast sub_ensembles on filter PEs *** +! *** - perform analysis step *** +! *** - re-initialize forecast counters/flags *** +! ******************************************************** + completeforecast: IF (member == local_dim_ens + 1 & + .OR. offline_mode) THEN + + ! *********************************************** + ! *** Collect forecast ensemble on filter PEs *** + ! *********************************************** + + doevolB: IF (nsteps > 0) THEN + + IF (.not.filterpe) THEN + ! Non filter PEs only store a sub-ensemble + CALL PDAF_gather_ens(dim_p, dim_ens_l, eofV, screen) + ELSE + ! On filter PEs, the ensemble array has full size + CALL PDAF_gather_ens(dim_p, dim_ens, eofV, screen) + END IF + + end IF doevolB + + ! *** call timer + CALL PDAF_timeit(2, 'old') + + IF (.NOT.offline_mode .AND. mype_world == 0 .AND. screen > 1) THEN + WRITE (*, '(a, 5x, a, F10.3, 1x, a)') & + 'PDAF', '--- duration of forecast phase:', PDAF_time_temp(2), 's' + END IF + + + ! ************************************** + ! *** Perform analysis on filter PEs *** + ! ************************************** + + ! Screen output + IF (offline_mode .AND. mype_world == 0 .AND. screen > 0) THEN + WRITE (*, '(//a5, 64a)') 'PDAF ',('-', i = 1, 64) + WRITE (*, '(a, 20x, a)') 'PDAF', '+++++ ASSIMILATION +++++' + WRITE (*, '(a5, 64a)') 'PDAF ', ('-', i = 1, 64) + ENDIF + + OnFilterPE: IF (filterpe) THEN + CALL PDAF_lestkf_update(step_obs, dim_p, dim_obs, dim_ens, rank, state, & + eofU, eofV, state_inc, U_init_dim_obs, & + U_obs_op, U_init_obs, U_init_obs_l, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, PDAFlocal_g2l_cb, & + PDAFlocal_l2g_cb, U_g2l_obs, U_init_obsvar, U_init_obsvar_l, U_prepoststep, screen, subtype_filter, & + incremental, type_forget, type_sqrt, dim_lag, sens, & + cnt_maxlag, flag) + END IF OnFilterPE + + + ! *********************************** + ! *** Set forecast counters/flags *** + ! *********************************** + initevol = 1 + member = 1 + step = step_obs + 1 + + END IF completeforecast + + +! ******************** +! *** finishing up *** +! ******************** + + outflag = flag + +END SUBROUTINE PDAFlocal_put_state_lestkf diff --git a/src/PDAFlocal_put_state_lestkf_si.F90 b/src/PDAFlocal_put_state_lestkf_si.F90 new file mode 100644 index 000000000..9da7687e0 --- /dev/null +++ b/src/PDAFlocal_put_state_lestkf_si.F90 @@ -0,0 +1,82 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_lestkf_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_lestkf_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for LESTKF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2011-09 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + obs_op_f_pdaf, & ! Full observation operator + init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + init_obs_f_pdaf, & ! Initialize full observation vector + init_obs_l_pdaf, & ! Initialize local observation vector + init_obsvar_pdaf, & ! Initialize mean observation error variance + init_obsvar_l_pdaf, & ! Initialize local mean observation error variance + g2l_obs_pdaf, & ! Restrict full obs. vector to local analysis domain + prodRinvA_l_pdaf, & ! Provide product R^-1 A on local analysis domain + prepoststep_pdaf ! User supplied pre/poststep routine + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_lestkf +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocal_put_state_lestkf(collect_state_pdaf, init_dim_obs_f_pdaf, & + obs_op_f_pdaf, init_obs_f_pdaf, init_obs_l_pdaf, prepoststep_pdaf, & + prodRinvA_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdaf, g2l_obs_pdaf, init_obsvar_pdaf, init_obsvar_l_pdaf, outflag) + +END SUBROUTINE PDAFlocal_put_state_lestkf_si diff --git a/src/PDAFlocal_put_state_letkf.F90 b/src/PDAFlocal_put_state_letkf.F90 new file mode 100644 index 000000000..aca627599 --- /dev/null +++ b/src/PDAFlocal_put_state_letkf.F90 @@ -0,0 +1,216 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_letkf --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_letkf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. For the parallelization +! this involves transfer from model PEs to filter +! PEs.\\ +! During the forecast phase state vectors are +! re-initialized from the forecast model fields +! by U\_collect\_state. +! At the end of a forecast phase (i.e. when all +! ensemble members have been integrated by the model) +! sub-ensembles are gathered from the model tasks. +! Subsequently the filter update is performed. +! +! The code is very generic. Basically the only +! filter-specific part if the call to the +! update-routine PDAF\_X\_update where the analysis +! is computed. The filter-specific subroutines that +! are specified in the call to PDAF\_put\_state\_X +! are passed through to the update routine +! +! Variant for LETKF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2009-07 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_communicate_ens, & + ONLY: PDAF_gather_ens + USE PDAF_timer, & + ONLY: PDAF_timeit, PDAF_time_temp + USE PDAF_mod_filter, & + ONLY: dim_p, dim_obs, dim_ens, local_dim_ens, & + nsteps, step_obs, step, member, member_save, subtype_filter, & + type_forget, incremental, initevol, state, eofV, & + eofU, state_inc, screen, flag, & + sens, dim_lag, cnt_maxlag, offline_mode + USE PDAF_mod_filtermpi, & + ONLY: mype_world, filterpe, dim_ens_l, modelpe, filter_no_model + USE PDAFlocal, & + ONLY: PDAFlocal_g2l_cb, & ! Project global to local state vector + PDAFlocal_l2g_cb ! Project local to global state vecto + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep ! User supplied pre/poststep routine + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: U_collect_state +! Calls: PDAF_gather_ens +! Calls: PDAF_letkf_update +! Calls: PDAF_timeit +!EOP + +! local variables + INTEGER :: i ! Counter + + +! ************************************************** +! *** Save forecast state back to the ensemble *** +! *** Only done on the filter Pes *** +! ************************************************** + + doevol: IF (nsteps > 0) THEN + + CALL PDAF_timeit(41, 'new') + + modelpes: IF (modelpe) THEN + + ! Store member index for PDAF_get_memberid + member_save = member + + IF (subtype_filter /= 2 .AND. subtype_filter /= 3) THEN + ! Save evolved state in ensemble matrix + CALL U_collect_state(dim_p, eofV(1 : dim_p, member)) + ELSE + ! Save evolved ensemble mean state + CALL U_collect_state(dim_p, state(1 : dim_p)) + END IF + END IF modelpes + + CALL PDAF_timeit(41, 'old') + + member = member + 1 + ELSE + member = local_dim_ens + 1 + END IF doevol + + IF (filter_no_model .AND. filterpe) THEN + member = local_dim_ens + 1 + END IF + + +! ******************************************************** +! *** When forecast phase is completed *** +! *** - collect forecast sub_ensembles on filter PEs *** +! *** - perform analysis step *** +! *** - re-initialize forecast counters/flags *** +! ******************************************************** + completeforecast: IF (member == local_dim_ens + 1 & + .OR. offline_mode) THEN + + ! *********************************************** + ! *** Collect forecast ensemble on filter PEs *** + ! *********************************************** + + doevolB: IF (nsteps > 0) THEN + + IF (.not.filterpe) THEN + ! Non filter PEs only store a sub-ensemble + CALL PDAF_gather_ens(dim_p, dim_ens_l, eofV, screen) + ELSE + ! On filter PEs, the ensemble array has full size + CALL PDAF_gather_ens(dim_p, dim_ens, eofV, screen) + END IF + + END IF doevolB + + ! *** call timer + CALL PDAF_timeit(2, 'old') + + IF (.NOT.offline_mode .AND. mype_world == 0 .AND. screen > 1) THEN + WRITE (*, '(a, 5x, a, F10.3, 1x, a)') & + 'PDAF', '--- duration of forecast phase:', PDAF_time_temp(2), 's' + END IF + + + ! ************************************** + ! *** Perform analysis on filter PEs *** + ! ************************************** + + ! Screen output + IF (offline_mode .AND. mype_world == 0 .AND. screen > 0) THEN + WRITE (*, '(//a5, 64a)') 'PDAF ',('-', i = 1, 64) + WRITE (*, '(a, 20x, a)') 'PDAF', '+++++ ASSIMILATION +++++' + WRITE (*, '(a5, 64a)') 'PDAF ', ('-', i = 1, 64) + ENDIF + + OnFilterPE: IF (filterpe) THEN + CALL PDAF_letkf_update(step_obs, dim_p, dim_obs, dim_ens, state, & + eofU, eofV, state_inc, U_init_dim_obs, & + U_obs_op, U_init_obs, U_init_obs_l, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, PDAFlocal_g2l_cb, & + PDAFlocal_l2g_cb, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, U_prepoststep, screen, subtype_filter, & + incremental, type_forget, dim_lag, sens, cnt_maxlag, flag) + END IF OnFilterPE + + + ! *********************************** + ! *** Set forecast counters/flags *** + ! *********************************** + initevol = 1 + member = 1 + step = step_obs + 1 + + END IF completeforecast + + +! ******************** +! *** finishing up *** +! ******************** + + outflag = flag + +END SUBROUTINE PDAFlocal_put_state_letkf diff --git a/src/PDAFlocal_put_state_letkf_si.F90 b/src/PDAFlocal_put_state_letkf_si.F90 new file mode 100644 index 000000000..0b5a64d7e --- /dev/null +++ b/src/PDAFlocal_put_state_letkf_si.F90 @@ -0,0 +1,82 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_letkf_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_letkf_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for LETKF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2010-07 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + obs_op_f_pdaf, & ! Full observation operator + init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + init_obs_f_pdaf, & ! Initialize full observation vector + init_obs_l_pdaf, & ! Initialize local observation vector + init_obsvar_pdaf, & ! Initialize mean observation error variance + init_obsvar_l_pdaf, & ! Initialize local mean observation error variance + g2l_obs_pdaf, & ! Restrict full obs. vector to local analysis domain + prodRinvA_l_pdaf, & ! Provide product R^-1 A on local analysis domain + prepoststep_pdaf ! User supplied pre/poststep routine + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_letkf +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocal_put_state_letkf(collect_state_pdaf, init_dim_obs_f_pdaf, & + obs_op_f_pdaf, init_obs_f_pdaf, init_obs_l_pdaf, prepoststep_pdaf, & + prodRinvA_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdaf, g2l_obs_pdaf, init_obsvar_pdaf, init_obsvar_l_pdaf, outflag) + +END SUBROUTINE PDAFlocal_put_state_letkf_si diff --git a/src/PDAFlocal_put_state_lknetf.F90 b/src/PDAFlocal_put_state_lknetf.F90 new file mode 100644 index 000000000..9bb67c417 --- /dev/null +++ b/src/PDAFlocal_put_state_lknetf.F90 @@ -0,0 +1,232 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_lknetf --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_lknetf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_prodRinvA_hyb_l, & + U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, U_likelihood_l, U_likelihood_hyb_l, outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. For the parallelization +! this involves transfer from model PEs to filter +! PEs.\\ +! During the forecast phase state vectors are +! re-initialized from the forecast model fields +! by U\_collect\_state. +! At the end of a forecast phase (i.e. when all +! ensemble members have been integrated by the model) +! sub-ensembles are gathered from the model tasks. +! Subsequently the filter update is performed. +! +! The code is very generic. Basically the only +! filter-specific part if the call to the +! update-routine PDAF\_X\_update where the analysis +! is computed. The filter-specific subroutines that +! are specified in the call to PDAF\_put\_state\_X +! are passed through to the update routine +! +! Variant for LKNETF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2017-08 - Lars Nerger - Initial code based on LETKF +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_communicate_ens, & + ONLY: PDAF_gather_ens + USE PDAF_timer, & + ONLY: PDAF_timeit, PDAF_time_temp + USE PDAF_mod_filter, & + ONLY: dim_p, dim_obs, dim_ens, local_dim_ens, & + nsteps, step_obs, step, member, member_save, subtype_filter, & + type_forget, incremental, initevol, state, eofV, & + eofU, state_inc, screen, flag, & + sens, dim_lag, cnt_maxlag, offline_mode + USE PDAF_mod_filtermpi, & + ONLY: mype_world, filterpe, dim_ens_l, modelpe, filter_no_model + USE PDAFlocal, & + ONLY: PDAFlocal_g2l_cb, & ! Project global to local state vector + PDAFlocal_l2g_cb ! Project local to global state vecto + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prodRinvA_hyb_l, & ! Provide product R^-1 A on local analysis domain with hybrid weight + U_likelihood_l, & ! Compute likelihood + U_likelihood_hyb_l, & ! Compute likelihood with hybrid weight + U_prepoststep ! User supplied pre/poststep routine + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: U_collect_state +! Calls: PDAF_gather_ens +! Calls: PDAF_lknetf_update +! Calls: PDAF_timeit +!EOP + +! local variables + INTEGER :: i ! Counter + + +! ************************************************** +! *** Save forecast state back to the ensemble *** +! *** Only done on the filter Pes *** +! ************************************************** + + doevol: IF (nsteps > 0) THEN + + CALL PDAF_timeit(41, 'new') + + modelpes: IF (modelpe) THEN + + ! Store member index for PDAF_get_memberid + member_save = member + + IF (subtype_filter /= 2 .AND. subtype_filter /= 3) THEN + ! Save evolved state in ensemble matrix + CALL U_collect_state(dim_p, eofV(1 : dim_p, member)) + ELSE + ! Save evolved ensemble mean state + CALL U_collect_state(dim_p, state(1 : dim_p)) + END IF + END IF modelpes + + CALL PDAF_timeit(41, 'old') + + member = member + 1 + ELSE + member = local_dim_ens + 1 + END IF doevol + + IF (filter_no_model .AND. filterpe) THEN + member = local_dim_ens + 1 + END IF + + +! ******************************************************** +! *** When forecast phase is completed *** +! *** - collect forecast sub_ensembles on filter PEs *** +! *** - perform analysis step *** +! *** - re-initialize forecast counters/flags *** +! ******************************************************** + completeforecast: IF (member == local_dim_ens + 1 & + .OR. offline_mode) THEN + + ! *********************************************** + ! *** Collect forecast ensemble on filter PEs *** + ! *********************************************** + + doevolB: IF (nsteps > 0) THEN + + IF (.not.filterpe) THEN + ! Non filter PEs only store a sub-ensemble + CALL PDAF_gather_ens(dim_p, dim_ens_l, eofV, screen) + ELSE + ! On filter PEs, the ensemble array has full size + CALL PDAF_gather_ens(dim_p, dim_ens, eofV, screen) + END IF + + END IF doevolB + + ! *** call timer + CALL PDAF_timeit(2, 'old') + + IF (.NOT.offline_mode .AND. mype_world == 0 .AND. screen > 1) THEN + WRITE (*, '(a, 5x, a, F10.3, 1x, a)') & + 'PDAF', '--- duration of forecast phase:', PDAF_time_temp(2), 's' + END IF + + + ! ************************************** + ! *** Perform analysis on filter PEs *** + ! ************************************** + + ! Screen output + IF (offline_mode .AND. mype_world == 0 .AND. screen > 0) THEN + WRITE (*, '(//a5, 64a)') 'PDAF ',('-', i = 1, 64) + WRITE (*, '(a, 20x, a)') 'PDAF', '+++++ ASSIMILATION +++++' + WRITE (*, '(a5, 64a)') 'PDAF ', ('-', i = 1, 64) + ENDIF + + OnFilterPE: IF (filterpe) THEN + IF (subtype_filter == 4) THEN + CALL PDAF_lknetf_update(step_obs, dim_p, dim_obs, dim_ens, state, & + eofU, eofV, state_inc, U_init_dim_obs, & + U_obs_op, U_init_obs, U_init_obs_l, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, PDAFlocal_g2l_cb, & + PDAFlocal_l2g_cb, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, U_likelihood_l, & + U_prepoststep, screen, subtype_filter, incremental, type_forget, & + dim_lag, sens, cnt_maxlag, flag) + ELSE + CALL PDAF_lknetf_step_update(step_obs, dim_p, dim_obs, dim_ens, state, & + eofU, eofV, state_inc, U_init_dim_obs, & + U_obs_op, U_init_obs, U_init_obs_l, U_prodRinvA_hyb_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, PDAFlocal_g2l_cb, & + PDAFlocal_l2g_cb, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, U_likelihood_l, U_likelihood_hyb_l, U_prepoststep, & + screen, subtype_filter, & + incremental, type_forget, dim_lag, sens, cnt_maxlag, flag) + END IF + END IF OnFilterPE + + + ! *********************************** + ! *** Set forecast counters/flags *** + ! *********************************** + initevol = 1 + member = 1 + step = step_obs + 1 + + END IF completeforecast + + +! ******************** +! *** finishing up *** +! ******************** + + outflag = flag + +END SUBROUTINE PDAFlocal_put_state_lknetf diff --git a/src/PDAFlocal_put_state_lknetf_si.F90 b/src/PDAFlocal_put_state_lknetf_si.F90 new file mode 100644 index 000000000..1b3756678 --- /dev/null +++ b/src/PDAFlocal_put_state_lknetf_si.F90 @@ -0,0 +1,86 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_lknetf_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_lknetf_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for LKNETF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2018-07 - Lars Nerger - Initial code based on LETKF +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + obs_op_f_pdaf, & ! Full observation operator + init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + init_obs_f_pdaf, & ! Initialize full observation vector + init_obs_l_pdaf, & ! Initialize local observation vector + init_obsvar_pdaf, & ! Initialize mean observation error variance + init_obsvar_l_pdaf, & ! Initialize local mean observation error variance + g2l_obs_pdaf, & ! Restrict full obs. vector to local analysis domain + prodRinvA_l_pdaf, & ! Provide product R^-1 A on local analysis domain + prodRinvA_hyb_l_pdaf, & ! Provide product R^-1 A on local analysis domain with hybrid weight + likelihood_l_pdaf, & ! Compute observation likelihood for an ensemble member + likelihood_hyb_l_pdaf, & ! Compute observation likelihood for an ensemble member with hybrid weight + prepoststep_pdaf ! User supplied pre/poststep routine + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_lknetf +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocal_put_state_lknetf(collect_state_pdaf, init_dim_obs_f_pdaf, & + obs_op_f_pdaf, init_obs_f_pdaf, init_obs_l_pdaf, prepoststep_pdaf, & + prodRinvA_l_pdaf, prodRinvA_hyb_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdaf, g2l_obs_pdaf, init_obsvar_pdaf, init_obsvar_l_pdaf, likelihood_l_pdaf, & + likelihood_hyb_l_pdaf, outflag) + +END SUBROUTINE PDAFlocal_put_state_lknetf_si diff --git a/src/PDAFlocal_put_state_lnetf.F90 b/src/PDAFlocal_put_state_lnetf.F90 new file mode 100644 index 000000000..a8bee8cf8 --- /dev/null +++ b/src/PDAFlocal_put_state_lnetf.F90 @@ -0,0 +1,204 @@ +! Copyright (c) 2014-2024 Paul Kirchgessner +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_lnetf --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_lnetf(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs_l, U_prepoststep, U_likelihood_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. For the parallelization +! this involves transfer from model PEs to filter +! PEs.\\ +! During the forecast phase state vectors are +! re-initialized from the forecast model fields +! by U\_collect\_state. +! At the end of a forecast phase (i.e. when all +! ensemble members have been integrated by the model) +! sub-ensembles are gathered from the model tasks. +! Subsequently the filter update is performed. +! +! The code is very generic. Basically the only +! filter-specific part if the call to the +! update-routine PDAF\_X\_update where the analysis +! is computed. The filter-specific subroutines that +! are specified in the call to PDAF\_put\_state\_X +! are passed through to the update routine +! +! Variant for LNETF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2014-05 - Paul Kirchgessner - Initial code based on LETKF +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_communicate_ens, & + ONLY: PDAF_gather_ens + USE PDAF_timer, & + ONLY: PDAF_timeit, PDAF_time_temp + USE PDAF_memcounting, & + ONLY: PDAF_memcount + USE PDAF_mod_filter, & + ONLY: dim_p, dim_obs, dim_ens, local_dim_ens, & + nsteps, step_obs, step, member, member_save, subtype_filter, & + type_forget, initevol, state, eofV, & + noise_type, pf_noise_amp, offline_mode, & + eofU, screen, flag, sens, dim_lag, cnt_maxlag + USE PDAF_mod_filtermpi, & + ONLY: mype_world, filterpe, dim_ens_l + USE PDAFlocal, & + ONLY: PDAFlocal_g2l_cb, & ! Project global to local state vector + PDAFlocal_l2g_cb ! Project local to global state vecto + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_likelihood_l, & ! Compute observation likelihood for an ensemble member + U_prepoststep ! User supplied pre/poststep routine + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: U_collect_state +! Calls: PDAF_gather_ens +! Calls: PDAF_etkf_update +! Calls: PDAF_timeit +!EOP + +! local variables + INTEGER :: i ! Counter + + +! ************************************************** +! *** Save forecasted state back to the ensemble *** +! *** Only done on the filter Pes *** +! ************************************************** + + doevol: IF (nsteps > 0 ) THEN + + CALL PDAF_timeit(41, 'new') + + ! Store member index for PDAF_get_memberid + member_save = member + + ! Save evolved state in ensemble matrix + CALL U_collect_state(dim_p, eofV(1 : dim_p, member)) + + CALL PDAF_timeit(41, 'old') + + member = member + 1 + ELSE + member = local_dim_ens + 1 + END IF doevol + + +! ******************************************************** +! *** When forecast phase is completed *** +! *** - collect forecast sub_ensembles on filter PEs *** +! *** - perform analysis step *** +! *** - re-initialize forecast counters/flags *** +! ******************************************************** + completeforecast: IF (member == local_dim_ens + 1 & + .OR. offline_mode) THEN + + ! *********************************************** + ! *** Collect forecast ensemble on filter PEs *** + ! *********************************************** + + doevolB: IF (nsteps > 0) THEN + + IF (.not.filterpe) THEN + ! Non filter PEs only store a sub-ensemble + CALL PDAF_gather_ens(dim_p, dim_ens_l, eofV, screen) + ELSE + ! On filter PEs, the ensemble array has full size + CALL PDAF_gather_ens(dim_p, dim_ens, eofV, screen) + END IF + + END IF doevolB + + ! *** call timer + CALL PDAF_timeit(2, 'old') + + IF (.NOT.offline_mode .AND. mype_world == 0 .AND. screen > 1) THEN + WRITE (*, '(a, 5x, a, F10.3, 1x, a)') & + 'PDAF', '--- duration of forecast phase:', PDAF_time_temp(2), 's' + END IF + + + ! ************************************** + ! *** Perform analysis on filter PEs *** + ! ************************************** + + ! Screen output + IF (offline_mode .AND. mype_world == 0 .AND. screen > 0) THEN + WRITE (*, '(//a5, 64a)') 'PDAF ',('-', i = 1, 64) + WRITE (*, '(a, 20x, a)') 'PDAF', '+++++ ASSIMILATION +++++' + WRITE (*, '(a5, 64a)') 'PDAF ', ('-', i = 1, 64) + ENDIF + + OnFilterPE: IF (filterpe) THEN + + CALL PDAF_lnetf_update(step_obs, dim_p, dim_obs, dim_ens, & + state, eofU, eofV, type_forget, noise_type, pf_noise_amp, & + U_obs_op, U_init_dim_obs, U_init_obs_l, U_likelihood_l, & + U_init_n_domains_p, U_init_dim_l, U_init_dim_obs_l, PDAFlocal_g2l_cb, & + PDAFlocal_l2g_cb, U_g2l_obs, U_prepoststep, screen, subtype_filter, & + dim_lag, sens, cnt_maxlag, flag) + + END IF OnFilterPE + + + ! *********************************** + ! *** Set forecast counters/flags *** + ! *********************************** + initevol = 1 + member = 1 + step = step_obs + 1 + + END IF completeforecast + + +! ******************** +! *** finishing up *** +! ******************** + + outflag = flag + +END SUBROUTINE PDAFlocal_put_state_lnetf diff --git a/src/PDAFlocal_put_state_lnetf_si.F90 b/src/PDAFlocal_put_state_lnetf_si.F90 new file mode 100644 index 000000000..1d0a90ae5 --- /dev/null +++ b/src/PDAFlocal_put_state_lnetf_si.F90 @@ -0,0 +1,78 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_lnetf_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_lnetf_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for LNETF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2016-11 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + obs_op_f_pdaf, & ! Full observation operator + init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + init_obs_l_pdaf, & ! Initialize local observation vector + g2l_obs_pdaf, & ! Restrict full obs. vector to local analysis domain + likelihood_l_pdaf, & ! Compute observation likelihood for an ensemble member + prepoststep_pdaf ! User supplied pre/poststep routine + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_lnetf +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocal_put_state_lnetf(collect_state_pdaf, init_dim_obs_f_pdaf, obs_op_f_pdaf, & + init_obs_l_pdaf, prepoststep_pdaf, likelihood_l_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdaf, g2l_obs_pdaf, outflag) + +END SUBROUTINE PDAFlocal_put_state_lnetf_si diff --git a/src/PDAFlocal_put_state_lseik.F90 b/src/PDAFlocal_put_state_lseik.F90 new file mode 100644 index 000000000..cea6aac1b --- /dev/null +++ b/src/PDAFlocal_put_state_lseik.F90 @@ -0,0 +1,214 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! The code is very generic. Basically the only +! filter-specific part if the call to the +! update-routine PDAF\_X\_update where the analysis +! is computed. The filter-specific subroutines that +! are specified in the call to PDAF\_put\_state\_X +! are passed through to the update routine +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_lseik --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_lseik(U_collect_state, U_init_dim_obs, U_obs_op, & + U_init_obs, U_init_obs_l, U_prepoststep, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. For the parallelization +! this involves transfer from model PEs to filter +! PEs.\\ +! During the forecast phase state vectors are +! re-initialized from the forecast model fields +! by U\_collect\_state. +! At the end of a forecast phase (i.e. when all +! ensemble members have been integrated by the model) +! sub-ensembles are gathered from the model tasks. +! Subsequently the filter update is performed. +! +! Variant for LSEIK with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2003-09 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_communicate_ens, & + ONLY: PDAF_gather_ens + USE PDAF_timer, & + ONLY: PDAF_timeit, PDAF_time_temp + USE PDAF_mod_filter, & + ONLY: dim_p, dim_obs, dim_ens, rank, local_dim_ens, & + nsteps, step_obs, step, member, member_save, subtype_filter, & + type_forget, incremental, initevol, state, eofV, eofU, & + state_inc, screen, flag, type_sqrt, offline_mode + USE PDAF_mod_filtermpi, & + ONLY: mype_world, filterpe, dim_ens_l, modelpe, filter_no_model + USE PDAFlocal, & + ONLY: PDAFlocal_g2l_cb, & ! Project global to local state vector + PDAFlocal_l2g_cb ! Project local to global state vecto + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(out) :: outflag ! Status flag + +! ! External subroutines +! ! (PDAF-internal names, real names are defined in the call to PDAF) + EXTERNAL :: U_collect_state, & ! Routine to collect a state vector + U_obs_op, & ! Observation operator + U_init_n_domains_p, & ! Provide number of local analysis domains + U_init_dim_l, & ! Init state dimension for local ana. domain + U_init_dim_obs, & ! Initialize dimension of observation vector + U_init_dim_obs_l, & ! Initialize dim. of obs. vector for local ana. domain + U_init_obs, & ! Initialize PE-local observation vector + U_init_obs_l, & ! Init. observation vector on local analysis domain + U_init_obsvar, & ! Initialize mean observation error variance + U_init_obsvar_l, & ! Initialize local mean observation error variance + U_g2l_obs, & ! Restrict full obs. vector to local analysis domain + U_prodRinvA_l, & ! Provide product R^-1 A on local analysis domain + U_prepoststep ! User supplied pre/poststep routine + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: U_collect_state +! Calls: PDAF_gather_ens +! Calls: PDAF_lseik_update +! Calls: PDAF_timeit +!EOP + +! local variables + INTEGER :: i ! Counter + + +! ************************************************** +! *** Save forecast state back to the ensemble *** +! *** Only done on the filter Pes *** +! ************************************************** + + doevol: IF (nsteps > 0) THEN + + CALL PDAF_timeit(41, 'new') + + modelpes: IF (modelpe) THEN + + ! Store member index for PDAF_get_memberid + member_save = member + + IF (subtype_filter /= 2 .AND. subtype_filter /= 3) THEN + ! Save evolved state in ensemble matrix + CALL U_collect_state(dim_p, eofV(1 : dim_p, member)) + ELSE + ! Save evolved ensemble mean state + CALL U_collect_state(dim_p, state(1 : dim_p)) + END IF + END IF modelpes + + CALL PDAF_timeit(41, 'old') + + member = member + 1 + ELSE + member = local_dim_ens + 1 + END IF doevol + + IF (filter_no_model .AND. filterpe) THEN + member = local_dim_ens + 1 + END IF + + +! ******************************************************** +! *** When forecast phase is completed *** +! *** - collect forecast sub_ensembles on filter PEs *** +! *** - perform analysis step *** +! *** - re-initialize forecast counters/flags *** +! ******************************************************** + completeforecast: IF (member == local_dim_ens + 1 & + .OR. offline_mode) THEN + + ! *********************************************** + ! *** Collect forecast ensemble on filter PEs *** + ! *********************************************** + + doevolB: IF (nsteps > 0) THEN + + IF (.NOT.filterpe) THEN + ! Non filter PEs only store a sub-ensemble + CALL PDAF_gather_ens(dim_p, dim_ens_l, eofV, screen) + ELSE + ! On filter PEs, the ensemble array has full size + CALL PDAF_gather_ens(dim_p, dim_ens, eofV, screen) + END IF + + END IF doevolB + + ! *** call timer + CALL PDAF_timeit(2, 'old') + + IF (.NOT.offline_mode .AND. mype_world == 0 .AND. screen > 1) THEN + WRITE (*, '(a, 5x, a, F10.3, 1x, a)') & + 'PDAF', '--- duration of forecast phase:', PDAF_time_temp(2), 's' + END IF + + + ! ************************************** + ! *** Perform analysis on filter PEs *** + ! ************************************** + + ! Screen output + IF (offline_mode .AND. mype_world == 0 .AND. screen > 0) THEN + WRITE (*, '(//a5, 64a)') 'PDAF ',('-', i = 1, 64) + WRITE (*, '(a, 20x, a)') 'PDAF', '+++++ ASSIMILATION +++++' + WRITE (*, '(a5, 64a)') 'PDAF ', ('-', i = 1, 64) + ENDIF + + OnFilterPE: IF (filterpe) THEN + CALL PDAF_lseik_update(step_obs, dim_p, dim_obs, dim_ens, rank, state, & + eofU, eofV, state_inc, U_init_dim_obs, & + U_obs_op, U_init_obs, U_init_obs_l, U_prodRinvA_l, U_init_n_domains_p, & + U_init_dim_l, U_init_dim_obs_l, PDAFlocal_g2l_cb, PDAFlocal_l2g_cb, U_g2l_obs, & + U_init_obsvar, U_init_obsvar_l, U_prepoststep, screen, subtype_filter, & + incremental, type_forget, type_sqrt, flag) + END IF OnFilterPE + + + ! *********************************** + ! *** Set forecast counters/flags *** + ! *********************************** + initevol = 1 + member = 1 + step = step_obs + 1 + + END IF completeforecast + + +! ******************** +! *** finishing up *** +! ******************** + + outflag = flag + +END SUBROUTINE PDAFlocal_put_state_lseik diff --git a/src/PDAFlocal_put_state_lseik_si.F90 b/src/PDAFlocal_put_state_lseik_si.F90 new file mode 100644 index 000000000..5256d756b --- /dev/null +++ b/src/PDAFlocal_put_state_lseik_si.F90 @@ -0,0 +1,82 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocal_put_state_lseik_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocal_put_state_lseik_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for LSEIK with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2010-07 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + obs_op_f_pdaf, & ! Full observation operator + init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + init_dim_obs_l_pdaf, & ! Initialize local dimimension of obs. vector + init_obs_f_pdaf, & ! Initialize full observation vector + init_obs_l_pdaf, & ! Initialize local observation vector + init_obsvar_pdaf, & ! Initialize mean observation error variance + init_obsvar_l_pdaf, & ! Initialize local mean observation error variance + g2l_obs_pdaf, & ! Restrict full obs. vector to local analysis domain + prodRinvA_l_pdaf, & ! Provide product R^-1 A on local analysis domain + prepoststep_pdaf ! User supplied pre/poststep routine + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocal_put_state_lseik +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocal_put_state_lseik(collect_state_pdaf, init_dim_obs_f_pdaf, & + obs_op_f_pdaf, init_obs_f_pdaf, init_obs_l_pdaf, prepoststep_pdaf, & + prodRinvA_l_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdaf, g2l_obs_pdaf, init_obsvar_pdaf, init_obsvar_l_pdaf, outflag) + +END SUBROUTINE PDAFlocal_put_state_lseik_si diff --git a/src/PDAFlocal_set_increment_weights.F90 b/src/PDAFlocal_set_increment_weights.F90 new file mode 100644 index 000000000..2507c8b7f --- /dev/null +++ b/src/PDAFlocal_set_increment_weights.F90 @@ -0,0 +1,59 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! + +!> Set vector of local increment weights +!! +!! This routine initializes a PDAF_internal local array +!! of increment weights. The weights are applied in +!! in PDAF_local_l2g_cb, when the global state vector +!! is initialized from the local state vector. These can +!! e.g. be used to apply a vertical localization. +!! +!! __Revision history:__ +!! * 2024-08 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! +SUBROUTINE PDAFlocal_set_increment_weights(dim_l, weights) + + USE PDAF_mod_filter, & + ONLY: debug + USE PDAFlocal, & + ONLY: l2g_weights + + IMPLICIT NONE + +! *** Arguments *** + INTEGER, INTENT(in) :: dim_l !< Dimension of local state vector + REAL, INTENT(in) :: weights(dim_l) !< Weights array + + +! ******************************************** +! *** Initialize PDAF_internal index array *** +! ******************************************** + + IF (ALLOCATED(l2g_weights)) DEALLOCATE(l2g_weights) + ALLOCATE(l2g_weights(dim_l)) + + l2g_weights(:) = weights(:) + + IF (debug>0) THEN + WRITE (*,*) '++ PDAF-debug: ', debug, 'PDAFlocal_set_increment_weights -- Set local increment weights' + WRITE (*,*) '++ PDAF-debug PDAFlocal_set_increment_weights:', debug, 'weights', l2g_weights(1:dim_l) + END IF + +END SUBROUTINE PDAFlocal_set_increment_weights diff --git a/src/PDAFlocal_set_indices.F90 b/src/PDAFlocal_set_indices.F90 new file mode 100644 index 000000000..c3899c8b6 --- /dev/null +++ b/src/PDAFlocal_set_indices.F90 @@ -0,0 +1,55 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! + +!> Set index vector to map between global and local state vectors +!! +!! This routine initializes a PDAF_internal local index array +!! for the mapping between the global and local state vectors +!! +!! __Revision history:__ +!! * 2024-08 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! +SUBROUTINE PDAFlocal_set_indices(dim_l, map) + + USE PDAF_mod_filter, & + ONLY: debug + USE PDAFlocal, & + ONLY: id_lstate_in_pstate + + IMPLICIT NONE + +! *** Arguments *** + INTEGER, INTENT(in) :: dim_l !< Dimension of local state vector + INTEGER, INTENT(in) :: map(dim_l) !< Index array for mapping + + +! ******************************************** +! *** Initialize PDAF_internal index array *** +! ******************************************** + + IF (ALLOCATED(id_lstate_in_pstate)) DEALLOCATE(id_lstate_in_pstate) + ALLOCATE(id_lstate_in_pstate(dim_l)) + + id_lstate_in_pstate(:) = map(:) + + IF (debug>0) THEN + WRITE (*,*) '++ PDAF-debug PDAFlocal_set_indices:', debug, 'indices', id_lstate_in_pstate(1:dim_l) + END IF + +END SUBROUTINE PDAFlocal_set_indices diff --git a/src/PDAFlocalomi_assimilate.F90 b/src/PDAFlocalomi_assimilate.F90 new file mode 100644 index 000000000..8d4949c2a --- /dev/null +++ b/src/PDAFlocalomi_assimilate.F90 @@ -0,0 +1,139 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdaf, & + next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2020-11 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb, & ! Restrict full obs. vector to local analysis domain + PDAFomi_prodRinvA_l_cb, & ! Provide product R^-1 A on local analysis domain + PDAFomi_likelihood_l_cb ! Compute likelihood and apply localization + EXTERNAL :: PDAFomi_prodRinvA_hyb_l_cb, & ! Product R^-1 A on local analysis domain with hybrid weight + PDAFomi_likelihood_hyb_l_cb ! Compute likelihood and apply localization with tempering + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate -- START' + + IF (TRIM(filterstr) == 'LSEIK') THEN + CALL PDAFlocal_assimilate_lseik(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, PDAFomi_prodRinvA_l_cb, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdaf, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + next_observation_pdaf, outflag) + ELSE IF (TRIM(filterstr) == 'LETKF') THEN + CALL PDAFlocal_assimilate_letkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, PDAFomi_prodRinvA_l_cb, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdaf, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + next_observation_pdaf, outflag) + ELSE IF (TRIM(filterstr) == 'LESTKF') THEN + CALL PDAFlocal_assimilate_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, PDAFomi_prodRinvA_l_cb, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdaf, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + next_observation_pdaf, outflag) + ELSE IF (TRIM(filterstr) == 'LNETF') THEN + CALL PDAFlocal_assimilate_lnetf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, PDAFomi_likelihood_l_cb, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdaf, & + PDAFomi_g2l_obs_cb, next_observation_pdaf, outflag) + ELSE IF (TRIM(filterstr) == 'LKNETF') THEN + CALL PDAFlocal_assimilate_lknetf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + PDAFomi_prodRinvA_l_cb, PDAFomi_prodRinvA_hyb_l_cb, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, PDAFomi_likelihood_l_cb, PDAFomi_likelihood_hyb_l_cb, & + next_observation_pdaf, outflag) + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate -- END' + +END SUBROUTINE PDAFlocalomi_assimilate diff --git a/src/PDAFlocalomi_assimilate_en3dvar_lestkf.F90 b/src/PDAFlocalomi_assimilate_en3dvar_lestkf.F90 new file mode 100644 index 000000000..68226c06a --- /dev/null +++ b/src/PDAFlocalomi_assimilate_en3dvar_lestkf.F90 @@ -0,0 +1,118 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate_en3dvar_lestkf --- Interface to PDAF for En3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate_en3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2021-04 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A + PDAFomi_g2l_obs_cb, & ! Restrict full obs. vector to local analysis domain + PDAFomi_prodRinvA_l_cb, & ! Provide product R^-1 A on local analysis domain + PDAFomi_likelihood_l_cb ! Compute likelihood and apply localization + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_en3dvar_lestkf -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAFlocal_assimilate_en3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_f_cb, PDAFomi_prodRinvA_cb, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + PDAFomi_prodRinvA_l_cb, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdaf, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + prepoststep_pdaf, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFlocalomi_assimilate_3dvar' + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_en3dvar_lestkf -- END' + +END SUBROUTINE PDAFlocalomi_assimilate_en3dvar_lestkf diff --git a/src/PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR.F90 b/src/PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR.F90 new file mode 100644 index 000000000..0185fa586 --- /dev/null +++ b/src/PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR.F90 @@ -0,0 +1,118 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR --- Interface to PDAF for En3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + prepoststep_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_pdafomi, & ! Provide product R^-1 A + prodRinvA_l_pdafomi ! Provide product R^-1 A with localization + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAFlocal_assimilate_en3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdafomi, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + prepoststep_pdaf, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR -- END' + +END SUBROUTINE PDAFlocalomi_assimilate_en3dvar_lestkf_nondiagR diff --git a/src/PDAFlocalomi_assimilate_hyb3dvar_lestkf.F90 b/src/PDAFlocalomi_assimilate_hyb3dvar_lestkf.F90 new file mode 100644 index 000000000..64b3305ce --- /dev/null +++ b/src/PDAFlocalomi_assimilate_hyb3dvar_lestkf.F90 @@ -0,0 +1,121 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate_hyb3dvar_lestkf --- Interface to PDAF for Hyb3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate_hyb3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2021-04 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A + PDAFomi_g2l_obs_cb, & ! Restrict full obs. vector to local analysis domain + PDAFomi_prodRinvA_l_cb, & ! Provide product R^-1 A on local analysis domain + PDAFomi_likelihood_l_cb ! Compute likelihood and apply localization + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_hyb3dvar_lestkf -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAFlocal_assimilate_hyb3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_f_cb, & + PDAFomi_prodRinvA_cb, cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + PDAFomi_prodRinvA_l_cb, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdaf, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + prepoststep_pdaf, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFlocalomi_assimilate_3dvar' + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_hyb3dvar_lestkf -- END' + +END SUBROUTINE PDAFlocalomi_assimilate_hyb3dvar_lestkf diff --git a/src/PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR.F90 b/src/PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR.F90 new file mode 100644 index 000000000..0928b74e0 --- /dev/null +++ b/src/PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR.F90 @@ -0,0 +1,122 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR --- Interface to PDAF for Hyb3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + prepoststep_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_pdafomi, & ! Provide product R^-1 A + prodRinvA_l_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAFlocal_assimilate_hyb3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, & + prodRinvA_pdafomi, cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdafomi, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + prepoststep_pdaf, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR -- END' + +END SUBROUTINE PDAFlocalomi_assimilate_hyb3dvar_lestkf_nondiagR diff --git a/src/PDAFlocalomi_assimilate_lknetf_nondiagR.F90 b/src/PDAFlocalomi_assimilate_lknetf_nondiagR.F90 new file mode 100644 index 000000000..a96fd25ee --- /dev/null +++ b/src/PDAFlocalomi_assimilate_lknetf_nondiagR.F90 @@ -0,0 +1,116 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate_lknetf_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate_lknetf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, & + next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdafomi, & ! Provide product R^-1 A on local analysis domain + likelihood_l_pdafomi, & ! Compute likelihood and apply localization + prodRinvA_hyb_l_pdafomi, & ! Product R^-1 A on local analysis domain with hybrid weight + likelihood_hyb_l_pdafomi ! Compute likelihood and apply localization with tempering + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_lknetf_nondiagR -- START' + + IF (TRIM(filterstr) == 'LKNETF') THEN + CALL PDAFlocal_assimilate_lknetf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, & + next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFlocalomi_assimilate_lknetf_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_lknetf_nondiagR -- END' + +END SUBROUTINE PDAFlocalomi_assimilate_lknetf_nondiagR diff --git a/src/PDAFlocalomi_assimilate_lknetf_nondiagR_si.F90 b/src/PDAFlocalomi_assimilate_lknetf_nondiagR_si.F90 new file mode 100644 index 000000000..62451ce87 --- /dev/null +++ b/src/PDAFlocalomi_assimilate_lknetf_nondiagR_si.F90 @@ -0,0 +1,85 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate_lknetf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate_lknetf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + prodRinvA_l_pdafomi, & ! Provide product R^-1 A on local analysis domain + prodRinvA_hyb_l_pdafomi, & ! Provide product R^-1 A on local analysis domain with hybrid weight + likelihood_l_pdafomi, & ! Compute observation likelihood for an ensemble member + likelihood_hyb_l_pdafomi ! Compute observation likelihood for an ensemble member with hybrid weight + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocalomi_assimilate_lknetf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocalomi_assimilate_lknetf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, & + next_observation_pdaf, outflag) + +END SUBROUTINE PDAFlocalomi_assimilate_lknetf_nondiagR_si diff --git a/src/PDAFlocalomi_assimilate_lnetf_nondiagR.F90 b/src/PDAFlocalomi_assimilate_lnetf_nondiagR.F90 new file mode 100644 index 000000000..2d34cb8ec --- /dev/null +++ b/src/PDAFlocalomi_assimilate_lnetf_nondiagR.F90 @@ -0,0 +1,109 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate_lnetf_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate_lnetf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, likelihood_l_pdafomi, & + next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + likelihood_l_pdafomi ! Compute likelihood and apply localization + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_lnetf_nondiagR -- START' + + IF (TRIM(filterstr) == 'LNETF') THEN + CALL PDAFlocal_assimilate_lnetf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, likelihood_l_pdafomi, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + PDAFomi_g2l_obs_cb, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFlocalomi_assimilate_lnetf_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_lnetf_nondiagR -- END' + +END SUBROUTINE PDAFlocalomi_assimilate_lnetf_nondiagR diff --git a/src/PDAFlocalomi_assimilate_lnetf_nondiagR_si.F90 b/src/PDAFlocalomi_assimilate_lnetf_nondiagR_si.F90 new file mode 100644 index 000000000..88f84b9f7 --- /dev/null +++ b/src/PDAFlocalomi_assimilate_lnetf_nondiagR_si.F90 @@ -0,0 +1,82 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate_lnetf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate_lnetf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + likelihood_l_pdafomi ! Compute likelihood and apply localization + + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocalomi_assimilate_lnetf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocalomi_assimilate_lnetf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, likelihood_l_pdafomi, & + next_observation_pdaf, outflag) + +END SUBROUTINE PDAFlocalomi_assimilate_lnetf_nondiagR_si diff --git a/src/PDAFlocalomi_assimilate_nondiagR.F90 b/src/PDAFlocalomi_assimilate_nondiagR.F90 new file mode 100644 index 000000000..dbd917ee8 --- /dev/null +++ b/src/PDAFlocalomi_assimilate_nondiagR.F90 @@ -0,0 +1,130 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, & + next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-07 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdafomi ! Provide product of inverse of R with matrix A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_nondiagR -- START' + + IF (TRIM(filterstr) == 'LSEIK') THEN + CALL PDAFlocal_assimilate_lseik(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, prodRinvA_l_pdafomi, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + next_observation_pdaf, outflag) + ELSE IF (TRIM(filterstr) == 'LETKF') THEN + CALL PDAFlocal_assimilate_letkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, prodRinvA_l_pdafomi, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + next_observation_pdaf, outflag) + ELSE IF (TRIM(filterstr) == 'LESTKF') THEN + CALL PDAFlocal_assimilate_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, prodRinvA_l_pdafomi, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + next_observation_pdaf, outflag) + ELSE IF (TRIM(filterstr) == 'LNETF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFlocalomi_assimilate_lnetf_nondiagR for LNETF' + outflag=200 + ELSE IF (TRIM(filterstr) == 'LKNETF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFlocalomi_assimilate_lknetf_nondiagR for LKNETF' + outflag=200 + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFlocalomi_assimilate_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_assimilate_nondiagR -- END' + +END SUBROUTINE PDAFlocalomi_assimilate_nondiagR diff --git a/src/PDAFlocalomi_assimilate_nondiagR_si.F90 b/src/PDAFlocalomi_assimilate_nondiagR_si.F90 new file mode 100644 index 000000000..51ecceaae --- /dev/null +++ b/src/PDAFlocalomi_assimilate_nondiagR_si.F90 @@ -0,0 +1,81 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-07 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + prodRinvA_l_pdafomi ! Provide product of inverse of R with matrix A + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocalomi_assimilate_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocalomi_assimilate_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, & + next_observation_pdaf, outflag) + +END SUBROUTINE PDAFlocalomi_assimilate_nondiagR_si diff --git a/src/PDAFlocalomi_assimilate_si.F90 b/src/PDAFlocalomi_assimilate_si.F90 new file mode 100644 index 000000000..f98a2e2ee --- /dev/null +++ b/src/PDAFlocalomi_assimilate_si.F90 @@ -0,0 +1,81 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_assimilate_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_assimilate_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2021-10 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + localize_covar_pdafomi ! Apply localization to covariance matrix in LEnKF + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocalomi_assimilate +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocalomi_assimilate(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + next_observation_pdaf, outflag) + +END SUBROUTINE PDAFlocalomi_assimilate_si diff --git a/src/PDAFlocalomi_put_state.F90 b/src/PDAFlocalomi_put_state.F90 new file mode 100644 index 000000000..272e2237a --- /dev/null +++ b/src/PDAFlocalomi_put_state.F90 @@ -0,0 +1,124 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state --- Interface to PDAF for domain-local filters +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state(collect_state_pdaf, init_dim_obs_f_pdaf, obs_op_f_pdaf, & + prepoststep_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2020-11 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb, & ! Restrict full obs. vector to local analysis domain + PDAFomi_prodRinvA_l_cb, & ! Provide product R^-1 A on local analysis domain + PDAFomi_likelihood_l_cb ! Compute likelihood and apply localization + EXTERNAL :: PDAFomi_prodRinvA_hyb_l_cb, & ! Product R^-1 A on local analysis domain with hybrid weight + PDAFomi_likelihood_hyb_l_cb ! Compute likelihood and apply localization with tempering + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (TRIM(filterstr) == 'LSEIK') THEN + CALL PDAFlocal_put_state_lseik(collect_state_pdaf, init_dim_obs_f_pdaf, obs_op_f_pdaf, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + PDAFomi_prodRinvA_l_cb, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, outflag) + ELSE IF (TRIM(filterstr) == 'LETKF') THEN + CALL PDAFlocal_put_state_letkf(collect_state_pdaf, init_dim_obs_f_pdaf, obs_op_f_pdaf, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + PDAFomi_prodRinvA_l_cb, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, outflag) + ELSE IF (TRIM(filterstr) == 'LESTKF') THEN + CALL PDAFlocal_put_state_lestkf(collect_state_pdaf, init_dim_obs_f_pdaf, obs_op_f_pdaf, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + PDAFomi_prodRinvA_l_cb, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, outflag) + ELSE IF (TRIM(filterstr) == 'LNETF') THEN + CALL PDAFlocal_put_state_lnetf(collect_state_pdaf, init_dim_obs_f_pdaf, obs_op_f_pdaf, & + PDAFomi_init_obs_l_cb, prepoststep_pdaf, PDAFomi_likelihood_l_cb, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdaf, & + PDAFomi_g2l_obs_cb, outflag) + ELSE IF (TRIM(filterstr) == 'LKNETF') THEN + CALL PDAFlocal_put_state_lknetf(collect_state_pdaf, init_dim_obs_f_pdaf, obs_op_f_pdaf, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + PDAFomi_prodRinvA_l_cb, PDAFomi_prodRinvA_hyb_l_cb, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, PDAFomi_likelihood_l_cb, PDAFomi_likelihood_hyb_l_cb, outflag) + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + +END SUBROUTINE PDAFlocalomi_put_state diff --git a/src/PDAFlocalomi_put_state_en3dvar_lestkf.F90 b/src/PDAFlocalomi_put_state_en3dvar_lestkf.F90 new file mode 100644 index 000000000..2b7606430 --- /dev/null +++ b/src/PDAFlocalomi_put_state_en3dvar_lestkf.F90 @@ -0,0 +1,109 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state_en3dvar_lestkf --- Interface to PDAF for En3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state_en3dvar_lestkf(collect_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2021-04 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A + PDAFomi_g2l_obs_cb, & ! Restrict full obs. vector to local analysis domain + PDAFomi_prodRinvA_l_cb, & ! Provide product R^-1 A on local analysis domain + PDAFomi_likelihood_l_cb ! Compute likelihood and apply localization + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAFlocal_put_state_en3dvar_lestkf(collect_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_f_cb, PDAFomi_prodRinvA_cb, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + PDAFomi_prodRinvA_l_cb, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdaf, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, prepoststep_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFlocalomi_put_state_3dvar' + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + +END SUBROUTINE PDAFlocalomi_put_state_en3dvar_lestkf diff --git a/src/PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR.F90 b/src/PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR.F90 new file mode 100644 index 000000000..be6babc0b --- /dev/null +++ b/src/PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR.F90 @@ -0,0 +1,115 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR --- Interface to PDAF for En3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + prepoststep_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_pdafomi, & ! Provide product R^-1 A + prodRinvA_l_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAFlocal_put_state_en3dvar_lestkf(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdafomi, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, prepoststep_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR -- END' + +END SUBROUTINE PDAFlocalomi_put_state_en3dvar_lestkf_nondiagR diff --git a/src/PDAFlocalomi_put_state_hyb3dvar_lestkf.F90 b/src/PDAFlocalomi_put_state_hyb3dvar_lestkf.F90 new file mode 100644 index 000000000..5d4db2bc3 --- /dev/null +++ b/src/PDAFlocalomi_put_state_hyb3dvar_lestkf.F90 @@ -0,0 +1,111 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state_hyb3dvar_lestkf --- Interface to PDAF for Hyb3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state_hyb3dvar_lestkf(collect_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdaf, & + prepoststep_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2021-04 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + obs_op_lin_pdaf, & ! Linearized observation operator + obs_op_adj_pdaf ! Adjoint observation operator + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + init_dim_obs_f_pdaf, & ! Initialize dimension of full observation vector + obs_op_f_pdaf, & ! Full observation operator + init_dim_obs_l_pdaf ! Initialize local dimimension of obs. vector + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A + PDAFomi_g2l_obs_cb, & ! Restrict full obs. vector to local analysis domain + PDAFomi_prodRinvA_l_cb, & ! Provide product R^-1 A on local analysis domain + PDAFomi_likelihood_l_cb ! Compute likelihood and apply localization + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAFlocal_put_state_hyb3dvar_lestkf(collect_state_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_f_cb, PDAFomi_prodRinvA_cb, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdaf, obs_op_adj_pdaf, & + init_dim_obs_f_pdaf, obs_op_f_pdaf, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + PDAFomi_prodRinvA_l_cb, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdaf, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, prepoststep_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFlocalomi_put_state_3dvar' + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + +END SUBROUTINE PDAFlocalomi_put_state_hyb3dvar_lestkf diff --git a/src/PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR.F90 b/src/PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR.F90 new file mode 100644 index 000000000..890a8a32c --- /dev/null +++ b/src/PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR.F90 @@ -0,0 +1,119 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR --- Interface to PDAF for Hyb3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + prepoststep_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_pdafomi, & ! Provide product R^-1 A + prodRinvA_l_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAFlocal_put_state_hyb3dvar_lestkf(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdafomi, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, prepoststep_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR -- END' + +END SUBROUTINE PDAFlocalomi_put_state_hyb3dvar_lestkf_nondiagR diff --git a/src/PDAFlocalomi_put_state_lknetf_nondiagR.F90 b/src/PDAFlocalomi_put_state_lknetf_nondiagR.F90 new file mode 100644 index 000000000..9750e98d6 --- /dev/null +++ b/src/PDAFlocalomi_put_state_lknetf_nondiagR.F90 @@ -0,0 +1,113 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state_lknetf_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state_lknetf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, & + outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdafomi, & ! Provide product R^-1 A on local analysis domain + likelihood_l_pdafomi, & ! Compute likelihood and apply localization + prodRinvA_hyb_l_pdafomi, & ! Product R^-1 A on local analysis domain with hybrid weight + likelihood_hyb_l_pdafomi ! Compute likelihood and apply localization with tempering + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_put_state_lknetf_nondiagR -- START' + + IF (TRIM(filterstr) == 'LKNETF') THEN + CALL PDAFlocal_put_state_lknetf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, & + outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFlocalomi_put_state_lknetf_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_put_state_lknetf_nondiagR -- END' + +END SUBROUTINE PDAFlocalomi_put_state_lknetf_nondiagR diff --git a/src/PDAFlocalomi_put_state_lknetf_nondiagR_si.F90 b/src/PDAFlocalomi_put_state_lknetf_nondiagR_si.F90 new file mode 100644 index 000000000..4ba77d36f --- /dev/null +++ b/src/PDAFlocalomi_put_state_lknetf_nondiagR_si.F90 @@ -0,0 +1,83 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state_lknetf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state_lknetf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + prodRinvA_l_pdafomi, & ! Provide product R^-1 A on local analysis domain + prodRinvA_hyb_l_pdafomi, & ! Provide product R^-1 A on local analysis domain with hybrid weight + likelihood_l_pdafomi, & ! Compute observation likelihood for an ensemble member + likelihood_hyb_l_pdafomi ! Compute observation likelihood for an ensemble member with hybrid weight + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocalomi_put_state_lknetf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocalomi_put_state_lknetf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, & + outflag) + +END SUBROUTINE PDAFlocalomi_put_state_lknetf_nondiagR_si diff --git a/src/PDAFlocalomi_put_state_lnetf_nondiagR.F90 b/src/PDAFlocalomi_put_state_lnetf_nondiagR.F90 new file mode 100644 index 000000000..91956b47c --- /dev/null +++ b/src/PDAFlocalomi_put_state_lnetf_nondiagR.F90 @@ -0,0 +1,106 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state_lnetf_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state_lnetf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, likelihood_l_pdafomi, & + outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + likelihood_l_pdafomi ! Compute likelihood and apply localization + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_put_state_lnetf_nondiagR -- START' + + IF (TRIM(filterstr) == 'LNETF') THEN + CALL PDAFlocal_put_state_lnetf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_l_cb, prepoststep_pdaf, likelihood_l_pdafomi, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + PDAFomi_g2l_obs_cb, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFlocalomi_put_state_lnetf_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_put_state_lnetf_nondiagR -- END' + +END SUBROUTINE PDAFlocalomi_put_state_lnetf_nondiagR diff --git a/src/PDAFlocalomi_put_state_lnetf_nondiagR_si.F90 b/src/PDAFlocalomi_put_state_lnetf_nondiagR_si.F90 new file mode 100644 index 000000000..dd2ad67a9 --- /dev/null +++ b/src/PDAFlocalomi_put_state_lnetf_nondiagR_si.F90 @@ -0,0 +1,80 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state_lnetf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state_lnetf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + likelihood_l_pdafomi ! Compute likelihood and apply localization + + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocalomi_put_state_lnetf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocalomi_put_state_lnetf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, likelihood_l_pdafomi, & + outflag) + +END SUBROUTINE PDAFlocalomi_put_state_lnetf_nondiagR_si diff --git a/src/PDAFlocalomi_put_state_nondiagR.F90 b/src/PDAFlocalomi_put_state_nondiagR.F90 new file mode 100644 index 000000000..5e1d2c2af --- /dev/null +++ b/src/PDAFlocalomi_put_state_nondiagR.F90 @@ -0,0 +1,125 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, & + outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-07 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdafomi ! Provide product of inverse of R with matrix A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_put_state_nondiagR -- START' + + IF (TRIM(filterstr) == 'LSEIK') THEN + CALL PDAFlocal_put_state_lseik(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, outflag) + ELSE IF (TRIM(filterstr) == 'LETKF') THEN + CALL PDAFlocal_put_state_letkf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, outflag) + ELSE IF (TRIM(filterstr) == 'LESTKF') THEN + CALL PDAFlocal_put_state_lestkf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, outflag) + ELSE IF (TRIM(filterstr) == 'LNETF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFlocalomi_put_state_lnetf_nondiagR for LNETF' + outflag=200 + ELSE IF (TRIM(filterstr) == 'LKNETF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFlocalomi_put_state_lknetf_nondiagR for LKNETF' + outflag=200 + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFlocalomi_put_state_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFlocalomi_put_state_nondiagR -- END' + +END SUBROUTINE PDAFlocalomi_put_state_nondiagR diff --git a/src/PDAFlocalomi_put_state_nondiagR_si.F90 b/src/PDAFlocalomi_put_state_nondiagR_si.F90 new file mode 100644 index 000000000..fb21b3622 --- /dev/null +++ b/src/PDAFlocalomi_put_state_nondiagR_si.F90 @@ -0,0 +1,79 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-07 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Init state dimension for local ana. domain + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + prodRinvA_l_pdafomi ! Provide product of inverse of R with matrix A + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocalomi_put_state_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocalomi_put_state_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, & + outflag) + +END SUBROUTINE PDAFlocalomi_put_state_nondiagR_si diff --git a/src/PDAFlocalomi_put_state_si.F90 b/src/PDAFlocalomi_put_state_si.F90 new file mode 100644 index 000000000..f3ad304c5 --- /dev/null +++ b/src/PDAFlocalomi_put_state_si.F90 @@ -0,0 +1,79 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFlocalomi_put_state_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFlocalomi_put_state_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model after the +! forecast of each ensemble state to transfer data +! from the model to PDAF. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2021-10 - Lars Nerger - Initial code +! 2024-08 - Yumeng Chen - Initial code based on non-PDAFlocal routine +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + ! Localization of state vector + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf ! Initialize state dimension for local analysis domain + ! Interface to PDAF-OMI for local and global filters + EXTERNAL :: & + init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + localize_covar_pdafomi ! Apply localization to covariance matrix in LEnKF + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFlocalomi_put_state +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFlocalomi_put_state(collect_state_pdaf, init_dim_obs_pdafomi, & + obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdafomi, outflag) + +END SUBROUTINE PDAFlocalomi_put_state_si diff --git a/src/PDAFomi.F90 b/src/PDAFomi.F90 index 3525001df..f1c92bebf 100644 --- a/src/PDAFomi.F90 +++ b/src/PDAFomi.F90 @@ -31,6 +31,7 @@ MODULE PDAFomi USE PDAFomi_obs_f USE PDAFomi_obs_l + USE PDAFomi_dim_obs_l USE PDAFomi_obs_op END MODULE PDAFomi diff --git a/src/PDAFomi_assimilate_3dvar_nondiagR.F90 b/src/PDAFomi_assimilate_3dvar_nondiagR.F90 new file mode 100644 index 000000000..b8694d0b4 --- /dev/null +++ b/src/PDAFomi_assimilate_3dvar_nondiagR.F90 @@ -0,0 +1,103 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_3dvar_nondiagR --- Interface to PDAF for 3D-Var +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_3dvar_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prepoststep_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + obs_op_pdafomi, & ! Observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + prodRinvA_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb ! Initialize observation vector + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_3dvar_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAF_assimilate_3dvar(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prepoststep_pdaf, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFomi_assimilate_3dvar_nondiagR' + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_3dvar_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_3dvar_nondiagR diff --git a/src/PDAFomi_assimilate_en3dvar_estkf.F90 b/src/PDAFomi_assimilate_en3dvar_estkf.F90 index cf0e33700..7fae8e256 100644 --- a/src/PDAFomi_assimilate_en3dvar_estkf.F90 +++ b/src/PDAFomi_assimilate_en3dvar_estkf.F90 @@ -60,18 +60,15 @@ SUBROUTINE PDAFomi_assimilate_en3dvar_estkf(collect_state_pdaf, distribute_state distribute_state_pdaf, & ! Routine to distribute a state vector next_observation_pdaf, & ! Provide time step, time and dimension of next observation prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf ! Apply adjoint control vector transform matrix EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector obs_op_pdaf, & ! Observation operator - cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector - cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix obs_op_lin_pdaf, & ! Linearized observation operator obs_op_adj_pdaf ! Adjoint observation operator EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance - PDAFomi_init_obscovar_cb, & ! Initialize mean observation error variance - PDAFomi_add_obs_error_cb, & ! Add observation error covariance matrix - PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A - PDAFomi_likelihood_cb ! Compute likelihood + PDAFomi_prodRinvA_cb ! Provide product R^-1 A ! !CALLING SEQUENCE: ! Called by: model code diff --git a/src/PDAFomi_assimilate_en3dvar_estkf_nondiagR.F90 b/src/PDAFomi_assimilate_en3dvar_estkf_nondiagR.F90 new file mode 100644 index 000000000..7fac7af03 --- /dev/null +++ b/src/PDAFomi_assimilate_en3dvar_estkf_nondiagR.F90 @@ -0,0 +1,105 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_en3dvar_estkf_nondiagR --- Interface to PDAF for En3D-Var/ESTKF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_en3dvar_estkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prepoststep_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + prodRinvA_pdafomi, & ! Provide product R^-1 A + obs_op_pdafomi, & ! Observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi ! Adjoint observation operator + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obsvar_cb ! Initialize mean observation error variance + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_en3dvar_estkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAF_assimilate_en3dvar_estkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + PDAFomi_init_obsvar_cb, prepoststep_pdaf, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFomi_assimilate_en3dvar_estkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_en3dvar_estkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_en3dvar_estkf_nondiagR diff --git a/src/PDAFomi_assimilate_en3dvar_lestkf_nondiagR.F90 b/src/PDAFomi_assimilate_en3dvar_lestkf_nondiagR.F90 new file mode 100644 index 000000000..b3d181ada --- /dev/null +++ b/src/PDAFomi_assimilate_en3dvar_lestkf_nondiagR.F90 @@ -0,0 +1,119 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_en3dvar_lestkf_nondiagR --- Interface to PDAF for En3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_en3dvar_lestkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_pdafomi, & ! Provide product R^-1 A + prodRinvA_l_pdafomi ! Provide product R^-1 A with localization + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_en3dvar_lestkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAF_assimilate_en3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + prepoststep_pdaf, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFomi_assimilate_en3dvar_lestkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_en3dvar_lestkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_en3dvar_lestkf_nondiagR diff --git a/src/PDAFomi_assimilate_enkf_nondiagR.F90 b/src/PDAFomi_assimilate_enkf_nondiagR.F90 new file mode 100644 index 000000000..b86b2d9e7 --- /dev/null +++ b/src/PDAFomi_assimilate_enkf_nondiagR.F90 @@ -0,0 +1,101 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_enkf_nondiagR --- Interface to PDAF for global filters +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_enkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, add_obs_error_pdafomi, init_obscovar_pdafomi, & + prepoststep_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + obs_op_pdafomi, & ! Observation operator + init_obscovar_pdafomi, & ! Initialize mean observation error variance + add_obs_error_pdafomi ! Add observation error covariance matrix + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A + PDAFomi_likelihood_cb ! Compute likelihood + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_enkf_nondiagR -- START' + + IF (TRIM(filterstr) == 'ENKF') THEN + CALL PDAF_assimilate_enkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prepoststep_pdaf, & + add_obs_error_pdafomi, init_obscovar_pdafomi, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_assimilate_enkf_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_enkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_enkf_nondiagR diff --git a/src/PDAFomi_assimilate_enkf_nondiagR_si.F90 b/src/PDAFomi_assimilate_enkf_nondiagR_si.F90 new file mode 100644 index 000000000..413496d8b --- /dev/null +++ b/src/PDAFomi_assimilate_enkf_nondiagR_si.F90 @@ -0,0 +1,77 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_enkf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_enkf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + ! Interface to PDAF-OMI for local and global filters + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_obscovar_pdafomi, & ! Initialize mean observation error variance + add_obs_error_pdafomi ! Add observation error covariance matrix + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_assimilate_enkf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_assimilate_enkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, add_obs_error_pdafomi, init_obscovar_pdafomi, & + prepoststep_pdaf, next_observation_pdaf, outflag) + +END SUBROUTINE PDAFomi_assimilate_enkf_nondiagR_si diff --git a/src/PDAFomi_assimilate_global_nondiagR.F90 b/src/PDAFomi_assimilate_global_nondiagR.F90 new file mode 100644 index 000000000..7c6ecb81b --- /dev/null +++ b/src/PDAFomi_assimilate_global_nondiagR.F90 @@ -0,0 +1,118 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_global_nondiagR --- Interface to PDAF for global filters +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_global_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, prodRinvA_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf ! Observation operator + EXTERNAL :: prodRinvA_pdaf ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obscovar_cb, & ! Initialize mean observation error variance + PDAFomi_add_obs_error_cb ! Add observation error covariance matrix + + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_global_nondiagR -- START' + + IF (TRIM(filterstr) == 'SEIK') THEN + CALL PDAF_assimilate_seik(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, PDAFomi_init_obs_f_cb, prepoststep_pdaf, & + prodRinvA_pdaf, PDAFomi_init_obsvar_cb, next_observation_pdaf, outflag) + ELSEIF (TRIM(filterstr) == 'ENKF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFomi_assimilate_enkf_nondiagR for EnKF' + outflag=200 + ELSEIF (TRIM(filterstr) == 'ETKF') THEN + CALL PDAF_assimilate_etkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, PDAFomi_init_obs_f_cb, prepoststep_pdaf, & + prodRinvA_pdaf, PDAFomi_init_obsvar_cb, next_observation_pdaf, outflag) + ELSEIF (TRIM(filterstr) == 'ESTKF') THEN + CALL PDAF_assimilate_estkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, PDAFomi_init_obs_f_cb, prepoststep_pdaf, & + prodRinvA_pdaf, PDAFomi_init_obsvar_cb, next_observation_pdaf, outflag) + ELSEIF (TRIM(filterstr) == 'NETF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFomi_assimilate_nonlin_nondiagR for NETF and PF' + outflag=200 + ELSEIF (TRIM(filterstr) == 'PF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFomi_assimilate_nonlin_nondiagR for NETF and PF' + outflag=200 + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_assimilate_global_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_global_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_global_nondiagR diff --git a/src/PDAFomi_assimilate_global_nondiagR_si.F90 b/src/PDAFomi_assimilate_global_nondiagR_si.F90 new file mode 100644 index 000000000..3117a2c9d --- /dev/null +++ b/src/PDAFomi_assimilate_global_nondiagR_si.F90 @@ -0,0 +1,76 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_global_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_global_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + ! Interface to PDAF-OMI for local and global filters + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + prodRinvA_pdafomi ! Provide product R^-1 A + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_assimilate_global_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_assimilate_global_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, prepoststep_pdaf, & + next_observation_pdaf, outflag) + +END SUBROUTINE PDAFomi_assimilate_global_nondiagR_si diff --git a/src/PDAFomi_assimilate_hyb3dvar_estkf_nondiagR.F90 b/src/PDAFomi_assimilate_hyb3dvar_estkf_nondiagR.F90 new file mode 100644 index 000000000..6d8675795 --- /dev/null +++ b/src/PDAFomi_assimilate_hyb3dvar_estkf_nondiagR.F90 @@ -0,0 +1,109 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_hyb3dvar_estkf_nondiagR --- Interface to PDAF for Hyb3D-Var/ESTKF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_hyb3dvar_estkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prepoststep_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + cvt_ens_pdaf, & ! Apply ensemble control vector transform matrix to control vector + cvt_adj_ens_pdaf ! Apply adjoint ensemble control vector transform matrix + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + obs_op_pdafomi, & ! Observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + prodRinvA_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obsvar_cb ! Initialize mean observation error variance + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_hyb3dvar_estkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAF_assimilate_hyb3dvar_estkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + PDAFomi_init_obsvar_cb, prepoststep_pdaf, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFomi_assimilate_hyb3dvar_estkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_hyb3dvar_estkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_hyb3dvar_estkf_nondiagR diff --git a/src/PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR.F90 b/src/PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR.F90 new file mode 100644 index 000000000..11bc0e09d --- /dev/null +++ b/src/PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR.F90 @@ -0,0 +1,123 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR --- Interface to PDAF for Hyb3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_pdafomi, & ! Provide product R^-1 A + prodRinvA_l_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAF_assimilate_hyb3dvar_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, & + prodRinvA_pdafomi, cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + prepoststep_pdaf, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_hyb3dvar_lestkf_nondiagR diff --git a/src/PDAFomi_assimilate_lenkf_nondiagR.F90 b/src/PDAFomi_assimilate_lenkf_nondiagR.F90 new file mode 100644 index 000000000..a832a8b40 --- /dev/null +++ b/src/PDAFomi_assimilate_lenkf_nondiagR.F90 @@ -0,0 +1,97 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_lenkf_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_lenkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, localize_covar_pdafomi, & + add_obs_error_pdafomi, init_obscovar_pdafomi, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for LENKF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + obs_op_pdafomi, & ! Observation operator + localize_covar_pdafomi, & ! Apply localization to HP and HPH^T + init_obscovar_pdafomi, & ! Initialize mean observation error variance + add_obs_error_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb ! Initialize observation vector + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAF_assimilate_lenkf +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_lenkf_nondiagR -- START' + + CALL PDAF_assimilate_lenkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prepoststep_pdaf, & + localize_covar_pdafomi, add_obs_error_pdafomi, init_obscovar_pdafomi, & + next_observation_pdaf, outflag) + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_lenkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_lenkf_nondiagR diff --git a/src/PDAFomi_assimilate_lenkf_nondiagR_si.F90 b/src/PDAFomi_assimilate_lenkf_nondiagR_si.F90 new file mode 100644 index 000000000..dd3904a2d --- /dev/null +++ b/src/PDAFomi_assimilate_lenkf_nondiagR_si.F90 @@ -0,0 +1,78 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_lenkf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_lenkf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + ! Interface to PDAF-OMI for local and global filters + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + localize_covar_pdafomi, & ! Apply localization to HP and HPH^T + init_obscovar_pdafomi, & ! Initialize mean observation error variance + add_obs_error_pdafomi ! Provide product R^-1 A + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_assimilate_lenkf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_assimilate_lenkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, localize_covar_pdafomi, & + add_obs_error_pdafomi, init_obscovar_pdafomi, next_observation_pdaf, outflag) + +END SUBROUTINE PDAFomi_assimilate_lenkf_nondiagR_si diff --git a/src/PDAFomi_assimilate_lknetf_nondiagR.F90 b/src/PDAFomi_assimilate_lknetf_nondiagR.F90 new file mode 100644 index 000000000..67a1600c4 --- /dev/null +++ b/src/PDAFomi_assimilate_lknetf_nondiagR.F90 @@ -0,0 +1,117 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_lknetf_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_lknetf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdafomi, & ! Provide product R^-1 A on local analysis domain + likelihood_l_pdafomi, & ! Compute likelihood and apply localization + prodRinvA_hyb_l_pdafomi, & ! Product R^-1 A on local analysis domain with hybrid weight + likelihood_hyb_l_pdafomi ! Compute likelihood and apply localization with tempering + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_lknetf_nondiagR -- START' + + IF (TRIM(filterstr) == 'LKNETF') THEN + CALL PDAF_assimilate_lknetf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, & + next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_assimilate_lknetf_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_lknetf_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_lknetf_nondiagR diff --git a/src/PDAFomi_assimilate_lknetf_nondiagR_si.F90 b/src/PDAFomi_assimilate_lknetf_nondiagR_si.F90 new file mode 100644 index 000000000..0c257e900 --- /dev/null +++ b/src/PDAFomi_assimilate_lknetf_nondiagR_si.F90 @@ -0,0 +1,86 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_lknetf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_lknetf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + prodRinvA_l_pdafomi, & ! Provide product R^-1 A on local analysis domain + prodRinvA_hyb_l_pdafomi, & ! Provide product R^-1 A on local analysis domain with hybrid weight + likelihood_l_pdafomi, & ! Compute observation likelihood for an ensemble member + likelihood_hyb_l_pdafomi ! Compute observation likelihood for an ensemble member with hybrid weight + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_assimilate_lknetf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_assimilate_lknetf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + next_observation_pdaf, outflag) + +END SUBROUTINE PDAFomi_assimilate_lknetf_nondiagR_si diff --git a/src/PDAFomi_assimilate_lnetf_nondiagR.F90 b/src/PDAFomi_assimilate_lnetf_nondiagR.F90 new file mode 100644 index 000000000..aef0873ee --- /dev/null +++ b/src/PDAFomi_assimilate_lnetf_nondiagR.F90 @@ -0,0 +1,110 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_lnetf_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_lnetf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, likelihood_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + likelihood_l_pdafomi ! Compute likelihood and apply localization + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_lnetf_nondiagR -- START' + + IF (TRIM(filterstr) == 'LNETF') THEN + CALL PDAF_assimilate_lnetf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, likelihood_l_pdafomi, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + PDAFomi_g2l_obs_cb, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_assimilate_lnetf_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_lnetf_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_lnetf_nondiagR diff --git a/src/PDAFomi_assimilate_lnetf_nondiagR_si.F90 b/src/PDAFomi_assimilate_lnetf_nondiagR_si.F90 new file mode 100644 index 000000000..da7542d82 --- /dev/null +++ b/src/PDAFomi_assimilate_lnetf_nondiagR_si.F90 @@ -0,0 +1,83 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_lnetf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_lnetf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + likelihood_l_pdafomi ! Compute likelihood and apply localization + + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_assimilate_lnetf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_assimilate_lnetf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, likelihood_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + next_observation_pdaf, outflag) + +END SUBROUTINE PDAFomi_assimilate_lnetf_nondiagR_si diff --git a/src/PDAFomi_assimilate_local_nondiagR.F90 b/src/PDAFomi_assimilate_local_nondiagR.F90 new file mode 100644 index 000000000..8991272f3 --- /dev/null +++ b/src/PDAFomi_assimilate_local_nondiagR.F90 @@ -0,0 +1,131 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_local_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_local_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-07 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdafomi ! Provide product of inverse of R with matrix A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_local_nondiagR -- START' + + IF (TRIM(filterstr) == 'LSEIK') THEN + CALL PDAF_assimilate_lseik(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, prodRinvA_l_pdafomi, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + next_observation_pdaf, outflag) + ELSE IF (TRIM(filterstr) == 'LETKF') THEN + CALL PDAF_assimilate_letkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, prodRinvA_l_pdafomi, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + next_observation_pdaf, outflag) + ELSE IF (TRIM(filterstr) == 'LESTKF') THEN + CALL PDAF_assimilate_lestkf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prepoststep_pdaf, prodRinvA_l_pdafomi, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, & + next_observation_pdaf, outflag) + ELSE IF (TRIM(filterstr) == 'LNETF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFomi_assimilate_lnetf_nondiagR for LNETF' + outflag=200 + ELSE IF (TRIM(filterstr) == 'LKNETF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFomi_assimilate_lknetf_nondiagR for LKNETF' + outflag=200 + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_assimilate_local_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_local_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_local_nondiagR diff --git a/src/PDAFomi_assimilate_local_nondiagR_si.F90 b/src/PDAFomi_assimilate_local_nondiagR_si.F90 new file mode 100644 index 000000000..41ba74d09 --- /dev/null +++ b/src/PDAFomi_assimilate_local_nondiagR_si.F90 @@ -0,0 +1,82 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_local_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_local_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-07 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + prodRinvA_l_pdafomi ! Provide product of inverse of R with matrix A + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_assimilate_local_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_assimilate_local_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, next_observation_pdaf, outflag) + +END SUBROUTINE PDAFomi_assimilate_local_nondiagR_si diff --git a/src/PDAFomi_assimilate_nonlin_nondiagR.F90 b/src/PDAFomi_assimilate_nonlin_nondiagR.F90 new file mode 100644 index 000000000..08e968a68 --- /dev/null +++ b/src/PDAFomi_assimilate_nonlin_nondiagR.F90 @@ -0,0 +1,105 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_nonlin_nondiagR --- Interface to PDAF for global filters +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_nonlin_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, likelihood_pdafomi, prepoststep_pdaf, & + next_observation_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + obs_op_pdafomi, & ! Observation operator + likelihood_pdafomi ! Compute likelihood + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obscovar_cb, & ! Initialize mean observation error variance + PDAFomi_add_obs_error_cb ! Add observation error covariance matrix + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_nonlin_nondiagR -- START' + + IF (TRIM(filterstr) == 'NETF') THEN + CALL PDAF_assimilate_netf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prepoststep_pdaf, & + likelihood_pdafomi, next_observation_pdaf, outflag) + ELSEIF (TRIM(filterstr) == 'PF') THEN + CALL PDAF_assimilate_pf(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prepoststep_pdaf, & + likelihood_pdafomi, next_observation_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_assimilate_nonlin_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_assimilate_nonlin_nondiagR -- END' + +END SUBROUTINE PDAFomi_assimilate_nonlin_nondiagR diff --git a/src/PDAFomi_assimilate_nonlin_nondiagR_si.F90 b/src/PDAFomi_assimilate_nonlin_nondiagR_si.F90 new file mode 100644 index 000000000..b52707301 --- /dev/null +++ b/src/PDAFomi_assimilate_nonlin_nondiagR_si.F90 @@ -0,0 +1,76 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_assimilate_nonlin_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_assimilate_nonlin_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + distribute_state_pdaf, & ! Routine to distribute a state vector + next_observation_pdaf, & ! Provide time step, time and dimension of next observation + prepoststep_pdaf ! User supplied pre/poststep routine + ! Interface to PDAF-OMI for local and global filters + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + likelihood_pdafomi ! Compute likelihood + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_assimilate_nonlin_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_assimilate_nonlin_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, likelihood_pdafomi, prepoststep_pdaf, & + next_observation_pdaf, outflag) + +END SUBROUTINE PDAFomi_assimilate_nonlin_nondiagR_si diff --git a/src/PDAFomi_dim_obs_l.F90 b/src/PDAFomi_dim_obs_l.F90 new file mode 100644 index 000000000..0d8ad25d7 --- /dev/null +++ b/src/PDAFomi_dim_obs_l.F90 @@ -0,0 +1,1733 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id: PDAFomi_obs_l.F90 1147 2023-03-12 16:14:34Z lnerger $ + +!> PDAF-OMI routines for determining local observations +!! +!! This module contains generic routines for several observation-related +!! operations for local filters. The routines are +!! +!! * PDAFomi_init_dim_obs_l \n +!! Initialize dimension of local obs. vetor and arrays for +!! local observations +!! * PDAFomi_init_dim_obs_l_iso \n +!! Initialize dimension of local obs. vetor and arrays for +!! local observations for isotropic localization +!! * PDAFomi_init_dim_obs_l_noniso \n +!! Initialize dimension of local obs. vetor and arrays for +!! local observations for nonisotropic localization +!! * PDAFomi_init_dim_obs_l_noniso_locweights \n +!! Initialize dimension of local obs. vetor and arrays for +!! local observations for nonisotropic localization +!! and different locweight for horizontal and vertical +!! * PDAFomi_check_dist2_loop \n +!! Compute and check distance for isotropic localization +!! * PDAFomi_check_dist2_noniso_loop \n +!! Compute and check distance for non-isotropic localization +!! * PDAFomi_set_localization \n +!! Store localization parameters in OMI (for isotropic localization) +!! * PDAFomi_set_localization_noniso \n +!! Store localization parameters in OMI (for non-isotropic localization) +!! * PDAFomi_set_dim_obs_l \n +!! Register local observation with OMI +!! * PDAFomi_store_obs_l_index \n +!! Store index, distance, cradius, and sradius of a local observation +!! * PDAFomi_store_obs_l_index_vdist \n +!! Store index, distance, cradius, sradius, and vertical distance of +!! a local observation for 2+1D factorized localization +!! +!! __Revision history:__ +!! * 2019-06 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! +MODULE PDAFomi_dim_obs_l + + USE PDAFomi_obs_f, ONLY: obs_f, r_earth, pi, debug, n_obstypes, error + USE PDAFomi_obs_l, ONLY: obs_l, obs_l_all, firstobs, offset_obs_l + USE PDAF_mod_filtermpi, ONLY: mype, npes_filter + + IMPLICIT NONE + SAVE + + INTERFACE PDAFomi_init_dim_obs_l + MODULE PROCEDURE PDAFomi_init_dim_obs_l_iso + MODULE PROCEDURE PDAFomi_init_dim_obs_l_noniso + MODULE PROCEDURE PDAFomi_init_dim_obs_l_noniso_locweights + END INTERFACE + +CONTAINS + +!------------------------------------------------------------------------------- +!> Set dimension of local obs. vector and local obs. arrays +!! +!! This routine sets the number of local observations for the +!! current observation type for the local analysis domain +!! with coordinates COORD_l and localization cut-off radius CRADIUS. +!! Further the routine initializes arrays for the index of a +!! local observation in the full observation vector and its +!! corresponding distance. +!! The operations are performed by calling the routine +!! PDAFomi_check_dist2_loop once for counting and a second time +!! for initializing the arrays. +!! +!! __Revision history:__ +!! * 2019-06 - Lars Nerger - Initial code from restructuring observation routines +!! * Later revisions - see repository log +!! + SUBROUTINE PDAFomi_init_dim_obs_l_iso(thisobs_l, thisobs, coords_l, locweight, cradius, & + sradius, cnt_obs_l_all) + + IMPLICIT NONE + +! *** Arguments *** + TYPE(obs_f), INTENT(inout) :: thisobs !< Data type with full observation + TYPE(obs_l), TARGET, INTENT(inout) :: thisobs_l !< Data type with local observation + REAL, INTENT(in) :: coords_l(:) !< Coordinates of current analysis domain + INTEGER, INTENT(in) :: locweight !< Type of localization function + REAL, INTENT(in) :: cradius !< Localization cut-off radius + REAL, INTENT(in) :: sradius !< Support radius of localization function + INTEGER, INTENT(inout) :: cnt_obs_l_all !< Local dimension of current observation vector + +! *** Local variables *** + REAL :: maxcoords_l, mincoords_l ! Min/Max domain coordinates to check geographic coords + REAL :: maxocoords_l, minocoords_l ! Min/Max observation coordinates to check geographic coords + INTEGER :: cnt_obs ! Counter for valid local observations + + + doassim: IF (thisobs%doassim == 1) THEN + +! *********************************************** +! *** Check offset in full observation vector *** +! *********************************************** + + IF (debug>0) & + WRITE (*,*) '++ OMI-debug: ', debug, 'PDAFomi_init_dim_obs_l -- START' + + IF (thisobs%ncoord/=3 .AND. thisobs%disttype>=10) THEN + WRITE (*,*) '+++++ ERROR PDAF-OMI: factorized 2+1D localization can only be used for thisobs%ncoord=3' + error = 14 + END IF + + +! ************************************** +! *** Store localization information *** +! ************************************** + + thisobs_l%locweight = locweight + + ! Allocate vectors for localization radii and store their values + ! For isotropic localization the size of the arrays is just 1 + IF (ALLOCATED(thisobs_l%cradius)) DEALLOCATE(thisobs_l%cradius) + ALLOCATE(thisobs_l%cradius(1)) + IF (ALLOCATED(thisobs_l%sradius)) DEALLOCATE(thisobs_l%sradius) + ALLOCATE(thisobs_l%sradius(1)) + + thisobs_l%nradii = 1 + thisobs_l%cradius(1) = cradius + thisobs_l%sradius(1) = sradius + + +! ************************************** +! *** Count valid local observations *** +! ************************************** + + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug: ', debug, & + ' PDAFomi_init_dim_obs_l -- count local observations' + IF (thisobs%obsid == firstobs) THEN + WRITE (*,*) '++ OMI-debug init_dim_obs_l:', debug, ' Re-init dim_obs_l=0' + END IF + WRITE (*,*) '++ OMI-debug init_dim_obs_l:', debug, ' coords_l', coords_l + + ! For geographic coordinates check whether their range is reasonable + IF (thisobs%disttype==2 .OR. thisobs%disttype==3 .OR. thisobs%disttype==12 .OR. thisobs%disttype==13) THEN + maxcoords_l = MAXVAL(coords_l) + mincoords_l = MINVAL(coords_l) + maxocoords_l = MAXVAL(thisobs%ocoord_f(1:2, :)) + minocoords_l = MINVAL(thisobs%ocoord_f(1:2, :)) + + IF (maxcoords_l>2.0*pi .OR. mincoords_l<-pi .OR. maxocoords_l>2.0*pi .OR. minocoords_l<-pi) THEN + WRITE (*,*) '++ OMI-debug init_dim_obs_l:', debug, & + ' WARNING: The unit for geographic coordinates is radian, thus range (0,2*pi) or (-pi,pi)!' + END IF + END IF + WRITE (*,*) '++ OMI-debug init_dim_obs_l:', debug, & + ' Note: Please ensure that coords_l and observation coordinates have the same unit' + + WRITE (*,*) '++ OMI-debug init_dim_obs_l: ', debug, ' thisobs%ncoord', thisobs%ncoord + WRITE (*,*) '++ OMI-debug init_dim_obs_l: ', debug, ' thisobs_l%cradius', thisobs_l%cradius + WRITE (*,*) '++ OMI-debug init_dim_obs_l: ', debug, ' Check for observations within radius' + END IF + + cnt_obs = 0 + CALL PDAFomi_check_dist2_loop(thisobs_l, thisobs, coords_l, cnt_obs, 1) + + +! ************************************************ +! *** Initialize local observation for PDAFomi *** +! ************************************************ + + CALL PDAFomi_set_dim_obs_l(thisobs_l, thisobs, cnt_obs_l_all, cnt_obs) + + +! ************************************************************ +! *** Initialize internal local arrays for local distances *** +! *** and indices of local obs. in full obs. vector *** +! ************************************************************ + + IF (debug>0) & + WRITE (*,*) '++ OMI-debug: ', debug, & + ' PDAFomi_init_dim_obs_l -- initialize local observation arrays' + + ! Count local observations and initialize index and distance arrays + IF (thisobs_l%dim_obs_l>0) THEN + cnt_obs = 0 + CALL PDAFomi_check_dist2_loop(thisobs_l, thisobs, coords_l, cnt_obs, 2) + END IF + + ! Print debug information + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug init_dim_obs_l:', debug, ' thisobs_l%dim_obs_l', thisobs_l%dim_obs_l + IF (thisobs_l%dim_obs_l>0) THEN + WRITE (*,*) '++ OMI-debug init_dim_obs_l:', debug, ' thisobs_l%id_obs_l', thisobs_l%id_obs_l + WRITE (*,*) '++ OMI-debug init_dim_obs_l:', debug, ' thisobs_l%distance_l', thisobs_l%distance_l + END IF + WRITE (*,*) '++ OMI-debug: ', debug, 'PDAFomi_init_dim_obs_l -- END' + END IF + + END IF doassim + + END SUBROUTINE PDAFomi_init_dim_obs_l_iso + + +!------------------------------------------------------------------------------- +!> Check distance in case of isotropic localization +!! +!! This routine computes the distance between the location of +!! a local analysis domains and all full observations and checks +!! whether the observations lies within the localization radius. +!! The computation can be for Cartesian grids with and without +!! periodicity and for geographic coordinates. For Cartesian +!! grids, the coordinates can be in any unit, while geographic +!! coordinates must be provided in radians and the resulting +!! distance will be in meters. Finally, the routine checks +!! whether the distance is not larger than the cut-off radius. +!! +!! Choices for distance computation - disttype: +!! 0: Cartesian distance in ncoord dimensions +!! 1: Cartesian distance in ncoord dimensions with periodicity +!! (Needs specification of domsize(ncoord)) +!! 2: Aproximate geographic distance with horizontal coordinates in radians (-pi/+pi) +!! 3: Geographic distance computation using haversine formula +!! 10-13: Variants of distance types 0-3, but particularly for 3 dimensions in which +!! a 2+1 dimensional localization is applied (distance weighting only in the horizontal) +!! +!! __Revision history:__ +!! * 2024-04 - Lars Nerger - Initial code based on PDAFomi_comp_dist2 +!! * Later revisions - see repository log +!! + SUBROUTINE PDAFomi_check_dist2_loop(thisobs_l, thisobs, coordsA, cnt_obs, mode) + + IMPLICIT NONE + +! *** Arguments *** + TYPE(obs_l), INTENT(inout) :: thisobs_l !< Data type with local observation + TYPE(obs_f), INTENT(in) :: thisobs !< Data type with full observation + REAL, INTENT(in) :: coordsA(:) !< Coordinates of current analysis domain (ncoord) + INTEGER, INTENT(inout) :: cnt_obs !< Count number of local observations + INTEGER, INTENT(in) :: mode !< 1: count local observations + !< 2: initialize local arrays + +! *** Local variables *** + INTEGER :: i, k ! Counters + INTEGER :: verbose ! verbosity flag + INTEGER :: domsize ! Flag whether domainsize is set + LOGICAL :: distflag ! Flag whether distance in a coordinate direction is within cradius + REAL :: slon, slat ! sine of distance in longitude or latitude + REAL :: distance2 ! square distance + REAL :: cradius2 ! squared localization cut-off radius + REAL :: dists(thisobs%ncoord) ! Distance vector between analysis point and observation + REAL :: coordsB(thisobs%ncoord) ! Array for coordinates of a single observation + + +! ********************** +! *** Initialization *** +! ********************** + + scancount: DO i = 1, thisobs%dim_obs_f + + ! Initialize distance flag + distflag = .TRUE. + + verbose = i + + coordsB = thisobs%ocoord_f(1:thisobs%ncoord, i) + + +! ************************ +! *** Compute distance *** +! ************************ + + IF (.NOT.ALLOCATED(thisobs%domainsize)) THEN + domsize = 0 + ELSE + domsize = 1 + END IF + + norm: IF ((thisobs%disttype==0 .OR. thisobs%disttype==10) .OR. & + ((thisobs%disttype==1 .OR. thisobs%disttype==11) .AND. domsize==0)) THEN + + ! *** Compute Cartesian distance *** + + IF (debug>0 .AND. verbose==0) THEN + WRITE (*,*) '++ OMI-debug check_dist2: ', debug, ' compute Cartesian distance' + END IF + + IF (thisobs%ncoord>=3) THEN + dists(3) = ABS(coordsA(3) - coordsB(3)) + IF (dists(3)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + dists(2) = ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + dists(1) = ABS(coordsA(1) - coordsB(1)) + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + IF (thisobs%disttype<10) THEN + ! full 3D localization + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + ELSE + ! factorized 2+1D localization + DO k = 1, thisobs%ncoord-1 + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + END IF + ELSEIF (thisobs%ncoord==2) THEN + dists(2) = ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + dists(1) = ABS(coordsA(1) - coordsB(1)) + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + ELSEIF (thisobs%ncoord==1) THEN + dists(1) = ABS(coordsA(1) - coordsB(1)) + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + + ELSEIF ((thisobs%disttype==1 .OR. thisobs%disttype==11) .AND. domsize==1) THEN norm + + ! *** Compute periodic Cartesian distance *** + + IF (debug>0 .AND. verbose==0) THEN + WRITE (*,*) '++ OMI-debug check_dist2: ', debug, ' compute periodic Cartesian distance' + END IF + + IF (thisobs%ncoord>=3) THEN + IF (thisobs%domainsize(3)<=0.0) THEN + dists(3) = ABS(coordsA(3) - coordsB(3)) + ELSE + dists(3) = MIN(ABS(coordsA(3) - coordsB(3)), & + ABS(ABS(coordsA(3) - coordsB(3))-thisobs%domainsize(3))) + END IF + IF (dists(3)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + IF (thisobs%domainsize(2)<=0.0) THEN + dists(2) = ABS(coordsA(2) - coordsB(2)) + ELSE + dists(2) = MIN(ABS(coordsA(2) - coordsB(2)), & + ABS(ABS(coordsA(2) - coordsB(2))-thisobs%domainsize(2))) + END IF + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + IF (thisobs%domainsize(1)<=0.0) THEN + dists(1) = ABS(coordsA(1) - coordsB(1)) + ELSE + dists(1) = MIN(ABS(coordsA(1) - coordsB(1)), & + ABS(ABS(coordsA(1) - coordsB(1))-thisobs%domainsize(1))) + END IF + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + IF (thisobs%disttype<10) THEN + ! full 3D localization + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + ELSE + ! factorized 2+1D localization + DO k = 1, thisobs%ncoord-1 + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + END IF + ELSEIF (thisobs%ncoord==2) THEN + IF (thisobs%domainsize(2)<=0.0) THEN + dists(2) = ABS(coordsA(2) - coordsB(2)) + ELSE + dists(2) = MIN(ABS(coordsA(2) - coordsB(2)), & + ABS(ABS(coordsA(2) - coordsB(2))-thisobs%domainsize(2))) + END IF + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + IF (thisobs%domainsize(1)<=0.0) THEN + dists(1) = ABS(coordsA(1) - coordsB(1)) + ELSE + dists(1) = MIN(ABS(coordsA(1) - coordsB(1)), & + ABS(ABS(coordsA(1) - coordsB(1))-thisobs%domainsize(1))) + END IF + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + ELSEIF (thisobs%ncoord==1) THEN + IF (thisobs%domainsize(1)<=0.0) THEN + dists(1) = ABS(coordsA(1) - coordsB(1)) + ELSE + dists(1) = MIN(ABS(coordsA(1) - coordsB(1)), & + ABS(ABS(coordsA(1) - coordsB(1))-thisobs%domainsize(1))) + END IF + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + + ELSEIF (thisobs%disttype==2 .OR. thisobs%disttype==12) THEN norm + + ! *** Compute distance from geographic coordinates *** + + IF (debug>0 .AND. verbose==0) THEN + WRITE (*,*) '++ OMI-debug check_dist2: ', debug, ' compute geographic distance' + END IF + + IF (thisobs%ncoord==3) THEN + dists(3) = ABS(coordsA(3) - coordsB(3)) + IF (dists(3)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + dists(2) = r_earth * ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + dists(1) = r_earth * MIN( ABS(coordsA(1) - coordsB(1))* COS(coordsA(2)), & + ABS(ABS(coordsA(1) - coordsB(1)) - 2.0*pi) * COS(coordsA(2))) + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + IF (thisobs%disttype<10) THEN + ! full 3D localization + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + ELSE + ! factorized 2+1D localization + DO k = 1, thisobs%ncoord-1 + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + END IF + ELSE + dists(2) = r_earth * ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + dists(1) = r_earth * MIN( ABS(coordsA(1) - coordsB(1))* COS(coordsA(2)), & + ABS(ABS(coordsA(1) - coordsB(1)) - 2.0*pi) * COS(coordsA(2))) + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + + ELSEIF (thisobs%disttype==3 .OR. thisobs%disttype==13) THEN norm + + ! *** Compute distance from geographic coordinates with haversine formula *** + + IF (debug>0 .AND. verbose==0) THEN + WRITE (*,*) '++ OMI-debug check_dist2: ', debug, & + ' compute geographic distance using haversine function' + END IF + + IF (thisobs%ncoord==3) THEN + dists(3) = ABS(coordsA(3) - coordsB(3)) + IF (dists(3)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + dists(2) = r_earth * ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! Haversine formula + slon = SIN((coordsA(1) - coordsB(1))/2) + slat = SIN((coordsA(2) - coordsB(2))/2) + + dists(2) = SQRT(slat*slat + COS(coordsA(2))*COS(coordsB(2))*slon*slon) + IF (dists(2)<=1.0) THEN + dists(2) = 2.0 * r_earth* ASIN(dists(2)) + ELSE + dists(2) = r_earth* pi + END IF + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + IF (thisobs%disttype<10) THEN + ! full 3D localization + DO k = 2, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + ELSE + ! factorized 2+1D localization + DO k = 2, thisobs%ncoord-1 + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + END IF + ELSE + dists(2) = r_earth * ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! Haversine formula + slon = SIN((coordsA(1) - coordsB(1))/2) + slat = SIN((coordsA(2) - coordsB(2))/2) + + dists(2) = SQRT(slat*slat + COS(coordsA(2))*COS(coordsB(2))*slon*slon) + IF (dists(2)<=1.0) THEN + dists(2) = 2.0 * r_earth* ASIN(dists(2)) + ELSE + dists(2) = r_earth* pi + END IF + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + + END IF norm + + IF (distflag) THEN + cradius2 = thisobs_l%cradius(1)*thisobs_l%cradius(1) + + IF (distance2 <= cradius2) THEN + + ! Increment counter + cnt_obs = cnt_obs + 1 + + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug cnt_dim_obs_l: ', debug, & + ' valid observation with coordinates', thisobs%ocoord_f(1:thisobs%ncoord, i) + END IF + + IF (mode == 2) THEN + ! For internal storage (use in prodRinvA_l) + thisobs_l%id_obs_l(cnt_obs) = i ! node index + thisobs_l%distance_l(cnt_obs) = SQRT(distance2) ! distance + thisobs_l%cradius_l(cnt_obs) = thisobs_l%cradius(1) ! isotropic cut-off radius + thisobs_l%sradius_l(cnt_obs) = thisobs_l%sradius(1) ! isotropic support radius + END IF + + END IF + END IF + END DO scancount + + END SUBROUTINE PDAFomi_check_dist2_loop + + + + +!------------------------------------------------------------------------------- +!> Set dimension of local obs. vector and local obs. arrays (non-isotropic) +!! +!! This routine sets the number of local observations for the +!! current observation type for the local analysis domain +!! with coordinates COORD_l and a vector of localization cut-off +!! radii CRADIUS. +!! Further the routine initializes arrays for the index of a +!! local observation in the full observation vector and its +!! corresponding distance. +!! The operation are performed by calling the routines +!! cnt_dim_obs_l and init_obsarrays_l. +!! +!! __Revision history:__ +!! * 2024-02 - Lars Nerger - Initial code from restructuring observation routines +!! * Later revisions - see repository log +!! + SUBROUTINE PDAFomi_init_dim_obs_l_noniso(thisobs_l, thisobs, coords_l, locweight, cradius, & + sradius, cnt_obs_l_all) + + IMPLICIT NONE + +! *** Arguments *** + TYPE(obs_f), INTENT(inout) :: thisobs !< Data type with full observation + TYPE(obs_l), TARGET, INTENT(inout) :: thisobs_l !< Data type with local observation + REAL, INTENT(in) :: coords_l(:) !< Coordinates of current analysis domain + INTEGER, INTENT(in) :: locweight !< Type of localization function + REAL, INTENT(in) :: cradius(:) !< Vector of localization cut-off radii + REAL, INTENT(in) :: sradius(:) !< Vector of support radii of localization function + INTEGER, INTENT(inout) :: cnt_obs_l_all !< Local dimension of current observation vector + +! *** Local variables *** + REAL :: maxcoords_l, mincoords_l ! Min/Max domain coordinates to check geographic coords + REAL :: maxocoords_l, minocoords_l ! Min/Max observation coordinates to check geographic coords + INTEGER :: cnt_obs ! Counter for valid local observations + + + doassim: IF (thisobs%doassim == 1) THEN + +! *********************************************** +! *** Check offset in full observation vector *** +! *********************************************** + + IF (debug>0) & + WRITE (*,*) '++ OMI-debug: ', debug, 'PDAFomi_init_dim_obs_l_noniso -- START' + + ! Check consistency of dimensions + IF (SIZE(cradius) /= thisobs%ncoord) THEN + WRITE (*,*) '+++++ ERROR PDAF-OMI: non-isotropic localization: Size of CRADIUS /= thisobs%ncoord' + error = 12 + END IF + IF (SIZE(sradius) /= thisobs%ncoord) THEN + WRITE (*,*) '+++++ ERROR PDAF-OMI: non-isotropic localization: Size of SRADIUS /= thisobs%ncoord' + error = 13 + END IF + IF (thisobs%ncoord/=3 .AND. thisobs%disttype>=10) THEN + WRITE (*,*) '+++++ ERROR PDAF-OMI: factorized 2+1D localization can only be used for thisobs%ncoord=3' + error = 14 + END IF + + +! ************************************** +! *** Store localization information *** +! ************************************** + + thisobs_l%locweight = locweight + + ! Allocate vectors for localization radii and store their values + IF (ALLOCATED(thisobs_l%cradius)) DEALLOCATE(thisobs_l%cradius) + ALLOCATE(thisobs_l%cradius(thisobs%ncoord)) + IF (ALLOCATED(thisobs_l%sradius)) DEALLOCATE(thisobs_l%sradius) + ALLOCATE(thisobs_l%sradius(thisobs%ncoord)) + + thisobs_l%nradii = thisobs%ncoord + thisobs_l%cradius(:) = cradius(:) + thisobs_l%sradius(:) = sradius(:) + + +! ************************************** +! *** Count valid local observations *** +! ************************************** + + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug: ', debug, & + ' PDAFomi_init_dim_obs_l_noniso -- count local observations' + IF (thisobs%obsid == firstobs) THEN + WRITE (*,*) '++ OMI-debug init_dim_obs_l_noniso:', debug, ' Re-init dim_obs_l=0' + END IF + WRITE (*,*) '++ OMI-debug init_dim_obs_l_noniso:', debug, ' coords_l', coords_l + + ! For geographic coordinates check whether their range is reasonable + IF (thisobs%disttype==2 .OR. thisobs%disttype==3 .OR. thisobs%disttype==12 .OR. thisobs%disttype==13) THEN + maxcoords_l = MAXVAL(coords_l) + mincoords_l = MINVAL(coords_l) + maxocoords_l = MAXVAL(thisobs%ocoord_f(1:2, :)) + minocoords_l = MINVAL(thisobs%ocoord_f(1:2, :)) + + IF (maxcoords_l>2.0*pi .OR. mincoords_l<-pi .OR. maxocoords_l>2.0*pi .OR. minocoords_l<-pi) THEN + WRITE (*,*) '++ OMI-debug init_dim_obs_l_noniso:', debug, & + ' WARNING: The unit for geographic coordinates is radian, thus range (0,2*pi) or (-pi,pi)!' + END IF + END IF + WRITE (*,*) '++ OMI-debug init_dim_obs_l_noniso:', debug, & + ' Note: Please ensure that coords_l and observation coordinates have the same unit' + + WRITE (*,*) '++ OMI-debug init_dim_obs_l_noniso: ', debug, ' thisobs%ncoord', thisobs%ncoord + WRITE (*,*) '++ OMI-debug init_dim_obs_l_noniso: ', debug, ' thisobs_l%cradius', thisobs_l%cradius + WRITE (*,*) '++ OMI-debug init_dim_obs_l_noniso: ', debug, ' Check for observations within radius' + END IF + + cnt_obs = 0 + IF (thisobs_l%nradii==1) THEN + ! 1D but with radius specified as array + CALL PDAFomi_check_dist2_loop(thisobs_l, thisobs, coords_l, cnt_obs, 1) + ELSEIF (thisobs_l%nradii==2 .OR. thisobs_l%nradii==3) THEN + ! Nonisotropic in 2 or 3 dimensions + CALL PDAFomi_check_dist2_noniso_loop(thisobs_l, thisobs, coords_l, cnt_obs, 1) + ELSE + WRITE (*,*) '+++++ ERROR PDAF-OMI: nonisotropic localization is only possible in 1, 2 or 3 dimensions' + error = 10 + END IF + + +! ************************************************ +! *** Initialize local observation for PDAFomi *** +! ************************************************ + + CALL PDAFomi_set_dim_obs_l(thisobs_l, thisobs, cnt_obs_l_all, cnt_obs) + + +! ************************************************************ +! *** Initialize internal local arrays for local distances *** +! *** and indices of local obs. in full obs. vector *** +! ************************************************************ + + IF (debug>0) & + WRITE (*,*) '++ OMI-debug: ', debug, & + ' PDAFomi_init_dim_obs_l_noniso -- initialize local observation arrays' + + ! Count local observations and initialize index and distance arrays + IF (thisobs_l%dim_obs_l>0) THEN + + cnt_obs = 0 + IF (thisobs_l%nradii==1) THEN + ! 1D but with radius specified as array + CALL PDAFomi_check_dist2_loop(thisobs_l, thisobs, coords_l, cnt_obs, 2) + ELSEIF (thisobs_l%nradii==2 .OR. thisobs_l%nradii==3) THEN + ! Nonisotropic in 2 or 3 dimensions + CALL PDAFomi_check_dist2_noniso_loop(thisobs_l, thisobs, coords_l, cnt_obs, 2) + ELSE + WRITE (*,*) '+++++ ERROR PDAF-OMI: nonisotropic localization is only possible in 1, 2 or 3 dimensions' + error = 11 + END IF + END IF + + ! Print debug information + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug init_dim_obs_l_noniso:', debug, ' thisobs_l%dim_obs_l', thisobs_l%dim_obs_l + IF (thisobs_l%dim_obs_l>0) THEN + WRITE (*,*) '++ OMI-debug init_dim_obs_l_noniso:', debug, ' thisobs_l%id_obs_l', thisobs_l%id_obs_l + WRITE (*,*) '++ OMI-debug init_dim_obs_l_noniso:', debug, ' thisobs_l%distance_l', thisobs_l%distance_l + END IF + WRITE (*,*) '++ OMI-debug: ', debug, 'PDAFomi_init_dim_obs_l_noniso -- END' + END IF + + END IF doassim + + END SUBROUTINE PDAFomi_init_dim_obs_l_noniso + + + + +!------------------------------------------------------------------------------- +!> Set dimension of local obs. vector and local obs. arrays +!! +!! This routine is a variant of PDAFomi_init_dim_obs_l_noniso with +!! support for a vector of localization weights. This is used +!! to specify different localization functions for the vertical and +!! horizontal directions. The routine only stores the value of +!! locweights(2) for the vertical and calls PDAFomi_init_dim_obs_l_iso. +!! +!! __Revision history:__ +!! * 2024-04 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! + SUBROUTINE PDAFomi_init_dim_obs_l_noniso_locweights(thisobs_l, thisobs, coords_l, locweights, cradius, & + sradius, cnt_obs_l) + + IMPLICIT NONE + +! *** Arguments *** + TYPE(obs_f), INTENT(inout) :: thisobs !< Data type with full observation + TYPE(obs_l), TARGET, INTENT(inout) :: thisobs_l !< Data type with local observation + REAL, INTENT(in) :: coords_l(:) !< Coordinates of current analysis domain + INTEGER, INTENT(in) :: locweights(:) !< Types of localization function + REAL, INTENT(in) :: cradius(:) !< Vector of localization cut-off radii + REAL, INTENT(in) :: sradius(:) !< Vector of support radii of localization function + INTEGER, INTENT(inout) :: cnt_obs_l !< Local dimension of current observation vector + + +! *** Store vertical locweight and call standard routine + + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug: ', debug, 'PDAFomi_init_dim_obs_l_noniso_locweights -- START' + WRITE (*,*) '++ OMI-debug init_dim_obs_l_noniso_locweights:', debug, ' locweights', locweights + END IF + + ! Check consistency of dimensions + IF (SIZE(locweights) /= 2) THEN + WRITE (*,*) '+++++ ERROR PDAF-OMI: Input for locweight in horizontal and vertical directions needs size 2' + error = 15 + END IF + IF (thisobs%ncoord /= 3) THEN + WRITE (*,*) '+++++ WARNING PDAF-OMI: separate locweight for vertical is only utilized if thisobs%ncoord=3' + END IF + + IF (thisobs%ncoord == 3) THEN + ! locweight for the vertical is treated separately + thisobs_l%locweight_v = locweights(2) + END IF + + ! Call to usual routine that handles a single locweight setting + CALL PDAFomi_init_dim_obs_l_noniso(thisobs_l, thisobs, coords_l, locweights(1), cradius, & + sradius, cnt_obs_l) + + IF (debug>0) & + WRITE (*,*) '++ OMI-debug: ', debug, 'PDAFomi_init_dim_obs_l_noniso_locweights -- END' + + END SUBROUTINE PDAFomi_init_dim_obs_l_noniso_locweights + + +!------------------------------------------------------------------------------- +!> Check distance in case of nonisotropic localization +!! +!! This routine computes the distance between the observation and a +!! model grid point and the cut-off radius of an ellipse (in 2D) +!! or ellipsoid (in 3D) in the direction of the distance. Finally, +!! the routine checks whether the distance is not larger than the +!! cut-off radius. +!! +!! Choices for distance computation - disttype: +!! 0: Cartesian distance in ncoord dimensions +!! 1: Cartesian distance in ncoord dimensions with periodicity +!! (Needs specification of domsize(ncoord)) +!! 2: Aproximate geographic distance with horizontal coordinates in radians (-pi/+pi) +!! 3: Geographic distance computation using haversine formula +!! 10-13: Variants of distance types 0-3, but particularly for 3 dimensions in which +!! a 2+1 dimensional localization is applied (distance weighting only in the horizontal) +!! +!! __Revision history:__ +!! * 2024-02 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! + SUBROUTINE PDAFomi_check_dist2_noniso_loop(thisobs_l, thisobs, coordsA, cnt_obs, mode) + + IMPLICIT NONE + +! *** Arguments *** + TYPE(obs_f), INTENT(in) :: thisobs !< Data type with full observation + TYPE(obs_l), INTENT(inout) :: thisobs_l !< Data type with local observation + REAL, INTENT(in) :: coordsA(:) !< Coordinates of current analysis domain (ncoord) + INTEGER, INTENT(inout) :: cnt_obs !< Count number of local observations + INTEGER, INTENT(in) :: mode !< 1: count local observations + !< 2: initialize local arrays + +! *** Local variables *** + INTEGER :: i, k ! Counters + INTEGER :: verbose ! verbosity flag + INTEGER :: domsize ! Flag whether domainsize is set + LOGICAL :: distflag ! Flag whether distance in a coordinate direction is within cradius + REAL :: slon, slat ! sine of distance in longitude or latitude + REAL :: distance2 ! square distance + REAL :: cradius2 ! cut-off radius on ellipse or ellipsoid + REAL :: phi, theta ! Angles in ellipse or ellipsoid + REAL :: dist_xy ! Distance in xy-plan in 3D case + REAL :: dists(thisobs%ncoord) ! Distance vector between analysis point and observation + REAL :: coordsB(thisobs%ncoord) ! Array for coordinates of a single observation + REAL :: cradius ! Directional cut-off radius + REAL :: sradius ! Directional support radius + LOGICAL :: checkdist ! Flag whether distance is within cut-off radius + + +! ********************** +! *** Initialization *** +! ********************** + + scancount: DO i = 1, thisobs%dim_obs_f + + ! Initialize distance flag + checkdist = .FALSE. ! Whether an observation lies within the local box + distflag = .TRUE. ! Whether an observation lies within the local radius (ellipse, ellipsoid) + + ! Verbosity flag + verbose = i + + ! Observation coordinates + coordsB = thisobs%ocoord_f(1:thisobs%ncoord, i) + + +! ************************ +! *** Compute distance *** +! ************************ + + IF (.NOT.ALLOCATED(thisobs%domainsize)) THEN + domsize = 0 + ELSE + domsize = 1 + END IF + + ! Debug output + IF (debug>0 .AND. verbose==0) THEN + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, ' use non-isotropic localization' + END IF + + norm: IF ((thisobs%disttype==0 .OR. thisobs%disttype==10) .OR. & + ((thisobs%disttype==1 .OR. thisobs%disttype==11) .AND. domsize==0)) THEN + + ! *** Compute Cartesian distance *** + + IF (debug>0 .AND. verbose==0) THEN + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, ' compute Cartesian distance' + END IF + + IF (thisobs%ncoord==3) THEN + dists(3) = ABS(coordsA(3) - coordsB(3)) + IF (dists(3)>thisobs_l%cradius(3)) THEN + distflag = .FALSE. + ELSE + dists(2) = ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(2)) THEN + distflag = .FALSE. + ELSE + dists(1) = ABS(coordsA(1) - coordsB(1)) + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + IF (thisobs%disttype<10) THEN + ! full 3D localization + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + ELSE + ! factorized 2+1D localization + DO k = 1, thisobs%ncoord-1 + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + END IF + ELSEIF (thisobs%ncoord==2) THEN + dists(2) = ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(2)) THEN + distflag = .FALSE. + ELSE + dists(1) = ABS(coordsA(1) - coordsB(1)) + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + ELSEIF (thisobs%ncoord==1) THEN + dists(1) = ABS(coordsA(1) - coordsB(1)) + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + + ELSEIF ((thisobs%disttype==1 .OR. thisobs%disttype==11) .AND. domsize==1) THEN norm + + ! *** Compute periodic Cartesian distance *** + + IF (debug>0 .AND. verbose==0) THEN + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, ' compute periodic Cartesian distance' + END IF + + IF (thisobs%ncoord==3) THEN + IF (thisobs%domainsize(3)<=0.0) THEN + dists(3) = ABS(coordsA(3) - coordsB(3)) + ELSE + dists(3) = MIN(ABS(coordsA(3) - coordsB(3)), & + ABS(ABS(coordsA(3) - coordsB(3))-thisobs%domainsize(3))) + END IF + IF (dists(3)>thisobs_l%cradius(3)) THEN + distflag = .FALSE. + ELSE + IF (thisobs%domainsize(2)<=0.0) THEN + dists(2) = ABS(coordsA(2) - coordsB(2)) + ELSE + dists(2) = MIN(ABS(coordsA(2) - coordsB(2)), & + ABS(ABS(coordsA(2) - coordsB(2))-thisobs%domainsize(2))) + END IF + IF (dists(2)>thisobs_l%cradius(2)) THEN + distflag = .FALSE. + ELSE + IF (thisobs%domainsize(1)<=0.0) THEN + dists(1) = ABS(coordsA(1) - coordsB(1)) + ELSE + dists(1) = MIN(ABS(coordsA(1) - coordsB(1)), & + ABS(ABS(coordsA(1) - coordsB(1))-thisobs%domainsize(1))) + END IF + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + IF (thisobs%disttype<10) THEN + ! full 3D localization + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + ELSE + ! factorized 2+1D localization + DO k = 1, thisobs%ncoord-1 + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + END IF + ELSEIF (thisobs%ncoord==2) THEN + IF (thisobs%domainsize(2)<=0.0) THEN + dists(2) = ABS(coordsA(2) - coordsB(2)) + ELSE + dists(2) = MIN(ABS(coordsA(2) - coordsB(2)), & + ABS(ABS(coordsA(2) - coordsB(2))-thisobs%domainsize(2))) + END IF + IF (dists(2)>thisobs_l%cradius(2)) THEN + distflag = .FALSE. + ELSE + IF (thisobs%domainsize(1)<=0.0) THEN + dists(1) = ABS(coordsA(1) - coordsB(1)) + ELSE + dists(1) = MIN(ABS(coordsA(1) - coordsB(1)), & + ABS(ABS(coordsA(1) - coordsB(1))-thisobs%domainsize(1))) + END IF + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + ELSEIF (thisobs%ncoord==1) THEN + IF (thisobs%domainsize(1)<=0.0) THEN + dists(1) = ABS(coordsA(1) - coordsB(1)) + ELSE + dists(1) = MIN(ABS(coordsA(1) - coordsB(1)), & + ABS(ABS(coordsA(1) - coordsB(1))-thisobs%domainsize(1))) + END IF + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + + ELSEIF (thisobs%disttype==2 .OR. thisobs%disttype==12) THEN norm + + ! *** Compute distance from geographic coordinates *** + + IF (debug>0 .AND. verbose==0) THEN + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, ' compute geographic distance' + END IF + + IF (thisobs%ncoord==3) THEN + dists(3) = ABS(coordsA(3) - coordsB(3)) + IF (dists(3)>thisobs_l%cradius(3)) THEN + distflag = .FALSE. + ELSE + dists(2) = r_earth * ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(2)) THEN + distflag = .FALSE. + ELSE + dists(1) = r_earth * MIN( ABS(coordsA(1) - coordsB(1))* COS(coordsA(2)), & + ABS(ABS(coordsA(1) - coordsB(1)) - 2.0*pi) * COS(coordsA(2))) + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + IF (thisobs%disttype<10) THEN + ! full 3D localization + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + ELSE + ! factorized 2+1D localization + DO k = 1, thisobs%ncoord-1 + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + END IF + ELSE + dists(2) = r_earth * ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(2)) THEN + distflag = .FALSE. + ELSE + dists(1) = r_earth * MIN( ABS(coordsA(1) - coordsB(1))* COS(coordsA(2)), & + ABS(ABS(coordsA(1) - coordsB(1)) - 2.0*pi) * COS(coordsA(2))) + IF (dists(1)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + + ELSEIF (thisobs%disttype==3 .OR. thisobs%disttype==13) THEN norm + + ! *** Compute distance from geographic coordinates with haversine formula *** + + IF (debug>0 .AND. verbose==0) THEN + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, & + ' compute geographic distance using haversine function' + END IF + + IF (thisobs%ncoord==3) THEN + dists(3) = ABS(coordsA(3) - coordsB(3)) + IF (dists(3)>thisobs_l%cradius(3)) THEN + distflag = .FALSE. + ELSE + dists(2) = r_earth * ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(2)) THEN + distflag = .FALSE. + ELSE + dists(1) = r_earth * MIN( ABS(coordsA(1) - coordsB(1))* COS(coordsA(2)), & + ABS(ABS(coordsA(1) - coordsB(1)) - 2.0*pi) * COS(coordsA(2))) + + ! Haversine formula + slon = SIN((coordsA(1) - coordsB(1))/2) + slat = SIN((coordsA(2) - coordsB(2))/2) + + dists(2) = SQRT(slat*slat + COS(coordsA(2))*COS(coordsB(2))*slon*slon) + IF (dists(2)<=1.0) THEN + dists(2) = 2.0 * r_earth* ASIN(dists(2)) + ELSE + dists(2) = r_earth* pi + END IF + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + IF (thisobs%disttype<10) THEN + ! full 3D localization + DO k = 2, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + ELSE + ! factorized 2+1D localization + DO k = 2, thisobs%ncoord-1 + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + END IF + ELSE + dists(2) = r_earth * ABS(coordsA(2) - coordsB(2)) + IF (dists(2)>thisobs_l%cradius(2)) THEN + distflag = .FALSE. + ELSE + dists(1) = r_earth * MIN( ABS(coordsA(1) - coordsB(1))* COS(coordsA(2)), & + ABS(ABS(coordsA(1) - coordsB(1)) - 2.0*pi) * COS(coordsA(2))) + + ! Haversine formula + slon = SIN((coordsA(1) - coordsB(1))/2) + slat = SIN((coordsA(2) - coordsB(2))/2) + + dists(2) = SQRT(slat*slat + COS(coordsA(2))*COS(coordsB(2))*slon*slon) + IF (dists(2)<=1.0) THEN + dists(2) = 2.0 * r_earth* ASIN(dists(2)) + ELSE + dists(2) = r_earth* pi + END IF + IF (dists(2)>thisobs_l%cradius(1)) THEN + distflag = .FALSE. + ELSE + ! full squared distance + distance2 = 0.0 + DO k = 1, thisobs%ncoord + distance2 = distance2 + dists(k)*dists(k) + END DO + END IF + END IF + END IF + + END IF norm + + +! *************************************************************************** +! *** Compute directional cut-off and support radii and set distance flag *** +! *************************************************************************** + + dflag: IF (distflag) THEN + nrad: IF (thisobs_l%nradii == 2 .OR. (thisobs_l%nradii == 3 .AND. thisobs%disttype >= 10)) THEN + + IF ((thisobs_l%cradius(1) == thisobs_l%cradius(2)) .OR. & + (thisobs_l%sradius(1) == thisobs_l%sradius(2))) THEN + ! 2D isotropic case + + cradius2 = thisobs_l%cradius(1) * thisobs_l%cradius(1) + + IF (distance2 <= cradius2) THEN + ! Set flag for valid observation + checkdist = .TRUE. + cnt_obs = cnt_obs + 1 + + cradius = thisobs_l%cradius(1) + sradius = thisobs_l%sradius(1) + + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, & + ' 2D isotropic with separately specified, but equal, radii' + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, ' theta, cradius, sradius', & + theta*180/pi, cradius, sradius + END IF + END IF + ELSE + + ! *** 2D anisotropic case: Use polar radius of ellipse in 2 dimensions *** + + ! Compute angle + IF (dists(1) /= 0.0) THEN + theta = ATAN(dists(2) / dists(1)) + ELSE + theta = pi / 2.0 + END IF + + ! Compute radius in direction of theta + IF (thisobs_l%cradius(1)>0.0 .OR. thisobs_l%cradius(2)>0.0) THEN + cradius = thisobs_l%cradius(1) * thisobs_l%cradius(2) / & + SQRT( (thisobs_l%cradius(2)*COS(theta))**2 & + + (thisobs_l%cradius(1)*SIN(theta))**2 ) + ELSE + cradius = 0.0 + END IF + + cradius2 = cradius * cradius + + IF (distance2 <= cradius2) THEN + ! Set flag for valid observation + checkdist = .TRUE. + cnt_obs = cnt_obs + 1 + + ! Compute support radius in direction of theta + IF (thisobs_l%sradius(1)>0.0 .OR. thisobs_l%sradius(2)>0.0) THEN + sradius = thisobs_l%sradius(1) * thisobs_l%sradius(2) / & + SQRT( (thisobs_l%sradius(2)*COS(theta))**2 & + + (thisobs_l%sradius(1)*SIN(theta))**2 ) + ELSE + sradius = 0.0 + END IF + + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, & + ' 2D nonisotropic localization' + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, ' theta, cradius, sradius', & + theta*180/pi, cradius, sradius + END IF + END IF + + END IF + + ELSE IF (thisobs_l%nradii == 3 .AND. thisobs%disttype < 10) THEN nrad + + ! To save computing time, we here distinguish whether + ! - the horizontal radii are equal and only direction 3 has a different radius + ! - whether all radii are equal (isotropic but specified with separate radii) + ! - the anisotropy is in all 3 dimensions (all radii different) + + aniso: IF ((thisobs_l%cradius(1) == thisobs_l%cradius(2)) .AND. & + (thisobs_l%cradius(1) /= thisobs_l%cradius(3)) .AND. & + (thisobs_l%sradius(1) == thisobs_l%sradius(2))) THEN + + ! *** Isotropic in horizontal direction, distinct radius in the third direction (vertical) *** + + dist_xy = SQRT(dists(1)*dists(1) + dists(2)*dists(2)) + + ! 2D anisotropy: Polar radius of ellipse in 2 dimensions + + ! Compute angle + IF (dist_xy /= 0.0) THEN + theta = ATAN(dists(3) / dist_xy) + ELSE + theta = pi / 2.0 + END IF + + ! Compute radius in direction of theta + IF (thisobs_l%cradius(1)>0.0 .OR. thisobs_l%cradius(3)>0.0) THEN + cradius = thisobs_l%cradius(1) * thisobs_l%cradius(3) / & + SQRT( (thisobs_l%cradius(3)*COS(theta))**2 & + + (thisobs_l%cradius(1)*SIN(theta))**2 ) + ELSE + cradius = 0.0 + END IF + + cradius2 = cradius * cradius + + IF (distance2 <= cradius2) THEN + ! Set flag for valid observation + checkdist = .TRUE. + cnt_obs = cnt_obs + 1 + + ! Compute support radius in direction of theta + IF (thisobs_l%sradius(1)>0.0 .OR. thisobs_l%sradius(3)>0.0) THEN + sradius = thisobs_l%sradius(1) * thisobs_l%sradius(3) / & + SQRT( (thisobs_l%sradius(3)*COS(theta))**2 & + + (thisobs_l%sradius(1)*SIN(theta))**2 ) + ELSE + sradius = 0.0 + END IF + + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, & + ' 3D: isotropic in directions 1 and 2, nonisotropic in direction 3' + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, ' theta, cradius, sradius', & + theta*180/pi, cradius, sradius + END IF + END IF + + ELSEIF ((thisobs_l%cradius(1) == thisobs_l%cradius(2)) .AND. & + (thisobs_l%cradius(1) == thisobs_l%cradius(3)) .AND. & + (thisobs_l%sradius(1) == thisobs_l%sradius(2)) .AND. & + (thisobs_l%sradius(2) == thisobs_l%sradius(3))) THEN aniso + + ! *** 3D isotropic case (all radii equal) *** + + cradius = thisobs_l%cradius(1) + cradius2 = thisobs_l%cradius(1) * thisobs_l%cradius(1) + sradius = thisobs_l%sradius(1) + + IF (distance2 <= cradius2) THEN + ! Set flag for valid observation + checkdist = .TRUE. + cnt_obs = cnt_obs + 1 + END IF + + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, & + ' 3D isotropic case specified with vector of radii' + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, ' theta, cradius, sradius', & + theta*180/pi, cradius, sradius + END IF + ELSE aniso + + ! *** general 3D anisotropic case *** + + ! Polar radius of ellipsoid in 3 dimensions + + ! Compute angle in x-y direction + IF (dists(1) /= 0.0) THEN + theta = ATAN(dists(2) / dists(1)) + ELSE + theta = pi / 2.0 + END IF + + ! Distance in xy-plane + dist_xy = SQRT(dists(1)**2 + dists(2)**2) + + ! Compute angle of xy-plane to z direction + IF (dist_xy /= 0.0) THEN + phi = ATAN(dists(3) / dist_xy) + ELSE + phi = 0.0 + END IF + + ! Compute radius in direction of theta + IF (thisobs_l%cradius(1)>0.0 .OR. thisobs_l%cradius(2)>0.0 .OR. thisobs_l%cradius(3)>0.0) THEN + cradius = thisobs_l%cradius(1) * thisobs_l%cradius(2) * thisobs_l%cradius(3) / & + SQRT( (thisobs_l%cradius(2)*thisobs_l%cradius(3)*COS(phi)*COS(theta))**2 & + + (thisobs_l%cradius(1)*thisobs_l%cradius(3)*COS(phi)*SIN(theta))**2 & + + (thisobs_l%cradius(1)*thisobs_l%cradius(2)*SIN(phi))**2 ) + ELSE + cradius = 0.0 + END IF + + cradius2 = cradius * cradius + + IF (distance2 <= cradius2) THEN + ! Set flag for valid observation + checkdist = .TRUE. + cnt_obs = cnt_obs + 1 + + ! Compute support radius in direction of theta + IF (thisobs_l%sradius(1)>0.0 .OR. thisobs_l%sradius(2)>0.0 .OR. thisobs_l%sradius(3)>0.0) THEN + sradius = thisobs_l%sradius(1) * thisobs_l%sradius(2) * thisobs_l%sradius(3) / & + SQRT( (thisobs_l%sradius(2)*thisobs_l%sradius(3)*COS(phi)*COS(theta))**2 & + + (thisobs_l%sradius(1)*thisobs_l%sradius(3)*COS(phi)*SIN(theta))**2 & + + (thisobs_l%sradius(1)*thisobs_l%sradius(2)*SIN(phi))**2 ) + ELSE + sradius = 0.0 + END IF + + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, & + ' 3D nonisotropic localization' + WRITE (*,*) '++ OMI-debug check_dist2_noniso: ', debug, ' theta, phi, distance, cradius, sradius', & + theta*180/pi, phi*180/pi, SQRT(distance2), cradius, sradius + END IF + END IF + + END IF aniso + ELSEIF (thisobs_l%nradii == 1) THEN nrad + cradius = thisobs_l%cradius(1) + cradius2 = thisobs_l%cradius(1) * thisobs_l%cradius(1) + sradius = thisobs_l%sradius(1) + + IF (distance2 <= cradius2) THEN + ! Set flag for valid observation + checkdist = .TRUE. + cnt_obs = cnt_obs + 1 + END IF + + END IF nrad + + IF (mode==2 .AND. checkdist) THEN + ! For internal storage (use in prodRinvA_l and likelihood_l) + thisobs_l%id_obs_l(cnt_obs) = i ! node index + thisobs_l%distance_l(cnt_obs) = SQRT(distance2) ! distance + thisobs_l%cradius_l(cnt_obs) = cradius ! directional cut-off radius + thisobs_l%sradius_l(cnt_obs) = sradius ! directional support radius + IF (thisobs_l%locweight_v>0 .AND. thisobs_l%nradii==3) THEN + thisobs_l%dist_l_v(cnt_obs) = dists(3) ! distance in vertical direction + END if + END IF + END IF dflag + + END DO scancount + + END SUBROUTINE PDAFomi_check_dist2_noniso_loop + + + +!------------------------------------------------------------------------------- +!> Set localization parameters for isotropic localization +!! +!! This routine stores localization information (locweight, cradius, sradius) +!! in OMI and allocates local arrays for cradius and sradius. This variant +!! is for isotropic localization. The routine is used by user-supplied +!! implementations of PDAFomi_init_dim_obs_l. +!! +!! The routine is called by all filter processes. +!! +!! __Revision history:__ +!! * 2024-09 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! + SUBROUTINE PDAFomi_set_localization(thisobs_l, cradius, sradius, locweight) + + IMPLICIT NONE + +! *** Arguments *** + TYPE(obs_l), INTENT(inout) :: thisobs_l !< Data type with local observation + REAL, INTENT(in) :: cradius !< Localization cut-off radius + REAL, INTENT(in) :: sradius !< Support radius of localization function + INTEGER, INTENT(in) :: locweight !< Type of localization function + + +! *** Allocate vectors for localization radii *** + + IF (ALLOCATED(thisobs_l%cradius)) DEALLOCATE(thisobs_l%cradius) + ALLOCATE(thisobs_l%cradius(1)) + IF (ALLOCATED(thisobs_l%sradius)) DEALLOCATE(thisobs_l%sradius) + ALLOCATE(thisobs_l%sradius(1)) + + thisobs_l%locweight = locweight + thisobs_l%nradii = 1 + thisobs_l%cradius(:) = cradius + thisobs_l%sradius(:) = sradius + + END SUBROUTINE PDAFomi_set_localization + + + +!------------------------------------------------------------------------------- +!> Set localization parameters for non-isotropic localization +!! +!! This routine stores localization information (locweight, cradius, sradius) +!! in OMI and allocates local arrays for cradius and sradius. This variant +!! is for non-isotropic localization. The routine is used by user-supplied +!! implementations of PDAFomi_init_dim_obs_l. +!! +!! The routine is called by all filter processes. +!! +!! __Revision history:__ +!! * 2024-09 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! + SUBROUTINE PDAFomi_set_localization_noniso(thisobs_l, nradii, cradius, sradius, locweight, locweight_v) + + IMPLICIT NONE + +! *** Arguments *** + TYPE(obs_l), INTENT(inout) :: thisobs_l !< Data type with local observation + INTEGER, INTENT(in) :: nradii !< Number of radii to consider for localization + REAL, INTENT(in) :: cradius(nradii) !< Localization cut-off radius + REAL, INTENT(in) :: sradius(nradii) !< Support radius of localization function + INTEGER, INTENT(in) :: locweight !< Type of localization function + INTEGER, INTENT(in) :: locweight_v !< Type of localization function in vertical direction (only for nradii=3) + + + +! *** Allocate vectors for localization radii *** + + IF (ALLOCATED(thisobs_l%cradius)) DEALLOCATE(thisobs_l%cradius) + ALLOCATE(thisobs_l%cradius(nradii)) + IF (ALLOCATED(thisobs_l%sradius)) DEALLOCATE(thisobs_l%sradius) + ALLOCATE(thisobs_l%sradius(nradii)) + + thisobs_l%locweight = locweight + thisobs_l%nradii = nradii + thisobs_l%cradius(1:nradii) = cradius(1:nradii) + thisobs_l%sradius(1:nradii) = sradius(1:nradii) + IF (nradii==3) thisobs_l%locweight_v = locweight_v + + END SUBROUTINE PDAFomi_set_localization_noniso + + +!------------------------------------------------------------------------------- +!> Initialization for dim_obs_l +!! +!! This routine initializes information on local observation vectors. +!! It is used by a user-supplied implementations of PDAFomi_init_dim_obs_l. +!! +!! The routine is called by all filter processes. +!! +!! __Revision history:__ +!! * 2024-08 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! + SUBROUTINE PDAFomi_set_dim_obs_l(thisobs_l, thisobs, cnt_obs_l_all, cnt_obs_l) + + IMPLICIT NONE + +! *** Arguments *** + TYPE(obs_f), INTENT(inout) :: thisobs !< Data type with full observation + TYPE(obs_l), TARGET, INTENT(inout) :: thisobs_l !< Data type with local observation + INTEGER, INTENT(inout) :: cnt_obs_l_all !< Local dimension of observation vector over all obs. types + INTEGER, INTENT(inout) :: cnt_obs_l !< Local dimension of single observation type vector + + + ! Store ID of first observation type that calls the routine + ! This is reset in PDAFomi_deallocate_obs + IF (firstobs == 0) THEN + firstobs = thisobs%obsid + END IF + + ! Reset offset of currrent observation in overall local obs. vector + IF (thisobs%obsid == firstobs) THEN + offset_obs_l = 0 + cnt_obs_l_all = 0 + END IF + + ! Store offset + thisobs_l%off_obs_l = offset_obs_l + + ! Initialize pointer array + IF (thisobs%obsid == firstobs) THEN + IF (ALLOCATED(obs_l_all)) DEALLOCATE(obs_l_all) + ALLOCATE(obs_l_all(n_obstypes)) + END IF + + ! Set pointer to current observation + obs_l_all(thisobs%obsid)%ptr => thisobs_l + + ! Store local observation dimension and increment offset + thisobs_l%dim_obs_l = cnt_obs_l + offset_obs_l = offset_obs_l + cnt_obs_l + cnt_obs_l_all = cnt_obs_l_all + cnt_obs_l + + ! Allocate arrays to store information on local observations + IF (ALLOCATED(thisobs_l%id_obs_l)) DEALLOCATE(thisobs_l%id_obs_l) + IF (ALLOCATED(thisobs_l%distance_l)) DEALLOCATE(thisobs_l%distance_l) + IF (ALLOCATED(thisobs_l%cradius_l)) DEALLOCATE(thisobs_l%cradius_l) + IF (ALLOCATED(thisobs_l%sradius_l)) DEALLOCATE(thisobs_l%sradius_l) + + haveobs: IF (cnt_obs_l>0) THEN + ALLOCATE(thisobs_l%id_obs_l(cnt_obs_l)) + ALLOCATE(thisobs_l%distance_l(cnt_obs_l)) + ALLOCATE(thisobs_l%cradius_l(cnt_obs_l)) + ALLOCATE(thisobs_l%sradius_l(cnt_obs_l)) + IF (thisobs_l%locweight_v>0) THEN + IF (ALLOCATED(thisobs_l%dist_l_v)) DEALLOCATE(thisobs_l%dist_l_v) + ALLOCATE(thisobs_l%dist_l_v(cnt_obs_l)) + END IF + + ELSE + ALLOCATE(thisobs_l%id_obs_l(1)) + ALLOCATE(thisobs_l%distance_l(1)) + ALLOCATE(thisobs_l%cradius_l(1)) + ALLOCATE(thisobs_l%sradius_l(1)) + IF (ALLOCATED(thisobs_l%dist_l_v)) DEALLOCATE(thisobs_l%dist_l_v) + ALLOCATE(thisobs_l%dist_l_v(1)) + END IF haveobs + + END SUBROUTINE PDAFomi_set_dim_obs_l + + + +!------------------------------------------------------------------------------- +!> Store local index, distance and radii +!! +!! This routine stores the mapping index between the global and local +!! observation vectors, the distance and the cradius and sradius +!! for a single observations in OMI. This variant is for non-factorized +!! localization. The routine is used by user-supplied implementations +!! of PDAFomi_init_dim_obs_l. +!! +!! The routine is called by all filter processes. +!! +!! __Revision history:__ +!! * 2024-09 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! + SUBROUTINE PDAFomi_store_obs_l_index(thisobs_l, idx, id_obs_l, distance, & + cradius_l, sradius_l) + + IMPLICIT NONE + +! *** Arguments *** + TYPE(obs_l), INTENT(inout) :: thisobs_l !< Data type with local observation + INTEGER, INTENT(in) :: idx !< Element of local observation array to be filled + INTEGER, INTENT(in) :: id_obs_l !< Index of local observation in full observation array + REAL, INTENT(in) :: distance !< Distance between local analysis domain and observation + REAL, INTENT(in) :: cradius_l !< cut-off radius for this local observation + ! (directional radius in case of non-isotropic localization) + REAL, INTENT(in) :: sradius_l !< support radius for this local observation + ! (directional radius in case of non-isotropic localization) + + +! *** Store values *** + + thisobs_l%id_obs_l(idx) = id_obs_l ! element of local obs. vector in full obs. vector + thisobs_l%distance_l(idx) = distance ! distance + thisobs_l%cradius_l(idx) = cradius_l ! cut-off radius + thisobs_l%sradius_l(idx) = sradius_l ! support radius + + + END SUBROUTINE PDAFomi_store_obs_l_index + + + +!------------------------------------------------------------------------------- +!> Store local index, dsitance and radii for factorized localization +!! +!! This routine stores the mapping index between the global and local +!! observation vectors, the distance and the cradius and sradius +!! for a single observations in OMI. This variant is for 2+1D factorized +!! localization. The routine is used by user-supplied implementations +!! of PDAFomi_init_dim_obs_l. +!! +!! The routine is called by all filter processes. +!! +!! __Revision history:__ +!! * 2024-09 - Lars Nerger - Initial code +!! * Later revisions - see repository log +!! + SUBROUTINE PDAFomi_store_obs_l_index_vdist(thisobs_l, idx, id_obs_l, distance, & + cradius_l, sradius_l, vdist) + + IMPLICIT NONE + +! *** Arguments *** + TYPE(obs_l), INTENT(inout) :: thisobs_l !< Data type with local observation + INTEGER, INTENT(in) :: idx !< Element of local observation array to be filled + INTEGER, INTENT(in) :: id_obs_l !< Index of local observation in full observation array + REAL, INTENT(in) :: distance !< Distance between local analysis domain and observation + REAL, INTENT(in) :: cradius_l !< cut-off radius for this local observation + ! (directional radius in case of non-isotropic localization) + REAL, INTENT(in) :: sradius_l !< support radius for this local observation + ! (directional radius in case of non-isotropic localization) + REAL, INTENT(in) :: vdist !< support radius in vertical direction for 2+1D factorized localization + + +! *** Store values *** + + thisobs_l%id_obs_l(idx) = id_obs_l ! element of local obs. vector in full obs. vector + thisobs_l%distance_l(idx) = distance ! distance + thisobs_l%cradius_l(idx) = cradius_l ! cut-off radius + thisobs_l%sradius_l(idx) = sradius_l ! support radius + IF (thisobs_l%locweight_v>0 .AND. thisobs_l%nradii==3) THEN + thisobs_l%dist_l_v(idx) = vdist ! distance in vertical direction + END if + + + END SUBROUTINE PDAFomi_store_obs_l_index_vdist + +END MODULE PDAFomi_dim_obs_l diff --git a/src/PDAFomi_obs_l.F90 b/src/PDAFomi_obs_l.F90 index b96f41345..e9f720fc3 100644 --- a/src/PDAFomi_obs_l.F90 +++ b/src/PDAFomi_obs_l.F90 @@ -24,17 +24,17 @@ !! !! * PDAFomi_set_debug_flag \n !! Set or unset the debugging flag for PDAFomi routines -!! * PDAFomi_init_dim_obs_l \n +!! * PDAFomi_init_dim_obs_l_old \n !! Initialize dimension of local obs. vetor and arrays for !! local observations -!! * PDAFomi_cnt_dim_obs_l \n +!! * PDAFomi_cnt_dim_obs_l_old \n !! Set dimension of local obs. vector with isotropic localization -!! * PDAFomi_cnt_dim_obs_l_noniso \n +!! * PDAFomi_cnt_dim_obs_l_noniso_old \n !! Set dimension of local obs. vector with nonisotropic localization -!! * PDAFomi_init_obsarrays_l \n +!! * PDAFomi_init_obsarrays_l_old \n !! Initialize arrays for the index of a local observation in !! the full observation vector and its corresponding distance. -!! * PDAFomi_init_obsarrays_l_noniso \n +!! * PDAFomi_init_obsarrays_l_noniso_old \n !! Initialize arrays for the index of a local observation in !! the full observation vector and its corresponding distance !! with onoisotrppic localization. @@ -123,10 +123,10 @@ MODULE PDAFomi_obs_l !$OMP THREADPRIVATE(obs_l_all, firstobs, offset_obs_l) - INTERFACE PDAFomi_init_dim_obs_l - MODULE PROCEDURE PDAFomi_init_dim_obs_l_iso - MODULE PROCEDURE PDAFomi_init_dim_obs_l_noniso - MODULE PROCEDURE PDAFomi_init_dim_obs_l_noniso_locweights + INTERFACE PDAFomi_init_dim_obs_l_old + MODULE PROCEDURE PDAFomi_init_dim_obs_l_iso_old + MODULE PROCEDURE PDAFomi_init_dim_obs_l_noniso_old + MODULE PROCEDURE PDAFomi_init_dim_obs_l_noniso_locweights_old END INTERFACE INTERFACE PDAFomi_localize_covar @@ -192,7 +192,7 @@ END SUBROUTINE PDAFomi_set_debug_flag !! * 2019-06 - Lars Nerger - Initial code from restructuring observation routines !! * Later revisions - see repository log !! - SUBROUTINE PDAFomi_init_dim_obs_l_iso(thisobs_l, thisobs, coords_l, locweight, cradius, & + SUBROUTINE PDAFomi_init_dim_obs_l_iso_old(thisobs_l, thisobs, coords_l, locweight, cradius, & sradius, cnt_obs_l) IMPLICIT NONE @@ -334,7 +334,7 @@ SUBROUTINE PDAFomi_init_dim_obs_l_iso(thisobs_l, thisobs, coords_l, locweight, c END IF doassim - END SUBROUTINE PDAFomi_init_dim_obs_l_iso + END SUBROUTINE PDAFomi_init_dim_obs_l_iso_old @@ -356,7 +356,7 @@ END SUBROUTINE PDAFomi_init_dim_obs_l_iso !! * 2024-02 - Lars Nerger - Initial code from restructuring observation routines !! * Later revisions - see repository log !! - SUBROUTINE PDAFomi_init_dim_obs_l_noniso(thisobs_l, thisobs, coords_l, locweight, cradius, & + SUBROUTINE PDAFomi_init_dim_obs_l_noniso_old(thisobs_l, thisobs, coords_l, locweight, cradius, & sradius, cnt_obs_l) IMPLICIT NONE @@ -507,7 +507,7 @@ SUBROUTINE PDAFomi_init_dim_obs_l_noniso(thisobs_l, thisobs, coords_l, locweight END IF doassim - END SUBROUTINE PDAFomi_init_dim_obs_l_noniso + END SUBROUTINE PDAFomi_init_dim_obs_l_noniso_old @@ -525,7 +525,7 @@ END SUBROUTINE PDAFomi_init_dim_obs_l_noniso !! * 2024-04 - Lars Nerger - Initial code !! * Later revisions - see repository log !! - SUBROUTINE PDAFomi_init_dim_obs_l_noniso_locweights(thisobs_l, thisobs, coords_l, locweights, cradius, & + SUBROUTINE PDAFomi_init_dim_obs_l_noniso_locweights_old(thisobs_l, thisobs, coords_l, locweights, cradius, & sradius, cnt_obs_l) IMPLICIT NONE @@ -562,13 +562,13 @@ SUBROUTINE PDAFomi_init_dim_obs_l_noniso_locweights(thisobs_l, thisobs, coords_l END IF ! Call to usual routine that handles a single locweight setting - CALL PDAFomi_init_dim_obs_l_noniso(thisobs_l, thisobs, coords_l, locweights(1), cradius, & + CALL PDAFomi_init_dim_obs_l_noniso_old(thisobs_l, thisobs, coords_l, locweights(1), cradius, & sradius, cnt_obs_l) IF (debug>0) & WRITE (*,*) '++ OMI-debug: ', debug, 'PDAFomi_init_dim_obs_l_noniso_locweights -- END' - END SUBROUTINE PDAFomi_init_dim_obs_l_noniso_locweights + END SUBROUTINE PDAFomi_init_dim_obs_l_noniso_locweights_old @@ -1158,81 +1158,31 @@ SUBROUTINE PDAFomi_init_obsvar_l(thisobs_l, thisobs, meanvar_l, cnt_obs_l) END SUBROUTINE PDAFomi_init_obsvar_l - - !------------------------------------------------------------------------------- -!> Compute product of inverse of R with some matrix +!> Compute weights for localization !! !! The routine is called during the analysis step -!! on each local analysis domain. It has to -!! compute the product of the inverse of the local -!! observation error covariance matrix with -!! the matrix of locally observed ensemble -!! perturbations. -!! -!! Next to computing the product, a localizing -!! weighting ("observation localization") can be -!! applied to matrix A. +!! on each local analysis domain. !! -!! This implementation assumes a diagonal observation -!! error covariance matrix, and supports varying -!! observation error variances. -!! -!! The routine can be applied with either all observations -!! of different types at once, or separately for each -!! observation type. -!! -!! __Revision history:__ -!! * 2019-06 - Lars Nerger - Initial code from restructuring observation routines -!! * Later revisions - see repository log -!! - SUBROUTINE PDAFomi_prodRinvA_l(thisobs_l, thisobs, nobs_all, ncols, & - A_l, C_l, verbose) + SUBROUTINE PDAFomi_observation_localization_weights(thisobs_l, thisobs, ncols, & + A_l, weight, verbose) - IMPLICIT NONE + IMPLICIT NONE ! *** Arguments *** TYPE(obs_l), INTENT(inout) :: thisobs_l !< Data type with local observation TYPE(obs_f), INTENT(inout) :: thisobs !< Data type with full observation - INTEGER, INTENT(in) :: nobs_all !< Dimension of local obs. vector (all obs. types) INTEGER, INTENT(in) :: ncols !< Rank of initial covariance matrix - REAL, INTENT(inout) :: A_l(:, :) !< Input matrix (thisobs_l%dim_obs_l, ncols) - REAL, INTENT(out) :: C_l(:, :) !< Output matrix (thisobs_l%dim_obs_l, ncols) + REAL, INTENT(in) :: A_l(:, :) !< Input matrix (thisobs_l%dim_obs_l, ncols) INTEGER, INTENT(in) :: verbose !< Verbosity flag + REAL, INTENT(out) :: weight(thisobs_l%dim_obs_l) !> Localization weights ! *** local variables *** - INTEGER :: i, j ! Index of observation component - REAL, ALLOCATABLE :: weight(:) ! Localization weights + INTEGER :: i ! Index of observation component REAL, ALLOCATABLE :: weight_v(:) ! Localization weights for vertical (for locweight_v>0) - INTEGER :: idummy ! Dummy to access nobs_all - INTEGER :: off ! row offset in A_l and C_l - - -! ********************** -! *** INITIALIZATION *** -! ********************** - - doassim: IF (thisobs%doassim == 1) THEN - - ! Initialize dummy to prevent compiler warning - idummy = nobs_all - - ! Initialize offset - off = thisobs_l%off_obs_l ! Screen output - IF (debug>0) THEN - WRITE (*,*) '++ OMI-debug: ', debug, & - 'PDAFomi_prodrinva_l -- START Multiply with inverse R and and apply localization' - WRITE (*,*) '++ OMI-debug prodrinva_l: ', debug, ' thisobs_l%locweight', thisobs_l%locweight - IF (thisobs_l%locweight_v>0) & - WRITE (*,*) '++ OMI-debug prodrinva_l: ', debug, ' thisobs_l%locweight_v', thisobs_l%locweight_v - WRITE (*,*) '++ OMI-debug prodRinvA_l: ', debug, ' thisobs%dim_obs_l', thisobs_l%dim_obs_l - WRITE (*,*) '++ OMI-debug prodRinvA_l: ', debug, ' thisobs%ivar_obs_l', thisobs_l%ivar_obs_l - WRITE (*,*) '++ OMI-debug prodRinvA_l: ', debug, ' Input matrix A_l', A_l - END IF - IF (verbose == 1) THEN WRITE (*, '(a, 5x, a, 1x, i3)') & 'PDAFomi', '--- Domain localization for obs. type ID',thisobs%obsid @@ -1282,8 +1232,6 @@ SUBROUTINE PDAFomi_prodRinvA_l(thisobs_l, thisobs, nobs_all, ncols, & ! *** Initialize weight array - ALLOCATE(weight(thisobs_l%dim_obs_l)) - CALL PDAFomi_weights_l(verbose, thisobs_l%dim_obs_l, ncols, thisobs_l%locweight, & thisobs_l%cradius_l, thisobs_l%sradius_l, & A_l, thisobs_l%ivar_obs_l, thisobs_l%distance_l, weight) @@ -1323,8 +1271,84 @@ SUBROUTINE PDAFomi_prodRinvA_l(thisobs_l, thisobs, nobs_all, ncols, & END IF END DO END IF lw2 + END SUBROUTINE + +!------------------------------------------------------------------------------- +!> Compute product of inverse of R with some matrix +!! +!! The routine is called during the analysis step +!! on each local analysis domain. It has to +!! compute the product of the inverse of the local +!! observation error covariance matrix with +!! the matrix of locally observed ensemble +!! perturbations. +!! +!! Next to computing the product, a localizing +!! weighting ("observation localization") can be +!! applied to matrix A. +!! +!! This implementation assumes a diagonal observation +!! error covariance matrix, and supports varying +!! observation error variances. +!! +!! The routine can be applied with either all observations +!! of different types at once, or separately for each +!! observation type. +!! +!! __Revision history:__ +!! * 2019-06 - Lars Nerger - Initial code from restructuring observation routines +!! * Later revisions - see repository log +!! + SUBROUTINE PDAFomi_prodRinvA_l(thisobs_l, thisobs, nobs_all, ncols, & + A_l, C_l, verbose) + + IMPLICIT NONE + +! *** Arguments *** + TYPE(obs_l), INTENT(inout) :: thisobs_l !< Data type with local observation + TYPE(obs_f), INTENT(inout) :: thisobs !< Data type with full observation + INTEGER, INTENT(in) :: nobs_all !< Dimension of local obs. vector (all obs. types) + INTEGER, INTENT(in) :: ncols !< Rank of initial covariance matrix + REAL, INTENT(inout) :: A_l(:, :) !< Input matrix (thisobs_l%dim_obs_l, ncols) + REAL, INTENT(out) :: C_l(:, :) !< Output matrix (thisobs_l%dim_obs_l, ncols) + INTEGER, INTENT(in) :: verbose !< Verbosity flag + + +! *** local variables *** + INTEGER :: i, j ! Index of observation component + REAL, ALLOCATABLE :: weight(:) ! Localization weights + INTEGER :: idummy ! Dummy to access nobs_all + INTEGER :: off ! row offset in A_l and C_l +! ********************** +! *** INITIALIZATION *** +! ********************** + + doassim: IF (thisobs%doassim == 1) THEN + + ! Initialize dummy to prevent compiler warning + idummy = nobs_all + + ! Initialize offset + off = thisobs_l%off_obs_l + + ! Screen output + IF (debug>0) THEN + WRITE (*,*) '++ OMI-debug: ', debug, & + 'PDAFomi_prodrinva_l -- START Multiply with inverse R and and apply localization' + WRITE (*,*) '++ OMI-debug prodrinva_l: ', debug, ' thisobs_l%locweight', thisobs_l%locweight + IF (thisobs_l%locweight_v>0) & + WRITE (*,*) '++ OMI-debug prodrinva_l: ', debug, ' thisobs_l%locweight_v', thisobs_l%locweight_v + WRITE (*,*) '++ OMI-debug prodRinvA_l: ', debug, ' thisobs%dim_obs_l', thisobs_l%dim_obs_l + WRITE (*,*) '++ OMI-debug prodRinvA_l: ', debug, ' thisobs%ivar_obs_l', thisobs_l%ivar_obs_l + WRITE (*,*) '++ OMI-debug prodRinvA_l: ', debug, ' Input matrix A_l', A_l + END IF + + ALLOCATE(weight(thisobs_l%dim_obs_l)) + call PDAFomi_observation_localization_weights(thisobs_l, thisobs, ncols, A_l, & + weight, verbose) + ! *** Apply weight doweighting: IF (thisobs_l%locweight >= 11) THEN @@ -1337,13 +1361,13 @@ SUBROUTINE PDAFomi_prodRinvA_l(thisobs_l, thisobs, nobs_all, ncols, & END DO ! *** -1 - ! *** C = R A + ! *** C = R A DO j = 1, ncols DO i = 1, thisobs_l%dim_obs_l C_l(i+off, j) = thisobs_l%ivar_obs_l(i) * A_l(i+off, j) END DO END DO - + ELSE doweighting ! *** Apply weight to matrix R only @@ -1352,7 +1376,7 @@ SUBROUTINE PDAFomi_prodRinvA_l(thisobs_l, thisobs, nobs_all, ncols, & C_l(i+off, j) = thisobs_l%ivar_obs_l(i) * weight(i) * A_l(i+off, j) END DO END DO - + END IF doweighting ! *** Clean up *** @@ -3822,7 +3846,11 @@ SUBROUTINE PDAFomi_weights_l(verbose, nobs_l, ncols, locweight, cradius, sradius ! Control verbosity of PDAF_local_weight - IF (verbose==1) verbose_w = 1 + IF (verbose==1) THEN + verbose_w = 1 + ELSE + verbose_w = 0 + END IF IF (locweight /= 4) THEN ! All localizations except regulated weight based on variance at @@ -3977,7 +4005,11 @@ SUBROUTINE PDAFomi_weights_l_sgnl(verbose, nobs_l, ncols, locweight, cradius, sr ! Control verbosity of PDAF_local_weight - IF (verbose==1) verbose_w = 1 + IF (verbose==1) THEN + verbose_w = 1 + ELSE + verbose_w = 0 + END IF IF (locweight /= 4) THEN ! All localizations except regulated weight based on variance at diff --git a/src/PDAFomi_put_state_3dvar.F90 b/src/PDAFomi_put_state_3dvar.F90 index 9c950a23a..70d07a746 100644 --- a/src/PDAFomi_put_state_3dvar.F90 +++ b/src/PDAFomi_put_state_3dvar.F90 @@ -81,6 +81,7 @@ SUBROUTINE PDAFomi_put_state_3dvar(collect_state_pdaf, init_dim_obs_pdaf, obs_op prepoststep_pdaf, outflag) ELSE WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFomi_put_state_3dvar' + outflag = 200 END IF diff --git a/src/PDAFomi_put_state_3dvar_nondiagR.F90 b/src/PDAFomi_put_state_3dvar_nondiagR.F90 new file mode 100644 index 000000000..681b3e0f2 --- /dev/null +++ b/src/PDAFomi_put_state_3dvar_nondiagR.F90 @@ -0,0 +1,102 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_3dvar_nondiagR --- Interface to PDAF for 3D-Var +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_3dvar_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prepoststep_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + obs_op_pdafomi, & ! Observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + prodRinvA_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb ! Initialize observation vector + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_3dvar_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAF_put_state_3dvar(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prepoststep_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFomi_put_state_3dvar_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_3dvar_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_3dvar_nondiagR diff --git a/src/PDAFomi_put_state_en3dvar_estkf_nondiagR.F90 b/src/PDAFomi_put_state_en3dvar_estkf_nondiagR.F90 new file mode 100644 index 000000000..a7fd75a8f --- /dev/null +++ b/src/PDAFomi_put_state_en3dvar_estkf_nondiagR.F90 @@ -0,0 +1,103 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_en3dvar_estkf_nondiagR --- Interface to PDAF for En3D-Var/ESTKF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_en3dvar_estkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prepoststep_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + obs_op_pdafomi, & ! Observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + prodRinvA_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obsvar_cb ! Initialize mean observation error variance + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_en3dvar_estkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAF_put_state_en3dvar_estkf(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + PDAFomi_init_obsvar_cb, prepoststep_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFomi_put_state_en3dvar_estkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_en3dvar_estkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_en3dvar_estkf_nondiagR diff --git a/src/PDAFomi_put_state_en3dvar_lestkf_nondiagR.F90 b/src/PDAFomi_put_state_en3dvar_lestkf_nondiagR.F90 new file mode 100644 index 000000000..8447c8fdb --- /dev/null +++ b/src/PDAFomi_put_state_en3dvar_lestkf_nondiagR.F90 @@ -0,0 +1,116 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_en3dvar_lestkf_nondiagR --- Interface to PDAF for En3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_en3dvar_lestkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_pdafomi, & ! Provide product R^-1 A + prodRinvA_l_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_en3dvar_lestkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAF_put_state_en3dvar_lestkf(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, prepoststep_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFomi_put_state_en3dvar_lestkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_en3dvar_lestkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_en3dvar_lestkf_nondiagR diff --git a/src/PDAFomi_put_state_enkf_nondiagR.F90 b/src/PDAFomi_put_state_enkf_nondiagR.F90 new file mode 100644 index 000000000..3ba6ea62c --- /dev/null +++ b/src/PDAFomi_put_state_enkf_nondiagR.F90 @@ -0,0 +1,99 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_enkf_nondiagR --- Interface to PDAF for global filters +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_enkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, add_obs_error_pdafomi, init_obscovar_pdafomi, & + prepoststep_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + obs_op_pdafomi, & ! Observation operator + init_obscovar_pdafomi, & ! Initialize mean observation error variance + add_obs_error_pdafomi ! Add observation error covariance matrix + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A + PDAFomi_likelihood_cb ! Compute likelihood + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_enkf_nondiagR -- START' + + IF (TRIM(filterstr) == 'ENKF') THEN + CALL PDAF_put_state_enkf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, prepoststep_pdaf, add_obs_error_pdafomi, & + init_obscovar_pdafomi, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_put_state_enkf_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_enkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_enkf_nondiagR diff --git a/src/PDAFomi_put_state_enkf_nondiagR_si.F90 b/src/PDAFomi_put_state_enkf_nondiagR_si.F90 new file mode 100644 index 000000000..5967f6788 --- /dev/null +++ b/src/PDAFomi_put_state_enkf_nondiagR_si.F90 @@ -0,0 +1,75 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_enkf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_enkf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + ! Interface to PDAF-OMI for local and global filters + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_obscovar_pdafomi, & ! Initialize mean observation error variance + add_obs_error_pdafomi ! Add observation error covariance matrix + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_put_state_enkf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_put_state_enkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, add_obs_error_pdafomi, init_obscovar_pdafomi, & + prepoststep_pdaf, outflag) + +END SUBROUTINE PDAFomi_put_state_enkf_nondiagR_si diff --git a/src/PDAFomi_put_state_global_nondiagR.F90 b/src/PDAFomi_put_state_global_nondiagR.F90 new file mode 100644 index 000000000..e57d9f009 --- /dev/null +++ b/src/PDAFomi_put_state_global_nondiagR.F90 @@ -0,0 +1,116 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_global_nondiagR --- Interface to PDAF for global filters +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_global_nondiagR(collect_state_pdaf, & + init_dim_obs_pdaf, obs_op_pdaf, prodRinvA_pdaf, prepoststep_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdaf, & ! Initialize dimension of observation vector + obs_op_pdaf ! Observation operator + EXTERNAL :: prodRinvA_pdaf ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obscovar_cb, & ! Initialize mean observation error variance + PDAFomi_add_obs_error_cb ! Add observation error covariance matrix + + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_global_nondiagR -- START' + + IF (TRIM(filterstr) == 'SEIK') THEN + CALL PDAF_put_state_seik(collect_state_pdaf, init_dim_obs_pdaf, obs_op_pdaf, & + PDAFomi_init_obs_f_cb, prepoststep_pdaf, & + prodRinvA_pdaf, PDAFomi_init_obsvar_cb, outflag) + ELSEIF (TRIM(filterstr) == 'ENKF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFomi_put_state_enkf_nondiagR for EnKF' + outflag=200 + ELSEIF (TRIM(filterstr) == 'ETKF') THEN + CALL PDAF_put_state_etkf(collect_state_pdaf, init_dim_obs_pdaf, obs_op_pdaf, & + PDAFomi_init_obs_f_cb, prepoststep_pdaf, & + prodRinvA_pdaf, PDAFomi_init_obsvar_cb, outflag) + ELSEIF (TRIM(filterstr) == 'ESTKF') THEN + CALL PDAF_put_state_estkf(collect_state_pdaf, init_dim_obs_pdaf, obs_op_pdaf, & + PDAFomi_init_obs_f_cb, prepoststep_pdaf, & + prodRinvA_pdaf, PDAFomi_init_obsvar_cb, outflag) + ELSEIF (TRIM(filterstr) == 'NETF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFomi_put_state_nonlin_nondiagR for NETF and PF' + outflag=200 + ELSEIF (TRIM(filterstr) == 'PF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFomi_put_state_nonlin_nondiagR for NETF and PF' + outflag=200 + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_put_state_global_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_global_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_global_nondiagR diff --git a/src/PDAFomi_put_state_global_nondiagR_si.F90 b/src/PDAFomi_put_state_global_nondiagR_si.F90 new file mode 100644 index 000000000..de10367e6 --- /dev/null +++ b/src/PDAFomi_put_state_global_nondiagR_si.F90 @@ -0,0 +1,74 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_global_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_global_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + ! Interface to PDAF-OMI for local and global filters + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + prodRinvA_pdafomi ! Provide product R^-1 A + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_put_state_global_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_put_state_global_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, prepoststep_pdaf, & + outflag) + +END SUBROUTINE PDAFomi_put_state_global_nondiagR_si diff --git a/src/PDAFomi_put_state_hyb3dvar_estkf_nondiagR.F90 b/src/PDAFomi_put_state_hyb3dvar_estkf_nondiagR.F90 new file mode 100644 index 000000000..8cf10eb43 --- /dev/null +++ b/src/PDAFomi_put_state_hyb3dvar_estkf_nondiagR.F90 @@ -0,0 +1,107 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_hyb3dvar_estkf_nondiagR --- Interface to PDAF for Hyb3D-Var/ESTKF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_hyb3dvar_estkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prepoststep_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf, & ! Apply adjoint control vector transform matrix + cvt_ens_pdaf, & ! Apply ensemble control vector transform matrix to control vector + cvt_adj_ens_pdaf ! Apply adjoint ensemble control vector transform matrix + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + obs_op_pdafomi, & ! Observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + prodRinvA_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obsvar_cb ! Initialize mean observation error variance + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_hyb3dvar_estkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAF_put_state_hyb3dvar_estkf(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdafomi, obs_op_adj_pdafomi, PDAFomi_init_obsvar_cb, & + prepoststep_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFomi_put_state_hyb3dvar_estkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_hyb3dvar_estkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_hyb3dvar_estkf_nondiagR diff --git a/src/PDAFomi_put_state_hyb3dvar_lestkf_nondiagR.F90 b/src/PDAFomi_put_state_hyb3dvar_lestkf_nondiagR.F90 new file mode 100644 index 000000000..504a93303 --- /dev/null +++ b/src/PDAFomi_put_state_hyb3dvar_lestkf_nondiagR.F90 @@ -0,0 +1,120 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_hyb3dvar_lestkf_nondiagR --- Interface to PDAF for Hyb3D-Var/LESTKF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_hyb3dvar_lestkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, & + obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, prepoststep_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: cvt_ens_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_ens_pdaf, & ! Apply adjoint control vector transform matrix + cvt_pdaf, & ! Apply control vector transform matrix to control vector + cvt_adj_pdaf ! Apply adjoint control vector transform matrix + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + obs_op_lin_pdafomi, & ! Linearized observation operator + obs_op_adj_pdafomi, & ! Adjoint observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_pdafomi, & ! Provide product R^-1 A + prodRinvA_l_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_prodRinvA_cb, & ! Provide product R^-1 A + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_hyb3dvar_lestkf_nondiagR -- START' + + IF (TRIM(filterstr) == '3DVAR') THEN + CALL PDAF_put_state_hyb3dvar_lestkf(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, prodRinvA_pdafomi, & + cvt_ens_pdaf, cvt_adj_ens_pdaf, cvt_pdaf, cvt_adj_pdaf, obs_op_lin_pdafomi, obs_op_adj_pdafomi, & + init_dim_obs_pdafomi, obs_op_pdafomi, PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, & + init_dim_obs_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, PDAFomi_g2l_obs_cb, & + PDAFomi_init_obsvar_cb, PDAFomi_init_obsvar_l_cb, prepoststep_pdaf, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: No valid filter type for PDAFomi_put_state_hyb3dvar_lestkf_nondiagR' + outflag = 200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_hyb3dvar_lestkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_hyb3dvar_lestkf_nondiagR diff --git a/src/PDAFomi_put_state_lenkf_nondiagR.F90 b/src/PDAFomi_put_state_lenkf_nondiagR.F90 new file mode 100644 index 000000000..d19a51c1a --- /dev/null +++ b/src/PDAFomi_put_state_lenkf_nondiagR.F90 @@ -0,0 +1,94 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_lenkf_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_lenkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, localize_covar_pdafomi, & + add_obs_error_pdafomi, init_obscovar_pdafomi, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! Variant for LENKF with domain decomposition. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + obs_op_pdafomi, & ! Observation operator + localize_covar_pdafomi, & ! Apply localization to HP and HPH^T + init_obscovar_pdafomi, & ! Initialize mean observation error variance + add_obs_error_pdafomi ! Provide product R^-1 A + EXTERNAL :: PDAFomi_init_obs_f_cb ! Initialize observation vector + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAF_put_state_lenkf +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_lenkf_nondiagR -- START' + + CALL PDAF_put_state_lenkf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, prepoststep_pdaf, localize_covar_pdafomi, & + add_obs_error_pdafomi, init_obscovar_pdafomi, outflag) + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_lenkf_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_lenkf_nondiagR diff --git a/src/PDAFomi_put_state_lenkf_nondiagR_si.F90 b/src/PDAFomi_put_state_lenkf_nondiagR_si.F90 new file mode 100644 index 000000000..ede97b240 --- /dev/null +++ b/src/PDAFomi_put_state_lenkf_nondiagR_si.F90 @@ -0,0 +1,76 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_lenkf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_lenkf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + ! Interface to PDAF-OMI for local and global filters + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + localize_covar_pdafomi, & ! Apply localization to HP and HPH^T + init_obscovar_pdafomi, & ! Initialize mean observation error variance + add_obs_error_pdafomi ! Provide product R^-1 A + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_put_state_lenkf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_put_state_lenkf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, localize_covar_pdafomi, & + add_obs_error_pdafomi, init_obscovar_pdafomi, outflag) + +END SUBROUTINE PDAFomi_put_state_lenkf_nondiagR_si diff --git a/src/PDAFomi_put_state_lknetf_nondiagR.F90 b/src/PDAFomi_put_state_lknetf_nondiagR.F90 new file mode 100644 index 000000000..b3e470db6 --- /dev/null +++ b/src/PDAFomi_put_state_lknetf_nondiagR.F90 @@ -0,0 +1,114 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_lknetf_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_lknetf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdafomi, & ! Provide product R^-1 A on local analysis domain + likelihood_l_pdafomi, & ! Compute likelihood and apply localization + prodRinvA_hyb_l_pdafomi, & ! Product R^-1 A on local analysis domain with hybrid weight + likelihood_hyb_l_pdafomi ! Compute likelihood and apply localization with tempering + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_lknetf_nondiagR -- START' + + IF (TRIM(filterstr) == 'LKNETF') THEN + CALL PDAF_put_state_lknetf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, & + outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_put_state_lknetf_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_lknetf_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_lknetf_nondiagR diff --git a/src/PDAFomi_put_state_lknetf_nondiagR_si.F90 b/src/PDAFomi_put_state_lknetf_nondiagR_si.F90 new file mode 100644 index 000000000..153a5476f --- /dev/null +++ b/src/PDAFomi_put_state_lknetf_nondiagR_si.F90 @@ -0,0 +1,84 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_lknetf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_lknetf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + prodRinvA_l_pdafomi, & ! Provide product R^-1 A on local analysis domain + prodRinvA_hyb_l_pdafomi, & ! Provide product R^-1 A on local analysis domain with hybrid weight + likelihood_l_pdafomi, & ! Compute observation likelihood for an ensemble member + likelihood_hyb_l_pdafomi ! Compute observation likelihood for an ensemble member with hybrid weight + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_put_state_lknetf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_put_state_lknetf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, prodRinvA_hyb_l_pdafomi, & + likelihood_l_pdafomi, likelihood_hyb_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + outflag) + +END SUBROUTINE PDAFomi_put_state_lknetf_nondiagR_si diff --git a/src/PDAFomi_put_state_lnetf_nondiagR.F90 b/src/PDAFomi_put_state_lnetf_nondiagR.F90 new file mode 100644 index 000000000..5817b2bf7 --- /dev/null +++ b/src/PDAFomi_put_state_lnetf_nondiagR.F90 @@ -0,0 +1,107 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_lnetf_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_lnetf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, likelihood_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + likelihood_l_pdafomi ! Compute likelihood and apply localization + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_lnetf_nondiagR -- START' + + IF (TRIM(filterstr) == 'LNETF') THEN + CALL PDAF_put_state_lnetf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_l_cb, prepoststep_pdaf, likelihood_l_pdafomi, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + PDAFomi_g2l_obs_cb, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_put_state_lnetf_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_lnetf_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_lnetf_nondiagR diff --git a/src/PDAFomi_put_state_lnetf_nondiagR_si.F90 b/src/PDAFomi_put_state_lnetf_nondiagR_si.F90 new file mode 100644 index 000000000..f40da3d9b --- /dev/null +++ b/src/PDAFomi_put_state_lnetf_nondiagR_si.F90 @@ -0,0 +1,81 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_lnetf_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_lnetf_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + likelihood_l_pdafomi ! Compute likelihood and apply localization + + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_put_state_lnetf_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_put_state_lnetf_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, likelihood_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & + outflag) + +END SUBROUTINE PDAFomi_put_state_lnetf_nondiagR_si diff --git a/src/PDAFomi_put_state_local_nondiagR.F90 b/src/PDAFomi_put_state_local_nondiagR.F90 new file mode 100644 index 000000000..6258663a3 --- /dev/null +++ b/src/PDAFomi_put_state_local_nondiagR.F90 @@ -0,0 +1,126 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_local_nondiagR --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_local_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-07 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of full observation vector + obs_op_pdafomi, & ! Full observation operator + init_dim_obs_l_pdafomi, & ! Initialize local dimimension of obs. vector + prodRinvA_l_pdafomi ! Provide product of inverse of R with matrix A + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize full observation vector + PDAFomi_init_obs_l_cb, & ! Initialize local observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obsvar_l_cb, & ! Initialize local mean observation error variance + PDAFomi_g2l_obs_cb ! Restrict full obs. vector to local analysis domain + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_local_nondiagR -- START' + + IF (TRIM(filterstr) == 'LSEIK') THEN + CALL PDAF_put_state_lseik(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, outflag) + ELSE IF (TRIM(filterstr) == 'LETKF') THEN + CALL PDAF_put_state_letkf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, outflag) + ELSE IF (TRIM(filterstr) == 'LESTKF') THEN + CALL PDAF_put_state_lestkf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, PDAFomi_init_obs_l_cb, prepoststep_pdaf, & + prodRinvA_l_pdafomi, init_n_domains_pdaf, init_dim_l_pdaf, init_dim_obs_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, PDAFomi_g2l_obs_cb, PDAFomi_init_obsvar_cb, & + PDAFomi_init_obsvar_l_cb, outflag) + ELSE IF (TRIM(filterstr) == 'LNETF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFomi_put_state_lnetf_nondiagR for LNETF' + outflag=200 + ELSE IF (TRIM(filterstr) == 'LKNETF') THEN + WRITE (*,*) 'PDAF-ERROR: Use PDAFomi_put_state_lknetf_nondiagR for LKNETF' + outflag=200 + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_put_state_local_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_local_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_local_nondiagR diff --git a/src/PDAFomi_put_state_local_nondiagR_si.F90 b/src/PDAFomi_put_state_local_nondiagR_si.F90 new file mode 100644 index 000000000..4e566efe8 --- /dev/null +++ b/src/PDAFomi_put_state_local_nondiagR_si.F90 @@ -0,0 +1,80 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_local_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_local_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all domain-localized filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-07 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_n_domains_pdaf, & ! Provide number of local analysis domains + init_dim_l_pdaf, & ! Init state dimension for local ana. domain + g2l_state_pdaf, & ! Get state on local ana. domain from full state + l2g_state_pdaf ! Init full state from local state + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain + prodRinvA_l_pdafomi ! Provide product of inverse of R with matrix A + + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_put_state_local_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_put_state_local_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, & + g2l_state_pdaf, l2g_state_pdaf, outflag) + +END SUBROUTINE PDAFomi_put_state_local_nondiagR_si diff --git a/src/PDAFomi_put_state_nonlin_nondiagR.F90 b/src/PDAFomi_put_state_nonlin_nondiagR.F90 new file mode 100644 index 000000000..5870feda1 --- /dev/null +++ b/src/PDAFomi_put_state_nonlin_nondiagR.F90 @@ -0,0 +1,101 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_nonlin_nondiagR --- Interface to PDAF for global filters +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_nonlin_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, likelihood_pdafomi, prepoststep_pdaf, & + outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + USE PDAF_mod_filter, ONLY: filterstr, debug + USE PDAFomi, ONLY: PDAFomi_dealloc + + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + EXTERNAL :: init_dim_obs_pdafomi, & ! Initialize dimension of observation vector + obs_op_pdafomi, & ! Observation operator + likelihood_pdafomi ! Compute likelihood + EXTERNAL :: PDAFomi_init_obs_f_cb, & ! Initialize observation vector + PDAFomi_init_obsvar_cb, & ! Initialize mean observation error variance + PDAFomi_init_obscovar_cb, & ! Initialize mean observation error variance + PDAFomi_add_obs_error_cb ! Add observation error covariance matrix + +! !CALLING SEQUENCE: +! Called by: model code +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_nonlin_nondiagR -- START' + + IF (TRIM(filterstr) == 'NETF') THEN + CALL PDAF_put_state_netf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, prepoststep_pdaf, likelihood_pdafomi, outflag) + ELSEIF (TRIM(filterstr) == 'PF') THEN + CALL PDAF_put_state_pf(collect_state_pdaf, init_dim_obs_pdafomi, obs_op_pdafomi, & + PDAFomi_init_obs_f_cb, prepoststep_pdaf, likelihood_pdafomi, outflag) + ELSE + WRITE (*,*) 'PDAF-ERROR: Invalid filter choice for PDAFomi_put_state_nonlin_nondiagR' + outflag=200 + END IF + + +! ******************************************* +! *** Deallocate and re-init observations *** +! ******************************************* + + CALL PDAFomi_dealloc() + + IF (debug>0) & + WRITE (*,*) '++ PDAFomi-debug: ', debug, 'PDAFomi_put_state_nonlin_nondiagR -- END' + +END SUBROUTINE PDAFomi_put_state_nonlin_nondiagR diff --git a/src/PDAFomi_put_state_nonlin_nondiagR_si.F90 b/src/PDAFomi_put_state_nonlin_nondiagR_si.F90 new file mode 100644 index 000000000..d48711311 --- /dev/null +++ b/src/PDAFomi_put_state_nonlin_nondiagR_si.F90 @@ -0,0 +1,74 @@ +! Copyright (c) 2004-2024 Lars Nerger +! +! This file is part of PDAF. +! +! PDAF is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License +! as published by the Free Software Foundation, either version +! 3 of the License, or (at your option) any later version. +! +! PDAF is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public +! License along with PDAF. If not, see . +! +!$Id$ +!BOP +! +! !ROUTINE: PDAFomi_put_state_nonlin_nondiagR_si --- Interface to transfer state to PDAF +! +! !INTERFACE: +SUBROUTINE PDAFomi_put_state_nonlin_nondiagR_si(outflag) + +! !DESCRIPTION: +! Interface routine called from the model during the +! forecast of each ensemble state to transfer data +! from the model to PDAF and to perform the analysis +! step. +! +! This routine provides the simplified interface +! where names of user-provided subroutines are +! fixed. It simply calls the routine with the +! full interface using pre-defined routine names. +! +! The routine supports all global filters. +! +! ! This is a core routine of PDAF and +! should not be changed by the user ! +! +! !REVISION HISTORY: +! 2024-08 - Lars Nerger - Initial code +! Later revisions - see svn log +! +! !USES: + IMPLICIT NONE + +! !ARGUMENTS: + INTEGER, INTENT(inout) :: outflag ! Status flag + +! ! Names of external subroutines + EXTERNAL :: collect_state_pdaf, & ! Routine to collect a state vector + prepoststep_pdaf ! User supplied pre/poststep routine + ! Interface to PDAF-OMI for local and global filters + EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain + obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain + likelihood_pdafomi ! Compute likelihood + +! !CALLING SEQUENCE: +! Called by: model code +! Calls: PDAFomi_put_state_nonlin_nondiagR +!EOP + + +! ************************************************** +! *** Call the full put_state interface routine *** +! ************************************************** + + CALL PDAFomi_put_state_nonlin_nondiagR(collect_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, likelihood_pdafomi, prepoststep_pdaf, & + outflag) + +END SUBROUTINE PDAFomi_put_state_nonlin_nondiagR_si From 66655f7166b21144c96b0e8cca7e1ca371ad9cce Mon Sep 17 00:00:00 2001 From: ewerdwalbesloh1 Date: Tue, 16 Dec 2025 17:51:56 +0100 Subject: [PATCH 22/32] Add full observation error covariance matrix for PDAF-OMI --- interface/framework/assimilate_pdaf.F90 | 30 +- interface/framework/callback_obs_pdafomi.F90 | 91 +++- interface/framework/obs_GRACE_pdafomi.F90 | 461 ++++++++++++++++++- interface/framework/obs_SM_pdafomi.F90 | 215 +++++++++ 4 files changed, 781 insertions(+), 16 deletions(-) diff --git a/interface/framework/assimilate_pdaf.F90 b/interface/framework/assimilate_pdaf.F90 index f7663024b..5492ef2f3 100644 --- a/interface/framework/assimilate_pdaf.F90 +++ b/interface/framework/assimilate_pdaf.F90 @@ -49,7 +49,9 @@ SUBROUTINE assimilate_pdaf() #ifdef CLMFIVE USE PDAF_interfaces_module, & ! Check consistency of PDAF calls ONLY: PDAFomi_assimilate_local, PDAFomi_assimilate_global, & - PDAFomi_assimilate_lenkf, PDAF_get_localfilter + PDAFomi_assimilate_lenkf, PDAF_get_localfilter, & + PDAFomi_assimilate_enkf_nondiagR, & + PDAFomi_assimilate_global_nondiagR, PDAFomi_assimilate_local_nondiagR #endif IMPLICIT NONE @@ -112,7 +114,11 @@ SUBROUTINE assimilate_pdaf() EXTERNAL :: init_dim_obs_pdafomi, & ! Get dimension of full obs. vector for PE-local domain obs_op_pdafomi, & ! Obs. operator for full obs. vector for PE-local domain init_dim_obs_l_pdafomi, & ! Get dimension of obs. vector for local analysis domain - localize_covar_pdafomi ! Apply localization to covariance matrix in LEnKF + localize_covar_pdafomi, & ! Apply localization to covariance matrix in LEnKF + add_obs_err_pdafomi, & ! Add obs. error covariance R to HPH in EnKF + init_obscovar_pdafomi, & ! Initialize obs error covar R in EnKF + prodRinvA_pdafomi, & ! Provide product R^-1 A for some matrix A + prodRinvA_l_pdafomi ! Provide product R^-1 A for some local matrix A @@ -133,10 +139,11 @@ SUBROUTINE assimilate_pdaf() IF (localfilter == 1) THEN - CALL PDAFomi_assimilate_local(collect_state_pdaf, distribute_state_pdaf, & - init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_ens_pdaf, init_n_domains_pdaf, & - init_dim_l_pdaf, init_dim_obs_l_pdafomi, g2l_state_pdaf, l2g_state_pdaf, & - next_observation_pdaf, status_pdaf) + CALL PDAFomi_assimilate_local_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_ens_pdaf, init_n_domains_pdaf, & + init_dim_l_pdaf, init_dim_obs_l_pdafomi, prodRinvA_l_pdafomi, g2l_state_pdaf, & + l2g_state_pdaf, next_observation_pdaf, status_pdaf) + ELSE @@ -146,11 +153,16 @@ SUBROUTINE assimilate_pdaf() init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_ens_pdaf, & localize_covar_pdafomi, next_observation_pdaf, status_pdaf) + ELSEIF (filtertype == 2) then ! non diagonal R for EnKF has its own callback routine + CALL PDAFomi_assimilate_enkf_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, add_obs_err_pdafomi, init_obscovar_pdafomi, & + prepoststep_ens_pdaf, next_observation_pdaf, status_pdaf) + ELSE - CALL PDAFomi_assimilate_global(collect_state_pdaf, distribute_state_pdaf, & - init_dim_obs_pdafomi, obs_op_pdafomi, prepoststep_ens_pdaf, & - next_observation_pdaf, status_pdaf) + CALL PDAFomi_assimilate_global_nondiagR(collect_state_pdaf, distribute_state_pdaf, & + init_dim_obs_pdafomi, obs_op_pdafomi, prodRinvA_pdafomi, & + prepoststep_ens_pdaf, next_observation_pdaf, status_pdaf) ENDIF diff --git a/interface/framework/callback_obs_pdafomi.F90 b/interface/framework/callback_obs_pdafomi.F90 index a4e75fc9a..f91e24847 100644 --- a/interface/framework/callback_obs_pdafomi.F90 +++ b/interface/framework/callback_obs_pdafomi.F90 @@ -33,7 +33,7 @@ ! Author: Yorck Ewerdwalbesloh #ifdef CLMFIVE -SUBROUTINE init_dim_obs_pdafomi(step, dim_obs) + SUBROUTINE init_dim_obs_pdafomi(step, dim_obs) use enkf_clm_mod, only: clmupdate_swc, clmupdate_tws @@ -227,4 +227,93 @@ SUBROUTINE localize_covar_pdafomi(dim_p, dim_obs, HP_p, HPH) DEALLOCATE(coords_p) END SUBROUTINE localize_covar_pdafomi + + + SUBROUTINE add_obs_err_pdafomi(step, dim_obs, C) + + USE obs_GRACE_pdafomi, ONLY: add_obs_err_GRACE + USE obs_SM_pdafomi, ONLY: add_obs_err_SM + + IMPLICIT NONE + + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs ! Dimension of obs. vector + REAL, INTENT(inout) :: C(dim_obs, dim_obs) ! Matrix to that the observation + ! error covariance matrix is added + + + INTEGER :: i ! index of observation component + REAL :: variance_obs ! variance of observations + CALL add_obs_err_GRACE(step, dim_obs, C) + CALL add_obs_err_SM(step, dim_obs, C) + !CALL add_obs_err_C(step, dim_obs, C) + + END SUBROUTINE add_obs_err_pdafomi + + + SUBROUTINE init_obscovar_pdafomi(step, dim_obs, dim_obs_p, covar, m_state_p, isdiag) + + USE obs_GRACE_pdafomi, ONLY: init_obscovar_GRACE + USE obs_SM_pdafomi, ONLY: init_obscovar_SM + IMPLICIT NONE + + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs ! Dimension of observation vector + INTEGER, INTENT(in) :: dim_obs_p ! PE-local dimension of observation vector + REAL, INTENT(out) :: covar(dim_obs, dim_obs) ! Observation error covariance matrix + REAL, INTENT(in) :: m_state_p(dim_obs_p) ! PE-local observation vector + LOGICAL, INTENT(out) :: isdiag ! Whether the observation error covar. matrix is diagonal + + integer :: i + REAL :: variance_obs + + + CALL init_obscovar_GRACE(step, dim_obs, dim_obs_p, covar, m_state_p, isdiag) + CALL init_obscovar_SM(step, dim_obs, dim_obs_p, covar, m_state_p, isdiag) + !CALL init_obscovar_C(step, dim_obs, dim_obs_p, covar, m_state_p, isdiag) + + END SUBROUTINE init_obscovar_pdafomi + + + SUBROUTINE prodRinvA_pdafomi(step, dim_obs_p, rank, obs_p, A_p, C_p) + + use obs_GRACE_pdafomi, ONLY: prodRinvA_GRACE + use obs_SM_pdafomi, ONLY: prodRinvA_SM + + implicit none + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs_p ! PE-local dimension of obs. vector + INTEGER, INTENT(in) :: rank ! Rank of initial covariance matrix + REAL, INTENT(in) :: obs_p(dim_obs_p) ! PE-local vector of observations + REAL, INTENT(in) :: A_p(dim_obs_p,rank) ! Input matrix from analysis routine + REAL, INTENT(out) :: C_p(dim_obs_p,rank) ! Output matrix + + CALL prodRinvA_GRACE(step, dim_obs_p, rank, obs_p, A_p, C_p) + CALL prodRinvA_SM(step, dim_obs_p, rank, obs_p, A_p, C_p) + !CALL prodRinvA_C(step, dim_obs_p, rank, obs_p, A_p, C_p) + + END SUBROUTINE prodRinvA_pdafomi + + + SUBROUTINE prodRinvA_l_pdafomi(domain_p, step, dim_obs_l, rank, obs_l, A_l, C_l) + + use obs_GRACE_pdafomi, ONLY: prodRinvA_l_GRACE + use obs_SM_pdafomi, ONLY: prodRinvA_l_SM + + implicit none + + INTEGER, INTENT(in) :: domain_p ! Current local analysis domain + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs_l ! Dimension of local observation vector + INTEGER, INTENT(in) :: rank ! Rank of initial covariance matrix + REAL, INTENT(in) :: obs_l(dim_obs_l) ! Local vector of observations + REAL, INTENT(inout) :: A_l(dim_obs_l, rank) ! Input matrix from analysis routine + REAL, INTENT(out) :: C_l(dim_obs_l, rank) ! Output matrix + + CALL prodRinvA_l_GRACE(domain_p, step, dim_obs_l, rank, obs_l, A_l, C_l) + CALL prodRinvA_l_SM(domain_p, step, dim_obs_l, rank, obs_l, A_l, C_l) + !CALL prodRinvA_l_C(domain_p, step, dim_obs_l, rank, obs_l, A_l, C_l) + + END SUBROUTINE prodRinvA_l_pdafomi + #endif diff --git a/interface/framework/obs_GRACE_pdafomi.F90 b/interface/framework/obs_GRACE_pdafomi.F90 index 5da404a9d..8bf2d7b11 100644 --- a/interface/framework/obs_GRACE_pdafomi.F90 +++ b/interface/framework/obs_GRACE_pdafomi.F90 @@ -172,19 +172,25 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) USE mpi, ONLY: MPI_SUM USE mpi, ONLY: MPI_2INTEGER USE mpi, ONLY: MPI_MAXLOC + USE mpi, ONLY: MPI_IN_PLACE + + USE mod_parallel_pdaf, & + ONLY: mype_filter, comm_filter, npes_filter, abort_parallel, & + mype_world USE PDAFomi, & ONLY: PDAFomi_gather_obs USE mod_assimilation, & - ONLY: filtertype, cradius_GRACE, obs_filename, temp_mean_filename, screen + ONLY: filtertype, cradius_GRACE, obs_filename, temp_mean_filename, screen, obscov, obscov_inv + + use mod_assimilation, only: obs_nc2pdaf, obs_pdaf2nc, & + local_dims_obs, & + local_disp_obs use mod_read_obs, only: read_obs_nc_type, domain_def_clm, multierr use enkf_clm_mod, only: num_layer, hactiveg_levels - use mod_parallel_pdaf, & - only: comm_filter - use shr_kind_mod, only: r8 => shr_kind_r8 use GridcellType, only: grc @@ -211,6 +217,7 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) REAL, ALLOCATABLE :: obs_g(:) ! Global observation vector REAL, ALLOCATABLE :: ivar_obs_p(:) ! PE-local inverse observation error variance REAL, ALLOCATABLE :: ocoord_p(:,:) ! PE-local observation coordinates + REAL, ALLOCATABLE :: clm_obscov(:,:) ! full observation error covariance matrix before removing observations that cannot be seen by enough gridcells CHARACTER(len=2) :: stepstr ! String for time step character (len = 110) :: current_observation_filename @@ -225,7 +232,6 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) INTEGER, ALLOCATABLE :: layer_obs(:) REAL, ALLOCATABLE :: dr_obs(:) REAL, ALLOCATABLE :: obserr(:) - REAL, ALLOCATABLE :: obscov(:,:) integer :: begp, endp ! per-proc beginning and ending pft indices integer :: begc, endc ! per-proc beginning and ending column indices @@ -241,6 +247,13 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) real :: deltax, deltay + INTEGER, ALLOCATABLE :: ipiv(:) + real(r8), ALLOCATABLE :: work(:) + + real(r8) :: work_query + integer :: lwork + + integer :: countR, countC, info ! ********************************************* @@ -284,7 +297,7 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) write(current_observation_filename, '(a, i5.5)') trim(obs_filename)//'.', step call read_obs_nc_type(current_observation_filename, obs_type_name, & dim_obs, obs_g, lon_obs, lat_obs, layer_obs, & - dr_obs, obserr, obscov) + dr_obs, obserr, clm_obscov) if (mype_filter==0 .and. screen > 2) then write(*,*)'Done: load observations from type GRACE' end if @@ -428,6 +441,57 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) end do + ! now obtain information about which observation is on which PE --> necessary for full VCV matrix later on + ! Allocate array of PE-local observation dimensions + IF (ALLOCATED(local_dims_obs)) DEALLOCATE(local_dims_obs) + ALLOCATE(local_dims_obs(npes_filter)) + + ! Gather array of PE-local observation dimensions + call mpi_allgather(dim_obs_p, 1, MPI_INTEGER, local_dims_obs, 1, MPI_INTEGER, & + comm_filter, ierror) + + ! Allocate observation displacement array local_disp_obs + IF (ALLOCATED(local_disp_obs)) DEALLOCATE(local_disp_obs) + ALLOCATE(local_disp_obs(npes_filter)) + + ! Set observation displacement array local_disp_obs + local_disp_obs(1) = 0 + do i = 2, npes_filter + local_disp_obs(i) = local_disp_obs(i-1) + local_dims_obs(i-1) + end do + + if (mype_filter==0 .and. screen > 2) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_pdaf: local_disp_obs=", local_disp_obs + end if + + if (allocated(obs_nc2pdaf)) deallocate(obs_nc2pdaf) + allocate(obs_nc2pdaf(count(vec_useObs_global))) + obs_nc2pdaf = 0 + + if (allocated(obs_pdaf2nc)) deallocate(obs_pdaf2nc) + allocate(obs_pdaf2nc(count(vec_useObs_global))) + obs_pdaf2nc = 0 + + + cnt = 0 + j = 0 + do i = 1, dim_obs + if (vec_useObs_global(i)) then + j = j + 1 + end if + if (vec_useObs(i)) then + cnt = cnt + 1 + obs_nc2pdaf(j) = local_disp_obs(mype_filter+1) + cnt + obs_pdaf2nc(local_disp_obs(mype_filter+1) + cnt) = j + end if + end do + + ! collect values from all PEs, by adding all PE-local arrays (works + ! since only the subsection belonging to a specific PE is non-zero) + call mpi_allreduce(MPI_IN_PLACE,obs_pdaf2nc,count(vec_useObs_global),MPI_INTEGER,MPI_SUM,comm_filter,ierror) + call mpi_allreduce(MPI_IN_PLACE,obs_nc2pdaf,count(vec_useObs_global),MPI_INTEGER,MPI_SUM,comm_filter,ierror) + + IF (ALLOCATED(obs_p)) DEALLOCATE(obs_p) ALLOCATE(obs_p(dim_obs_p)) @@ -438,9 +502,51 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) IF (ALLOCATED(ocoord_p)) DEALLOCATE(ocoord_p) ALLOCATE(ocoord_p(2, dim_obs_p)) + if (multierr==0) then + cnt_p = 1 + do i = 1, dim_obs + if (vec_useObs(i)) then + ivar_obs_p(cnt_p) = 1.0/(rms_obs_GRACE*rms_obs_GRACE) + cnt_p = cnt_p + 1 + end if + end do + end if if (multierr==1) ivar_obs_p = pack(1/obserr, vec_useObs) + if (multierr==2) then + + if (allocated(obscov)) deallocate(obscov) + allocate(obscov(count(vec_useObs_global), count(vec_useObs_global))) + countR = 1 + countC = 1 + do i = 1, dim_obs + if (vec_useObs_global(i)) then + do j = 1, dim_obs + if (vec_useObs_global(j)) then + obscov(countR, countC) = clm_obscov(i,j) + countC = countC + 1 + end if + end do + countC = 1 + countR = countR + 1 + end if + end do + + cnt_p = 1 + countC = 1 + do i = 1, dim_obs + if (vec_useObs(i)) then + ivar_obs_p(cnt_p) = 1.0/obscov(countC,countC) + cnt_p = cnt_p + 1 + end if + if (vec_useObs_global(i)) then + countC = countC + 1 + end if + end do + + end if + cnt_p = 1 do i = 1, dim_obs if (vec_useObs(i)) then @@ -452,6 +558,38 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) end do dim_obs = count(vec_useObs_global) + + if (multierr.eq.2) then ! compute inverse of covariance matrix for prodRinvA, has to be before PDAFomi_gather_obs because the routine changes dim_obs + + if (allocated(obscov_inv)) deallocate(obscov_inv) + allocate(obscov_inv(dim_obs, dim_obs)) + + obscov_inv = obscov + + if (allocated(ipiv)) deallocate(ipiv) + ALLOCATE(ipiv(dim_obs)) + + call dgetrf(dim_obs, dim_obs, obscov_inv, dim_obs, ipiv, info) + if (info /= 0) then + print *, "Error in dgetrf, info =", info + stop + end if + + lwork = -1 + call dgetri(dim_obs, obscov_inv, dim_obs, ipiv, work_query, lwork, info) + lwork = int(work_query) + if (allocated(work)) deallocate(work) + allocate(work(lwork)) + call dgetri(dim_obs, obscov_inv, dim_obs, ipiv, work, lwork, info) + if (info /= 0) then + print *, "Error in dgetri, info =", info + stop + end if + + end if + + + ! **************************************** ! *** Gather global observation arrays *** ! **************************************** @@ -836,6 +974,317 @@ SUBROUTINE localize_covar_GRACE(dim_p, dim_obs, HP_p, HPH, coords_p) END SUBROUTINE localize_covar_GRACE + subroutine add_obs_err_GRACE(step, dim_obs, C) + + use mod_assimilation, only: obscov, obs_pdaf2nc + use mod_read_obs, only: multierr + USE mod_parallel_pdaf, & + ONLY: npes_filter + + use PDAFomi, only: obsdims + + implicit none + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs ! Dimension of observation vector + REAL, INTENT(inout) :: C(dim_obs,dim_obs) ! Matrix to that + ! observation covariance R is added + integer :: i, pe, cnt, j + INTEGER, ALLOCATABLE :: id_start(:) ! Start index of obs. type in global averall obs. vector + INTEGER, ALLOCATABLE :: id_end(:) ! End index of obs. type in global averall obs. vector + + ALLOCATE(id_start(npes_filter), id_end(npes_filter)) + + pe = 1 + id_start(1) = 1 + IF (thisobs%obsid>1) id_start(1) = id_start(1) + sum(obsdims(1, 1:thisobs%obsid-1)) + id_end(1) = id_start(1) + obsdims(1,thisobs%obsid) - 1 + DO pe = 2, npes_filter + id_start(pe) = id_start(pe-1) + SUM(obsdims(pe-1,thisobs%obsid:)) + IF (thisobs%obsid>1) id_start(pe) = id_start(pe) + sum(obsdims(pe,1:thisobs%obsid-1)) + id_end(pe) = id_start(pe) + obsdims(pe,thisobs%obsid) - 1 + END DO + + select case (multierr) + case(0,1) + cnt = 1 + DO pe = 1, npes_filter + DO i = id_start(pe), id_end(pe) + C(i,i) = C(i,i) + 1.0/thisobs%ivar_obs_f(cnt) + cnt = cnt + 1 + end do + end do + case(2) + + do i=1, thisobs%dim_obs_f + do j=1, thisobs%dim_obs_f + C(i,j) = C(i,j) + obscov(obs_pdaf2nc(i),obs_pdaf2nc(j)) + end do + end do + end select + + + DEALLOCATE(id_start, id_end) + + end subroutine add_obs_err_GRACE + + + subroutine init_obscovar_GRACE(step, dim_obs, dim_obs_p, covar, m_state_p, isdiag) + + use mod_read_obs, only: multierr + + USE mod_parallel_pdaf, & + ONLY: npes_filter + + use PDAFomi, only: obsdims, map_obs_id + + use mod_assimilation, only: obs_pdaf2nc, obscov + + implicit none + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs ! Dimension of observation vector + INTEGER, INTENT(in) :: dim_obs_p ! PE-local dimension of observation vector + REAL, INTENT(inout) :: covar(dim_obs, dim_obs) ! Observation error covariance matrix + REAL, INTENT(in) :: m_state_p(dim_obs_p) ! PE-local observation vector + LOGICAL, INTENT(inout) :: isdiag ! Whether the observation error covar. matrix is diagonal + + integer :: i, pe, cnt, j + INTEGER, ALLOCATABLE :: id_start(:) ! Start index of obs. type in global averall obs. vector + INTEGER, ALLOCATABLE :: id_end(:) ! End index of obs. type in global averall obs. vector + + ALLOCATE(id_start(npes_filter), id_end(npes_filter)) + + ! Initialize indices + pe = 1 + id_start(1) = 1 + IF (thisobs%obsid>1) id_start(1) = id_start(1) + sum(obsdims(1, 1:thisobs%obsid-1)) + id_end(1) = id_start(1) + obsdims(1,thisobs%obsid) - 1 + DO pe = 2, npes_filter + id_start(pe) = id_start(pe-1) + SUM(obsdims(pe-1,thisobs%obsid:)) + IF (thisobs%obsid>1) id_start(pe) = id_start(pe) + sum(obsdims(pe,1:thisobs%obsid-1)) + id_end(pe) = id_start(pe) + obsdims(pe,thisobs%obsid) - 1 + END DO + + ! Initialize mapping vector (to be used in PDAF_enkf_obs_ensemble) + cnt = 1 + IF (thisobs%obsid-1 > 0) cnt = cnt+ SUM(obsdims(:,1:thisobs%obsid-1)) + DO pe = 1, npes_filter + DO i = id_start(pe), id_end(pe) + map_obs_id(i) = cnt + cnt = cnt + 1 + END DO + END DO + + select case(multierr) + case(0,1) + + cnt = 1 + DO pe = 1, npes_filter + DO i = id_start(pe), id_end(pe) + covar(i, i) = covar(i, i) + 1.0/thisobs%ivar_obs_f(cnt) + cnt = cnt + 1 + ENDDO + ENDDO + + ! The matrix is diagonal + ! This setting avoids the computation of the SVD of COVAR + ! in PDAF_enkf_obs_ensemble + isdiag = .TRUE. + case(2) + + do i=1, thisobs%dim_obs_f + do j=1, thisobs%dim_obs_f + covar(i, i) = obscov(obs_pdaf2nc(i),obs_pdaf2nc(j)) + end do + end do + + isdiag = .FALSE. + + end select + + + DEALLOCATE(id_start, id_end) + + + end subroutine init_obscovar_GRACE + + + subroutine prodRinvA_GRACE(step, dim_obs_p, rank, obs_p, A_p, C_p) + + use mod_read_obs, only: multierr + use mod_assimilation, only: obscov_inv, obs_pdaf2nc + use shr_kind_mod, only: r8 => shr_kind_r8 + + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs_p ! PE-local dimension of obs. vector + INTEGER, INTENT(in) :: rank ! Rank of initial covariance matrix + REAL, INTENT(in) :: obs_p(dim_obs_p) ! PE-local vector of observations + REAL, INTENT(in) :: A_p(dim_obs_p,rank) ! Input matrix from analysis routine + REAL, INTENT(inout) :: C_p(dim_obs_p,rank) ! Output matrix + + INTEGER :: i, j ! index of observation component + INTEGER :: off ! row offset in A_l and C_l + + real(r8) :: obscov_inv_l(thisobs%dim_obs_f,thisobs%dim_obs_f) ! errors of observations in the model domain + + off = thisobs%off_obs_f ! account for offset if multiple observation types are assimilated at once + + select case (multierr) + case(0,1) + do j=1, rank + do i=1, thisobs%dim_obs_f + C_p(i+off, j) = thisobs%ivar_obs_f(i) * A_p(i+off, j) + END DO + end do + + case(2) + do i =1, thisobs%dim_obs_f + do j = 1, thisobs%dim_obs_f + obscov_inv_l(i,j) = obscov_inv(obs_pdaf2nc(i),obs_pdaf2nc(j)) + end do + end do + C_p(off+1:off+thisobs%dim_obs_f,:) = matmul(obscov_inv_l,A_p(off+1:off+thisobs%dim_obs_f,:)) + end select + + + end subroutine prodRinvA_GRACE + + + subroutine prodRinvA_l_GRACE(domain_p, step, dim_obs, rank, obs_l, A_l, C_l) + + use shr_kind_mod, only: r8 => shr_kind_r8 + use mod_assimilation, only: obscov, obs_pdaf2nc, cradius_GRACE, locweight + use mod_read_obs, only: multierr + use PDAFomi, only: PDAFomi_observation_localization_weights + + implicit none + + INTEGER, INTENT(in) :: domain_p ! Current local analysis domain + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs ! Dimension of local observation vector, multiple observation types possible, then we have to access with thisobs_l%dim_obs_l + INTEGER, INTENT(in) :: rank ! Rank of initial covariance matrix + REAL, INTENT(in) :: obs_l(dim_obs) ! Local vector of observations + REAL, INTENT(inout) :: A_l(dim_obs, rank) ! Input matrix from analysis routine + REAL, INTENT(out) :: C_l(dim_obs, rank) ! Output matrix + + INTEGER :: verbose ! Verbosity flag + INTEGER :: verbose_w ! Verbosity flag for weight computation + INTEGER, SAVE :: domain_save = -1 ! Save previous domain index + INTEGER :: wtype ! Type of weight function + INTEGER :: rtype ! Type of weight regulation + REAL, ALLOCATABLE :: weight(:) ! Localization weights + REAL, ALLOCATABLE :: A_obs(:,:) ! Array for a single row of A_l + REAL :: var_obs ! Variance of observation error + + INTEGER :: i, j + + INTEGER :: off ! row offset in A_l and C_l + INTEGER :: idummy ! Dummy to access nobs_all + + real(r8) :: ivariance_obs + + REAL(r8) :: obscov_l(thisobs_l%dim_obs_l,thisobs_l%dim_obs_l) ! local observation covariance matrix + REAL(r8) :: obscov_inv_l(thisobs_l%dim_obs_l,thisobs_l%dim_obs_l) ! inverse of local observation covariance matrix + + INTEGER, ALLOCATABLE :: ipiv(:) + real(r8), ALLOCATABLE :: work(:) + INTEGER :: info, lwork + real(r8) :: work_query + + real(r8) :: maxdiff + + + off = thisobs_l%off_obs_l + idummy = dim_obs + + IF ((domain_p <= domain_save .OR. domain_save < 0) .AND. mype_filter==0) THEN + verbose = 1 + ELSE + verbose = 0 + END IF + domain_save = domain_p + + ! Screen output + IF (verbose == 1) THEN + WRITE (*, '(8x, a, f12.3)') & + '--- Use global rms for observations of ', rms_obs_GRACE + WRITE (*, '(8x, a, 1x)') & + '--- Domain localization' + WRITE (*, '(12x, a, 1x, f12.2)') & + '--- Local influence radius', cradius_GRACE + + IF (locweight > 0) THEN + WRITE (*, '(12x, a)') & + '--- Use distance-dependent weight for observation errors' + + IF (locweight == 3) THEN + write (*, '(12x, a)') & + '--- Use regulated weight with mean error variance' + ELSE IF (locweight == 4) THEN + write (*, '(12x, a)') & + '--- Use regulated weight with single-point error variance' + END IF + END IF + ENDIF + + ALLOCATE(weight(thisobs_l%dim_obs_l)) + call PDAFomi_observation_localization_weights(thisobs_l, thisobs, rank, A_l, & + weight, verbose) + + select case(multierr) + case(0,1) + do j=1,rank + do i=1,thisobs_l%dim_obs_l + C_l(i+off,j) = thisobs_l%ivar_obs_l(i) * weight(i) * A_l(i+off, j) + end do + end do + + case(2) + + obscov_l = 0.0_r8 + + do i=1, thisobs_l%dim_obs_l ! fill local observation covariance matrix, invert it and apply it to A_l + do j=1, thisobs_l%dim_obs_l + obscov_l(i,j) = obscov(obs_pdaf2nc(thisobs_l%id_obs_l(i)),obs_pdaf2nc(thisobs_l%id_obs_l(j))) + end do + end do + + obscov_inv_l = obscov_l + + if (allocated(ipiv)) deallocate(ipiv) + ALLOCATE(ipiv(thisobs_l%dim_obs_l)) + + call dgetrf(thisobs_l%dim_obs_l, thisobs_l%dim_obs_l, obscov_inv_l, thisobs_l%dim_obs_l, ipiv, info) + if (info /= 0) then + print *, "Error in dgetrf, info =", info + stop + end if + + lwork = -1 + call dgetri(thisobs_l%dim_obs_l, obscov_inv_l, thisobs_l%dim_obs_l, ipiv, work_query, lwork, info) + lwork = int(work_query) + if (allocated(work)) deallocate(work) + allocate(work(lwork)) + call dgetri(thisobs_l%dim_obs_l, obscov_inv_l, thisobs_l%dim_obs_l, ipiv, work, lwork, info) + if (info /= 0) then + print *, "Error in dgetri, info =", info + stop + end if + + do j = 1,rank + do i = 1,thisobs_l%dim_obs_l + A_l(i+off,j) = weight(i)*A_l(i+off,j) + end do + end do + + C_l(off+1:off+thisobs_l%dim_obs_l,:) = matmul(obscov_inv_l,A_l(off+1:off+thisobs_l%dim_obs_l,:)) + + end select + + deallocate(weight) + + end subroutine prodRinvA_l_GRACE + + !> @author Anne Springer !> @date 29.10.2025 !> @brief Read temporal mean of TWS from NetCDF file diff --git a/interface/framework/obs_SM_pdafomi.F90 b/interface/framework/obs_SM_pdafomi.F90 index 75671609e..c182a0a55 100644 --- a/interface/framework/obs_SM_pdafomi.F90 +++ b/interface/framework/obs_SM_pdafomi.F90 @@ -1098,5 +1098,220 @@ SUBROUTINE localize_covar_SM(dim_p, dim_obs, HP_p, HPH, coords_p) END SUBROUTINE localize_covar_SM + subroutine add_obs_err_SM(step, dim_obs, C) + + USE mod_parallel_pdaf, & + ONLY: npes_filter + + use PDAFomi, only: obsdims + + implicit none + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs ! Dimension of observation vector + REAL, INTENT(inout) :: C(dim_obs,dim_obs) ! Matrix to that + ! observation covariance R is added + integer :: i, pe, cnt + INTEGER, ALLOCATABLE :: id_start(:) ! Start index of obs. type in global averall obs. vector + INTEGER, ALLOCATABLE :: id_end(:) ! End index of obs. type in global averall obs. vector + + ALLOCATE(id_start(npes_filter), id_end(npes_filter)) + + ! Initialize indices --> we only have information about local obs. dims per PE, so we get the global indices, more generalizable than using + ! the arrays initiliazed in init_dim_obs_SM as we can also consider different observation types in one observation file. Arrays from init_dim_obs_pdaf + ! (e.g. obs_nc2pdaf) may not be necessary anymore, @ Johannes, please have a check here., see also in PDAFomi_obs_f.F90, there the same code is used + ! addition: I also use now the obs_pdaf2nc for reordering the observation covariance matrix to the PDAF internal order + ! So for an obs type where correlations should be accounted for, this should not be removed! + + pe = 1 + id_start(1) = 1 + IF (thisobs%obsid>1) id_start(1) = id_start(1) + sum(obsdims(1, 1:thisobs%obsid-1)) + id_end(1) = id_start(1) + obsdims(1,thisobs%obsid) - 1 + DO pe = 2, npes_filter + id_start(pe) = id_start(pe-1) + SUM(obsdims(pe-1,thisobs%obsid:)) + IF (thisobs%obsid>1) id_start(pe) = id_start(pe) + sum(obsdims(pe,1:thisobs%obsid-1)) + id_end(pe) = id_start(pe) + obsdims(pe,thisobs%obsid) - 1 + END DO + + + cnt = 1 + DO pe = 1, npes_filter + DO i = id_start(pe), id_end(pe) + C(i,i) = C(i,i) + 1.0/thisobs%ivar_obs_f(cnt) + cnt = cnt + 1 + end do + end do + + DEALLOCATE(id_start, id_end) + + end subroutine add_obs_err_SM + + + subroutine init_obscovar_SM(step, dim_obs, dim_obs_p, covar, m_state_p, isdiag) + + USE mod_parallel_pdaf, & + ONLY: npes_filter + + use PDAFomi, only: obsdims, map_obs_id + + implicit none + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs ! Dimension of observation vector + INTEGER, INTENT(in) :: dim_obs_p ! PE-local dimension of observation vector + REAL, INTENT(inout) :: covar(dim_obs, dim_obs) ! Observation error covariance matrix + REAL, INTENT(in) :: m_state_p(dim_obs_p) ! PE-local observation vector + LOGICAL, INTENT(inout) :: isdiag ! Whether the observation error covar. matrix is diagonal + + integer :: i, pe, cnt + INTEGER, ALLOCATABLE :: id_start(:) ! Start index of obs. type in global averall obs. vector + INTEGER, ALLOCATABLE :: id_end(:) ! End index of obs. type in global averall obs. vector + + ALLOCATE(id_start(npes_filter), id_end(npes_filter)) + + ! Initialize indices --> we only have information about local obs. dims per PE, so we use the same logic as in add_obs_err_SM + pe = 1 + id_start(1) = 1 + IF (thisobs%obsid>1) id_start(1) = id_start(1) + sum(obsdims(1, 1:thisobs%obsid-1)) + id_end(1) = id_start(1) + obsdims(1,thisobs%obsid) - 1 + DO pe = 2, npes_filter + id_start(pe) = id_start(pe-1) + SUM(obsdims(pe-1,thisobs%obsid:)) + IF (thisobs%obsid>1) id_start(pe) = id_start(pe) + sum(obsdims(pe,1:thisobs%obsid-1)) + id_end(pe) = id_start(pe) + obsdims(pe,thisobs%obsid) - 1 + END DO + + ! Initialize mapping vector (to be used in PDAF_enkf_obs_ensemble) --> has to be initialized here, else there will be errors! + cnt = 1 + IF (thisobs%obsid-1 > 0) cnt = cnt+ SUM(obsdims(:,1:thisobs%obsid-1)) + DO pe = 1, npes_filter + DO i = id_start(pe), id_end(pe) + map_obs_id(i) = cnt + cnt = cnt + 1 + END DO + END DO + + cnt = 1 + DO pe = 1, npes_filter + DO i = id_start(pe), id_end(pe) + covar(i, i) = covar(i, i) + 1.0/thisobs%ivar_obs_f(cnt) ! the inverse of the observation variance is saved for each observation, so we do not need any other + ! array here. As we initiliazed the indices for each process, we also can just take index cnt instead of complicated mapping between nc and pdaf indices + cnt = cnt + 1 + ENDDO + ENDDO + + ! The matrix is diagonal + ! This setting avoids the computation of the SVD of COVAR + ! in PDAF_enkf_obs_ensemble + isdiag = .TRUE. + + DEALLOCATE(id_start, id_end) + + + end subroutine init_obscovar_SM + + + subroutine prodRinvA_SM(step, dim_obs_p, rank, obs_p, A_p, C_p) + + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs_p ! PE-local dimension of obs. vector + INTEGER, INTENT(in) :: rank ! Rank of initial covariance matrix + REAL, INTENT(in) :: obs_p(dim_obs_p) ! PE-local vector of observations + REAL, INTENT(in) :: A_p(dim_obs_p,rank) ! Input matrix from analysis routine + REAL, INTENT(inout) :: C_p(dim_obs_p,rank) ! Output matrix + + INTEGER :: i, j ! index of observation component + INTEGER :: off ! row offset in A_l and C_l + + off = thisobs%off_obs_f + + do j=1, rank + do i=1, thisobs%dim_obs_f + C_p(i+off, j) = thisobs%ivar_obs_f(i) * A_p(i+off, j) + END DO + end do + + end subroutine prodRinvA_SM + + + subroutine prodRinvA_l_SM(domain_p, step, dim_obs, rank, obs_l, A_l, C_l) + + use shr_kind_mod, only: r8 => shr_kind_r8 + USE mod_assimilation, & + ONLY: cradius_SM, locweight, sradius_SM + use pdafomi, only: PDAFomi_observation_localization_weights + + implicit none + + INTEGER, INTENT(in) :: domain_p ! Current local analysis domain + INTEGER, INTENT(in) :: step ! Current time step + INTEGER, INTENT(in) :: dim_obs ! Dimension of local observation vector, multiple observation types possible, then we have to access with thisobs_l%dim_obs_l + INTEGER, INTENT(in) :: rank ! Rank of initial covariance matrix + REAL, INTENT(in) :: obs_l(dim_obs) ! Local vector of observations + REAL, INTENT(inout) :: A_l(dim_obs, rank) ! Input matrix from analysis routine + REAL, INTENT(out) :: C_l(dim_obs, rank) ! Output matrix + + INTEGER :: verbose ! Verbosity flag + INTEGER :: verbose_w ! Verbosity flag for weight computation + INTEGER, SAVE :: domain_save = -1 ! Save previous domain index + INTEGER :: wtype ! Type of weight function + INTEGER :: rtype ! Type of weight regulation + REAL, ALLOCATABLE :: weight(:) ! Localization weights + REAL, ALLOCATABLE :: A_obs(:,:) ! Array for a single row of A_l + REAL :: var_obs ! Variance of observation error + + INTEGER :: i, j + + INTEGER :: off ! row offset in A_l and C_l + INTEGER :: idummy ! Dummy to access nobs_all + + real(r8) :: ivariance_obs + + + off = thisobs_l%off_obs_l + idummy = dim_obs + + IF ((domain_p <= domain_save .OR. domain_save < 0) .AND. mype_filter==0) THEN + verbose = 1 + ELSE + verbose = 0 + END IF + domain_save = domain_p + + ! Screen output + IF (verbose == 1) THEN + WRITE (*, '(8x, a, f12.3)') & + '--- Use global rms for observations of ', rms_obs_SM + WRITE (*, '(8x, a, 1x)') & + '--- Domain localization' + WRITE (*, '(12x, a, 1x, f12.2)') & + '--- Local influence radius', cradius_SM + + IF (locweight > 0) THEN + WRITE (*, '(12x, a)') & + '--- Use distance-dependent weight for observation errors' + + IF (locweight == 3) THEN + write (*, '(12x, a)') & + '--- Use regulated weight with mean error variance' + ELSE IF (locweight == 4) THEN + write (*, '(12x, a)') & + '--- Use regulated weight with single-point error variance' + END IF + END IF + ENDIF + + ALLOCATE(weight(thisobs_l%dim_obs_l)) + call PDAFomi_observation_localization_weights(thisobs_l, thisobs, rank, A_l, & + weight, verbose) + + do j=1,rank + do i=1,thisobs_l%dim_obs_l + C_l(i+off,j) = thisobs_l%ivar_obs_l(i) * weight(i) * A_l(i+off, j) + end do + end do + + deallocate(weight) + + end subroutine prodRinvA_l_SM + + END MODULE obs_SM_pdafomi #endif From e0ed4cce1868be5b10b68c6fde1b561c1a27ed51 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Wed, 17 Dec 2025 11:50:04 +0100 Subject: [PATCH 23/32] remove unnecessary files --- external/SANGOMA/SANGOMA_quicksort.o | Bin 4048 -> 0 bytes .../PDAF_reset_dim_p-checkpoint.F90 | 128 ------------------ .../PDAF_reset_forget-checkpoint.F90 | 62 --------- 3 files changed, 190 deletions(-) delete mode 100644 external/SANGOMA/SANGOMA_quicksort.o delete mode 100644 src/.ipynb_checkpoints/PDAF_reset_dim_p-checkpoint.F90 delete mode 100644 src/.ipynb_checkpoints/PDAF_reset_forget-checkpoint.F90 diff --git a/external/SANGOMA/SANGOMA_quicksort.o b/external/SANGOMA/SANGOMA_quicksort.o deleted file mode 100644 index f9987538030f1282cce56e7670dff96b5ebeda36..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 4048 zcmdT`eQaA-6@SlhQ>XK6cM76nm0BQznq?-@f~Z-A@*KN;cYUs^bzS$-VWm#OLcU6D zlZ>)9)k`Z~r7yFlDXS*du}Lr?fdoQGV}Rsm$4%oj4NF+kEK;Mjq@772$*7ta>gI9I z`=}k$0D`}`((}Fdcg{Wc+;h+QU7rXDyDcosn2lw=$>e7y$}sT<^W$1=Sj&`wW~xbR z9_O}R4ecux71r5*#KJHKxkKF3+(GWC1N%kgtIpFYP~fHgEKfh+#gA9hcU;0N3jBUH zz2eC@UzK5acnE-3htn%N+aGvO;+J32EyrC$+GF>fxrQd;Si-eauxpLR48z zgJ!a8VYgIM#(5{5(&G?@AUgsIn}rbtjBa)bbb7v@7Za<$!4UC7$yHTV1JwzhuFijv zxF>@2qhNR(SNNwCUOaE(Rhd^a#49^{eQ1u#gpLsLT8^j*+}S^7BcfuBc)9n{B6mAc z68$|{o>}Xk{R+4yN6u-kT(J>#gr_3{I}^J)9}iTI;{~iak9|_pKcMMP+HfObQqi!z zh}kD~Xi)0X@lR1IT2<$}cC)sDRxEDBe$WM1w@btQ_A`aS~=MHl(aNpuWFQl5{e7KYs6^rxCqY%IY>)g$k z^}E4*S@(W!f&>5C{k)+C?f>O|o=-Wq`5C6qaw_5Mf2RbZPi6k($BL?+i2Bki3yJD+ zj92>Zs&#-DlQ!O)>HKu?+RI*6N1w{;Ca@B7fMfBgd13Uf{iQY}0%>R0SGf zd?n?lA=w3QB6cfJ2)uZ6%c=1g$DbOGexZ7N@aoIYY`_d?ilC9@N&o+}r^sHq!Jv@-pNGPe1(9d8`Bgy4?OA!f03rOfaU>F{FieH`y(pe(kuo8MZ=w2oA zwGD)-LH8`76PO?1x=WbVn8Yczf}7e|W|g|W)^kc7Z9SLUCsjO5)QiAcM9i_VOW9{Z z>)w3=y98;bAYKq$`;Xyt$|GyFjQ z(HASIpy2A9uA%c=jV@h8=`EDPbCHBVjW|yo1Mjk*f&q=^evShmxgTqNCi^DzfohfW z&I7Xz)k*e^z;2t=3?22eAJV5P?7W0O$ZWR>9SqX60H`aibQLokk!nuE6OjwJZwA~s z|04|*E>0cv(}oHg+OU~)w;EOs43zXd70 zRLPR)uYkLWeA7afuLS8Fk>?;umV@pEBL4}JLJISxdZx&p4EZvx<;zR>Mhnw6uCMYeM_bQY@sEHot>?>& zD6~&=eXVD69IZU7%k&rUkiJksp@J)Ox>U~`55rFBAR^VIa%l!^VF9Nrvrqu@Bof+TtK^0k&0>=z2I5 z;HxsQb|eA8;qp1Q_#E4PjvYQn73bK=Icmj?XG*0F{nl4XPFqTX7R0JFIcR~di*wjg z7e_CRooBXyi5|lq{@Y>pIb5Qpq>=><-0O#i>=*DlFqXD|+RX3Rzh<)?CF^g7_V9_t zmNE7!@_mi1pR((Dt=m}d_bv#m%#wOPc?p9-Tib4FQ|np~W)tu|RG^P8WBVn1h~xcW z)9wNKKKKytF}Bd+30R|nCoqQ4v{*v_IDDvobR(ihOrYnD_2>~ki8)AqY%S~HPZ+MF z7`HI>zhc-$F%C`qxpnaEpo0zV7+Y!c8tpfao9FH=!p(F4s0cUDy;y{s=Vm;ejji>b zXk&Mj@w9hD8$EmW9egwrtq->tqQ)0PO`Y{^jf^J}?TpqRf&Qg7>?8H<-|lFu4}CY* z9BzqpbVfsMM?=l+k;cwwb4R-dG&gjI8bbHi%rE;_T5Ik7dt3L@@Pyzf9S!x-dQUhK ztzkSu-G1^|sETQB>aKb&*cFUPgM`+>2qk?!{- z=G^S@n8jy8<(?wHO#{WcpV!wPEv$jU^*f6enEspgkhAZ1ewz{h!t-N{&GqK_9|Np- VZ?yg1Cj4cX%X+7s5%(!x{}1lWQWpRK diff --git a/src/.ipynb_checkpoints/PDAF_reset_dim_p-checkpoint.F90 b/src/.ipynb_checkpoints/PDAF_reset_dim_p-checkpoint.F90 deleted file mode 100644 index de7a7324b..000000000 --- a/src/.ipynb_checkpoints/PDAF_reset_dim_p-checkpoint.F90 +++ /dev/null @@ -1,128 +0,0 @@ -! Copyright (c) 2004-2024 Lars Nerger -! -! This file is part of PDAF. -! -! PDAF is free software: you can redistribute it and/or modify -! it under the terms of the GNU Lesser General Public License -! as published by the Free Software Foundation, either version -! 3 of the License, or (at your option) any later version. -! -! PDAF is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with PDAF. If not, see . -! -!$Id$ -!BOP -! -! !ROUTINE: PDAF_reset_dim_p --- Reset state dimension and re-allocate state and ensemble -! -! !INTERFACE: -SUBROUTINE PDAF_reset_dim_p(dim_p_in, outflag) - -! !DESCRIPTION: -! Reset state dimension and re-allocate the state vector -! and ensemble array. -! -! ! This is a core routine of PDAF and -! should not be changed by the user ! -! -! !REVISION HISTORY: -! 2024-02 - Lars Nerger - Initial code -! Later revisions - see svn log -! -! !USES: - USE mpi -! USE PDAF_memcounting, & -! ONLY: PDAF_memcount - USE PDAF_mod_filter, & - ONLY: screen, incremental, dim_ens, dim_p, & - state, state_inc, eofV - USE PDAF_mod_filtermpi, & - ONLY: mype, mype_model, filterpe, dim_ens_l, task_id, & - COMM_couple - - IMPLICIT NONE - -! !ARGUMENTS: - INTEGER, INTENT(in) :: dim_p_in ! Sub-type of filter - INTEGER, INTENT(inout):: outflag ! Status flag - -! !CALLING SEQUENCE: -! Called by: PDAF_alloc_filters -! Calls: PDAF_memcount -!EOP - -! *** local variables *** - INTEGER :: allocstat ! Status for allocate - - -! ************************************ -! *** Reset state vector dimension *** -! ************************************ - - dim_p = dim_p_in - - -! ********************************* -! *** Re-allocate filter fields *** -! ********************************* - - ! Initialize status flag - outflag = 0 - - on_filterpe: IF (filterpe) THEN - ! Allocate all arrays and full ensemble matrix on Filter-PEs - - IF (ALLOCATED(state)) DEALLOCATE(state) - ALLOCATE(state(dim_p), stat = allocstat) - IF (allocstat /= 0) THEN - WRITE (*,'(5x, a)') 'PDAF-ERROR(20): error in re-allocation of STATE' - outflag = 20 - END IF - - IF (incremental == 1) THEN - IF (ALLOCATED(state_inc)) DEALLOCATE(state_inc) - ALLOCATE(state_inc(dim_p), stat = allocstat) - IF (allocstat /= 0) THEN - WRITE (*,'(5x, a)') 'PDAF-ERROR(20): error in allocation of STATE_INC' - outflag = 20 - END IF - - state_inc = 0.0 - END IF - - ! Allocate full ensemble on filter-PEs - IF (ALLOCATED(eofV)) DEALLOCATE(eofV) - ALLOCATE(eofV(dim_p, dim_ens), stat = allocstat) - IF (allocstat /= 0) THEN - WRITE (*,'(5x, a)') 'PDAF-ERROR(20): error in allocation of eofV' - outflag = 20 - END IF - - IF (screen > 2) WRITE (*,*) 'PDAF: reset_dim_p - re-allocate eofV of size ', & - dim_ens, ' on pe(f) ', mype - - ELSE on_filterpe - ! Model-PEs that are not Filter-PEs only need an array for the local ensemble - ! if they participate in the coupling communication - - ! Allocate partial ensemble on model-only PEs that do coupling communication - IF (COMM_couple /= MPI_COMM_NULL) THEN - IF (ALLOCATED(eofV)) DEALLOCATE(eofV) - ALLOCATE(eofV(dim_p, dim_ens_l), stat = allocstat) - IF (allocstat /= 0) THEN - WRITE (*,'(5x, a)') 'PDAF-ERROR(20): error in allocation of eofV on model-pe' - outflag = 20 - END IF - - IF (screen > 2) WRITE (*,*) 'PDAF: reset_dim_p - re-allocate eofV of size ', & - dim_ens_l, ' on pe(m) ', mype_model, ' of model task ',task_id - END IF - - END IF on_filterpe - -END SUBROUTINE PDAF_reset_dim_p diff --git a/src/.ipynb_checkpoints/PDAF_reset_forget-checkpoint.F90 b/src/.ipynb_checkpoints/PDAF_reset_forget-checkpoint.F90 deleted file mode 100644 index 829d7cc2e..000000000 --- a/src/.ipynb_checkpoints/PDAF_reset_forget-checkpoint.F90 +++ /dev/null @@ -1,62 +0,0 @@ -! Copyright (c) 2004-2024 Lars Nerger -! -! This file is part of PDAF. -! -! PDAF is free software: you can redistribute it and/or modify -! it under the terms of the GNU Lesser General Public License -! as published by the Free Software Foundation, either version -! 3 of the License, or (at your option) any later version. -! -! PDAF is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with PDAF. If not, see . -! -!$Id$ -!BOP -! -! !ROUTINE: PDAF_reset_forget --- Manually reset forgetting factor -! -! !INTERFACE: -SUBROUTINE PDAF_reset_forget(forget_in) - -! !DESCRIPTION: -! Helper routine for PDAF. -! The routine allows to manually set the forgetting -! factor to a new value. Usually this should be called -! in assimilate_pdaf before calling the analysis step -! routine. -! -! ! This is a core routine of PDAF and -! should not be changed by the user ! -! -! !REVISION HISTORY: -! 2021-05 - Lars Nerger - Initial code -! Later revisions - see svn log -! -! !USES: - USE PDAF_mod_filter, & - ONLY: localfilter, forget, forget_l, inloop - - IMPLICIT NONE - -! !ARGUMENTS: - REAL,INTENT(in) :: forget_in ! New value of forgetting factor -!EOP - -! *** Set forgetting factor *** - - IF (localfilter == 0) THEN - forget = forget_in - ELSE - IF (inloop) THEN - forget_l = forget_in - ELSE - forget = forget_in - END IF - END IF - -END SUBROUTINE PDAF_reset_forget From 7615916df16c9487d9af4d87d66c1211cb8a7388 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Wed, 17 Dec 2025 13:03:27 +0100 Subject: [PATCH 24/32] test: remove additional object file --- interface/model/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/interface/model/Makefile b/interface/model/Makefile index b12bc2c16..4b1bebdb9 100644 --- a/interface/model/Makefile +++ b/interface/model/Makefile @@ -17,7 +17,7 @@ OBJ = dictionary.o\ read_enkfpar.o\ wrapper_tsmp.o\ -OBJ += ${PDAF_SRC}/src/PDAF_reset_dim_p.o +# OBJ += ${PDAF_SRC}/src/PDAF_reset_dim_p.o ## clm object files OBJCLM = enkf_clm_mod.o\ From c80f2e99df463a996b7c175a93a02a3d4d3d8eb2 Mon Sep 17 00:00:00 2001 From: ewerdwalbesloh1 Date: Wed, 17 Dec 2025 13:08:51 +0100 Subject: [PATCH 25/32] Add reading of observation error covariance matrix --- interface/framework/mod_read_obs.F90 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/interface/framework/mod_read_obs.F90 b/interface/framework/mod_read_obs.F90 index 84a9caa2c..fd0824203 100755 --- a/interface/framework/mod_read_obs.F90 +++ b/interface/framework/mod_read_obs.F90 @@ -210,6 +210,18 @@ subroutine read_obs_nc_type(current_observation_filename, & end if + haserr = nf90_inq_varid(ncid, obscov_name, clmobscov_varid) + if(haserr == nf90_noerr) then + + multierr = 2 + + if(allocated(obscov_g)) deallocate(obscov_g) + allocate(obscov_g(dim_obs,dim_obs)) + + call check(nf90_get_var(ncid, clmobscov_varid, obscov_g)) + + end if + dim_obs_g = dim_obs end if From c15c97b22f0ef38857f41a86b4ab3feed2553282 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Fri, 19 Dec 2025 15:00:24 +0100 Subject: [PATCH 26/32] interface/model/Makefile: use existing BASEDIR no need to specify PDAF_SRC as input in TSMP2 --- interface/model/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/interface/model/Makefile b/interface/model/Makefile index 4b1bebdb9..acd8862ee 100644 --- a/interface/model/Makefile +++ b/interface/model/Makefile @@ -17,7 +17,7 @@ OBJ = dictionary.o\ read_enkfpar.o\ wrapper_tsmp.o\ -# OBJ += ${PDAF_SRC}/src/PDAF_reset_dim_p.o +OBJ += ${BASEDIR}/src/PDAF_reset_dim_p.o ## clm object files OBJCLM = enkf_clm_mod.o\ From 6c3161c9652e781a97ee272b919151dddbb6c3cc Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Fri, 19 Dec 2025 15:08:31 +0100 Subject: [PATCH 27/32] Add PDAF_reset_dim_p to PDAF_interfaces_modules --- interface/model/Makefile | 2 -- interface/model/eclm/enkf_clm_mod_5.F90 | 1 + src/PDAF_interfaces_module.F90 | 7 +++++++ 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/interface/model/Makefile b/interface/model/Makefile index acd8862ee..580b8dc99 100644 --- a/interface/model/Makefile +++ b/interface/model/Makefile @@ -17,8 +17,6 @@ OBJ = dictionary.o\ read_enkfpar.o\ wrapper_tsmp.o\ -OBJ += ${BASEDIR}/src/PDAF_reset_dim_p.o - ## clm object files OBJCLM = enkf_clm_mod.o\ mod_clm_statistics.o\ diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index 42a9b39b7..8be709863 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -130,6 +130,7 @@ subroutine define_clm_statevec(mype) use decompMod , only : get_proc_bounds use clm_varpar , only : nlevsoi use clm_varcon, only: set_averaging_to_zero + use PDAF_interfaces_module, only: PDAF_reset_dim_p implicit none diff --git a/src/PDAF_interfaces_module.F90 b/src/PDAF_interfaces_module.F90 index 68a685966..a652a7c99 100644 --- a/src/PDAF_interfaces_module.F90 +++ b/src/PDAF_interfaces_module.F90 @@ -923,6 +923,13 @@ SUBROUTINE PDAF_get_ensstats(skew_ptr, kurt_ptr, status) END SUBROUTINE PDAF_get_ensstats END INTERFACE + INTERFACE + SUBROUTINE PDAF_reset_dim_p(dim_p_in, outflag) + INTEGER, INTENT(in) :: dim_p_in ! Sub-type of filter + INTEGER, INTENT(inout):: outflag ! Status flag + END SUBROUTINE PDAF_reset_dim_p + END INTERFACE + INTERFACE SUBROUTINE PDAF_reset_forget(forget_in) REAL, INTENT(in) :: forget_in ! New value of forgetting factor From 5947463c10dd726f8875db2ab1f5055319296b5f Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Fri, 19 Dec 2025 15:34:39 +0100 Subject: [PATCH 28/32] interface/framework/Makefile: switch order of $(LIBMODEL) / -lpdaf-d goal: calling a subroutine in `-lpdaf-d` inside the code of `$(LIBMODEL)` --- interface/framework/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/interface/framework/Makefile b/interface/framework/Makefile index f59705553..35719909e 100644 --- a/interface/framework/Makefile +++ b/interface/framework/Makefile @@ -155,7 +155,7 @@ $(PROG) : $(LIBMODEL) libpdaf-d.a \ $(PREP_C) $(LD) $(OPT_LNK) -o $@ \ $(MODULES) $(MOD_ASSIM) $(MOD_USER_PDAFOMI) \ $(OBJ_MODEL_PDAF) $(OBJ_PDAF_INT) $(OBJ_PDAF_USER) \ - -L$(BASEDIR)/lib -lpdaf-d $(LIBMODEL) $(LIBS) $(LINK_LIBS) + -L$(BASEDIR)/lib $(LIBMODEL) -lpdaf-d $(LIBS) $(LINK_LIBS) ###################################################### From 1042c40ecf31a2a398631f2dc5b5dbd15d691d94 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Fri, 19 Dec 2025 15:47:15 +0100 Subject: [PATCH 29/32] interface/framework/Makefile: use linker group for -lpdaf-d and $(LIBMODEL), possibly a circular dependency? --- interface/framework/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/interface/framework/Makefile b/interface/framework/Makefile index 35719909e..f6213fb84 100644 --- a/interface/framework/Makefile +++ b/interface/framework/Makefile @@ -155,7 +155,7 @@ $(PROG) : $(LIBMODEL) libpdaf-d.a \ $(PREP_C) $(LD) $(OPT_LNK) -o $@ \ $(MODULES) $(MOD_ASSIM) $(MOD_USER_PDAFOMI) \ $(OBJ_MODEL_PDAF) $(OBJ_PDAF_INT) $(OBJ_PDAF_USER) \ - -L$(BASEDIR)/lib $(LIBMODEL) -lpdaf-d $(LIBS) $(LINK_LIBS) + -L$(BASEDIR)/lib -Wl,--start-group -lpdaf-d $(LIBMODEL) -Wl,--end-group $(LIBS) $(LINK_LIBS) ###################################################### From 8dcdef7eb43b44b4be008253a74000fd44b1f957 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Fri, 19 Dec 2025 16:17:33 +0100 Subject: [PATCH 30/32] Makefile: add PDAF_reset_dim_p.F90 to sources --- Makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 06ed26693..9478c096c 100644 --- a/Makefile +++ b/Makefile @@ -138,7 +138,8 @@ SRC_PDAF_GEN = PDAF_analysis_utils.F90 \ PDAFlocalomi_put_state_nondiagR.F90 \ PDAFlocalomi_put_state_nondiagR_si.F90 \ PDAFlocalomi_put_state_si.F90 \ - PDAF_correlation_function.F90 + PDAF_correlation_function.F90 \ + PDAF_reset_dim_p.F90 # Specific PDAF-routines for SEIK SRC_SEIK = PDAF_seik_init.F90 \ From fdc98c17a0731c959bbe9bf3fd77cf82abf064a7 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Fri, 19 Dec 2025 16:30:00 +0100 Subject: [PATCH 31/32] interface/framework/Makefile: order currently enough circular dependencies not wanted this way library-subroutines can be called from model interface routines, but not the other way around (should not be needed as model interface routines should always be called by framework routines). --- interface/framework/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/interface/framework/Makefile b/interface/framework/Makefile index f6213fb84..35719909e 100644 --- a/interface/framework/Makefile +++ b/interface/framework/Makefile @@ -155,7 +155,7 @@ $(PROG) : $(LIBMODEL) libpdaf-d.a \ $(PREP_C) $(LD) $(OPT_LNK) -o $@ \ $(MODULES) $(MOD_ASSIM) $(MOD_USER_PDAFOMI) \ $(OBJ_MODEL_PDAF) $(OBJ_PDAF_INT) $(OBJ_PDAF_USER) \ - -L$(BASEDIR)/lib -Wl,--start-group -lpdaf-d $(LIBMODEL) -Wl,--end-group $(LIBS) $(LINK_LIBS) + -L$(BASEDIR)/lib $(LIBMODEL) -lpdaf-d $(LIBS) $(LINK_LIBS) ###################################################### From 4b1f1a2d98e7055a2b6521d588a05d4a158b1045 Mon Sep 17 00:00:00 2001 From: Johannes Keller Date: Fri, 19 Dec 2025 16:49:32 +0100 Subject: [PATCH 32/32] fortitude changes --- interface/framework/callback_obs_pdafomi.F90 | 10 +++---- interface/framework/next_observation_pdaf.F90 | 8 +++--- interface/framework/obs_GRACE_pdafomi.F90 | 28 +++++++++---------- interface/framework/obs_SM_pdafomi.F90 | 20 ++++++------- interface/model/eclm/enkf_clm_mod_5.F90 | 2 +- 5 files changed, 34 insertions(+), 34 deletions(-) diff --git a/interface/framework/callback_obs_pdafomi.F90 b/interface/framework/callback_obs_pdafomi.F90 index f91e24847..6ac260d9e 100644 --- a/interface/framework/callback_obs_pdafomi.F90 +++ b/interface/framework/callback_obs_pdafomi.F90 @@ -238,10 +238,10 @@ SUBROUTINE add_obs_err_pdafomi(step, dim_obs, C) INTEGER, INTENT(in) :: step ! Current time step INTEGER, INTENT(in) :: dim_obs ! Dimension of obs. vector - REAL, INTENT(inout) :: C(dim_obs, dim_obs) ! Matrix to that the observation + REAL, INTENT(inout) :: C(dim_obs, dim_obs) ! Matrix to that the observation ! error covariance matrix is added - - + + INTEGER :: i ! index of observation component REAL :: variance_obs ! variance of observations CALL add_obs_err_GRACE(step, dim_obs, C) @@ -260,8 +260,8 @@ SUBROUTINE init_obscovar_pdafomi(step, dim_obs, dim_obs_p, covar, m_state_p, isd INTEGER, INTENT(in) :: step ! Current time step INTEGER, INTENT(in) :: dim_obs ! Dimension of observation vector INTEGER, INTENT(in) :: dim_obs_p ! PE-local dimension of observation vector - REAL, INTENT(out) :: covar(dim_obs, dim_obs) ! Observation error covariance matrix - REAL, INTENT(in) :: m_state_p(dim_obs_p) ! PE-local observation vector + REAL, INTENT(out) :: covar(dim_obs, dim_obs) ! Observation error covariance matrix + REAL, INTENT(in) :: m_state_p(dim_obs_p) ! PE-local observation vector LOGICAL, INTENT(out) :: isdiag ! Whether the observation error covar. matrix is diagonal integer :: i diff --git a/interface/framework/next_observation_pdaf.F90 b/interface/framework/next_observation_pdaf.F90 index a98efd926..f11c64d91 100644 --- a/interface/framework/next_observation_pdaf.F90 +++ b/interface/framework/next_observation_pdaf.F90 @@ -226,12 +226,12 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) #ifdef CLMSA #ifdef CLMFIVE OMI:if (use_omi) then - if (clmupdate_tws.ne.0) then ! only update set_zero when GRACE is assimilated at the current time step + if (clmupdate_tws/=0) then ! only update set_zero when GRACE is assimilated at the current time step nstep = get_nstep() - if (stepnow.ne.toffset) then + if (stepnow/=toffset) then write(fn, '(a, i5.5)') trim(obs_filename)//'.', stepnow call check_n_observationfile_set_zero(fn, set_averaging_to_zero) - if (set_averaging_to_zero.ne.ispval) then + if (set_averaging_to_zero/=ispval) then set_averaging_to_zero = set_averaging_to_zero+nstep end if @@ -258,7 +258,7 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) if (trim(obs_type_str) /= '') then call update_obs_type(obs_type_str) end if - + if (mype_world==0 .and. screen > 2) then write(*,*)'next_type (in next_observation_pdaf):',trim(obs_type_str) end if diff --git a/interface/framework/obs_GRACE_pdafomi.F90 b/interface/framework/obs_GRACE_pdafomi.F90 index 8bf2d7b11..f8318a1e7 100644 --- a/interface/framework/obs_GRACE_pdafomi.F90 +++ b/interface/framework/obs_GRACE_pdafomi.F90 @@ -559,7 +559,7 @@ SUBROUTINE init_dim_obs_GRACE(step, dim_obs) dim_obs = count(vec_useObs_global) - if (multierr.eq.2) then ! compute inverse of covariance matrix for prodRinvA, has to be before PDAFomi_gather_obs because the routine changes dim_obs + if (multierr==2) then ! compute inverse of covariance matrix for prodRinvA, has to be before PDAFomi_gather_obs because the routine changes dim_obs if (allocated(obscov_inv)) deallocate(obscov_inv) allocate(obscov_inv(dim_obs, dim_obs)) @@ -1006,7 +1006,7 @@ subroutine add_obs_err_GRACE(step, dim_obs, C) select case (multierr) case(0,1) - cnt = 1 + cnt = 1 DO pe = 1, npes_filter DO i = id_start(pe), id_end(pe) C(i,i) = C(i,i) + 1.0/thisobs%ivar_obs_f(cnt) @@ -1021,7 +1021,7 @@ subroutine add_obs_err_GRACE(step, dim_obs, C) end do end do end select - + DEALLOCATE(id_start, id_end) @@ -1043,8 +1043,8 @@ subroutine init_obscovar_GRACE(step, dim_obs, dim_obs_p, covar, m_state_p, isdia INTEGER, INTENT(in) :: step ! Current time step INTEGER, INTENT(in) :: dim_obs ! Dimension of observation vector INTEGER, INTENT(in) :: dim_obs_p ! PE-local dimension of observation vector - REAL, INTENT(inout) :: covar(dim_obs, dim_obs) ! Observation error covariance matrix - REAL, INTENT(in) :: m_state_p(dim_obs_p) ! PE-local observation vector + REAL, INTENT(inout) :: covar(dim_obs, dim_obs) ! Observation error covariance matrix + REAL, INTENT(in) :: m_state_p(dim_obs_p) ! PE-local observation vector LOGICAL, INTENT(inout) :: isdiag ! Whether the observation error covar. matrix is diagonal integer :: i, pe, cnt, j @@ -1077,7 +1077,7 @@ subroutine init_obscovar_GRACE(step, dim_obs, dim_obs_p, covar, m_state_p, isdia select case(multierr) case(0,1) - cnt = 1 + cnt = 1 DO pe = 1, npes_filter DO i = id_start(pe), id_end(pe) covar(i, i) = covar(i, i) + 1.0/thisobs%ivar_obs_f(cnt) @@ -1100,10 +1100,10 @@ subroutine init_obscovar_GRACE(step, dim_obs, dim_obs_p, covar, m_state_p, isdia isdiag = .FALSE. end select - + DEALLOCATE(id_start, id_end) - + end subroutine init_obscovar_GRACE @@ -1127,7 +1127,7 @@ subroutine prodRinvA_GRACE(step, dim_obs_p, rank, obs_p, A_p, C_p) real(r8) :: obscov_inv_l(thisobs%dim_obs_f,thisobs%dim_obs_f) ! errors of observations in the model domain off = thisobs%off_obs_f ! account for offset if multiple observation types are assimilated at once - + select case (multierr) case(0,1) do j=1, rank @@ -1160,7 +1160,7 @@ subroutine prodRinvA_l_GRACE(domain_p, step, dim_obs, rank, obs_l, A_l, C_l) INTEGER, INTENT(in) :: domain_p ! Current local analysis domain INTEGER, INTENT(in) :: step ! Current time step - INTEGER, INTENT(in) :: dim_obs ! Dimension of local observation vector, multiple observation types possible, then we have to access with thisobs_l%dim_obs_l + INTEGER, INTENT(in) :: dim_obs ! Dimension of local observation vector, multiple observation types possible, then we have to access with thisobs_l%dim_obs_l INTEGER, INTENT(in) :: rank ! Rank of initial covariance matrix REAL, INTENT(in) :: obs_l(dim_obs) ! Local vector of observations REAL, INTENT(inout) :: A_l(dim_obs, rank) ! Input matrix from analysis routine @@ -1202,7 +1202,7 @@ subroutine prodRinvA_l_GRACE(domain_p, step, dim_obs, rank, obs_l, A_l, C_l) verbose = 0 END IF domain_save = domain_p - + ! Screen output IF (verbose == 1) THEN WRITE (*, '(8x, a, f12.3)') & @@ -1211,11 +1211,11 @@ subroutine prodRinvA_l_GRACE(domain_p, step, dim_obs, rank, obs_l, A_l, C_l) '--- Domain localization' WRITE (*, '(12x, a, 1x, f12.2)') & '--- Local influence radius', cradius_GRACE - + IF (locweight > 0) THEN WRITE (*, '(12x, a)') & '--- Use distance-dependent weight for observation errors' - + IF (locweight == 3) THEN write (*, '(12x, a)') & '--- Use regulated weight with mean error variance' @@ -1229,7 +1229,7 @@ subroutine prodRinvA_l_GRACE(domain_p, step, dim_obs, rank, obs_l, A_l, C_l) ALLOCATE(weight(thisobs_l%dim_obs_l)) call PDAFomi_observation_localization_weights(thisobs_l, thisobs, rank, A_l, & weight, verbose) - + select case(multierr) case(0,1) do j=1,rank diff --git a/interface/framework/obs_SM_pdafomi.F90 b/interface/framework/obs_SM_pdafomi.F90 index c182a0a55..882558277 100644 --- a/interface/framework/obs_SM_pdafomi.F90 +++ b/interface/framework/obs_SM_pdafomi.F90 @@ -1116,7 +1116,7 @@ subroutine add_obs_err_SM(step, dim_obs, C) ALLOCATE(id_start(npes_filter), id_end(npes_filter)) - ! Initialize indices --> we only have information about local obs. dims per PE, so we get the global indices, more generalizable than using + ! Initialize indices --> we only have information about local obs. dims per PE, so we get the global indices, more generalizable than using ! the arrays initiliazed in init_dim_obs_SM as we can also consider different observation types in one observation file. Arrays from init_dim_obs_pdaf ! (e.g. obs_nc2pdaf) may not be necessary anymore, @ Johannes, please have a check here., see also in PDAFomi_obs_f.F90, there the same code is used ! addition: I also use now the obs_pdaf2nc for reordering the observation covariance matrix to the PDAF internal order @@ -1133,7 +1133,7 @@ subroutine add_obs_err_SM(step, dim_obs, C) END DO - cnt = 1 + cnt = 1 DO pe = 1, npes_filter DO i = id_start(pe), id_end(pe) C(i,i) = C(i,i) + 1.0/thisobs%ivar_obs_f(cnt) @@ -1157,8 +1157,8 @@ subroutine init_obscovar_SM(step, dim_obs, dim_obs_p, covar, m_state_p, isdiag) INTEGER, INTENT(in) :: step ! Current time step INTEGER, INTENT(in) :: dim_obs ! Dimension of observation vector INTEGER, INTENT(in) :: dim_obs_p ! PE-local dimension of observation vector - REAL, INTENT(inout) :: covar(dim_obs, dim_obs) ! Observation error covariance matrix - REAL, INTENT(in) :: m_state_p(dim_obs_p) ! PE-local observation vector + REAL, INTENT(inout) :: covar(dim_obs, dim_obs) ! Observation error covariance matrix + REAL, INTENT(in) :: m_state_p(dim_obs_p) ! PE-local observation vector LOGICAL, INTENT(inout) :: isdiag ! Whether the observation error covar. matrix is diagonal integer :: i, pe, cnt @@ -1188,7 +1188,7 @@ subroutine init_obscovar_SM(step, dim_obs, dim_obs_p, covar, m_state_p, isdiag) END DO END DO - cnt = 1 + cnt = 1 DO pe = 1, npes_filter DO i = id_start(pe), id_end(pe) covar(i, i) = covar(i, i) + 1.0/thisobs%ivar_obs_f(cnt) ! the inverse of the observation variance is saved for each observation, so we do not need any other @@ -1234,7 +1234,7 @@ end subroutine prodRinvA_SM subroutine prodRinvA_l_SM(domain_p, step, dim_obs, rank, obs_l, A_l, C_l) use shr_kind_mod, only: r8 => shr_kind_r8 - USE mod_assimilation, & + USE mod_assimilation, & ONLY: cradius_SM, locweight, sradius_SM use pdafomi, only: PDAFomi_observation_localization_weights @@ -1242,7 +1242,7 @@ subroutine prodRinvA_l_SM(domain_p, step, dim_obs, rank, obs_l, A_l, C_l) INTEGER, INTENT(in) :: domain_p ! Current local analysis domain INTEGER, INTENT(in) :: step ! Current time step - INTEGER, INTENT(in) :: dim_obs ! Dimension of local observation vector, multiple observation types possible, then we have to access with thisobs_l%dim_obs_l + INTEGER, INTENT(in) :: dim_obs ! Dimension of local observation vector, multiple observation types possible, then we have to access with thisobs_l%dim_obs_l INTEGER, INTENT(in) :: rank ! Rank of initial covariance matrix REAL, INTENT(in) :: obs_l(dim_obs) ! Local vector of observations REAL, INTENT(inout) :: A_l(dim_obs, rank) ! Input matrix from analysis routine @@ -1274,7 +1274,7 @@ subroutine prodRinvA_l_SM(domain_p, step, dim_obs, rank, obs_l, A_l, C_l) verbose = 0 END IF domain_save = domain_p - + ! Screen output IF (verbose == 1) THEN WRITE (*, '(8x, a, f12.3)') & @@ -1283,11 +1283,11 @@ subroutine prodRinvA_l_SM(domain_p, step, dim_obs, rank, obs_l, A_l, C_l) '--- Domain localization' WRITE (*, '(12x, a, 1x, f12.2)') & '--- Local influence radius', cradius_SM - + IF (locweight > 0) THEN WRITE (*, '(12x, a)') & '--- Use distance-dependent weight for observation errors' - + IF (locweight == 3) THEN write (*, '(12x, a)') & '--- Use regulated weight with mean error variance' diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index 8be709863..58d203e06 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -215,7 +215,7 @@ subroutine define_clm_statevec(mype) ! possibility to assimilate GRACE not in the first month --> enkfpf.par file has information set_zero_start where the running average should be resetted ! This is usually one month prior to the first GRACE observation. If it is not included in the file, it is resetted when the first GRACE observation ! is assimilated. Afterwards, the normal set_zero information inside the observation file is used (see next_observation_pdaf for details). - if (set_zero_start.ne.0) then + if (set_zero_start/=0) then set_averaging_to_zero = set_zero_start end if end if