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/add_obs_error_pdaf.F90 b/interface/framework/add_obs_error_pdaf.F90 index 5020017d8..d422b08c4 100644 --- a/interface/framework/add_obs_error_pdaf.F90 +++ b/interface/framework/add_obs_error_pdaf.F90 @@ -50,8 +50,11 @@ SUBROUTINE add_obs_error_pdaf(step, dim_obs, C_p) ! !USES: USE mod_assimilation, & ONLY: rms_obs, obs_pdaf2nc + USE mod_assimilation, ONLY: obscov USE mod_read_obs, ONLY: multierr,clm_obserr, pressure_obserr + USE mod_read_obs, ONLY: vec_useObs_global + USE enkf_clm_mod, ONLY: clmupdate_tws USE mod_parallel_pdaf, ONLY: mype_world USE mod_parallel_pdaf, ONLY: abort_parallel USE mod_tsmp, ONLY: point_obs @@ -72,7 +75,9 @@ SUBROUTINE add_obs_error_pdaf(step, dim_obs, C_p) ! *** local variables *** INTEGER :: i ! index of observation component + INTEGER :: j ! index of observation component REAL :: variance_obs ! variance of observations + REAL :: clm_obserr_model(dim_obs) ! errors of observations in the model domain ! ********************** @@ -98,6 +103,8 @@ SUBROUTINE add_obs_error_pdaf(step, dim_obs, C_p) if(multierr==1) then + NOGRACE: if (clmupdate_tws/=1) then + ! Check that point observations are used if (.not. point_obs == 1) then print *, "TSMP-PDAF mype(w)=", mype_world, ": ERROR(3) `point_obs.eq.1` needed for using obs_pdaf2nc." @@ -111,6 +118,24 @@ SUBROUTINE add_obs_error_pdaf(step, dim_obs, C_p) C_p(i,i) = C_p(i,i) + pressure_obserr(obs_pdaf2nc(i))*pressure_obserr(obs_pdaf2nc(i)) #endif enddo + + else NOGRACE + + clm_obserr_model = pack(clm_obserr,vec_useObs_global) + do i = 1,dim_obs + C_p(i,i) = C_p(i,i) + clm_obserr_model(i) ! we put already variances in GRACE observation files, so no square need + end do + + end if NOGRACE + endif + if(multierr==2) then + do i = 1, size(obscov,1) + do j = 1, size(obscov,2) + C_p(i,j) = C_p(i,j)+obscov(i,j) + end do + end do + end if + END SUBROUTINE add_obs_error_pdaf diff --git a/interface/framework/g2l_obs_pdaf.F90 b/interface/framework/g2l_obs_pdaf.F90 index 8c2bda9d9..6f980e57a 100644 --- a/interface/framework/g2l_obs_pdaf.F90 +++ b/interface/framework/g2l_obs_pdaf.F90 @@ -55,6 +55,7 @@ SUBROUTINE g2l_obs_pdaf(domain_p, step, dim_obs_f, dim_obs_l, mstate_f, & ! !USES: USE mod_assimilation, & ONLY: obs_index_l, obs_nc2pdaf + USE enkf_clm_mod, ONLY: clmupdate_tws IMPLICIT NONE @@ -89,8 +90,12 @@ SUBROUTINE g2l_obs_pdaf(domain_p, step, dim_obs_f, dim_obs_l, mstate_f, & ! Index array OBS_NC2PDAF set in subroutine INIT_DIM_OBS_F_PDAF ! Index array OBS_INDEX_L (returns nc-ordered index) set in subroutine INIT_DIM_OBS_L_PDAF do i=1,dim_obs_l + GRACE: if (clmupdate_tws==1) then + mstate_l(i) = mstate_f(obs_index_l(i)) + else GRACE !mstate_l(i) = mstate_f(obs_index_l(i)) mstate_l(i) = mstate_f(obs_nc2pdaf(obs_index_l(i))) + end if GRACE end do END SUBROUTINE g2l_obs_pdaf diff --git a/interface/framework/g2l_state_pdaf.F90 b/interface/framework/g2l_state_pdaf.F90 index 987a2c258..6c9d8ffaf 100644 --- a/interface/framework/g2l_state_pdaf.F90 +++ b/interface/framework/g2l_state_pdaf.F90 @@ -52,6 +52,8 @@ SUBROUTINE g2l_state_pdaf(step, domain_p, dim_p, state_p, dim_l, state_l) USE mod_tsmp, & ONLY: nx_local, ny_local #if defined CLMSA + use enkf_clm_mod, only: hactiveg_levels, num_layer, state_setup, num_hactiveg_patch, hactiveg_patch, clm_varsize_tws + USE enkf_clm_mod, ONLY: clmupdate_tws USE enkf_clm_mod, ONLY: g2l_state_clm #endif @@ -68,6 +70,7 @@ SUBROUTINE g2l_state_pdaf(step, domain_p, dim_p, state_p, dim_l, state_l) REAL, TARGET, INTENT(out) :: state_l(dim_l) ! State vector on local analysis domain INTEGER :: i, n_domain, nshift_p + INTEGER :: sub, j, g INTEGER :: begg, endg ! per-proc gridcell ending gridcell indices ! !CALLING SEQUENCE: ! Called by: PDAF_lseik_update (as U_g2l_state) @@ -90,7 +93,157 @@ SUBROUTINE g2l_state_pdaf(step, domain_p, dim_p, state_p, dim_l, state_l) end if !call g2l_state(domain_p, c_loc(state_p), dim_l, c_loc(state_l)) #else + if (clmupdate_tws/=1) then call g2l_state_clm(domain_p, dim_p, state_p, dim_l, state_l) + end if + + if (clmupdate_tws==1) then + + + ! first depth dependent variables --> liq and ice (together in statevector or not) + ! dim_l is number of layers of gridcell + 3 (3 for other compartments that are added to the statevector) + ! lets loop over known layers + + ! first do canopy water to check how many variables are for this gridcell available next to snow and surface water as well as the layers + ! compartments to subtract from dim_l to get layers variables: + + if (clm_varsize_tws(5)/=0) then + sub=3 + else + sub=2 + end if + + + select case (state_setup) + case(0) ! liq and ice seperated + g = hactiveg_levels(domain_p,1) + do i = 1, (dim_l-sub)/2 ! two entries for liq and ice seperated + 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_l(i) = state_p(j) ! first liquid water as it is first in the statevector + state_l(i+(dim_l-3)/2) = state_p(j+clm_varsize_tws(1)) + else + state_l(i) = state_p(j + sum(num_layer(1:i-1))) + state_l(i+(dim_l-3)/2) = state_p(j + sum(num_layer(1:i-1)) + clm_varsize_tws(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 + clm_varsize_tws(1) + clm_varsize_tws(2)) + state_l(dim_l-1) = state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3)) + state_l(dim_l) = state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3) + clm_varsize_tws(4)) + else + state_l(dim_l-1) = state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2)) + state_l(dim_l) = state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3)) + end if + end if + end do + + case(1) + + g = hactiveg_levels(domain_p,1) + do i = 1, dim_l-sub ! liq and ice added up + 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_l(i) = state_p(j) ! first liquid water as it is first in the statevector + 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 + clm_varsize_tws(1) + clm_varsize_tws(2)) + state_l(dim_l-1) = state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3)) + state_l(dim_l) = state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3) + clm_varsize_tws(4)) + else + state_l(dim_l-1) = state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2)) + state_l(dim_l) = state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3)) + end if + end if + end do + + case(2) ! 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(3) + + 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) + state_l(2) = state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2)) + end if + end do + + case(4) + + 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) + state_l(dim_l) = state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2)) + end if + end do + + if (dim_l==3) then + do j = 1, num_layer(8) + if (g==hactiveg_levels(j,8)) then + state_l(2) = state_p(j + clm_varsize_tws(1)) + end if + end do + end if + + case(5) + + 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) + state_l(dim_l) = state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3)) + 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)) + 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 + clm_varsize_tws(1) + clm_varsize_tws(2)) + end if + end do + end if + + end select + + end if #endif END SUBROUTINE g2l_state_pdaf diff --git a/interface/framework/init_dim_l_pdaf.F90 b/interface/framework/init_dim_l_pdaf.F90 index 09bd9bdb1..ef4c0220f 100644 --- a/interface/framework/init_dim_l_pdaf.F90 +++ b/interface/framework/init_dim_l_pdaf.F90 @@ -49,7 +49,11 @@ SUBROUTINE init_dim_l_pdaf(step, domain_p, dim_l) tag_model_clm, model USE mod_tsmp, & ONLY: init_dim_l_pfl + use clm_varpar , only : nlevsoi #ifdef CLMSA + USE enkf_clm_mod, & + ONLY: hactiveg_levels, num_layer, state_setup, num_hactiveg_patch, hactiveg_patch, clm_varsize_tws + USE enkf_clm_mod, ONLY: clmupdate_tws USE enkf_clm_mod, ONLY: init_dim_l_clm #endif IMPLICIT NONE @@ -59,6 +63,8 @@ SUBROUTINE init_dim_l_pdaf(step, domain_p, dim_l) INTEGER, INTENT(in) :: domain_p ! Current local analysis domain INTEGER, INTENT(out) :: dim_l ! Local state dimension + integer :: g, i, count + ! !CALLING SEQUENCE: ! Called by: PDAF_lseik_update (as U_init_dim_l) ! Called by: PDAF_lestkf_update (as U_init_dim_l) @@ -68,6 +74,7 @@ SUBROUTINE init_dim_l_pdaf(step, domain_p, dim_l) ! **************************************** ! *** Initialize local state dimension *** ! **************************************** + #if defined PARFLOW_STAND_ALONE ! Set the size of the local analysis domain call init_dim_l_pfl(dim_l) @@ -88,7 +95,91 @@ SUBROUTINE init_dim_l_pdaf(step, domain_p, dim_l) ! Set the size of the local analysis domain ! for clm stand alone mode only + if (clmupdate_tws/=1) then call init_dim_l_clm(domain_p, dim_l) + end if + + ! Set the size of the local analysis domain + ! for clm stand alone mode only + if (clmupdate_tws==1) then + + ! initialize local state dimension --> different for each domain as a domain is a gridcell, number of layers in statevector differs per gridcell + ! --> check with begg and endg as well as domain_p and hactiveg_levels what is going on + ! hactiveg_levels in level 1 at position domain_p gives gridcell index of domain_p --> go through rest of hactiveg_levels and check for number of layers + dim_l = 0 + g = hactiveg_levels(domain_p,1) + + select case(state_setup) + case(0) + do i = 1,nlevsoi + do count = 1, num_layer(i) + if (g==hactiveg_levels(count,i)) then + dim_l = dim_l+2 + end if + end do + end do + + ! snow and surface water + dim_l = dim_l+2 + + ! canopy water + if (clm_varsize_tws(5)/=0) then + dim_l = dim_l+1 + end if + + case(1) + do i = 1,nlevsoi + do count = 1, num_layer(i) + if (g==hactiveg_levels(count,i)) then + dim_l = dim_l+1 + 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(2) ! only TWS in statevector + + dim_l=1 + + case(3) ! sum over all soil layers and snow in statevector + + dim_l=2 + + case(4) + + dim_l=2 + + do count = 1, num_layer(8) + if (g==hactiveg_levels(count,8)) then + dim_l = dim_l+1 + end if + end do + + case(5) + + 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 + + end if #endif END SUBROUTINE init_dim_l_pdaf diff --git a/interface/framework/init_dim_obs_f_pdaf.F90 b/interface/framework/init_dim_obs_f_pdaf.F90 index a0280f9c6..70c33f728 100755 --- a/interface/framework/init_dim_obs_f_pdaf.F90 +++ b/interface/framework/init_dim_obs_f_pdaf.F90 @@ -61,6 +61,8 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) USE mpi, ONLY: MPI_ALLREDUCE USE mpi, ONLY: MPI_SUM USE mpi, ONLY: MPI_IN_PLACE + USE mpi, ONLY: MPI_2INTEGER + USE mpi, ONLY: MPI_MAXLOC USE mod_parallel_pdaf, & ONLY: mype_filter, comm_filter, npes_filter, abort_parallel, & mype_world @@ -73,6 +75,10 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) obs_pdaf2nc, & local_dims_obs, & local_disp_obs, & + obs_id_p, & + obscov, obscov_inv, filtertype, & + tws_temp_mean_d, & + temp_mean_filename, & dim_obs_p #ifndef PARFLOW_STAND_ALONE #ifndef OBS_ONLY_PARFLOW @@ -107,6 +113,13 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) clm_obs, & var_id_obs_nc, dim_nx, dim_ny, & clmobs_lon, clmobs_lat, clmobs_layer, clmobs_dr, clm_obserr + USE mod_read_obs, & + only: clm_obscov, vec_useObs, vec_useObs_global, vec_numPoints_global, & + lon_temp_mean, lat_temp_mean, tws_temp_mean +#ifdef CLMFIVE + USE mod_read_obs, & + only: read_temp_mean_model, domain_def_clm_tws +#endif use mod_read_obs, only: dampfac_state_time_dependent_in use mod_read_obs, only: dampfac_param_time_dependent_in use mod_tsmp, & @@ -131,6 +144,7 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) use ColumnType, only : col ! use GetGlobalValuesMod, only: GetGlobalWrite ! use clm_varcon, only: nameg + use clm_varcon, only: spval use enkf_clm_mod, only: state_clm2pdaf_p use enkf_clm_mod, only: clmstatevec_only_active use enkf_clm_mod, only: clmstatevec_max_layer @@ -146,6 +160,9 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) USE enkf_clm_mod, only: get_interp_idx use enkf_clm_mod, only: clmstatevec_allcol !hcp end + USE enkf_clm_mod, only: clmupdate_tws + USE enkf_clm_mod, only: num_layer + USE enkf_clm_mod, only: hactiveg_levels #endif #endif @@ -170,6 +187,7 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) INTEGER :: i,j,k ! Counters INTEGER :: cnt ! Counters INTEGER :: cnt_interp ! Counter for interpolation grid cells + INTEGER :: count_points, countR, countC ! Counters INTEGER :: m,l ! Counters logical :: is_multi_observation_files character (len = 110) :: current_observation_filename @@ -191,10 +209,19 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) integer :: numc ! total number of columns across all processors integer :: nump ! total number of pfts across all processors real :: deltax, deltay + real :: dist !real :: deltaxy, y1 , x1, z1, x2, y2, z2, R, dist, deltaxy_max logical :: is_use_dr logical :: obs_snapped !Switch for checking multiple observation counts logical :: newgridcell + 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(:,:) + INTEGER, ALLOCATABLE :: ipiv(:) + real, ALLOCATABLE :: work(:) + real, allocatable :: obs_lon(:) + real, allocatable :: obs_lat(:) + real(r8) :: pi #endif #endif @@ -356,6 +383,10 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) if(allocated(clm_obserr)) deallocate(clm_obserr) allocate(clm_obserr(dim_obs)) end if + if(multierr==2) then + if(allocated(clm_obscov)) deallocate(clm_obscov) + allocate(clm_obscov(dim_obs, dim_obs)) + end if ! end if #endif #endif @@ -389,6 +420,7 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) ! if exist CLM-type obs call mpi_bcast(clm_obs, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) if(multierr==1) call mpi_bcast(clm_obserr, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) + if(multierr==2) call mpi_bcast(clm_obscov, dim_obs*dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) call mpi_bcast(clmobs_lon, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) call mpi_bcast(clmobs_lat, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) call mpi_bcast(clmobs_dr, 2, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) @@ -411,7 +443,9 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) ! if exist CLM-type obs if(model == tag_model_clm) then ! Generate CLM index arrays from lon/lat values - call domain_def_clm(clmobs_lon, clmobs_lat, dim_obs, longxy, latixy, longxy_obs, latixy_obs) + if(clmupdate_tws/=1) then + call domain_def_clm(clmobs_lon, clmobs_lat, dim_obs, longxy, latixy, longxy_obs, latixy_obs) + end if ! Interpolation of measured states: Save the indices of the ! nearest grid points @@ -461,6 +495,7 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) #ifndef PARFLOW_STAND_ALONE #ifndef OBS_ONLY_PARFLOW + NOGRACE1: if(clmupdate_tws/=1) then ! Switch for how to check index of CLM observations ! True: Use snapping distance between long/lat on CLM grid ! False: Use index arrays from `domain_def_clm` @@ -508,9 +543,44 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) end do end do end if + end if NOGRACE1 +#endif +#endif + +#ifndef PARFLOW_STAND_ALONE +#ifndef OBS_ONLY_PARFLOW + NOGRACE2: if(clmupdate_tws/=1) then + + if (screen > 2) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_pdaf: dim_obs_p=", dim_obs_p + end if + + ! 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) + + ! Set dimension of full observation vector + dim_obs_f = sum_dim_obs_p + + ! 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 + + end if NOGRACE2 #endif #endif +#ifndef CLMSA +#ifndef OBS_ONLY_CLM + if (screen > 2) then print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_pdaf: dim_obs_p=", dim_obs_p end if @@ -534,6 +604,46 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) call abort_parallel() end if +#endif +#endif + + +#ifndef PARFLOW_STAND_ALONE +#ifndef OBS_ONLY_PARFLOW + NOGRACE3: if(clmupdate_tws/=1) then + + ! 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 + +end if NOGRACE3 +#endif +#endif + +#ifndef CLMSA +#ifndef OBS_ONLY_CLM + ! Gather PE-local observation dimensions and displacements in arrays ! ---------------------------------------------------------------- @@ -559,6 +669,12 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_pdaf: local_disp_obs=", local_disp_obs end if +#endif +#endif + +#ifndef PARFLOW_STAND_ALONE +#ifndef OBS_ONLY_PARFLOW + NOGRACE4: if(clmupdate_tws/=1) then ! Write index mapping array NetCDF->PDAF ! -------------------------------------- ! Set index mapping `obs_pdaf2nc` between observation order in @@ -594,29 +710,6 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) allocate(obs_nc2pdaf(dim_obs)) obs_nc2pdaf = 0 -#ifndef CLMSA -#ifndef OBS_ONLY_CLM - if (model == tag_model_parflow) then - if (point_obs==1) then - - cnt = 1 - do i = 1, dim_obs - do j = 1, enkf_subvecsize - if (idx_obs_nc(i) == idx_map_subvec2state_fortran(j)) then - obs_pdaf2nc(local_disp_obs(mype_filter+1)+cnt) = i - obs_nc2pdaf(i) = local_disp_obs(mype_filter+1)+cnt - cnt = cnt + 1 - end if - end do - end do - - end if - end if -#endif -#endif - -#ifndef PARFLOW_STAND_ALONE -#ifndef OBS_ONLY_PARFLOW if(model == tag_model_clm) then if (point_obs==1) then @@ -654,9 +747,77 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) end if 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 + + + end if NOGRACE4 #endif #endif + +#ifndef CLMSA +#ifndef OBS_ONLY_CLM + + ! 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 (model == tag_model_parflow) then + if (point_obs==1) then + + cnt = 1 + do i = 1, dim_obs + do j = 1, enkf_subvecsize + if (idx_obs_nc(i) == idx_map_subvec2state_fortran(j)) then + obs_pdaf2nc(local_disp_obs(mype_filter+1)+cnt) = i + obs_nc2pdaf(i) = local_disp_obs(mype_filter+1)+cnt + cnt = cnt + 1 + end if + end do + end do + + end if + 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) @@ -666,6 +827,12 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_pdaf: obs_pdaf2nc=", obs_pdaf2nc end if +#endif +#endif + +#ifndef PARFLOW_STAND_ALONE +#ifndef OBS_ONLY_PARFLOW + NOGRACE5: if(clmupdate_tws/=1) then ! Write process-local observation arrays ! -------------------------------------- @@ -689,228 +856,50 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) ALLOCATE(var_id_obs(dim_obs_p)) end if -#ifndef CLMSA -#ifndef OBS_ONLY_CLM - if (model == tag_model_parflow) then - ! allocate pressure_obserr_p observation error for parflow run at PE-local domain -! if((multierr.eq.1) .and. (.not.allocated(pressure_obserr_p))) allocate(pressure_obserr_p(dim_obs_p)) - !hcp pressure_obserr_p must be reallocated because the numbers of obs are - !not necessary the same for all observation files. + if(model == tag_model_clm) then + ! allocate clm_obserr_p observation error for clm run at PE-local domain +! if((multierr.eq.1) .and. (.not.allocated(clm_obserr_p))) allocate(clm_obserr_p(dim_obs_p)) if(multierr==1) then - if (allocated(pressure_obserr_p)) deallocate(pressure_obserr_p) - allocate(pressure_obserr_p(dim_obs_p)) - endif - - if(crns_flag==1) then - if (allocated(sc_p)) deallocate(sc_p) - allocate(sc_p(nz_glob, dim_obs_p)) - if (allocated(idx_obs_nc_p)) deallocate(idx_obs_nc_p) - allocate(idx_obs_nc_p(dim_obs_p)) + if (allocated(clm_obserr_p)) deallocate(clm_obserr_p) + allocate(clm_obserr_p(dim_obs_p)) endif - !hcp fin - - if (point_obs==0) then + if(point_obs==0) then max_var_id = MAXVAL(var_id_obs_nc(:,:)) + if(allocated(lon_var_id)) deallocate(lon_var_id) + allocate(lon_var_id(max_var_id)) + if(allocated(lat_var_id)) deallocate(lat_var_id) + allocate(lat_var_id(max_var_id)) + if(allocated(maxlon)) deallocate(maxlon) + allocate(maxlon(max_var_id)) + if(allocated(minlon)) deallocate(minlon) + allocate(minlon(max_var_id)) + if(allocated(maxlat)) deallocate(maxlat) + allocate(maxlat(max_var_id)) + if(allocated(minlat)) deallocate(minlat) + allocate(minlat(max_var_id)) - if(allocated(ix_var_id)) deallocate(ix_var_id) - allocate(ix_var_id(max_var_id)) - if(allocated(iy_var_id)) deallocate(iy_var_id) - allocate(iy_var_id(max_var_id)) - - if(allocated(maxix)) deallocate(maxix) - allocate(maxix(max_var_id)) - if(allocated(minix)) deallocate(minix) - allocate(minix(max_var_id)) - if(allocated(maxiy)) deallocate(maxiy) - allocate(maxiy(max_var_id)) - if(allocated(miniy)) deallocate(miniy) - allocate(miniy(max_var_id)) - - ix_var_id(:) = 0 - iy_var_id(:) = 0 - maxix = -999 - minix = 9999999 - maxiy = -999 - miniy = 9999999 + lon_var_id(:) = 0 + lat_var_id(:) = 0 + maxlon = -999 + minlon = 9999999 + maxlat = -999 + minlat = 9999999 do j = 1, max_var_id do m = 1, dim_nx do k = 1, dim_ny i = (m-1)* dim_ny + k if (var_id_obs_nc(k,m) == j) then - maxix(j) = MAX(x_idx_obs_nc(i),maxix(j)) - minix(j) = MIN(x_idx_obs_nc(i),minix(j)) - maxiy(j) = MAX(y_idx_obs_nc(i),maxiy(j)) - miniy(j) = MIN(y_idx_obs_nc(i),miniy(j)) + maxlon(j) = MAX(longxy_obs(i),maxlon(j)) + minlon(j) = MIN(longxy_obs(i),minlon(j)) + maxlat(j) = MAX(latixy_obs(i),maxlat(j)) + minlat(j) = MIN(latixy_obs(i),minlat(j)) end if end do - end do - ix_var_id(j) = (maxix(j) + minix(j))/2.0 - iy_var_id(j) = (maxiy(j) + miniy(j))/2.0 - end do - - cnt = 1 - do m = 1, dim_nx - do k = 1, dim_ny - i = (m-1)* dim_ny + k - obs(i) = pressure_obs(i) - ! coords_obs(1, i) = idx_obs_nc(i) - do j = 1, enkf_subvecsize - if (idx_obs_nc(i) == idx_map_subvec2state_fortran(j)) then - obs_index_p(cnt) = j - obs_p(cnt) = pressure_obs(i) - var_id_obs(cnt) = var_id_obs_nc(k,m) - if(multierr==1) pressure_obserr_p(cnt) = pressure_obserr(i) - cnt = cnt + 1 - end if - end do - end do - end do - else if (point_obs==1) then - - !hcp - if(crns_flag==1) then - idx_obs_nc(:)=nx_glob*(y_idx_obs_nc(:)-1)+x_idx_obs_nc(:) - endif - !hcp fin - cnt = 1 - do i = 1, dim_obs - obs(i) = pressure_obs(i) - ! coords_obs(1, i) = idx_obs_nc(i) - do j = 1, enkf_subvecsize - if (idx_obs_nc(i) == idx_map_subvec2state_fortran(j)) then - !print *, j - !obs_index(cnt) = j - !obs(cnt) = pressure_obs(i) - obs_index_p(cnt) = j - obs_p(cnt) = pressure_obs(i) - if(multierr==1) pressure_obserr_p(cnt) = pressure_obserr(i) - if(crns_flag==1) then - idx_obs_nc_p(cnt)=idx_obs_nc(i) - !Allocate(sc_p(cnt)%scol_obs_in(nz_glob)) - endif - cnt = cnt + 1 - end if - end do - end do - do i = 1, dim_obs_p - if(crns_flag==1) then - do k = 1, nz_glob - k_cnt=idx_obs_nc_p(i)+(k-1)*nx_glob*ny_glob - do j = 1, enkf_subvecsize - if (k_cnt == idx_map_subvec2state_fortran(j)) sc_p(nz_glob-k+1,i)=j - enddo - enddo - endif - enddo - - 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 j = 1, enkf_subvecsize - ! First: ix and iy smaller than observation location - if (idx_obs_nc(i) == idx_map_subvec2state_fortran(j)) then - obs_interp_indices_p(cnt, 1) = j - obs_interp_weights_p(cnt, 1) = sqrt(abs(x_idx_interp_d_obs_nc(i)) * abs(x_idx_interp_d_obs_nc(i)) + & - abs(y_idx_interp_d_obs_nc(i)) * abs(y_idx_interp_d_obs_nc(i))) - cnt_interp = cnt_interp + 1 - end if - ! Second: ix larger than observation location, iy smaller - if (idx_obs_nc(i) + 1 == idx_map_subvec2state_fortran(j)) then - obs_interp_indices_p(cnt, 2) = j - obs_interp_weights_p(cnt, 2) = sqrt(abs(1.0-x_idx_interp_d_obs_nc(i)) * abs(1.0-x_idx_interp_d_obs_nc(i)) + & - abs(y_idx_interp_d_obs_nc(i)) * abs(y_idx_interp_d_obs_nc(i))) - cnt_interp = cnt_interp + 1 - end if - ! Third: ix smaller than observation location, iy larger - if (idx_obs_nc(i) + nx_glob == idx_map_subvec2state_fortran(j)) then - obs_interp_indices_p(cnt, 3) = j - obs_interp_weights_p(cnt, 3) = sqrt(abs(x_idx_interp_d_obs_nc(i)) * abs(x_idx_interp_d_obs_nc(i)) + & - abs(1.0-y_idx_interp_d_obs_nc(i)) * abs(1.0-y_idx_interp_d_obs_nc(i))) - cnt_interp = cnt_interp + 1 - end if - ! Fourth: ix and iy larger than observation location - if (idx_obs_nc(i) + nx_glob + 1 == idx_map_subvec2state_fortran(j)) then - obs_interp_indices_p(cnt, 4) = j - obs_interp_weights_p(cnt, 4) = sqrt(abs(1.0-x_idx_interp_d_obs_nc(i)) * abs(1.0-x_idx_interp_d_obs_nc(i)) + & - abs(1.0-y_idx_interp_d_obs_nc(i)) * abs(1.0-y_idx_interp_d_obs_nc(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 - - end if - end if -#endif -#endif - -#ifndef PARFLOW_STAND_ALONE -#ifndef OBS_ONLY_PARFLOW - if(model == tag_model_clm) then - ! allocate clm_obserr_p observation error for clm run at PE-local domain -! if((multierr.eq.1) .and. (.not.allocated(clm_obserr_p))) allocate(clm_obserr_p(dim_obs_p)) - if(multierr==1) then - if (allocated(clm_obserr_p)) deallocate(clm_obserr_p) - allocate(clm_obserr_p(dim_obs_p)) - endif - if(point_obs==0) then - max_var_id = MAXVAL(var_id_obs_nc(:,:)) - if(allocated(lon_var_id)) deallocate(lon_var_id) - allocate(lon_var_id(max_var_id)) - if(allocated(lat_var_id)) deallocate(lat_var_id) - allocate(lat_var_id(max_var_id)) - if(allocated(maxlon)) deallocate(maxlon) - allocate(maxlon(max_var_id)) - if(allocated(minlon)) deallocate(minlon) - allocate(minlon(max_var_id)) - if(allocated(maxlat)) deallocate(maxlat) - allocate(maxlat(max_var_id)) - if(allocated(minlat)) deallocate(minlat) - allocate(minlat(max_var_id)) - - lon_var_id(:) = 0 - lat_var_id(:) = 0 - maxlon = -999 - minlon = 9999999 - maxlat = -999 - minlat = 9999999 - do j = 1, max_var_id - do m = 1, dim_nx - do k = 1, dim_ny - i = (m-1)* dim_ny + k - if (var_id_obs_nc(k,m) == j) then - maxlon(j) = MAX(longxy_obs(i),maxlon(j)) - minlon(j) = MIN(longxy_obs(i),minlon(j)) - maxlat(j) = MAX(latixy_obs(i),maxlat(j)) - minlat(j) = MIN(latixy_obs(i),minlat(j)) - end if - end do - lon_var_id(j) = (maxlon(j) + minlon(j))/2.0 - lat_var_id(j) = (maxlat(j) + minlat(j))/2.0 - !print *, 'j lon_var_id lat_var_id ', j, lon_var_id(j), lat_var_id(j) - enddo ! allocate clm_obserr_p observation error for clm run at PE-local domain - enddo + lon_var_id(j) = (maxlon(j) + minlon(j))/2.0 + lat_var_id(j) = (maxlat(j) + minlat(j))/2.0 + !print *, 'j lon_var_id lat_var_id ', j, lon_var_id(j), lat_var_id(j) + enddo ! allocate clm_obserr_p observation error for clm run at PE-local domain + enddo cnt = 1 do m = 1, dim_nx @@ -1069,9 +1058,220 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) end if 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 + + end if NOGRACE5 #endif #endif +#ifndef CLMSA +#ifndef OBS_ONLY_CLM + + ! Write process-local observation arrays + ! -------------------------------------- + IF (ALLOCATED(obs)) DEALLOCATE(obs) + ALLOCATE(obs(dim_obs)) + !IF (ALLOCATED(obs_index)) DEALLOCATE(obs_index) + !ALLOCATE(obs_index(dim_obs)) + 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 + if(point_obs==0) then + IF (ALLOCATED(var_id_obs)) DEALLOCATE(var_id_obs) + ALLOCATE(var_id_obs(dim_obs_p)) + end if + + if (model == tag_model_parflow) then + ! allocate pressure_obserr_p observation error for parflow run at PE-local domain +! if((multierr.eq.1) .and. (.not.allocated(pressure_obserr_p))) allocate(pressure_obserr_p(dim_obs_p)) + !hcp pressure_obserr_p must be reallocated because the numbers of obs are + !not necessary the same for all observation files. + if(multierr==1) then + if (allocated(pressure_obserr_p)) deallocate(pressure_obserr_p) + allocate(pressure_obserr_p(dim_obs_p)) + endif + + if(crns_flag==1) then + if (allocated(sc_p)) deallocate(sc_p) + allocate(sc_p(nz_glob, dim_obs_p)) + if (allocated(idx_obs_nc_p)) deallocate(idx_obs_nc_p) + allocate(idx_obs_nc_p(dim_obs_p)) + endif + !hcp fin + + if (point_obs==0) then + max_var_id = MAXVAL(var_id_obs_nc(:,:)) + + if(allocated(ix_var_id)) deallocate(ix_var_id) + allocate(ix_var_id(max_var_id)) + if(allocated(iy_var_id)) deallocate(iy_var_id) + allocate(iy_var_id(max_var_id)) + + if(allocated(maxix)) deallocate(maxix) + allocate(maxix(max_var_id)) + if(allocated(minix)) deallocate(minix) + allocate(minix(max_var_id)) + if(allocated(maxiy)) deallocate(maxiy) + allocate(maxiy(max_var_id)) + if(allocated(miniy)) deallocate(miniy) + allocate(miniy(max_var_id)) + + ix_var_id(:) = 0 + iy_var_id(:) = 0 + maxix = -999 + minix = 9999999 + maxiy = -999 + miniy = 9999999 + do j = 1, max_var_id + do m = 1, dim_nx + do k = 1, dim_ny + i = (m-1)* dim_ny + k + if (var_id_obs_nc(k,m) == j) then + maxix(j) = MAX(x_idx_obs_nc(i),maxix(j)) + minix(j) = MIN(x_idx_obs_nc(i),minix(j)) + maxiy(j) = MAX(y_idx_obs_nc(i),maxiy(j)) + miniy(j) = MIN(y_idx_obs_nc(i),miniy(j)) + end if + end do + end do + ix_var_id(j) = (maxix(j) + minix(j))/2.0 + iy_var_id(j) = (maxiy(j) + miniy(j))/2.0 + end do + + cnt = 1 + do m = 1, dim_nx + do k = 1, dim_ny + i = (m-1)* dim_ny + k + obs(i) = pressure_obs(i) + ! coords_obs(1, i) = idx_obs_nc(i) + do j = 1, enkf_subvecsize + if (idx_obs_nc(i) == idx_map_subvec2state_fortran(j)) then + obs_index_p(cnt) = j + obs_p(cnt) = pressure_obs(i) + var_id_obs(cnt) = var_id_obs_nc(k,m) + if(multierr==1) pressure_obserr_p(cnt) = pressure_obserr(i) + cnt = cnt + 1 + end if + end do + end do + end do + else if (point_obs==1) then + + !hcp + if(crns_flag==1) then + idx_obs_nc(:)=nx_glob*(y_idx_obs_nc(:)-1)+x_idx_obs_nc(:) + endif + !hcp fin + cnt = 1 + do i = 1, dim_obs + obs(i) = pressure_obs(i) + ! coords_obs(1, i) = idx_obs_nc(i) + do j = 1, enkf_subvecsize + if (idx_obs_nc(i) == idx_map_subvec2state_fortran(j)) then + !print *, j + !obs_index(cnt) = j + !obs(cnt) = pressure_obs(i) + obs_index_p(cnt) = j + obs_p(cnt) = pressure_obs(i) + if(multierr==1) pressure_obserr_p(cnt) = pressure_obserr(i) + if(crns_flag==1) then + idx_obs_nc_p(cnt)=idx_obs_nc(i) + !Allocate(sc_p(cnt)%scol_obs_in(nz_glob)) + endif + cnt = cnt + 1 + end if + end do + end do + do i = 1, dim_obs_p + if(crns_flag==1) then + do k = 1, nz_glob + k_cnt=idx_obs_nc_p(i)+(k-1)*nx_glob*ny_glob + do j = 1, enkf_subvecsize + if (k_cnt == idx_map_subvec2state_fortran(j)) sc_p(nz_glob-k+1,i)=j + enddo + enddo + endif + enddo + + 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 j = 1, enkf_subvecsize + ! First: ix and iy smaller than observation location + if (idx_obs_nc(i) == idx_map_subvec2state_fortran(j)) then + obs_interp_indices_p(cnt, 1) = j + obs_interp_weights_p(cnt, 1) = sqrt(abs(x_idx_interp_d_obs_nc(i)) * abs(x_idx_interp_d_obs_nc(i)) + & + abs(y_idx_interp_d_obs_nc(i)) * abs(y_idx_interp_d_obs_nc(i))) + cnt_interp = cnt_interp + 1 + end if + ! Second: ix larger than observation location, iy smaller + if (idx_obs_nc(i) + 1 == idx_map_subvec2state_fortran(j)) then + obs_interp_indices_p(cnt, 2) = j + obs_interp_weights_p(cnt, 2) = sqrt(abs(1.0-x_idx_interp_d_obs_nc(i)) * abs(1.0-x_idx_interp_d_obs_nc(i)) + & + abs(y_idx_interp_d_obs_nc(i)) * abs(y_idx_interp_d_obs_nc(i))) + cnt_interp = cnt_interp + 1 + end if + ! Third: ix smaller than observation location, iy larger + if (idx_obs_nc(i) + nx_glob == idx_map_subvec2state_fortran(j)) then + obs_interp_indices_p(cnt, 3) = j + obs_interp_weights_p(cnt, 3) = sqrt(abs(x_idx_interp_d_obs_nc(i)) * abs(x_idx_interp_d_obs_nc(i)) + & + abs(1.0-y_idx_interp_d_obs_nc(i)) * abs(1.0-y_idx_interp_d_obs_nc(i))) + cnt_interp = cnt_interp + 1 + end if + ! Fourth: ix and iy larger than observation location + if (idx_obs_nc(i) + nx_glob + 1 == idx_map_subvec2state_fortran(j)) then + obs_interp_indices_p(cnt, 4) = j + obs_interp_weights_p(cnt, 4) = sqrt(abs(1.0-x_idx_interp_d_obs_nc(i)) * abs(1.0-x_idx_interp_d_obs_nc(i)) + & + abs(1.0-y_idx_interp_d_obs_nc(i)) * abs(1.0-y_idx_interp_d_obs_nc(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 + + end if + end if + #ifdef PDAF_DEBUG IF (da_print_obs_index > 0) THEN ! TSMP-PDAF: For debug runs, output the state vector in files @@ -1084,10 +1284,223 @@ SUBROUTINE init_dim_obs_f_pdaf(step, dim_obs_f) END IF #endif +#endif +#endif + +#ifndef PARFLOW_STAND_ALONE +#ifndef OBS_ONLY_PARFLOW +#ifdef CLMFIVE + GRACE1: if(clmupdate_tws==1) then + + is_use_dr = .false. + + call domain_def_clm_tws(clmobs_lon, clmobs_lat, dim_obs, longxy, latixy, longxy_obs, latixy_obs) + + if (ALLOCATED(vec_useObs_global).eqv..false.) then + 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 + do i = 1, dim_obs + count_points = 0 + ! only take gridcells into account that have at least one hydrological active column + do c = 1, num_layer(1) + deltax = abs(longxy(c)-longxy_obs(i)) + deltay = abs(latixy(c)-latixy_obs(i)) + dist = sqrt(real(deltax)**2 + real(deltay)**2) + + ! EUR-11 Grid --> 1 gridcell every 1/0.11° + if(dist<=clmobs_dr(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 + 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 + !numPoints = int(ceiling((clmobs_dr(1)*2/0.11 * clmobs_dr(2)*2/0.11)/2.0)) + pi = 3.14159265358979323846 + numPoints = int(ceiling((pi*(clmobs_dr(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 + + 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(obs_id_p)) deallocate(obs_id_p) + allocate(obs_id_p(begg:endg)) + obs_id_p(:) = 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)) + dist = sqrt(real(deltax)**2 + real(deltay)**2) + + if(dist<=clmobs_dr(1)/0.11) then + obs_id_p(j) = i + end if + end do + end if + end do + + end if + + + dim_obs = count(vec_useObs_global) + dim_obs_f = dim_obs + + IF (ALLOCATED(obs)) DEALLOCATE(obs) + ALLOCATE(obs(dim_obs_f)) + + obs = pack(clm_obs,vec_useObs_global) + obs_p = pack(clm_obs,vec_useObs) + + + ! Overwrite longxy_obs and latixy_obs as the observation dimension could be smaller now + + if (allocated(obs_lon)) deallocate(obs_lon) + allocate(obs_lon(dim_obs)) + + if (allocated(obs_lat)) deallocate(obs_lat) + allocate(obs_lat(dim_obs)) + + obs_lon = pack(clmobs_lon,vec_useObs_global) + obs_lat = pack(clmobs_lat,vec_useObs_global) + + call domain_def_clm_tws(obs_lon, obs_lat, dim_obs, longxy, latixy, longxy_obs, latixy_obs) + + + if (multierr == 2) then + print *, 'Store observation covariance matrix' + IF (ALLOCATED(obscov)) DEALLOCATE(obscov) + ALLOCATE(obscov(dim_obs,dim_obs)) + ! First store covariance matrix + countR = 1 + countC = 1 + do i = 1, size(clm_obscov,1) + if(vec_useObs_global(i)) then + do j = 1, size(clm_obscov,2) + 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 + + print *, 'Compute inverse of observation covariance matrix' + IF (ALLOCATED(obscov_inv)) DEALLOCATE(obscov_inv) + ALLOCATE(obscov_inv(dim_obs,dim_obs)) + ALLOCATE(ipiv(dim_obs)) + ALLOCATE(work(dim_obs)) + obscov_inv = obscov + !LU factorization + call dgetrf(dim_obs,dim_obs,obscov_inv,dim_obs,ipiv,ierror) + ! Inverse using LU factorization + call dgetri(dim_obs, obscov_inv, dim_obs, ipiv, work, dim_obs, ierror) + if (ierror /= 0) then + stop 'init_dim_obs_pdaf: inversion failed!' + end if + IF (ALLOCATED(ipiv)) DEALLOCATE(ipiv) + IF (ALLOCATED(work)) DEALLOCATE(work) + + end if + end if GRACE1 +#endif +#endif +#endif ! clean up the temp data from nc file ! ------------------------------------ call clean_obs_nc() +#ifndef PARFLOW_STAND_ALONE +#ifndef OBS_ONLY_PARFLOW +#ifdef CLMFIVE + ! Read temporal mean TWS from model for observation operator, only for GRACE data assimilation + GRACE2: if (clmupdate_tws==1) then + ! do it only in the first call of this routine + + if (.not. allocated(tws_temp_mean_d)) then + + ! fill tws_temp mean, lat_temp_mean and lon_temp_mean + 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 + + !this process only need the sub domain information + do j = begg,endg + ! find lon and lat in the file that corresponds to that of the grid point of the sub process + outer3: 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 outer3 + end if + end do + end do outer3 + + 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 + end if GRACE2 +#endif +#endif +#endif + END SUBROUTINE init_dim_obs_f_pdaf diff --git a/interface/framework/init_dim_obs_l_pdaf.F90 b/interface/framework/init_dim_obs_l_pdaf.F90 index 04c25803f..a97df85cc 100755 --- a/interface/framework/init_dim_obs_l_pdaf.F90 +++ b/interface/framework/init_dim_obs_l_pdaf.F90 @@ -59,6 +59,7 @@ SUBROUTINE init_dim_obs_l_pdaf(domain_p, step, dim_obs_f, dim_obs_l) USE mod_read_obs, & ONLY: x_idx_obs_nc, y_idx_obs_nc, z_idx_obs_nc, idx_obs_nc, clmobs_lon, & clmobs_lat, var_id_obs_nc, dim_nx, dim_ny + ! USE mod_read_obs, ONLY: vec_useObs_global #if defined CLMSA USE mod_tsmp, & ONLY: idx_map_subvec2state_fortran, tag_model_parflow, enkf_subvecsize, & @@ -71,6 +72,9 @@ SUBROUTINE init_dim_obs_l_pdaf(domain_p, step, dim_obs_f, dim_obs_l) xcoord_fortran, ycoord_fortran, zcoord_fortran, & point_obs, model #endif + use enkf_clm_mod, only: hactiveg_levels + USE enkf_clm_mod, ONLY: clmupdate_tws + ! use GridcellType, only: grc #if defined CLMSA USE enkf_clm_mod, ONLY: state_loc2clm_c_p @@ -102,6 +106,7 @@ SUBROUTINE init_dim_obs_l_pdaf(domain_p, step, dim_obs_f, dim_obs_l) ! local variables INTEGER :: i, j, k, m, cnt ! Counters + INTEGER :: g ! Counters ! INTEGER :: idx, ix, iy, ix1, iy1 REAL :: dist ! Distance between observation and analysis domain LOGICAL, ALLOCATABLE :: log_var_id(:) ! logical variable ID for setting location observation vector using remote sensing data @@ -116,6 +121,16 @@ SUBROUTINE init_dim_obs_l_pdaf(domain_p, step, dim_obs_f, dim_obs_l) integer :: max_var_id, ierror integer :: obsind(dim_obs) real :: obsdist(dim_obs) + + ! real, pointer :: lon(:) + ! real, pointer :: lat(:) + + ! REAL, ALLOCATABLE :: obs_lon(:) + ! REAL, ALLOCATABLE :: obs_lat(:) + + ! lon => grc%londeg + ! lat => grc%latdeg + ! kuw end #if defined CLMSA @@ -218,7 +233,7 @@ SUBROUTINE init_dim_obs_l_pdaf(domain_p, step, dim_obs_f, dim_obs_l) obsind = 0 obsdist = 0.0 dim_obs_l = 0 - if(point_obs==0) then + if(point_obs==0 .and. clmupdate_tws/=1) then max_var_id = MAXVAL(var_id_obs_nc(:,:)) allocate(log_var_id(max_var_id)) log_var_id(:) = .TRUE. @@ -313,6 +328,43 @@ SUBROUTINE init_dim_obs_l_pdaf(domain_p, step, dim_obs_f, dim_obs_l) obsind(i) = 1 end if end do + + ! ! TWS-addition (outdated) + ! if (allocated(obs_lon)) deallocate(obs_lon) + ! if (allocated(obs_lat)) deallocate(obs_lat) + ! allocate(obs_lon(dim_obs)) + ! allocate(obs_lat(dim_obs)) + ! if (allocated(clmobs_lon)) then + ! print*, "lon is allocated" + ! else + ! print*, "lon is not allocated" + ! end if + + ! obs_lon = pack(clmobs_lon,vec_useObs_global) + ! obs_lat = pack(clmobs_lat,vec_useObs_global) + ! !if (allocated(clmobs_lon)) deallocate(clmobs_lon) + ! !if (allocated(clmobs_lat)) deallocate(clmobs_lat) + + ! do i = 1, dim_obs + ! ! check which gridcell domain_p is + ! g = hactiveg_levels(domain_p,1) + ! if (lon(g)<180) then + ! dx = abs(obs_lon(i) - lon(g)) + ! else + ! dx = abs(obs_lon(i) - (lon(g)-360)) + ! end if + ! dy = abs(obs_lat(i) - lat(g)) + ! a = sin(dy / 2)**2 + cos(obs_lat(i)) * cos(lat(g)) * sin(dx/ 2)**2 + ! c = 2 * atan2(sqrt(a), sqrt(1 - a)) + ! !dist = sqrt(real(dx)**2 + real(dy)**2) + ! dist = R*c + ! obsdist(i) = dist + ! if (dist <= real(cradius)) then + ! dim_obs_l = dim_obs_l + 1 + ! obsind(i) = 1 + ! end if + ! end do + end if end if #endif diff --git a/interface/framework/init_dim_obs_pdaf.F90 b/interface/framework/init_dim_obs_pdaf.F90 index 6ce590e63..fbae50b0b 100755 --- a/interface/framework/init_dim_obs_pdaf.F90 +++ b/interface/framework/init_dim_obs_pdaf.F90 @@ -57,6 +57,8 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) USE mpi, ONLY: MPI_ALLREDUCE USE mpi, ONLY: MPI_SUM USE mpi, ONLY: MPI_IN_PLACE + USE mpi, ONLY: MPI_2INTEGER + USE mpi, ONLY: MPI_MAXLOC USE mod_parallel_pdaf, & ONLY: mype_filter, comm_filter, npes_filter, abort_parallel, & mype_world @@ -68,8 +70,11 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) pressure_obserr_p, clm_obserr_p, & obs_pdaf2nc, & local_dims_obs, & - local_disp_obs - ! dim_obs_p, & + local_disp_obs, & + obs_id_p, & + obscov, obscov_inv, filtertype, & + tws_temp_mean_d, & + temp_mean_filename #ifndef PARFLOW_STAND_ALONE #ifndef OBS_ONLY_PARFLOW !hcp @@ -103,6 +108,13 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) clm_obs, & var_id_obs_nc, dim_nx, dim_ny, & clmobs_lon, clmobs_lat, clmobs_layer, clmobs_dr, clm_obserr + USE mod_read_obs, & + only: clm_obscov, vec_useObs, vec_useObs_global, vec_numPoints_global, & + lon_temp_mean, lat_temp_mean, tws_temp_mean +#ifdef CLMFIVE + USE mod_read_obs, & + only: read_temp_mean_model, domain_def_clm_tws +#endif use mod_read_obs, only: dampfac_state_time_dependent_in use mod_read_obs, only: dampfac_param_time_dependent_in use mod_tsmp, & @@ -127,6 +139,7 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) use ColumnType, only : col ! use GetGlobalValuesMod, only: GetGlobalWrite ! use clm_varcon, only: nameg + use clm_varcon, only: spval use enkf_clm_mod, only: state_clm2pdaf_p use enkf_clm_mod, only: clmstatevec_only_active use enkf_clm_mod, only: clmstatevec_max_layer @@ -142,6 +155,9 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) USE enkf_clm_mod, only: get_interp_idx use enkf_clm_mod, only: clmstatevec_allcol !hcp end + USE enkf_clm_mod, only: clmupdate_tws + USE enkf_clm_mod, only: num_layer + USE enkf_clm_mod, only: hactiveg_levels #endif #endif @@ -166,6 +182,7 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) INTEGER :: i,j,k ! Counters INTEGER :: cnt ! Counters INTEGER :: cnt_interp ! Counter for interpolation grid cells + INTEGER :: count_points, countR, countC ! Counters INTEGER :: m,l ! Counters logical :: is_multi_observation_files character (len = 110) :: current_observation_filename @@ -187,10 +204,19 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) integer :: numc ! total number of columns across all processors integer :: nump ! total number of pfts across all processors real :: deltax, deltay + real :: dist !real :: deltaxy, y1 , x1, z1, x2, y2, z2, R, dist, deltaxy_max logical :: is_use_dr logical :: obs_snapped !Switch for checking multiple observation counts logical :: newgridcell + 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(:,:) + INTEGER, ALLOCATABLE :: ipiv(:) + real, ALLOCATABLE :: work(:) + real, allocatable :: obs_lon(:) + real, allocatable :: obs_lat(:) + real(r8) :: pi #endif #endif @@ -352,6 +378,10 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) if(allocated(clm_obserr)) deallocate(clm_obserr) allocate(clm_obserr(dim_obs)) end if + if(multierr==2) then + if(allocated(clm_obscov)) deallocate(clm_obscov) + allocate(clm_obscov(dim_obs, dim_obs)) + end if ! end if #endif #endif @@ -385,6 +415,7 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) ! if exist CLM-type obs call mpi_bcast(clm_obs, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) if(multierr==1) call mpi_bcast(clm_obserr, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) + if(multierr==2) call mpi_bcast(clm_obscov, dim_obs*dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) call mpi_bcast(clmobs_lon, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) call mpi_bcast(clmobs_lat, dim_obs, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) call mpi_bcast(clmobs_dr, 2, MPI_DOUBLE_PRECISION, 0, comm_filter, ierror) @@ -407,7 +438,9 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) ! if exist CLM-type obs if(model == tag_model_clm) then ! Generate CLM index arrays from lon/lat values + if(clmupdate_tws/=1) then call domain_def_clm(clmobs_lon, clmobs_lat, dim_obs, longxy, latixy, longxy_obs, latixy_obs) + end if ! Interpolation of measured states: Save the indices of the ! nearest grid points @@ -452,11 +485,16 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) end do end do end if + + if (screen > 2) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_pdaf: dim_obs_p=", dim_obs_p + end if #endif #endif #ifndef PARFLOW_STAND_ALONE #ifndef OBS_ONLY_PARFLOW + NOGRACE1: if(clmupdate_tws/=1) then ! Switch for how to check index of CLM observations ! True: Use snapping distance between long/lat on CLM grid ! False: Use index arrays from `domain_def_clm` @@ -504,13 +542,18 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) end do end do end if -#endif -#endif if (screen > 2) then print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_pdaf: dim_obs_p=", dim_obs_p end if + end if NOGRACE1 +#endif +#endif + +#ifndef CLMSA +#ifndef OBS_ONLY_CLM + ! Dimension of full observation vector ! ------------------------------------ @@ -527,6 +570,69 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) call abort_parallel() end if +#endif +#endif + + +#ifndef PARFLOW_STAND_ALONE +#ifndef OBS_ONLY_PARFLOW + NOGRACE2: if(clmupdate_tws/=1) then + + ! 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 + + end if NOGRACE2 +#endif +#endif + +#ifndef CLMSA +#ifndef OBS_ONLY_CLM + + ! 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 + +#endif +#endif + +#ifndef PARFLOW_STAND_ALONE +#ifndef OBS_ONLY_PARFLOW + NOGRACE3: if(clmupdate_tws/=1) then + ! Gather PE-local observation dimensions and displacements in arrays ! ---------------------------------------------------------------- @@ -552,6 +658,13 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) print *, "TSMP-PDAF mype(w)=", mype_world, ": init_dim_obs_pdaf: local_disp_obs=", local_disp_obs end if + end if NOGRACE3 +#endif +#endif + +#ifndef CLMSA +#ifndef OBS_ONLY_CLM + ! Write index mapping array NetCDF->PDAF ! -------------------------------------- ! Set index mapping `obs_pdaf2nc` between observation order in @@ -587,8 +700,6 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) allocate(obs_nc2pdaf(dim_obs)) obs_nc2pdaf = 0 -#ifndef CLMSA -#ifndef OBS_ONLY_CLM if (model == tag_model_parflow) then if (point_obs==1) then @@ -605,11 +716,57 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) end if 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 + #endif #endif #ifndef PARFLOW_STAND_ALONE #ifndef OBS_ONLY_PARFLOW + NOGRACE4: if(clmupdate_tws/=1) then + ! 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(model == tag_model_clm) then if (point_obs==1) then @@ -647,8 +804,6 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) end if end if -#endif -#endif ! collect values from all PEs, by adding all PE-local arrays (works ! since only the subsection belonging to a specific PE is non-zero) @@ -660,6 +815,14 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) end if + end if NOGRACE4 +#endif +#endif + + +#ifndef CLMSA +#ifndef OBS_ONLY_CLM + ! Write process-local observation arrays ! -------------------------------------- IF (ALLOCATED(obs)) DEALLOCATE(obs) @@ -682,8 +845,6 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) ALLOCATE(var_id_obs(dim_obs_p)) end if -#ifndef CLMSA -#ifndef OBS_ONLY_CLM if (model == tag_model_parflow) then ! allocate pressure_obserr_p observation error for parflow run at PE-local domain ! if((multierr.eq.1) .and. (.not.allocated(pressure_obserr_p))) allocate(pressure_obserr_p(dim_obs_p)) @@ -855,11 +1016,48 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) end if 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 + #endif #endif #ifndef PARFLOW_STAND_ALONE #ifndef OBS_ONLY_PARFLOW + NOGRACE5: if(clmupdate_tws/=1) then + + ! Write process-local observation arrays + ! -------------------------------------- + IF (ALLOCATED(obs)) DEALLOCATE(obs) + ALLOCATE(obs(dim_obs)) + !IF (ALLOCATED(obs_index)) DEALLOCATE(obs_index) + !ALLOCATE(obs_index(dim_obs)) + 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 + if(point_obs==0) then + IF (ALLOCATED(var_id_obs)) DEALLOCATE(var_id_obs) + ALLOCATE(var_id_obs(dim_obs_p)) + end if + if(model == tag_model_clm) then ! allocate clm_obserr_p observation error for clm run at PE-local domain ! if((multierr.eq.1) .and. (.not.allocated(clm_obserr_p))) allocate(clm_obserr_p(dim_obs_p)) @@ -1062,8 +1260,6 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) end if end if -#endif -#endif #ifdef PDAF_DEBUG IF (da_print_obs_index > 0) THEN @@ -1077,10 +1273,223 @@ SUBROUTINE init_dim_obs_pdaf(step, dim_obs_p) END IF #endif + end if NOGRACE5 +#endif +#endif + +#ifndef PARFLOW_STAND_ALONE +#ifndef OBS_ONLY_PARFLOW +#ifdef CLMFIVE + GRACE1: if(clmupdate_tws==1) then + + is_use_dr = .false. + + call domain_def_clm_tws(clmobs_lon, clmobs_lat, dim_obs, longxy, latixy, longxy_obs, latixy_obs) + + if (ALLOCATED(vec_useObs_global).eqv..false.) then + 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 + do i = 1, dim_obs + count_points = 0 + ! only take gridcells into account that have at least one hydrological active column + do c = 1, num_layer(1) + deltax = abs(longxy(c)-longxy_obs(i)) + deltay = abs(latixy(c)-latixy_obs(i)) + dist = sqrt(real(deltax)**2 + real(deltay)**2) + + ! EUR-11 Grid --> 1 gridcell every 1/0.11° + if(dist<=clmobs_dr(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 + 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 + !numPoints = int(ceiling((clmobs_dr(1)*2/0.11 * clmobs_dr(2)*2/0.11)/2.0)) + pi = 3.14159265358979323846 + numPoints = int(ceiling((pi*(clmobs_dr(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 + + 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(obs_id_p)) deallocate(obs_id_p) + allocate(obs_id_p(begg:endg)) + obs_id_p(:) = 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)) + dist = sqrt(real(deltax)**2 + real(deltay)**2) + + if(dist<=clmobs_dr(1)/0.11) then + obs_id_p(j) = i + end if + end do + end if + end do + + end if + + + dim_obs = count(vec_useObs_global) + + IF (ALLOCATED(obs)) DEALLOCATE(obs) + ALLOCATE(obs(dim_obs)) + + obs = pack(clm_obs,vec_useObs_global) + obs_p = pack(clm_obs,vec_useObs) + + + ! Overwrite longxy_obs and latixy_obs as the observation dimension could be smaller now + + if (allocated(obs_lon)) deallocate(obs_lon) + allocate(obs_lon(dim_obs)) + + if (allocated(obs_lat)) deallocate(obs_lat) + allocate(obs_lat(dim_obs)) + + obs_lon = pack(clmobs_lon,vec_useObs_global) + obs_lat = pack(clmobs_lat,vec_useObs_global) + + call domain_def_clm_tws(obs_lon, obs_lat, dim_obs, longxy, latixy, longxy_obs, latixy_obs) + + + if (multierr == 2) then + print *, 'Store observation covariance matrix' + IF (ALLOCATED(obscov)) DEALLOCATE(obscov) + ALLOCATE(obscov(dim_obs,dim_obs)) + ! First store covariance matrix + countR = 1 + countC = 1 + do i = 1, size(clm_obscov,1) + if(vec_useObs_global(i)) then + do j = 1, size(clm_obscov,2) + 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 + + print *, 'Compute inverse of observation covariance matrix' + IF (ALLOCATED(obscov_inv)) DEALLOCATE(obscov_inv) + ALLOCATE(obscov_inv(dim_obs,dim_obs)) + ALLOCATE(ipiv(dim_obs)) + ALLOCATE(work(dim_obs)) + obscov_inv = obscov + !LU factorization + call dgetrf(dim_obs,dim_obs,obscov_inv,dim_obs,ipiv,ierror) + ! Inverse using LU factorization + call dgetri(dim_obs, obscov_inv, dim_obs, ipiv, work, dim_obs, ierror) + if (ierror /= 0) then + stop 'init_dim_obs_pdaf: inversion failed!' + end if + IF (ALLOCATED(ipiv)) DEALLOCATE(ipiv) + IF (ALLOCATED(work)) DEALLOCATE(work) + + end if + end if GRACE1 +#endif +#endif +#endif ! clean up the temp data from nc file ! ------------------------------------ call clean_obs_nc() +#ifndef PARFLOW_STAND_ALONE +#ifndef OBS_ONLY_PARFLOW +#ifdef CLMFIVE + ! Read temporal mean TWS from model for observation operator, only for GRACE data assimilation + GRACE2: if (clmupdate_tws==1) then + ! do it only in the first call of this routine + + if (.not. allocated(tws_temp_mean_d)) then + + ! fill tws_temp mean, lat_temp_mean and lon_temp_mean + 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 + + !this process only need the sub domain information + do j = begg,endg + ! find lon and lat in the file that corresponds to that of the grid point of the sub process + outer3: 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 outer3 + end if + end do + end do outer3 + + 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 + end if GRACE2 +#endif +#endif +#endif + END SUBROUTINE init_dim_obs_pdaf diff --git a/interface/framework/init_n_domains_pdaf.F90 b/interface/framework/init_n_domains_pdaf.F90 index 11988321b..5aeffb64c 100644 --- a/interface/framework/init_n_domains_pdaf.F90 +++ b/interface/framework/init_n_domains_pdaf.F90 @@ -53,6 +53,8 @@ SUBROUTINE init_n_domains_pdaf(step, n_domains_p) USE mod_tsmp, & ONLY: init_n_domains_pfl #if defined CLMSA + use enkf_clm_mod, only: num_hactiveg + USE enkf_clm_mod, ONLY: clmupdate_tws USE enkf_clm_mod, ONLY: init_n_domains_clm #endif @@ -86,7 +88,13 @@ SUBROUTINE init_n_domains_pdaf(step, n_domains_p) #endif #if defined CLMSA + if (clmupdate_tws/=1) then call init_n_domains_clm(n_domains_p) + end if + + if (clmupdate_tws==1) then + n_domains_p = num_hactiveg + end if #endif END SUBROUTINE init_n_domains_pdaf diff --git a/interface/framework/init_obscovar_pdaf.F90 b/interface/framework/init_obscovar_pdaf.F90 index bce76cf58..6e1fb8b8f 100644 --- a/interface/framework/init_obscovar_pdaf.F90 +++ b/interface/framework/init_obscovar_pdaf.F90 @@ -51,9 +51,12 @@ SUBROUTINE init_obscovar_pdaf(step, dim_obs, dim_obs_p, covar, m_state_p, & ONLY: rms_obs, obs_pdaf2nc USE mod_parallel_pdaf, ONLY: mype_world USE mod_parallel_pdaf, ONLY: abort_parallel + USE mod_assimilation, ONLY: obscov use mod_read_obs, only: multierr,clm_obserr, pressure_obserr + use mod_read_obs, only: vec_useObs_global USE mod_tsmp, ONLY: point_obs ! use netcdf + use enkf_clm_mod, only: clmupdate_tws IMPLICIT NONE @@ -87,6 +90,7 @@ SUBROUTINE init_obscovar_pdaf(step, dim_obs, dim_obs_p, covar, m_state_p, & INTEGER :: i ! Index of observation component REAL :: variance_obs ! ariance of observations integer :: ncid,j,status,varid + REAL :: clm_obserr_model(dim_obs) ! ********************** @@ -123,6 +127,7 @@ SUBROUTINE init_obscovar_pdaf(step, dim_obs, dim_obs_p, covar, m_state_p, & call abort_parallel() end if + if (clmupdate_tws/=1) then do i=1,dim_obs #if defined CLMSA covar(i,i) = clm_obserr(obs_pdaf2nc(i))*clm_obserr(obs_pdaf2nc(i)) @@ -130,6 +135,15 @@ SUBROUTINE init_obscovar_pdaf(step, dim_obs, dim_obs_p, covar, m_state_p, & covar(i,i) = pressure_obserr(obs_pdaf2nc(i))*pressure_obserr(obs_pdaf2nc(i)) #endif enddo + + else + + clm_obserr_model = pack(clm_obserr,vec_useObs_global) + do i=1,dim_obs + covar(i,i) = clm_obserr_model(i) + end do + + end if endif ! The matrix is diagonal ! This setting avoids the computation of the SVD of COVAR @@ -162,6 +176,11 @@ SUBROUTINE init_obscovar_pdaf(step, dim_obs, dim_obs_p, covar, m_state_p, & !isdiag=.false. ! kuw end +if(multierr==2) then + covar = obscov + isdiag = .FALSE. +endif + END SUBROUTINE init_obscovar_pdaf ! subroutine check(status) diff --git a/interface/framework/init_obsvar_l_pdaf.F90 b/interface/framework/init_obsvar_l_pdaf.F90 index a1e7a5f14..d92061a54 100644 --- a/interface/framework/init_obsvar_l_pdaf.F90 +++ b/interface/framework/init_obsvar_l_pdaf.F90 @@ -54,6 +54,10 @@ SUBROUTINE init_obsvar_l_pdaf(domain_p, step, dim_obs_l, obs_l, meanvar_l) ! !USES: USE mod_assimilation, & ONLY:rms_obs + USE mod_assimilation, & + ONLY: clm_obserr_p, obs_index_l + use mod_read_obs, & + ONLY: multierr, clm_obserr, clm_obscov, vec_useObs, vec_useObs_global IMPLICIT NONE @@ -64,6 +68,9 @@ SUBROUTINE init_obsvar_l_pdaf(domain_p, step, dim_obs_l, obs_l, meanvar_l) REAL, INTENT(in) :: obs_l(dim_obs_l) ! Local observation vector REAL, INTENT(out) :: meanvar_l ! Mean local observation error variance + REAL :: sum_l + INTEGER :: i, count + ! !CALLING SEQUENCE: ! Called by: PDAF_set_forget_local (as U_init_obsvar_l) !EOP @@ -72,7 +79,8 @@ SUBROUTINE init_obsvar_l_pdaf(domain_p, step, dim_obs_l, obs_l, meanvar_l) ! *********************************** ! *** Compute local mean variance *** ! *********************************** - + select case (multierr) + case (0) meanvar_l = rms_obs ** 2 ! meanvar_l = ? @@ -119,5 +127,32 @@ SUBROUTINE init_obsvar_l_pdaf(domain_p, step, dim_obs_l, obs_l, meanvar_l) !!$ meanvar = meanvar/npes_filter !!$ end if !!$#endif + case (1) + meanvar_l = 0 + sum_l = 0 + count = 0 + clm_obserr_p = pack(clm_obserr,vec_useObs_global) + do i = 1, dim_obs_l + if (clm_obserr_p(obs_index_l(i)) /= 0) then + sum_l = sum_l + clm_obserr_p(obs_index_l(i)) + count = count+1 + end if + end do + + meanvar_l = sum_l/count + + case(2) + meanvar_l = 0 + sum_l = 0 + count = 0 + do i = 1, dim_obs_l + if(vec_useObs_global(obs_index_l(i))) then + sum_l = sum_l + clm_obscov(obs_index_l(i),obs_index_l(i)) + count = count + 1 + end if + end do + ! averaging the sum of observation errors with total no of non-zero observations + meanvar_l = sum_l/count + end select END SUBROUTINE init_obsvar_l_pdaf diff --git a/interface/framework/init_obsvar_pdaf.F90 b/interface/framework/init_obsvar_pdaf.F90 index a73515afe..eae5f3645 100644 --- a/interface/framework/init_obsvar_pdaf.F90 +++ b/interface/framework/init_obsvar_pdaf.F90 @@ -70,6 +70,8 @@ SUBROUTINE init_obsvar_pdaf(step, dim_obs_p, obs_p, meanvar) USE mod_tsmp, & ONLY: tag_model_parflow, model #endif +use mod_read_obs, only: multierr, clm_obserr, clm_obscov, vec_useObs, vec_useObs_global +USE enkf_clm_mod, ONLY: clmupdate_tws IMPLICIT NONE @@ -124,9 +126,17 @@ SUBROUTINE init_obsvar_pdaf(step, dim_obs_p, obs_p, meanvar) #if defined CLMSA if(model == tag_model_clm) then + + select case (multierr) + case(0) + meanvar = rms_obs ** 2 + case(1) meanvar_p = 0 sum_p = 0 counter = 0 + if (clmupdate_tws==1) then + clm_obserr_p = pack(clm_obserr,vec_useObs_global) + end if do i = 1, dim_obs_p if(clm_obserr_p(i) /= 0) then sum_p = sum_p + clm_obserr_p(i) @@ -139,6 +149,27 @@ SUBROUTINE init_obsvar_pdaf(step, dim_obs_p, obs_p, meanvar) call MPI_Allreduce(meanvar_p, meanvar, 1, MPI_REAL8, MPI_SUM, COMM_filter, MPIerr) ! to get the mean dividing the mean observation error by size of processors meanvar = meanvar/npes_filter + + case(2) + meanvar_p = 0 + sum_p = 0 + counter = 0 + + do i = 1, size(clm_obscov,1) + if(vec_useObs_global(i)) then + sum_p = sum_p + clm_obscov(i,i) + counter = counter + 1 + end if + end do + ! averaging the sum of observation errors with total no of non-zero observations + meanvar_p = sum_p/counter + ! summing the average of observation errors and communicating it back to each rank + call MPI_Allreduce(meanvar_p, meanvar, 1, MPI_REAL8, MPI_SUM, COMM_filter, MPIerr) + ! to get the mean dividing the mean observation error by size of processors + meanvar = meanvar/npes_filter + end select + + end if #endif diff --git a/interface/framework/init_pdaf_parse.F90 b/interface/framework/init_pdaf_parse.F90 index 92c2dab4a..a8e6e2713 100644 --- a/interface/framework/init_pdaf_parse.F90 +++ b/interface/framework/init_pdaf_parse.F90 @@ -53,6 +53,7 @@ SUBROUTINE init_pdaf_parse() forget, rank_analysis_enkf, locweight, cradius, & sradius, filename, type_trans, dim_obs, & type_sqrt, obs_filename, dim_lag + USE mod_assimilation, ONLY: temp_mean_filename IMPLICIT NONE @@ -131,6 +132,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/l2g_state_pdaf.F90 b/interface/framework/l2g_state_pdaf.F90 index 469370d02..3bca9585d 100644 --- a/interface/framework/l2g_state_pdaf.F90 +++ b/interface/framework/l2g_state_pdaf.F90 @@ -55,6 +55,8 @@ SUBROUTINE l2g_state_pdaf(step, domain_p, dim_l, state_l, dim_p, state_p) USE iso_c_binding, ONLY: c_loc #if defined CLMSA + use enkf_clm_mod, only: hactiveg_levels, num_layer, state_setup, num_hactiveg_patch, hactiveg_patch, clm_varsize_tws + USE enkf_clm_mod, ONLY: clmupdate_tws use enkf_clm_mod, ONLY: l2g_state_clm #endif @@ -69,6 +71,7 @@ SUBROUTINE l2g_state_pdaf(step, domain_p, dim_l, state_l, dim_p, state_p) REAL, TARGET, INTENT(inout) :: state_p(dim_p) ! PE-local full state vector INTEGER :: i, n_domain, nshift_p + INTEGER :: sub, j, g INTEGER :: begg, endg ! per-proc gridcell ending gridcell indices ! !CALLING SEQUENCE: ! Called by: PDAF_lseik_update (as U_l2g_state) @@ -91,7 +94,140 @@ SUBROUTINE l2g_state_pdaf(step, domain_p, dim_l, state_l, dim_p, state_p) end if !call l2g_state(domain_p, c_loc(state_p), dim_l, c_loc(state_l)) #else + NOGRACE: if (clmupdate_tws/=1) then call l2g_state_clm(domain_p, dim_l, state_l, dim_p, state_p) + end if NOGRACE + + GRACE: if (clmupdate_tws==1) then + if (clm_varsize_tws(5)/=0) then + sub=3 + else + sub=2 + end if + + select case (state_setup) + case(0) ! liq and ice seperated + g = hactiveg_levels(domain_p,1) + do i = 1, (dim_l-sub)/2 ! two entries for liq and ice seperated + 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) + state_p(j+clm_varsize_tws(1)) = state_l(i+(dim_l-3)/2) + else + state_p(j + sum(num_layer(1:i-1))) = state_l(i) + state_p(j + sum(num_layer(1:i-1)) + clm_varsize_tws(1)) = state_l(i+(dim_l-3)/2) + 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 + clm_varsize_tws(1) + clm_varsize_tws(2)) = state_l(dim_l-2) + state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3)) = state_l(dim_l-1) + state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3) + clm_varsize_tws(4)) = state_l(dim_l) + else + state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2)) = state_l(dim_l-1) + state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3)) = state_l(dim_l) + end if + + end if + end do + + case(1) + g = hactiveg_levels(domain_p,1) + do i = 1, dim_l-sub ! liq and ice added up + 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 + clm_varsize_tws(1) + clm_varsize_tws(2)) = state_l(dim_l-2) + state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3)) = state_l(dim_l-1) + state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3) + clm_varsize_tws(4)) = state_l(dim_l) + else + state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2)) = state_l(dim_l-1) + state_p(j + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(3)) = state_l(dim_l) + end if + + end if + end do + + + case(2) ! only 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(3) + 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 + clm_varsize_tws(1) + clm_varsize_tws(2)) = state_l(2) + end if + end do + + case(4) + 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 + clm_varsize_tws(1) + clm_varsize_tws(2)) = state_l(dim_l) + end if + end do + + do j = 1, num_layer(8) + if (g==hactiveg_levels(j,8)) then + state_p(j + clm_varsize_tws(1)) = state_l(2) + end if + end do + + case(5) + + 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 + clm_varsize_tws(1) + clm_varsize_tws(2) + clm_varsize_tws(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 + clm_varsize_tws(1) + clm_varsize_tws(2)) = state_l(3) + end if + end do + + end select + + end if GRACE #endif END SUBROUTINE l2g_state_pdaf diff --git a/interface/framework/localize_covar_pdaf.F90 b/interface/framework/localize_covar_pdaf.F90 index b0865fb8b..405372ba1 100644 --- a/interface/framework/localize_covar_pdaf.F90 +++ b/interface/framework/localize_covar_pdaf.F90 @@ -36,10 +36,15 @@ SUBROUTINE localize_covar_pdaf(dim_p, dim_obs, HP, HPH) USE mod_read_obs,& ONLY: x_idx_obs_nc, y_idx_obs_nc, z_idx_obs_nc + USE mod_read_obs, & + ONLY: vec_useObs_global, clmobs_lat, clmobs_lon #if defined CLMSA USE shr_kind_mod , only : r8 => shr_kind_r8 USE mod_read_obs, ONLY: clmobs_lon USE mod_read_obs, ONLY: clmobs_lat + ! USE enkf_clm_mod, ONLY: init_clm_l_size + USE enkf_clm_mod, ONLY: clmupdate_tws + USE enkf_clm_mod, ONLY: gridcell_state USE enkf_clm_mod, ONLY: clmupdate_T USE enkf_clm_mod, ONLY: clm_begc USE enkf_clm_mod, ONLY: clm_endc @@ -85,6 +90,7 @@ SUBROUTINE localize_covar_pdaf(dim_p, dim_obs, HP, HPH) ! *** local variables *** INTEGER :: i, j ! Index of observation component + INTEGER :: gcell REAL :: dx,dy,distance ! Distance between points in the domain REAL :: weight ! Localization weight REAL :: tmp(1,1) ! Temporary, but unused array @@ -105,6 +111,9 @@ SUBROUTINE localize_covar_pdaf(dim_p, dim_obs, HP, HPH) #endif INTEGER :: icoord + REAL, ALLOCATABLE :: obs_lon(:) + REAL, ALLOCATABLE :: obs_lat(:) + ! ********************** ! *** INITIALIZATION *** ! ********************** @@ -202,8 +211,6 @@ SUBROUTINE localize_covar_pdaf(dim_p, dim_obs, HP, HPH) !by hcp to computer the localized covariance matrix in CLMSA case #if defined CLMSA - IF(model==tag_model_clm)THEN - ! localize HP ! ----------- @@ -220,6 +227,11 @@ SUBROUTINE localize_covar_pdaf(dim_p, dim_obs, HP, HPH) mycgridcell => clm3%g%l%c%gridcell #endif + if(clmupdate_tws/=1) then + + + IF(model==tag_model_clm)THEN + DO j = 1, dim_obs DO i = 1, dim_p @@ -313,6 +325,55 @@ SUBROUTINE localize_covar_pdaf(dim_p, dim_obs, HP, HPH) if(allocated(clmobs_lat))deallocate(clmobs_lat) ENDIF ! model==tag_model_clm + + else + + if (allocated(obs_lon)) deallocate(obs_lon) + if (allocated(obs_lat)) deallocate(obs_lat) + allocate(obs_lon(dim_obs)) + allocate(obs_lat(dim_obs)) + obs_lon = pack(clmobs_lon,vec_useObs_global) + obs_lat = pack(clmobs_lat,vec_useObs_global) + !if (allocated(clmobs_lon)) deallocate(clmobs_lon) + !if (allocated(clmobs_lat)) deallocate(clmobs_lat) + + DO j = 1, dim_obs + do i = 1, dim_p + + gcell = gridcell_state(i) + + if (lon(gcell)<180) then + dx = abs(obs_lon(j) - lon(gcell)) + else + dx = abs(obs_lon(j) - (lon(gcell)-360)) + end if + dy = abs(obs_lat(j) - lat(gcell)) + distance = sqrt(real(dx)**2 + real(dy)**2) + + ! Compute weight + CALL PDAF_local_weight(wtype, rtype, cradius, sradius, distance, 1, 1, tmp, 1.0, weight, 0) + + ! Apply localization + HP(j,i) = weight * HP(j,i) + + END DO + END DO + + do j = 1, dim_obs + do i = 1, dim_obs + + dx = abs(obs_lon(j) - obs_lon(i)) + dy = abs(obs_lat(j) - obs_lat(i)) + distance = sqrt(real(dx)**2 + real(dy)**2) + + CALL PDAF_local_weight(wtype, rtype, cradius, sradius, distance, 1, 1, tmp, 1.0, weight, 0) + + HPH(j,i) = weight * HPH(j,i) + + end do + end do + + end if #endif !hcp end diff --git a/interface/framework/mod_assimilation.F90 b/interface/framework/mod_assimilation.F90 index 170b26175..e37d0a3d1 100755 --- a/interface/framework/mod_assimilation.F90 +++ b/interface/framework/mod_assimilation.F90 @@ -93,9 +93,21 @@ MODULE mod_assimilation INTEGER, ALLOCATABLE :: var_id_obs(:) ! for remote sensing data the variable identifier to group ! variables distributed over a grid surface area !kuw + INTEGER, ALLOCATABLE :: obs_id_p(:) ! ID of observation point in PE-local domain 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 + REAL, ALLOCATABLE :: tws_temp_mean_d(:) ! Mean temporal TWS for model domain + 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 diff --git a/interface/framework/mod_read_obs.F90 b/interface/framework/mod_read_obs.F90 index 9c202acda..962e51d33 100755 --- a/interface/framework/mod_read_obs.F90 +++ b/interface/framework/mod_read_obs.F90 @@ -57,6 +57,17 @@ module mod_read_obs real, allocatable :: clm_obserr(:) !kuw end + ! Yorck + real, allocatable :: clm_obscov(:,:) ! covariance matrix for TWS observations + logical, allocatable :: vec_useObs(:) ! vector that tells if an observation of used (1) or not (0), same dimension as observation vector, for local process + 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 :: lon_temp_mean(:,:) ! corresponding longitude + real, allocatable :: lat_temp_mean(:,:) ! corresponding latitude + + + real, allocatable :: pressure_obs(:) real, allocatable :: pressure_obserr(:) @@ -142,13 +153,16 @@ subroutine read_obs_nc(current_observation_filename) #ifndef OBS_ONLY_PARFLOW integer :: clmobs_varid, dr_varid, clmobs_lon_varid, clmobs_lat_varid, & clmobs_layer_varid, clmobserr_varid + integer :: clmobscov_varid 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" integer :: has_obs_clm + integer :: i #endif #endif @@ -370,6 +384,19 @@ subroutine read_obs_nc(current_observation_filename) end if endif + !check, if covariance matrix is present in observation file + haserr = nf90_inq_varid(ncid, obscov_name, clmobscov_varid) + if(haserr == nf90_noerr) then + multierr = 2 + if(allocated(clm_obscov)) deallocate(clm_obscov) + allocate(clm_obscov(dim_obs, dim_obs)) + call check(nf90_get_var(ncid, clmobscov_varid, clm_obscov)) + ! if (screen > 2) then + ! print *, "TSMP-PDAF mype(w)=", mype_world, ": clm_obscov=", clm_obscov + ! end if + + endif + ! Read the longitude latidute data from the file. if(allocated(clmobs_lon)) deallocate(clmobs_lon) @@ -527,6 +554,7 @@ end subroutine get_obsindex_currentobsfile subroutine clean_obs_nc() USE mod_assimilation, ONLY: filtertype + USE enkf_clm_mod, ONLY: clmupdate_tws implicit none ! if(allocated(idx_obs_nc))deallocate(idx_obs_nc) @@ -536,7 +564,7 @@ subroutine clean_obs_nc() !if(allocated(y_idx_obs_nc))deallocate(y_idx_obs_nc) !if(allocated(z_idx_obs_nc))deallocate(z_idx_obs_nc) !kuw: clean clm observations - IF (.NOT. filtertype == 5 .AND. .NOT. filtertype == 7 .AND. .NOT. filtertype == 8) THEN + IF (.NOT. filtertype == 5 .AND. .NOT. filtertype == 7 .AND. .NOT. filtertype == 8 .and. clmupdate_tws/=1) THEN ! For LETKF, LESTKF, LEnKF lat/lon are used if(allocated(clmobs_lon))deallocate(clmobs_lon) if(allocated(clmobs_lat))deallocate(clmobs_lat) @@ -545,6 +573,7 @@ subroutine clean_obs_nc() if(allocated(clmobs_layer))deallocate(clmobs_layer) if(allocated(clmobs_dr))deallocate(clmobs_dr) !if(allocated(clm_obserr))deallocate(clm_obserr) + if(allocated(clm_obscov))deallocate(clm_obscov) !kuw end end subroutine clean_obs_nc @@ -610,7 +639,7 @@ end subroutine check_n_observationfile !> @param[in] fn Filename of the observation file !> @param[out] aa new da_interval (number of time steps until next assimilation time step) !> @details - !> Reads the content of the variable name `da_interval` from NetCDF + !> Reads the content of the variable name `da_interval`/`da_interval_variable` from NetCDF !> file `fn` using subroutines from the NetCDF module. !> The result is returned in `aa`. !> @@ -621,7 +650,11 @@ 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 - +#ifdef CLMSA + use clm_varcon, only: ispval + use clm_time_manager, only : get_step_size + USE enkf_clm_mod, ONLY: clmupdate_tws +#endif implicit none character(len=*),intent(in) :: fn @@ -629,22 +662,361 @@ subroutine check_n_observationfile_da_interval(fn,aa) integer :: ncid, varid, status !,dimid - character (len = *), parameter :: varname = "da_interval" + character (len = 20) :: varname real(r8) :: dtime ! land model time step (sec) !character (len = *), parameter :: dim_name = "dim_obs" !character(len = nf90_max_name) :: recorddimname +#ifdef CLMSA + if (clmupdate_tws==1) then + varname = "da_interval_variable" + else + varname = "da_interval " + end if +#else + varname = "da_interval " +#endif + +#ifdef CLMSA + if (clmupdate_tws==1) then + 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, trim(varname), varid) + if (status == nf90_noerr) then + call check(nf90_inq_varid(ncid, trim(varname), varid)) + call check( nf90_get_var(ncid, varid, aa) ) + 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 + aa = aa*INT(3600/dtime) + else + aa = ispval + end if + end if + if (clmupdate_tws/=1) then 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)) - call check( nf90_inq_varid(ncid, varname, varid)) + call check( nf90_inq_varid(ncid, trim(varname), varid)) call check( nf90_get_var(ncid, varid, aa) ) call check(nf90_close(ncid)) + end if +#else + 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)) + call check( nf90_inq_varid(ncid, trim(varname), varid)) + call check( nf90_get_var(ncid, varid, aa) ) + call check(nf90_close(ncid)) +#endif 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 + + !> @author Yorck Ewerdwalbesloh + !> @date 05.09.2023 + !> @brief reading TWS temporal mean model file + !> @param[in] temp_mean_filename Name of mean file + !> @details + !> This subroutine reads a provided temporal mean model file + 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 + use netcdf, only: nf90_get_var + use netcdf, only: nf90_close + 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 + + !print *, "Read temporal mean of CLM OL run" + + 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 + +#ifdef CLMFIVE + subroutine domain_def_clm_tws(lon_clmobs, lat_clmobs, dim_obs, & + longxy, latixy, longxy_obs, latixy_obs) + + USE mpi, ONLY: MPI_DOUBLE_PRECISION + USE mpi, ONLY: MPI_INTEGER + 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 + 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, & + mype_world, 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_tws +#endif + + !> @author Wolfgang Kurtz, Guowei He, Mukund Pondkule !> @date 03.03.2023 !> @brief Error handling for netCDF commands diff --git a/interface/framework/next_observation_pdaf.F90 b/interface/framework/next_observation_pdaf.F90 index 37b78f8a4..46ba2b63f 100644 --- a/interface/framework/next_observation_pdaf.F90 +++ b/interface/framework/next_observation_pdaf.F90 @@ -53,6 +53,8 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) ! !USES: USE mod_assimilation, & ONLY: delt_obs, toffset, screen + USE mod_assimilation, & + ONLY: da_interval_variable USE mod_parallel_pdaf, & ONLY: mype_world USE mod_tsmp, & @@ -65,6 +67,13 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) use mod_read_obs, & only: check_n_observationfile use mod_read_obs, ONLY: check_n_observationfile_da_interval + use mod_read_obs, ONLY: check_n_observationfile_set_zero + use clm_time_manager, only: get_nstep + use enkf_clm_mod, only: clmupdate_tws +#ifdef CLMFIVE + use clm_varcon, only: set_averaging_to_zero +#endif + use clm_varcon, only: ispval IMPLICIT NONE ! !ARGUMENTS: @@ -80,6 +89,7 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) !kuw: local variables integer :: counter integer :: no_obs + integer :: nstep character (len = 110) :: fn !kuw end @@ -89,6 +99,8 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) time = 0.0 ! Not used in fully-parallel implementation variant doexit = 0 + if(clmupdate_tws/=1) then + !kuw: implementation for at least 1 existing observation per observation file !!print *, "stepnow", stepnow !write(*,*)'stepnow (in next_observation_pdaf):',stepnow @@ -183,8 +195,47 @@ SUBROUTINE next_observation_pdaf(stepnow, nsteps, doexit, time) end if !kuw end + end if + +#ifdef CLMSA +#ifdef CLMFIVE + if(clmupdate_tws==1) 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+delt_obs + 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 + + end if +#endif +#endif ! IF (stepnow + nsteps <= total_steps) THEN ! if (2<1) then diff --git a/interface/framework/obs_op_f_pdaf.F90 b/interface/framework/obs_op_f_pdaf.F90 index 7ef496f43..32b76bfe7 100755 --- a/interface/framework/obs_op_f_pdaf.F90 +++ b/interface/framework/obs_op_f_pdaf.F90 @@ -58,17 +58,32 @@ SUBROUTINE obs_op_f_pdaf(step, dim_p, dim_obs_f, state_p, m_state_f) ! !USES: USE mpi, ONLY: MPI_DOUBLE_PRECISION USE mpi, ONLY: MPI_ALLGATHERV + USE mpi, ONLY: MPI_DOUBLE + USE mpi, ONLY: MPI_INT + USE mpi, ONLY: MPI_SUM USE mod_assimilation, & - ONLY: obs_index_p, local_dims_obs, local_disp_obs, & + ONLY: obs_index_p, local_dims_obs, obs_id_p, & var_id_obs, dim_obs_p USE mod_assimilation, ONLY: obs_pdaf2nc USE mod_assimilation, ONLY: obs_nc2pdaf + USE mod_assimilation, ONLY: local_disp_obs + USE mod_assimilation, ONLY: tws_temp_mean_d + USE mod_assimilation, ONLY: tws_temp_mean_d USE mod_parallel_pdaf, & - ONLY: mype_world, mype_filter, npes_filter, comm_filter, & - abort_parallel + ONLY: mype_filter, npes_filter, comm_filter + USE mod_parallel_pdaf, ONLY: mype_world + USE mod_parallel_pdaf, ONLY: abort_parallel !USE mod_read_obs, & ! ONLY: var_id_obs_nc - +#ifdef CLMSA + use decompMod , only : get_proc_bounds + use enkf_clm_mod, only: clmupdate_tws, clm_varsize_tws, state_setup, & + num_layer, hactiveg_levels, num_hactiveg_patch, hactiveg_patch, remove_mean + Use mod_read_obs, only: vec_useObs_global, vec_numPoints_global + use clm_varcon, only: spval + use clm_varpar , only : nlevsoi + use shr_kind_mod, only: r8 => shr_kind_r8 +#endif IMPLICIT NONE ! !ARGUMENTS: @@ -87,13 +102,62 @@ SUBROUTINE obs_op_f_pdaf(step, dim_p, dim_obs_f, state_p, m_state_f) ! local variables INTEGER :: ierror, max_var_id INTEGER :: i ! Counter + INTEGER :: j ! Counter + INTEGER :: g ! Counter REAL, ALLOCATABLE :: m_state_tmp(:) ! Temporary process-local state vector +#ifdef CLMSA + REAL:: m_state_sum(size(vec_useObs_global)) ! sum up all model grid cells and variables which correspond to an observation + REAL:: m_state_sum_global(size(vec_useObs_global)) ! sum up all model grid cells and variables which correspond to an observation + + integer :: count + + REAL, allocatable :: tws_from_statevector(:) + + 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 :: obs_point ! which observation is seen by which point? +#endif + ! ********************************************* ! *** Perform application of measurement *** ! *** operator H on vector or matrix column *** ! ********************************************* + +#ifdef CLMSA + NOGRACE: if (clmupdate_tws/=1) then + + ! Check local observation dimension + if (.not. local_dims_obs(mype_filter+1) == dim_obs_p) then + print *, "TSMP-PDAF mype(w)=", mype_world, ": ERROR in local observation dimension" + print *, "mype_filter=", mype_filter + print *, "local_dims_obs(mype_filter+1)=", local_dims_obs(mype_filter+1) + print *, "dim_obs_p=", dim_obs_p + call abort_parallel() + end if + + ! Initialize process-local observed state + ALLOCATE(m_state_tmp(dim_obs_p)) + + DO i = 1, dim_obs_p + m_state_tmp(i) = state_p(obs_index_p(i)) + END DO + + !print *,'local_dims_obs(mype_filter+1) ', local_dims_obs(mype_filter+1) + !print *,'dim_obs_p ', dim_obs_p + + ! Gather full observed state using local_dims_obs, local_disp_obs + + ! gather local observed states of different sizes in a vector + CALL mpi_allgatherv(m_state_tmp, dim_obs_p, & + MPI_DOUBLE_PRECISION, m_state_f, local_dims_obs, local_disp_obs, & + MPI_DOUBLE_PRECISION, comm_filter, ierror) + + end if NOGRACE +#else ! Check local observation dimension if (.not. local_dims_obs(mype_filter+1) == dim_obs_p) then print *, "TSMP-PDAF mype(w)=", mype_world, ": ERROR in local observation dimension" @@ -120,4 +184,242 @@ SUBROUTINE obs_op_f_pdaf(step, dim_p, dim_obs_f, state_p, m_state_f) MPI_DOUBLE_PRECISION, m_state_f, local_dims_obs, local_disp_obs, & MPI_DOUBLE_PRECISION, comm_filter, ierror) +#endif +#ifdef CLMSA + GRACE: if (clmupdate_tws==1) then + + 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) + + 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 + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count) + + ! ice + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1)) + + else + + ! liq + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count+sum(num_layer(1:j-1))) + + ! ice + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count+sum(num_layer(1:j-1)) + clm_varsize_tws(1)) + + end if + + if (j == 1) then + + ! 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)) + + 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) + + 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) + + else + + ! liq + ice + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count+sum(num_layer(1:j-1))) + + end if + + if (j == 1) then + + ! 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)) + + 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(2) + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + tws_from_statevector(g) = state_p(count) + + end do + + case(3) + + do count = 1,num_layer(1) + + g = hactiveg_levels(count,1) + + tws_from_statevector(g) = state_p(count) + + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)) + + end do + + case(4) + + do count = 1,num_layer(1) + + g = hactiveg_levels(count,1) + + tws_from_statevector(g) = state_p(count) + + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)) + + end do + + do count = 1,num_layer(8) + + g = hactiveg_levels(count,8) + + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1)) + + end do + + case(5) + + do count = 1,num_layer(1) + + g = hactiveg_levels(count,1) + + tws_from_statevector(g) = state_p(count) + + 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 + + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + obs_point = obs_id_p(g) + + if (obs_point /= 0) then + ! now, the gridcell that was looked upon has been added to the sum for its corresponging observations to reproduce it. However, GRACE measures anomalies + ! (TWS changes). Due to this reason, a mean per gridcell has to be removed from this sum. The value from the mean corresponds to the mean per gridcell in an + ! reference run with unperturbed forcings and surface data. + !print*, 'difference TWS and reproduced (', g , ') = ', TWS(g)-tws_from_statevector(g) + if (tws_temp_mean_d(g)/=spval .and. tws_from_statevector(g)/=spval) then + + if (remove_mean==0) then + + m_state_sum(obs_point) = m_state_sum(obs_point) + tws_from_statevector(g)-tws_temp_mean_d(g) + + else + + m_state_sum(obs_point) = m_state_sum(obs_point) + tws_from_statevector(g) + + end if + 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 spvalfor g = ", g + print*, "temp_mean = ", tws_temp_mean_d(g) + stop + end if + + end if + + end do + + 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 + + m_state_f = pack(m_state_sum_global, vec_useObs_global) + + if (mype_filter==0) then + print *, "m_state_global = ", m_state_sum_global + end if + + end if GRACE +#endif + END SUBROUTINE obs_op_f_pdaf diff --git a/interface/framework/obs_op_pdaf.F90 b/interface/framework/obs_op_pdaf.F90 index 1ce5db817..974827056 100644 --- a/interface/framework/obs_op_pdaf.F90 +++ b/interface/framework/obs_op_pdaf.F90 @@ -48,6 +48,12 @@ SUBROUTINE obs_op_pdaf(step, dim_p, dim_obs_p, state_p, m_state_p) ! Later revisions - see svn log ! ! !USES: + 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_MAXLOC USE mod_assimilation, & ONLY: obs_index_p, obs_p #ifndef CLMSA @@ -57,6 +63,10 @@ SUBROUTINE obs_op_pdaf(step, dim_p, dim_obs_p, state_p, m_state_p) #endif USE mod_assimilation, ONLY: obs_interp_indices_p USE mod_assimilation, ONLY: obs_interp_weights_p + USE mod_assimilation, & + ONLY: obs_id_p, & + tws_temp_mean_d + USE mod_read_obs, ONLY: vec_numPoints_global !clm_obs use mod_tsmp, & only: obs_interp_switch, & soilay, & @@ -71,9 +81,22 @@ SUBROUTINE obs_op_pdaf(step, dim_p, dim_obs_p, state_p, m_state_p) #if defined CLMSA USE enkf_clm_mod, & ONLY : clm_varsize, clm_paramarr, clmupdate_swc, clmupdate_T, clmcrns_bd + USE enkf_clm_mod, & + ONLY : clmupdate_tws, clm_varsize_tws, state_setup, & + num_layer, hactiveg_levels, num_hactiveg_patch, hactiveg_patch, remove_mean + Use mod_read_obs, only: vec_useObs, vec_useObs_global + use mod_parallel_pdaf, & + only: mype_filter, comm_filter, & + mype_world + 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 #ifdef CLMFIVE USE clm_instMod, & ONLY : soilstate_inst + use clm_instMod, only : waterstate_inst + use clm_varctl , only: inst_suffix #endif #endif IMPLICIT NONE @@ -85,6 +108,7 @@ SUBROUTINE obs_op_pdaf(step, dim_p, dim_obs_p, state_p, m_state_p) REAL, INTENT(in) :: state_p(dim_p) ! PE-local model state REAL, INTENT(out) :: m_state_p(dim_obs_p) ! PE-local observed state integer :: i, j, k, z, n + integer :: g integer :: icorner logical :: lpointobs !If true: no special observation; use point observation ! !CALLING SEQUENCE: @@ -104,6 +128,26 @@ SUBROUTINE obs_op_pdaf(step, dim_p, dim_obs_p, state_p, m_state_p) integer :: nsc ! end of hcp +#ifdef CLMSA +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? + +integer :: gridcell_index + +REAL:: m_state_sum(size(vec_useObs_global)) ! sum up all model grid cells and variables which correspond to an observation +REAL:: m_state_sum_global(size(vec_useObs_global)) ! sum up all model grid cells and variables which correspond to an observation + +integer :: count + +real :: sum + +REAL, allocatable :: tws_from_statevector(:) +#endif + #ifndef PARFLOW_STAND_ALONE #ifndef OBS_ONLY_PARFLOW ! Variables used in crns version 2 @@ -152,6 +196,243 @@ SUBROUTINE obs_op_pdaf(step, dim_p, dim_obs_p, state_p, m_state_p) ! write(*,*) 'TG', state_p(obs_index_p(:)) ! write(*,*) 'TV', state_p(clm_varsize+obs_index_p(:)) endif + + if (clmupdate_tws==1) then + m_state_sum(:) = 0 + lpointobs = .false. + + 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) + + 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 + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count) + + ! ice + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1)) + + else + + ! liq + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count+sum(num_layer(1:j-1))) + + ! ice + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count+sum(num_layer(1:j-1)) + clm_varsize_tws(1)) + + end if + + if (j == 1) then + + ! 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)) + + 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) + + 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) + + else + + ! liq + ice + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count+sum(num_layer(1:j-1))) + + end if + + if (j == 1) then + + ! 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)) + + 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(2) + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + tws_from_statevector(g) = state_p(count) + + end do + + case(3) + + do count = 1,num_layer(1) + + g = hactiveg_levels(count,1) + + tws_from_statevector(g) = state_p(count) + + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)) + + end do + + case(4) + + do count = 1,num_layer(1) + + g = hactiveg_levels(count,1) + + tws_from_statevector(g) = state_p(count) + + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1) + clm_varsize_tws(2)) + + end do + + do count = 1,num_layer(8) + + g = hactiveg_levels(count,8) + + tws_from_statevector(g) = tws_from_statevector(g) + state_p(count + clm_varsize_tws(1)) + + end do + + case(5) + + do count = 1,num_layer(1) + + g = hactiveg_levels(count,1) + + tws_from_statevector(g) = state_p(count) + + 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 + + + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + obs_point = obs_id_p(g) + + if (obs_point /= 0) then + ! now, the gridcell that was looked upon has been added to the sum for its corresponging observations to reproduce it. However, GRACE measures anomalies + ! (TWS changes). Due to this reason, a mean per gridcell has to be removed from this sum. The value from the mean corresponds to the mean per gridcell in an + ! reference run with unperturbed forcings and surface data. + !print*, 'difference TWS and reproduced (', g , ') = ', TWS(g)-tws_from_statevector(g) + if (tws_temp_mean_d(g)/=spval .and. tws_from_statevector(g)/=spval) then + + if (remove_mean==0) then + + m_state_sum(obs_point) = m_state_sum(obs_point) + tws_from_statevector(g)-tws_temp_mean_d(g) + + else + + m_state_sum(obs_point) = m_state_sum(obs_point) + tws_from_statevector(g) + + end if + 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 spvalfor g = ", g + print*, "temp_mean = ", tws_temp_mean_d(g) + stop + end if + + end if + + end do + + 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 + + m_state_p = pack(m_state_sum_global, vec_useObs) + + if (mype_filter==0) then + print *, "m_state_global = ", m_state_sum_global + end if + + end if #endif diff --git a/interface/framework/prodrinva_l_pdaf.F90 b/interface/framework/prodrinva_l_pdaf.F90 index 3169850c7..9a9451ead 100644 --- a/interface/framework/prodrinva_l_pdaf.F90 +++ b/interface/framework/prodrinva_l_pdaf.F90 @@ -53,7 +53,9 @@ SUBROUTINE prodRinvA_l_pdaf(domain_p, step, dim_obs_l, rank, obs_l, A_l, C_l) USE mod_assimilation, & ONLY: cradius, locweight, sradius, obs_index_p, & rms_obs, distance - USE mod_assimilation, ONLY: obs_index_l + USE mod_assimilation, & + ONLY: obscov, obscov_inv, obs_index_l, dim_obs + use mod_read_obs, only: multierr, clm_obserr, clm_obscov, vec_useObs, vec_useObs_global USE mod_parallel_pdaf, & ONLY: mype_filter USE mod_read_obs, ONLY: multierr @@ -79,6 +81,7 @@ SUBROUTINE prodRinvA_l_pdaf(domain_p, step, dim_obs_l, rank, obs_l, A_l, C_l) ! *** local variables *** INTEGER :: i, j ! Index of observation component + INTEGER :: k INTEGER :: verbose ! Verbosity flag INTEGER :: verbose_w ! Verbosity flag for weight computation INTEGER :: ilow, iup ! Lower and upper bounds of observation domain @@ -94,6 +97,13 @@ SUBROUTINE prodRinvA_l_pdaf(domain_p, step, dim_obs_l, rank, obs_l, A_l, C_l) REAL :: svarpovar ! Mean state plus observation variance REAL :: var_obs ! Variance of observation error + integer :: countR, countC, ierror + REAL :: clm_obserr_model(dim_obs) ! errors of observations in the model domain + REAL :: obscov_l(dim_obs_l,dim_obs_l) ! errors of observations in the model domain + REAL :: obscov_inv_l(dim_obs_l,dim_obs_l) ! errors of observations in the model domain + INTEGER, ALLOCATABLE :: ipiv(:) + real, ALLOCATABLE :: work(:) + ! *** NO CHANGES REQUIRED BELOW IF OBSERVATION ERRORS ARE CONSTANT *** ! ********************** @@ -199,12 +209,85 @@ SUBROUTINE prodRinvA_l_pdaf(domain_p, step, dim_obs_l, rank, obs_l, A_l, C_l) SELECT CASE (multierr) CASE(0) + select case (multierr) + case(0) + DO j = 1, rank DO i = 1, dim_obs_l C_l(i, j) = ivariance_obs * weight(i) * A_l(i, j) END DO END DO + case(1) + + clm_obserr_model = pack(clm_obserr,vec_useObs_global) + DO j = 1, rank + DO i = 1, dim_obs_l + C_l(i, j) = 1/clm_obserr_model(obs_index_l(i)) * weight(i) * A_l(i, j) + END DO + END DO + + case(2) + + countR = 1 + countC = 1 + do i = 1, dim_obs_l + do j = 1,dim_obs_l + !if (i==j) then !test + obscov_l(countR,countC) = obscov(obs_index_l(i),obs_index_l(j)) + !else + ! obscov_l(countR,countC) = 0 + !end if + countC = countC+1 + end do + countC=1 + countR=countR+1 + end do + + ALLOCATE(ipiv(dim_obs_l)) + ALLOCATE(work(dim_obs_l)) + obscov_inv_l = obscov_l + + call dgetrf(dim_obs_l,dim_obs_l,obscov_inv_l,dim_obs_l,ipiv,ierror) + call dgetri(dim_obs_l, obscov_inv_l, dim_obs_l, ipiv, work, dim_obs_l, ierror) + + + if (ierror /= 0) then + stop 'prodinva_l_pdaf: inversion failed!' + end if + + + do j = 1,rank + do i = 1,dim_obs_l + A_l(i,j) = weight(i)*A_l(i,j) + end do + end do + C_l = matmul(obscov_inv_l,A_l) + + ! DO j = 1, rank + ! if (dim_obs_l == 1) then + ! C_l(i,j) = obscov_inv_l(1,1)* weight(1) * A_l(1, j) + ! else + ! do i = 1,dim_obs_l + ! C_l(i,j) = 0 + ! do k = 1,dim_obs_l + ! C_l(i,j) = C_l(i,j) + obscov_inv_l(i,k)*A_l(k,j) + ! end do + ! C_l(i,j) = C_l(i,j)*weight(i) + ! end do + ! end if + ! END DO + + !C_l = matmul(obscov_inv_l,A_l) + ! DO j = 1, rank + ! DO i = 1, dim_obs_l + ! !C_l(i, j) = weight(i) * C_l (i, j) + ! C_l(i, j) = 1/obscov(obs_index_l(i),obs_index_l(i)) * weight(i) * A_l(i, j) + ! END DO + ! END DO + + end select + CASE(1) DO j = 1, rank diff --git a/interface/framework/prodrinva_pdaf.F90 b/interface/framework/prodrinva_pdaf.F90 index f6a7be17a..56bcf122e 100644 --- a/interface/framework/prodrinva_pdaf.F90 +++ b/interface/framework/prodrinva_pdaf.F90 @@ -47,8 +47,11 @@ SUBROUTINE prodRinvA_pdaf(step, dim_obs_p, rank_dim_ens, obs_p, A_p, C_p) ! !USES: USE mod_assimilation, & ONLY: rms_obs + USE mod_assimilation, & + ONLY: dim_obs, obscov_inv use mod_read_obs, only: multierr,clm_obserr, pressure_obserr + use mod_read_obs, only: clm_obscov, vec_useObs, vec_useObs_global IMPLICIT NONE @@ -73,6 +76,10 @@ SUBROUTINE prodRinvA_pdaf(step, dim_obs_p, rank_dim_ens, obs_p, A_p, C_p) ! *** local variables *** INTEGER :: i, j ! index of observation component REAL :: ivariance_obs ! inverse of variance of the observations + REAL :: clm_obserr_model(dim_obs_p) ! errors of observations in the model domain + REAL :: obscov_inv_l(dim_obs_p,dim_obs_p) ! local inverse covariance matrix + integer :: countR, countC + logical :: vec_useObs_p(dim_obs) ! ********************** ! *** INITIALIZATION *** @@ -80,6 +87,8 @@ SUBROUTINE prodRinvA_pdaf(step, dim_obs_p, rank_dim_ens, obs_p, A_p, C_p) WRITE (*,*) 'TEMPLATE prodrinva_pdaf.F90: Implement multiplication here!' + SELECT CASE (multierr) + CASE (0) ! *** initialize numbers ivariance_obs = 1.0 / rms_obs ** 2 @@ -93,10 +102,61 @@ SUBROUTINE prodRinvA_pdaf(step, dim_obs_p, rank_dim_ens, obs_p, A_p, C_p) ! *** computed explicitely. *** ! ************************************* +#ifdef PDAF_DEBUG + print *, 'prodrinva_pdaf: covariance matrix: case 0' +#endif + DO j = 1, rank_dim_ens !rank DO i = 1, dim_obs_p C_p(i, j) = ivariance_obs * A_p(i, j) END DO END DO + CASE (1) ! Diagonal covariance matrix, read from observation file + print *, 'prodrinva_pdaf: Observation covariance matrix: case 1' + clm_obserr_model = pack(clm_obserr,vec_useObs) + DO j = 1, rank_dim_ens + DO i = 1, dim_obs_p + C_p(i, j) = 1.0/clm_obserr_model(i) * A_p(i, j) + END DO + END DO + + CASE (2) ! Fully occupied covariance matrix, read from observation file + print *, 'prodrinva_pdaf: Observation covariance matrix: case 2' + ! Find out observations that shoud be considered, obscov_inv contains all used observations + j = 1 + DO i = 1, size(vec_useObs_global,1) + if(vec_useObs_global(i).eqv..true.) then + if(vec_useObs(i).eqv..true.) then + vec_useObs_p(j) = .true. + else + vec_useObs_p(j) = .false. + end if + j = j+1 + end if + END DO + + ! Local covariance matrix + countR = 1 + countC = 1 + do i = 1, size(obscov_inv,1) + if(vec_useObs_p(i)) then + do j = 1, size(obscov_inv,2) + if(vec_useObs_p(j)) then + obscov_inv_l(countR,countC) = obscov_inv(i,j) + countC = countC+1; + end if + end do + countC = 1 + countR = countR+1; + end if + end do + + C_p = matmul(obscov_inv_l,A_p) + + IF(allocated(obscov_inv))DEALLOCATE(obscov_inv) + END SELECT + if(allocated(clm_obserr))deallocate(clm_obserr) + if(allocated(clm_obscov))deallocate(clm_obscov) + END SUBROUTINE prodRinvA_pdaf diff --git a/interface/model/clm3_5/enkf_clm_mod.F90 b/interface/model/clm3_5/enkf_clm_mod.F90 index cb53f938e..8ac80d1e6 100755 --- a/interface/model/clm3_5/enkf_clm_mod.F90 +++ b/interface/model/clm3_5/enkf_clm_mod.F90 @@ -54,15 +54,19 @@ module enkf_clm_mod integer :: clm_paramsize !hcp: Size of CLM parameter vector (f.e. LAI) integer :: clm_varsize integer :: clm_begg,clm_endg + integer :: clm_begl,clm_endl integer :: clm_begc,clm_endc integer :: clm_begp,clm_endp real(r8),allocatable :: clm_statevec(:) + real(r8),allocatable :: clm_statevec_orig(:) + real(r8),allocatable :: clm_statevec_original_input(:) ! orginal values in statevector so that I can also access them in the update integer,allocatable :: state_pdaf2clm_c_p(:) integer,allocatable :: state_pdaf2clm_j_p(:) integer,allocatable :: state_loc2clm_c_p(:) ! clm_paramarr: Contains LAI used in obs_op_pdaf for computing model ! LST in LST assimilation (clmupdate_T) real(r8),allocatable :: clm_paramarr(:) !hcp CLM parameter vector (f.e. LAI) + integer, allocatable :: state_clm2pdaf_p(:,:) !Index of column in hydraulic active state vector (nlevsoi,endc-begc+1) integer(c_int),bind(C,name="clmupdate_swc") :: clmupdate_swc integer(c_int),bind(C,name="clmupdate_T") :: clmupdate_T ! by hcp integer(c_int),bind(C,name="clmupdate_texture") :: clmupdate_texture @@ -70,10 +74,44 @@ module enkf_clm_mod #endif integer(c_int),bind(C,name="clmprint_et") :: clmprint_et integer(c_int),bind(C,name="clmstatevec_allcol") :: clmstatevec_allcol + integer(c_int),bind(C,name="clmstatevec_colmean") :: clmstatevec_colmean + integer(c_int),bind(C,name="clmstatevec_only_active") :: clmstatevec_only_active + integer(c_int),bind(C,name="clmstatevec_max_layer") :: clmstatevec_max_layer integer(c_int),bind(C,name="clmt_printensemble") :: clmt_printensemble integer(c_int),bind(C,name="clmwatmin_switch") :: clmwatmin_switch real(c_double),bind(C,name="clmcrns_bd") :: clmcrns_bd + ! 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 !0: liq and ice seperated in statevector, 1: liq and ice together in statevector, 2: raw TWS values in statevector (just for testing) + integer(c_int),bind(C,name="update_snow") :: update_snow !0: scripts from Lukas, 1: simple factor of old and new snow multiplied with old values + integer(c_int),bind(C,name="remove_mean") :: remove_mean + integer, allocatable :: num_layer(:) + integer, allocatable :: num_layer_columns(:) + + real(r8), allocatable :: tws_temp_mean(:,:) ! temporal mean for TWS + real(r8), allocatable :: lon_temp_mean(:,:) ! corresponding longitude + real(r8), allocatable :: lat_temp_mean(:,:) ! corresponding latitude + + real(r8), allocatable :: tws_temp_mean_vector(:) ! temporal mean for TWS, in vector form, sorted just as sub-domain + + integer :: num_hactiveg, num_hactivec, num_hactiveg_patch, num_hactivep + + integer, allocatable :: hactiveg_levels(:,:) ! hydrolocial active filter for all levels (gridcell) + integer, allocatable :: hactivec_levels(:,:) ! hydrolocial active filter for all levels (column) + integer, allocatable :: hactivep(:) ! hydrolocial active filter (patches) + integer, allocatable :: hactiveg_patch(:) ! hydrolocial active filter (patches) + integer, allocatable :: gridcell_state(:) + + character(c_char),dimension(100),bind(C,name="mean_filename") :: mean_filename + + ! end Yorck + integer :: nstep ! time step index real(r8) :: dtime ! time step increment (sec) integer :: ier ! error code @@ -90,6 +128,8 @@ module enkf_clm_mod logical :: flag integer(c_int),bind(C,name="clmprefixlen") :: clmprefixlen integer :: COMM_couple_clm ! CLM-version of COMM_couple + ! (currently not used for clm5_0) + logical :: newgridcell !only clm5_0 contains @@ -124,8 +164,8 @@ subroutine define_clm_statevec(mype) clm_begp = begp clm_endp = endp - if(clmupdate_swc.eq.1) then - if(clmstatevec_allcol.eq.1) then + if(clmupdate_swc==1) then + if(clmstatevec_allcol==1) then error stop "Not implemented: clmstatevec_allcol.ne.0" else ! One value per grid-cell @@ -135,22 +175,22 @@ subroutine define_clm_statevec(mype) end if endif - if(clmupdate_swc.eq.2) then + if(clmupdate_swc==2) then clm_varsize = (endg-begg+1) * nlevsoi clm_statevecsize = (endg-begg+1) * (nlevsoi+1) endif - if(clmupdate_texture.eq.1) then + if(clmupdate_texture==1) then clm_statevecsize = clm_statevecsize + 2*((endg-begg+1)*nlevsoi) endif - if(clmupdate_texture.eq.2) then + if(clmupdate_texture==2) then error stop "Not implemented: clmupdate_texture.eq.2" endif !hcp LST DA - if(clmupdate_T.eq.1) then - clm_varsize = endg-begg+1 + if(clmupdate_T==1) then + clm_varsize = endg-begg+1 clm_paramsize = endg-begg+1 !LAI clm_statevecsize = (endg-begg+1)*2 !TG, then TV endif @@ -163,7 +203,7 @@ subroutine define_clm_statevec(mype) !write(*,*) 'clm_statevecsize is ',clm_statevecsize IF (allocated(clm_statevec)) deallocate(clm_statevec) - if ((clmupdate_swc.ne.0) .or. (clmupdate_T.ne.0) .or. (clmupdate_texture.ne.0)) then + if ((clmupdate_swc/=0) .or. (clmupdate_T/=0) .or. (clmupdate_texture/=0)) then !hcp added condition allocate(clm_statevec(clm_statevecsize)) allocate(state_pdaf2clm_c_p(clm_statevecsize)) @@ -172,7 +212,7 @@ subroutine define_clm_statevec(mype) !write(*,*) 'clm_paramsize is ',clm_paramsize if (allocated(clm_paramarr)) deallocate(clm_paramarr) !hcp - if ((clmupdate_T.ne.0)) then !hcp + if ((clmupdate_T/=0)) then !hcp allocate(clm_paramarr(clm_paramsize)) end if @@ -207,7 +247,7 @@ subroutine set_clm_statevec(tstartcycle, mype) #ifdef PDAF_DEBUG IF(clmt_printensemble == tstartcycle + 1 .OR. clmt_printensemble < 0) THEN - IF(clmupdate_swc.NE.0) THEN + IF(clmupdate_swc/=0) THEN ! TSMP-PDAF: Debug output of CLM swc WRITE(fn2, "(a,i5.5,a,i5.5,a)") "swcstate_", mype, ".integrate.", tstartcycle + 1, ".txt" OPEN(unit=71, file=fn2, action="write") @@ -219,16 +259,16 @@ subroutine set_clm_statevec(tstartcycle, mype) #endif ! calculate shift when CRP data are assimilated - if(clmupdate_swc.eq.2) then + if(clmupdate_swc==2) then offset = clm_endg-clm_begg+1 endif - if(clmupdate_swc.ne.0) then + if(clmupdate_swc/=0) then ! write swc values to state vector cc = 1 do i=1,nlevsoi - if(clmstatevec_allcol.eq.1) then + if(clmstatevec_allcol==1) then error stop "Not implemented: clmstatevec_allcol.ne.0" @@ -248,7 +288,7 @@ subroutine set_clm_statevec(tstartcycle, mype) endif !hcp LAI - if(clmupdate_T.eq.1) then + if(clmupdate_T==1) then cc = 1 do j=clm_begg,clm_endg clm_statevec(cc) = tgrou(j) @@ -261,7 +301,7 @@ subroutine set_clm_statevec(tstartcycle, mype) !end hcp LAI ! write average swc to state vector (CRP assimilation) - if(clmupdate_swc.eq.2) then + if(clmupdate_swc==2) then cc = 1 do j=clm_begg,clm_endg do i=1,nlevsoi @@ -274,13 +314,13 @@ subroutine set_clm_statevec(tstartcycle, mype) endif ! write texture values to state vector (if desired) - if(clmupdate_texture.ne.0) then + 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.eq.2) then + if(clmupdate_texture==2) then error stop "Not implemented: clmupdate_texture.eq.2" end if cc = cc + 1 @@ -365,7 +405,7 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") #ifdef PDAF_DEBUG IF(clmt_printensemble == tstartcycle .OR. clmt_printensemble < 0) THEN - IF(clmupdate_swc.NE.0) THEN + IF(clmupdate_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") @@ -383,20 +423,20 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") #endif ! calculate shift when CRP data are assimilated - if(clmupdate_swc.eq.2) then + if(clmupdate_swc==2) then offset = clm_endg-clm_begg+1 endif ! write updated swc back to CLM - if(clmupdate_swc.ne.0) then + if(clmupdate_swc/=0) then ! Set minimum soil moisture for checking the state vector and ! for setting minimum swc for CLM - if(clmwatmin_switch.eq.3) then + if(clmwatmin_switch==3) then ! CLM3.5 type watmin watmin_check = 0.00 watmin_set = 0.05 - else if(clmwatmin_switch.eq.5) then + else if(clmwatmin_switch==5) then ! CLM5.0 type watmin watmin_check = watmin watmin_set = watmin @@ -416,13 +456,13 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") ! Set cc (the state vector index) from the ! CLM5-grid-index and the `CLM5-layer-index times ! num_gridcells` - if(clmstatevec_allcol.eq.1) then + if(clmstatevec_allcol==1) then error stop "Not implemented: clmstatevec_allcol.ne.0" else cc = (j - clm_begg + 1) + (i - 1) * (clm_endg - clm_begg + 1) end if - if(swc(j,i).eq.0.0) 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 @@ -437,9 +477,9 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") !h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) end if - if(clm_statevec(cc+offset).le.watmin_check) then + if(clm_statevec(cc+offset)<=watmin_check) then swc(j,i) = watmin_set - else if(clm_statevec(cc+offset).ge.watsat(j,i)) then + else if(clm_statevec(cc+offset)>=watsat(j,i)) then swc(j,i) = watsat(j,i) else swc(j,i) = clm_statevec(cc+offset) @@ -456,7 +496,7 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") ! ! 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" @@ -477,7 +517,7 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") #ifdef PDAF_DEBUG IF(clmt_printensemble == tstartcycle .OR. clmt_printensemble < 0) THEN - IF(clmupdate_swc.NE.0) THEN + 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") @@ -503,11 +543,11 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") endif !hcp: TG, TV - if(clmupdate_T.EQ.1) then + if(clmupdate_T==1) then cc = 1 do j=clm_begg,clm_endg - tgrou(j) = clm_statevec(cc) - tvege(j) = clm_statevec(cc+clm_varsize) + tgrou(j) = clm_statevec(cc) + tvege(j) = clm_statevec(cc+clm_varsize) cc = cc + 1 end do write(*,*) 'After update, tgrou(beg) tvege(beg)=',tgrou(clm_begg), tvege(clm_begg) @@ -522,7 +562,7 @@ subroutine update_clm(tstartcycle, mype) bind(C,name="update_clm") !end do ! write updated texture back to CLM - if(clmupdate_texture.eq.1) then + if(clmupdate_texture==1) then cc = 1 do i=1,nlevsoi do j=clm_begg,clm_endg @@ -557,11 +597,11 @@ subroutine clm_correct_texture() clay = pclay(c,lev) sand = psand(c,lev) - if(sand.le.0.0) sand = 1.0 - if(clay.le.0.0) clay = 1.0 + if(sand<=0.0) sand = 1.0 + if(clay<=0.0) clay = 1.0 ttot = sand + clay - if(ttot.gt.100) then + if(ttot>100) then sand = sand/ttot * 100.0 clay = clay/ttot * 100.0 end if @@ -745,7 +785,7 @@ subroutine domain_def_clm(lon_clmobs, lat_clmobs, dim_obs, & ! initialize vector with zero values longxy(:) = 0 latixy(:) = 0 - + ! fill vector with index values counter = 1 do ii = 1, nj @@ -923,21 +963,21 @@ subroutine init_dim_l_clm(domain_p, dim_l) integer, intent(out) :: dim_l integer :: nshift - if(clmupdate_swc.eq.1) then + if(clmupdate_swc==1) then dim_l = nlevsoi nshift = nlevsoi endif - if(clmupdate_swc.eq.2) then + if(clmupdate_swc==2) then dim_l = nlevsoi + 1 nshift = nlevsoi + 1 endif - if(clmupdate_texture.eq.1) then + if(clmupdate_texture==1) then dim_l = 2*nlevsoi + nshift endif - if(clmupdate_texture.eq.2) then + if(clmupdate_texture==2) then error stop "Not implemented: clmupdate_texture.eq.2" endif diff --git a/interface/model/clm3_5/mod_clm_statistics.F90 b/interface/model/clm3_5/mod_clm_statistics.F90 index 86753a3fe..2b0aa0c3a 100644 --- a/interface/model/clm3_5/mod_clm_statistics.F90 +++ b/interface/model/clm3_5/mod_clm_statistics.F90 @@ -75,8 +75,8 @@ subroutine write_clm_statistics(ts,ttot) bind(C,name="write_clm_statistics") real(r8), pointer :: mm(:),var(:),sd(:) real(r8),pointer :: ptr(:) integer,dimension(3) :: dimids - integer ji,jj - integer realrank,realsize + integer :: ji,jj + integer :: realrank,realsize real(r8), pointer :: lon(:) real(r8), pointer :: lat(:) @@ -107,9 +107,9 @@ subroutine write_clm_statistics(ts,ttot) bind(C,name="write_clm_statistics") variable_names(4) = "sh_sd" ! define netcdf output file - if(masterproc .and. (realrank.eq.0)) then + if(masterproc .and. (realrank==0)) then statistic_filename = get_statistic_filename() - if(ts.eq.1) then + if(ts==1) then ierr = nf90_create(statistic_filename, NF90_CLOBBER, il_file_id) ierr = nf90_def_dim(il_file_id, "lon", nlon, dimids(1)) ierr = nf90_def_dim(il_file_id, "lat", nlat, dimids(2)) @@ -159,7 +159,7 @@ subroutine write_clm_statistics(ts,ttot) bind(C,name="write_clm_statistics") sd = sqrt(sd/(realsize-1)) - if((realrank.eq.0)) then + if((realrank==0)) then ptr => mm call gather_data_to_master(ptr,clmvar_global_g,clmlevel=nameg) @@ -170,11 +170,11 @@ subroutine write_clm_statistics(ts,ttot) bind(C,name="write_clm_statistics") clmvar_out(ji,jj) = clmvar_global_g(g1) end do ierr = nf90_inq_varid(il_file_id, trim(variable_names(3)) , ncvarid(3)) - ierr = nf90_put_var( il_file_id, ncvarid(3), clmvar_out(:,:), start = (/ 1, 1,ts /), count = (/ nlon, nlat, 1 /) ) + ierr = nf90_put_var( il_file_id, ncvarid(3), clmvar_out(:,:), start = [ 1, 1,ts ], count = [ nlon, nlat, 1 ] ) end if end if - if((realrank.eq.0)) then + if((realrank==0)) then ptr => sd call gather_data_to_master(ptr,clmvar_global_g,clmlevel=nameg) @@ -185,7 +185,7 @@ subroutine write_clm_statistics(ts,ttot) bind(C,name="write_clm_statistics") clmvar_out(ji,jj) = clmvar_global_g(g1) end do ierr = nf90_inq_varid(il_file_id, trim(variable_names(4)) , ncvarid(4)) - ierr = nf90_put_var( il_file_id, ncvarid(4), clmvar_out(:,:), start = (/ 1, 1,ts /), count = (/ nlon, nlat, 1 /) ) + ierr = nf90_put_var( il_file_id, ncvarid(4), clmvar_out(:,:), start = [ 1, 1,ts ], count = [ nlon, nlat, 1 ] ) end if end if @@ -207,7 +207,7 @@ subroutine write_clm_statistics(ts,ttot) bind(C,name="write_clm_statistics") call mpi_reduce(var,sd,nloc,MPI_REAL8,MPI_SUM,0,COMM_couple_clm,ierr) sd = sqrt(sd/(realsize-1)) - if((realrank.eq.0)) then + if((realrank==0)) then ptr => mm call gather_data_to_master(ptr,clmvar_global_g,clmlevel=nameg) @@ -218,11 +218,11 @@ subroutine write_clm_statistics(ts,ttot) bind(C,name="write_clm_statistics") clmvar_out(ji,jj) = clmvar_global_g(g1) end do ierr = nf90_inq_varid(il_file_id, trim(variable_names(1)) , ncvarid(1)) - ierr = nf90_put_var( il_file_id, ncvarid(1), clmvar_out(:,:), start = (/ 1, 1,ts /), count = (/ nlon, nlat, 1 /) ) + ierr = nf90_put_var( il_file_id, ncvarid(1), clmvar_out(:,:), start = [ 1, 1,ts ], count = [ nlon, nlat, 1 ] ) end if end if - if((realrank.eq.0)) then + if((realrank==0)) then ptr => sd call gather_data_to_master(ptr,clmvar_global_g,clmlevel=nameg) @@ -233,7 +233,7 @@ subroutine write_clm_statistics(ts,ttot) bind(C,name="write_clm_statistics") clmvar_out(ji,jj) = clmvar_global_g(g1) end do ierr = nf90_inq_varid(il_file_id, trim(variable_names(2)) , ncvarid(2)) - ierr = nf90_put_var( il_file_id, ncvarid(2), clmvar_out(:,:), start = (/ 1, 1,ts /), count = (/ nlon, nlat, 1 /) ) + ierr = nf90_put_var( il_file_id, ncvarid(2), clmvar_out(:,:), start = [ 1, 1,ts ], count = [ nlon, nlat, 1 ] ) end if end if @@ -273,7 +273,7 @@ subroutine write_clm_statistics(ts,ttot) bind(C,name="write_clm_statistics") !end do ! close netcdf output file - if(masterproc .and. (realrank.eq.0)) then + if(masterproc .and. (realrank==0)) then ierr = nf90_close(il_file_id) end if diff --git a/interface/model/clm3_5/print_update_clm.F90 b/interface/model/clm3_5/print_update_clm.F90 index a237e6812..a8f429079 100644 --- a/interface/model/clm3_5/print_update_clm.F90 +++ b/interface/model/clm3_5/print_update_clm.F90 @@ -82,15 +82,15 @@ subroutine print_update_clm(ts,ttot) bind(C,name="print_update_clm") if(masterproc) then call get_update_filename(update_filename) - if(ts.eq.1) then + if(ts==1) then status = nf90_create(update_filename, NF90_CLOBBER, il_file_id) status = nf90_def_dim(il_file_id, "x", ndlon, dimids(1)) status = nf90_def_dim(il_file_id, "y", ndlat, dimids(2)) status = nf90_def_dim(il_file_id, "z", nlevsoi, dimids(3)) status = nf90_def_dim(il_file_id, "t", ttot, dimids(4)) - if(clmprint_swc.eq.1) status = nf90_def_var(il_file_id, "swc", NF90_DOUBLE, dimids, ncvarid(1)) - if(clmupdate_texture.eq.1) status = nf90_def_var(il_file_id, "sand", NF90_DOUBLE, dimids, ncvarid(2)) - if(clmupdate_texture.eq.1) status = nf90_def_var(il_file_id, "clay", NF90_DOUBLE, dimids, ncvarid(3)) + if(clmprint_swc==1) status = nf90_def_var(il_file_id, "swc", NF90_DOUBLE, dimids, ncvarid(1)) + if(clmupdate_texture==1) status = nf90_def_var(il_file_id, "sand", NF90_DOUBLE, dimids, ncvarid(2)) + if(clmupdate_texture==1) status = nf90_def_var(il_file_id, "clay", NF90_DOUBLE, dimids, ncvarid(3)) status = nf90_enddef(il_file_id) else status = nf90_open(update_filename,NF90_WRITE,il_file_id) @@ -98,7 +98,7 @@ subroutine print_update_clm(ts,ttot) bind(C,name="print_update_clm") endif - if(clmprint_swc.eq.1) then + if(clmprint_swc==1) then swc => clm3%g%l%c%cws%h2osoi_vol ! swc clmstate_tmp_local = transpose(swc) @@ -116,12 +116,12 @@ subroutine print_update_clm(ts,ttot) bind(C,name="print_update_clm") end do status = nf90_inq_varid(il_file_id, "swc" , ncvarid(1)) status = nf90_put_var( il_file_id, ncvarid(1), clmstate_out(:,:,:), & - start = (/ 1, 1, 1, ts/), count = (/ ndlon, ndlat, nlevsoi, 1 /) ) + start = [ 1, 1, 1, ts], count = [ ndlon, ndlat, nlevsoi, 1 ] ) !status = nf90_close(il_file_id) end if end if - if(clmupdate_texture.eq.1) then + if(clmupdate_texture==1) then psand => clm3%g%l%c%cps%psand pclay => clm3%g%l%c%cps%pclay ! sand @@ -140,7 +140,7 @@ subroutine print_update_clm(ts,ttot) bind(C,name="print_update_clm") end do status = nf90_inq_varid(il_file_id, "sand" , ncvarid(2)) status = nf90_put_var( il_file_id, ncvarid(2), clmstate_out(:,:,:), & - start = (/ 1, 1, 1, ts/), count = (/ ndlon, ndlat, nlevsoi, 1 /) ) + start = [ 1, 1, 1, ts], count = [ ndlon, ndlat, nlevsoi, 1 ] ) !status = nf90_close(il_file_id) end if @@ -160,7 +160,7 @@ subroutine print_update_clm(ts,ttot) bind(C,name="print_update_clm") end do status = nf90_inq_varid(il_file_id, "clay" , ncvarid(3)) status = nf90_put_var( il_file_id, ncvarid(3), clmstate_out(:,:,:), & - start = (/ 1, 1, 1, ts/), count = (/ ndlon, ndlat, nlevsoi, 1 /) ) + start = [ 1, 1, 1, ts], count = [ ndlon, ndlat, nlevsoi, 1 ] ) !status = nf90_close(il_file_id) end if end if diff --git a/interface/model/common/enkf.h b/interface/model/common/enkf.h index f943ad903..37460dfa0 100755 --- a/interface/model/common/enkf.h +++ b/interface/model/common/enkf.h @@ -43,6 +43,10 @@ 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); +#if defined CLMFIVE +extern void print_inc_clm(); +extern void print_state_clm(); +#endif #endif extern void write_clm_statistics(int *ts, int *ttot); extern void clm_finalize(); @@ -59,6 +63,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 +93,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 +114,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 +150,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..844af6e3d 100755 --- a/interface/model/common/read_enkfpar.c +++ b/interface/model/common/read_enkfpar.c @@ -86,6 +86,7 @@ void read_enkfpar(char *parname) clmstatevec_max_layer = iniparser_getint(pardict,"CLM:statevec_max_layer",25); clmt_printensemble = iniparser_getint(pardict,"CLM:t_printensemble",-1); clmwatmin_switch = iniparser_getint(pardict,"CLM:watmin_switch",0); + clmupdate_tws = iniparser_getint(pardict,"CLM:update_tws",0); clmswc_mask_snow = iniparser_getint(pardict,"CLM:swc_mask_snow",0); /* get settings for COSMO */ @@ -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/cosmo4_21/enkf_cosmo.F90 b/interface/model/cosmo4_21/enkf_cosmo.F90 index 27d94dc22..19de9e519 100644 --- a/interface/model/cosmo4_21/enkf_cosmo.F90 +++ b/interface/model/cosmo4_21/enkf_cosmo.F90 @@ -172,7 +172,7 @@ subroutine cosmo_init(pdaf_id) bind(C,name="cosmo_init") yzerrmsg = ' ERROR *** Allocation of space for meteofields failed ***' CALL model_abort (my_cart_id, ierrstat, yzerrmsg, 'allocation: default') ENDIF - + #ifdef COSMOART IF (l_cosmo_art) THEN CALL organize_cosmo_art ('allocate', ydate_ini, izerror, yzerrmsg) @@ -253,7 +253,7 @@ subroutine cosmo_init(pdaf_id) bind(C,name="cosmo_init") CALL model_abort (my_cart_id, ierrstat, yzerrmsg, 'allocation: canopy') ENDIF ENDIF - + #ifdef COSMOART ! Initialization of COSMO_ART IF (l_cosmo_art) THEN @@ -338,7 +338,7 @@ subroutine cosmo_init(pdaf_id) bind(C,name="cosmo_init") 'dfi_initialization') ENDIF ENDIF - + ! Close file for control output IF (my_cart_id == 0) THEN CLOSE (nuspecif, STATUS='KEEP') @@ -383,7 +383,7 @@ subroutine cosmo_init(pdaf_id) bind(C,name="cosmo_init") ! There are different types of possible disturbances, see the documentation ! of the corresponding namelist parameters in INPUT_IDEAL, and there is the possibility ! to specify more than one disturbance (up to 50 right now). - + IF (lartif_data) THEN CALL set_tempdist(nnew) ! Initial condition on t_so (takes only effect if lsoil=.true.) @@ -445,11 +445,11 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") !AK (20.03.12) CALL initialize_loop (ntstep, nbd1, nbd2, nold, nnow, nnew) - + IF (ltime) CALL get_timings (i_add_computations, ntstep, dt, izerror) !-------------------------------------------------------------------------- - !- Section 6.2.1: physics + !- Section 6.2.1: physics !-------------------------------------------------------------------------- #ifdef COSMOART @@ -490,9 +490,9 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") !-------------------------------------------------------------------------- IF (lartif_data) THEN - ! Set possible artificial heating rate disturbance(s) in the soil + ! Set possible artificial heating rate disturbance(s) in the soil ! (affects t_so or t_s/t_m/t_cl depending on soil model - ! and takes effect only IF lsoil=.TRUE.). + ! and takes effect only IF lsoil=.TRUE.). ! Because the soil model has already done the time integration, ! the artificial disturbances have to be imposed on ! timelevel nnew: @@ -664,7 +664,7 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") !-------------------------------------------------------------------------- !- Section 6.5: water budget !-------------------------------------------------------------------------- - + IF (ldiagnos .AND. (l2tls .OR. (ntstep > 0))) THEN ! for the leapfrog scheme the summations in diagbudget must not be done ! in the first intermediate step ntstep==0. These calculations are done @@ -772,10 +772,10 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") !-------------------------------------------------------------------------- !- Section 6.7: Exchange of boundary data !-------------------------------------------------------------------------- - + ! The calls to exchg_boundaries have to be here in any case, even for a - ! sequential version, because of possible periodic boundary conditions - ! the check, which kind of communication is necessary, is done within + ! sequential version, because of possible periodic boundary conditions + ! the check, which kind of communication is necessary, is done within ! the subroutine now. ! Check, whether additional communication for the convection is @@ -852,7 +852,7 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") !-------------------------------------------------------------------------- !- Section 6.10: Finalization of this time step !-------------------------------------------------------------------------- - + #if defined RTTOV7 || defined RTTOV9 || defined RTTOV10 ! deallocate the satellite variables IF (luse_rttov) THEN diff --git a/interface/model/cosmo4_21/enkf_cosmo_mod.F90 b/interface/model/cosmo4_21/enkf_cosmo_mod.F90 index d136ec0c1..6259e2790 100644 --- a/interface/model/cosmo4_21/enkf_cosmo_mod.F90 +++ b/interface/model/cosmo4_21/enkf_cosmo_mod.F90 @@ -92,7 +92,7 @@ module enkf_cosmo_mod !AK (20.03.12) USE src_tracer_supply, ONLY: organize_tracer_init, organize_tracer, & organize_tracer_bound, organize_tracer_source -!AK (20.03.12) +!AK (20.03.12) !============================================================================== IMPLICIT NONE @@ -151,7 +151,7 @@ SUBROUTINE initialize_loop (ntstep, nbd1, nbd2, nold, nnow, nnew) !------------------------------------------------------------------------------ ! ! Description: -! This routine initializes each time step. It checks whether certain +! This routine initializes each time step. It checks whether certain ! actions have to be performed and sets the logical variables from ! the parameterlist. Organizational variables are updated. ! @@ -414,7 +414,7 @@ SUBROUTINE initialize_loop (ntstep, nbd1, nbd2, nold, nnow, nnew) ELSE ! Boundary values of cloud ice are interpreted from qc and ! qv is recalculated from relative humidity over ice below - ! a threshold temperature. + ! a threshold temperature. DO k = 1, ke !CDIR COLLAPSE qi(:,:,k,nnew) = 0.0_ireals @@ -739,7 +739,7 @@ SUBROUTINE initialize_loop (ntstep, nbd1, nbd2, nold, nnow, nnew) istartpar, iendpar, jstartpar, jendpar ) ENDIF #endif - ! compute density of moist air for time-level nnow + ! compute density of moist air for time-level nnow CALL calrho ( t(:,:,:,nnow), pp(:,:,:,nnow), qv(:,:,:,nnow), qc(:,:,:,nnow),& qrs, p0, rho, ie, je, ke, r_d, rvd_m_o) @@ -784,8 +784,8 @@ SUBROUTINE exchange_leapfrog IF (lprog_qi .AND. lzconv .AND. .NOT. lprogprec) THEN kzdims(1:24) = & - (/ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & - ke,ke,ke,ke,ke,ke,1,0,0,0,0,0/) + [ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & + ke,ke,ke,ke,ke,ke,1,0,0,0,0,0] CALL exchg_boundaries & (nnew+39, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -798,8 +798,8 @@ SUBROUTINE exchange_leapfrog qrs(:,:,:) , dqvdt(:,:,:) , qvsflx(:,:) ) ELSEIF (lprog_qi .AND. lzconv .AND. lprogprec) THEN kzdims(1:24) = & - (/ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & - ke,ke,ke,ke,ke,ke,ke,ke,ke,ke,1,0/) + [ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & + ke,ke,ke,ke,ke,ke,ke,ke,ke,ke,1,0] CALL exchg_boundaries & (nnew+39, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -813,7 +813,7 @@ SUBROUTINE exchange_leapfrog qs(:,:,:,nnow), qs(:,:,:,nnew), pp(:,:,:,nnow), pp(:,:,:,nnew), & qrs(:,:,:) , dqvdt(:,:,:) , qvsflx(:,:) ) IF (itype_gscp==4) THEN - kzdims(1:24) =(/ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24) =[ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -824,8 +824,8 @@ SUBROUTINE exchange_leapfrog ENDIF ELSEIF (lprog_qi .AND. .NOT. lzconv .AND. .NOT. lprogprec) THEN kzdims(1:24) = & - (/ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & - ke,ke,ke,ke,ke,0,0,0,0,0,0,0/) + [ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & + ke,ke,ke,ke,ke,0,0,0,0,0,0,0] CALL exchg_boundaries & (nnew+36, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -839,8 +839,8 @@ SUBROUTINE exchange_leapfrog qrs(:,:,:) ) ELSEIF (lprog_qi .AND. .NOT. lzconv) THEN kzdims(1:24) = & - (/ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & - ke,ke,ke,ke,ke,ke,ke,ke,ke,0,0,0/) + [ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & + ke,ke,ke,ke,ke,ke,ke,ke,ke,0,0,0] CALL exchg_boundaries & (nnew+36, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -854,7 +854,7 @@ SUBROUTINE exchange_leapfrog qs(:,:,:,nnow), qs(:,:,:,nnew), pp(:,:,:,nnow), pp(:,:,:,nnew), & qrs(:,:,:) ) IF (itype_gscp==4) THEN - kzdims(1:24) =(/ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24) =[ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -865,8 +865,8 @@ SUBROUTINE exchange_leapfrog ENDIF ELSEIF (.NOT. lprog_qi .AND. lzconv) THEN kzdims(1:24) = & - (/ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & - ke,ke,ke,1,0,0,0,0,0,0,0,0/) + [ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & + ke,ke,ke,1,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (nnew+33, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -880,8 +880,8 @@ SUBROUTINE exchange_leapfrog IF (lprogprec) THEN IF (itype_gscp > 1) THEN kzdims(1:24) = & - (/ke,ke,ke,ke,ke,0,0,0,0,0,0,0, & - 0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,ke,ke,ke,0,0,0,0,0,0,0, & + 0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -892,8 +892,8 @@ SUBROUTINE exchange_leapfrog qs(:,:,:,nnow), qs(:,:,:,nnew), qrs(:,:,:) ) ELSE kzdims(1:24) = & - (/ke,ke,ke,0,0,0,0,0,0,0,0,0, & - 0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,ke,0,0,0,0,0,0,0,0,0, & + 0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -905,8 +905,8 @@ SUBROUTINE exchange_leapfrog ENDIF ELSE kzdims(1:24) = & - (/ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & - ke,ke,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,ke,ke,ke1,ke1,ke,ke,ke,ke,ke,ke, & + ke,ke,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (nnew+30, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -920,8 +920,8 @@ SUBROUTINE exchange_leapfrog IF (lprogprec) THEN IF (itype_gscp > 1) THEN kzdims(1:24) = & - (/ke,ke,ke,ke,ke,0,0,0,0,0,0,0, & - 0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,ke,ke,ke,0,0,0,0,0,0,0, & + 0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -932,8 +932,8 @@ SUBROUTINE exchange_leapfrog qs(:,:,:,nnow), qs(:,:,:,nnew), qrs(:,:,:) ) ELSE kzdims(1:24) = & - (/ke,ke,ke,0,0,0,0,0,0,0,0,0, & - 0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,ke,0,0,0,0,0,0,0,0,0, & + 0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -950,7 +950,7 @@ SUBROUTINE exchange_leapfrog IF (lgas) THEN DO isp = 1,isp_gas kzdims(1:24) = & - (/ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -963,7 +963,7 @@ SUBROUTINE exchange_leapfrog IF (laero) THEN DO isp = 1,isp_aero kzdims(1:24) = & - (/ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -980,7 +980,7 @@ SUBROUTINE exchange_leapfrog IF (l_pollen) THEN DO isp = 1,isp_pollen kzdims(1:24) = & - (/ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -998,8 +998,8 @@ SUBROUTINE exchange_leapfrog DO iprog=1, 7 nprog = nprog + ltracer(iprog,iig) ENDDO - IF (nprog .GE. 1) THEN - kzdims(1:24)=(/ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + IF (nprog >= 1) THEN + kzdims(1:24)=[ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, & @@ -1017,12 +1017,12 @@ END SUBROUTINE exchange_leapfrog !============================================================================== SUBROUTINE exchange_runge_kutta - + IF (lprog_qi) THEN IF (lprogprec) THEN ! this is former itype_gscp = 5 IF (itype_gscp == 3) THEN - kzdims(1:24)=(/ke,ke,ke1,ke,ke,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24)=[ke,ke,ke1,ke,ke,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (50+nnew, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1034,7 +1034,7 @@ SUBROUTINE exchange_runge_kutta qs(:,:,:,nnew), pp(:,:,:,nnew), qrs(:,:,:) ) END IF IF (itype_gscp == 4) THEN - kzdims(1:24)=(/ke,ke,ke1,ke,ke,ke,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24)=[ke,ke,ke1,ke,ke,ke,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (50+nnew, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1047,7 +1047,7 @@ SUBROUTINE exchange_runge_kutta ENDIF ELSE ! .NOT. lprogprec: ! this is former itype_gscp = 3 - kzdims(1:24)=(/ke,ke,ke1,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24)=[ke,ke,ke1,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (50+nnew, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1060,9 +1060,9 @@ SUBROUTINE exchange_runge_kutta ENDIF ELSE ! .NOT. lprog_qi: IF (lprogprec) THEN - IF (itype_gscp > 1) THEN + IF (itype_gscp > 1) THEN ! this is former itype_gscp = 4 - kzdims(1:24)=(/ke,ke,ke1,ke,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24)=[ke,ke,ke1,ke,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (50+nnew, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1073,7 +1073,7 @@ SUBROUTINE exchange_runge_kutta qv(:,:,:,nnew), qc(:,:,:,nnew), qr(:,:,:,nnew), qs(:,:,:,nnew), & pp(:,:,:,nnew), qrs(:,:,:) ) ELSE ! kessler_pp: - kzdims(1:24)=(/ke,ke,ke1,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24)=[ke,ke,ke1,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (50+nnew, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1082,10 +1082,10 @@ SUBROUTINE exchange_runge_kutta 20000+ntstep, ldatatypes, ncomm_type, izerror, yzerrmsg, & u (:,:,:,nnew), v (:,:,:,nnew), w (:,:,:,nnew), t (:,:,:,nnew), & qv(:,:,:,nnew), qc(:,:,:,nnew), qr(:,:,:,nnew), pp(:,:,:,nnew), & - qrs(:,:,:) ) - ENDIF + qrs(:,:,:) ) + ENDIF ELSE ! .NOT. lprogprec: - kzdims(1:24)=(/ke,ke,ke1,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24)=[ke,ke,ke1,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (50+nnew, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1096,10 +1096,10 @@ SUBROUTINE exchange_runge_kutta qv(:,:,:,nnew), qc(:,:,:,nnew), pp(:,:,:,nnew), qrs(:,:,:) ) ENDIF END IF - + IF ( lzconv ) THEN IF ( lprog_tke ) THEN - kzdims(1:24)=(/ke,1,ke1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24)=[ke,1,ke1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1108,7 +1108,7 @@ SUBROUTINE exchange_runge_kutta 20000+ntstep, .FALSE., ncomm_type, izerror, yzerrmsg, & dqvdt(:,:,:), qvsflx(:,:), tke(:,:,:,nnew) ) ELSE - kzdims(1:24)=(/ke,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24)=[ke,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1119,7 +1119,7 @@ SUBROUTINE exchange_runge_kutta END IF ELSE IF ( lprog_tke ) THEN - kzdims(1:24)=(/ke1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24)=[ke1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1136,7 +1136,7 @@ SUBROUTINE exchange_runge_kutta IF (lgas) THEN DO isp = 1,isp_gas kzdims(1:24) = & - (/ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (2, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1149,7 +1149,7 @@ SUBROUTINE exchange_runge_kutta IF (laero) THEN DO isp = 1,isp_aero kzdims(1:24) = & - (/ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (2, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1166,7 +1166,7 @@ SUBROUTINE exchange_runge_kutta IF (l_pollen) THEN DO isp = 1,isp_pollen kzdims(1:24) = & - (/ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (2, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1184,8 +1184,8 @@ SUBROUTINE exchange_runge_kutta DO iprog=1, 7 nprog = nprog + ltracer(iprog,iig) ENDDO - IF (nprog .GE. 1) THEN - kzdims(1:24)=(/ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + IF (nprog >= 1) THEN + kzdims(1:24)=[ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (2, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute,ie, je, & kzdims, jstartpar, jendpar, nbl_exchg, nboundlines, my_cart_neigh, & @@ -1205,7 +1205,7 @@ END SUBROUTINE exchange_runge_kutta SUBROUTINE exchange_2timelevel IF (lprog_qi .AND. lzconv) THEN - kzdims(1:24) =(/ke,ke,ke1,ke,ke,ke,ke,ke,ke,ke,1,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24) =[ke,ke,ke1,ke,ke,ke,ke,ke,ke,ke,1,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (nnew+39, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1216,7 +1216,7 @@ SUBROUTINE exchange_2timelevel qv(:,:,:,nnew), qc(:,:,:,nnew), qi(:,:,:,nnew), pp(:,:,:,nnew), & qrs(:,:,:) , dqvdt(:,:,:) , qvsflx(:,:) ) ELSEIF (lprog_qi .AND. .NOT. lzconv) THEN - kzdims(1:24) =(/ke,ke,ke1,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24) =[ke,ke,ke1,ke,ke,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (nnew+36, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1227,7 +1227,7 @@ SUBROUTINE exchange_2timelevel qv(:,:,:,nnew), qc(:,:,:,nnew), qi(:,:,:,nnew), pp(:,:,:,nnew), & qrs(:,:,:) ) ELSEIF (.NOT. lprog_qi .AND. lzconv) THEN - kzdims(1:24) =(/ke,ke,ke1,ke,ke,ke,ke,ke,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24) =[ke,ke,ke1,ke,ke,ke,ke,ke,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (nnew+33, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1238,7 +1238,7 @@ SUBROUTINE exchange_2timelevel qv(:,:,:,nnew), qc(:,:,:,nnew), pp(:,:,:,nnew), & dqvdt(:,:,:) , qvsflx(:,:) ) ELSE - kzdims(1:24) =(/ke,ke,ke1,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + kzdims(1:24) =[ke,ke,ke1,ke,ke,ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (nnew+30, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1255,8 +1255,8 @@ SUBROUTINE exchange_2timelevel DO iprog=1, 7 nprog = nprog + ltracer(iprog,iig) ENDDO - IF (nprog .GE. 1) THEN - kzdims(1:24)=(/ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) + IF (nprog >= 1) THEN + kzdims(1:24)=[ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & (nnew+30, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, ie, je,& kzdims, jstartpar, jendpar, nbl_exchg, nboundlines, my_cart_neigh, & @@ -1270,8 +1270,8 @@ SUBROUTINE exchange_2timelevel IF (lprogprec) THEN IF (itype_gscp == 4) THEN kzdims(1:24) = & - (/ke,ke,ke,ke,0,0,0,0,0,0,0,0, & - 0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,ke,ke,0,0,0,0,0,0,0,0, & + 0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1281,8 +1281,8 @@ SUBROUTINE exchange_2timelevel qr(:,:,:,nnew), qs(:,:,:,nnew), qg(:,:,:,nnew), qrs(:,:,:) ) ELSEIF (itype_gscp > 1) THEN kzdims(1:24) = & - (/ke,ke,ke,0,0,0,0,0,0,0,0,0, & - 0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,ke,0,0,0,0,0,0,0,0,0, & + 0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1292,8 +1292,8 @@ SUBROUTINE exchange_2timelevel qr(:,:,:,nnew), qs(:,:,:,nnew), qrs(:,:,:) ) ELSE kzdims(1:24) = & - (/ke,ke,0,0,0,0,0,0,0,0,0,0, & - 0,0,0,0,0,0,0,0,0,0,0,0/) + [ke,ke,0,0,0,0,0,0,0,0,0,0, & + 0,0,0,0,0,0,0,0,0,0,0,0] CALL exchg_boundaries & ( 0, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, & @@ -1313,7 +1313,7 @@ SUBROUTINE exchange_l2dim DO k = 1, ke DO j = 1,nboundlines - + t (:,jstart-j,k,nnew) = t (:,jend +1-j,k,nnew) pp(:,jstart-j,k,nnew) = pp(:,jend +1-j,k,nnew) qv(:,jstart-j,k,nnew) = qv(:,jend +1-j,k,nnew) @@ -1358,7 +1358,7 @@ SUBROUTINE exchange_l2dim v(:,jstartv-j,k,nnew) = v(:,jendv +1-j,k,nnew) u(:,jendu +j,k,nnew) = u(:,jstartu-1+j,k,nnew) v(:,jendv +j,k,nnew) = v(:,jstartv-1+j,k,nnew) - + ENDDO ENDDO @@ -1375,12 +1375,12 @@ SUBROUTINE exchange_l2dim qvsflx (:,jend +j) = qvsflx (:,jstart-1+j) ENDDO ENDIF - + IF ( .NOT.l2tls ) THEN DO k = 1, ke DO j = 1,nboundlines - + t (:,jstart-j,k,nnow) = t (:,jend +1-j,k,nnow) pp(:,jstart-j,k,nnow) = pp(:,jend +1-j,k,nnow) qv(:,jstart-j,k,nnow) = qv(:,jend +1-j,k,nnow) @@ -1411,7 +1411,7 @@ SUBROUTINE exchange_l2dim v(:,jstartv-j,k,nnow) = v(:,jendv +1-j,k,nnow) u(:,jendu +j,k,nnow) = u(:,jstartu-1+j,k,nnow) v(:,jendv +j,k,nnow) = v(:,jstartv-1+j,k,nnow) - + ENDDO ENDDO @@ -1423,7 +1423,7 @@ SUBROUTINE exchange_l2dim ENDDO ENDIF - + END SUBROUTINE exchange_l2dim !============================================================================== @@ -1431,7 +1431,7 @@ END SUBROUTINE exchange_l2dim SUBROUTINE set_qrqsqg_boundaries ! Now we have to set the nnew values for qr and qs in a consistent way: - ! this is an intermediate solution, as long as no better treatment of + ! this is an intermediate solution, as long as no better treatment of ! the boundary values is found ! Treatment of rain and snow @@ -1629,14 +1629,14 @@ SUBROUTINE set_qrqsqg_boundaries IF (my_cart_neigh(1) == -1) THEN DO k = 1, ke DO i = 1, nboundlines -!CDIR NOLOOPCHG +!CDIR NOLOOPCHG DO j = jstart, jend qg(i,j,k,nnew) = qg(istart,j,k,nnew) ENDDO ENDDO ENDDO ENDIF - ! eastern boundary + ! eastern boundary IF (my_cart_neigh(3) == -1) THEN DO k = 1, ke DO i = ie-nboundlines+1, ie @@ -1671,14 +1671,14 @@ SUBROUTINE set_qrqsqg_boundaries IF (my_cart_neigh(1) == -1) THEN DO k = 1, ke DO i = 1, nboundlines -!CDIR NOLOOPCHG +!CDIR NOLOOPCHG DO j = jstart, jend qg(i,j,k,nnew) = 0.0_ireals ENDDO ENDDO ENDDO ENDIF - ! eastern boundary + ! eastern boundary IF (my_cart_neigh(3) == -1) THEN DO k = 1, ke DO i = ie-nboundlines+1, ie diff --git a/interface/model/cosmo5_1/enkf_cosmo.F90 b/interface/model/cosmo5_1/enkf_cosmo.F90 index d94650251..99339d046 100644 --- a/interface/model/cosmo5_1/enkf_cosmo.F90 +++ b/interface/model/cosmo5_1/enkf_cosmo.F90 @@ -1,6 +1,6 @@ subroutine cosmo_init(pdaf_id) bind(C,name="cosmo_init") -use iso_C_binding +use iso_C_binding use enkf_cosmo_mod integer(c_int), intent(in) :: pdaf_id @@ -218,7 +218,7 @@ subroutine cosmo_init(pdaf_id) bind(C,name="cosmo_init") ENDIF #ifdef NETCDF - IF( lasync_io .AND. nc_asyn_io>0 ) THEN + IF( lasync_io .AND. nc_asyn_io>0 ) THEN CALL allocate_io_sendbuffer(yzerrmsg, izerror) IF (izerror /= 0) THEN ierrstat = 3321 @@ -404,7 +404,7 @@ subroutine cosmo_init(pdaf_id) bind(C,name="cosmo_init") ENDIF ENDIF ENDIF - + #ifdef COSMOART ! Initialization of COSMO_ART IF (l_cosmo_art) THEN @@ -487,7 +487,7 @@ subroutine cosmo_init(pdaf_id) bind(C,name="cosmo_init") #endif ENDIF - ! Initialization of blocks fields + ! Initialization of blocks fields ! This needs to be done after all arrays have been allocated IF (lphys) THEN ! Register block fields @@ -531,7 +531,7 @@ subroutine cosmo_init(pdaf_id) bind(C,name="cosmo_init") ENDIF lsppt = lzspptd ENDIF - + ! Close file for control output IF (my_cart_id == 0) THEN CLOSE (nuspecif, STATUS='KEEP') @@ -572,7 +572,7 @@ subroutine cosmo_init(pdaf_id) bind(C,name="cosmo_init") ! There are different types of possible disturbances, see the documentation ! of the corresponding namelist parameters in INPUT_IDEAL, and there is the possibility ! to specify more than one disturbance (up to 50 right now). - + IF (lartif_data) THEN CALL set_tempdist(nnew) @@ -659,8 +659,8 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") use iso_C_binding use enkf_cosmo_mod -integer(c_int),intent(in) :: cos_dt - +integer(c_int),intent(in) :: cos_dt + !------------------------------------------------------------------------------ !- Section 6: Time stepping !------------------------------------------------------------------------------ @@ -706,7 +706,7 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") IF (ltime) CALL get_timings (i_add_computations, ntstep, dt, izerror) !-------------------------------------------------------------------------- - !- Section 6.2.1: physics + !- Section 6.2.1: physics !-------------------------------------------------------------------------- #ifdef COSMOART @@ -759,9 +759,9 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") !-------------------------------------------------------------------------- IF (lartif_data) THEN - ! Set possible artificial heating rate disturbance(s) in the soil + ! Set possible artificial heating rate disturbance(s) in the soil ! (affects t_so or t_s/t_m/t_cl depending on soil model - ! and takes effect only IF lsoil=.TRUE.). + ! and takes effect only IF lsoil=.TRUE.). ! Because the soil model has already done the time integration, ! the artificial disturbances have to be imposed on ! timelevel nnew: @@ -937,7 +937,7 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") !-------------------------------------------------------------------------- !- Section 6.5: water budget !-------------------------------------------------------------------------- - + IF (ldiagnos .AND. (l2tls .OR. (ntstep > 0))) THEN ! for the leapfrog scheme the summations in diagbudget must not be done ! in the first intermediate step ntstep==0. These calculations are done @@ -1046,10 +1046,10 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") !-------------------------------------------------------------------------- !- Section 6.7: Exchange of boundary data !-------------------------------------------------------------------------- - + ! The calls to exchg_boundaries have to be here in any case, even for a - ! sequential version, because of possible periodic boundary conditions - ! the check, which kind of communication is necessary, is done within + ! sequential version, because of possible periodic boundary conditions + ! the check, which kind of communication is necessary, is done within ! the subroutine now. ! Check, whether additional communication for the convection is @@ -1125,7 +1125,7 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") #ifdef RADARFWO !-------------------------------------------------------------------------- - !- Section 6.8b: radar forward operator and optionally preparing + !- Section 6.8b: radar forward operator and optionally preparing ! of radar feedback files for radar data assimilation ! (the latter needs radar observation files) !-------------------------------------------------------------------------- @@ -1153,7 +1153,7 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") IF (l_cosmo_art_nl) THEN l_cosmo_art=l_cosmo_art_nl ENDIF -#endif +#endif CALL organize_data ('result', ntstep, izerror, yzerrmsg) IF (izerror /= 0_iintegers) THEN @@ -1187,7 +1187,7 @@ subroutine cosmo_advance(cos_dt) bind(C,name="cosmo_advance") !-------------------------------------------------------------------------- !- Section 6.10: Finalization of this time step !-------------------------------------------------------------------------- - + #if defined RTTOV7 || defined RTTOV9 || defined RTTOV10 ! deallocate the satellite variables IF (luse_rttov) THEN @@ -1261,7 +1261,7 @@ subroutine cosmo_finalize() bind(C,name="cosmo_finalize") use iso_C_binding use enkf_cosmo_mod - + !------------------------------------------------------------------------------ !- Section 7: Final clean up !------------------------------------------------------------------------------ diff --git a/interface/model/eclm/enkf_clm_mod_5.F90 b/interface/model/eclm/enkf_clm_mod_5.F90 index 259e2238f..3888bfb88 100755 --- a/interface/model/eclm/enkf_clm_mod_5.F90 +++ b/interface/model/eclm/enkf_clm_mod_5.F90 @@ -40,10 +40,12 @@ module enkf_clm_mod integer :: clm_paramsize !hcp: Size of CLM parameter vector (f.e. LAI) integer :: clm_varsize integer :: clm_begg,clm_endg + integer :: clm_begl,clm_endl integer :: clm_begc,clm_endc integer :: clm_begp,clm_endp real(r8),allocatable :: clm_statevec(:) real(r8),allocatable :: clm_statevec_orig(:) + real(r8),allocatable :: clm_statevec_original_input(:) ! orginal values in statevector so that I can also access them in the update integer,allocatable :: state_pdaf2clm_c_p(:) integer,allocatable :: state_pdaf2clm_j_p(:) integer,allocatable :: state_loc2clm_c_p(:) @@ -66,6 +68,36 @@ module enkf_clm_mod integer(c_int),bind(C,name="clmswc_mask_snow") :: clmswc_mask_snow real(c_double),bind(C,name="clmcrns_bd") :: clmcrns_bd + ! Yorck + integer(c_int),bind(C,name="clmupdate_tws") :: clmupdate_tws + integer(c_int),bind(C,name="exclude_greenland") :: exclude_greenland + 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 !0: liq and ice seperated in statevector, 1: liq and ice together in statevector, 2: raw TWS values in statevector (just for testing) + integer(c_int),bind(C,name="update_snow") :: update_snow !0: scripts from Lukas, 1: simple factor of old and new snow multiplied with old values + integer(c_int),bind(C,name="remove_mean") :: remove_mean + integer, allocatable :: num_layer(:) + integer, allocatable :: num_layer_columns(:) + + real(r8), allocatable :: tws_temp_mean(:,:) ! temporal mean for TWS + real(r8), allocatable :: lon_temp_mean(:,:) ! corresponding longitude + real(r8), allocatable :: lat_temp_mean(:,:) ! corresponding latitude + + real(r8), allocatable :: tws_temp_mean_vector(:) ! temporal mean for TWS, in vector form, sorted just as sub-domain + + integer :: num_hactiveg, num_hactivec, num_hactiveg_patch, num_hactivep + + integer, allocatable :: hactiveg_levels(:,:) ! hydrolocial active filter for all levels (gridcell) + integer, allocatable :: hactivec_levels(:,:) ! hydrolocial active filter for all levels (column) + integer, allocatable :: hactivep(:) ! hydrolocial active filter (patches) + integer, allocatable :: hactiveg_patch(:) ! hydrolocial active filter (patches) + integer, allocatable :: gridcell_state(:) + + character(c_char),dimension(100),bind(C,name="mean_filename") :: mean_filename + + ! end Yorck + integer :: nstep ! time step index real(r8) :: dtime ! time step increment (sec) integer :: ier ! error code @@ -93,7 +125,10 @@ subroutine define_clm_statevec(mype) use decompMod , only : get_proc_bounds use clm_varpar , only : nlevsoi use clm_varcon , only : ispval + use clm_varcon, only: spval + use GridcellType, only: grc use ColumnType , only : col + use PatchType, only: patch implicit none @@ -104,15 +139,26 @@ subroutine define_clm_statevec(mype) integer :: jj integer :: c integer :: g + integer :: p integer :: cg integer :: cc integer :: cccheck + integer :: fa + integer :: 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) @@ -124,11 +170,16 @@ subroutine define_clm_statevec(mype) clm_begg = begg clm_endg = endg + clm_begl = begl + clm_endl = endl clm_begc = begc clm_endc = endc clm_begp = begp clm_endp = endp + if (allocated(found)) deallocate(found) + allocate(found(clm_begg:clm_endg)) + ! Soil Moisture DA: State vector index arrays if(clmupdate_swc==1) then @@ -303,6 +354,268 @@ subroutine define_clm_statevec(mype) endif !end hcp + if (clmupdate_tws==1) then + + ! 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 + + found(clm_begg:clm_endg) = .false. + + allocate(num_layer(1:nlevsoi)) + num_layer(1:nlevsoi) = 0 + + allocate(num_layer_columns(1:nlevsoi)) + num_layer_columns(1:nlevsoi) = 0 + + do c = clm_begc, clm_endc ! find out 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 + + if (col%hydrologically_active(c)) then + + if (.not. found(g)) then ! if the gridcell is not found before + + found(g) = .true. + + do j = 1,nlevsoi + ! 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 + ! 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 + + + found(clm_begg:clm_endg) = .false. + num_hactiveg_patch = 0 + num_hactivep = 0 + do p = clm_begp, clm_endp + c = patch%column(p) + g = col%gridcell(c) + + if ((exclude_greenland==0) .or. (.not.(lon(g)<330 .and. lon(g)>180 .and. lat(g)>55))) then + + if (col%hydrologically_active(c) .and. patch%active(p)) then + if (.not. found(g)) then ! if the gridcell is not found before + + found(g) = .true. + + num_hactiveg_patch = num_hactiveg_patch+1 + + end if + + num_hactivep = num_hactivep + 1 + + end if + + end if + + end do + + allocate(hactiveg_levels(1:num_hactiveg,1:nlevsoi)) + allocate(hactivec_levels(1:num_hactivec,1:nlevsoi)) + allocate(hactiveg_patch(1:num_hactiveg_patch)) + allocate(hactivep(1:num_hactivep)) + + ! 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 + + found(clm_begg:clm_endg) = .false. + fa = 0 + fg = 0 + do p = clm_begp, clm_endp + c = patch%column(p) + 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) .and. patch%active(p)) then + + if (.not. found(g)) then ! if the gridcell is not found before + found(g) = .true. + fg = fg+1 + hactiveg_patch(fg) = g + end if + + fa = fa+1 + hactivep(fa) = p + + end if + end if + + end do + + if (allocated(found)) deallocate(found) + + ! now lets find out the dimension of the state vector + + ! first h2osoi_liq and h2osoi_ice + clm_varsize_tws(:) = 0 + + clm_statevecsize = 0 + + select case (state_setup) + case(0) + 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) = clm_varsize_tws(2) + num_layer(j) + clm_statevecsize = clm_statevecsize + num_layer(j) + 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) = num_hactiveg_patch + clm_statevecsize = clm_statevecsize + num_hactiveg_patch + + case(1) + + 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 + 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) = num_hactiveg_patch + clm_statevecsize = clm_statevecsize + num_hactiveg_patch + + case(2) + + 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(3) ! only sum over all soil layers and snow in state vector, maybe I will add other compartments too + + clm_varsize_tws(1) = num_layer(1) + clm_statevecsize = clm_statevecsize + num_layer(1) + clm_varsize_tws(2) = 0 + + ! snow + clm_varsize_tws(3) = num_layer(1) + clm_statevecsize = clm_statevecsize + num_layer(1) + clm_varsize_tws(4) = 0 + clm_varsize_tws(5) = 0 + + case(4) ! sum over upper layer (1-7), sum over bottom layers (8-nlevsoi), snow + + clm_varsize_tws(1) = num_layer(1) + clm_statevecsize = clm_statevecsize + num_layer(1) + clm_varsize_tws(2) = num_layer(8) + clm_statevecsize = clm_statevecsize + num_layer(8) + + ! snow + clm_varsize_tws(3) = num_layer(1) + clm_statevecsize = clm_statevecsize + num_layer(1) + clm_varsize_tws(4) = 0 + clm_varsize_tws(5) = 0 + + case(5) ! one variable for surface soil moisture (upper 10 cm), one for root zone soil moisture (until 200 cm), one for everything underneath and one for snow + + ! upper three layers for surface soil moisture (layer three is in a depth of 9 cm) + + clm_varsize_tws(1) = num_layer(1) + clm_statevecsize = clm_statevecsize + num_layer(1) + + ! layer 4 to 12 for root zone soil moisture (layer 12 is in a depth of 208 cm) + + clm_varsize_tws(2) = num_layer(4) + clm_statevecsize = clm_statevecsize + num_layer(4) + + ! layer 13 to 20 for deep soil moisture + + clm_varsize_tws(3) = num_layer(13) + clm_statevecsize = clm_statevecsize + num_layer(13) + + ! one variable for snow --> caution !!! normally snow is var 3, now it is var 4!!! + + clm_varsize_tws(4) = num_layer(1) + clm_statevecsize = clm_statevecsize + num_layer(1) + + end select + + + end if + #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 @@ -310,7 +623,7 @@ subroutine define_clm_statevec(mype) !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 + if ((clmupdate_swc/=0) .or. (clmupdate_T/=0) .or. (clmupdate_texture/=0) .or. (clmupdate_tws==1)) then !hcp added condition allocate(clm_statevec(clm_statevecsize)) end if @@ -323,6 +636,14 @@ subroutine define_clm_statevec(mype) allocate(clm_statevec_orig(clm_statevecsize)) end if + if (clmupdate_tws==1) then + IF (allocated(clm_statevec_original_input)) deallocate(clm_statevec_original_input) + allocate(clm_statevec_original_input(1:clm_statevecsize)) + + IF (allocated(gridcell_state)) deallocate(gridcell_state) + allocate(gridcell_state(1:clm_statevecsize)) + end if + !write(*,*) 'clm_paramsize is ',clm_paramsize if (allocated(clm_paramarr)) deallocate(clm_paramarr) !hcp if ((clmupdate_T/=0)) then !hcp @@ -340,6 +661,8 @@ 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_original_input)) deallocate(clm_statevec_original_input) + IF (allocated(gridcell_state)) deallocate(gridcell_state) end subroutine cleanup_clm_statevec @@ -349,6 +672,10 @@ subroutine set_clm_statevec(tstartcycle, mype) ! use clm_varcon, only: nameg, namec ! use GetGlobalValuesMod, only: GetGlobalWrite use ColumnType , only : col + use PatchType, only: patch + use GridcellType, only: grc + use clm_varcon, only: spval + use clm_varctl, only: inst_suffix use shr_kind_mod, only: r8 => shr_kind_r8 implicit none integer,intent(in) :: tstartcycle @@ -357,11 +684,37 @@ subroutine set_clm_statevec(tstartcycle, mype) real(r8), pointer :: psand(:,:) real(r8), pointer :: pclay(:,:) real(r8), pointer :: porgm(:,:) + real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) + real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2) + real(r8), pointer :: h2osno(:) ! snow water (mm) + real(r8), pointer :: h2osfc(:) ! surface water + real(r8), pointer :: h2ocan(:) ! canopy water + real(r8), pointer :: TWS(:) + + real(r8), pointer :: lon(:) + real(r8), pointer :: lat(:) + + real(r8), pointer :: tws_state(:) + real(r8), pointer :: h2osoi_liq_state(:,:) + real(r8), pointer :: h2osoi_ice_state(:,:) + real(r8), pointer :: h2osno_state(:) + + real(r8), pointer :: watsat(:,:) + integer :: i,j,jj,g,c,cc,offset integer :: n_c character (len = 34) :: fn !TSMP-PDAF: function name for state vector output character (len = 34) :: fn2 !TSMP-PDAF: function name for swc output + integer :: count,count_columns, count_patch, p, l, k + real(r8) :: avg_sum + real(r8) :: avg_sum_ice + real(r8) :: avg_sum_patch + integer :: avg_divide + integer :: avg_divide_patch + + character (len = 110) :: filename_temp + cc = 0 offset = 0 @@ -370,6 +723,18 @@ subroutine set_clm_statevec(tstartcycle, mype) pclay => soilstate_inst%cellclay_col porgm => soilstate_inst%cellorg_col + TWS => waterstate_inst%tws_hactive + + tws_state => waterstate_inst%tws_state_before + h2osoi_liq_state => waterstate_inst%h2osoi_liq_state_before + h2osoi_ice_state => waterstate_inst%h2osoi_ice_state_before + h2osno_state => waterstate_inst%h2osno_state_before + + lon => grc%londeg + lat => grc%latdeg + + watsat => soilstate_inst%watsat_col + #ifdef PDAF_DEBUG IF(clmt_printensemble == tstartcycle + 1 .OR. clmt_printensemble < 0) THEN @@ -384,6 +749,31 @@ subroutine set_clm_statevec(tstartcycle, mype) END IF #endif + select case (TWS_smoother) + case(0) + + !print*, 'instanteneous values in statevector' + + h2osoi_liq => waterstate_inst%h2osoi_liq_col + h2osoi_ice => waterstate_inst%h2osoi_ice_col + h2osno => waterstate_inst%h2osno_col + h2osfc => waterstate_inst%h2osfc_col + h2ocan => waterstate_inst%h2ocan_patch + TWS => waterstate_inst%tws_hactive + + case default + + !print*, 'mean values over one month in statevector' + + h2osoi_liq => waterstate_inst%h2osoi_liq_col_mean + h2osoi_ice => waterstate_inst%h2osoi_ice_col_mean + h2osno => waterstate_inst%h2osno_col_mean + h2osfc => waterstate_inst%h2osfc_col_mean + h2ocan => waterstate_inst%h2ocan_patch_mean + TWS => waterstate_inst%tws_hactive_mean + + end select + ! calculate shift when CRP data are assimilated if(clmupdate_swc==2) then error stop "Not implemented clmupdate_swc.eq.2" @@ -465,287 +855,3116 @@ subroutine set_clm_statevec(tstartcycle, mype) 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 - end subroutine set_clm_statevec + if (clmupdate_tws==1) then - 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 + if (remove_mean==1) then + + if (.not. allocated(tws_temp_mean_vector)) then + + do j = 1,100 + filename_temp(j:j) = mean_filename(j) + end do + filename_temp = trim(filename_temp) + call read_temp_mean_model(filename_temp) + + + if (allocated(tws_temp_mean_vector)) DEALLOCATE(tws_temp_mean_vector) + ALLOCATE(tws_temp_mean_vector(clm_begg:clm_endg)) + tws_temp_mean_vector(:) = spval + + !this process only need the sub domain information + do j = clm_begg,clm_endg + ! find lon and lat in the file that corresponds to that of the grid point of the sub process + 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_vector(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(lon_temp_mean) + deallocate(lat_temp_mean) + deallocate(tws_temp_mean) + + end if + + end if + + select case (state_setup) + + case(0) ! all compartments, liq and ice water indidually + + if (inst_suffix=='_0000' .and. clm_begc==1) then + print*, "Filling up state vector with all compartments, liq and ice water indidually" + end if + + cc = 1 + + do j = 1,nlevsoi + + do count = 1, num_layer(j) + + g = hactiveg_levels(count,j) + + avg_sum = 0 + avg_sum_ice = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + avg_sum_ice = avg_sum_ice + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + + end if + + end do + + clm_statevec(cc) = avg_sum/avg_divide + clm_statevec(cc+clm_varsize_tws(1)) = avg_sum_ice/avg_divide + + clm_statevec_original_input(cc) = avg_sum/avg_divide + clm_statevec_original_input(cc+clm_varsize_tws(1)) = avg_sum_ice/avg_divide + + gridcell_state(cc) = g + gridcell_state(cc+clm_varsize_tws(1)) = g + + h2osoi_liq_state(g,j) = clm_statevec(cc) + h2osoi_ice_state(g,j) = clm_statevec(cc+clm_varsize_tws(1)) + + avg_sum = 0 + avg_divide = 0 + if (j==1) then + ! snow + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(j) + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osno(c) + + avg_divide = avg_divide+1 + + + end if + + end do + + clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = avg_sum/avg_divide + clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = avg_sum/avg_divide + + gridcell_state(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = g + + h2osno_state(g) = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) + + ! surface water + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(j) + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osfc(c) + + avg_divide = avg_divide+1 + + + end if + + end do + + clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) = avg_sum/avg_divide + clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) = avg_sum/avg_divide + + gridcell_state(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) = g + + end if + + cc = cc+1 + + end do + end do + + + + case(1) ! all compartments, sum of ice and liq soil water to overcome balancing errors due to different partitioning of water caused by different temperature + + if (inst_suffix=='_0000' .and. clm_begc==1) then + print*, "Filling up state vector with all compartments, sum of liq and ice" + end if + + cc = 1 + + do j = 1,nlevsoi + + do count = 1, num_layer(j) + + g = hactiveg_levels(count,j) + + avg_sum = 0 + avg_sum_ice = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + clm_statevec(cc) = avg_sum/avg_divide + clm_statevec_original_input(cc) = avg_sum/avg_divide + + gridcell_state(cc) = g + + h2osoi_liq_state(g,j) = clm_statevec(cc) + + avg_sum = 0 + avg_divide = 0 + if (j==1) then + ! snow + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(j) + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osno(c) + + avg_divide = avg_divide+1 + + + end if + + end do + + clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = avg_sum/avg_divide + clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = avg_sum/avg_divide + + gridcell_state(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = g + + h2osno_state(g) = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) + + ! surface water + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(j) + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osfc(c) + + avg_divide = avg_divide+1 + + + end if + + end do + + clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) = avg_sum/avg_divide + clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) = avg_sum/avg_divide + + gridcell_state(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) = g + + end if + + cc = cc+1 + + end do + end do + + + + case(2) ! only TWS in statevector + + if (inst_suffix=='_0000' .and. clm_begc==1) then + print*, "Filling up state vector with TWS" + end if + + cc = 1 + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + if (remove_mean==0) then + + clm_statevec(cc) = TWS(g) + clm_statevec_original_input(cc) = TWS(g) + + else + + clm_statevec(cc) = TWS(g)-tws_temp_mean_vector(g) + clm_statevec_original_input(cc) = TWS(g)-tws_temp_mean_vector(g) + + end if + + gridcell_state(cc) = g + + tws_state(g) = clm_statevec(cc) + + cc = cc+1 + + end do + + case(3) ! sum over all soil layers and snow in statevector + + if (inst_suffix=='_0000' .and. clm_begc==1) then + print*, "Filling up state vector with sum over all soil layers and snow" + end if + + cc = 1 + + do count = 1, num_layer(1) + + clm_statevec(cc) = 0 + + g = hactiveg_levels(count,1) + + do j = 1, nlevsoi + + avg_sum = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + if (avg_divide/=0) then + + clm_statevec(cc) = clm_statevec(cc) + avg_sum/avg_divide + + end if + + end do + + clm_statevec_original_input(cc) = clm_statevec(cc) + h2osoi_liq_state(g,1) = clm_statevec(cc) + + cc = cc + 1 + + end do + + + ! snow + + cc = 1 + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(1) + c = hactivec_levels(count_columns,1) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osno(c) + + avg_divide = avg_divide+1 + + + end if + + end do + + clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = avg_sum/avg_divide + clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = avg_sum/avg_divide + + h2osno_state(g) = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) + + + cc = cc+1 + + + end do + + + case(4) ! sum of liq and ice water in the upper layers (1-7, until some gridcells have first bedrock layer in depth 8), sum underneath and snow in state vector + + if (inst_suffix=='_0000' .and. clm_begc==1) then + print*, "Filling up state vector with sum in the upper layers, sum underneath and snow" + end if + + cc = 1 + + do count = 1, num_layer(1) + + clm_statevec(cc) = 0 + + g = hactiveg_levels(count,1) + + do j = 1, 7 + + avg_sum = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + if (avg_divide/=0) then + + clm_statevec(cc) = clm_statevec(cc) + avg_sum/avg_divide + + end if + + end do + + clm_statevec_original_input(cc) = clm_statevec(cc) + h2osoi_liq_state(g,1) = clm_statevec(cc) + + cc = cc + 1 + + end do + + cc = 1 + + do count = 1, num_layer(8) + + clm_statevec(cc+clm_varsize_tws(1)) = 0 + + g = hactiveg_levels(count,8) + + do j = 8, nlevsoi + + avg_sum = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + if (avg_divide/=0) then + + clm_statevec(cc+clm_varsize_tws(1)) = clm_statevec(cc+clm_varsize_tws(1)) + avg_sum/avg_divide + + end if + + end do + + clm_statevec_original_input(cc+clm_varsize_tws(1)) = clm_statevec(cc+clm_varsize_tws(1)) + h2osoi_liq_state(g,2) = clm_statevec(cc+clm_varsize_tws(1)) + + cc = cc + 1 + + end do + + ! snow + + cc = 1 + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(1) + c = hactivec_levels(count_columns,1) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osno(c) + + avg_divide = avg_divide+1 + + + end if + + end do + + clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = avg_sum/avg_divide + clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = avg_sum/avg_divide + + h2osno_state(g) = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) + + + cc = cc+1 + + + end do + + case(5) ! sum of liq and ice water in surface soil mositure (1-3), root zone (4-12), sum underneath (13-20) and snow in state vector + + if (inst_suffix=='_0000' .and. clm_begc==1) then + print*, "Filling up state vector with sum over surface, root zone, 'groundwater', snow" + end if + + cc = 1 + + do count = 1, num_layer(1) + + clm_statevec(cc) = 0 + + g = hactiveg_levels(count,1) + + do j = 1, 3 + + avg_sum = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + if (avg_divide/=0) then + + clm_statevec(cc) = clm_statevec(cc) + avg_sum/avg_divide + + end if + + end do + + clm_statevec_original_input(cc) = clm_statevec(cc) + h2osoi_liq_state(g,1) = clm_statevec(cc) + + cc = cc + 1 + + end do + + cc = 1 + + 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 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + if (avg_divide/=0) then + + clm_statevec(cc+clm_varsize_tws(1)) = clm_statevec(cc+clm_varsize_tws(1)) + avg_sum/avg_divide + + end if + + end do + + clm_statevec_original_input(cc+clm_varsize_tws(1)) = clm_statevec(cc+clm_varsize_tws(1)) + h2osoi_liq_state(g,2) = clm_statevec(cc+clm_varsize_tws(1)) + + cc = cc + 1 + + end do + + cc = 1 + + do count = 1, num_layer(13) + + clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = 0 + + g = hactiveg_levels(count,13) + + do j = 13, nlevsoi + + avg_sum = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + if (avg_divide/=0) then + + clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) + avg_sum/avg_divide + + end if + + end do + + clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) + h2osoi_liq_state(g,3) = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) + + cc = cc + 1 + + end do + + + ! snow + + cc = 1 + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(1) + c = hactivec_levels(count_columns,1) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osno(c) + + avg_divide = avg_divide+1 + + + end if + + end do + + clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) = avg_sum/avg_divide + clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) = avg_sum/avg_divide + + h2osno_state(g) = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) + + + cc = cc+1 + + + end do + + end select + + + 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 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 + + 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 + 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 + IF(clmt_printensemble == tstartcycle .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, ".update.", tstartcycle, ".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 + + 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 + ! 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") + WRITE (71,"(es22.15)") h2osoi_liq(:,:) + CLOSE(71) + + ! TSMP-PDAF: For debug runs, output the state vector in files + WRITE(fn6, "(a,i5.5,a,i5.5,a)") "h2osoi_ice", mype, ".bef_up.", tstartcycle, ".txt" + OPEN(unit=71, file=fn6, action="write") + WRITE (71,"(es22.15)") h2osoi_ice(:,:) + CLOSE(71) + END IF + + END IF +#endif + + ! calculate shift when CRP data are assimilated + if(clmupdate_swc==2) then + error stop "Not implemented: clmupdate_swc.eq.2" + endif + + ! CLM5: Update the Data Assimulation time-step to the current time + ! step, since DA has been done. Used by CLM5 to skip BalanceChecks + ! directly after the DA step. + call update_DA_nstep() + + ! write updated swc back to CLM + if(clmupdate_swc/=0) then + + ! Set minimum soil moisture for checking the state vector and + ! for setting minimum swc for CLM + if(clmwatmin_switch==3) then + ! CLM3.5 type watmin + watmin_check = 0.00 + watmin_set = 0.05 + else if(clmwatmin_switch==5) then + ! CLM5.0 type watmin + watmin_check = watmin + watmin_set = watmin + else + ! Default + watmin_check = 0.0 + watmin_set = 0.0 + end if + + ! cc = 0 + do i=1,nlevsoi + ! CLM3.5: iterate over grid cells + ! CLM5.0: iterate over columns + ! 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(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 + + 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) + + ! 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 + + 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 + + !! 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 + + ! 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) + end if + cc = cc + 1 + end do + end do + call clm_correct_texture + call clm_texture_to_parameters + endif + + if (clmupdate_tws==1) then + + call clm_update_tws + + end if + + end subroutine update_clm + + subroutine clm_update_tws() + use clm_instMod, only: waterstate_inst + use clm_instMod, only: soilstate_inst + use clm_instMod, only: atm2lnd_inst + use clm_varpar , only : nlevsoi, nlevsno + use shr_kind_mod, only: r8 => shr_kind_r8 + use clm_varcon, only: spval, watmin, denh2o, denice, averaging_var + use ColumnType , only : col + use LandunitType, only: lun + use clm_varctl, only: inst_suffix + implicit none + + integer, pointer :: snl(:) ! negative number of snow layers + real(r8), pointer :: h2osno(:) ! snow water (mm) + real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) + real(r8), pointer :: h2osoi_vol(:,:) + + real(r8), pointer :: TWS(:) + + real(r8), pointer :: h2osoi_liq_mean(:,:) ! liquid water (kg/m2) + real(r8), pointer :: h2osoi_ice_mean(:,:) ! ice lens (kg/m2) + real(r8), pointer :: h2osno_mean(:) ! snow water (mm) + + real(r8), pointer :: h2osoi_liq_inc(:,:) ! liquid water (kg/m2) + real(r8), pointer :: h2osoi_ice_inc(:,:) ! ice lens (kg/m2) + + real(r8), pointer :: h2osno_inc(:) ! snow water (mm) + real(r8), pointer :: snow_depth(:) ! snow water (mm) + real(r8), pointer :: dz(:,:) ! snow water (mm) + real(r8), pointer :: zi(:,:) ! snow water (mm) + real(r8), pointer :: z(:,:) ! snow water (mm) + + real(r8), pointer :: watsat(:,:) + + real(r8), pointer :: forc_t(:) + + real(r8), pointer :: forc_wind(:) + + real(r8), pointer :: frac_iceold(:,:) + + real(r8), pointer :: tws_state(:) + + real(r8), pointer :: h2osoi_liq_state(:,:) + real(r8), pointer :: h2osoi_ice_state(:,:) + real(r8), pointer :: h2osno_state(:) + + + + ! Local variables: + integer :: c, j, fc,cc, l,p,g, temp, count, count_columns ! indices + real(r8) :: inc, var_temp, inc_1, inc_2, inc_col, ratio, inc_ice !increment + + real(r8) :: scale + + real(r8) :: rsnow(clm_begc:clm_endc) + real(r8) :: snowden, frac_swe, frac_liq, frac_ice + real(r8) :: gain_h2osno, gain_h2oliq, gain_h2oice, gain_dzsno + + real(r8) :: t_for_bifall_degC ! temperature to use in bifall equation (deg C) + real(r8) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + + + real(r8) :: avg_sum + real(r8) :: avg_sum_ice + real(r8) :: avg_sum_patch + integer :: avg_divide + integer :: avg_divide_patch + + real(r8) :: mult_liq(clm_begc:clm_endc) + real(r8) :: mult_ice(clm_begc:clm_endc) + + real(r8) :: lok_liq(clm_begc:clm_endc,1:nlevsoi) + real(r8) :: lok_ice(clm_begc:clm_endc,1:nlevsoi) + real(r8) :: lok_vol(clm_begc:clm_endc,1:nlevsoi) + + + select case (TWS_smoother) + case(0) + h2osoi_liq_mean => waterstate_inst%h2osoi_liq_col + h2osoi_ice_mean => waterstate_inst%h2osoi_ice_col + h2osno_mean => waterstate_inst%h2osno_col + case default + h2osoi_liq_mean => waterstate_inst%h2osoi_liq_col_mean + h2osoi_ice_mean => waterstate_inst%h2osoi_ice_col_mean + h2osno_mean => waterstate_inst%h2osno_col_mean + end select + + h2osoi_liq => waterstate_inst%h2osoi_liq_col + h2osoi_ice => waterstate_inst%h2osoi_ice_col + h2osno => waterstate_inst%h2osno_col + snl => col%snl + dz => col%dz + zi => col%zi + z => col%z + snow_depth => waterstate_inst%snow_depth_col + h2osoi_vol => waterstate_inst%h2osoi_vol_col + watsat => soilstate_inst%watsat_col + + h2osoi_liq_inc => waterstate_inst%h2osoi_liq_col_inc + h2osoi_ice_inc => waterstate_inst%h2osoi_ice_col_inc + h2osno_inc => waterstate_inst%h2osno_col_inc + + forc_t => atm2lnd_inst%forc_t_downscaled_col ! atmospheric temperature (Kelvin) + forc_wind => atm2lnd_inst%forc_wind_grc ! atmospheric wind speed (m/s) + frac_iceold => waterstate_inst%frac_iceold_col ! fraction of ice relative to the tot water + + TWS => waterstate_inst%tws_hactive + + tws_state => waterstate_inst%tws_state_after + + h2osoi_liq_state => waterstate_inst%h2osoi_liq_state_after + h2osoi_ice_state => waterstate_inst%h2osoi_ice_state_after + h2osno_state => waterstate_inst%h2osno_state_after + + + ! now all variables are updated. Restrictions have to be introduced to ensure that the model is still running correctly + + ! set averaging factor to zero + averaging_var = 0 + + do j = 1,nlevsoi + do count = 1,num_layer_columns(j) + c = hactivec_levels(count,j) + + h2osoi_liq_inc(c,j) = h2osoi_liq(c,j) + h2osoi_ice_inc(c,j) = h2osoi_ice(c,j) + + if (j==1) then + h2osno_inc(c) = h2osno(c) + end if + end do + end do + + + + cc = 1 + + if (state_setup==0 .or. state_setup==1) then + + do j = 1,nlevsoi + + do count = 1, num_layer(j) + + g = hactiveg_levels(count,j) + + inc = clm_statevec(cc)-clm_statevec_original_input(cc) + + if (abs(inc)>1.e-10_r8) then + + if (state_setup==0) then + inc_ice = clm_statevec(cc+clm_varsize_tws(1)) + end if + + do count_columns = 1, num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (col%gridcell(c)==g) then + + select case(state_setup) + case(0) + + inc_col = inc + + if (inc_col/=inc_col) then + inc_col = 0.0 + end if + + ! if increment larger than maximal increment, adjust it to maximal increment with the sign of old increment + ! so that the direction of the increment is right + if (abs(inc_col)>max_inc*h2osoi_liq(c,j)) then + inc_col = sign(max_inc*h2osoi_liq(c,j),inc_col) + end if + + h2osoi_liq(c,j) = h2osoi_liq(c,j) + inc_col + + if (h2osoi_liq(c,j)max_inc*h2osoi_ice(c,j)) then + inc_col = sign(max_inc*h2osoi_ice(c,j),inc_col) + end if + + h2osoi_ice(c,j) = h2osoi_ice(c,j) + inc_col + + if (h2osoi_ice(c,j)<0) then + h2osoi_ice(c,j) = 0._r8 + end if + + case(1) + + inc_col = inc + + var_temp = h2osoi_liq(c,j)+h2osoi_ice(c,j) + + if (abs(inc_col)>max_inc*var_temp) then + inc_col = sign(max_inc*var_temp,inc_col) + end if + + inc_1 = inc_col*(h2osoi_liq(c,j)/var_temp) + + h2osoi_liq(c,j) = h2osoi_liq(c,j)+inc_1 + + if (h2osoi_liq(c,j)0.00001 .and. j>1) then + + if (h2osoi_ice(c,j) == 0) then + + h2osoi_liq(c,j) = h2osoi_vol(c,j)*dz(c,j)*denh2o + + else + + var_temp = watsat(c,j) / h2osoi_vol(c,j) + + h2osoi_liq(c,j) = h2osoi_liq(c,j)*var_temp + + if (h2osoi_liq(c,j) < watmin) then + h2osoi_liq(c,j) = watmin + end if + + h2osoi_ice(c,j) = (watsat(c,j)*dz(c,j)*denice)-h2osoi_liq(c,j)*denice/denh2o + + end if + + h2osoi_vol(c,j) = watsat(c,j) + + end if + + 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+clm_varsize_tws(1)+clm_varsize_tws(2)) - clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) ! save increment for gridcell + + if (abs(inc)>1.e-10_r8) then + + do count_columns = 1, num_layer_columns(1) + + c = hactivec_levels(count_columns,1) + + if (col%gridcell(c)==g) then + + !ratio = h2osno_mean(c)/clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) ! ratio of column value to averaged gridcell value (input in state vector) + !inc_col = inc*ratio - h2osno_mean(c) ! increment of column is then the gridcell increment scaled with this ratio + inc_col = inc + + if (inc_col/=inc_col) then + inc_col = 0.0 + end if + + if (abs(inc_col)>500) then + inc_col = sign(500._r8,inc_col) + end if + + select case (update_snow) + ! Tests with snow DA, scripts adapted from Lukas Strebel + case(0) + + if (inc_col/=0._r8) then + + if (snl(c) < 0) then ! snow layers in the column + + h2osno(c) = h2osno(c) + inc_col + + if (h2osno(c)>10000) then + h2osno(c) = 10000 + end if + + do j=0,snl(c)+1,-1 ! iterate through the snow layers + + ! snow density prior for each layer + if (dz(c,j)>0.0_r8) then + snowden = (h2osoi_liq(c,j) + h2osoi_ice(c,j)) / dz(c,j) + else + snowden = 0.0_r8 + endif + + ! fraction of SWE in each active layers + if(rsnow(c)>0.0_r8) then + frac_swe = (h2osoi_liq(c,j) + h2osoi_ice(c,j)) / rsnow(c) + else + frac_swe = 0.0_r8 ! no fraction SWE if no snow is present in column + end if ! end SWE fraction if + + ! fraction of liquid and ice + if ((h2osoi_liq(c,j) + h2osoi_ice(c,j))>0.0_r8) then + frac_liq = h2osoi_liq(c,j) / (h2osoi_liq(c,j) + h2osoi_ice(c,j)) + frac_ice = 1.0_r8 - frac_liq + else + frac_liq = 0.0_r8 + frac_ice = 0.0_r8 + end if + + ! SWE adjustment per layer + ! assumes identical layer distribution of liq and ice than before DA (frac_*) + gain_h2osno = (h2osno(c) - rsnow(c)) * frac_swe + gain_h2oliq = gain_h2osno * frac_liq + gain_h2oice = gain_h2osno * frac_ice + + ! layer level adjustments + if (snowden>0.0_r8) then + gain_dzsno = gain_h2osno / snowden + else + gain_dzsno = 0.0_r8 + end if + h2osoi_liq(c,j) = h2osoi_liq(c,j) + gain_h2oliq + h2osoi_ice(c,j) = h2osoi_ice(c,j) + gain_h2oice + + + ! Adjust snow layer dimensions so that CLM5 can calculate compaction / aggregation + ! in the DART code dzsno is adjusted directly but in CLM5 dzsno is local and diagnostic + ! i.e. calculated / assigned from frac_sno and dz(:, snow_layer) in SnowHydrologyMod + ! therefore we adjust dz(:, snow_layer) here + + dz(c,j) = dz(c,j) + gain_dzsno + ! mid point and interface adjustments + ! i.e. zsno (col%z(:, snow_layers)) and zisno (col%zi(:, snow_layers)) + ! DART version the sum goes from ilevel:nlevsno to fit with our indexing: + zi(c,j-1) = sum(dz(c,j:0))*-1.0_r8 + ! In DART the check is ilevel == nlevsno but here + + if (j==0) then + z(c,j) = zi(c,j-1) / 2.0_r8 + else + z(c,j) = sum(zi(c,j-1:j)) / 2.0_r8 + end if + + + end do + + ! Update the total snow depth to match updates to layers for active snow layers + snow_depth(c) = sum(dz(c,snl(c)+1:0)) + h2osno(c) = sum(h2osoi_ice(c,snl(c)+1:0)+h2osoi_liq(c,snl(c)+1:0)) + + end if + + end if + + case (1) !update with factor of old and new snow + + if (snl(c) < 0) then ! snow layers in the column + + ! if (inc_col>1000._r8) then + ! inc_col = 1000._r8 + ! end if + + inc_col = h2osno(c)+inc_col + + if (inc_col>10000) then + inc_col = 10000 + end if + + scale = inc_col/h2osno(c) + h2osno(c) = inc_col + + do j=0,snl(c)+1,-1 + h2osoi_liq(c,j) = h2osoi_liq(c,j)*scale + h2osoi_ice(c,j) = h2osoi_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 if + + end select + + ! snow negative + if (h2osno(c) < 0._r8) then + if (snl(c)<0) then + + do j=0,snl(c)+1,-1 + h2osoi_liq(c,j) = 0.0_r8 + h2osoi_ice(c,j) = 0.00000001_r8 + dz(c,j) = 0.00000001_r8 + zi(c,j-1) = sum(dz(c,j:0))*-1.0_r8 + if (j==0) then + z(c,j) = zi(c,j-1) / 2.0_r8 + else + z(c,j) = sum(zi(c,j-1:j)) / 2.0_r8 + end if + end do + + else + + h2osoi_liq(c,0) = 0.0_r8 + h2osoi_ice(c,0) = 0.00000001_r8 + dz(c,0) = 0.00000001_r8 + zi(c,-1) = dz(c,0)*-1.0_r8 + z(c,0) = zi(c,-1) / 2.0_r8 + + end if + + snow_depth(c) = sum(dz(c,-nlevsno+1:0)) + h2osno(c) = sum(h2osoi_ice(c,-nlevsno+1:0)) + end if + + end if + + end do + + end if + + cc = cc+1 + + end do + + + + + elseif (state_setup==2) then + + cc = 1 + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + inc = clm_statevec(cc)-clm_statevec_original_input(cc) + + if (abs(inc)>1.e-10_r8) then + + ! update soil water + do j = 1,nlevsoi + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (col%gridcell(c)==g) then + + inc_col = inc*h2osoi_liq_mean(c,j)/clm_statevec_original_input(cc) + + if (inc_col/=inc_col) then + inc_col = 0.0 + end if + + ! if increment larger than maximal increment, adjust it to maximal increment with the sign of old increment + ! so that the direction of the increment is right + if (abs(inc_col)>max_inc*h2osoi_liq(c,j)) then + inc_col = sign(max_inc*h2osoi_liq(c,j),inc_col) + end if + + h2osoi_liq(c,j) = h2osoi_liq(c,j) + inc_col + + if (h2osoi_liq(c,j)max_inc*h2osoi_ice(c,j)) then + inc_col = sign(max_inc*h2osoi_ice(c,j),inc_col) + end if + + h2osoi_ice(c,j) = h2osoi_ice(c,j) + inc_col + + if (h2osoi_ice(c,j)<0) then + h2osoi_ice(c,j) = 0._r8 + end if + + + + h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) + + if (j>1 .and. h2osoi_vol(c,j)-watsat(c,j)>0.000001) then + + var_temp = watsat(c,j) / h2osoi_vol(c,j) + + h2osoi_liq(c,j) = h2osoi_liq(c,j)*var_temp + + if (h2osoi_liq(c,j) < watmin) then + h2osoi_liq(c,j) = watmin + end if + + h2osoi_ice(c,j) = (watsat(c,j)*dz(c,j)*denice)-h2osoi_liq(c,j)*denice/denh2o + if (abs(h2osoi_ice(c,j))<1.e-10_r8) then !numerics, if h2osoiice was zero before, it is -something e-16 after the previous calculation, so something marginal negative + h2osoi_ice(c,j) = 0._r8 + end if + + h2osoi_vol(c,j) = watsat(c,j) + + end if + + end if + + end do + + end do + + ! update snow + + do count_columns = 1,num_layer_columns(1) + + c = hactivec_levels(count_columns,1) + + if (col%gridcell(c)==g) then + + inc_col = inc*h2osno_mean(c)/clm_statevec_original_input(cc) + + if (abs(inc_col)>500) then + inc_col = sign(500._r8,inc_col) + end if + + if (inc_col/=inc_col) then + inc_col = 0.0 + end if + + if (snl(c) < 0) then ! snow layers in the column + + inc_col = h2osno(c)+inc_col + + if (inc_col>10000) then + inc_col = 10000 + end if + + scale = inc_col/h2osno(c) + h2osno(c) = inc_col + + do j=0,snl(c)+1,-1 + h2osoi_liq(c,j) = h2osoi_liq(c,j)*scale + h2osoi_ice(c,j) = h2osoi_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 if + + ! snow negative + if (h2osno(c) < 0._r8) then + if (snl(c)<0) then + + do j=0,snl(c)+1,-1 + h2osoi_liq(c,j) = 0.0_r8 + h2osoi_ice(c,j) = 0.00000001_r8 + dz(c,j) = 0.00000001_r8 + zi(c,j-1) = sum(dz(c,j:0))*-1.0_r8 + if (j==0) then + z(c,j) = zi(c,j-1) / 2.0_r8 + else + z(c,j) = sum(zi(c,j-1:j)) / 2.0_r8 + end if + end do + + else + + h2osoi_liq(c,0) = 0.0_r8 + h2osoi_ice(c,0) = 0.00000001_r8 + dz(c,0) = 0.00000001_r8 + zi(c,-1) = dz(c,0)*-1.0_r8 + z(c,0) = zi(c,-1) / 2.0_r8 + + end if + + snow_depth(c) = sum(dz(c,-nlevsno+1:0)) + h2osno(c) = sum(h2osoi_ice(c,-nlevsno+1:0)) + end if + + + end if + + end do + + end if + cc = cc+1 + + end do + + + + + elseif (state_setup==3) then + + ! ! soil water + cc = 1 + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + inc = clm_statevec(cc)-clm_statevec_original_input(cc) + + if (inc/=inc) then + inc = 0.0 + end if + + if (abs(inc)>1.e-10_r8) then + + ! update soil water + do j = 1,nlevsoi + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (col%gridcell(c)==g) then + + var_temp = h2osoi_liq(c,j)+h2osoi_ice(c,j) + + inc_col = inc*(h2osoi_liq_mean(c,j)+h2osoi_ice_mean(c,j))/clm_statevec_original_input(cc) + + if (abs(inc_col)>max_inc*var_temp) then + inc_col = sign(max_inc*var_temp,inc_col) + end if + + h2osoi_liq(c,j) = h2osoi_liq(c,j) + inc_col*(h2osoi_liq(c,j)/var_temp) + h2osoi_ice(c,j) = h2osoi_ice(c,j) + inc_col*(h2osoi_ice(c,j)/var_temp) + + if (h2osoi_liq(c,j)1 .and. h2osoi_vol(c,j)>watsat(c,j)) then + + var_temp = watsat(c,j) / h2osoi_vol(c,j) + + h2osoi_liq(c,j) = h2osoi_liq(c,j)*var_temp + + if (h2osoi_liq(c,j) < watmin) then + h2osoi_liq(c,j) = watmin + end if + + h2osoi_ice(c,j) = (watsat(c,j)*dz(c,j)*denice)-h2osoi_liq(c,j)*denice/denh2o + if (abs(h2osoi_ice(c,j))<1.e-10_r8) then !numerics, if h2osoiice was zero before, it is -something e-16 after the previous calculation, so something marginal negative + h2osoi_ice(c,j) = 0._r8 + end if + + h2osoi_vol(c,j) = watsat(c,j) + + end if + + end if + + end do + + end do + + end if + + cc = cc+1 + + end do + + ! ! snow + + ! cc = 1 + + ! do count = 1, num_layer(1) + + ! g = hactiveg_levels(count,1) + + ! inc = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) - clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) ! save increment for gridcell + + ! if (abs(inc)>1.e-10_r8) then + + ! do count_columns = 1, num_layer_columns(1) + + ! c = hactivec_levels(count_columns,1) + + ! if (col%gridcell(c)==g) then + + ! inc_col = inc*h2osno(c)/clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) + + ! if (inc_col/=inc_col) then + ! inc_col = 0.0 + ! end if + + ! select case (update_snow) + ! ! Tests with snow DA, scripts adapted from Lukas Strebel + ! case(0) + + ! if (inc_col.ne.0._r8) then + + ! if (snl(c) < 0) then ! snow layers in the column + + ! h2osno(c) = h2osno(c) + inc_col + + ! do j=0,snl(c)+1,-1 ! iterate through the snow layers + + ! ! snow density prior for each layer + ! if (dz(c,j)>0.0_r8) then + ! snowden = (h2osoi_liq(c,j) + h2osoi_ice(c,j)) / dz(c,j) + ! else + ! snowden = 0.0_r8 + ! endif + + ! ! fraction of SWE in each active layers + ! if(rsnow(c).gt.0.0_r8) then + ! frac_swe = (h2osoi_liq(c,j) + h2osoi_ice(c,j)) / rsnow(c) + ! else + ! frac_swe = 0.0_r8 ! no fraction SWE if no snow is present in column + ! end if ! end SWE fraction if + + ! ! fraction of liquid and ice + ! if ((h2osoi_liq(c,j) + h2osoi_ice(c,j)).gt.0.0_r8) then + ! frac_liq = h2osoi_liq(c,j) / (h2osoi_liq(c,j) + h2osoi_ice(c,j)) + ! frac_ice = 1.0_r8 - frac_liq + ! else + ! frac_liq = 0.0_r8 + ! frac_ice = 0.0_r8 + ! end if + + ! ! SWE adjustment per layer + ! ! assumes identical layer distribution of liq and ice than before DA (frac_*) + ! gain_h2osno = (h2osno(c) - rsnow(c)) * frac_swe + ! gain_h2oliq = gain_h2osno * frac_liq + ! gain_h2oice = gain_h2osno * frac_ice + + ! ! layer level adjustments + ! if (snowden.gt.0.0_r8) then + ! gain_dzsno = gain_h2osno / snowden + ! else + ! gain_dzsno = 0.0_r8 + ! end if + ! h2osoi_liq(c,j) = h2osoi_liq(c,j) + gain_h2oliq + ! h2osoi_ice(c,j) = h2osoi_ice(c,j) + gain_h2oice + + + ! ! Adjust snow layer dimensions so that CLM5 can calculate compaction / aggregation + ! ! in the DART code dzsno is adjusted directly but in CLM5 dzsno is local and diagnostic + ! ! i.e. calculated / assigned from frac_sno and dz(:, snow_layer) in SnowHydrologyMod + ! ! therefore we adjust dz(:, snow_layer) here + + ! dz(c,j) = dz(c,j) + gain_dzsno + ! ! mid point and interface adjustments + ! ! i.e. zsno (col%z(:, snow_layers)) and zisno (col%zi(:, snow_layers)) + ! ! DART version the sum goes from ilevel:nlevsno to fit with our indexing: + ! zi(c,j-1) = sum(dz(c,j:0))*-1.0_r8 + ! ! In DART the check is ilevel == nlevsno but here + + ! if (j.eq.0) then + ! z(c,j) = zi(c,j-1) / 2.0_r8 + ! else + ! z(c,j) = sum(zi(c,j-1:j)) / 2.0_r8 + ! end if + + + ! end do + + ! ! Update the total snow depth to match updates to layers for active snow layers + ! snow_depth(c) = sum(dz(c,snl(c)+1:0)) + ! h2osno(c) = sum(h2osoi_ice(c,snl(c)+1:0)+h2osoi_liq(c,snl(c)+1:0)) + + ! end if + + ! end if + + ! case (1) !update with factor of old and new snow + + ! if (snl(c) < 0) then ! snow layers in the column + + ! ! if (inc_col>1000._r8) then + ! ! inc_col = 1000._r8 + ! ! end if + + ! inc_col = h2osno(c)+inc_col + ! scale = inc_col/h2osno(c) + ! h2osno(c) = inc_col + + ! do j=0,snl(c)+1,-1 + ! h2osoi_liq(c,j) = h2osoi_liq(c,j)*scale + ! h2osoi_ice(c,j) = h2osoi_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 if + + ! end select + + ! ! snow negative + ! if (h2osno(c) < 0._r8) then + ! if (snl(c)<0) then + + ! do j=0,snl(c)+1,-1 + ! h2osoi_liq(c,j) = 0.0_r8 + ! h2osoi_ice(c,j) = 0.00000001_r8 + ! dz(c,j) = 0.00000001_r8 + ! zi(c,j-1) = sum(dz(c,j:0))*-1.0_r8 + ! if (j.eq.0) then + ! z(c,j) = zi(c,j-1) / 2.0_r8 + ! else + ! z(c,j) = sum(zi(c,j-1:j)) / 2.0_r8 + ! end if + ! end do + + ! else + + ! h2osoi_liq(c,0) = 0.0_r8 + ! h2osoi_ice(c,0) = 0.00000001_r8 + ! dz(c,0) = 0.00000001_r8 + ! zi(c,-1) = dz(c,0)*-1.0_r8 + ! z(c,0) = zi(c,-1) / 2.0_r8 + + ! end if + + ! snow_depth(c) = sum(dz(c,-nlevsno+1:0)) + ! h2osno(c) = sum(h2osoi_ice(c,-nlevsno+1:0)) + ! end if + + ! end if + + ! end do + + ! end if + + ! cc = cc+1 + + ! end do + + elseif (state_setup==4) then + + + ! soil water + + cc = 1 + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + inc = clm_statevec(cc)-clm_statevec_original_input(cc) + + if (abs(inc)>1.e-10_r8) then + + ! update soil water + do j = 1,7 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (col%gridcell(c)==g) then + + inc_col = inc*h2osoi_liq_mean(c,j)/clm_statevec_original_input(cc) + + if (inc_col/=inc_col) then + inc_col = 0.0 + end if + + ! if increment larger than maximal increment, adjust it to maximal increment with the sign of old increment + ! so that the direction of the increment is right + if (abs(inc_col)>max_inc*h2osoi_liq(c,j)) then + inc_col = sign(max_inc*h2osoi_liq(c,j),inc_col) + end if + + h2osoi_liq(c,j) = h2osoi_liq(c,j) + inc_col + + if (h2osoi_liq(c,j)max_inc*h2osoi_ice(c,j)) then + inc_col = sign(max_inc*h2osoi_ice(c,j),inc_col) + end if + + h2osoi_ice(c,j) = h2osoi_ice(c,j) + inc_col + + if (h2osoi_ice(c,j)<0) then + h2osoi_ice(c,j) = 0._r8 + end if + + + + h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) + + if (j>1 .and. h2osoi_vol(c,j)>watsat(c,j)) then + + var_temp = watsat(c,j) / h2osoi_vol(c,j) + + h2osoi_liq(c,j) = h2osoi_liq(c,j)*var_temp + + if (h2osoi_liq(c,j) < watmin) then + h2osoi_liq(c,j) = watmin + end if + + h2osoi_ice(c,j) = (watsat(c,j)*dz(c,j)*denice)-h2osoi_liq(c,j)*denice/denh2o + if (abs(h2osoi_ice(c,j))<1.e-10_r8) then !numerics, if h2osoiice was zero before, it is -something e-16 after the previous calculation, so something marginal negative + h2osoi_ice(c,j) = 0._r8 + end if + + h2osoi_vol(c,j) = watsat(c,j) + + end if + + end if + + end do + end do + + end if + + cc = cc+1 + + end do + + + + cc = 1 + + do count = 1, num_layer(8) + + g = hactiveg_levels(count,8) + + inc = clm_statevec(cc+clm_varsize_tws(1))-clm_statevec_original_input(cc+clm_varsize_tws(1)) + + if (abs(inc)>1.e-10_r8) then + + ! update soil water + do j = 8,nlevsoi + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (col%gridcell(c)==g) then + + inc_col = inc*h2osoi_liq_mean(c,j)/clm_statevec_original_input(cc+clm_varsize_tws(1)) + + if (inc_col/=inc_col) then + inc_col = 0.0 + end if + + ! if increment larger than maximal increment, adjust it to maximal increment with the sign of old increment + ! so that the direction of the increment is right + if (abs(inc_col)>max_inc*h2osoi_liq(c,j)) then + inc_col = sign(max_inc*h2osoi_liq(c,j),inc_col) + end if + + h2osoi_liq(c,j) = h2osoi_liq(c,j) + inc_col + + if (h2osoi_liq(c,j)max_inc*h2osoi_ice(c,j)) then + inc_col = sign(max_inc*h2osoi_ice(c,j),inc_col) + end if + + h2osoi_ice(c,j) = h2osoi_ice(c,j) + inc_col + + if (h2osoi_ice(c,j)<0) then + h2osoi_ice(c,j) = 0._r8 + end if + + + + h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) + + if (j>1 .and. h2osoi_vol(c,j)>watsat(c,j)) then + + var_temp = watsat(c,j) / h2osoi_vol(c,j) + + h2osoi_liq(c,j) = h2osoi_liq(c,j)*var_temp + + if (h2osoi_liq(c,j) < watmin) then + h2osoi_liq(c,j) = watmin + end if + + h2osoi_ice(c,j) = (watsat(c,j)*dz(c,j)*denice)-h2osoi_liq(c,j)*denice/denh2o + if (abs(h2osoi_ice(c,j))<1.e-10_r8) then !numerics, if h2osoiice was zero before, it is -something e-16 after the previous calculation, so something marginal negative + h2osoi_ice(c,j) = 0._r8 + end if + + h2osoi_vol(c,j) = watsat(c,j) + + end if + + end if + + end do + end do + + end if + + cc = cc+1 + + end do + + + + ! snow + + cc = 1 + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + inc = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) - clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) ! save increment for gridcell + + if (abs(inc)>1.e-10_r8) then + + do count_columns = 1, num_layer_columns(1) + + c = hactivec_levels(count_columns,1) + + if (col%gridcell(c)==g) then + + inc_col = inc*h2osno_mean(c)/clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) + + if (inc_col/=inc_col) then + inc_col = 0.0 + end if + + if (abs(inc_col)>500) then + inc_col = sign(500._r8,inc_col) + end if + + select case (update_snow) + ! Tests with snow DA, scripts adapted from Lukas Strebel + case(0) + + if (inc_col/=0._r8) then + + if (snl(c) < 0) then ! snow layers in the column + + h2osno(c) = h2osno(c) + inc_col + + do j=0,snl(c)+1,-1 ! iterate through the snow layers + + ! snow density prior for each layer + if (dz(c,j)>0.0_r8) then + snowden = (h2osoi_liq(c,j) + h2osoi_ice(c,j)) / dz(c,j) + else + snowden = 0.0_r8 + endif + + ! fraction of SWE in each active layers + if(rsnow(c)>0.0_r8) then + frac_swe = (h2osoi_liq(c,j) + h2osoi_ice(c,j)) / rsnow(c) + else + frac_swe = 0.0_r8 ! no fraction SWE if no snow is present in column + end if ! end SWE fraction if + + ! fraction of liquid and ice + if ((h2osoi_liq(c,j) + h2osoi_ice(c,j))>0.0_r8) then + frac_liq = h2osoi_liq(c,j) / (h2osoi_liq(c,j) + h2osoi_ice(c,j)) + frac_ice = 1.0_r8 - frac_liq + else + frac_liq = 0.0_r8 + frac_ice = 0.0_r8 + end if + + ! SWE adjustment per layer + ! assumes identical layer distribution of liq and ice than before DA (frac_*) + gain_h2osno = (h2osno(c) - rsnow(c)) * frac_swe + gain_h2oliq = gain_h2osno * frac_liq + gain_h2oice = gain_h2osno * frac_ice + + ! layer level adjustments + if (snowden>0.0_r8) then + gain_dzsno = gain_h2osno / snowden + else + gain_dzsno = 0.0_r8 + end if + h2osoi_liq(c,j) = h2osoi_liq(c,j) + gain_h2oliq + h2osoi_ice(c,j) = h2osoi_ice(c,j) + gain_h2oice + + + ! Adjust snow layer dimensions so that CLM5 can calculate compaction / aggregation + ! in the DART code dzsno is adjusted directly but in CLM5 dzsno is local and diagnostic + ! i.e. calculated / assigned from frac_sno and dz(:, snow_layer) in SnowHydrologyMod + ! therefore we adjust dz(:, snow_layer) here + + dz(c,j) = dz(c,j) + gain_dzsno + ! mid point and interface adjustments + ! i.e. zsno (col%z(:, snow_layers)) and zisno (col%zi(:, snow_layers)) + ! DART version the sum goes from ilevel:nlevsno to fit with our indexing: + zi(c,j-1) = sum(dz(c,j:0))*-1.0_r8 + ! In DART the check is ilevel == nlevsno but here + + if (j==0) then + z(c,j) = zi(c,j-1) / 2.0_r8 + else + z(c,j) = sum(zi(c,j-1:j)) / 2.0_r8 + end if + + + end do + + ! Update the total snow depth to match updates to layers for active snow layers + snow_depth(c) = sum(dz(c,snl(c)+1:0)) + h2osno(c) = sum(h2osoi_ice(c,snl(c)+1:0)+h2osoi_liq(c,snl(c)+1:0)) + + end if + + end if + + case (1) !update with factor of old and new snow + + if (snl(c) < 0) then ! snow layers in the column + + ! if (inc_col>1000._r8) then + ! inc_col = 1000._r8 + ! end if + + inc_col = h2osno(c)+inc_col + + if (inc_col>10000) then + inc_col = 10000 + end if + + scale = inc_col/h2osno(c) + h2osno(c) = inc_col + + do j=0,snl(c)+1,-1 + h2osoi_liq(c,j) = h2osoi_liq(c,j)*scale + h2osoi_ice(c,j) = h2osoi_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 if + + end select + + ! snow negative + if (h2osno(c) < 0._r8) then + if (snl(c)<0) then + + do j=0,snl(c)+1,-1 + h2osoi_liq(c,j) = 0.0_r8 + h2osoi_ice(c,j) = 0.00000001_r8 + dz(c,j) = 0.00000001_r8 + zi(c,j-1) = sum(dz(c,j:0))*-1.0_r8 + if (j==0) then + z(c,j) = zi(c,j-1) / 2.0_r8 + else + z(c,j) = sum(zi(c,j-1:j)) / 2.0_r8 + end if + end do + + else + + h2osoi_liq(c,0) = 0.0_r8 + h2osoi_ice(c,0) = 0.00000001_r8 + dz(c,0) = 0.00000001_r8 + zi(c,-1) = dz(c,0)*-1.0_r8 + z(c,0) = zi(c,-1) / 2.0_r8 + + end if + + snow_depth(c) = sum(dz(c,-nlevsno+1:0)) + h2osno(c) = sum(h2osoi_ice(c,-nlevsno+1:0)) + end if + + end if + + end do + + end if + + cc = cc+1 + + end do + + elseif (state_setup==5) then !--> I use this as default + + + ! soil water + + cc = 1 + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + inc = clm_statevec(cc)-clm_statevec_original_input(cc) + + if (abs(inc)>1.e-10_r8) then + + ! update soil water + do j = 1,3 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (col%gridcell(c)==g) then + + inc_col = inc*h2osoi_liq_mean(c,j)/clm_statevec_original_input(cc) + + if (inc_col/=inc_col) then + inc_col = 0.0 + end if + + ! if increment larger than maximal increment, adjust it to maximal increment with the sign of old increment + ! so that the direction of the increment is right + if (abs(inc_col)>max_inc*h2osoi_liq(c,j)) then + inc_col = sign(max_inc*h2osoi_liq(c,j),inc_col) + end if + + h2osoi_liq(c,j) = h2osoi_liq(c,j) + inc_col + + if (h2osoi_liq(c,j)max_inc*h2osoi_ice(c,j)) then + inc_col = sign(max_inc*h2osoi_ice(c,j),inc_col) + end if + + h2osoi_ice(c,j) = h2osoi_ice(c,j) + inc_col + + if (h2osoi_ice(c,j)<0) then + h2osoi_ice(c,j) = 0._r8 + end if + + + + h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) + + if (j>1 .and. h2osoi_vol(c,j)>watsat(c,j)) then + !if (h2osoi_vol(c,j)>watsat(c,j)) then ! check if soil balancing error comes from this + + var_temp = watsat(c,j) / h2osoi_vol(c,j) + + h2osoi_liq(c,j) = h2osoi_liq(c,j)*var_temp + + if (h2osoi_liq(c,j) < watmin) then + h2osoi_liq(c,j) = watmin + end if + + h2osoi_ice(c,j) = (watsat(c,j)*dz(c,j)*denice)-h2osoi_liq(c,j)*denice/denh2o + if (abs(h2osoi_ice(c,j))<1.e-10_r8) then !numerics, if h2osoiice was zero before, it is -something e-16 after the previous calculation, so something marginal negative + h2osoi_ice(c,j) = 0._r8 + end if + + h2osoi_vol(c,j) = watsat(c,j) + + end if + + end if + + end do + end do + + end if + + cc = cc+1 + + end do + + + + cc = 1 + + do count = 1, num_layer(4) + + g = hactiveg_levels(count,4) + + inc = clm_statevec(cc+clm_varsize_tws(1))-clm_statevec_original_input(cc+clm_varsize_tws(1)) + + if (abs(inc)>1.e-10_r8) then + + ! update soil water + do j = 4,12 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (col%gridcell(c)==g) then + + inc_col = inc*h2osoi_liq_mean(c,j)/clm_statevec_original_input(cc+clm_varsize_tws(1)) + + if (inc_col/=inc_col) then + inc_col = 0.0 + end if + + ! if increment larger than maximal increment, adjust it to maximal increment with the sign of old increment + ! so that the direction of the increment is right + if (abs(inc_col)>max_inc*h2osoi_liq(c,j)) then + inc_col = sign(max_inc*h2osoi_liq(c,j),inc_col) + end if + + h2osoi_liq(c,j) = h2osoi_liq(c,j) + inc_col + + if (h2osoi_liq(c,j)max_inc*h2osoi_ice(c,j)) then + inc_col = sign(max_inc*h2osoi_ice(c,j),inc_col) + end if + + h2osoi_ice(c,j) = h2osoi_ice(c,j) + inc_col + + if (h2osoi_ice(c,j)<0) then + h2osoi_ice(c,j) = 0._r8 + end if + + + + h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) + + if (h2osoi_vol(c,j)-watsat(c,j)>0.00001) then + + var_temp = watsat(c,j) / h2osoi_vol(c,j) + + h2osoi_liq(c,j) = h2osoi_liq(c,j)*var_temp + + if (h2osoi_liq(c,j) < watmin) then + h2osoi_liq(c,j) = watmin + end if + + h2osoi_ice(c,j) = (watsat(c,j)*dz(c,j)*denice)-h2osoi_liq(c,j)*denice/denh2o + if (abs(h2osoi_ice(c,j))<1.e-10_r8) then !numerics, if h2osoiice was zero before, it is -something e-16 after the previous calculation, so something marginal negative + h2osoi_ice(c,j) = 0._r8 + end if + + h2osoi_vol(c,j) = watsat(c,j) + + end if + + end if + + end do + end do + + end if + + cc = cc+1 + + end do + + cc = 1 + + do count = 1, num_layer(13) + + g = hactiveg_levels(count,13) + + inc = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2))-clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) + + if (abs(inc)>1.e-10_r8) then + + ! update soil water + do j = 13,nlevsoi + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (col%gridcell(c)==g) then + + inc_col = inc*h2osoi_liq_mean(c,j)/clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)) + + if (inc_col/=inc_col) then + inc_col = 0.0 + end if + + ! if increment larger than maximal increment, adjust it to maximal increment with the sign of old increment + ! so that the direction of the increment is right + if (abs(inc_col)>max_inc*h2osoi_liq(c,j)) then + inc_col = sign(max_inc*h2osoi_liq(c,j),inc_col) + end if + + h2osoi_liq(c,j) = h2osoi_liq(c,j) + inc_col + + if (h2osoi_liq(c,j)max_inc*h2osoi_ice(c,j)) then + inc_col = sign(max_inc*h2osoi_ice(c,j),inc_col) + end if + + h2osoi_ice(c,j) = h2osoi_ice(c,j) + inc_col + + if (h2osoi_ice(c,j)<0) then + h2osoi_ice(c,j) = 0._r8 + end if + + + + h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) + + if (h2osoi_vol(c,j)-watsat(c,j)>0.00001) then + + var_temp = watsat(c,j) / h2osoi_vol(c,j) + + h2osoi_liq(c,j) = h2osoi_liq(c,j)*var_temp + + if (h2osoi_liq(c,j) < watmin) then + h2osoi_liq(c,j) = watmin + end if + + h2osoi_ice(c,j) = (watsat(c,j)*dz(c,j)*denice)-h2osoi_liq(c,j)*denice/denh2o + if (abs(h2osoi_ice(c,j))<1.e-10_r8) then !numerics, if h2osoiice was zero before, it is -something e-16 after the previous calculation, so something marginal negative + h2osoi_ice(c,j) = 0._r8 + end if + + h2osoi_vol(c,j) = watsat(c,j) + + end if + + end if + + end do + end do + + end if + + cc = cc+1 + + end do + + + + ! snow + + cc = 1 + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + inc = clm_statevec(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) - clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) ! save increment for gridcell + + if (abs(inc)>1.e-10_r8) then + + do count_columns = 1, num_layer_columns(1) + + c = hactivec_levels(count_columns,1) + + if (col%gridcell(c)==g) then + + inc_col = inc*h2osno_mean(c)/clm_statevec_original_input(cc+clm_varsize_tws(1)+clm_varsize_tws(2)+clm_varsize_tws(3)) + + if (inc_col/=inc_col) then + inc_col = 0.0 + end if + + if (abs(inc_col)>max_inc*h2osno(c)) then + inc_col = sign(max_inc*h2osno(c),inc_col) + end if + + select case (update_snow) + ! Tests with snow DA, scripts adapted from Lukas Strebel + case(0) + + if (inc_col/=0._r8) then + + if (snl(c) < 0) then ! snow layers in the column + + h2osno(c) = h2osno(c) + inc_col + + do j=0,snl(c)+1,-1 ! iterate through the snow layers + + ! snow density prior for each layer + if (dz(c,j)>0.0_r8) then + snowden = (h2osoi_liq(c,j) + h2osoi_ice(c,j)) / dz(c,j) + else + snowden = 0.0_r8 + endif + + ! fraction of SWE in each active layers + if(rsnow(c)>0.0_r8) then + frac_swe = (h2osoi_liq(c,j) + h2osoi_ice(c,j)) / rsnow(c) + else + frac_swe = 0.0_r8 ! no fraction SWE if no snow is present in column + end if ! end SWE fraction if + + ! fraction of liquid and ice + if ((h2osoi_liq(c,j) + h2osoi_ice(c,j))>0.0_r8) then + frac_liq = h2osoi_liq(c,j) / (h2osoi_liq(c,j) + h2osoi_ice(c,j)) + frac_ice = 1.0_r8 - frac_liq + else + frac_liq = 0.0_r8 + frac_ice = 0.0_r8 + end if + + ! SWE adjustment per layer + ! assumes identical layer distribution of liq and ice than before DA (frac_*) + gain_h2osno = (h2osno(c) - rsnow(c)) * frac_swe + gain_h2oliq = gain_h2osno * frac_liq + gain_h2oice = gain_h2osno * frac_ice + + ! layer level adjustments + if (snowden>0.0_r8) then + gain_dzsno = gain_h2osno / snowden + else + gain_dzsno = 0.0_r8 + end if + h2osoi_liq(c,j) = h2osoi_liq(c,j) + gain_h2oliq + h2osoi_ice(c,j) = h2osoi_ice(c,j) + gain_h2oice + + + ! Adjust snow layer dimensions so that CLM5 can calculate compaction / aggregation + ! in the DART code dzsno is adjusted directly but in CLM5 dzsno is local and diagnostic + ! i.e. calculated / assigned from frac_sno and dz(:, snow_layer) in SnowHydrologyMod + ! therefore we adjust dz(:, snow_layer) here + + dz(c,j) = dz(c,j) + gain_dzsno + ! mid point and interface adjustments + ! i.e. zsno (col%z(:, snow_layers)) and zisno (col%zi(:, snow_layers)) + ! DART version the sum goes from ilevel:nlevsno to fit with our indexing: + zi(c,j-1) = sum(dz(c,j:0))*-1.0_r8 + ! In DART the check is ilevel == nlevsno but here + + if (j==0) then + z(c,j) = zi(c,j-1) / 2.0_r8 + else + z(c,j) = sum(zi(c,j-1:j)) / 2.0_r8 + end if + + + end do + + ! Update the total snow depth to match updates to layers for active snow layers + snow_depth(c) = sum(dz(c,snl(c)+1:0)) + h2osno(c) = sum(h2osoi_ice(c,snl(c)+1:0)+h2osoi_liq(c,snl(c)+1:0)) + + end if + + end if + + case (1) !update with factor of old and new snow + + if (snl(c) < 0) then ! snow layers in the column + + ! if (inc_col>1000._r8) then + ! inc_col = 1000._r8 + ! end if + + inc_col = h2osno(c)+inc_col + scale = inc_col/h2osno(c) + h2osno(c) = inc_col + + do j=0,snl(c)+1,-1 + h2osoi_liq(c,j) = h2osoi_liq(c,j)*scale + h2osoi_ice(c,j) = h2osoi_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 if + + end select + + ! snow negative + if (h2osno(c) < 0._r8) then + if (snl(c)<0) then + + do j=0,snl(c)+1,-1 + h2osoi_liq(c,j) = 0.0_r8 + h2osoi_ice(c,j) = 0.00000001_r8 + dz(c,j) = 0.00000001_r8 + zi(c,j-1) = sum(dz(c,j:0))*-1.0_r8 + if (j==0) then + z(c,j) = zi(c,j-1) / 2.0_r8 + else + z(c,j) = sum(zi(c,j-1:j)) / 2.0_r8 + end if + end do + + else + + h2osoi_liq(c,0) = 0.0_r8 + h2osoi_ice(c,0) = 0.00000001_r8 + dz(c,0) = 0.00000001_r8 + zi(c,-1) = dz(c,0)*-1.0_r8 + z(c,0) = zi(c,-1) / 2.0_r8 + + end if + + snow_depth(c) = sum(dz(c,-nlevsno+1:0)) + h2osno(c) = sum(h2osoi_ice(c,-nlevsno+1:0)) + end if + + end if + + end do + + end if + + cc = cc+1 + + end do + + + end if + + + do j = 1,nlevsoi + do count = 1,num_layer_columns(j) + c = hactivec_levels(count,j) + + h2osoi_liq_inc(c,j) = h2osoi_liq(c,j)-h2osoi_liq_inc(c,j) + h2osoi_ice_inc(c,j) = h2osoi_ice(c,j)-h2osoi_ice_inc(c,j) + + if (j==1) then + h2osno_inc(c) = h2osno(c)-h2osno_inc(c) + end if + end do + end do + + + + + ! fill state after assimilation (the same script as filling the state vector before the assimilation, now only after the assimilation) + + select case (state_setup) + + case(0) ! all compartments, liq and ice water indidually + + do j = 1,nlevsoi + + do count = 1, num_layer(j) + + g = hactiveg_levels(count,j) + + avg_sum = 0 + avg_sum_ice = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + avg_sum_ice = avg_sum_ice + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + + end if + + end do + + h2osoi_liq_state(g,j) = avg_sum/avg_divide + h2osoi_ice_state(g,j) = avg_sum_ice/avg_divide + + avg_sum = 0 + avg_divide = 0 + if (j==1) then + ! snow + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(j) + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osno(c) + + avg_divide = avg_divide+1 + + + end if + + end do + + h2osno_state(g) = avg_sum/avg_divide + + end if + + end do + end do + + + + case(1) ! all compartments, sum of ice and liq soil water to overcome balancing errors due to different partitioning of water caused by different temperature + + do j = 1,nlevsoi + + do count = 1, num_layer(j) + + g = hactiveg_levels(count,j) + + avg_sum = 0 + avg_sum_ice = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + h2osoi_liq_state(g,j) = avg_sum/avg_divide + + avg_sum = 0 + avg_divide = 0 + if (j==1) then + ! snow + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(j) + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osno(c) + + avg_divide = avg_divide+1 + + + end if + + end do + + h2osno_state(g) = avg_sum/avg_divide + + end if + + end do + end do + + + + case(2) ! only TWS in statevector + + do count = 1, num_layer(1) + + h2osoi_liq_state(g,1) = hactiveg_levels(count,1) + + h2osoi_liq_state(g,1) = TWS(g) + + end do + + case(3) ! sum over all soil layers and snow in statevector + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + h2osoi_liq_state(g,1) = 0 + + do j = 1, nlevsoi + + avg_sum = 0 + avg_sum_ice = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + if (avg_divide/=0) then + h2osoi_liq_state(g,1) = h2osoi_liq_state(g,1) + avg_sum/avg_divide + end if + + end do + + end do + + + ! snow + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(1) + c = hactivec_levels(count_columns,1) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osno(c) + + avg_divide = avg_divide+1 + + + end if + + end do + + h2osno_state(g) = avg_sum/avg_divide + + end do + + case(4) + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + h2osoi_liq_state(g,1) = 0 + + do j = 1, 7 + + avg_sum = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + if (avg_divide/=0) then + + h2osoi_liq_state(g,1) = h2osoi_liq_state(g,1) + avg_sum/avg_divide + + end if + + end do + + end do + + do count = 1, num_layer(8) + + g = hactiveg_levels(count,8) + + h2osoi_liq_state(g,2) = 0 + + do j = 8, nlevsoi + + avg_sum = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + if (avg_divide/=0) then + + h2osoi_liq_state(g,2) = h2osoi_liq_state(g,2) + avg_sum/avg_divide + + end if + + end do + + end do + + ! snow + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(1) + c = hactivec_levels(count_columns,1) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osno(c) + + avg_divide = avg_divide+1 + + + end if + + end do + + h2osno_state(g) = avg_sum/avg_divide + + end do + + case(5) !--> I use this as default + + do count = 1, num_layer(1) + + g = hactiveg_levels(count,1) + + h2osoi_liq_state(g,1) = 0 + + do j = 1, 3 + + avg_sum = 0 + avg_divide = 0 + + do count_columns = 1,num_layer_columns(j) + + c = hactivec_levels(count_columns,j) + + if (g==col%gridcell(c)) then + + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) + + avg_divide = avg_divide+1 + + end if + + end do + + if (avg_divide/=0) then + + h2osoi_liq_state(g,1) = h2osoi_liq_state(g,1) + avg_sum/avg_divide + + end if - implicit none + end do - integer,intent(in) :: tstartcycle - integer,intent(in) :: mype + end do - real(r8), pointer :: swc(:,:) - real(r8), pointer :: watsat(:,:) - real(r8), pointer :: psand(:,:) - real(r8), pointer :: pclay(:,:) - real(r8), pointer :: porgm(:,:) + do count = 1, num_layer(4) - 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 + g = hactiveg_levels(count,4) - 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 - character (len = 32) :: fn5 !TSMP-PDAF: function name for state vector outpu - character (len = 32) :: fn6 !TSMP-PDAF: function name for state vector outpu + h2osoi_liq_state(g,2) = 0 - logical :: swc_zero_before_update + do j = 4, 12 - cc = 0 - offset = 0 - swc_zero_before_update = .false. + avg_sum = 0 + avg_divide = 0 -#ifdef PDAF_DEBUG - IF(clmt_printensemble == tstartcycle .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, ".update.", tstartcycle, ".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 + do count_columns = 1,num_layer_columns(j) - 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 + c = hactivec_levels(count_columns,j) - snow_depth => waterstate_inst%snow_depth_col ! snow height of snow covered area (m) + if (g==col%gridcell(c)) then - dz => col%dz - h2osoi_liq => waterstate_inst%h2osoi_liq_col - h2osoi_ice => waterstate_inst%h2osoi_ice_col + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) -#ifdef PDAF_DEBUG - IF(clmt_printensemble == tstartcycle .OR. clmt_printensemble < 0) THEN + avg_divide = avg_divide+1 - IF(clmupdate_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") - WRITE (71,"(es22.15)") h2osoi_liq(:,:) - CLOSE(71) + end if - ! TSMP-PDAF: For debug runs, output the state vector in files - WRITE(fn6, "(a,i5.5,a,i5.5,a)") "h2osoi_ice", mype, ".bef_up.", tstartcycle, ".txt" - OPEN(unit=71, file=fn6, action="write") - WRITE (71,"(es22.15)") h2osoi_ice(:,:) - CLOSE(71) - END IF + end do - END IF -#endif + if (avg_divide/=0) then - ! calculate shift when CRP data are assimilated - if(clmupdate_swc==2) then - error stop "Not implemented: clmupdate_swc.eq.2" - endif + h2osoi_liq_state(g,2) = h2osoi_liq_state(g,2) + avg_sum/avg_divide - ! CLM5: Update the Data Assimulation time-step to the current time - ! step, since DA has been done. Used by CLM5 to skip BalanceChecks - ! directly after the DA step. - call update_DA_nstep() + end if - ! write updated swc back to CLM - if(clmupdate_swc/=0) then + end do - ! Set minimum soil moisture for checking the state vector and - ! for setting minimum swc for CLM - if(clmwatmin_switch==3) then - ! CLM3.5 type watmin - watmin_check = 0.00 - watmin_set = 0.05 - else if(clmwatmin_switch==5) then - ! CLM5.0 type watmin - watmin_check = watmin - watmin_set = watmin - else - ! Default - watmin_check = 0.0 - watmin_set = 0.0 - end if + end do - ! cc = 0 - do i=1,nlevsoi - ! CLM3.5: iterate over grid cells - ! CLM5.0: iterate over columns - ! do j=clm_begg,clm_endg - do j=clm_begc,clm_endc + do count = 1, num_layer(13) - ! 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 + g = hactiveg_levels(count,13) - if(swc(j,i)==0.0) then - swc_zero_before_update = .true. + h2osoi_liq_state(g,3) = 0 - ! 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. + do j = 13, nlevsoi - 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 + avg_sum = 0 + avg_divide = 0 - 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 + do count_columns = 1,num_layer_columns(j) - ! 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 + c = hactivec_levels(count_columns,j) - 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 (g==col%gridcell(c)) then - if (isnan(swc(j,i))) then - swc(j,i) = watmin_set - print *, "WARNING: swc at j,i is nan: ", j, i - endif + avg_sum = avg_sum + h2osoi_liq(c,j) + h2osoi_ice(c,j) - 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 + avg_divide = avg_divide+1 -#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 do + + if (avg_divide/=0) then + + h2osoi_liq_state(g,3) = h2osoi_liq_state(g,3) + avg_sum/avg_divide + + 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 + end do - 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) - ! 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) + ! snow - ! 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 + do count = 1, num_layer(1) - END IF -#endif + g = hactiveg_levels(count,1) - endif + avg_sum = 0 + avg_divide = 0 + do count_columns = 1,num_layer_columns(1) + c = hactivec_levels(count_columns,1) - !hcp: TG, TV - if(clmupdate_T==1) then - error stop "Not implemented: clmupdate_T.eq.1" - endif - ! end hcp TG, TV + if (g==col%gridcell(c)) then - !! 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 + avg_sum = avg_sum + h2osno(c) + + avg_divide = avg_divide+1 - ! 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) end if - cc = cc + 1 + end do + + if (avg_divide/=0) then + + h2osno_state(g) = avg_sum/avg_divide + + end if + end do - call clm_correct_texture - call clm_texture_to_parameters - endif - end subroutine update_clm + end select + + + end subroutine clm_update_tws subroutine clm_correct_texture() @@ -1312,6 +4531,17 @@ subroutine init_dim_l_clm(domain_p, dim_l) dim_l = 3*nlevsoi + nshift endif + if (clmupdate_tws==1) then + select case (state_setup) + case(0) + dim_l = 2*nlevsoi+3 + case(2) + dim_l = 1 + case default + dim_l = 1*nlevsoi+3 + end select + end if + end subroutine init_dim_l_clm !> @author Wolfgang Kurtz, Johannes Keller @@ -1390,5 +4620,74 @@ subroutine l2g_state_clm(domain_p, dim_l, state_l, dim_p, state_p) end subroutine l2g_state_clm #endif + !> @author Yorck Ewerdwalbesloh + !> @date 05.09.2023 + !> @brief reading TWS temporal mean model file + !> @param[in] temp_mean_filename Name of mean file + !> @details + !> This subroutine reads a provided temporal mean model file + 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 + use netcdf, only: nf90_get_var + use netcdf, only: nf90_close + 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 + + !print *, "Read temporal mean of CLM OL run" + + call check_nc(nf90_open(temp_mean_filename, nf90_nowrite, ncid)) + call check_nc(nf90_inq_dimid(ncid, dim_lon_name, dimid_lon)) + call check_nc(nf90_inq_dimid(ncid, dim_lat_name, dimid_lat)) + call check_nc(nf90_inquire_dimension(ncid, dimid_lon, recorddimname, dim_lon)) + call check_nc(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_nc( nf90_inq_varid(ncid, lon_name, lon_varid)) + call check_nc(nf90_get_var(ncid, lon_varid, lon_temp_mean)) + + call check_nc( nf90_inq_varid(ncid, lat_name, lat_varid)) + call check_nc(nf90_get_var(ncid, lat_varid, lat_temp_mean)) + + call check_nc( nf90_inq_varid(ncid, tws_name, tws_varid)) + call check_nc(nf90_get_var(ncid, tws_varid, tws_temp_mean)) + + call check_nc( nf90_close(ncid) ) + + end subroutine read_temp_mean_model + + subroutine check_nc(status) + + use netcdf, only: nf90_noerr + use netcdf, only: nf90_strerror + integer, intent ( in) :: status + + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + stop "Stopped" + end if + end subroutine check_nc + end module enkf_clm_mod diff --git a/interface/model/eclm/print_update_clm_5.F90 b/interface/model/eclm/print_update_clm_5.F90 index 09dbc6810..b86e7e442 100644 --- a/interface/model/eclm/print_update_clm_5.F90 +++ b/interface/model/eclm/print_update_clm_5.F90 @@ -219,6 +219,621 @@ 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, 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 enkf_clm_mod, only : num_layer, num_layer_columns, hactivec_levels, hactiveg_levels + ! use cime_comp_mod + use ColumnType , only : col + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use mpi, only: mpi_gatherv + use mpi, only: mpi_real8 + + 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 count = 1, num_layer(j) + g = hactiveg_levels(count,j) + count_columns = 0 + sum_columns = 0 + do count2 = 1, num_layer_columns(j) + c = hactivec_levels(count2,j) + if (g==col%gridcell(c)) then + sum_columns = sum_columns+h2osoi_liq(c,j) + count_columns = count_columns+1 + end if + end do + clmstate_tmp_local(g,j) = sum_columns/count_columns + if (j==1) then + tws_inc(g) = 0._r8 + end if + tws_inc(g) = tws_inc(g) + clmstate_tmp_local(g,j) + 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 count = 1, num_layer(j) + g = hactiveg_levels(count,j) + count_columns = 0 + sum_columns = 0 + do count2 = 1, num_layer_columns(j) + c = hactivec_levels(count2,j) + if (g==col%gridcell(c)) then + sum_columns = sum_columns+h2osoi_ice(c,j) + count_columns = count_columns+1 + end if + end do + clmstate_tmp_local(g,j) = sum_columns/count_columns + tws_inc(g) = tws_inc(g) + clmstate_tmp_local(g,j) + 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 count = 1, num_layer(1) + g = hactiveg_levels(count,1) + count_columns = 0 + sum_columns = 0 + do count2 = 1, num_layer_columns(1) + c = hactivec_levels(count2,1) + if (g==col%gridcell(c)) then + sum_columns = sum_columns+h2osno(c) + count_columns = count_columns+1 + end if + end do + clmstate_tmp_local(g,1) = sum_columns/count_columns + tws_inc(g) = tws_inc(g) + clmstate_tmp_local(g,1) + 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 + + +subroutine print_state_clm() bind(C,name="print_state_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, 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 enkf_clm_mod, only : num_layer, num_layer_columns, hactivec_levels, hactiveg_levels, state_setup + ! use cime_comp_mod + use ColumnType , only : col + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use mpi, only: mpi_gatherv + use mpi, only: mpi_real8 + + 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 :: tws_state_before(:) + real(r8), pointer :: h2osoi_liq_state_before(:,:) + real(r8), pointer :: h2osoi_ice_state_before(:,:) + real(r8), pointer :: h2osno_state_before(:) + + real(r8), pointer :: tws_state_after(:) + real(r8), pointer :: h2osoi_liq_state_after(:,:) + real(r8), pointer :: h2osoi_ice_state_after(:,:) + real(r8), pointer :: h2osno_state_after(:) + + real(r8), pointer :: clmstate_tmp_global(:) + real(r8), allocatable :: clmstate_out(:,:,:) + integer ,dimension(3) :: dimids + integer ,dimension(2) :: dimids_1level + integer :: il_file_id, ncvarid(4), status + character(len = 300) :: state_before_filename + character(len = 300) :: state_after_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 + + tws_state_before => waterstate_inst%tws_state_before + tws_state_after => waterstate_inst%tws_state_after + + h2osoi_liq_state_before => waterstate_inst%h2osoi_liq_state_before + h2osoi_ice_state_before => waterstate_inst%h2osoi_ice_state_before + h2osno_state_before => waterstate_inst%h2osno_state_before + + h2osoi_liq_state_after => waterstate_inst%h2osoi_liq_state_after + h2osoi_ice_state_after => waterstate_inst%h2osoi_ice_state_after + h2osno_state_after => waterstate_inst%h2osno_state_after + + call get_proc_global(ng=numg,nl=numl,nc=numc,np=nump) + call get_proc_bounds(begg,endg,begl,endl,begc,endc,begp,endp) + + 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 + + ! state before assimilation + + + if(masterproc) then + call get_state_filename_before(state_before_filename) + status = nf90_create(state_before_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(4)) + status = nf90_enddef(il_file_id) + end if + + do jn = 1,nlevsoi + + if (masterproc) then + call mpi_gatherv (h2osoi_liq_state_before(beg,jn), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (h2osoi_liq_state_before(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 + + 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 + + end do + + do jn = 1,nlevsoi + + if (masterproc) then + call mpi_gatherv (h2osoi_ice_state_before(beg,jn), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (h2osoi_ice_state_before(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 + + 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 + + end do + + if (masterproc) then + call mpi_gatherv (h2osno_state_before(beg), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (h2osno_state_before(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, "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_state_before(beg), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (tws_state_before(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) + end if + + + + ! state after assimilation + + if(masterproc) then + call get_state_filename_after(state_after_filename) + status = nf90_create(state_after_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(4)) + status = nf90_enddef(il_file_id) + end if + + do jn = 1,nlevsoi + + if (masterproc) then + call mpi_gatherv (h2osoi_liq_state_after(beg,jn), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (h2osoi_liq_state_after(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 + + 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 + + end do + + do jn = 1,nlevsoi + + if (masterproc) then + call mpi_gatherv (h2osoi_ice_state_after(beg,jn), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (h2osoi_ice_state_after(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 + + 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 + + end do + + if (masterproc) then + call mpi_gatherv (h2osno_state_after(beg), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (h2osno_state_after(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, "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_state_after(beg), numsend , MPI_REAL8, clmstate_tmp_global, numrecvv, displsv, MPI_REAL8, 0, mpicom, ier) + else + call mpi_gatherv (tws_state_after(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) + end if + + if(masterproc) then + deallocate(clmstate_out) + deallocate(clmstate_tmp_global) + end if + +end subroutine print_state_clm #endif subroutine get_update_filename (iofile) @@ -243,3 +858,60 @@ 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 + +subroutine get_state_filename_before (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)//".state_before"//trim(inst_suffix)//"."//trim(cdate)//".nc" + +end subroutine get_state_filename_before + +subroutine get_state_filename_after (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)//".state_after"//trim(inst_suffix)//"."//trim(cdate)//".nc" + +end subroutine get_state_filename_after diff --git a/interface/model/wrapper_tsmp.c b/interface/model/wrapper_tsmp.c index 56687e032..63fa6e9f5 100644 --- a/interface/model/wrapper_tsmp.c +++ b/interface/model/wrapper_tsmp.c @@ -198,11 +198,18 @@ 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){ + if(clmprint_swc == 1 || clmupdate_texture == 1 || clmupdate_texture == 2 || (clmupdate_T != 0)){ print_update_clm(&tcycle, &total_steps); } + if ((clmupdate_tws != 0)){ + +#if defined CLMFIVE + print_inc_clm(); + // print_state_clm(); +#endif + } } #endif