From 36b63ec2eaa5865a2491ccc46b5f413f6b22ad63 Mon Sep 17 00:00:00 2001 From: zhangsp8 <21294631@qq.com> Date: Thu, 23 May 2024 10:48:56 +0800 Subject: [PATCH 1/3] modifications to mapping, crop fraction, history info, forcing downscaling. --- CaMa/src/MOD_CaMa_Vars.F90 | 23 +- CaMa/src/MOD_CaMa_colmCaMa.F90 | 4 +- Makefile | 4 +- include/Makeoptions.gnu | 7 +- include/Makeoptions.intel | 8 +- main/DA/MOD_DA_GRACE.F90 | 14 +- main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 | 10 +- main/MOD_Aerosol.F90 | 36 +- main/MOD_CropReadin.F90 | 29 +- main/MOD_FireData.F90 | 14 +- main/MOD_Forcing.F90 | 406 ++-- main/MOD_ForcingDownscaling.F90 | 321 ++- main/MOD_Hist.F90 | 170 +- main/MOD_HistGridded.F90 | 696 +++--- main/MOD_HistSingle.F90 | 2 + main/MOD_HistVector.F90 | 3 + main/MOD_HistWriteBack.F90 | 2 + main/MOD_LightningData.F90 | 8 +- main/MOD_NdepData.F90 | 12 +- main/MOD_NitrifData.F90 | 10 +- main/MOD_Ozone.F90 | 8 +- main/MOD_Vars_1DAccFluxes.F90 | 4 - main/MOD_Vars_1DForcing.F90 | 97 +- main/MOD_Vars_TimeInvariants.F90 | 34 +- mkinidata/MOD_Initialize.F90 | 86 +- mkinidata/MOD_PercentagesPFTReadin.F90 | 13 +- mksrfdata/MKSRFDATA.F90 | 4 - mksrfdata/MOD_ElmVector.F90 | 4 - mksrfdata/MOD_HRUVector.F90 | 4 - mksrfdata/MOD_LandCrop.F90 | 16 +- mksrfdata/MOD_LandPFT.F90 | 16 + mksrfdata/MOD_PixelsetShared.F90 | 2 + mksrfdata/MOD_SrfdataDiag.F90 | 28 +- mksrfdata/MOD_SrfdataRestart.F90 | 24 + run/forcing/ERA5LAND.nml | 2 +- share/MOD_DataType.F90 | 50 + share/MOD_InterpBilinear.F90 | 698 ------ share/MOD_Mapping_Grid2Pset.F90 | 905 -------- share/MOD_Mapping_Pset2Grid.F90 | 1080 --------- share/MOD_Namelist.F90 | 15 +- share/MOD_NetCDFSerial.F90 | 48 + share/MOD_Pixelset.F90 | 135 +- share/MOD_SpatialMapping.F90 | 2558 +++++++++++++++++++++ 43 files changed, 3950 insertions(+), 3660 deletions(-) delete mode 100644 share/MOD_InterpBilinear.F90 delete mode 100644 share/MOD_Mapping_Grid2Pset.F90 delete mode 100644 share/MOD_Mapping_Pset2Grid.F90 create mode 100644 share/MOD_SpatialMapping.F90 diff --git a/CaMa/src/MOD_CaMa_Vars.F90 b/CaMa/src/MOD_CaMa_Vars.F90 index 8c6771ee..3480fad2 100644 --- a/CaMa/src/MOD_CaMa_Vars.F90 +++ b/CaMa/src/MOD_CaMa_Vars.F90 @@ -28,8 +28,7 @@ MODULE MOD_CaMa_Vars USE MOD_Precision USE MOD_Grid USE MOD_DataType - USE MOD_Mapping_Pset2Grid - USE MOD_Mapping_Grid2Pset + USE MOD_SpatialMapping USE YOS_CMF_INPUT, only: RMIS, DMIS real(r8) :: nacc ! number of accumulation @@ -57,8 +56,8 @@ MODULE MOD_CaMa_Vars real(r8), allocatable :: finfg_2d (:,:) ! on Master : total runoff [mm/s] type(grid_type) :: gcama - type (mapping_pset2grid_type) :: mp2g_cama ! mapping pset to grid - type (mapping_grid2pset_type) :: mg2p_cama ! mapping grid to pset + type (spatial_mapping_type) :: mp2g_cama ! mapping pset to grid + type (spatial_mapping_type) :: mg2p_cama ! mapping grid to pset type (grid_concat_type) :: cama_gather ! gather grid @@ -550,7 +549,6 @@ SUBROUTINE colm2cama_real8 (WorkerVar, IOVar, MasterVar) USE MOD_Block USE MOD_DataType USE MOD_LandPatch - USE MOD_Mapping_Pset2Grid USE MOD_Vars_TimeInvariants, only : patchtype USE MOD_Forcing, only : forcmask_pch @@ -561,7 +559,6 @@ SUBROUTINE colm2cama_real8 (WorkerVar, IOVar, MasterVar) real(r8), intent(inout) :: MasterVar(:,:) !varialbe on master processer type(block_data_real8_2d) :: sumwt !sum of weight - real(r8), allocatable :: vectmp(:) !temporary vector logical, allocatable :: filter(:) !filter for patchtype !----------------------- Dummy argument -------------------------------- integer :: xblk, yblk, xloc, yloc @@ -581,23 +578,19 @@ SUBROUTINE colm2cama_real8 (WorkerVar, IOVar, MasterVar) IF (numpatch > 0) THEN allocate (filter (numpatch)) - allocate (vectmp (numpatch)) filter(:) = patchtype < 99 IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask_pch ENDIF - vectmp (:) = 1. ENDIF ENDIF - CALL mp2g_cama%map (WorkerVar, IOVar, spv = spval, msk = filter) + CALL mp2g_cama%pset2grid (WorkerVar, IOVar, spv = spval, msk = filter) - IF (p_is_io) THEN - CALL allocate_block_data (gcama, sumwt) - ENDIF + IF (p_is_io) CALL allocate_block_data (gcama, sumwt) + CALL mp2g_cama%get_sumarea (sumwt, filter) - CALL mp2g_cama%map (vectmp, sumwt, spv = spval, msk = filter) IF (p_is_io) THEN DO yblk = 1, gblock%nyblk @@ -673,7 +666,6 @@ SUBROUTINE colm2cama_real8 (WorkerVar, IOVar, MasterVar) ENDIF IF (allocated(filter)) deallocate(filter) - IF (allocated(vectmp)) deallocate(vectmp) END SUBROUTINE colm2cama_real8 @@ -699,7 +691,6 @@ SUBROUTINE cama2colm_real8 (MasterVar, IOVar, WorkerVar) USE MOD_Block USE MOD_DataType USE MOD_LandPatch - USE MOD_Mapping_Pset2Grid USE MOD_Vars_TimeInvariants, only : patchtype USE MOD_Grid @@ -769,7 +760,7 @@ SUBROUTINE cama2colm_real8 (MasterVar, IOVar, WorkerVar) ENDDO ENDIF - CALL mg2p_cama%map_aweighted (IOVar, WorkerVar) !mapping grid to pset_type + CALL mg2p_cama%grid2pset (IOVar, WorkerVar) !mapping grid to pset_type END SUBROUTINE cama2colm_real8 diff --git a/CaMa/src/MOD_CaMa_colmCaMa.F90 b/CaMa/src/MOD_CaMa_colmCaMa.F90 index dbdb0903..26d62106 100644 --- a/CaMa/src/MOD_CaMa_colmCaMa.F90 +++ b/CaMa/src/MOD_CaMa_colmCaMa.F90 @@ -185,8 +185,8 @@ SUBROUTINE colm_CaMa_init !allocate the data structure for cama CALL gcama%define_by_ndims (NX, NY) !define the data structure for cama - CALL mp2g_cama%build (landpatch, gcama) !build the mapping between cama and mpi - CALL mg2p_cama%build (gcama, landpatch) + CALL mp2g_cama%build_arealweighted (gcama, landpatch) !build the mapping between cama and mpi + CALL mg2p_cama%build_arealweighted (gcama, landpatch) CALL cama_gather%set (gcama) diff --git a/Makefile b/Makefile index 50430535..d2cbaeff 100644 --- a/Makefile +++ b/Makefile @@ -48,9 +48,7 @@ OBJS_SHARED = \ MOD_NetCDFVectorOneS.o \ MOD_NetCDFVectorOneP.o \ MOD_RangeCheck.o \ - MOD_Mapping_Grid2Pset.o \ - MOD_Mapping_Pset2Grid.o \ - MOD_InterpBilinear.o \ + MOD_SpatialMapping.o \ MOD_AggregationRequestData.o \ MOD_PixelsetShared.o \ MOD_LandElm.o \ diff --git a/include/Makeoptions.gnu b/include/Makeoptions.gnu index 6e99b60b..d9593b75 100644 --- a/include/Makeoptions.gnu +++ b/include/Makeoptions.gnu @@ -4,8 +4,11 @@ FF = mpif90 -fopenmp - NETCDF_LIB = /usr/lib/x86_64-linux-gnu - NETCDF_INC = /usr/include +# NETCDF_LIB = /usr/lib/x86_64-linux-gnu +# NETCDF_INC = /usr/include + + NETCDF_LIB = /opt/netcdf-c-4.9.2-fortran-4.6.0-gnu/lib + NETCDF_INC = /opt/netcdf-c-4.9.2-fortran-4.6.0-gnu/include MOD_CMD = -J diff --git a/include/Makeoptions.intel b/include/Makeoptions.intel index 40e65634..3596883f 100755 --- a/include/Makeoptions.intel +++ b/include/Makeoptions.intel @@ -2,12 +2,10 @@ # mpif90 - ifort # - FF = mpif90 -f90=ifort + FF = mpif90 - NETCDF_LIB = /usr/lib/x86_64-linux-gnu - NETCDF_INC = /usr/include - - MATH_LIB = /share/home/dq013/software//miniconda3/lib/ #MKL LIB_PATH + NETCDF_LIB = /opt/netcdf-c-4.9.2-fortran-4.6.0-intel/lib + NETCDF_INC = /opt/netcdf-c-4.9.2-fortran-4.6.0-intel/include MOD_CMD = -module diff --git a/main/DA/MOD_DA_GRACE.F90 b/main/DA/MOD_DA_GRACE.F90 index 35d6a9ef..776c159a 100644 --- a/main/DA/MOD_DA_GRACE.F90 +++ b/main/DA/MOD_DA_GRACE.F90 @@ -4,7 +4,6 @@ MODULE MOD_DA_GRACE USE MOD_DataType - USE MOD_Mapping_Grid2Pset IMPLICIT NONE PUBLIC :: init_DA_GRACE @@ -26,7 +25,7 @@ MODULE MOD_DA_GRACE integer, allocatable :: obsyear (:) integer, allocatable :: obsmonth (:) - type (mapping_grid2pset_type) :: mg2p_grace + type (spatial_mapping_type) :: mg2p_grace real(r8), allocatable :: lwe_obs_this (:) real(r8), allocatable :: err_obs_this (:) @@ -69,7 +68,6 @@ SUBROUTINE init_DA_GRACE () USE MOD_LandCrop #endif USE MOD_Pixelset - USE MOD_Mapping_Grid2pset USE MOD_Vars_TimeInvariants, only : patchtype USE MOD_Forcing, only : forcmask_pch USE MOD_RangeCheck @@ -105,7 +103,7 @@ SUBROUTINE init_DA_GRACE () CALL grid_grace%define_by_center (latgrace,longrace) - CALL mg2p_grace%build (grid_grace, landelm) + CALL mg2p_grace%build_arealweighted (grid_grace, landelm) IF (p_is_worker) THEN IF (numelm > 0) THEN @@ -133,11 +131,7 @@ SUBROUTINE init_DA_GRACE () ENDIF IF (p_is_worker) THEN -#ifdef CROP - CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) -#else CALL elm_patch%build (landelm, landpatch, use_frac = .true.) -#endif ENDIF IF (p_is_worker) THEN @@ -248,8 +242,8 @@ SUBROUTINE do_DA_GRACE (idate, deltim) CALL ncio_read_block_time (file_grace, 'uncertainty' , grid_grace, itime, f_grace_err) ENDIF - CALL mg2p_grace%map_aweighted (f_grace_lwe, lwe_obs_this) - CALL mg2p_grace%map_aweighted (f_grace_err, err_obs_this) + CALL mg2p_grace%grid2pset (f_grace_lwe, lwe_obs_this) + CALL mg2p_grace%grid2pset (f_grace_err, err_obs_this) IF (p_is_worker) THEN diff --git a/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 b/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 index 59aa50eb..b5b1291c 100644 --- a/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 +++ b/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 @@ -709,7 +709,7 @@ SUBROUTINE calc_riverdepth_from_runoff () USE MOD_Block USE MOD_Mesh USE MOD_Grid - USE MOD_Mapping_Grid2Pset + USE MOD_SpatialMapping USE MOD_LandElm USE MOD_ElmVector USE MOD_ElementNeighbour @@ -719,8 +719,8 @@ SUBROUTINE calc_riverdepth_from_runoff () ! Local Variables character(len=256) :: file_rnof, file_rivdpt type(grid_type) :: grid_rnof - type(block_data_real8_2d) :: f_rnof - type(mapping_grid2pset_type) :: mg2p_rnof + type(block_data_real8_2d) :: f_rnof + type(spatial_mapping_type) :: mg2p_rnof real(r8), allocatable :: bsnrnof(:) , bsndis(:) integer, allocatable :: nups_riv(:), iups_riv(:), b_up2down(:) @@ -739,7 +739,7 @@ SUBROUTINE calc_riverdepth_from_runoff () CALL grid_rnof%define_from_file (file_rnof, 'lat', 'lon') - CALL mg2p_rnof%build (grid_rnof, landelm) + CALL mg2p_rnof%build_arealweighted (grid_rnof, landelm) IF (p_is_io) THEN CALL allocate_block_data (grid_rnof, f_rnof) @@ -760,7 +760,7 @@ SUBROUTINE calc_riverdepth_from_runoff () IF (numelm > 0) allocate (bsnrnof (numelm)) ENDIF - CALL mg2p_rnof%map_aweighted (f_rnof, bsnrnof) + CALL mg2p_rnof%grid2pset (f_rnof, bsnrnof) IF (p_is_worker) THEN IF (numelm > 0) THEN diff --git a/main/MOD_Aerosol.F90 b/main/MOD_Aerosol.F90 index b2c3ad95..47cfa579 100644 --- a/main/MOD_Aerosol.F90 +++ b/main/MOD_Aerosol.F90 @@ -6,7 +6,7 @@ MODULE MOD_Aerosol USE MOD_Precision USE MOD_Grid USE MOD_DataType - USE MOD_Mapping_Grid2Pset + USE MOD_SpatialMapping USE MOD_Vars_Global, only: maxsnl IMPLICIT NONE SAVE @@ -27,8 +27,8 @@ MODULE MOD_Aerosol character(len=256) :: file_aerosol type(grid_type) :: grid_aerosol - type(block_data_real8_2d) :: f_aerdep - type(mapping_grid2pset_type) :: mg2p_aerdep + type(block_data_real8_2d) :: f_aerdep + type(spatial_mapping_type) :: mg2p_aerdep integer, parameter :: start_year = 1849 integer, parameter :: end_year = 2001 @@ -319,7 +319,7 @@ SUBROUTINE AerosolDepInit () CALL allocate_block_data (grid_aerosol, f_aerdep) - CALL mg2p_aerdep%build (grid_aerosol, landpatch) + CALL mg2p_aerdep%build_arealweighted (grid_aerosol, landpatch) month_p = -1 @@ -365,59 +365,59 @@ SUBROUTINE AerosolDepReadin (idate) ! BCPHIDRY , hydrophilic BC dry deposition CALL ncio_read_block_time (file_aerosol, 'BCPHIDRY', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(1,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(1,:)) ! BCPHODRY , hydrophobic BC dry deposition CALL ncio_read_block_time (file_aerosol, 'BCPHODRY', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(2,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(2,:)) ! BCDEPWET , hydrophilic BC wet deposition CALL ncio_read_block_time (file_aerosol, 'BCDEPWET', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(3,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(3,:)) ! OCPHIDRY , hydrophilic OC dry deposition CALL ncio_read_block_time (file_aerosol, 'OCPHIDRY', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(4,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(4,:)) ! OCPHODRY , hydrophobic OC dry deposition CALL ncio_read_block_time (file_aerosol, 'OCPHODRY', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(5,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(5,:)) ! OCDEPWET , hydrophilic OC wet deposition CALL ncio_read_block_time (file_aerosol, 'OCDEPWET', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(6,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(6,:)) ! DSTX01WD , DSTX01 wet deposition flux at bottom CALL ncio_read_block_time (file_aerosol, 'DSTX01WD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(7,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(7,:)) ! DSTX01DD , DSTX01 dry deposition flux at bottom CALL ncio_read_block_time (file_aerosol, 'DSTX01DD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(8,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(8,:)) ! DSTX02WD , DSTX02 wet deposition flux at bottom CALL ncio_read_block_time (file_aerosol, 'DSTX02WD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(9,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(9,:)) ! DSTX02DD , DSTX02 dry deposition flux at bottom CALL ncio_read_block_time (file_aerosol, 'DSTX02DD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(10,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(10,:)) ! DSTX03WD , DSTX03 wet deposition flux at bottom CALL ncio_read_block_time (file_aerosol, 'DSTX03WD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(11,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(11,:)) ! DSTX03DD , DSTX03 dry deposition flux at bottom CALL ncio_read_block_time (file_aerosol, 'DSTX03DD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(12,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(12,:)) ! DSTX04WD , DSTX04 wet deposition flux at bottom CALL ncio_read_block_time (file_aerosol, 'DSTX04WD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(13,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(13,:)) ! DSTX04DD , DSTX04 dry deposition flux at bottom CALL ncio_read_block_time (file_aerosol, 'DSTX04DD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(14,:)) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(14,:)) #ifdef RangeCheck !CALL check_block_data ('aerosol', f_aerdep) diff --git a/main/MOD_CropReadin.F90 b/main/MOD_CropReadin.F90 index 60709601..4ca4f395 100644 --- a/main/MOD_CropReadin.F90 +++ b/main/MOD_CropReadin.F90 @@ -28,7 +28,7 @@ SUBROUTINE CROP_readin () USE MOD_LandPatch USE MOD_NetCDFSerial USE MOD_NetCDFBlock - USE MOD_Mapping_Grid2Pset + USE MOD_SpatialMapping USE MOD_Vars_TimeInvariants USE MOD_Vars_TimeVariables @@ -42,13 +42,13 @@ SUBROUTINE CROP_readin () character(len=256) :: file_crop type(grid_type) :: grid_crop - type(block_data_real8_2d) :: f_xy_crop - type(mapping_grid2pset_type) :: mg2patch_crop - type(mapping_grid2pset_type) :: mg2pft_crop + type(block_data_real8_2d) :: f_xy_crop + type(spatial_mapping_type) :: mg2patch_crop + type(spatial_mapping_type) :: mg2pft_crop character(len=256) :: file_irrig type(grid_type) :: grid_irrig - type(block_data_int32_2d) :: f_xy_irrig - type(mapping_grid2pset_type) :: mg2pft_irrig + type(block_data_int32_2d) :: f_xy_irrig + type(spatial_mapping_type) :: mg2pft_irrig real(r8),allocatable :: pdrice2_tmp (:) real(r8),allocatable :: plantdate_tmp (:) @@ -87,8 +87,11 @@ SUBROUTINE CROP_readin () CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop) ENDIF - CALL mg2patch_crop%build (grid_crop, landpatch, f_xy_crop, missing_value) - CALL mg2pft_crop%build (grid_crop, landpft, f_xy_crop, missing_value) + CALL mg2patch_crop%build_arealweighted (grid_crop, landpatch) + CALL mg2patch_crop%set_missing_value (f_xy_crop, missing_value) + + CALL mg2pft_crop%build_arealweighted (grid_crop, landpft) + CALL mg2pft_crop%set_missing_value (f_xy_crop, missing_value) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) @@ -106,7 +109,7 @@ SUBROUTINE CROP_readin () CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop) ENDIF - CALL mg2patch_crop%map_aweighted (f_xy_crop, pdrice2_tmp) + CALL mg2patch_crop%grid2pset (f_xy_crop, pdrice2_tmp) IF (p_is_worker) THEN DO npatch = 1, numpatch @@ -134,7 +137,7 @@ SUBROUTINE CROP_readin () CALL ncio_read_block_time (file_crop, 'PLANTDATE_CFT_'//trim(cx), grid_crop, 1, f_xy_crop) ENDIF - CALL mg2pft_crop%map_aweighted (f_xy_crop, plantdate_tmp) + CALL mg2pft_crop%grid2pset (f_xy_crop, plantdate_tmp) IF (p_is_worker) THEN DO ipft = 1, numpft @@ -163,7 +166,7 @@ SUBROUTINE CROP_readin () CALL ncio_read_block_time (file_crop, 'CONST_FERTNITRO_CFT_'//trim(cx), grid_crop, 1, f_xy_crop) ENDIF - CALL mg2pft_crop%map_aweighted (f_xy_crop, fertnitro_tmp) + CALL mg2pft_crop%grid2pset (f_xy_crop, fertnitro_tmp) IF (p_is_worker) THEN DO ipft = 1, numpft @@ -194,7 +197,7 @@ SUBROUTINE CROP_readin () CALL allocate_block_data (grid_irrig, f_xy_irrig) ENDIF - CALL mg2pft_irrig%build (grid_irrig, landpft) + CALL mg2pft_irrig%build_arealweighted (grid_irrig, landpft) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) @@ -208,7 +211,7 @@ SUBROUTINE CROP_readin () CALL ncio_read_block_time (file_irrig, 'irrigation_method', grid_irrig, cft, f_xy_irrig) ENDIF - CALL mg2pft_irrig%map_max_frequency_2d (f_xy_irrig, irrig_method_tmp) + CALL mg2pft_irrig%grid2pset_dominant (f_xy_irrig, irrig_method_tmp) IF (p_is_worker) THEN DO ipft = 1, numpft diff --git a/main/MOD_FireData.F90 b/main/MOD_FireData.F90 index 82b0f2d8..74671fbc 100644 --- a/main/MOD_FireData.F90 +++ b/main/MOD_FireData.F90 @@ -10,7 +10,7 @@ MODULE MOD_FireData ! Lu Xingjie and Zhang Shupeng, 2023, prepare the original version of the fire data module. USE MOD_Grid - USE MOD_Mapping_Grid2Pset + USE MOD_SpatialMapping USE MOD_Vars_TimeInvariants, only: abm_lf, gdp_lf, peatf_lf USE MOD_Vars_TimeVariables, only: hdm_lf IMPLICIT NONE @@ -18,7 +18,7 @@ MODULE MOD_FireData character(len=256) :: file_fire type(grid_type) :: grid_fire - type(mapping_grid2pset_type) :: mg2p_fire + type(spatial_mapping_type) :: mg2p_fire CONTAINS @@ -52,7 +52,7 @@ SUBROUTINE init_fire_data (YY) CALL grid_fire%define_by_center (lat, lon) - CALL mg2p_fire%build (grid_fire, landpatch) + CALL mg2p_fire%build_arealweighted (grid_fire, landpatch) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) @@ -65,7 +65,7 @@ SUBROUTINE init_fire_data (YY) IF (p_is_io) THEN CALL ncio_read_block (file_fire, 'abm', grid_fire, f_xy_fire) ENDIF - CALL mg2p_fire%map_aweighted (f_xy_fire, abm_lf) + CALL mg2p_fire%grid2pset (f_xy_fire, abm_lf) #ifdef RangeCheck CALL check_vector_data ('abm', abm_lf) #endif @@ -74,7 +74,7 @@ SUBROUTINE init_fire_data (YY) IF (p_is_io) THEN CALL ncio_read_block (file_fire, 'peatf', grid_fire, f_xy_fire) ENDIF - CALL mg2p_fire%map_aweighted (f_xy_fire, peatf_lf) + CALL mg2p_fire%grid2pset (f_xy_fire, peatf_lf) #ifdef RangeCheck CALL check_vector_data ('peatf', peatf_lf) #endif @@ -83,7 +83,7 @@ SUBROUTINE init_fire_data (YY) IF (p_is_io) THEN CALL ncio_read_block (file_fire, 'gdp', grid_fire, f_xy_fire) ENDIF - CALL mg2p_fire%map_aweighted (f_xy_fire, gdp_lf) + CALL mg2p_fire%grid2pset (f_xy_fire, gdp_lf) #ifdef RangeCheck CALL check_vector_data ('gdp', gdp_lf) #endif @@ -126,7 +126,7 @@ SUBROUTINE update_hdm_data (YY) CALL ncio_read_block_time (file_fire, 'hdm', grid_fire, itime, f_xy_fire) ENDIF - CALL mg2p_fire%map_aweighted (f_xy_fire, hdm_lf) + CALL mg2p_fire%grid2pset (f_xy_fire, hdm_lf) #ifdef RangeCheck CALL check_vector_data ('hdm', hdm_lf) diff --git a/main/MOD_Forcing.F90 b/main/MOD_Forcing.F90 index c5eac5a4..4e0afc0d 100644 --- a/main/MOD_Forcing.F90 +++ b/main/MOD_Forcing.F90 @@ -20,8 +20,7 @@ MODULE MOD_Forcing USE MOD_Precision USE MOD_Namelist USE MOD_Grid - USE MOD_Mapping_Grid2Pset - USE MOD_InterpBilinear + USE MOD_SpatialMapping USE MOD_UserSpecifiedForcing USE MOD_TimeManager USE MOD_SPMD_Task @@ -33,14 +32,37 @@ MODULE MOD_Forcing type (grid_type), PUBLIC :: gforc - type (mapping_grid2pset_type) :: mg2p_forc ! area weighted mapping from forcing to model unit - type (interp_bilinear_type) :: forc_interp ! bilinear interpolation from forcing to model unit + type (spatial_mapping_type) :: mg2p_forc ! area weighted mapping from forcing to model unit logical, allocatable :: forcmask_pch (:) - logical, allocatable :: forcmask_elm (:) - + ! for Forcing_Downscaling - logical, allocatable :: glacierss (:) + type(block_data_real8_2d) :: topo_grid, maxelv_grid + type(block_data_real8_2d) :: sumarea_grid + + type(pointer_real8_1d), allocatable :: forc_topo_grid (:) + type(pointer_real8_1d), allocatable :: forc_maxelv_grid (:) + + type(pointer_real8_1d), allocatable :: forc_t_grid (:) + type(pointer_real8_1d), allocatable :: forc_th_grid (:) + type(pointer_real8_1d), allocatable :: forc_q_grid (:) + type(pointer_real8_1d), allocatable :: forc_pbot_grid (:) + type(pointer_real8_1d), allocatable :: forc_rho_grid (:) + type(pointer_real8_1d), allocatable :: forc_prc_grid (:) + type(pointer_real8_1d), allocatable :: forc_prl_grid (:) + type(pointer_real8_1d), allocatable :: forc_lwrad_grid(:) + type(pointer_real8_1d), allocatable :: forc_hgt_grid (:) + + type(pointer_real8_1d), allocatable :: forc_t_part (:) + type(pointer_real8_1d), allocatable :: forc_th_part (:) + type(pointer_real8_1d), allocatable :: forc_q_part (:) + type(pointer_real8_1d), allocatable :: forc_pbot_part (:) + type(pointer_real8_1d), allocatable :: forc_rhoair_part(:) + type(pointer_real8_1d), allocatable :: forc_prc_part (:) + type(pointer_real8_1d), allocatable :: forc_prl_part (:) + type(pointer_real8_1d), allocatable :: forc_frl_part (:) + + logical, allocatable :: glacierss (:) ! local variables integer :: deltim_int ! model time step length @@ -77,6 +99,7 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) USE MOD_SPMD_Task USE MOD_Namelist + USE MOD_Block USE MOD_DataType USE MOD_Mesh USE MOD_LandElm @@ -84,7 +107,6 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) #ifdef CROP USE MOD_LandCrop #endif - USE MOD_Mapping_Grid2Pset USE MOD_UserSpecifiedForcing USE MOD_NetCDFSerial USE MOD_NetCDFVector @@ -106,6 +128,9 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) real(r8) :: missing_value integer :: ielm, istt, iend + real(r8), allocatable :: vecone(:) + integer :: iblkme, xblk, yblk, xloc, yloc + CALL init_user_specified_forcing ! CO2 data initialization @@ -152,13 +177,9 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) ENDIF - IF (DEF_USE_Forcing_Downscaling) THEN - IF (p_is_worker) THEN -#if (defined CROP) - CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) -#else - CALL elm_patch%build (landelm, landpatch, use_frac = .true.) -#endif + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (forcmask_pch(numpatch)); forcmask_pch(:) = .true. ENDIF ENDIF @@ -168,17 +189,6 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) filename = trim(dir_forcing)//trim(metfilename(year, month, day, 1)) tstamp_LB(1) = timestamp(-1, -1, -1) - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - allocate (forcmask_pch(numpatch)); forcmask_pch(:) = .true. - ENDIF - IF (DEF_USE_Forcing_Downscaling) THEN - IF (numelm > 0) THEN - allocate (forcmask_elm(numelm)); forcmask_elm(:) = .true. - ENDIF - ENDIF - ENDIF - IF (p_is_master) THEN CALL ncio_get_attr (filename, vname(1), trim(DEF_forcing%missing_value_name), missing_value) ENDIF @@ -190,72 +200,65 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) ENDIF - IF (.not. DEF_USE_Forcing_Downscaling) THEN - - IF (.not. DEF_forcing%has_missing_value) THEN - - IF (trim(DEF_Forcing_Interp) == 'areaweight') THEN - CALL mg2p_forc%build (gforc, landpatch) - ELSEIF (trim(DEF_Forcing_Interp) == 'bilinear') THEN - CALL forc_interp%build (gforc, landpatch) - ENDIF - - ELSE - - IF (trim(DEF_Forcing_Interp) == 'areaweight') THEN - CALL mg2p_forc%build (gforc, landpatch, metdata, missing_value, forcmask_pch) - ELSEIF (trim(DEF_Forcing_Interp) == 'bilinear') THEN - CALL forc_interp%build (gforc, landpatch, metdata, missing_value, forcmask_pch) - ENDIF - - ENDIF - - ELSE - - IF (.not. DEF_forcing%has_missing_value) THEN - - IF (trim(DEF_Forcing_Interp) == 'areaweight') THEN - CALL mg2p_forc%build (gforc, landelm) - ELSEIF (trim(DEF_Forcing_Interp) == 'bilinear') THEN - CALL forc_interp%build (gforc, landelm) - ENDIF - - ELSE - - IF (trim(DEF_Forcing_Interp) == 'areaweight') THEN - CALL mg2p_forc%build (gforc, landelm, metdata, missing_value, forcmask_elm) - ELSEIF (trim(DEF_Forcing_Interp) == 'bilinear') THEN - CALL forc_interp%build (gforc, landelm, metdata, missing_value, forcmask_elm) - ENDIF - - IF (p_is_worker) THEN - DO ielm = 1, numelm - istt = elm_patch%substt(ielm) - iend = elm_patch%subend(ielm) - forcmask_pch(istt:iend) = forcmask_elm(ielm) - ENDDO - ENDIF + IF (trim(DEF_Forcing_Interp_Method) == 'arealweight') THEN + CALL mg2p_forc%build_arealweighted (gforc, landpatch) + ELSEIF (trim(DEF_Forcing_Interp_Method) == 'bilinear') THEN + CALL mg2p_forc%build_bilinear (gforc, landpatch) + ENDIF - ENDIF + IF (DEF_forcing%has_missing_value) THEN + CALL mg2p_forc%set_missing_value (metdata, missing_value, forcmask_pch) ENDIF IF (DEF_USE_Forcing_Downscaling) THEN - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - - forc_topo = topoelv - DO ielm = 1, numelm - istt = elm_patch%substt(ielm) - iend = elm_patch%subend(ielm) - forc_topo_elm(ielm) = sum(forc_topo(istt:iend) * elm_patch%subfrc(istt:iend)) - ENDDO + IF (p_is_worker .and. (numpatch > 0)) THEN + forc_topo = topoelv + WHERE(forc_topo == spval) forc_topo = 0. + ENDIF - allocate (glacierss(numpatch)) - glacierss(:) = patchtype(:) == 3 + IF (p_is_io) CALL allocate_block_data (gforc, topo_grid) + CALL mg2p_forc%pset2grid (forc_topo, topo_grid) + + IF (p_is_io) CALL allocate_block_data (gforc, sumarea_grid) + CALL mg2p_forc%get_sumarea (sumarea_grid) + + CALL block_data_division (topo_grid, sumarea_grid) + + IF (p_is_io) CALL allocate_block_data (gforc, maxelv_grid) + CALL mg2p_forc%pset2grid_max (forc_topo, maxelv_grid) + - ENDIF + CALL mg2p_forc%allocate_part (forc_topo_grid ) + CALL mg2p_forc%allocate_part (forc_maxelv_grid) + + CALL mg2p_forc%allocate_part (forc_t_grid ) + CALL mg2p_forc%allocate_part (forc_th_grid ) + CALL mg2p_forc%allocate_part (forc_q_grid ) + CALL mg2p_forc%allocate_part (forc_pbot_grid ) + CALL mg2p_forc%allocate_part (forc_rho_grid ) + CALL mg2p_forc%allocate_part (forc_prc_grid ) + CALL mg2p_forc%allocate_part (forc_prl_grid ) + CALL mg2p_forc%allocate_part (forc_lwrad_grid ) + CALL mg2p_forc%allocate_part (forc_hgt_grid ) + + CALL mg2p_forc%allocate_part (forc_t_part ) + CALL mg2p_forc%allocate_part (forc_th_part ) + CALL mg2p_forc%allocate_part (forc_q_part ) + CALL mg2p_forc%allocate_part (forc_pbot_part ) + CALL mg2p_forc%allocate_part (forc_rhoair_part) + CALL mg2p_forc%allocate_part (forc_prc_part ) + CALL mg2p_forc%allocate_part (forc_prl_part ) + CALL mg2p_forc%allocate_part (forc_frl_part ) + + CALL mg2p_forc%grid2part (topo_grid, forc_topo_grid ) + CALL mg2p_forc%grid2part (maxelv_grid, forc_maxelv_grid) + + IF (p_is_worker .and. (numpatch > 0)) THEN + allocate (glacierss(numpatch)) + glacierss(:) = patchtype(:) == 3 ENDIF + ENDIF forcing_read_ahead = .false. @@ -300,16 +303,46 @@ END SUBROUTINE forcing_init ! ---- forcing finalize ---- SUBROUTINE forcing_final () + USE MOD_LandPatch, only : numpatch IMPLICIT NONE IF (allocated(forcmask_pch)) deallocate(forcmask_pch) - IF (allocated(forcmask_elm)) deallocate(forcmask_elm) IF (allocated(glacierss )) deallocate(glacierss ) IF (allocated(forctime )) deallocate(forctime ) IF (allocated(iforctime )) deallocate(iforctime ) IF (allocated(forc_disk )) deallocate(forc_disk ) IF (allocated(tstamp_LB )) deallocate(tstamp_LB ) IF (allocated(tstamp_UB )) deallocate(tstamp_UB ) + + IF (DEF_USE_Forcing_Downscaling) THEN + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + deallocate (forc_topo_grid ) + deallocate (forc_maxelv_grid) + + deallocate (forc_t_grid ) + deallocate (forc_th_grid ) + deallocate (forc_q_grid ) + deallocate (forc_pbot_grid ) + deallocate (forc_rho_grid ) + deallocate (forc_prc_grid ) + deallocate (forc_prl_grid ) + deallocate (forc_lwrad_grid ) + deallocate (forc_hgt_grid ) + + deallocate (forc_t_part ) + deallocate (forc_th_part ) + deallocate (forc_q_part ) + deallocate (forc_pbot_part ) + deallocate (forc_rhoair_part) + deallocate (forc_prc_part ) + deallocate (forc_prl_part ) + deallocate (forc_frl_part ) + + ENDIF + ENDIF + ENDIF END SUBROUTINE forcing_final @@ -323,22 +356,6 @@ SUBROUTINE forcing_reset () END SUBROUTINE forcing_reset - ! ------------ - SUBROUTINE forcing_xy2vec (f_xy, f_vec) - - IMPLICIT NONE - - type(block_data_real8_2d) :: f_xy - real(r8) :: f_vec(:) - - IF (trim(DEF_Forcing_Interp) == 'areaweight') THEN - CALL mg2p_forc%map_aweighted (f_xy, f_vec) - ELSEIF (trim(DEF_Forcing_Interp) == 'bilinear') THEN - CALL forc_interp%interp (f_xy, f_vec) - ENDIF - - END SUBROUTINE forcing_xy2vec - !-------------------------------- SUBROUTINE read_forcing (idate, dir_forcing) @@ -353,10 +370,9 @@ SUBROUTINE read_forcing (idate, dir_forcing) USE MOD_DataType USE MOD_Mesh USE MOD_LandPatch - USE MOD_Mapping_Grid2Pset USE MOD_RangeCheck USE MOD_UserSpecifiedForcing - USE MOD_ForcingDownscaling, only : rair, cpair, downscale_forcings + USE MOD_ForcingDownscaling, only : rair, cpair, downscale_forcings_1c IMPLICIT NONE integer, intent(in) :: idate(3) @@ -364,7 +380,7 @@ SUBROUTINE read_forcing (idate, dir_forcing) ! local variables: integer :: ivar, istt, iend - integer :: iblkme, ib, jb, i, j, ilon, ilat, np, ne + integer :: iblkme, ib, jb, i, j, ilon, ilat, np, ipart, ne real(r8) :: calday ! Julian cal day (1.xx to 365.xx) real(r8) :: sunang, cloud, difrat, vnrat real(r8) :: a, hsolar, ratio_rvrf @@ -590,39 +606,38 @@ SUBROUTINE read_forcing (idate, dir_forcing) ! Mapping the 2d atmospheric fields [lon_points]x[lat_points] ! -> the 1d vector of subgrid points [numpatch] - CALL forcing_xy2vec (forc_xy_pco2m, forc_pco2m) - CALL forcing_xy2vec (forc_xy_po2m , forc_po2m ) - CALL forcing_xy2vec (forc_xy_us , forc_us ) - CALL forcing_xy2vec (forc_xy_vs , forc_vs ) + CALL mg2p_forc%grid2pset (forc_xy_pco2m, forc_pco2m) + CALL mg2p_forc%grid2pset (forc_xy_po2m , forc_po2m ) + CALL mg2p_forc%grid2pset (forc_xy_us , forc_us ) + CALL mg2p_forc%grid2pset (forc_xy_vs , forc_vs ) - CALL forcing_xy2vec (forc_xy_psrf , forc_psrf ) + CALL mg2p_forc%grid2pset (forc_xy_psrf , forc_psrf ) - CALL forcing_xy2vec (forc_xy_sols , forc_sols ) - CALL forcing_xy2vec (forc_xy_soll , forc_soll ) - CALL forcing_xy2vec (forc_xy_solsd, forc_solsd) - CALL forcing_xy2vec (forc_xy_solld, forc_solld) + CALL mg2p_forc%grid2pset (forc_xy_sols , forc_sols ) + CALL mg2p_forc%grid2pset (forc_xy_soll , forc_soll ) + CALL mg2p_forc%grid2pset (forc_xy_solsd, forc_solsd) + CALL mg2p_forc%grid2pset (forc_xy_solld, forc_solld) - CALL forcing_xy2vec (forc_xy_hgt_t, forc_hgt_t) - CALL forcing_xy2vec (forc_xy_hgt_u, forc_hgt_u) - CALL forcing_xy2vec (forc_xy_hgt_q, forc_hgt_q) + CALL mg2p_forc%grid2pset (forc_xy_hgt_t, forc_hgt_t) + CALL mg2p_forc%grid2pset (forc_xy_hgt_u, forc_hgt_u) + CALL mg2p_forc%grid2pset (forc_xy_hgt_q, forc_hgt_q) IF (DEF_USE_CBL_HEIGHT) THEN - CALL forcing_xy2vec (forc_xy_hpbl, forc_hpbl) + CALL mg2p_forc%grid2pset (forc_xy_hpbl, forc_hpbl) ENDIF - CALL forcing_xy2vec (forc_xy_t , forc_t ) - CALL forcing_xy2vec (forc_xy_q , forc_q ) - CALL forcing_xy2vec (forc_xy_prc , forc_prc ) - CALL forcing_xy2vec (forc_xy_prl , forc_prl ) - CALL forcing_xy2vec (forc_xy_pbot , forc_pbot ) - CALL forcing_xy2vec (forc_xy_frl , forc_frl ) + CALL mg2p_forc%grid2pset (forc_xy_t , forc_t ) + CALL mg2p_forc%grid2pset (forc_xy_q , forc_q ) + CALL mg2p_forc%grid2pset (forc_xy_prc , forc_prc ) + CALL mg2p_forc%grid2pset (forc_xy_prl , forc_prl ) + CALL mg2p_forc%grid2pset (forc_xy_pbot , forc_pbot ) + CALL mg2p_forc%grid2pset (forc_xy_frl , forc_frl ) IF (p_is_worker) THEN DO np = 1, numpatch - IF (DEF_forcing%has_missing_value) THEN - IF (.not. forcmask_pch(np)) CYCLE - ENDIF + + IF (.not. forcmask_pch(np)) CYCLE ! The standard measuring conditions for temperature are two meters above the ground ! Scientists have measured the most frigid temperature ever @@ -644,90 +659,87 @@ SUBROUTINE read_forcing (idate, dir_forcing) ! Mapping the 2d atmospheric fields [lon_points]x[lat_points] ! -> the 1d vector of subgrid points [numelm] - CALL forcing_xy2vec (forc_xy_pco2m, forc_pco2m_elm) - CALL forcing_xy2vec (forc_xy_po2m , forc_po2m_elm ) - CALL forcing_xy2vec (forc_xy_us , forc_us_elm ) - CALL forcing_xy2vec (forc_xy_vs , forc_vs_elm ) + CALL mg2p_forc%grid2pset (forc_xy_pco2m, forc_pco2m) + CALL mg2p_forc%grid2pset (forc_xy_po2m , forc_po2m ) + CALL mg2p_forc%grid2pset (forc_xy_us , forc_us ) + CALL mg2p_forc%grid2pset (forc_xy_vs , forc_vs ) - CALL forcing_xy2vec (forc_xy_psrf , forc_psrf_elm ) + CALL mg2p_forc%grid2pset (forc_xy_psrf , forc_psrf ) - CALL forcing_xy2vec (forc_xy_sols , forc_sols_elm ) - CALL forcing_xy2vec (forc_xy_soll , forc_soll_elm ) - CALL forcing_xy2vec (forc_xy_solsd, forc_solsd_elm) - CALL forcing_xy2vec (forc_xy_solld, forc_solld_elm) + CALL mg2p_forc%grid2pset (forc_xy_sols , forc_sols ) + CALL mg2p_forc%grid2pset (forc_xy_soll , forc_soll ) + CALL mg2p_forc%grid2pset (forc_xy_solsd, forc_solsd) + CALL mg2p_forc%grid2pset (forc_xy_solld, forc_solld) - CALL forcing_xy2vec (forc_xy_hgt_t, forc_hgt_t_elm) - CALL forcing_xy2vec (forc_xy_hgt_u, forc_hgt_u_elm) - CALL forcing_xy2vec (forc_xy_hgt_q, forc_hgt_q_elm) + CALL mg2p_forc%grid2pset (forc_xy_hgt_t, forc_hgt_t) + CALL mg2p_forc%grid2pset (forc_xy_hgt_u, forc_hgt_u) + CALL mg2p_forc%grid2pset (forc_xy_hgt_q, forc_hgt_q) IF (DEF_USE_CBL_HEIGHT) THEN - CALL forcing_xy2vec (forc_xy_hpbl, forc_hpbl_elm) + CALL mg2p_forc%grid2pset (forc_xy_hpbl, forc_hpbl) ENDIF - CALL forcing_xy2vec (forc_xy_t , forc_t_elm ) - CALL forcing_xy2vec (forc_xy_q , forc_q_elm ) - CALL forcing_xy2vec (forc_xy_prc , forc_prc_elm ) - CALL forcing_xy2vec (forc_xy_prl , forc_prl_elm ) - CALL forcing_xy2vec (forc_xy_pbot , forc_pbot_elm ) - CALL forcing_xy2vec (forc_xy_frl , forc_lwrad_elm) - CALL forcing_xy2vec (forc_xy_hgt_t, forc_hgt_elm ) + CALL mg2p_forc%grid2part (forc_xy_t , forc_t_grid ) + CALL mg2p_forc%grid2part (forc_xy_q , forc_q_grid ) + CALL mg2p_forc%grid2part (forc_xy_prc , forc_prc_grid ) + CALL mg2p_forc%grid2part (forc_xy_prl , forc_prl_grid ) + CALL mg2p_forc%grid2part (forc_xy_pbot , forc_pbot_grid ) + CALL mg2p_forc%grid2part (forc_xy_frl , forc_lwrad_grid) + CALL mg2p_forc%grid2part (forc_xy_hgt_t, forc_hgt_grid ) IF (p_is_worker) THEN - DO ne = 1, numelm - IF (DEF_forcing%has_missing_value) THEN - IF (.not. forcmask_elm(ne)) CYCLE - ENDIF - - istt = elm_patch%substt(ne) - iend = elm_patch%subend(ne) - - forc_pco2m(istt:iend) = forc_pco2m_elm (ne) - forc_po2m (istt:iend) = forc_po2m_elm (ne) - forc_us (istt:iend) = forc_us_elm (ne) - forc_vs (istt:iend) = forc_vs_elm (ne) - - forc_psrf (istt:iend) = forc_psrf_elm (ne) - - forc_sols (istt:iend) = forc_sols_elm (ne) - forc_soll (istt:iend) = forc_soll_elm (ne) - forc_solsd(istt:iend) = forc_solsd_elm (ne) - forc_solld(istt:iend) = forc_solld_elm (ne) - - forc_hgt_t(istt:iend) = forc_hgt_t_elm (ne) - forc_hgt_u(istt:iend) = forc_hgt_u_elm (ne) - forc_hgt_q(istt:iend) = forc_hgt_q_elm (ne) - - IF (DEF_USE_CBL_HEIGHT) THEN - forc_hpbl(istt:iend) = forc_hpbl_elm(ne) - ENDIF - - ! The standard measuring conditions for temperature are two meters above the ground - ! Scientists have measured the most frigid temperature ever - ! recorded on the continent's eastern highlands: about (180K) colder than dry ice. - IF(forc_t_elm(ne) < 180.) forc_t_elm(ne) = 180. - ! the highest air temp was found in Kuwait 326 K, Sulaibya 2012-07-31; - ! Pakistan, Sindh 2010-05-26; Iraq, Nasiriyah 2011-08-03 - IF(forc_t_elm(ne) > 326.) forc_t_elm(ne) = 326. - - forc_rho_elm(ne) = (forc_pbot_elm(ne) & - - 0.378*forc_q_elm(ne)*forc_pbot_elm(ne)/(0.622+0.378*forc_q_elm(ne)))& - / (rgas*forc_t_elm(ne)) - - forc_th_elm(ne) = forc_t_elm(ne) * (1.e5/forc_pbot_elm(ne)) ** (rair/cpair) - + DO np = 1, numpatch + DO ipart = 1, mg2p_forc%npart(np) + + IF (mg2p_forc%areapart(np)%val(ipart) == 0.) CYCLE + + ! The standard measuring conditions for temperature are two meters above + ! the ground. Scientists have measured the most frigid temperature ever + ! recorded on the continent's eastern highlands: about (180K) colder than + ! dry ice. + IF(forc_t_grid(np)%val(ipart) < 180.) forc_t_grid(np)%val(ipart) = 180. + ! the highest air temp was found in Kuwait 326 K, Sulaibya 2012-07-31; + ! Pakistan, Sindh 2010-05-26; Iraq, Nasiriyah 2011-08-03 + IF(forc_t_grid(np)%val(ipart) > 326.) forc_t_grid(np)%val(ipart) = 326. + + forc_rho_grid(np)%val(ipart) = (forc_pbot_grid(np)%val(ipart) & + - 0.378*forc_q_grid(np)%val(ipart)*forc_pbot_grid(np)%val(ipart) & + /(0.622+0.378*forc_q_grid(np)%val(ipart)))/(rgas*forc_t_grid(np)%val(ipart)) + + forc_th_grid(np)%val(ipart) = forc_t_grid(np)%val(ipart) & + * (1.e5/forc_pbot_grid(np)%val(ipart)) ** (rair/cpair) + + + CALL downscale_forcings_1c ( glacierss(np), & + ! forcing in gridcells + forc_topo_grid(np)%val(ipart), forc_maxelv_grid(np)%val(ipart), & + forc_t_grid(np)%val(ipart), forc_th_grid(np)%val(ipart), & + forc_q_grid(np)%val(ipart), forc_pbot_grid(np)%val(ipart), & + forc_rho_grid(np)%val(ipart), forc_prc_grid(np)%val(ipart), & + forc_prl_grid(np)%val(ipart), forc_lwrad_grid(np)%val(ipart), & + forc_hgt_grid(np)%val(ipart), & + ! forcing in part of patches + forc_topo(np), forc_t_part(np)%val(ipart), & + forc_th_part(np)%val(ipart), forc_q_part(np)%val(ipart), & + forc_pbot_part(np)%val(ipart), forc_rhoair_part(np)%val(ipart), & + forc_prc_part(np)%val(ipart), forc_prl_part(np)%val(ipart), & + forc_frl_part(np)%val(ipart)) + + ENDDO ENDDO - CALL downscale_forcings ( & - numelm, numpatch, elm_patch%substt, elm_patch%subend, glacierss, elm_patch%subfrc, & - ! forcing in gridcells - forc_topo_elm, forc_t_elm, forc_th_elm, forc_q_elm, forc_pbot_elm, & - forc_rho_elm, forc_prc_elm, forc_prl_elm, forc_lwrad_elm, forc_hgt_elm, & - ! forcing in patches - forc_topo, forc_t, forc_th, forc_q, forc_pbot, & - forc_rhoair, forc_prc, forc_prl, forc_frl) + ENDIF - ENDIF + CALL mg2p_forc%normalize (forc_xy_frl, forc_frl_part) + + CALL mg2p_forc%part2pset (forc_t_part, forc_t ) + CALL mg2p_forc%part2pset (forc_q_part, forc_q ) + CALL mg2p_forc%part2pset (forc_pbot_part, forc_pbot ) + CALL mg2p_forc%part2pset (forc_rhoair_part, forc_rhoair) + CALL mg2p_forc%part2pset (forc_prc_part, forc_prc ) + CALL mg2p_forc%part2pset (forc_prl_part, forc_prl ) + CALL mg2p_forc%part2pset (forc_frl_part, forc_frl ) ENDIF diff --git a/main/MOD_ForcingDownscaling.F90 b/main/MOD_ForcingDownscaling.F90 index ee95ebab..2b9eb300 100644 --- a/main/MOD_ForcingDownscaling.F90 +++ b/main/MOD_ForcingDownscaling.F90 @@ -45,11 +45,13 @@ MODULE MOD_ForcingDownscaling SAVE ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: downscale_forcings ! Downscale atm forcing fields from gridcell to column + PUBLIC :: downscale_forcings ! Downscale atm forcing fields from gridcell to column + PUBLIC :: downscale_forcings_1c ! Downscale atm forcing fields from gridcell to column ! PRIVATE MEMBER FUNCTIONS: - PRIVATE :: rhos ! calculate atmospheric density - PRIVATE :: downscale_longwave ! Downscale longwave radiation from gridcell to column + PRIVATE :: rhos ! calculate atmospheric density + PRIVATE :: downscale_longwave ! Downscale longwave radiation from gridcell to column + PRIVATE :: downscale_longwave_1c ! Downscale longwave radiation from gridcell to column !----------------------------------------------------------------------------- @@ -61,6 +63,8 @@ MODULE MOD_ForcingDownscaling SUBROUTINE downscale_forcings(& num_gridcells,num_columns,begc,endc,glaciers,wt_column,& + mask_g,& + !slp_c, asp_c, cur_c, svf_c, sf_c,& forc_topo_g ,forc_t_g ,forc_th_g ,forc_q_g ,forc_pbot_g ,& @@ -94,6 +98,8 @@ SUBROUTINE downscale_forcings(& logical, intent(in) :: glaciers (1:num_columns) ! true: glacier column (itypwat = 3) real(r8), intent(in) :: wt_column(1:num_columns) ! weight of the column relative to the grid cell + logical, intent(in) :: mask_g(1:num_columns) + ! topography factor !real(r8), intent(in) :: forc_slp_c(1:num_columns) ! slope factor !real(r8), intent(in) :: forc_asp_c(1:num_columns) ! aspect factor @@ -148,6 +154,9 @@ SUBROUTINE downscale_forcings(& ! Initialize column forcing (needs to be done for ALL active columns) DO g = 1, num_gridcells + + IF (.not. mask_g(g)) CYCLE + DO c = begc(g), endc(g) forc_t_c (c) = forc_t_g (g) forc_th_c (c) = forc_th_g (g) @@ -158,10 +167,10 @@ SUBROUTINE downscale_forcings(& forc_prl_c (c) = forc_prl_g (g) forc_lwrad_c(c) = forc_lwrad_g(g) END DO - END DO + ! END DO - ! Downscale forc_t, forc_th, forc_q, forc_pbot, and forc_rho to columns. - DO g = 1, num_gridcells + ! ! Downscale forc_t, forc_th, forc_q, forc_pbot, and forc_rho to columns. + ! DO g = 1, num_gridcells hsurf_g = forc_topo_g(g) ! gridcell sfc elevation tbot_g = forc_t_g(g) ! atm sfc temp thbot_g = forc_th_g(g) ! atm sfc pot temp @@ -274,7 +283,7 @@ SUBROUTINE downscale_forcings(& END DO END DO - CALL downscale_longwave(num_gridcells, num_columns, begc, endc, glaciers, wt_column, & + CALL downscale_longwave(num_gridcells, num_columns, begc, endc, glaciers, wt_column, mask_g,& forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, & forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c) @@ -316,7 +325,7 @@ END FUNCTION rhos !----------------------------------------------------------------------------- SUBROUTINE downscale_longwave(& - num_gridcells, num_columns, begc, endc, glaciers, wt_column, & + num_gridcells, num_columns, begc, endc, glaciers, wt_column, mask_g,& forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, & forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c) @@ -336,6 +345,8 @@ SUBROUTINE downscale_longwave(& logical, intent(in) :: glaciers (1:num_columns) ! true: glacier column real(r8), intent(in) :: wt_column (1:num_columns) ! weight of the column relative to the grid cell + logical, intent(in) :: mask_g(1:num_columns) + real(r8), intent(in) :: forc_topo_g (1:num_gridcells) ! atmospheric surface height (m) real(r8), intent(in) :: forc_t_g (1:num_gridcells) ! atmospheric temperature [Kelvin] real(r8), intent(in) :: forc_q_g (1:num_gridcells) ! atmospheric specific humidity [kg/kg] @@ -370,22 +381,25 @@ SUBROUTINE downscale_longwave(& ! Initialize column forcing (needs to be done for ALL active columns) DO g = 1, num_gridcells + + IF (.not. mask_g(g)) CYCLE + DO c = begc(g), endc(g) forc_lwrad_c(c) = forc_lwrad_g(g) END DO - END DO + ! END DO ! Downscale the longwave radiation, conserving energy ! Initialize variables related to normalization - DO g = 1, num_gridcells + ! DO g = 1, num_gridcells sum_lwrad_g(g) = 0._r8 sum_wts_g(g) = 0._r8 newsum_lwrad_g(g) = 0._r8 - END DO + ! END DO ! Do the downscaling - DO g = 1, num_gridcells + ! DO g = 1, num_gridcells DO c = begc(g), endc(g) hsurf_g = forc_topo_g(g) @@ -463,10 +477,10 @@ SUBROUTINE downscale_longwave(& newsum_lwrad_g(g) = newsum_lwrad_g(g) + wt_column(c)*forc_lwrad_c(c) END DO - END DO + ! END DO ! Make sure that, after normalization, the grid cell mean is conserved - DO g = 1, num_gridcells + ! DO g = 1, num_gridcells IF (sum_wts_g(g) > 0._r8) THEN IF (abs((newsum_lwrad_g(g) / sum_wts_g(g)) - forc_lwrad_g(g)) > 1.e-8_r8) THEN write(6,*) 'g, newsum_lwrad_g, sum_wts_g, forc_lwrad_g: ', & @@ -479,4 +493,283 @@ SUBROUTINE downscale_longwave(& END SUBROUTINE downscale_longwave + + !----------------------------------------------------------------------------- + + SUBROUTINE downscale_forcings_1c (& + glaciers, & + + !slp_c, asp_c, cur_c, svf_c, sf_c,& + + forc_topo_g ,forc_maxelv_g ,forc_t_g ,forc_th_g ,forc_q_g ,& + forc_pbot_g ,forc_rho_g ,forc_prc_g ,forc_prl_g ,forc_lwrad_g ,& + forc_hgt_grc,& + !forc_us_g ,forc_vs_g ,forc_swrad_g,& + + forc_topo_c ,forc_t_c ,forc_th_c ,forc_q_c ,forc_pbot_c ,& + forc_rho_c ,forc_prc_c ,forc_prl_c ,forc_lwrad_c) + !forc_swrad_c,forc_us_c ,forc_vs_c) + +!----------------------------------------------------------------------------- +! DESCRIPTION: +! Downscale atmospheric forcing fields from gridcell to column. +! +! Downscaling is done based on the difference between each land model column's elevation and +! the atmosphere's surface elevation (which is the elevation at which the atmospheric +! forcings are valid). +! +! Note that the downscaling procedure can result in changes in grid cell mean values +! compared to what was provided by the atmosphere. We conserve fluxes of mass and +! energy, but allow states such as temperature to differ. +!----------------------------------------------------------------------------- + + IMPLICIT NONE + + ! ARGUMENTS: + logical, intent(in) :: glaciers ! true: glacier column (itypwat = 3) + + ! Gridcell-level non-downscaled fields: + real(r8), intent(in) :: forc_topo_g ! atmospheric surface height [m] + real(r8), intent(in) :: forc_maxelv_g ! max atmospheric surface height [m] + real(r8), intent(in) :: forc_t_g ! atmospheric temperature [Kelvin] + real(r8), intent(in) :: forc_th_g ! atmospheric potential temperature [Kelvin] + real(r8), intent(in) :: forc_q_g ! atmospheric specific humidity [kg/kg] + real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa] + real(r8), intent(in) :: forc_rho_g ! atmospheric density [kg/m**3] + real(r8), intent(in) :: forc_prc_g ! convective precipitation in grid [mm/s] + real(r8), intent(in) :: forc_prl_g ! large-scale precipitation in grid [mm/s] + real(r8), intent(in) :: forc_lwrad_g ! grid downward longwave [W/m**2] + real(r8), intent(in) :: forc_hgt_grc ! atmospheric reference height [m] + + ! Column-level downscaled fields: + real(r8), intent(in) :: forc_topo_c ! column surface height [m] + real(r8), intent(out) :: forc_t_c ! atmospheric temperature [Kelvin] + real(r8), intent(out) :: forc_th_c ! atmospheric potential temperature [Kelvin] + real(r8), intent(out) :: forc_q_c ! atmospheric specific humidity [kg/kg] + real(r8), intent(out) :: forc_pbot_c ! atmospheric pressure [Pa] + real(r8), intent(out) :: forc_rho_c ! atmospheric density [kg/m**3] + real(r8), intent(out) :: forc_prc_c ! column convective precipitation [mm/s] + real(r8), intent(out) :: forc_prl_c ! column large-scale precipitation [mm/s] + real(r8), intent(out) :: forc_lwrad_c ! column downward longwave [W/m**2] + + ! Local variables for topo downscaling: + + real(r8) :: hsurf_g, hsurf_c + real(r8) :: Hbot, zbot + real(r8) :: tbot_g, pbot_g, thbot_g, qbot_g, qs_g, es_g, rhos_g + real(r8) :: tbot_c, pbot_c, thbot_c, qbot_c, qs_c, es_c, rhos_c + real(r8) :: rhos_c_estimate, rhos_g_estimate + real(r8) :: dum1, dum2 + + real(r8) :: max_elev_c ! the maximum column level elevation value within the grid + real(r8) :: delta_prc_c ! deviation of the column convective precipitation from the grid level precipitation + real(r8) :: delta_prl_c ! deviation of the column large-scale precipitation from the grid level precipitation + + + ! ! Downscale forc_t, forc_th, forc_q, forc_pbot, and forc_rho to columns. + hsurf_g = forc_topo_g ! gridcell sfc elevation + tbot_g = forc_t_g ! atm sfc temp + thbot_g = forc_th_g ! atm sfc pot temp + qbot_g = forc_q_g ! atm sfc spec humid + pbot_g = forc_pbot_g ! atm sfc pressure + rhos_g = forc_rho_g ! atm density + zbot = forc_hgt_grc ! atm ref height + + ! This is a simple downscaling procedure + ! Note that forc_hgt, forc_u, forc_v and solar radiation are not downscaled. + + !asp_c = forc_asp_c(c) + !cur_c = forc_cur_c(c) + + hsurf_c = forc_topo_c ! column sfc elevation + tbot_c = tbot_g-lapse_rate*(hsurf_c-hsurf_g) ! adjust temp for column + Hbot = rair*0.5_r8*(tbot_g+tbot_c)/grav ! scale ht at avg temp + pbot_c = pbot_g*exp(-(hsurf_c-hsurf_g)/Hbot) ! adjust press for column + + ! Derivation of potential temperature calculation: + ! + ! The textbook definition would be: + ! thbot_c = tbot_c * (p0/pbot_c)^(rair/cpair) + ! + ! Note that pressure is related to scale height as: + ! pbot_c = p0 * exp(-zbot/Hbot) + ! + ! Plugging this in to the textbook definition, then manipulating, we get: + ! thbot_c = tbot_c * (p0/(p0*exp(-zbot/Hbot)))^(rair/cpair) + ! = tbot_c * (1/exp(-zbot/Hbot))^(rair/cpair) + ! = tbot_c * (exp(zbot/Hbot))^(rair/cpair) + ! = tbot_c * exp((zbot/Hbot) * (rair/cpair)) + + ! But we want everything expressed in delta form, resulting in: + thbot_c = thbot_g + (tbot_c - tbot_g)*exp((zbot/Hbot)*(rair/cpair)) ! adjust pot temp for column + + CALL Qsadv(tbot_g,pbot_g,es_g,dum1,qs_g,dum2) ! es, qs for gridcell + CALL Qsadv(tbot_c,pbot_c,es_c,dum1,qs_c,dum2) ! es, qs for column + qbot_c = qbot_g*(qs_c/qs_g) ! adjust q for column + + rhos_c_estimate = rhos(qbot=qbot_c, pbot=pbot_c, tbot=tbot_c) + rhos_g_estimate = rhos(qbot=qbot_g, pbot=pbot_g, tbot=tbot_g) + rhos_c = rhos_g * (rhos_c_estimate / rhos_g_estimate) ! adjust density for column + + forc_t_c = tbot_c + forc_th_c = thbot_c + forc_q_c = qbot_c + forc_pbot_c = pbot_c + forc_rho_c = rhos_c + + ! adjust precipitation + IF (trim(DEF_DS_precipitation_adjust_scheme) == 'I') THEN + ! Tesfa et al, 2020: Exploring Topography-Based Methods for Downscaling + ! Subgrid Precipitation for Use in Earth System Models. Equation (5) + ! https://doi.org/ 10.1029/2019JD031456 + + delta_prc_c = forc_prc_g * (forc_topo_c - forc_topo_g) / forc_maxelv_g + forc_prc_c = forc_prc_g + delta_prc_c ! convective precipitation [mm/s] + + delta_prl_c = forc_prl_g * (forc_topo_c - forc_topo_g) / forc_maxelv_g + forc_prl_c = forc_prl_g + delta_prl_c ! large scale precipitation [mm/s] + + ELSEIF (trim(DEF_DS_precipitation_adjust_scheme) == 'II') THEN + ! Liston, G. E. and Elder, K.: A meteorological distribution system + ! for high-resolution terrestrial modeling (MicroMet), J. Hydrometeorol., 7, 217-234, 2006. + ! Equation (33) and Table 1: chi range from January to December: + ! [0.35,0.35,0.35,0.30,0.25,0.20,0.20,0.20,0.20,0.25,0.30,0.35] (1/m) + + delta_prc_c = forc_prc_g * 2.0*0.27e-3*(forc_topo_c - forc_topo_g) & + /(1.0 - 0.27e-3*(forc_topo_c - forc_topo_g)) + forc_prc_c = forc_prc_g + delta_prc_c ! large scale precipitation [mm/s] + + delta_prl_c = forc_prl_g * 2.0*0.27e-3*(forc_topo_c - forc_topo_g) & + /(1.0 - 0.27e-3*(forc_topo_c - forc_topo_g)) + forc_prl_c = forc_prl_g + delta_prl_c ! large scale precipitation [mm/s] + + ELSEIF (trim(DEF_DS_precipitation_adjust_scheme) == 'III') THEN + ! Mei, Y., Maggioni, V., Houser, P., Xue, Y., & Rouf, T. (2020). A nonparametric statistical + ! technique for spatial downscaling of precipitation over High Mountain Asia. Water Resources Research, + ! 56, e2020WR027472. https://doi.org/ 10.1029/2020WR027472 + ! Change Random forest model to AutoML model. + !TODO: Lu Li; Need to done after all other forcings are downscaled + END IF + + IF (forc_prl_c < 0) THEN + write(*,*) 'negative prl', forc_prl_g, forc_maxelv_g, forc_topo_c, forc_topo_g + forc_prl_c = 0. + END IF + + IF (forc_prc_c < 0) THEN + write(*,*) 'negative prc', forc_prc_g, forc_maxelv_g, forc_topo_c, forc_topo_g + forc_prc_c = 0. + END IF + + + CALL downscale_longwave_1c (glaciers, & + forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, & + forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c) + + END SUBROUTINE downscale_forcings_1c + + + +!----------------------------------------------------------------------------- + + SUBROUTINE downscale_longwave_1c (glaciers, & + forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, & + forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c) + +!----------------------------------------------------------------------------- +! DESCRIPTION: +! Downscale longwave radiation from gridcell to column +! Must be done AFTER temperature downscaling +!----------------------------------------------------------------------------- + + IMPLICIT NONE + + ! ARGUMENTS: + logical, intent(in) :: glaciers ! true: glacier column + + real(r8), intent(in) :: forc_topo_g ! atmospheric surface height (m) + real(r8), intent(in) :: forc_t_g ! atmospheric temperature [Kelvin] + real(r8), intent(in) :: forc_q_g ! atmospheric specific humidity [kg/kg] + real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa] + real(r8), intent(in) :: forc_lwrad_g ! downward longwave (W/m**2) + real(r8), intent(in) :: forc_topo_c ! column surface height (m) + real(r8), intent(in) :: forc_t_c ! atmospheric temperature [Kelvin] + real(r8), intent(in) :: forc_q_c ! atmospheric specific humidity [kg/kg] + real(r8), intent(in) :: forc_pbot_c ! atmospheric pressure [Pa] + real(r8), intent(out) :: forc_lwrad_c ! downward longwave (W/m**2) + + ! LOCAL VARIABLES: + real(r8) :: hsurf_c ! column-level elevation (m) + real(r8) :: hsurf_g ! gridcell-level elevation (m) + + real(r8) :: pv_g ! the water vapor pressure at grid cell (hPa) + real(r8) :: pv_c ! the water vapor pressure at column (hPa) + real(r8) :: emissivity_clearsky_g ! clear-sky emissivity at grid cell + real(r8) :: emissivity_clearsky_c ! clear-sky emissivity at grid column + real(r8) :: emissivity_allsky_g ! all-sky emissivity at grid cell + real(r8) :: es_g, es_c, dum1, dum2, dum3 + + real(r8), parameter :: lapse_rate_longwave = 0.032_r8 ! longwave radiation lapse rate (W m-2 m-1) + real(r8), parameter :: longwave_downscaling_limit = 0.5_r8 ! relative limit for how much longwave downscaling can be done (unitless) + + !-------------------------------------------------------------------------- + + ! Initialize column forcing (needs to be done for ALL active columns) + forc_lwrad_c = forc_lwrad_g + + ! Do the downscaling + + hsurf_g = forc_topo_g + hsurf_c = forc_topo_c + + IF (trim(DEF_DS_longwave_adjust_scheme) == 'I') THEN + ! Fiddes and Gruber, 2014, TopoSCALE v.1.0: downscaling gridded climate data in + ! complex terrain. Geosci. Model Dev., 7, 387-405. doi:10.5194/gmd-7-387-2014. + ! Equation (1) (2) (3); here, the empirical parameters x1 and x2 are different from + ! Konzelmann et al. (1994) where x1 = 0.443 and x2 = 8 (optimal for measurements on the Greenland ice sheet) + + CALL Qsadv(forc_t_g, forc_pbot_g, es_g,dum1,dum2,dum3) + CALL Qsadv(forc_t_c, forc_pbot_c, es_c,dum1,dum2,dum3) + pv_g = forc_q_g*es_g/100._r8 ! (hPa) + pv_c = forc_q_c*es_c/100._r8 ! (hPa) + + emissivity_clearsky_g = 0.23_r8 + 0.43_r8*(pv_g/forc_t_g)**(1._r8/5.7_r8) + emissivity_clearsky_c = 0.23_r8 + 0.43_r8*(pv_c/forc_t_c)**(1._r8/5.7_r8) + emissivity_allsky_g = forc_lwrad_g / (5.67e-8_r8*forc_t_g**4) + + forc_lwrad_c = & + (emissivity_clearsky_c + (emissivity_allsky_g - emissivity_clearsky_g)) & + * 5.67e-8_r8*forc_t_c**4 + ELSE + ! Longwave radiation is downscaled by assuming a linear decrease in downwelling longwave radiation + ! with increasing elevation (0.032 W m-2 m-1, limited to 0.5 - 1.5 times the gridcell mean value, + ! then normalized to conserve gridcell total energy) (Van Tricht et al., 2016, TC) Figure 6, + ! doi:10.5194/tc-10-2379-2016 + + IF (glaciers) THEN + forc_lwrad_c = forc_lwrad_g - lapse_rate_longwave * (hsurf_c-hsurf_g) + + ! Here we assume that deltaLW = (dLW/dT)*(dT/dz)*deltaz + ! We get dLW/dT = 4*eps*sigma*T^3 = 4*LW/T from the Stefan-Boltzmann law, + ! evaluated at the mean temp. We assume the same temperature lapse rate as above. + + ELSE + forc_lwrad_c = forc_lwrad_g & + - 4.0_r8 * forc_lwrad_g/(0.5_r8*(forc_t_c+forc_t_g)) & + * lapse_rate * (hsurf_c - hsurf_g) + END IF + END IF + + ! But ensure that we don't depart too far from the atmospheric forcing value: + ! negative values of lwrad are certainly bad, but small positive values might + ! also be bad. We can especially run into trouble due to the normalization: a + ! small lwrad value in one column can lead to a big normalization factor, + ! leading to huge lwrad values in other columns. + + forc_lwrad_c = min(forc_lwrad_c, forc_lwrad_g * (1._r8 + longwave_downscaling_limit)) + forc_lwrad_c = max(forc_lwrad_c, forc_lwrad_g * (1._r8 - longwave_downscaling_limit)) + + + END SUBROUTINE downscale_longwave_1c + END MODULE MOD_ForcingDownscaling diff --git a/main/MOD_Hist.F90 b/main/MOD_Hist.F90 index b2f50e27..248b7c0f 100644 --- a/main/MOD_Hist.F90 +++ b/main/MOD_Hist.F90 @@ -107,7 +107,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & USE MOD_Block USE MOD_DataType USE MOD_LandPatch - USE MOD_Mapping_Pset2Grid + USE MOD_SpatialMapping USE MOD_Vars_TimeInvariants, only: patchtype, patchclass, patchmask #ifdef URBAN_MODEL USE MOD_LandUrban @@ -149,13 +149,11 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & type(block_data_real8_2d) :: sumarea type(block_data_real8_2d) :: sumarea_urb - real(r8), allocatable :: VecOnes(:) real(r8), allocatable :: vecacc (:) logical, allocatable :: filter (:) integer i, u #ifdef URBAN_MODEL - real(r8), allocatable :: VecOnes_urb(:) logical, allocatable :: filter_urb (:) #endif @@ -227,16 +225,12 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & IF (p_is_worker) THEN IF (numpatch > 0) THEN - allocate (filter (numpatch)) - allocate (VecOnes (numpatch)) - allocate (vecacc (numpatch)) - VecOnes(:) = 1.0_r8 + allocate (filter (numpatch)) + allocate (vecacc (numpatch)) ENDIF #ifdef URBAN_MODEL IF (numurban > 0) THEN - allocate (filter_urb (numurban)) - allocate (VecOnes_urb (numurban)) - VecOnes_urb(:) = 1.0_r8 + allocate (filter_urb (numurban)) ENDIF #endif ENDIF @@ -267,13 +261,15 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF IF (HistForm == 'Gridded') THEN IF (itime_in_file == 1) THEN CALL hist_write_var_real8_2d (file_hist, 'landarea', ghist, 1, sumarea, & compress = 1, longname = 'land area', units = 'km2') + CALL hist_write_var_real8_2d (file_hist, 'landfraction', ghist, 1, landfraction, & + compress = 1, longname = 'land fraction', units = '-') ENDIF ENDIF @@ -356,7 +352,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! wind stress: E-W [kg/m/s2] @@ -680,7 +676,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist_urb%map (VecOnes_urb, sumarea_urb, spv = spval, msk = filter_urb) + CALL mp2g_hist_urb%get_sumarea (sumarea_urb, filter_urb) ENDIF ! sensible heat from building roof [W/m2] @@ -797,7 +793,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! 1: assimsun enf temperate @@ -1339,7 +1335,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! 1: gpp enf temperate @@ -1501,7 +1497,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF IF (p_is_worker) THEN @@ -1532,7 +1528,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%pdcorn, & @@ -1556,7 +1552,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%pdswheat, & @@ -1580,7 +1576,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%pdwwheat, & @@ -1605,7 +1601,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%pdsoybean, & @@ -1629,7 +1625,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%pdcotton, & @@ -1653,7 +1649,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%pdrice1, & @@ -1677,7 +1673,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%pdrice2, & @@ -1701,7 +1697,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%pdsugarcane, & @@ -1726,7 +1722,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_corn, & @@ -1750,7 +1746,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_swheat, & @@ -1774,7 +1770,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_wwheat, & @@ -1799,7 +1795,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_soybean, & @@ -1823,7 +1819,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_cotton, & @@ -1847,7 +1843,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_rice1, & @@ -1871,7 +1867,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_rice2, & @@ -1895,7 +1891,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_sugarcane, & @@ -1920,7 +1916,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_corn, & @@ -1944,7 +1940,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_swheat, & @@ -1968,7 +1964,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_wwheat, & @@ -1993,7 +1989,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_soybean, & @@ -2017,7 +2013,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_cotton, & @@ -2041,7 +2037,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_rice1, & @@ -2065,7 +2061,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_rice2, & @@ -2089,7 +2085,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_sugarcane, & @@ -2115,7 +2111,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of rainfed temperate corn @@ -2145,7 +2141,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of irrigated temperate corn @@ -2176,7 +2172,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of rainfed spring wheat @@ -2207,7 +2203,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of irrigated spring wheat @@ -2237,7 +2233,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of rainfed winter wheat @@ -2267,7 +2263,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of irrigated winter wheat @@ -2297,7 +2293,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of rainfed temperate soybean @@ -2327,7 +2323,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of irrigated temperate soybean @@ -2357,7 +2353,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of rainfed cotton @@ -2387,7 +2383,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of irrigated cotton @@ -2417,7 +2413,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of rainfed rice @@ -2447,7 +2443,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of irrigated rice @@ -2477,7 +2473,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of rainfed sugarcane @@ -2507,7 +2503,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of irrigated sugarcane @@ -2537,7 +2533,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of rainfed trop corn @@ -2567,7 +2563,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of irrigated trop corn @@ -2597,7 +2593,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of rainfed trop soybean @@ -2627,7 +2623,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of irrigated trop soybean @@ -2658,7 +2654,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! planting date of unmanaged crop production @@ -2688,7 +2684,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to corn production carbon @@ -2718,7 +2714,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to corn production carbon @@ -2748,7 +2744,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to spring wheat production carbon @@ -2778,7 +2774,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to spring wheat production carbon @@ -2808,7 +2804,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to winter wheat production carbon @@ -2838,7 +2834,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to winter wheat production carbon @@ -2868,7 +2864,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to soybean production carbon @@ -2898,7 +2894,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to soybean production carbon @@ -2928,7 +2924,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to cotton production carbon @@ -2958,7 +2954,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to cotton production carbon @@ -2988,7 +2984,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to rice production carbon @@ -3018,7 +3014,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to rice production carbon @@ -3048,7 +3044,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to sugarcane production carbon @@ -3078,7 +3074,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to sugarcane production carbon @@ -3108,7 +3104,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to sugarcane production carbon @@ -3138,7 +3134,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to sugarcane production carbon @@ -3168,7 +3164,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to sugarcane production carbon @@ -3198,7 +3194,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to sugarcane production carbon @@ -3228,7 +3224,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! grain to unmanaged crop production carbon @@ -3262,7 +3258,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! soil temperature [K] @@ -3300,7 +3296,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! volumetric soil water in layers [m3/m3] @@ -3343,7 +3339,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! water storage in aquifer [mm] @@ -3388,7 +3384,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! lake temperature [K] @@ -3418,7 +3414,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! u* in similarity theory [m/s] @@ -3537,7 +3533,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF ! incident direct beam vis solar radiation at local noon (W/m2) @@ -3593,11 +3589,9 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & CALL hist_basin_out (file_hist, idate) #endif - IF (allocated(filter )) deallocate (filter ) - IF (allocated(VecOnes)) deallocate (VecOnes) + IF (allocated(filter)) deallocate (filter) #ifdef URBAN_MODEL - IF (allocated(filter_urb )) deallocate(filter_urb ) - IF (allocated(VecOnes_urb)) deallocate(VecOnes_urb) + IF (allocated(filter_urb)) deallocate(filter_urb) #endif CALL FLUSH_acc_fluxes () diff --git a/main/MOD_HistGridded.F90 b/main/MOD_HistGridded.F90 index 5bddd60f..6b40edbd 100644 --- a/main/MOD_HistGridded.F90 +++ b/main/MOD_HistGridded.F90 @@ -1,6 +1,6 @@ #include -module MOD_HistGridded +MODULE MOD_HistGridded !---------------------------------------------------------------------------- ! DESCRIPTION: @@ -15,9 +15,10 @@ module MOD_HistGridded ! TODO...(need complement) !---------------------------------------------------------------------------- - use MOD_Precision - use MOD_Grid - use MOD_Mapping_Pset2Grid + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SpatialMapping USE MOD_Namelist USE MOD_NetCDFSerial #ifdef USEMPI @@ -25,82 +26,99 @@ module MOD_HistGridded #endif type(grid_type), target :: ghist - type(mapping_pset2grid_type) :: mp2g_hist - type(mapping_pset2grid_type) :: mp2g_hist_urb + type(spatial_mapping_type) :: mp2g_hist + type(spatial_mapping_type) :: mp2g_hist_urb - TYPE(grid_concat_type) :: hist_concat + type(block_data_real8_2d) :: landfraction + + type(grid_concat_type) :: hist_concat integer :: hist_data_id !-------------------------------------------------------------------------- -contains +CONTAINS !--------------------------------------- - subroutine hist_gridded_init (dir_hist) + SUBROUTINE hist_gridded_init (dir_hist) USE MOD_Vars_Global USE MOD_Namelist - use MOD_Grid + USE MOD_Block USE MOD_LandPatch #ifdef URBAN_MODEL USE MOD_LandUrban #endif -#ifdef CROP - USE MOD_LandCrop -#endif - use MOD_Mapping_Pset2Grid - use MOD_Vars_1DAccFluxes + USE MOD_Vars_1DAccFluxes USE MOD_Forcing, only : gforc #ifdef SinglePoint USE MOD_SingleSrfData #endif - implicit none + USE MOD_Utils + IMPLICIT NONE character(len=*), intent(in) :: dir_hist + type(block_data_real8_2d) :: gridarea + integer :: iblkme, xblk, yblk, xloc, yloc, xglb, yglb - IF (DEF_hist_grid_as_forcing) then + IF (DEF_hist_grid_as_forcing) THEN CALL ghist%define_by_copy (gforc) ELSE - call ghist%define_by_res (DEF_hist_lon_res, DEF_hist_lat_res) + CALL ghist%define_by_res (DEF_hist_lon_res, DEF_hist_lat_res) ENDIF -#ifndef CROP - call mp2g_hist%build (landpatch, ghist) -#else - call mp2g_hist%build (landpatch, ghist, pctshrpch) -#endif + CALL mp2g_hist%build_arealweighted (ghist, landpatch) #ifdef URBAN_MODEL - CALL mp2g_hist_urb%build (landurban, ghist) + CALL mp2g_hist_urb%build_arealweighted (ghist, landurban) #endif + + IF (p_is_io) THEN + CALL allocate_block_data (ghist, landfraction) + CALL allocate_block_data (ghist, gridarea) - call hist_concat%set (ghist) + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + DO yloc = 1, ghist%ycnt(yblk) + DO xloc = 1, ghist%xcnt(xblk) + xglb = ghist%xdsp(xblk) + xloc + yglb = ghist%ydsp(yblk) + yloc + gridarea%blk(xblk,yblk)%val(xloc,yloc) = areaquad ( & + ghist%lat_s(yglb), ghist%lat_n(yglb), ghist%lon_w(xglb), ghist%lon_e(xglb)) + ENDDO + ENDDO + ENDDO + ENDIF + + CALL mp2g_hist%get_sumarea (landfraction) + CALL block_data_division (landfraction, gridarea) + + CALL hist_concat%set (ghist) #ifdef SinglePoint hist_concat%ginfo%lat_c(:) = SITE_lat_location hist_concat%ginfo%lon_c(:) = SITE_lon_location #endif - if (trim(DEF_HIST_mode) == 'one') then + IF (trim(DEF_HIST_mode) == 'one') THEN hist_data_id = 1 - end if + ENDIF - end subroutine hist_gridded_init + END SUBROUTINE hist_gridded_init ! ------- - subroutine flux_map_and_write_2d ( & + SUBROUTINE flux_map_and_write_2d ( & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & longname, units) - use MOD_Precision - use MOD_SPMD_Task - use MOD_Namelist - use MOD_DataType - use MOD_Mapping_Pset2Grid - use MOD_Block - use MOD_Grid - use MOD_Vars_1DAccFluxes, only: nac - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Block + USE MOD_Grid + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE real(r8), intent(inout) :: acc_vec(:) character(len=*), intent(in) :: file_hist @@ -117,56 +135,55 @@ subroutine flux_map_and_write_2d ( & integer :: iblkme, xblk, yblk, xloc, yloc integer :: compress - if (p_is_worker) where (acc_vec /= spval) acc_vec = acc_vec / nac - IF (p_is_io) call allocate_block_data (ghist, flux_xy_2d) + IF (p_is_worker) WHERE (acc_vec /= spval) acc_vec = acc_vec / nac + IF (p_is_io) CALL allocate_block_data (ghist, flux_xy_2d) - call mp2g_hist%map (acc_vec, flux_xy_2d, spv = spval, msk = filter) + CALL mp2g_hist%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter) - if (p_is_io) then + IF (p_is_io) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) yblk = gblock%yblkme(iblkme) - do yloc = 1, ghist%ycnt(yblk) - do xloc = 1, ghist%xcnt(xblk) + DO yloc = 1, ghist%ycnt(yblk) + DO xloc = 1, ghist%xcnt(xblk) - if (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) then + IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN IF (flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & = flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & / sumarea%blk(xblk,yblk)%val(xloc,yloc) ENDIF - else + ELSE flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval - end if + ENDIF - end do - end do + ENDDO + ENDDO - end do - end if + ENDDO + ENDIF compress = DEF_HIST_CompressLevel - call hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, & + CALL hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, & flux_xy_2d, compress, longname, units) - end subroutine flux_map_and_write_2d + END SUBROUTINE flux_map_and_write_2d ! ------- - subroutine flux_map_and_write_urb_2d ( & + SUBROUTINE flux_map_and_write_urb_2d ( & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & longname, units) - use MOD_Precision - use MOD_SPMD_Task - use MOD_Namelist - use MOD_DataType - use MOD_Mapping_Pset2Grid - use MOD_Block - use MOD_Grid - use MOD_Vars_1DAccFluxes, only: nac - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Block + USE MOD_Grid + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE real(r8), intent(inout) :: acc_vec(:) character(len=*), intent(in) :: file_hist @@ -183,56 +200,55 @@ subroutine flux_map_and_write_urb_2d ( & integer :: iblkme, xblk, yblk, xloc, yloc integer :: compress - if (p_is_worker) where (acc_vec /= spval) acc_vec = acc_vec / nac - IF (p_is_io) call allocate_block_data (ghist, flux_xy_2d) + IF (p_is_worker) WHERE (acc_vec /= spval) acc_vec = acc_vec / nac + IF (p_is_io) CALL allocate_block_data (ghist, flux_xy_2d) - call mp2g_hist_urb%map (acc_vec, flux_xy_2d, spv = spval, msk = filter) + CALL mp2g_hist_urb%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter) - if (p_is_io) then + IF (p_is_io) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) yblk = gblock%yblkme(iblkme) - do yloc = 1, ghist%ycnt(yblk) - do xloc = 1, ghist%xcnt(xblk) + DO yloc = 1, ghist%ycnt(yblk) + DO xloc = 1, ghist%xcnt(xblk) - if (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) then + IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN IF (flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & = flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & / sumarea%blk(xblk,yblk)%val(xloc,yloc) ENDIF - else + ELSE flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval - end if + ENDIF - end do - end do + ENDDO + ENDDO - end do - end if + ENDDO + ENDIF compress = DEF_HIST_CompressLevel - call hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, flux_xy_2d, & + CALL hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, flux_xy_2d, & compress, longname, units) - end subroutine flux_map_and_write_urb_2d + END SUBROUTINE flux_map_and_write_urb_2d ! ------- - subroutine flux_map_and_write_3d ( & + SUBROUTINE flux_map_and_write_3d ( & acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, sumarea, filter, & longname, units) - use MOD_Precision - use MOD_SPMD_Task - use MOD_Namelist - use MOD_DataType - use MOD_Mapping_Pset2Grid - use MOD_Block - use MOD_Grid - use MOD_Vars_1DAccFluxes, only: nac - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Block + USE MOD_Grid + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE real(r8), intent(inout) :: acc_vec(:,:) character(len=*), intent(in) :: file_hist @@ -251,24 +267,24 @@ subroutine flux_map_and_write_3d ( & integer :: iblkme, xblk, yblk, xloc, yloc, i1 integer :: compress - if (p_is_worker) THEN - where (acc_vec /= spval) acc_vec = acc_vec / nac + IF (p_is_worker) THEN + WHERE (acc_vec /= spval) acc_vec = acc_vec / nac ENDIF - IF (p_is_io) then - call allocate_block_data (ghist, flux_xy_3d, ndim1, lb1) + IF (p_is_io) THEN + CALL allocate_block_data (ghist, flux_xy_3d, ndim1, lb1) ENDIF - call mp2g_hist%map (acc_vec, flux_xy_3d, spv = spval, msk = filter) + CALL mp2g_hist%pset2grid (acc_vec, flux_xy_3d, spv = spval, msk = filter) - if (p_is_io) then + IF (p_is_io) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) yblk = gblock%yblkme(iblkme) - do yloc = 1, ghist%ycnt(yblk) - do xloc = 1, ghist%xcnt(xblk) + DO yloc = 1, ghist%ycnt(yblk) + DO xloc = 1, ghist%xcnt(xblk) - if (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) then + IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN DO i1 = flux_xy_3d%lb1, flux_xy_3d%ub1 IF (flux_xy_3d%blk(xblk,yblk)%val(i1,xloc,yloc) /= spval) THEN flux_xy_3d%blk(xblk,yblk)%val(i1,xloc,yloc) & @@ -276,38 +292,37 @@ subroutine flux_map_and_write_3d ( & / sumarea%blk(xblk,yblk)%val(xloc,yloc) ENDIF ENDDO - else + ELSE flux_xy_3d%blk(xblk,yblk)%val(:,xloc,yloc) = spval - end if + ENDIF - end do - end do + ENDDO + ENDDO - end do - end if + ENDDO + ENDIF compress = DEF_HIST_CompressLevel - call hist_write_var_real8_3d (file_hist, varname, dim1name, ghist, & + CALL hist_write_var_real8_3d (file_hist, varname, dim1name, ghist, & itime_in_file, flux_xy_3d, compress, longname, units) - end subroutine flux_map_and_write_3d + END SUBROUTINE flux_map_and_write_3d ! ------- - subroutine flux_map_and_write_4d ( & + SUBROUTINE flux_map_and_write_4d ( & acc_vec, file_hist, varname, itime_in_file, & dim1name, lb1, ndim1, dim2name, lb2, ndim2, & sumarea, filter, longname, units) - use MOD_Precision - use MOD_SPMD_Task - use MOD_Namelist - use MOD_DataType - use MOD_Mapping_Pset2Grid - use MOD_Block - use MOD_Grid - use MOD_Vars_1DAccFluxes, only: nac - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Block + USE MOD_Grid + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE real(r8), intent(inout) :: acc_vec(:,:,:) character(len=*), intent(in) :: file_hist @@ -326,24 +341,24 @@ subroutine flux_map_and_write_4d ( & integer :: iblkme, xblk, yblk, xloc, yloc, i1, i2 integer :: compress - if (p_is_worker) then - where(acc_vec /= spval) acc_vec = acc_vec / nac - end if - IF (p_is_io) then - call allocate_block_data (ghist, flux_xy_4d, ndim1, ndim2, lb1 = lb1, lb2 = lb2) + IF (p_is_worker) THEN + WHERE(acc_vec /= spval) acc_vec = acc_vec / nac + ENDIF + IF (p_is_io) THEN + CALL allocate_block_data (ghist, flux_xy_4d, ndim1, ndim2, lb1 = lb1, lb2 = lb2) ENDIF - call mp2g_hist%map (acc_vec, flux_xy_4d, spv = spval, msk = filter) + CALL mp2g_hist%pset2grid (acc_vec, flux_xy_4d, spv = spval, msk = filter) - if (p_is_io) then + IF (p_is_io) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) yblk = gblock%yblkme(iblkme) - do yloc = 1, ghist%ycnt(yblk) - do xloc = 1, ghist%xcnt(xblk) + DO yloc = 1, ghist%ycnt(yblk) + DO xloc = 1, ghist%xcnt(xblk) - if (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) then + IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN DO i1 = flux_xy_4d%lb1, flux_xy_4d%ub1 DO i2 = flux_xy_4d%lb2, flux_xy_4d%ub2 IF (flux_xy_4d%blk(xblk,yblk)%val(i1,i2,xloc,yloc) /= spval) THEN @@ -353,37 +368,36 @@ subroutine flux_map_and_write_4d ( & ENDIF ENDDO ENDDO - else + ELSE flux_xy_4d%blk(xblk,yblk)%val(:,:,xloc,yloc) = spval - end if + ENDIF - end do - end do + ENDDO + ENDDO - end do - end if + ENDDO + ENDIF compress = DEF_HIST_CompressLevel - call hist_write_var_real8_4d (file_hist, varname, dim1name, dim2name, & + CALL hist_write_var_real8_4d (file_hist, varname, dim1name, dim2name, & ghist, itime_in_file, flux_xy_4d, compress, longname, units) - end subroutine flux_map_and_write_4d + END SUBROUTINE flux_map_and_write_4d ! ------- - subroutine flux_map_and_write_ln ( & + SUBROUTINE flux_map_and_write_ln ( & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & longname, units) - use MOD_Precision - use MOD_SPMD_Task - use MOD_Namelist - use MOD_DataType - use MOD_Mapping_Pset2Grid - use MOD_Block - use MOD_Grid - use MOD_Vars_1DAccFluxes, only: nac_ln - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Block + USE MOD_Grid + USE MOD_Vars_1DAccFluxes, only: nac_ln + USE MOD_Vars_Global, only: spval + IMPLICIT NONE real(r8), intent(inout) :: acc_vec(:) character(len=*), intent(in) :: file_hist @@ -400,58 +414,58 @@ subroutine flux_map_and_write_ln ( & integer :: i, iblkme, xblk, yblk, xloc, yloc integer :: compress - if (p_is_worker) then - do i = lbound(acc_vec,1), ubound(acc_vec,1) - if ((acc_vec(i) /= spval) .and. (nac_ln(i) > 0)) then + IF (p_is_worker) THEN + DO i = lbound(acc_vec,1), ubound(acc_vec,1) + IF ((acc_vec(i) /= spval) .and. (nac_ln(i) > 0)) THEN acc_vec(i) = acc_vec(i) / nac_ln(i) - end if - end do - end if + ENDIF + ENDDO + ENDIF IF (p_is_io) THEN - call allocate_block_data (ghist, flux_xy_2d) + CALL allocate_block_data (ghist, flux_xy_2d) ENDIF - call mp2g_hist%map (acc_vec, flux_xy_2d, spv = spval, msk = filter) + CALL mp2g_hist%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter) - if (p_is_io) then + IF (p_is_io) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) yblk = gblock%yblkme(iblkme) - do yloc = 1, ghist%ycnt(yblk) - do xloc = 1, ghist%xcnt(xblk) + DO yloc = 1, ghist%ycnt(yblk) + DO xloc = 1, ghist%xcnt(xblk) - if ((sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) & - .and. (flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval)) then + IF ((sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) & + .and. (flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval)) THEN flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & = flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & / sumarea%blk(xblk,yblk)%val(xloc,yloc) - else + ELSE flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval - end if + ENDIF - end do - end do + ENDDO + ENDDO - end do - end if + ENDDO + ENDIF compress = DEF_HIST_CompressLevel - call hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, flux_xy_2d, & + CALL hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, flux_xy_2d, & compress, longname, units) - end subroutine flux_map_and_write_ln + END SUBROUTINE flux_map_and_write_ln !------------------------------ - subroutine hist_gridded_write_time ( & + SUBROUTINE hist_gridded_write_time ( & filename, dataname, time, itime) - use MOD_Namelist - use MOD_Grid - use MOD_Block - use MOD_SPMD_Task - implicit none + USE MOD_Namelist + USE MOD_Grid + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE character (len=*), intent(in) :: filename character (len=*), intent(in) :: dataname @@ -464,37 +478,41 @@ subroutine hist_gridded_write_time ( & integer :: iblkme, iblk, jblk logical :: fexists - if (trim(DEF_HIST_mode) == 'one') then - if (p_is_master) then + IF (trim(DEF_HIST_mode) == 'one') THEN + IF (p_is_master) THEN #ifdef USEMPI IF (DEF_HIST_WriteBack) THEN CALL hist_writeback_latlon_time (filename, dataname, time, hist_concat) ELSE #endif inquire (file=filename, exist=fexists) - if (.not. fexists) then - call ncio_create_file (trim(filename)) + IF (.not. fexists) THEN + + CALL ncio_create_file (trim(filename)) CALL ncio_define_dimension(filename, 'time', 0) - call ncio_define_dimension(filename, 'lat' , hist_concat%ginfo%nlat) - call ncio_define_dimension(filename, 'lon' , hist_concat%ginfo%nlon) + CALL ncio_define_dimension(filename, 'lat' , hist_concat%ginfo%nlat) + CALL ncio_define_dimension(filename, 'lon' , hist_concat%ginfo%nlon) - call ncio_write_serial (filename, 'lat', hist_concat%ginfo%lat_c, 'lat') + CALL ncio_write_serial (filename, 'lat', hist_concat%ginfo%lat_c, 'lat') CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') - call ncio_write_serial (filename, 'lon', hist_concat%ginfo%lon_c, 'lon') + CALL ncio_write_serial (filename, 'lon', hist_concat%ginfo%lon_c, 'lon') CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') #ifndef SinglePoint - call ncio_write_serial (filename, 'lat_s', hist_concat%ginfo%lat_s, 'lat') - call ncio_write_serial (filename, 'lat_n', hist_concat%ginfo%lat_n, 'lat') - call ncio_write_serial (filename, 'lon_w', hist_concat%ginfo%lon_w, 'lon') - call ncio_write_serial (filename, 'lon_e', hist_concat%ginfo%lon_e, 'lon') + CALL ncio_write_serial (filename, 'lat_s', hist_concat%ginfo%lat_s, 'lat') + CALL ncio_write_serial (filename, 'lat_n', hist_concat%ginfo%lat_n, 'lat') + CALL ncio_write_serial (filename, 'lon_w', hist_concat%ginfo%lon_w, 'lon') + CALL ncio_write_serial (filename, 'lon_e', hist_concat%ginfo%lon_e, 'lon') #endif - endif + + CALL ncio_write_colm_dimension (filename) + + ENDIF - call ncio_write_time (filename, dataname, time, itime, DEF_HIST_FREQ) + CALL ncio_write_time (filename, dataname, time, itime, DEF_HIST_FREQ) #ifdef USEMPI ENDIF @@ -507,49 +525,49 @@ subroutine hist_gridded_write_time ( & ENDIF #endif - elseif (trim(DEF_HIST_mode) == 'block') then + ELSEIF (trim(DEF_HIST_mode) == 'block') THEN - if (p_is_io) then + IF (p_is_io) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) - IF (ghist%ycnt(jblk) <= 0) cycle - IF (ghist%xcnt(iblk) <= 0) cycle + IF (ghist%ycnt(jblk) <= 0) CYCLE + IF (ghist%xcnt(iblk) <= 0) CYCLE - call get_filename_block (filename, iblk, jblk, fileblock) + CALL get_filename_block (filename, iblk, jblk, fileblock) inquire (file=fileblock, exist=fexists) - if (.not. fexists) then - call ncio_create_file (trim(fileblock)) + IF (.not. fexists) THEN + CALL ncio_create_file (trim(fileblock)) CALL ncio_define_dimension (fileblock, 'time', 0) - call hist_write_grid_info (fileblock, ghist, iblk, jblk) - end if + CALL hist_write_grid_info (fileblock, ghist, iblk, jblk) + ENDIF - call ncio_write_time (fileblock, dataname, time, itime, DEF_HIST_FREQ) + CALL ncio_write_time (fileblock, dataname, time, itime, DEF_HIST_FREQ) - end do + ENDDO - end if + ENDIF #ifdef USEMPI IF (.not. p_is_master) CALL mpi_bcast (itime, 1, MPI_INTEGER, p_root, p_comm_group, p_err) #endif - endif + ENDIF - end subroutine hist_gridded_write_time + END SUBROUTINE hist_gridded_write_time !---------------------------------------------------------------------------- - subroutine hist_write_var_real8_2d ( & + SUBROUTINE hist_write_var_real8_2d ( & filename, dataname, grid, itime, wdata, compress, longname, units) - use MOD_Namelist - use MOD_Block - use MOD_Grid - use MOD_DataType - use MOD_SPMD_Task - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Namelist + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE character (len=*), intent(in) :: filename character (len=*), intent(in) :: dataname @@ -569,9 +587,9 @@ subroutine hist_write_var_real8_2d ( & character(len=256) :: fileblock real(r8), allocatable :: rbuf(:,:), sbuf(:,:), vdata(:,:) - if (trim(DEF_HIST_mode) == 'one') then + IF (trim(DEF_HIST_mode) == 'one') THEN - if (p_is_master) then + IF (p_is_master) THEN #ifdef USEMPI IF (.not. DEF_HIST_WriteBack) THEN @@ -579,8 +597,8 @@ subroutine hist_write_var_real8_2d ( & allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) vdata(:,:) = spval - do idata = 1, hist_concat%ndatablk - call mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, & + DO idata = 1, hist_concat%ndatablk + CALL mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, & hist_data_id, p_comm_glb, p_stat, p_err) isrc = rmesg(1) @@ -594,13 +612,13 @@ subroutine hist_write_var_real8_2d ( & allocate (rbuf(xcnt,ycnt)) - call mpi_recv (rbuf, xcnt*ycnt, MPI_DOUBLE, & + CALL mpi_recv (rbuf, xcnt*ycnt, MPI_DOUBLE, & isrc, hist_data_id, p_comm_glb, p_stat, p_err) vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = rbuf deallocate (rbuf) - end do + ENDDO ELSE CALL hist_writeback_var_header (hist_data_id, filename, dataname, & @@ -610,11 +628,11 @@ subroutine hist_write_var_real8_2d ( & allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) vdata(:,:) = spval - do iyseg = 1, hist_concat%nyseg - do ixseg = 1, hist_concat%nxseg + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg iblk = hist_concat%xsegs(ixseg)%blk jblk = hist_concat%ysegs(iyseg)%blk - if (gblock%pio(iblk,jblk) == p_iam_glb) then + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN xbdsp = hist_concat%xsegs(ixseg)%bdsp ybdsp = hist_concat%ysegs(iyseg)%bdsp xgdsp = hist_concat%xsegs(ixseg)%gdsp @@ -626,16 +644,16 @@ subroutine hist_write_var_real8_2d ( & wdata%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) ENDIF ENDDO - end do + ENDDO #endif #ifdef USEMPI IF (.not. DEF_HIST_WriteBack) THEN #endif - call ncio_write_serial_time (filename, dataname, itime, vdata, & + CALL ncio_write_serial_time (filename, dataname, itime, vdata, & 'lon', 'lat', 'time', compress) - IF (itime == 1) then + IF (itime == 1) THEN CALL ncio_put_attr (filename, dataname, 'long_name', longname) CALL ncio_put_attr (filename, dataname, 'units', units) CALL ncio_put_attr (filename, dataname, 'missing_value', spval) @@ -649,14 +667,14 @@ subroutine hist_write_var_real8_2d ( & ENDIF #ifdef USEMPI - if (p_is_io) then - do iyseg = 1, hist_concat%nyseg - do ixseg = 1, hist_concat%nxseg + IF (p_is_io) THEN + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg iblk = hist_concat%xsegs(ixseg)%blk jblk = hist_concat%ysegs(iyseg)%blk - if (gblock%pio(iblk,jblk) == p_iam_glb) then + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN xbdsp = hist_concat%xsegs(ixseg)%bdsp ybdsp = hist_concat%ysegs(iyseg)%bdsp @@ -668,9 +686,9 @@ subroutine hist_write_var_real8_2d ( & IF (.not. DEF_HIST_WriteBack) THEN smesg = (/p_iam_glb, ixseg, iyseg/) - call mpi_send (smesg, 3, MPI_INTEGER, & + CALL mpi_send (smesg, 3, MPI_INTEGER, & p_root, hist_data_id, p_comm_glb, p_err) - call mpi_send (sbuf, xcnt*ycnt, MPI_DOUBLE, & + CALL mpi_send (sbuf, xcnt*ycnt, MPI_DOUBLE, & p_root, hist_data_id, p_comm_glb, p_err) ELSE CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata2d = sbuf) @@ -678,47 +696,47 @@ subroutine hist_write_var_real8_2d ( & deallocate (sbuf) - end if - end do - end do - end if + ENDIF + ENDDO + ENDDO + ENDIF #endif hist_data_id = mod(hist_data_id,1000) + 1 - elseif (trim(DEF_HIST_mode) == 'block') then + ELSEIF (trim(DEF_HIST_mode) == 'block') THEN - if (p_is_io) then + IF (p_is_io) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) - if ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) cycle + IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE - call get_filename_block (filename, iblk, jblk, fileblock) + CALL get_filename_block (filename, iblk, jblk, fileblock) - call ncio_write_serial_time (fileblock, dataname, itime, & + CALL ncio_write_serial_time (fileblock, dataname, itime, & wdata%blk(iblk,jblk)%val, 'lon', 'lat', 'time', compress) - end do + ENDDO - end if - end if + ENDIF + ENDIF - end subroutine hist_write_var_real8_2d + END SUBROUTINE hist_write_var_real8_2d !---------------------------------------------------------------------------- - subroutine hist_write_var_real8_3d ( & + SUBROUTINE hist_write_var_real8_3d ( & filename, dataname, dim1name, grid, itime, wdata, compress, longname, units) - use MOD_Namelist - use MOD_Block - use MOD_Grid - use MOD_DataType - use MOD_SPMD_Task - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Namelist + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE character (len=*), intent(in) :: filename character (len=*), intent(in) :: dataname @@ -739,16 +757,16 @@ subroutine hist_write_var_real8_3d ( & character(len=256) :: fileblock real(r8), allocatable :: rbuf(:,:,:), sbuf(:,:,:), vdata(:,:,:) - if (trim(DEF_HIST_mode) == 'one') then + IF (trim(DEF_HIST_mode) == 'one') THEN - if (p_is_master) then + IF (p_is_master) THEN #ifdef USEMPI IF (.not. DEF_HIST_WriteBack) THEN - do idata = 1, hist_concat%ndatablk + DO idata = 1, hist_concat%ndatablk - call mpi_recv (rmesg, 4, MPI_INTEGER, MPI_ANY_SOURCE, & + CALL mpi_recv (rmesg, 4, MPI_INTEGER, MPI_ANY_SOURCE, & hist_data_id, p_comm_glb, p_stat, p_err) isrc = rmesg(1) @@ -763,7 +781,7 @@ subroutine hist_write_var_real8_3d ( & allocate (rbuf (ndim1,xcnt,ycnt)) - call mpi_recv (rbuf, ndim1 * xcnt * ycnt, MPI_DOUBLE, & + CALL mpi_recv (rbuf, ndim1 * xcnt * ycnt, MPI_DOUBLE, & isrc, hist_data_id, p_comm_glb, p_stat, p_err) IF (idata == 1) THEN @@ -774,7 +792,7 @@ subroutine hist_write_var_real8_3d ( & vdata (:,xgdsp+1:xgdsp+xcnt,ygdsp+1:ygdsp+ycnt) = rbuf deallocate (rbuf) - end do + ENDDO ELSE CALL hist_writeback_var_header (hist_data_id, filename, dataname, & @@ -785,11 +803,11 @@ subroutine hist_write_var_real8_3d ( & allocate (vdata (ndim1, hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) vdata(:,:,:) = spval - do iyseg = 1, hist_concat%nyseg - do ixseg = 1, hist_concat%nxseg + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg iblk = hist_concat%xsegs(ixseg)%blk jblk = hist_concat%ysegs(iyseg)%blk - if (gblock%pio(iblk,jblk) == p_iam_glb) then + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN xbdsp = hist_concat%xsegs(ixseg)%bdsp ybdsp = hist_concat%ysegs(iyseg)%bdsp xgdsp = hist_concat%xsegs(ixseg)%gdsp @@ -800,7 +818,7 @@ subroutine hist_write_var_real8_3d ( & vdata (:,xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = & wdata%blk(iblk,jblk)%val(:,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) ENDIF - end do + ENDDO ENDDO #endif @@ -808,12 +826,12 @@ subroutine hist_write_var_real8_3d ( & #ifdef USEMPI IF (.not. DEF_HIST_WriteBack) THEN #endif - call ncio_define_dimension (filename, dim1name, ndim1) + CALL ncio_define_dimension (filename, dim1name, ndim1) - call ncio_write_serial_time (filename, dataname, itime, & + CALL ncio_write_serial_time (filename, dataname, itime, & vdata, dim1name, 'lon', 'lat', 'time', compress) - IF (itime == 1) then + IF (itime == 1) THEN CALL ncio_put_attr (filename, dataname, 'long_name', longname) CALL ncio_put_attr (filename, dataname, 'units', units) CALL ncio_put_attr (filename, dataname, 'missing_value', spval) @@ -826,15 +844,15 @@ subroutine hist_write_var_real8_3d ( & ENDIF #ifdef USEMPI - if (p_is_io) then + IF (p_is_io) THEN - do iyseg = 1, hist_concat%nyseg - do ixseg = 1, hist_concat%nxseg + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg iblk = hist_concat%xsegs(ixseg)%blk jblk = hist_concat%ysegs(iyseg)%blk - if (gblock%pio(iblk,jblk) == p_iam_glb) then + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN xbdsp = hist_concat%xsegs(ixseg)%bdsp ybdsp = hist_concat%ysegs(iyseg)%bdsp @@ -847,58 +865,58 @@ subroutine hist_write_var_real8_3d ( & IF (.not. DEF_HIST_WriteBack) THEN smesg = (/p_iam_glb, ixseg, iyseg, ndim1/) - call mpi_send (smesg, 4, MPI_INTEGER, & + CALL mpi_send (smesg, 4, MPI_INTEGER, & p_root, hist_data_id, p_comm_glb, p_err) - call mpi_send (sbuf, ndim1*xcnt*ycnt, MPI_DOUBLE, & + CALL mpi_send (sbuf, ndim1*xcnt*ycnt, MPI_DOUBLE, & p_root, hist_data_id, p_comm_glb, p_err) ELSE CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata3d = sbuf) ENDIF deallocate (sbuf) - end if - end do - end do - end if + ENDIF + ENDDO + ENDDO + ENDIF #endif hist_data_id = mod(hist_data_id,1000) + 1 - elseif (trim(DEF_HIST_mode) == 'block') then + ELSEIF (trim(DEF_HIST_mode) == 'block') THEN - if (p_is_io) then + IF (p_is_io) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) - if ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) cycle + IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE - call get_filename_block (filename, iblk, jblk, fileblock) + CALL get_filename_block (filename, iblk, jblk, fileblock) - call ncio_define_dimension (fileblock, dim1name, wdata%ub1-wdata%lb1+1) + CALL ncio_define_dimension (fileblock, dim1name, wdata%ub1-wdata%lb1+1) - call ncio_write_serial_time (fileblock, dataname, itime, & + CALL ncio_write_serial_time (fileblock, dataname, itime, & wdata%blk(iblk,jblk)%val, dim1name, 'lon', 'lat', 'time', compress) - end do + ENDDO - end if - end if + ENDIF + ENDIF - end subroutine hist_write_var_real8_3d + END SUBROUTINE hist_write_var_real8_3d !---------------------------------------------------------------------------- - subroutine hist_write_var_real8_4d ( & + SUBROUTINE hist_write_var_real8_4d ( & filename, dataname, dim1name, dim2name, grid, itime, wdata, compress, longname, units) - use MOD_Namelist - use MOD_Block - use MOD_Grid - use MOD_DataType - use MOD_SPMD_Task - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Namelist + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE character (len=*), intent(in) :: filename character (len=*), intent(in) :: dataname @@ -919,16 +937,16 @@ subroutine hist_write_var_real8_4d ( & character(len=256) :: fileblock real(r8), allocatable :: rbuf(:,:,:,:), sbuf(:,:,:,:), vdata(:,:,:,:) - if (trim(DEF_HIST_mode) == 'one') then + IF (trim(DEF_HIST_mode) == 'one') THEN - if (p_is_master) then + IF (p_is_master) THEN #ifdef USEMPI IF (.not. DEF_HIST_WriteBack) THEN - do idata = 1, hist_concat%ndatablk + DO idata = 1, hist_concat%ndatablk - call mpi_recv (rmesg, 5, MPI_INTEGER, MPI_ANY_SOURCE, & + CALL mpi_recv (rmesg, 5, MPI_INTEGER, MPI_ANY_SOURCE, & hist_data_id, p_comm_glb, p_stat, p_err) isrc = rmesg(1) @@ -944,7 +962,7 @@ subroutine hist_write_var_real8_4d ( & allocate (rbuf (ndim1,ndim2,xcnt,ycnt)) - call mpi_recv (rbuf, ndim1*ndim2*xcnt*ycnt, MPI_DOUBLE, & + CALL mpi_recv (rbuf, ndim1*ndim2*xcnt*ycnt, MPI_DOUBLE, & isrc, hist_data_id, p_comm_glb, p_stat, p_err) IF (idata == 1) THEN @@ -955,7 +973,7 @@ subroutine hist_write_var_real8_4d ( & vdata (:,:,xgdsp+1:xgdsp+xcnt,ygdsp+1:ygdsp+ycnt) = rbuf deallocate (rbuf) - end do + ENDDO ELSE CALL hist_writeback_var_header (hist_data_id, filename, dataname, & @@ -967,11 +985,11 @@ subroutine hist_write_var_real8_4d ( & allocate (vdata (ndim1,ndim2,hist_concat%ginfo%nlon,hist_concat%ginfo%nlat)) vdata(:,:,:,:) = spval - do iyseg = 1, hist_concat%nyseg - do ixseg = 1, hist_concat%nxseg + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg iblk = hist_concat%xsegs(ixseg)%blk jblk = hist_concat%ysegs(iyseg)%blk - if (gblock%pio(iblk,jblk) == p_iam_glb) then + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN xbdsp = hist_concat%xsegs(ixseg)%bdsp ybdsp = hist_concat%ysegs(iyseg)%bdsp xgdsp = hist_concat%xsegs(ixseg)%gdsp @@ -990,13 +1008,13 @@ subroutine hist_write_var_real8_4d ( & #ifdef USEMPI IF (.not. DEF_HIST_WriteBack) THEN #endif - call ncio_define_dimension (filename, dim1name, ndim1) - call ncio_define_dimension (filename, dim2name, ndim2) + CALL ncio_define_dimension (filename, dim1name, ndim1) + CALL ncio_define_dimension (filename, dim2name, ndim2) - call ncio_write_serial_time (filename, dataname, itime, vdata, & + CALL ncio_write_serial_time (filename, dataname, itime, vdata, & dim1name, dim2name, 'lon', 'lat', 'time', compress) - IF (itime == 1) then + IF (itime == 1) THEN CALL ncio_put_attr (filename, dataname, 'long_name', longname) CALL ncio_put_attr (filename, dataname, 'units', units) CALL ncio_put_attr (filename, dataname, 'missing_value', spval) @@ -1009,15 +1027,15 @@ subroutine hist_write_var_real8_4d ( & ENDIF #ifdef USEMPI - if (p_is_io) then + IF (p_is_io) THEN - do iyseg = 1, hist_concat%nyseg - do ixseg = 1, hist_concat%nxseg + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg iblk = hist_concat%xsegs(ixseg)%blk jblk = hist_concat%ysegs(iyseg)%blk - if (gblock%pio(iblk,jblk) == p_iam_glb) then + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN xbdsp = hist_concat%xsegs(ixseg)%bdsp ybdsp = hist_concat%ysegs(iyseg)%bdsp @@ -1031,53 +1049,53 @@ subroutine hist_write_var_real8_4d ( & IF (.not. DEF_HIST_WriteBack) THEN smesg = (/p_iam_glb, ixseg, iyseg, ndim1, ndim2/) - call mpi_send (smesg, 5, MPI_INTEGER, & + CALL mpi_send (smesg, 5, MPI_INTEGER, & p_root, hist_data_id, p_comm_glb, p_err) - call mpi_send (sbuf, ndim1*ndim2*xcnt*ycnt, MPI_DOUBLE, & + CALL mpi_send (sbuf, ndim1*ndim2*xcnt*ycnt, MPI_DOUBLE, & p_root, hist_data_id, p_comm_glb, p_err) ELSE CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata4d = sbuf) ENDIF deallocate (sbuf) - end if - end do - end do - end if + ENDIF + ENDDO + ENDDO + ENDIF #endif hist_data_id = mod(hist_data_id,1000) + 1 - elseif (trim(DEF_HIST_mode) == 'block') then - if (p_is_io) then + ELSEIF (trim(DEF_HIST_mode) == 'block') THEN + IF (p_is_io) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) - if ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) cycle + IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE - call get_filename_block (filename, iblk, jblk, fileblock) + CALL get_filename_block (filename, iblk, jblk, fileblock) - call ncio_define_dimension (fileblock, dim1name, wdata%ub1-wdata%lb1+1) - call ncio_define_dimension (fileblock, dim2name, wdata%ub2-wdata%lb2+1) + CALL ncio_define_dimension (fileblock, dim1name, wdata%ub1-wdata%lb1+1) + CALL ncio_define_dimension (fileblock, dim2name, wdata%ub2-wdata%lb2+1) - call ncio_write_serial_time (fileblock, dataname, itime, & + CALL ncio_write_serial_time (fileblock, dataname, itime, & wdata%blk(iblk,jblk)%val, dim1name, dim2name, 'lon', 'lat', 'time', compress) - end do + ENDDO - end if - end if + ENDIF + ENDIF - end subroutine hist_write_var_real8_4d + END SUBROUTINE hist_write_var_real8_4d !------------------ - subroutine hist_write_grid_info (fileblock, grid, iblk, jblk) + SUBROUTINE hist_write_grid_info (fileblock, grid, iblk, jblk) - use MOD_Block - use MOD_Grid - implicit none + USE MOD_Block + USE MOD_Grid + IMPLICIT NONE character(len=*), intent(in) :: fileblock type (grid_type), intent(in) :: grid @@ -1098,7 +1116,7 @@ subroutine hist_write_grid_info (fileblock, grid, iblk, jblk) lat_s = grid%lat_s(yl:yu) lat_n = grid%lat_n(yl:yu) - if (grid%xdsp(iblk) + grid%xcnt(iblk) > grid%nlon) then + IF (grid%xdsp(iblk) + grid%xcnt(iblk) > grid%nlon) THEN xl = grid%xdsp(iblk) + 1 xu = grid%nlon nx = grid%nlon - grid%xdsp(iblk) @@ -1109,20 +1127,22 @@ subroutine hist_write_grid_info (fileblock, grid, iblk, jblk) xu = grid%xcnt(iblk) - nx lon_w(nx+1:grid%xcnt(iblk)) = grid%lon_w(xl:xu) lon_e(nx+1:grid%xcnt(iblk)) = grid%lon_e(xl:xu) - else + ELSE xl = grid%xdsp(iblk) + 1 xu = grid%xdsp(iblk) + grid%xcnt(iblk) lon_w = grid%lon_w(xl:xu) lon_e = grid%lon_e(xl:xu) - end if + ENDIF CALL ncio_define_dimension (fileblock, 'lat', grid%ycnt(jblk)) CALL ncio_define_dimension (fileblock, 'lon', grid%xcnt(iblk)) - call ncio_write_serial (fileblock, 'lat_s', lat_s, 'lat') - call ncio_write_serial (fileblock, 'lat_n', lat_n, 'lat') - call ncio_write_serial (fileblock, 'lon_w', lon_w, 'lon') - call ncio_write_serial (fileblock, 'lon_e', lon_e, 'lon') + CALL ncio_write_serial (fileblock, 'lat_s', lat_s, 'lat') + CALL ncio_write_serial (fileblock, 'lat_n', lat_n, 'lat') + CALL ncio_write_serial (fileblock, 'lon_w', lon_w, 'lon') + CALL ncio_write_serial (fileblock, 'lon_e', lon_e, 'lon') + + CALL ncio_write_colm_dimension (fileblock) - end subroutine hist_write_grid_info + END SUBROUTINE hist_write_grid_info -end module MOD_HistGridded +END MODULE MOD_HistGridded diff --git a/main/MOD_HistSingle.F90 b/main/MOD_HistSingle.F90 index c13e6887..4383d6f5 100644 --- a/main/MOD_HistSingle.F90 +++ b/main/MOD_HistSingle.F90 @@ -147,6 +147,8 @@ subroutine hist_single_write_time (filename, dataname, time, itime) CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') + CALL ncio_write_colm_dimension (filename) + IF (.not. USE_SITE_HistWriteBack) THEN CALL ncio_define_dimension(filename, 'time', 0) ENDIF diff --git a/main/MOD_HistVector.F90 b/main/MOD_HistVector.F90 index 7901060c..ddea1761 100644 --- a/main/MOD_HistVector.F90 +++ b/main/MOD_HistVector.F90 @@ -69,6 +69,9 @@ SUBROUTINE hist_vector_write_time (filename, dataname, time, itime_in_file) CALL ncio_put_attr (filename, 'elmindex', 'long_name', & 'element index in mesh') #endif + + CALL ncio_write_colm_dimension (filename) + endif call ncio_write_time (filename, dataname, time, itime_in_file, DEF_HIST_FREQ) diff --git a/main/MOD_HistWriteBack.F90 b/main/MOD_HistWriteBack.F90 index 9431182c..ce5e7a39 100644 --- a/main/MOD_HistWriteBack.F90 +++ b/main/MOD_HistWriteBack.F90 @@ -249,6 +249,8 @@ SUBROUTINE hist_writeback_daemon () ENDIF + CALL ncio_write_colm_dimension (filename) + ENDIF CALL ncio_write_time (filename, dataname, time, itime_in_file, DEF_HIST_FREQ) diff --git a/main/MOD_LightningData.F90 b/main/MOD_LightningData.F90 index 6d0cee6b..332a2499 100644 --- a/main/MOD_LightningData.F90 +++ b/main/MOD_LightningData.F90 @@ -12,7 +12,7 @@ MODULE MOD_LightningData USE MOD_Grid USE MOD_DataType - USE MOD_Mapping_Grid2Pset + USE MOD_SpatialMapping USE MOD_BGC_Vars_TimeVariables, only: lnfm IMPLICIT NONE @@ -21,7 +21,7 @@ MODULE MOD_LightningData type(block_data_real8_2d) :: f_lnfm - type (mapping_grid2pset_type) :: mg2p_lnfm + type (spatial_mapping_type) :: mg2p_lnfm CONTAINS @@ -58,7 +58,7 @@ SUBROUTINE init_lightning_data (idate) CALL allocate_block_data (grid_lightning, f_lnfm) - CALL mg2p_lnfm%build (grid_lightning, landpatch) + CALL mg2p_lnfm%build_arealweighted (grid_lightning, landpatch) itime = (idate(2)-1)*8 + min(idate(3)/10800+1,8) IF (itime .gt. 2920)itime = itime - 8 ! for the leap year @@ -102,7 +102,7 @@ SUBROUTINE update_lightning_data (time, deltim) CALL check_block_data ('lightning', f_lnfm) #endif - CALL mg2p_lnfm%map_aweighted (f_lnfm, lnfm) + CALL mg2p_lnfm%grid2pset (f_lnfm, lnfm) #ifdef RangeCheck CALL check_vector_data ('lightning', lnfm) #endif diff --git a/main/MOD_NdepData.F90 b/main/MOD_NdepData.F90 index 7ab5f29a..342061e2 100644 --- a/main/MOD_NdepData.F90 +++ b/main/MOD_NdepData.F90 @@ -10,7 +10,7 @@ MODULE MOD_NdepData ! Lu Xingjie and Zhang Shupeng, 2023, prepare the original version of the ndep data module. USE MOD_Grid - USE MOD_Mapping_Grid2Pset + USE MOD_SpatialMapping USE MOD_BGC_Vars_TimeVariables, only : ndep USE MOD_BGC_Vars_1DFluxes, only: ndep_to_sminn IMPLICIT NONE @@ -18,7 +18,7 @@ MODULE MOD_NdepData character(len=256) :: file_ndep type(grid_type) :: grid_ndep - type(mapping_grid2pset_type) :: mg2p_ndep + type(spatial_mapping_type) :: mg2p_ndep CONTAINS @@ -49,7 +49,7 @@ SUBROUTINE init_ndep_data_annually (YY) CALL grid_ndep%define_by_center (lat, lon) - CALL mg2p_ndep%build (grid_ndep, landpatch) + CALL mg2p_ndep%build_arealweighted (grid_ndep, landpatch) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) @@ -85,7 +85,7 @@ SUBROUTINE init_ndep_data_monthly (YY,MM) !sf_add CALL grid_ndep%define_by_center (lat, lon) - CALL mg2p_ndep%build (grid_ndep, landpatch) + CALL mg2p_ndep%build_arealweighted (grid_ndep, landpatch) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) @@ -131,7 +131,7 @@ SUBROUTINE update_ndep_data_annually (YY, iswrite) CALL ncio_read_block_time (file_ndep, 'NDEP_year', grid_ndep, itime, f_xy_ndep) ENDIF - CALL mg2p_ndep%map_aweighted (f_xy_ndep, ndep) + CALL mg2p_ndep%grid2pset (f_xy_ndep, ndep) IF (p_is_worker .and. iswrite) THEN IF (numpatch > 0) THEN @@ -197,7 +197,7 @@ SUBROUTINE update_ndep_data_monthly (YY, MM, iswrite) !sf_add CALL ncio_read_block_time (file_ndep, 'NDEP_month', grid_ndep, itime, f_xy_ndep) ! sf_add ENDIF - CALL mg2p_ndep%map_aweighted (f_xy_ndep, ndep) + CALL mg2p_ndep%grid2pset (f_xy_ndep, ndep) IF (p_is_worker .and. iswrite) THEN IF (numpatch > 0) THEN diff --git a/main/MOD_NitrifData.F90 b/main/MOD_NitrifData.F90 index ac8b5aa6..6ecf35f1 100644 --- a/main/MOD_NitrifData.F90 +++ b/main/MOD_NitrifData.F90 @@ -10,12 +10,12 @@ MODULE MOD_NitrifData ! Lu Xingjie and Zhang Shupeng, 2023, prepare the original version of the nitrif data module. USE MOD_Grid - USE MOD_Mapping_Grid2Pset + USE MOD_SpatialMapping USE MOD_BGC_Vars_TimeVariables, only : tCONC_O2_UNSAT, tO2_DECOMP_DEPTH_UNSAT IMPLICIT NONE type(grid_type) :: grid_nitrif - type(mapping_grid2pset_type) :: mg2p_nitrif + type(spatial_mapping_type) :: mg2p_nitrif CONTAINS @@ -48,7 +48,7 @@ SUBROUTINE init_nitrif_data (idate) CALL grid_nitrif%define_by_center (lat, lon) - CALL mg2p_nitrif%build (grid_nitrif, landpatch) + CALL mg2p_nitrif%build_arealweighted (grid_nitrif, landpatch) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) @@ -99,7 +99,7 @@ SUBROUTINE update_nitrif_data (month) CALL ncio_read_block_time (file_nitrif, 'CONC_O2_UNSAT', grid_nitrif, month, f_xy_nitrif) ENDIF - CALL mg2p_nitrif%map_aweighted (f_xy_nitrif, tCONC_O2_UNSAT_tmp) + CALL mg2p_nitrif%grid2pset (f_xy_nitrif, tCONC_O2_UNSAT_tmp) IF (p_is_worker) THEN IF (numpatch > 0) THEN @@ -131,7 +131,7 @@ SUBROUTINE update_nitrif_data (month) CALL ncio_read_block_time (file_nitrif, 'O2_DECOMP_DEPTH_UNSAT', grid_nitrif, month, f_xy_nitrif) ENDIF - CALL mg2p_nitrif%map_aweighted (f_xy_nitrif, tO2_DECOMP_DEPTH_UNSAT_tmp) + CALL mg2p_nitrif%grid2pset (f_xy_nitrif, tO2_DECOMP_DEPTH_UNSAT_tmp) IF (p_is_worker) THEN IF (numpatch > 0) THEN diff --git a/main/MOD_Ozone.F90 b/main/MOD_Ozone.F90 index c613a95e..de229426 100644 --- a/main/MOD_Ozone.F90 +++ b/main/MOD_Ozone.F90 @@ -20,7 +20,7 @@ Module MOD_Ozone USE MOD_Const_PFT, only: isevg, leaf_long, woody USE MOD_Grid USE MOD_DataType - USE MOD_Mapping_Grid2Pset + USE MOD_SpatialMapping USE MOD_Vars_1DForcing, only: forc_ozone USE MOD_Namelist, only: DEF_USE_OZONEDATA IMPLICIT NONE @@ -31,7 +31,7 @@ Module MOD_Ozone type(block_data_real8_2d) :: f_ozone - type (mapping_grid2pset_type) :: mg2p_ozone + type(spatial_mapping_type) :: mg2p_ozone SAVE @@ -222,7 +222,7 @@ SUBROUTINE init_ozone_data (idate) CALL allocate_block_data (grid_ozone, f_ozone) - CALL mg2p_ozone%build (grid_ozone, landpatch) + CALL mg2p_ozone%build_arealweighted (grid_ozone, landpatch) itime = mday @@ -279,7 +279,7 @@ SUBROUTINE update_ozone_data (time, deltim) CALL check_block_data ('Ozone', f_ozone) #endif - CALL mg2p_ozone%map_aweighted (f_ozone, forc_ozone) + CALL mg2p_ozone%grid2pset (f_ozone, forc_ozone) forc_ozone = forc_ozone * 1.e-9 #ifdef RangeCheck CALL check_vector_data ('Ozone', forc_ozone) diff --git a/main/MOD_Vars_1DAccFluxes.F90 b/main/MOD_Vars_1DAccFluxes.F90 index b260bcb9..0b4acde4 100644 --- a/main/MOD_Vars_1DAccFluxes.F90 +++ b/main/MOD_Vars_1DAccFluxes.F90 @@ -667,11 +667,7 @@ SUBROUTINE allocate_acc_fluxes ENDIF IF (p_is_worker) THEN -#if (defined CROP) - CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) -#else CALL elm_patch%build (landelm, landpatch, use_frac = .true.) -#endif ENDIF END SUBROUTINE allocate_acc_fluxes diff --git a/main/MOD_Vars_1DForcing.F90 b/main/MOD_Vars_1DForcing.F90 index 2fea182c..9613a039 100644 --- a/main/MOD_Vars_1DForcing.F90 +++ b/main/MOD_Vars_1DForcing.F90 @@ -37,38 +37,11 @@ MODULE MOD_Vars_1DForcing real(r8), allocatable :: forc_ozone (:) ! air density [kg/m3] real(r8), allocatable :: forc_topo (:) ! topography [m] - real(r8), allocatable :: forc_th (:) ! potential temperature [K] real(r8), allocatable :: forc_hpbl (:) ! atmospheric boundary layer height [m] real(r8), allocatable :: forc_aerdep(:,:) ! atmospheric aerosol deposition data [kg/m/s] - ! For Forcing_Downscaling - real(r8), allocatable :: forc_pco2m_elm (:) ! CO2 concentration in atmos. (pascals) - real(r8), allocatable :: forc_po2m_elm (:) ! O2 concentration in atmos. (pascals) - real(r8), allocatable :: forc_us_elm (:) ! wind in eastward direction [m/s] - real(r8), allocatable :: forc_vs_elm (:) ! wind in northward direction [m/s] - real(r8), allocatable :: forc_psrf_elm (:) ! atmospheric pressure at the surface [pa] - real(r8), allocatable :: forc_sols_elm (:) ! atm vis direct beam solar rad onto srf [W/m2] - real(r8), allocatable :: forc_soll_elm (:) ! atm nir direct beam solar rad onto srf [W/m2] - real(r8), allocatable :: forc_solsd_elm (:) ! atm vis diffuse solar rad onto srf [W/m2] - real(r8), allocatable :: forc_solld_elm (:) ! atm nir diffuse solar rad onto srf [W/m2] - real(r8), allocatable :: forc_hgt_u_elm (:) ! observational height of wind [m] - real(r8), allocatable :: forc_hgt_t_elm (:) ! observational height of temperature [m] - real(r8), allocatable :: forc_hgt_q_elm (:) ! observational height of humidity [m] - real(r8), allocatable :: forc_hpbl_elm (:) ! atmospheric boundary layer height [m] - - real(r8), allocatable :: forc_t_elm (:) ! atmospheric temperature [Kelvin] - real(r8), allocatable :: forc_th_elm (:) ! atmospheric potential temperature [Kelvin] - real(r8), allocatable :: forc_q_elm (:) ! atmospheric specific humidity [kg/kg] - real(r8), allocatable :: forc_pbot_elm (:) ! atmospheric pressure [Pa] - real(r8), allocatable :: forc_rho_elm (:) ! atmospheric density [kg/m**3] - real(r8), allocatable :: forc_prc_elm (:) ! convective precipitation in grid [mm/s] - real(r8), allocatable :: forc_prl_elm (:) ! large-scale precipitation in grid [mm/s] - real(r8), allocatable :: forc_lwrad_elm (:) ! grid downward longwave [W/m**2] - real(r8), allocatable :: forc_hgt_elm (:) ! atmospheric reference height [m] - - real(r8), allocatable :: forc_topo_elm (:) ! atmospheric surface height [m] - + ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: allocate_1D_Forcing PUBLIC :: deallocate_1D_Forcing @@ -115,46 +88,18 @@ SUBROUTINE allocate_1D_Forcing allocate (forc_rhoair (numpatch) ) ! air density [kg/m3] allocate (forc_ozone (numpatch) ) ! air density [kg/m3] + allocate (forc_hpbl (numpatch) ) ! atmospheric boundary layer height [m] + IF (DEF_USE_Forcing_Downscaling) THEN - allocate (forc_topo (numpatch) ) ! topography [m] - allocate (forc_th (numpatch) ) ! potential temperature [K] + allocate (forc_topo (numpatch)) ENDIF - allocate (forc_hpbl (numpatch) ) ! atmospheric boundary layer height [m] - IF (DEF_Aerosol_Readin) THEN allocate (forc_aerdep(14,numpatch) ) ! atmospheric aerosol deposition data [kg/m/s] ENDIF ENDIF - IF (DEF_USE_Forcing_Downscaling) THEN - IF (numelm > 0) THEN - allocate ( forc_pco2m_elm (numelm) ) ! CO2 concentration in atmos. (pascals) - allocate ( forc_po2m_elm (numelm) ) ! O2 concentration in atmos. (pascals) - allocate ( forc_us_elm (numelm) ) ! wind in eastward direction [m/s] - allocate ( forc_vs_elm (numelm) ) ! wind in northward direction [m/s] - allocate ( forc_psrf_elm (numelm) ) ! atmospheric pressure at the surface [pa] - allocate ( forc_sols_elm (numelm) ) ! atm vis direct beam solar rad onto srf [W/m2] - allocate ( forc_soll_elm (numelm) ) ! atm nir direct beam solar rad onto srf [W/m2] - allocate ( forc_solsd_elm (numelm) ) ! atm vis diffuse solar rad onto srf [W/m2] - allocate ( forc_solld_elm (numelm) ) ! atm nir diffuse solar rad onto srf [W/m2] - allocate ( forc_hgt_u_elm (numelm) ) ! observational height of wind [m] - allocate ( forc_hgt_t_elm (numelm) ) ! observational height of temperature [m] - allocate ( forc_hgt_q_elm (numelm) ) ! observational height of humidity [m] - allocate ( forc_hpbl_elm (numelm) ) ! atmospheric boundary layer height [m] - allocate ( forc_topo_elm (numelm) ) ! atmospheric surface height [m] - allocate ( forc_t_elm (numelm) ) ! atmospheric temperature [Kelvin] - allocate ( forc_th_elm (numelm) ) ! atmospheric potential temperature [Kelvin] - allocate ( forc_q_elm (numelm) ) ! atmospheric specific humidity [kg/kg] - allocate ( forc_pbot_elm (numelm) ) ! atmospheric pressure [Pa] - allocate ( forc_rho_elm (numelm) ) ! atmospheric density [kg/m**3] - allocate ( forc_prc_elm (numelm) ) ! convective precipitation in grid [mm/s] - allocate ( forc_prl_elm (numelm) ) ! large-scale precipitation in grid [mm/s] - allocate ( forc_lwrad_elm (numelm) ) ! grid downward longwave [W/m**2] - allocate ( forc_hgt_elm (numelm) ) ! atmospheric reference height [m] - ENDIF - ENDIF ENDIF END SUBROUTINE allocate_1D_Forcing @@ -194,46 +139,18 @@ SUBROUTINE deallocate_1D_Forcing () deallocate ( forc_rhoair ) ! air density [kg/m3] deallocate ( forc_ozone ) ! Ozone partial pressure [mol/mol] + deallocate ( forc_hpbl ) ! atmospheric boundary layer height [m] + IF (DEF_USE_Forcing_Downscaling) THEN - deallocate ( forc_topo ) ! topography [m] - deallocate ( forc_th ) ! potential temperature [K] + deallocate (forc_topo) ENDIF - deallocate ( forc_hpbl ) ! atmospheric boundary layer height [m] - IF (DEF_Aerosol_Readin) THEN deallocate ( forc_aerdep ) ! atmospheric aerosol deposition data [kg/m/s] ENDIF ENDIF - IF (DEF_USE_Forcing_Downscaling) THEN - IF (numelm > 0) THEN - deallocate ( forc_pco2m_elm ) ! CO2 concentration in atmos. (pascals) - deallocate ( forc_po2m_elm ) ! O2 concentration in atmos. (pascals) - deallocate ( forc_us_elm ) ! wind in eastward direction [m/s] - deallocate ( forc_vs_elm ) ! wind in northward direction [m/s] - deallocate ( forc_psrf_elm ) ! atmospheric pressure at the surface [pa] - deallocate ( forc_sols_elm ) ! atm vis direct beam solar rad onto srf [W/m2] - deallocate ( forc_soll_elm ) ! atm nir direct beam solar rad onto srf [W/m2] - deallocate ( forc_solsd_elm ) ! atm vis diffuse solar rad onto srf [W/m2] - deallocate ( forc_solld_elm ) ! atm nir diffuse solar rad onto srf [W/m2] - deallocate ( forc_hgt_u_elm ) ! observational height of wind [m] - deallocate ( forc_hgt_t_elm ) ! observational height of temperature [m] - deallocate ( forc_hgt_q_elm ) ! observational height of humidity [m] - deallocate ( forc_hpbl_elm ) ! atmospheric boundary layer height [m] - deallocate ( forc_topo_elm ) ! atmospheric surface height [m] - deallocate ( forc_t_elm ) ! atmospheric temperature [Kelvin] - deallocate ( forc_th_elm ) ! atmospheric potential temperature [Kelvin] - deallocate ( forc_q_elm ) ! atmospheric specific humidity [kg/kg] - deallocate ( forc_pbot_elm ) ! atmospheric pressure [Pa] - deallocate ( forc_rho_elm ) ! atmospheric density [kg/m**3] - deallocate ( forc_prc_elm ) ! convective precipitation in grid [mm/s] - deallocate ( forc_prl_elm ) ! large-scale precipitation in grid [mm/s] - deallocate ( forc_lwrad_elm ) ! grid downward longwave [W/m**2] - deallocate ( forc_hgt_elm ) ! atmospheric reference height [m] - ENDIF - ENDIF ENDIF END SUBROUTINE deallocate_1D_Forcing diff --git a/main/MOD_Vars_TimeInvariants.F90 b/main/MOD_Vars_TimeInvariants.F90 index ac9d05ba..f2667218 100644 --- a/main/MOD_Vars_TimeInvariants.F90 +++ b/main/MOD_Vars_TimeInvariants.F90 @@ -23,6 +23,9 @@ MODULE MOD_Vars_PFTimeInvariants real(r8), allocatable :: pftfrac (:) !PFT fractional cover real(r8), allocatable :: htop_p (:) !canopy top height [m] real(r8), allocatable :: hbot_p (:) !canopy bottom height [m] +#ifdef CROP + real(r8), allocatable :: cropfrac (:) !Crop fractional cover +#endif ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: allocate_PFTimeInvariants @@ -47,6 +50,7 @@ SUBROUTINE allocate_PFTimeInvariants ! -------------------------------------------------------------------- USE MOD_SPMD_Task + USE MOD_LandPatch, only : numpatch USE MOD_LandPFT, only : numpft USE MOD_Precision IMPLICIT NONE @@ -57,6 +61,9 @@ SUBROUTINE allocate_PFTimeInvariants allocate (pftfrac (numpft)) allocate (htop_p (numpft)) allocate (hbot_p (numpft)) +#ifdef CROP + allocate (cropfrac (numpatch)) +#endif ENDIF ENDIF @@ -65,11 +72,8 @@ END SUBROUTINE allocate_PFTimeInvariants SUBROUTINE READ_PFTimeInvariants (file_restart) USE MOD_NetCDFVector + USE MOD_LandPatch USE MOD_LandPFT -#ifdef CROP - USE MOD_LandCrop, only : pctshrpch - USE MOD_LandPatch, only : landpatch -#endif IMPLICIT NONE character(len=*), intent(in) :: file_restart @@ -79,7 +83,7 @@ SUBROUTINE READ_PFTimeInvariants (file_restart) CALL ncio_read_vector (file_restart, 'htop_p ', landpft, htop_p ) ! CALL ncio_read_vector (file_restart, 'hbot_p ', landpft, hbot_p ) ! #ifdef CROP - CALL ncio_read_vector (file_restart, 'pct_crops', landpatch, pctshrpch) ! + CALL ncio_read_vector (file_restart, 'cropfrac ', landpatch, cropfrac) ! #endif END SUBROUTINE READ_PFTimeInvariants @@ -88,12 +92,9 @@ SUBROUTINE WRITE_PFTimeInvariants (file_restart) USE MOD_NetCDFVector USE MOD_LandPFT + USE MOD_LandPatch USE MOD_Namelist USE MOD_Vars_Global -#ifdef CROP - USE MOD_LandCrop, only : pctshrpch - USE MOD_LandPatch, only : landpatch -#endif IMPLICIT NONE ! Local variables @@ -112,7 +113,7 @@ SUBROUTINE WRITE_PFTimeInvariants (file_restart) #ifdef CROP CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') - CALL ncio_write_vector (file_restart, 'pct_crops', 'patch', landpatch, pctshrpch, compress) ! + CALL ncio_write_vector (file_restart, 'cropfrac', 'patch', landpatch, cropfrac, compress) ! #endif END SUBROUTINE WRITE_PFTimeInvariants @@ -123,9 +124,6 @@ SUBROUTINE deallocate_PFTimeInvariants ! -------------------------------------------------- USE MOD_SPMD_Task USE MOD_LandPFT -#ifdef CROP - USE MOD_LandCrop, only : pctshrpch -#endif IF (p_is_worker) THEN IF (numpft > 0) THEN @@ -133,10 +131,10 @@ SUBROUTINE deallocate_PFTimeInvariants deallocate (pftfrac ) deallocate (htop_p ) deallocate (hbot_p ) - ENDIF #ifdef CROP - IF (allocated(pctshrpch)) deallocate(pctshrpch) + deallocate (cropfrac) #endif + ENDIF ENDIF END SUBROUTINE deallocate_PFTimeInvariants @@ -145,16 +143,14 @@ END SUBROUTINE deallocate_PFTimeInvariants SUBROUTINE check_PFTimeInvariants () USE MOD_RangeCheck -#ifdef CROP - USE MOD_LandCrop, only : pctshrpch -#endif + USE MOD_LandPatch IMPLICIT NONE CALL check_vector_data ('pftfrac', pftfrac) ! CALL check_vector_data ('htop_p ', htop_p ) ! CALL check_vector_data ('hbot_p ', hbot_p ) ! #ifdef CROP - CALL check_vector_data ('pct crop', pctshrpch) ! + CALL check_vector_data ('cropfrac', cropfrac) ! #endif END SUBROUTINE check_PFTimeInvariants diff --git a/mkinidata/MOD_Initialize.F90 b/mkinidata/MOD_Initialize.F90 index 7f3da99c..d957747e 100644 --- a/mkinidata/MOD_Initialize.F90 +++ b/mkinidata/MOD_Initialize.F90 @@ -57,7 +57,7 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & #ifdef vanGenuchten_Mualem_SOIL_MODEL USE MOD_Hydro_SoilFunction #endif - USE MOD_Mapping_Grid2Pset + USE MOD_SpatialMapping #ifdef CatchLateralFlow USE MOD_Mesh USE MOD_LandHRU @@ -107,10 +107,10 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & type(grid_type) :: gsoil type(grid_type) :: gsnow type(grid_type) :: gcn - type(mapping_grid2pset_type) :: ms2p - type(mapping_grid2pset_type) :: mc2p - type(mapping_grid2pset_type) :: mc2f - type(mapping_grid2pset_type) :: msoil2p, msnow2p + type(spatial_mapping_type) :: ms2p + type(spatial_mapping_type) :: mc2p + type(spatial_mapping_type) :: mc2f + type(spatial_mapping_type) :: msoil2p, msnow2p integer :: nl_soil_ini real(r8) :: missing_value @@ -182,8 +182,8 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & character(len=256) :: fwtd type(grid_type) :: gwtd - type(block_data_real8_2d) :: wtd_xy ! [m] - type(mapping_grid2pset_type) :: m_wtd2p + type(block_data_real8_2d) :: wtd_xy ! [m] + type(spatial_mapping_type) :: m_wtd2p real(r8) :: zwtmm real(r8) :: zc_soimm(1:nl_soil) @@ -665,10 +665,12 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & ENDIF ENDIF - CALL msoil2p%build (gsoil, landpatch, zwt_grid, missing_value, validval) - CALL msoil2p%map_aweighted (soil_t_grid, nl_soil_ini, soil_t) - CALL msoil2p%map_aweighted (soil_w_grid, nl_soil_ini, soil_w) - CALL msoil2p%map_aweighted (zwt_grid, zwt) + CALL msoil2p%build_arealweighted (gsoil, landpatch) + CALL msoil2p%set_missing_value (zwt_grid, missing_value, validval) + + CALL msoil2p%grid2pset (soil_t_grid, nl_soil_ini, soil_t) + CALL msoil2p%grid2pset (soil_w_grid, nl_soil_ini, soil_w) + CALL msoil2p%grid2pset (zwt_grid, zwt) IF (p_is_worker) THEN DO i = 1, numpatch @@ -722,8 +724,8 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & IF (use_cnini) THEN CALL gcn%define_from_file (fcndat,"lat","lon") - CALL mc2p%build (gcn, landpatch) - CALL mc2f%build (gcn, landpft) + CALL mc2p%build_arealweighted (gcn, landpatch) + CALL mc2f%build_arealweighted (gcn, landpft) IF (p_is_io) THEN ! soil layer litter & carbon (gC m-3) @@ -834,30 +836,30 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & ENDIF - CALL mc2p%map_aweighted (litr1c_grid, nl_soil, litr1c_vr) - CALL mc2p%map_aweighted (litr2c_grid, nl_soil, litr2c_vr) - CALL mc2p%map_aweighted (litr3c_grid, nl_soil, litr3c_vr) - CALL mc2p%map_aweighted (cwdc_grid , nl_soil, cwdc_vr ) - CALL mc2p%map_aweighted (soil1c_grid, nl_soil, soil1c_vr) - CALL mc2p%map_aweighted (soil2c_grid, nl_soil, soil2c_vr) - CALL mc2p%map_aweighted (soil3c_grid, nl_soil, soil3c_vr) - CALL mc2p%map_aweighted (litr1n_grid, nl_soil, litr1n_vr) - CALL mc2p%map_aweighted (litr2n_grid, nl_soil, litr2n_vr) - CALL mc2p%map_aweighted (litr3n_grid, nl_soil, litr3n_vr) - CALL mc2p%map_aweighted (cwdn_grid , nl_soil, cwdn_vr ) - CALL mc2p%map_aweighted (soil1n_grid, nl_soil, soil1n_vr) - CALL mc2p%map_aweighted (soil2n_grid, nl_soil, soil2n_vr) - CALL mc2p%map_aweighted (soil3n_grid, nl_soil, soil3n_vr) - CALL mc2p%map_aweighted (smin_nh4_grid , nl_soil, min_nh4_vr ) - CALL mc2p%map_aweighted (smin_no3_grid , nl_soil, min_no3_vr ) - CALL mc2f%map_aweighted (leafc_grid, leafcin_p ) - CALL mc2f%map_aweighted (leafc_storage_grid, leafc_storagein_p ) - CALL mc2f%map_aweighted (frootc_grid, frootcin_p ) - CALL mc2f%map_aweighted (frootc_storage_grid, frootc_storagein_p ) - CALL mc2f%map_aweighted (livestemc_grid, livestemcin_p ) - CALL mc2f%map_aweighted (deadstemc_grid, deadstemcin_p ) - CALL mc2f%map_aweighted (livecrootc_grid, livecrootcin_p ) - CALL mc2f%map_aweighted (deadcrootc_grid, deadcrootcin_p ) + CALL mc2p%grid2pset (litr1c_grid, nl_soil, litr1c_vr) + CALL mc2p%grid2pset (litr2c_grid, nl_soil, litr2c_vr) + CALL mc2p%grid2pset (litr3c_grid, nl_soil, litr3c_vr) + CALL mc2p%grid2pset (cwdc_grid , nl_soil, cwdc_vr ) + CALL mc2p%grid2pset (soil1c_grid, nl_soil, soil1c_vr) + CALL mc2p%grid2pset (soil2c_grid, nl_soil, soil2c_vr) + CALL mc2p%grid2pset (soil3c_grid, nl_soil, soil3c_vr) + CALL mc2p%grid2pset (litr1n_grid, nl_soil, litr1n_vr) + CALL mc2p%grid2pset (litr2n_grid, nl_soil, litr2n_vr) + CALL mc2p%grid2pset (litr3n_grid, nl_soil, litr3n_vr) + CALL mc2p%grid2pset (cwdn_grid , nl_soil, cwdn_vr ) + CALL mc2p%grid2pset (soil1n_grid, nl_soil, soil1n_vr) + CALL mc2p%grid2pset (soil2n_grid, nl_soil, soil2n_vr) + CALL mc2p%grid2pset (soil3n_grid, nl_soil, soil3n_vr) + CALL mc2p%grid2pset (smin_nh4_grid , nl_soil, min_nh4_vr ) + CALL mc2p%grid2pset (smin_no3_grid , nl_soil, min_no3_vr ) + CALL mc2f%grid2pset (leafc_grid, leafcin_p ) + CALL mc2f%grid2pset (leafc_storage_grid, leafc_storagein_p ) + CALL mc2f%grid2pset (frootc_grid, frootcin_p ) + CALL mc2f%grid2pset (frootc_storage_grid, frootc_storagein_p ) + CALL mc2f%grid2pset (livestemc_grid, livestemcin_p ) + CALL mc2f%grid2pset (deadstemc_grid, deadstemcin_p ) + CALL mc2f%grid2pset (livecrootc_grid, livecrootcin_p ) + CALL mc2f%grid2pset (deadcrootc_grid, deadcrootcin_p ) IF (p_is_worker) THEN DO i = 1, numpatch @@ -953,8 +955,10 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & ENDIF ENDIF - CALL msnow2p%build (gsnow, landpatch, snow_d_grid, missing_value, validval) - CALL msnow2p%map_aweighted (snow_d_grid, snow_d) + CALL msnow2p%build_arealweighted (gsnow, landpatch) + CALL msnow2p%set_missing_value (snow_d_grid, missing_value, validval) + + CALL msnow2p%grid2pset (snow_d_grid, snow_d) IF (p_is_worker) THEN WHERE (.not. validval) @@ -996,8 +1000,8 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & CALL ncio_read_block_time (fwtd, 'wtd', gwtd, month, wtd_xy) ENDIF - CALL m_wtd2p%build (gwtd, landpatch) - CALL m_wtd2p%map_aweighted (wtd_xy, zwt) + CALL m_wtd2p%build_arealweighted (gwtd, landpatch) + CALL m_wtd2p%grid2pset (wtd_xy, zwt) ENDIF diff --git a/mkinidata/MOD_PercentagesPFTReadin.F90 b/mkinidata/MOD_PercentagesPFTReadin.F90 index 4c480a6d..34745310 100644 --- a/mkinidata/MOD_PercentagesPFTReadin.F90 +++ b/mkinidata/MOD_PercentagesPFTReadin.F90 @@ -27,7 +27,7 @@ SUBROUTINE pct_readin (dir_landdata, lc_year) #endif #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT - USE MOD_Vars_PFTimeInvariants, only : pftfrac + USE MOD_Vars_PFTimeInvariants #endif #ifdef SinglePoint USE MOD_SingleSrfdata @@ -53,13 +53,12 @@ SUBROUTINE pct_readin (dir_landdata, lc_year) #if (defined CROP) #ifndef SinglePoint lndname = trim(dir_landdata)//'/pctpft/'//trim(cyear)//'/pct_crops.nc' - CALL ncio_read_vector (lndname, 'pct_crops', landpatch, pctshrpch) + CALL ncio_read_vector (lndname, 'pct_crops', landpatch, cropfrac) #else - allocate (pctshrpch (numpatch)) IF (SITE_landtype == CROPLAND) THEN - pctshrpch = pack(SITE_pctcrop, SITE_pctcrop > 0.) + cropfrac = pack(SITE_pctcrop, SITE_pctcrop > 0.) ELSE - pctshrpch = 0. + cropfrac = 0. ENDIF #endif #endif @@ -81,10 +80,10 @@ SUBROUTINE pct_readin (dir_landdata, lc_year) CALL check_vector_data ('Sum PFT pct', sumpct) #if (defined CROP) - CALL check_vector_data ('CROP pct', pctshrpch) + CALL check_vector_data ('CROP pct', cropfrac) #endif - #endif + #endif IF (allocated(sumpct)) deallocate(sumpct) diff --git a/mksrfdata/MKSRFDATA.F90 b/mksrfdata/MKSRFDATA.F90 index b37db32c..368325ea 100644 --- a/mksrfdata/MKSRFDATA.F90 +++ b/mksrfdata/MKSRFDATA.F90 @@ -335,11 +335,7 @@ PROGRAM MKSRFDATA ! 3. Mapping land characteristic parameters to the model grids ! ................................................................ #ifdef SrfdataDiag -#if (defined CROP) - CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) -#else CALL elm_patch%build (landelm, landpatch, use_frac = .true.) -#endif #ifdef GRIDBASED CALL gdiag%define_by_copy (gridmesh) #else diff --git a/mksrfdata/MOD_ElmVector.F90 b/mksrfdata/MOD_ElmVector.F90 index 6fa43184..3258c00f 100644 --- a/mksrfdata/MOD_ElmVector.F90 +++ b/mksrfdata/MOD_ElmVector.F90 @@ -53,11 +53,7 @@ SUBROUTINE elm_vector_init integer, allocatable :: order (:) IF (p_is_worker) THEN -#if (defined CROP) - CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) -#else CALL elm_patch%build (landelm, landpatch, use_frac = .true.) -#endif ENDIF IF (p_is_worker) THEN diff --git a/mksrfdata/MOD_HRUVector.F90 b/mksrfdata/MOD_HRUVector.F90 index ce300013..094c0805 100644 --- a/mksrfdata/MOD_HRUVector.F90 +++ b/mksrfdata/MOD_HRUVector.F90 @@ -58,11 +58,7 @@ SUBROUTINE hru_vector_init CALL basin_hru%build (landelm, landhru, use_frac = .true.) -#if (defined CROP) - CALL hru_patch%build (landhru, landpatch, use_frac = .true., sharedfrac = pctshrpch) -#else CALL hru_patch%build (landhru, landpatch, use_frac = .true.) -#endif IF (numelm > 0) THEN allocate (nhru_bsn (numelm)) diff --git a/mksrfdata/MOD_LandCrop.F90 b/mksrfdata/MOD_LandCrop.F90 index 58ce8c21..5e60c050 100644 --- a/mksrfdata/MOD_LandCrop.F90 +++ b/mksrfdata/MOD_LandCrop.F90 @@ -85,6 +85,10 @@ SUBROUTINE landcrop_build (lc_year) landpatch%ipxstt(:) = 1 landpatch%ipxend(:) = 1 landpatch%settyp(:) = CROPLAND + + landpatch%has_shared = .true. + allocate (landpatch%pctshared(numpatch)) + landpatch%pctshared = pctshrpch landpatch%nset = numpatch CALL landpatch%set_vecgs @@ -138,6 +142,14 @@ SUBROUTINE landcrop_build (lc_year) numpatch = landpatch%nset + landpatch%has_shared = .true. + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate(landpatch%pctshared(numpatch)) + landpatch%pctshared = pctshrpch + ENDIF + ENDIF + IF (allocated(pctshared )) deallocate(pctshared ) IF (allocated(classshared)) deallocate(classshared) @@ -154,9 +166,9 @@ SUBROUTINE landcrop_build (lc_year) write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' #endif - CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) #ifdef CATCHMENT - CALL hru_patch%build (landhru, landpatch, use_frac = .true., sharedfrac = pctshrpch) + CALL hru_patch%build (landhru, landpatch, use_frac = .true.) #endif CALL write_patchfrac (DEF_dir_landdata, lc_year) diff --git a/mksrfdata/MOD_LandPFT.F90 b/mksrfdata/MOD_LandPFT.F90 index 0c93c4c4..61f83de3 100644 --- a/mksrfdata/MOD_LandPFT.F90 +++ b/mksrfdata/MOD_LandPFT.F90 @@ -108,6 +108,9 @@ SUBROUTINE landpft_build (lc_year) allocate(pft2patch (numpft)) + landpft%has_shared = .true. + allocate (landpft%pctshared (numpft)) + #ifndef CROP IF (patchtypes(landpatch%settyp(1)) == 0) THEN #else @@ -118,6 +121,8 @@ SUBROUTINE landpft_build (lc_year) pft2patch (:) = 1 patch_pft_s(:) = 1 patch_pft_e(:) = numpft + + landpft%pctshared = pack(SITE_pctpfts, SITE_pctpfts > 0.) #ifdef CROP ELSEIF (landpatch%settyp(1) == CROPLAND) THEN DO ipft = 1, numpft @@ -126,6 +131,8 @@ SUBROUTINE landpft_build (lc_year) patch_pft_s (ipft) = ipft patch_pft_e (ipft) = ipft ENDDO + + landpft%pctshared = landpatch%pctshared #endif ENDIF ELSE @@ -144,6 +151,8 @@ SUBROUTINE landpft_build (lc_year) #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif + + landpft%has_shared = .true. IF (p_is_io) THEN @@ -222,6 +231,9 @@ SUBROUTINE landpft_build (lc_year) allocate (landpft%ipxend (numpft)) allocate (landpft%ielm (numpft)) + allocate (landpft%pctshared (numpft)) + landpft%pctshared(:) = 1. + npft = 0 npatch = 0 DO ipatch = 1, numpatch @@ -246,6 +258,8 @@ SUBROUTINE landpft_build (lc_year) landpft%ipxend(npft) = landpatch%ipxend(ipatch) landpft%settyp(npft) = ipft + landpft%pctshared(npft) = pctpft_patch(ipft,ipatch) + pft2patch(npft) = npatch ENDIF ENDDO @@ -260,6 +274,8 @@ SUBROUTINE landpft_build (lc_year) landpft%ipxstt(npft) = landpatch%ipxstt(ipatch) landpft%ipxend(npft) = landpatch%ipxend(ipatch) landpft%settyp(npft) = cropclass(ipatch) + N_PFT - 1 + + landpft%pctshared(npft) = landpatch%pctshared(ipatch) pft2patch(npft) = npatch #endif diff --git a/mksrfdata/MOD_PixelsetShared.F90 b/mksrfdata/MOD_PixelsetShared.F90 index 7b60ade6..dbc8c054 100644 --- a/mksrfdata/MOD_PixelsetShared.F90 +++ b/mksrfdata/MOD_PixelsetShared.F90 @@ -150,6 +150,8 @@ SUBROUTINE pixelsetshared_build (pixelset, gshared, datashared, nmaxshared, typf allocate (fracout (nsetshared)) allocate (sharedclass(nsetshared)) + fracout(:) = 1.0 + jpset = 0 DO ipset = 1, pixelset%nset IF (any(typfilter(:) == settyp1(ipset))) THEN diff --git a/mksrfdata/MOD_SrfdataDiag.F90 b/mksrfdata/MOD_SrfdataDiag.F90 index ac6222da..6793b7a9 100644 --- a/mksrfdata/MOD_SrfdataDiag.F90 +++ b/mksrfdata/MOD_SrfdataDiag.F90 @@ -21,21 +21,21 @@ MODULE MOD_SrfdataDiag !----------------------------------------------------------------------------------------- USE MOD_Grid - USE MOD_Mapping_Pset2Grid + USE MOD_SpatialMapping IMPLICIT NONE ! PUBLIC variables and subroutines type(grid_type) :: gdiag - type(mapping_pset2grid_type) :: m_elm2diag + type(spatial_mapping_type) :: m_elm2diag - type(mapping_pset2grid_type) :: m_patch2diag + type(spatial_mapping_type) :: m_patch2diag #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - type(mapping_pset2grid_type) :: m_pft2diag + type(spatial_mapping_type) :: m_pft2diag #endif #ifdef URBAN_MODEL - type(mapping_pset2grid_type) :: m_urb2diag + type(spatial_mapping_type) :: m_urb2diag #endif PUBLIC :: srfdata_diag_init @@ -80,20 +80,16 @@ SUBROUTINE srfdata_diag_init (dir_landdata) CALL srf_concat%set (gdiag) - CALL m_elm2diag%build (landelm, gdiag) + CALL m_elm2diag%build_arealweighted (gdiag, landelm) -#ifndef CROP - CALL m_patch2diag%build (landpatch, gdiag) -#else - CALL m_patch2diag%build (landpatch, gdiag, pctshrpch) -#endif + CALL m_patch2diag%build_arealweighted (gdiag, landpatch) #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL m_pft2diag%build (landpft, gdiag) + CALL m_pft2diag%build_arealweighted (gdiag, landpft) #endif #ifdef URBAN_MODEL - CALL m_urb2diag%build (landurban, gdiag) + CALL m_urb2diag%build_arealweighted (gdiag, landurban) #endif srf_data_id = 666 @@ -139,7 +135,7 @@ SUBROUTINE srfdata_map_and_write ( & integer , intent(in) :: settyp (:) integer , intent(in) :: typindex (:) - type(mapping_pset2grid_type), intent(in) :: m_srf + type(spatial_mapping_type), intent(in) :: m_srf real(r8), intent(in) :: spv @@ -185,8 +181,8 @@ SUBROUTINE srfdata_map_and_write ( & ENDIF ENDIF - CALL m_srf%map_split (vecone , settyp, typindex, sumwt, spv) - CALL m_srf%map_split (vsrfdata, settyp, typindex, wdata, spv) + CALL m_srf%pset2grid_split (vecone , settyp, typindex, sumwt, spv) + CALL m_srf%pset2grid_split (vsrfdata, settyp, typindex, wdata, spv) IF (p_is_io) THEN DO iblkme = 1, gblock%nblkme diff --git a/mksrfdata/MOD_SrfdataRestart.F90 b/mksrfdata/MOD_SrfdataRestart.F90 index 1e61b7e0..ac17da1b 100644 --- a/mksrfdata/MOD_SrfdataRestart.F90 +++ b/mksrfdata/MOD_SrfdataRestart.F90 @@ -393,6 +393,10 @@ SUBROUTINE pixelset_save_to_file (dir_landdata, psetname, pixelset, lc_year) CALL ncio_write_vector (filename, 'ipxend', trim(psetname), pixelset, pixelset%ipxend, DEF_Srfdata_CompressLevel) CALL ncio_write_vector (filename, 'settyp', trim(psetname), pixelset, pixelset%settyp, DEF_Srfdata_CompressLevel) + IF (pixelset%has_shared) THEN + CALL ncio_write_vector (filename, 'pctshared', trim(psetname), pixelset, pixelset%pctshared, DEF_Srfdata_CompressLevel) + ENDIF + #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif @@ -611,6 +615,26 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ENDIF numset = pixelset%nset + + pixelset%has_shared = .false. + IF (p_is_worker) THEN + DO iset = 1, pixelset%nset-1 + IF ((pixelset%ielm(iset) == pixelset%ielm(iset+1)) & + .and. (pixelset%ipxstt(iset) == pixelset%ipxstt(iset+1))) THEN + pixelset%has_shared = .true. + exit + ENDIF + ENDDO + ENDIF + +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, pixelset%has_shared, 1, MPI_LOGICAL, & + MPI_LOR, p_comm_glb, p_err) +#endif + + IF (pixelset%has_shared) THEN + CALL ncio_read_vector (filename, 'pctshared', pixelset, pixelset%pctshared) + ENDIF #ifdef CoLMDEBUG IF (p_is_io) write(*,*) numset, trim(psetname), ' on group', p_iam_io diff --git a/run/forcing/ERA5LAND.nml b/run/forcing/ERA5LAND.nml index edb1bd6e..b0e46c66 100644 --- a/run/forcing/ERA5LAND.nml +++ b/run/forcing/ERA5LAND.nml @@ -1,7 +1,7 @@ &nl_colm_forcing ! ----- forcing ----- - DEF_dir_forcing = '/tera06/zhwei/CoLM_Forcing/ERA5LAND/' + DEF_dir_forcing = '/shr03/CoLM_Forcing/ERA5LAND/' DEF_forcing%dataset = 'ERA5LAND' DEF_forcing%solarin_all_band = .true. diff --git a/share/MOD_DataType.F90 b/share/MOD_DataType.F90 index e4e94b15..62dba08f 100644 --- a/share/MOD_DataType.F90 +++ b/share/MOD_DataType.F90 @@ -136,6 +136,7 @@ MODULE MOD_DataType PUBLIC :: block_data_linear_transform PUBLIC :: block_data_copy PUBLIC :: block_data_linear_interp + PUBLIC :: block_data_division CONTAINS @@ -655,5 +656,54 @@ SUBROUTINE block_data_linear_interp ( & END SUBROUTINE block_data_linear_interp + !----------------- + SUBROUTINE block_data_division (gdata, sumdata, spv) + + USE MOD_Precision + USE MOD_Block + USE MOD_SPMD_Task + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + type(block_data_real8_2d), intent(inout) :: gdata + type(block_data_real8_2d), intent(inout) :: sumdata + real(r8), intent(in), optional :: spv + + ! Local variables + integer :: iblkme, iblk, jblk + + IF (p_is_io) THEN + + IF (.not. present(spv)) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + WHERE (sumdata%blk(iblk,jblk)%val > 0.) + gdata%blk(iblk,jblk)%val = & + gdata%blk(iblk,jblk)%val / sumdata%blk(iblk,jblk)%val + ELSEWHERE + gdata%blk(iblk,jblk)%val = spval + ENDWHERE + ENDDO + + ELSE + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + WHERE ((sumdata%blk(iblk,jblk)%val > 0.) .and. (gdata%blk(iblk,jblk)%val /= spv)) + gdata%blk(iblk,jblk)%val = & + gdata%blk(iblk,jblk)%val / sumdata%blk(iblk,jblk)%val + ELSEWHERE + gdata%blk(iblk,jblk)%val = spv + ENDWHERE + ENDDO + + ENDIF + + ENDIF + + END SUBROUTINE block_data_division END MODULE MOD_DataType diff --git a/share/MOD_InterpBilinear.F90 b/share/MOD_InterpBilinear.F90 deleted file mode 100644 index bae7b8f5..00000000 --- a/share/MOD_InterpBilinear.F90 +++ /dev/null @@ -1,698 +0,0 @@ -#include - -MODULE MOD_InterpBilinear - -!----------------------------------------------------------------------- -! DESCRIPTION: -! -! Bilinear Interpolation module. -! -! Created by Shupeng Zhang, April 2024 -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Grid - USE MOD_DataType - IMPLICIT NONE - - !------ - type :: interp_bilinear_type - - type(grid_type) :: grid - integer :: npset - type(grid_list_type), allocatable :: glist (:) - integer, allocatable :: address(:,:,:) - real(r8), allocatable :: weight (:,:) - - CONTAINS - - procedure, PUBLIC :: build => interp_bilinear_build - procedure, PUBLIC :: interp => interp_bilinear_2d - - final :: interp_bilinear_free_mem - - END type interp_bilinear_type - -!------------------------------------------------------------------- -CONTAINS - - !------------------------------------------ - SUBROUTINE interp_bilinear_build (this, fgrid, pixelset, gfilter, missing_value, pfilter) - - USE MOD_Precision - USE MOD_Namelist - USE MOD_Block - USE MOD_Pixel - USE MOD_Grid - USE MOD_DataType - USE MOD_Mesh - USE MOD_Pixelset - USE MOD_Utils - USE MOD_SPMD_Task - USE MOD_Vars_Global, only: pi - IMPLICIT NONE - - class (interp_bilinear_type) :: this - - type(grid_type), intent(in) :: fgrid - type(pixelset_type), intent(in) :: pixelset - - type(block_data_real8_2d), intent(in), optional :: gfilter - real(r8), intent(in), optional :: missing_value - logical, intent(inout), optional :: pfilter(:) - - - ! Local variables - integer, allocatable :: ys(:), yn(:), xw(:), xe(:) - integer, allocatable :: xlist(:), ylist(:), ipt(:) - - real(r8), allocatable :: rlon_pset(:), rlat_pset(:) - real(r8), allocatable :: nwgt(:), swgt(:), wwgt(:), ewgt(:) - - logical, allocatable :: msk(:) - - integer :: iset, ilat, ilon, iwest, ieast - integer :: nglist, iloc, ng, ig - integer :: iworker, iproc, iio, idest, isrc, nrecv - integer :: rmesg(2), smesg(2) - integer :: iy, ix, xblk, yblk, xloc, yloc - - real(r8) :: lon, lonw, lone, latn, lats - real(r8) :: distn, dists, distw, diste, diffw, diffe, sumwt - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_master) THEN - write(*,*) - write(*,"(A, I7, A, I7, A)") & - 'Building bilinear interpolation from grid to pixel set: ', & - fgrid%nlat, ' grids in latitude', fgrid%nlon, ' grids in longitude' - write(*,*) - ENDIF - - this%grid%nlat = fgrid%nlat - this%grid%nlon = fgrid%nlon - - allocate (this%grid%xblk (this%grid%nlon)); this%grid%xblk = fgrid%xblk - allocate (this%grid%yblk (this%grid%nlat)); this%grid%yblk = fgrid%yblk - allocate (this%grid%xloc (this%grid%nlon)); this%grid%xloc = fgrid%xloc - allocate (this%grid%yloc (this%grid%nlat)); this%grid%yloc = fgrid%yloc - - IF (p_is_worker) THEN - - allocate (this%grid%lat_s(this%grid%nlat)); this%grid%lat_s = fgrid%lat_s - allocate (this%grid%lat_n(this%grid%nlat)); this%grid%lat_n = fgrid%lat_n - allocate (this%grid%lon_w(this%grid%nlon)); this%grid%lon_w = fgrid%lon_w - allocate (this%grid%lon_e(this%grid%nlon)); this%grid%lon_e = fgrid%lon_e - allocate (this%grid%rlon (this%grid%nlon)); CALL this%grid%set_rlon () - allocate (this%grid%rlat (this%grid%nlat)); CALL this%grid%set_rlat () - - this%npset = pixelset%nset - - allocate (yn (this%npset)) - allocate (ys (this%npset)) - allocate (xw (this%npset)) - allocate (xe (this%npset)) - allocate (rlon_pset (this%npset)) - allocate (rlat_pset (this%npset)) - - CALL pixelset%get_lonlat_radian (rlon_pset, rlat_pset) - - allocate (xlist(4*this%npset)) - allocate (ylist(4*this%npset)) - - allocate (nwgt (this%npset)) - allocate (swgt (this%npset)) - allocate (wwgt (this%npset)) - allocate (ewgt (this%npset)) - - nglist = 0 - - DO iset = 1, this%npset - - IF (this%grid%rlat(1) > this%grid%rlat(this%grid%nlat)) THEN - ! from north to south - ilat = 1 - DO WHILE ((rlat_pset(iset) < this%grid%rlat(ilat)) .and. (ilat < this%grid%nlat)) - ilat = ilat + 1 - ENDDO - - IF (rlat_pset(iset) >= this%grid%rlat(ilat)) THEN - yn(iset) = max(ilat-1,1) - ys(iset) = ilat - ELSE - yn(iset) = this%grid%nlat - ys(iset) = this%grid%nlat - ENDIF - ELSE - ! from south to north - ilat = this%grid%nlat - DO WHILE ((rlat_pset(iset) < this%grid%rlat(ilat)) .and. (ilat > 1)) - ilat = ilat - 1 - ENDDO - - IF (rlat_pset(iset) >= this%grid%rlat(ilat)) THEN - yn(iset) = min(ilat+1,this%grid%nlat) - ys(iset) = ilat - ELSE - yn(iset) = 1 - ys(iset) = 1 - ENDIF - ENDIF - - IF (yn(iset) /= ys(iset)) THEN - latn = this%grid%rlat(yn(iset)) - lats = this%grid%rlat(ys(iset)) - distn = arclen(rlat_pset(iset), rlon_pset(iset), latn, rlon_pset(iset)) - dists = arclen(rlat_pset(iset), rlon_pset(iset), lats, rlon_pset(iset)) - nwgt(iset) = dists/(dists+distn) - swgt(iset) = distn/(dists+distn) - ELSE - nwgt(iset) = 1.0 - swgt(iset) = 0.0 - ENDIF - - - lon = rlon_pset(iset)*180.0/pi - CALL normalize_longitude (lon) - - DO iwest = 1, this%grid%nlon - lonw = this%grid%rlon(iwest) *180.0/pi - CALL normalize_longitude (lonw) - - ieast = mod(iwest,this%grid%nlon) + 1 - lone = this%grid%rlon(ieast)*180.0/pi - CALL normalize_longitude (lone) - - IF (lon_between_floor(lon, lonw, lone)) EXIT - ENDDO - - xw(iset) = iwest - xe(iset) = ieast - - ! for the case grid does not cover [-180,180) - IF ((iwest == this%grid%nlon) .and. (this%grid%nlon > 1)) THEN - IF (lon_between_floor( & - this%grid%lon_e(this%grid%nlon), lonw, this%grid%lon_w(1))) THEN - - diffw = lon - lonw; IF (diffw < 0) diffw = diffw + 360.0 - diffe = lone - lon; IF (diffe < 0) diffe = diffe + 360.0 - - IF (diffw > diffe) THEN - xw(iset) = ieast - xe(iset) = ieast - ELSE - xw(iset) = iwest - xe(iset) = iwest - ENDIF - - ENDIF - ENDIF - - IF (xw(iset) /= xe(iset)) THEN - lonw = this%grid%rlon(xw(iset)) - lone = this%grid%rlon(xe(iset)) - distw = arclen(rlat_pset(iset), rlon_pset(iset), rlat_pset(iset), lonw) - diste = arclen(rlat_pset(iset), rlon_pset(iset), rlat_pset(iset), lone) - wwgt(iset) = diste/(distw+diste) - ewgt(iset) = distw/(distw+diste) - ELSE - wwgt(iset) = 1.0 - ewgt(iset) = 0.0 - ENDIF - - CALL insert_into_sorted_list2 ( xw(iset), yn(iset), nglist, xlist, ylist, iloc) - CALL insert_into_sorted_list2 ( xe(iset), yn(iset), nglist, xlist, ylist, iloc) - CALL insert_into_sorted_list2 ( xw(iset), ys(iset), nglist, xlist, ylist, iloc) - CALL insert_into_sorted_list2 ( xe(iset), ys(iset), nglist, xlist, ylist, iloc) - - ENDDO - -#ifdef USEMPI - allocate (ipt (nglist)) - allocate (msk (nglist)) - DO ig = 1, nglist - xblk = this%grid%xblk(xlist(ig)) - yblk = this%grid%yblk(ylist(ig)) - ipt(ig) = gblock%pio(xblk,yblk) - ENDDO -#endif - - allocate (this%glist (0:p_np_io-1)) - DO iproc = 0, p_np_io-1 -#ifdef USEMPI - msk = (ipt == p_address_io(iproc)) - ng = count(msk) -#else - ng = nglist -#endif - - IF (ng > 0) THEN - allocate (this%glist(iproc)%ilat (ng)) - allocate (this%glist(iproc)%ilon (ng)) - ENDIF - - this%glist(iproc)%ng = 0 - ENDDO - - DO ig = 1, nglist -#ifdef USEMPI - iproc = p_itis_io(ipt(ig)) -#else - iproc = 0 -#endif - this%glist(iproc)%ng = this%glist(iproc)%ng + 1 - - ng = this%glist(iproc)%ng - this%glist(iproc)%ilon(ng) = xlist(ig) - this%glist(iproc)%ilat(ng) = ylist(ig) - ENDDO - - deallocate (xlist) - deallocate (ylist) - -#ifdef USEMPI - deallocate (ipt) - deallocate (msk) -#endif - - ENDIF - -#ifdef USEMPI - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 - idest = p_address_io(iproc) - smesg = (/p_iam_glb, this%glist(iproc)%ng/) - - CALL mpi_send (smesg, 2, MPI_INTEGER, & - idest, mpi_tag_mesg, p_comm_glb, p_err) - - IF (this%glist(iproc)%ng > 0) THEN - CALL mpi_send (this%glist(iproc)%ilon, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (this%glist(iproc)%ilat, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO - ENDIF - - IF (p_is_io) THEN - - allocate (this%glist (0:p_np_worker-1)) - - DO iworker = 0, p_np_worker-1 - - CALL mpi_recv (rmesg, 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - nrecv = rmesg(2) - iproc = p_itis_worker(isrc) - - this%glist(iproc)%ng = nrecv - - IF (nrecv > 0) THEN - allocate (this%glist(iproc)%ilon (nrecv)) - allocate (this%glist(iproc)%ilat (nrecv)) - - CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - - ENDDO - - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (present(missing_value)) THEN - - IF (p_is_io) THEN - DO iproc = 0, p_np_worker-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (msk (this%glist(iproc)%ng)) - - DO ig = 1, this%glist(iproc)%ng - ilon = this%glist(iproc)%ilon(ig) - ilat = this%glist(iproc)%ilat(ig) - xblk = this%grid%xblk (ilon) - yblk = this%grid%yblk (ilat) - xloc = this%grid%xloc (ilon) - yloc = this%grid%yloc (ilat) - - msk(ig) = gfilter%blk(xblk,yblk)%val(xloc,yloc) /= missing_value - ENDDO - - IF (any(.not. msk)) THEN - - this%glist(iproc)%ng = count(msk) - - IF (this%glist(iproc)%ng > 0) THEN - allocate (xlist(this%glist(iproc)%ng)) - allocate (ylist(this%glist(iproc)%ng)) - xlist = pack(this%glist(iproc)%ilon, mask=msk) - ylist = pack(this%glist(iproc)%ilat, mask=msk) - ENDIF - - deallocate (this%glist(iproc)%ilon) - deallocate (this%glist(iproc)%ilat) - - IF (this%glist(iproc)%ng > 0) THEN - allocate (this%glist(iproc)%ilon(this%glist(iproc)%ng)) - allocate (this%glist(iproc)%ilat(this%glist(iproc)%ng)) - this%glist(iproc)%ilon = xlist - this%glist(iproc)%ilat = ylist - ENDIF - - IF (allocated(xlist)) deallocate(xlist) - IF (allocated(ylist)) deallocate(ylist) - ENDIF - - deallocate(msk) - ENDIF - ENDDO - ENDIF - -#ifdef USEMPI - IF (p_is_io) THEN - DO iworker = 0, p_np_worker-1 - - idest = p_address_worker(iworker) - smesg = (/p_iam_glb, this%glist(iworker)%ng/) - CALL mpi_send (smesg, 2, MPI_INTEGER, & - idest, mpi_tag_mesg, p_comm_glb, p_err) - - IF (this%glist(iworker)%ng > 0) THEN - CALL mpi_send (this%glist(iworker)%ilon, this%glist(iworker)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (this%glist(iworker)%ilat, this%glist(iworker)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO - ENDIF - - IF (p_is_worker) THEN - DO iio = 0, p_np_io-1 - - CALL mpi_recv (rmesg, 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - nrecv = rmesg(2) - iproc = p_itis_io(isrc) - - this%glist(iproc)%ng = nrecv - - IF (allocated(this%glist(iproc)%ilon)) deallocate(this%glist(iproc)%ilon) - IF (allocated(this%glist(iproc)%ilat)) deallocate(this%glist(iproc)%ilat) - - IF (nrecv > 0) THEN - allocate (this%glist(iproc)%ilon (nrecv)) - allocate (this%glist(iproc)%ilat (nrecv)) - - CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDDO - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (this%address (2,4,this%npset)) - allocate (this%weight (4,this%npset)) - - DO iset = 1, pixelset%nset - - ! northwest grid -#ifdef USEMPI - ix = xw(iset); xblk = this%grid%xblk(ix) - iy = yn(iset); yblk = this%grid%yblk(iy) - iproc = p_itis_io(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif - this%address(1,1,iset) = iproc - IF (this%glist(iproc)%ng > 0) THEN - this%address(2,1,iset) = find_in_sorted_list2 ( ix, iy, & - this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) - ELSE - this%address(2,1,iset) = -1 - ENDIF - - IF (this%address(2,1,iset) > 0) THEN - this%weight(1,iset) = nwgt(iset) * wwgt(iset) - ELSE - this%weight(1,iset) = 0 - ENDIF - - ! northeast grid -#ifdef USEMPI - ix = xe(iset); xblk = this%grid%xblk(ix) - iy = yn(iset); yblk = this%grid%yblk(iy) - iproc = p_itis_io(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif - this%address(1,2,iset) = iproc - IF (this%glist(iproc)%ng > 0) THEN - this%address(2,2,iset) = find_in_sorted_list2 ( ix, iy, & - this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) - ELSE - this%address(2,2,iset) = -1 - ENDIF - - IF (this%address(2,2,iset) > 0) THEN - this%weight(2,iset) = nwgt(iset) * ewgt(iset) - ELSE - this%weight(2,iset) = 0 - ENDIF - - ! southwest -#ifdef USEMPI - ix = xw(iset); xblk = this%grid%xblk(ix) - iy = ys(iset); yblk = this%grid%yblk(iy) - iproc = p_itis_io(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif - this%address(1,3,iset) = iproc - IF (this%glist(iproc)%ng > 0) THEN - this%address(2,3,iset) = find_in_sorted_list2 ( ix, iy, & - this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) - ELSE - this%address(2,3,iset) = -1 - ENDIF - - IF (this%address(2,3,iset) > 0) THEN - this%weight(3,iset) = swgt(iset) * wwgt(iset) - ELSE - this%weight(3,iset) = 0 - ENDIF - - ! southeast -#ifdef USEMPI - ix = xe(iset); xblk = this%grid%xblk(ix) - iy = ys(iset); yblk = this%grid%yblk(iy) - iproc = p_itis_io(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif - this%address(1,4,iset) = iproc - IF (this%glist(iproc)%ng > 0) THEN - this%address(2,4,iset) = find_in_sorted_list2 ( ix, iy, & - this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) - ELSE - this%address(2,4,iset) = -1 - ENDIF - - IF (this%address(2,4,iset) > 0) THEN - this%weight(4,iset) = swgt(iset) * ewgt(iset) - ELSE - this%weight(4,iset) = 0 - ENDIF - - sumwt = sum(this%weight(:,iset)) - IF (sumwt > 0) THEN - this%weight(:,iset) = this%weight(:,iset) / sumwt - ENDIF - - ENDDO - - IF (present(pfilter)) THEN - pfilter = sum(this%weight, dim=1) > 0 - ENDIF - - ENDIF - - IF (allocated(this%grid%lat_s)) deallocate(this%grid%lat_s) - IF (allocated(this%grid%lat_n)) deallocate(this%grid%lat_n) - IF (allocated(this%grid%lon_w)) deallocate(this%grid%lon_w) - IF (allocated(this%grid%lon_e)) deallocate(this%grid%lon_e) - IF (allocated(this%grid%rlon )) deallocate(this%grid%rlon ) - IF (allocated(this%grid%rlat )) deallocate(this%grid%rlat ) - - IF (allocated(yn)) deallocate(yn) - IF (allocated(ys)) deallocate(ys) - IF (allocated(xw)) deallocate(xw) - IF (allocated(xe)) deallocate(xe) - - IF (allocated(rlon_pset)) deallocate(rlon_pset) - IF (allocated(rlat_pset)) deallocate(rlat_pset) - - IF (allocated(nwgt)) deallocate(nwgt) - IF (allocated(swgt)) deallocate(swgt) - IF (allocated(wwgt)) deallocate(wwgt) - IF (allocated(ewgt)) deallocate(ewgt) - - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - END SUBROUTINE interp_bilinear_build - - !----------------------------------------------------- - SUBROUTINE interp_bilinear_2d (this, gdata, pdata) - - USE MOD_Precision - USE MOD_Grid - USE MOD_Pixelset - USE MOD_DataType - USE MOD_SPMD_Task - USE MOD_Vars_Global, only : spval - IMPLICIT NONE - - class (interp_bilinear_type) :: this - - type(block_data_real8_2d), intent(in) :: gdata - real(r8), intent(out) :: pdata(:) - - ! Local variables - integer :: iproc, idest, isrc - integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset - - real(r8), allocatable :: gbuff(:) - type(pointer_real8_1d), allocatable :: pbuff(:) - - IF (p_is_io) THEN - - DO iproc = 0, p_np_worker-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (gbuff (this%glist(iproc)%ng)) - - DO ig = 1, this%glist(iproc)%ng - ilon = this%glist(iproc)%ilon(ig) - ilat = this%glist(iproc)%ilat(ig) - xblk = this%grid%xblk (ilon) - yblk = this%grid%yblk (ilat) - xloc = this%grid%xloc (ilon) - yloc = this%grid%yloc (ilat) - - gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) - - ENDDO - -#ifdef USEMPI - idest = p_address_worker(iproc) - CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (gbuff) -#endif - ENDIF - ENDDO - - ENDIF - - IF (p_is_worker) THEN - - allocate (pbuff (0:p_np_io-1)) - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) - -#ifdef USEMPI - isrc = p_address_io(iproc) - CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - pbuff(0)%val = gbuff - deallocate (gbuff) -#endif - ENDIF - ENDDO - - DO iset = 1, this%npset - pdata(iset) = spval - DO ig = 1, 4 - iproc = this%address(1,ig,iset) - iloc = this%address(2,ig,iset) - IF (iloc > 0) THEN - IF (pdata(iset) == spval) THEN - pdata(iset) = pbuff(iproc)%val(iloc) * this%weight(ig,iset) - ELSE - pdata(iset) = pdata(iset) + pbuff(iproc)%val(iloc) * this%weight(ig,iset) - ENDIF - ENDIF - ENDDO - ENDDO - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - deallocate (pbuff(iproc)%val) - ENDIF - ENDDO - - deallocate (pbuff) - - ENDIF - - END SUBROUTINE interp_bilinear_2d - - !----------------------------------------------------- - SUBROUTINE interp_bilinear_free_mem (this) - - USE MOD_SPMD_Task - IMPLICIT NONE - - type(interp_bilinear_type) :: this - - ! Local variables - integer :: iproc - - IF (allocated (this%grid%xblk)) deallocate (this%grid%xblk) - IF (allocated (this%grid%yblk)) deallocate (this%grid%yblk) - - IF (allocated (this%grid%xloc)) deallocate (this%grid%xloc) - IF (allocated (this%grid%yloc)) deallocate (this%grid%yloc) - - IF (allocated(this%glist)) THEN - DO iproc = lbound(this%glist,1), ubound(this%glist,1) - IF (allocated(this%glist(iproc)%ilat)) deallocate (this%glist(iproc)%ilat) - IF (allocated(this%glist(iproc)%ilon)) deallocate (this%glist(iproc)%ilon) - ENDDO - - deallocate (this%glist) - ENDIF - - IF (allocated(this%address)) deallocate (this%address) - IF (allocated(this%weight )) deallocate (this%weight ) - - END SUBROUTINE interp_bilinear_free_mem - -END MODULE MOD_InterpBilinear diff --git a/share/MOD_Mapping_Grid2Pset.F90 b/share/MOD_Mapping_Grid2Pset.F90 deleted file mode 100644 index 3f306b72..00000000 --- a/share/MOD_Mapping_Grid2Pset.F90 +++ /dev/null @@ -1,905 +0,0 @@ -#include - -MODULE MOD_Mapping_Grid2Pset - -!----------------------------------------------------------------------- -! DESCRIPTION: -! -! Mapping data types and subroutines from gridded data to vector data -! defined on pixelset. -! -! Notice that: -! 1. A mapping can be built with method mapping%build. -! 2. Area weighted mapping is carried out. -! 3. For 2D gridded data, dimensions are from [lon,lat] to [vector]. -! 4. For 3D gridded data, dimensions are from [d,lon,lat] to [d,vector]. -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Grid - USE MOD_DataType - IMPLICIT NONE - - !------ - type :: mapping_grid2pset_type - - type(grid_type) :: grid - integer :: npset - - type(grid_list_type), allocatable :: glist (:) - - type(pointer_int32_2d), allocatable :: address(:) - type(pointer_real8_1d), allocatable :: gweight(:) - - CONTAINS - - procedure, PUBLIC :: build => mapping_grid2pset_build - - procedure, PRIVATE :: map_aweighted_2d => map_g2p_aweighted_2d - procedure, PRIVATE :: map_aweighted_3d => map_g2p_aweighted_3d - generic, PUBLIC :: map_aweighted => map_aweighted_2d, map_aweighted_3d - - procedure, PUBLIC :: map_max_frequency_2d => map_g2p_max_frequency_2d - - final :: mapping_grid2pset_free_mem - - END type mapping_grid2pset_type - -!------------------------------------------------------------------- -CONTAINS - - !------------------------------------------ - SUBROUTINE mapping_grid2pset_build (this, fgrid, pixelset, gfilter, missing_value, pfilter) - - USE MOD_Precision - USE MOD_Namelist - USE MOD_Block - USE MOD_Pixel - USE MOD_Grid - USE MOD_DataType - USE MOD_Mesh - USE MOD_Pixelset - USE MOD_Utils - USE MOD_SPMD_Task - IMPLICIT NONE - - class (mapping_grid2pset_type) :: this - - type(grid_type), intent(in) :: fgrid - type(pixelset_type), intent(in) :: pixelset - - type(block_data_real8_2d), intent(in), optional :: gfilter - real(r8), intent(in), optional :: missing_value - logical, intent(inout), optional :: pfilter(:) - - - ! Local variables - type(pointer_real8_1d), allocatable :: afrac(:) - type(grid_list_type), allocatable :: gfrom(:) - type(pointer_int32_1d), allocatable :: list_lat(:) - integer, allocatable :: ng_lat(:) - integer, allocatable :: ys(:), yn(:), xw(:), xe(:) - integer, allocatable :: xlist(:), ylist(:) - integer, allocatable :: ipt(:) - logical, allocatable :: msk(:) - - integer :: ie, iset - integer :: ng, ig, ng_all, iloc, ng0 - integer :: npxl, ipxl, ilat, ilon - integer :: iworker, iproc, iio, idest, isrc, nrecv - integer :: rmesg(2), smesg(2) - integer :: iy, ix, xblk, yblk, xloc, yloc - real(r8) :: lat_s, lat_n, lon_w, lon_e, area - logical :: is_new - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_master) THEN - write(*,"('Making mapping from grid to pixel set: ', I7, A, I7, A)") & - fgrid%nlat, ' grids in latitude', fgrid%nlon, ' grids in longitude' - ENDIF - - IF (allocated(this%grid%xblk)) deallocate(this%grid%xblk) - IF (allocated(this%grid%yblk)) deallocate(this%grid%yblk) - IF (allocated(this%grid%xloc)) deallocate(this%grid%xloc) - IF (allocated(this%grid%yloc)) deallocate(this%grid%yloc) - allocate (this%grid%xblk (size(fgrid%xblk))) - allocate (this%grid%yblk (size(fgrid%yblk))) - allocate (this%grid%xloc (size(fgrid%xloc))) - allocate (this%grid%yloc (size(fgrid%yloc))) - - this%grid%xblk = fgrid%xblk - this%grid%yblk = fgrid%yblk - this%grid%xloc = fgrid%xloc - this%grid%yloc = fgrid%yloc - - this%npset = pixelset%nset - - IF (p_is_worker) THEN - - allocate (afrac (pixelset%nset)) - allocate (gfrom (pixelset%nset)) - - allocate (ys (pixel%nlat)) - allocate (yn (pixel%nlat)) - allocate (xw (pixel%nlon)) - allocate (xe (pixel%nlon)) - - DO ilat = 1, pixel%nlat - ys(ilat) = find_nearest_south (pixel%lat_s(ilat), fgrid%nlat, fgrid%lat_s) - yn(ilat) = find_nearest_north (pixel%lat_n(ilat), fgrid%nlat, fgrid%lat_n) - ENDDO - - DO ilon = 1, pixel%nlon - xw(ilon) = find_nearest_west (pixel%lon_w(ilon), fgrid%nlon, fgrid%lon_w) - xe(ilon) = find_nearest_east (pixel%lon_e(ilon), fgrid%nlon, fgrid%lon_e) - ENDDO - - allocate (list_lat (fgrid%nlat)) - DO iy = 1, fgrid%nlat - allocate (list_lat(iy)%val (100)) - ENDDO - - allocate (ng_lat (fgrid%nlat)) - ng_lat(:) = 0 - - DO iset = 1, pixelset%nset - - ie = pixelset%ielm(iset) - npxl = pixelset%ipxend(iset) - pixelset%ipxstt(iset) + 1 - - allocate (afrac(iset)%val (npxl)) - allocate (gfrom(iset)%ilat(npxl)) - allocate (gfrom(iset)%ilon(npxl)) - - gfrom(iset)%ng = 0 - - DO ipxl = pixelset%ipxstt(iset), pixelset%ipxend(iset) - - ilat = mesh(ie)%ilat(ipxl) - ilon = mesh(ie)%ilon(ipxl) - - DO iy = ys(ilat), yn(ilat), fgrid%yinc - - lat_s = max(fgrid%lat_s(iy), pixel%lat_s(ilat)) - lat_n = min(fgrid%lat_n(iy), pixel%lat_n(ilat)) - - IF ((lat_n-lat_s) < 1.0e-6_r8) THEN - CYCLE - ENDIF - - ix = xw(ilon) - DO WHILE (.true.) - - IF (ix == xw(ilon)) THEN - lon_w = pixel%lon_w(ilon) - ELSE - lon_w = fgrid%lon_w(ix) - ENDIF - - IF (ix == xe(ilon)) THEN - lon_e = pixel%lon_e(ilon) - ELSE - lon_e = fgrid%lon_e(ix) - ENDIF - - IF (lon_e > lon_w) THEN - IF ((lon_e-lon_w) < 1.0e-6_r8) THEN - IF (ix == xe(ilon)) EXIT - ix = mod(ix,fgrid%nlon) + 1 - CYCLE - ENDIF - ELSE - IF ((lon_e+360.0_r8-lon_w) < 1.0e-6_r8) THEN - IF (ix == xe(ilon)) EXIT - ix = mod(ix,fgrid%nlon) + 1 - CYCLE - ENDIF - ENDIF - - area = areaquad (lat_s, lat_n, lon_w, lon_e) - - CALL insert_into_sorted_list2 ( ix, iy, & - gfrom(iset)%ng, gfrom(iset)%ilon, gfrom(iset)%ilat, & - iloc, is_new) - - IF (is_new) THEN - IF (iloc < gfrom(iset)%ng) THEN - afrac(iset)%val(iloc+1:gfrom(iset)%ng) & - = afrac(iset)%val(iloc:gfrom(iset)%ng-1) - ENDIF - - afrac(iset)%val(iloc) = area - ELSE - afrac(iset)%val(iloc) = afrac(iset)%val(iloc) + area - ENDIF - - IF (gfrom(iset)%ng == size(gfrom(iset)%ilat)) THEN - CALL expand_list (gfrom(iset)%ilat, 0.2_r8) - CALL expand_list (gfrom(iset)%ilon, 0.2_r8) - CALL expand_list (afrac(iset)%val, 0.2_r8) - ENDIF - - CALL insert_into_sorted_list1 ( & - ix, ng_lat(iy), list_lat(iy)%val, iloc) - - IF (ng_lat(iy) == size(list_lat(iy)%val)) THEN - CALL expand_list (list_lat(iy)%val, 0.2_r8) - ENDIF - - IF (ix == xe(ilon)) EXIT - ix = mod(ix,fgrid%nlon) + 1 - ENDDO - ENDDO - - ENDDO - ENDDO - - deallocate (ys) - deallocate (yn) - deallocate (xw) - deallocate (xe) - - ng_all = sum(ng_lat) - allocate (xlist(ng_all)) - allocate (ylist(ng_all)) - - ig = 0 - DO iy = 1, fgrid%nlat - DO ix = 1, ng_lat(iy) - ig = ig + 1 - xlist(ig) = list_lat(iy)%val(ix) - ylist(ig) = iy - ENDDO - ENDDO - - deallocate (ng_lat) - DO iy = 1, fgrid%nlat - deallocate (list_lat(iy)%val) - ENDDO - deallocate (list_lat) - -#ifdef USEMPI - allocate (ipt (ng_all)) - allocate (msk (ng_all)) - DO ig = 1, ng_all - xblk = fgrid%xblk(xlist(ig)) - yblk = fgrid%yblk(ylist(ig)) - ipt(ig) = gblock%pio(xblk,yblk) - ENDDO -#endif - - IF (allocated(this%glist)) deallocate(this%glist) - allocate (this%glist (0:p_np_io-1)) - DO iproc = 0, p_np_io-1 -#ifdef USEMPI - msk = (ipt == p_address_io(iproc)) - ng = count(msk) -#else - ng = ng_all -#endif - - allocate (this%glist(iproc)%ilat (ng)) - allocate (this%glist(iproc)%ilon (ng)) - - this%glist(iproc)%ng = 0 - ENDDO - - DO ig = 1, ng_all -#ifdef USEMPI - iproc = p_itis_io(ipt(ig)) -#else - iproc = 0 -#endif - this%glist(iproc)%ng = this%glist(iproc)%ng + 1 - - ng = this%glist(iproc)%ng - this%glist(iproc)%ilon(ng) = xlist(ig) - this%glist(iproc)%ilat(ng) = ylist(ig) - ENDDO - - deallocate (xlist) - deallocate (ylist) - -#ifdef USEMPI - deallocate (ipt) - deallocate (msk) -#endif - - ENDIF - -#ifdef USEMPI - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 - idest = p_address_io(iproc) - smesg = (/p_iam_glb, this%glist(iproc)%ng/) - - CALL mpi_send (smesg, 2, MPI_INTEGER, & - idest, mpi_tag_mesg, p_comm_glb, p_err) - - IF (this%glist(iproc)%ng > 0) THEN - CALL mpi_send (this%glist(iproc)%ilon, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (this%glist(iproc)%ilat, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO - ENDIF - - IF (p_is_io) THEN - - IF (allocated(this%glist)) deallocate(this%glist) - allocate (this%glist (0:p_np_worker-1)) - - DO iworker = 0, p_np_worker-1 - - CALL mpi_recv (rmesg, 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - nrecv = rmesg(2) - iproc = p_itis_worker(isrc) - - this%glist(iproc)%ng = nrecv - - IF (nrecv > 0) THEN - allocate (this%glist(iproc)%ilon (nrecv)) - allocate (this%glist(iproc)%ilat (nrecv)) - - CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - - ENDDO - - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (present(missing_value)) THEN - - IF (p_is_io) THEN - DO iproc = 0, p_np_worker-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (msk (this%glist(iproc)%ng)) - - DO ig = 1, this%glist(iproc)%ng - ilon = this%glist(iproc)%ilon(ig) - ilat = this%glist(iproc)%ilat(ig) - xblk = this%grid%xblk (ilon) - yblk = this%grid%yblk (ilat) - xloc = this%grid%xloc (ilon) - yloc = this%grid%yloc (ilat) - - msk(ig) = gfilter%blk(xblk,yblk)%val(xloc,yloc) /= missing_value - ENDDO - - IF (any(.not. msk)) THEN - - this%glist(iproc)%ng = count(msk) - - IF (this%glist(iproc)%ng > 0) THEN - allocate (xlist(this%glist(iproc)%ng)) - allocate (ylist(this%glist(iproc)%ng)) - xlist = pack(this%glist(iproc)%ilon, mask=msk) - ylist = pack(this%glist(iproc)%ilat, mask=msk) - ENDIF - - deallocate (this%glist(iproc)%ilon) - deallocate (this%glist(iproc)%ilat) - - IF (this%glist(iproc)%ng > 0) THEN - allocate (this%glist(iproc)%ilon(this%glist(iproc)%ng)) - allocate (this%glist(iproc)%ilat(this%glist(iproc)%ng)) - this%glist(iproc)%ilon = xlist - this%glist(iproc)%ilat = ylist - ENDIF - - IF (allocated(xlist)) deallocate(xlist) - IF (allocated(ylist)) deallocate(ylist) - ENDIF - - deallocate(msk) - ENDIF - ENDDO - ENDIF - -#ifdef USEMPI - IF (p_is_io) THEN - DO iworker = 0, p_np_worker-1 - - idest = p_address_worker(iworker) - smesg = (/p_iam_glb, this%glist(iworker)%ng/) - CALL mpi_send (smesg, 2, MPI_INTEGER, & - idest, mpi_tag_mesg, p_comm_glb, p_err) - - IF (this%glist(iworker)%ng > 0) THEN - CALL mpi_send (this%glist(iworker)%ilon, this%glist(iworker)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (this%glist(iworker)%ilat, this%glist(iworker)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO - ENDIF - - IF (p_is_worker) THEN - DO iio = 0, p_np_io-1 - - CALL mpi_recv (rmesg, 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - nrecv = rmesg(2) - iproc = p_itis_io(isrc) - - this%glist(iproc)%ng = nrecv - - IF (allocated(this%glist(iproc)%ilon)) deallocate(this%glist(iproc)%ilon) - IF (allocated(this%glist(iproc)%ilat)) deallocate(this%glist(iproc)%ilat) - - IF (nrecv > 0) THEN - allocate (this%glist(iproc)%ilon (nrecv)) - allocate (this%glist(iproc)%ilat (nrecv)) - - CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDDO - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_worker) THEN - DO iset = 1, pixelset%nset - - allocate (msk(gfrom(iset)%ng)) - - DO ig = 1, gfrom(iset)%ng - ilon = gfrom(iset)%ilon(ig) - ilat = gfrom(iset)%ilat(ig) - xblk = fgrid%xblk(ilon) - yblk = fgrid%yblk(ilat) -#ifdef USEMPI - iproc = p_itis_io(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif - msk(ig) = find_in_sorted_list2 (ilon, ilat, this%glist(iproc)%ng, & - this%glist(iproc)%ilon, this%glist(iproc)%ilat) > 0 - - ENDDO - - IF (present(pfilter)) THEN - pfilter(iset) = any(msk) - ENDIF - - ng0 = gfrom(iset)%ng - gfrom(iset)%ng = count(msk) - IF (any(msk) .and. any(.not. msk)) THEN - ng = gfrom(iset)%ng - gfrom(iset)%ilon(1:ng) = pack(gfrom(iset)%ilon(1:ng0), mask = msk) - gfrom(iset)%ilat(1:ng) = pack(gfrom(iset)%ilat(1:ng0), mask = msk) - afrac(iset)%val (1:ng) = pack(afrac(iset)%val (1:ng0), mask = msk) - ENDIF - - deallocate (msk) - ENDDO - ENDIF - ENDIF - - IF (p_is_worker) THEN - - IF (allocated(this%address)) deallocate(this%address) - IF (allocated(this%gweight)) deallocate(this%gweight) - allocate (this%address (pixelset%nset)) - allocate (this%gweight (pixelset%nset)) - - DO iset = 1, pixelset%nset - - ng = gfrom(iset)%ng - IF (ng > 0) THEN - allocate (this%address(iset)%val (2,ng)) - allocate (this%gweight(iset)%val (ng)) - - IF (sum(afrac(iset)%val(1:ng)) < 1.0e-12) THEN - this%gweight(iset)%val = 1.0_r8 / ng - ELSE - this%gweight(iset)%val & - = afrac(iset)%val(1:ng) / sum(afrac(iset)%val(1:ng)) - ENDIF - - DO ig = 1, gfrom(iset)%ng - ilon = gfrom(iset)%ilon(ig) - ilat = gfrom(iset)%ilat(ig) - xblk = fgrid%xblk(ilon) - yblk = fgrid%yblk(ilat) - -#ifdef USEMPI - iproc = p_itis_io(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif - this%address(iset)%val(1,ig) = iproc - this%address(iset)%val(2,ig) = find_in_sorted_list2 ( & - ilon, ilat, this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) - ENDDO - ENDIF - ENDDO - - DO iset = 1, pixelset%nset - deallocate (afrac(iset)%val ) - deallocate (gfrom(iset)%ilon) - deallocate (gfrom(iset)%ilat) - ENDDO - - deallocate (afrac) - deallocate (gfrom) - - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - END SUBROUTINE mapping_grid2pset_build - - !----------------------------------------------------- - SUBROUTINE map_g2p_aweighted_2d (this, gdata, pdata) - - USE MOD_Precision - USE MOD_Grid - USE MOD_Pixelset - USE MOD_DataType - USE MOD_SPMD_Task - USE MOD_Vars_Global, only : spval - IMPLICIT NONE - - class (mapping_grid2pset_type) :: this - - type(block_data_real8_2d), intent(in) :: gdata - real(r8), intent(out) :: pdata(:) - - ! Local variables - integer :: iproc, idest, isrc - integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset - - real(r8), allocatable :: gbuff(:) - type(pointer_real8_1d), allocatable :: pbuff(:) - - IF (p_is_io) THEN - - DO iproc = 0, p_np_worker-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (gbuff (this%glist(iproc)%ng)) - - DO ig = 1, this%glist(iproc)%ng - ilon = this%glist(iproc)%ilon(ig) - ilat = this%glist(iproc)%ilat(ig) - xblk = this%grid%xblk (ilon) - yblk = this%grid%yblk (ilat) - xloc = this%grid%xloc (ilon) - yloc = this%grid%yloc (ilat) - - gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) - - ENDDO - -#ifdef USEMPI - idest = p_address_worker(iproc) - CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (gbuff) -#endif - ENDIF - ENDDO - - ENDIF - - IF (p_is_worker) THEN - - allocate (pbuff (0:p_np_io-1)) - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) - -#ifdef USEMPI - isrc = p_address_io(iproc) - CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - pbuff(0)%val = gbuff - deallocate (gbuff) -#endif - ENDIF - ENDDO - - DO iset = 1, this%npset - IF (allocated(this%gweight(iset)%val)) THEN - pdata(iset) = 0._r8 - DO ig = 1, size(this%gweight(iset)%val) - iproc = this%address(iset)%val(1,ig) - iloc = this%address(iset)%val(2,ig) - - pdata(iset) = pdata(iset) & - + pbuff(iproc)%val(iloc) * this%gweight(iset)%val(ig) - ENDDO - ELSE - pdata(iset) = spval - ENDIF - ENDDO - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - deallocate (pbuff(iproc)%val) - ENDIF - ENDDO - - deallocate (pbuff) - - ENDIF - - END SUBROUTINE map_g2p_aweighted_2d - - !----------------------------------------------------- - SUBROUTINE map_g2p_aweighted_3d (this, gdata, ndim1, pdata) - - USE MOD_Precision - USE MOD_Grid - USE MOD_Pixelset - USE MOD_DataType - USE MOD_SPMD_Task - USE MOD_Vars_Global, only : spval - IMPLICIT NONE - - class (mapping_grid2pset_type) :: this - - type(block_data_real8_3d), intent(in) :: gdata - integer, intent(in) :: ndim1 - real(r8), intent(out) :: pdata(:,:) - - ! Local variables - integer :: iproc, idest, isrc - integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset - - real(r8), allocatable :: gbuff(:,:) - type(pointer_real8_2d), allocatable :: pbuff(:) - - - IF (p_is_io) THEN - - DO iproc = 0, p_np_worker-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (gbuff (ndim1, this%glist(iproc)%ng)) - - DO ig = 1, this%glist(iproc)%ng - ilon = this%glist(iproc)%ilon(ig) - ilat = this%glist(iproc)%ilat(ig) - xblk = this%grid%xblk (ilon) - yblk = this%grid%yblk (ilat) - xloc = this%grid%xloc (ilon) - yloc = this%grid%yloc (ilat) - - gbuff(:,ig) = gdata%blk(xblk,yblk)%val(:,xloc,yloc) - ENDDO - -#ifdef USEMPI - idest = p_address_worker(iproc) - CALL mpi_send (gbuff, ndim1 * this%glist(iproc)%ng, MPI_DOUBLE, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (gbuff) -#endif - ENDIF - ENDDO - - ENDIF - - IF (p_is_worker) THEN - - allocate (pbuff (0:p_np_io-1)) - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (pbuff(iproc)%val (ndim1, this%glist(iproc)%ng)) - -#ifdef USEMPI - isrc = p_address_io(iproc) - CALL mpi_recv (pbuff(iproc)%val, ndim1 * this%glist(iproc)%ng, MPI_DOUBLE, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - pbuff(0)%val = gbuff - deallocate (gbuff) -#endif - ENDIF - ENDDO - - DO iset = 1, this%npset - IF (allocated(this%gweight(iset)%val)) THEN - pdata(:,iset) = 0._r8 - DO ig = 1, size(this%gweight(iset)%val) - iproc = this%address(iset)%val(1,ig) - iloc = this%address(iset)%val(2,ig) - - pdata(:,iset) = pdata(:,iset) & - + pbuff(iproc)%val(:,iloc) * this%gweight(iset)%val(ig) - ENDDO - ELSE - pdata(:,iset) = spval - ENDIF - ENDDO - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - deallocate (pbuff(iproc)%val) - ENDIF - ENDDO - - deallocate (pbuff) - - ENDIF - - END SUBROUTINE map_g2p_aweighted_3d - - !----------------------------------------------------- - SUBROUTINE map_g2p_max_frequency_2d (this, gdata, pdata) - - USE MOD_Precision - USE MOD_Grid - USE MOD_Pixelset - USE MOD_DataType - USE MOD_SPMD_Task - USE MOD_Vars_Global, only : spval - IMPLICIT NONE - - class (mapping_grid2pset_type) :: this - - type(block_data_int32_2d), intent(in) :: gdata - integer, intent(out) :: pdata(:) - - ! Local variables - integer :: iproc, idest, isrc - integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset - - integer, allocatable :: gbuff(:) - type(pointer_int32_1d), allocatable :: pbuff(:) - - IF (p_is_io) THEN - - DO iproc = 0, p_np_worker-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (gbuff (this%glist(iproc)%ng)) - - DO ig = 1, this%glist(iproc)%ng - ilon = this%glist(iproc)%ilon(ig) - ilat = this%glist(iproc)%ilat(ig) - xblk = this%grid%xblk (ilon) - yblk = this%grid%yblk (ilat) - xloc = this%grid%xloc (ilon) - yloc = this%grid%yloc (ilat) - - gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) - - ENDDO - -#ifdef USEMPI - idest = p_address_worker(iproc) - CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (gbuff) -#endif - ENDIF - ENDDO - - ENDIF - - IF (p_is_worker) THEN - - allocate (pbuff (0:p_np_io-1)) - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) - -#ifdef USEMPI - isrc = p_address_io(iproc) - CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - pbuff(0)%val = gbuff - deallocate (gbuff) -#endif - ENDIF - ENDDO - - DO iset = 1, this%npset - IF (allocated(this%gweight(iset)%val)) THEN - ig = maxloc(this%gweight(iset)%val, dim=1) - iproc = this%address(iset)%val(1,ig) - iloc = this%address(iset)%val(2,ig) - pdata(iset) = pbuff(iproc)%val(iloc) - ELSE - pdata(iset) = -9999 - ENDIF - ENDDO - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - deallocate (pbuff(iproc)%val) - ENDIF - ENDDO - - deallocate (pbuff) - - ENDIF - - END SUBROUTINE map_g2p_max_frequency_2d - - !----------------------------------------------------- - SUBROUTINE mapping_grid2pset_free_mem (this) - - USE MOD_SPMD_Task - IMPLICIT NONE - - type(mapping_grid2pset_type) :: this - - ! Local variables - integer :: iproc, iset - - IF (allocated (this%grid%xblk)) deallocate (this%grid%xblk) - IF (allocated (this%grid%yblk)) deallocate (this%grid%yblk) - - IF (allocated (this%grid%xloc)) deallocate (this%grid%xloc) - IF (allocated (this%grid%yloc)) deallocate (this%grid%yloc) - - IF (allocated(this%glist)) THEN - DO iproc = lbound(this%glist,1), ubound(this%glist,1) - IF (allocated(this%glist(iproc)%ilat)) deallocate (this%glist(iproc)%ilat) - IF (allocated(this%glist(iproc)%ilon)) deallocate (this%glist(iproc)%ilon) - ENDDO - - deallocate (this%glist) - ENDIF - - IF (allocated(this%address)) THEN - DO iset = 1, this%npset - IF (allocated(this%address(iset)%val)) THEN - deallocate (this%address(iset)%val) - ENDIF - ENDDO - - deallocate (this%address) - ENDIF - - IF (allocated(this%gweight)) THEN - DO iset = 1, this%npset - IF (allocated(this%gweight(iset)%val)) THEN - deallocate (this%gweight(iset)%val) - ENDIF - ENDDO - - deallocate (this%gweight) - ENDIF - - END SUBROUTINE mapping_grid2pset_free_mem - -END MODULE MOD_Mapping_Grid2Pset diff --git a/share/MOD_Mapping_Pset2Grid.F90 b/share/MOD_Mapping_Pset2Grid.F90 deleted file mode 100644 index e973e59b..00000000 --- a/share/MOD_Mapping_Pset2Grid.F90 +++ /dev/null @@ -1,1080 +0,0 @@ -#include - -MODULE MOD_Mapping_Pset2Grid - -!---------------------------------------------------------------------------- -! DESCRIPTION: -! -! Mapping data types and subroutines from vector data defined on pixelsets -! to gridded data. -! -! Notice that: -! 1. A mapping can be built with method mapping%build. -! 2. Overloaded method "map" can map 1D, 2D or 3D vector data to gridded data -! by using area weighted scheme. -! 3. Method "map_split" can split data in a vector according to pixelset type -! and map data to 3D gridded data. -! The dimensions are from [vector] to [type,lon,lat]. -! -! Created by Shupeng Zhang, May 2023 -!---------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Grid - USE MOD_DataType - IMPLICIT NONE - - ! ------ - type :: mapping_pset2grid_type - - type(grid_type) :: grid - integer :: npset - - type(grid_list_type), allocatable :: glist (:) - - type(pointer_int32_2d), allocatable :: address(:) - type(pointer_real8_1d), allocatable :: olparea(:) - - CONTAINS - - procedure, PUBLIC :: build => mapping_pset2grid_build - - procedure, PRIVATE :: map_2d => map_p2g_2d - procedure, PRIVATE :: map_3d => map_p2g_3d - procedure, PRIVATE :: map_4d => map_p2g_4d - generic, PUBLIC :: map => map_2d, map_3d, map_4d - - procedure, PUBLIC :: map_split => map_p2g_split_to_3d - - final :: mapping_pset2grid_free_mem - - END type mapping_pset2grid_type - -!----------------------- -CONTAINS - - !------------------------------------------ - SUBROUTINE mapping_pset2grid_build (this, pixelset, fgrid, pctpset) - - USE MOD_Precision - USE MOD_Namelist - USE MOD_Block - USE MOD_Pixel - USE MOD_Grid - USE MOD_Pixelset - USE MOD_DataType - USE MOD_Mesh - USE MOD_Utils - USE MOD_SPMD_Task - IMPLICIT NONE - - class (mapping_pset2grid_type) :: this - - type(pixelset_type), intent(in) :: pixelset - type(grid_type), intent(in) :: fgrid - real(r8), optional, intent(in) :: pctpset (:) - - ! Local variables - type(pointer_real8_1d), allocatable :: afrac(:) - type(grid_list_type), allocatable :: gfrom(:) - type(pointer_int32_1d), allocatable :: list_lat(:) - integer, allocatable :: ng_lat(:) - integer, allocatable :: ys(:), yn(:), xw(:), xe(:) - integer, allocatable :: xlist(:), ylist(:) - integer, allocatable :: ipt(:) - logical, allocatable :: msk(:) - - integer :: ie, iset - integer :: ng, ig, ng_all, iloc - integer :: npxl, ipxl, ilat, ilon - integer :: iworker, iproc, idest, isrc, nrecv - integer :: rmesg(2), smesg(2) - integer :: iy, ix, xblk, yblk, xloc, yloc - real(r8) :: lat_s, lat_n, lon_w, lon_e, area - logical :: is_new - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_master) THEN - write(*,"('Making mapping from pixel set to grid: ', I7, A, I7, A)") & - fgrid%nlat, ' grids in latitude', fgrid%nlon, ' grids in longitude' - ENDIF - - IF (allocated(this%grid%xblk)) deallocate(this%grid%xblk) - IF (allocated(this%grid%yblk)) deallocate(this%grid%yblk) - IF (allocated(this%grid%xloc)) deallocate(this%grid%xloc) - IF (allocated(this%grid%yloc)) deallocate(this%grid%yloc) - allocate (this%grid%xblk (size(fgrid%xblk))) - allocate (this%grid%yblk (size(fgrid%yblk))) - allocate (this%grid%xloc (size(fgrid%xloc))) - allocate (this%grid%yloc (size(fgrid%yloc))) - - this%grid%xblk = fgrid%xblk - this%grid%yblk = fgrid%yblk - this%grid%xloc = fgrid%xloc - this%grid%yloc = fgrid%yloc - - this%npset = pixelset%nset - - IF (p_is_worker) THEN - - allocate (afrac (pixelset%nset)) - allocate (gfrom (pixelset%nset)) - - allocate (ys (pixel%nlat)) - allocate (yn (pixel%nlat)) - allocate (xw (pixel%nlon)) - allocate (xe (pixel%nlon)) - - DO ilat = 1, pixel%nlat - ys(ilat) = find_nearest_south (pixel%lat_s(ilat), fgrid%nlat, fgrid%lat_s) - yn(ilat) = find_nearest_north (pixel%lat_n(ilat), fgrid%nlat, fgrid%lat_n) - ENDDO - - DO ilon = 1, pixel%nlon - xw(ilon) = find_nearest_west (pixel%lon_w(ilon), fgrid%nlon, fgrid%lon_w) - xe(ilon) = find_nearest_east (pixel%lon_e(ilon), fgrid%nlon, fgrid%lon_e) - ENDDO - - allocate (list_lat (fgrid%nlat)) - DO iy = 1, fgrid%nlat - allocate (list_lat(iy)%val (100)) - ENDDO - - allocate (ng_lat (fgrid%nlat)) - ng_lat(:) = 0 - - DO iset = 1, pixelset%nset - - ie = pixelset%ielm(iset) - npxl = pixelset%ipxend(iset) - pixelset%ipxstt(iset) + 1 - - allocate (afrac(iset)%val (npxl)) - allocate (gfrom(iset)%ilat(npxl)) - allocate (gfrom(iset)%ilon(npxl)) - - gfrom(iset)%ng = 0 - DO ipxl = pixelset%ipxstt(iset), pixelset%ipxend(iset) - - ilat = mesh(ie)%ilat(ipxl) - ilon = mesh(ie)%ilon(ipxl) - - DO iy = ys(ilat), yn(ilat), fgrid%yinc - - lat_s = max(fgrid%lat_s(iy), pixel%lat_s(ilat)) - lat_n = min(fgrid%lat_n(iy), pixel%lat_n(ilat)) - - IF ((lat_n-lat_s) < 1.0e-6_r8) THEN - CYCLE - ENDIF - - ix = xw(ilon) - DO WHILE (.true.) - - IF (ix == xw(ilon)) THEN - lon_w = pixel%lon_w(ilon) - ELSE - lon_w = fgrid%lon_w(ix) - ENDIF - - IF (ix == xe(ilon)) THEN - lon_e = pixel%lon_e(ilon) - ELSE - lon_e = fgrid%lon_e(ix) - ENDIF - - IF (lon_e > lon_w) THEN - IF ((lon_e-lon_w) < 1.0e-6_r8) THEN - IF (ix == xe(ilon)) EXIT - ix = mod(ix,fgrid%nlon) + 1 - CYCLE - ENDIF - ELSE - IF ((lon_e+360.0_r8-lon_w) < 1.0e-6_r8) THEN - IF (ix == xe(ilon)) EXIT - ix = mod(ix,fgrid%nlon) + 1 - CYCLE - ENDIF - ENDIF - - area = areaquad (lat_s, lat_n, lon_w, lon_e) - - CALL insert_into_sorted_list2 ( ix, iy, & - gfrom(iset)%ng, gfrom(iset)%ilon, gfrom(iset)%ilat, & - iloc, is_new) - - IF (is_new) THEN - IF (iloc < gfrom(iset)%ng) THEN - afrac(iset)%val(iloc+1:gfrom(iset)%ng) & - = afrac(iset)%val(iloc:gfrom(iset)%ng-1) - ENDIF - - afrac(iset)%val(iloc) = area - ELSE - afrac(iset)%val(iloc) = afrac(iset)%val(iloc) + area - ENDIF - - IF (gfrom(iset)%ng == size(gfrom(iset)%ilat)) THEN - CALL expand_list (gfrom(iset)%ilat, 0.2_r8) - CALL expand_list (gfrom(iset)%ilon, 0.2_r8) - CALL expand_list (afrac(iset)%val, 0.2_r8) - ENDIF - - CALL insert_into_sorted_list1 ( & - ix, ng_lat(iy), list_lat(iy)%val, iloc) - - IF (ng_lat(iy) == size(list_lat(iy)%val)) THEN - CALL expand_list (list_lat(iy)%val, 0.2_r8) - ENDIF - - IF (ix == xe(ilon)) EXIT - ix = mod(ix,fgrid%nlon) + 1 - ENDDO - ENDDO - - ENDDO - ENDDO - - deallocate (ys) - deallocate (yn) - deallocate (xw) - deallocate (xe) - - ng_all = sum(ng_lat) - allocate (xlist(ng_all)) - allocate (ylist(ng_all)) - - ig = 0 - DO iy = 1, fgrid%nlat - IF (ng_lat(iy) > 0) THEN - DO ix = 1, ng_lat(iy) - ig = ig + 1 - xlist(ig) = list_lat(iy)%val(ix) - ylist(ig) = iy - ENDDO - ENDIF - ENDDO - - deallocate (ng_lat) - DO iy = 1, fgrid%nlat - deallocate (list_lat(iy)%val) - ENDDO - deallocate (list_lat) - -#ifdef USEMPI - allocate (ipt (ng_all)) - allocate (msk (ng_all)) - DO ig = 1, ng_all - xblk = fgrid%xblk(xlist(ig)) - yblk = fgrid%yblk(ylist(ig)) - ipt(ig) = gblock%pio(xblk,yblk) - ENDDO -#endif - - IF (allocated(this%glist)) deallocate(this%glist) - allocate (this%glist (0:p_np_io-1)) - DO iproc = 0, p_np_io-1 -#ifdef USEMPI - msk = (ipt == p_address_io(iproc)) - ng = count(msk) -#else - ng = ng_all -#endif - - allocate (this%glist(iproc)%ilat (ng)) - allocate (this%glist(iproc)%ilon (ng)) - - this%glist(iproc)%ng = 0 - ENDDO - - DO ig = 1, ng_all -#ifdef USEMPI - iproc = p_itis_io(ipt(ig)) -#else - iproc = 0 -#endif - - this%glist(iproc)%ng = this%glist(iproc)%ng + 1 - - ng = this%glist(iproc)%ng - this%glist(iproc)%ilon(ng) = xlist(ig) - this%glist(iproc)%ilat(ng) = ylist(ig) - ENDDO - -#ifdef USEMPI - deallocate (ipt) - deallocate (msk) -#endif - - IF (allocated(this%address)) deallocate(this%address) - IF (allocated(this%olparea)) deallocate(this%olparea) - allocate (this%address (pixelset%nset)) - allocate (this%olparea (pixelset%nset)) - - DO iset = 1, pixelset%nset - ng = gfrom(iset)%ng - allocate (this%address(iset)%val (2,ng)) - allocate (this%olparea(iset)%val (ng)) - - this%olparea(iset)%val = afrac(iset)%val(1:ng) - - IF (present(pctpset)) THEN - this%olparea(iset)%val = this%olparea(iset)%val * pctpset(iset) - ENDIF - - DO ig = 1, gfrom(iset)%ng - ilon = gfrom(iset)%ilon(ig) - ilat = gfrom(iset)%ilat(ig) - xblk = fgrid%xblk(ilon) - yblk = fgrid%yblk(ilat) - -#ifdef USEMPI - iproc = p_itis_io(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif - - this%address(iset)%val(1,ig) = iproc - this%address(iset)%val(2,ig) = find_in_sorted_list2 ( & - ilon, ilat, this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) - ENDDO - ENDDO - - deallocate (xlist) - deallocate (ylist) - - DO iset = 1, pixelset%nset - deallocate (afrac(iset)%val ) - deallocate (gfrom(iset)%ilon) - deallocate (gfrom(iset)%ilat) - ENDDO - - deallocate (afrac) - deallocate (gfrom) - -#ifdef USEMPI - DO iproc = 0, p_np_io-1 - idest = p_address_io(iproc) - smesg = (/p_iam_glb, this%glist(iproc)%ng/) - - CALL mpi_send (smesg, 2, MPI_INTEGER, & - idest, mpi_tag_mesg, p_comm_glb, p_err) - - IF (this%glist(iproc)%ng > 0) THEN - CALL mpi_send (this%glist(iproc)%ilon, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (this%glist(iproc)%ilat, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO -#endif - - ENDIF - -#ifdef USEMPI - IF (p_is_io) THEN - - IF (allocated(this%glist)) deallocate(this%glist) - allocate (this%glist (0:p_np_worker-1)) - - DO iworker = 0, p_np_worker-1 - - CALL mpi_recv (rmesg, 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - nrecv = rmesg(2) - iproc = p_itis_worker(isrc) - - this%glist(iproc)%ng = nrecv - - IF (nrecv > 0) THEN - allocate (this%glist(iproc)%ilon (nrecv)) - allocate (this%glist(iproc)%ilat (nrecv)) - - CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDDO - ENDIF -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - END SUBROUTINE mapping_pset2grid_build - - - !----------------------------------------------------- - SUBROUTINE map_p2g_2d (this, pdata, gdata, spv, msk) - - USE MOD_Precision - USE MOD_Grid - USE MOD_DataType - USE MOD_SPMD_Task - IMPLICIT NONE - - class (mapping_pset2grid_type) :: this - - real(r8), intent(in) :: pdata(:) - type(block_data_real8_2d), intent(inout) :: gdata - - real(r8), intent(in), optional :: spv - logical, intent(in), optional :: msk(:) - - ! Local variables - integer :: iproc, idest, isrc - integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset - - real(r8), allocatable :: gbuff(:) - type(pointer_real8_1d), allocatable :: pbuff(:) - - IF (p_is_worker) THEN - - allocate (pbuff (0:p_np_io-1)) - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) - - IF (present(spv)) THEN - pbuff(iproc)%val(:) = spv - ELSE - pbuff(iproc)%val(:) = 0.0 - ENDIF - ENDIF - ENDDO - - DO iset = 1, this%npset - - IF (present(spv)) THEN - IF (pdata(iset) == spv) CYCLE - ENDIF - - IF (present(msk)) THEN - IF (.not. msk(iset)) CYCLE - ENDIF - - DO ig = 1, size(this%olparea(iset)%val) - iproc = this%address(iset)%val(1,ig) - iloc = this%address(iset)%val(2,ig) - - IF (present(spv)) THEN - IF (pbuff(iproc)%val(iloc) /= spv) THEN - pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & - + pdata(iset) * this%olparea(iset)%val(ig) - ELSE - pbuff(iproc)%val(iloc) = & - pdata(iset) * this%olparea(iset)%val(ig) - ENDIF - ELSE - pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & - + pdata(iset) * this%olparea(iset)%val(ig) - ENDIF - ENDDO - ENDDO - -#ifdef USEMPI - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_io(iproc) - CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO -#endif - - ENDIF - - IF (p_is_io) THEN - - IF (present(spv)) THEN - CALL flush_block_data (gdata, spv) - ELSE - CALL flush_block_data (gdata, 0.0_r8) - ENDIF - - DO iproc = 0, p_np_worker-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (gbuff (this%glist(iproc)%ng)) - -#ifdef USEMPI - isrc = p_address_worker(iproc) - CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - gbuff = pbuff(0)%val -#endif - - DO ig = 1, this%glist(iproc)%ng - IF (present(spv)) THEN - IF (gbuff(ig) /= spv) THEN - ilon = this%glist(iproc)%ilon(ig) - ilat = this%glist(iproc)%ilat(ig) - xblk = this%grid%xblk (ilon) - yblk = this%grid%yblk (ilat) - xloc = this%grid%xloc (ilon) - yloc = this%grid%yloc (ilat) - - IF (gdata%blk(xblk,yblk)%val(xloc,yloc) /= spv) THEN - gdata%blk(xblk,yblk)%val(xloc,yloc) = & - gdata%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) - ELSE - gdata%blk(xblk,yblk)%val(xloc,yloc) = gbuff(ig) - ENDIF - ENDIF - ELSE - ilon = this%glist(iproc)%ilon(ig) - ilat = this%glist(iproc)%ilat(ig) - xblk = this%grid%xblk (ilon) - yblk = this%grid%yblk (ilat) - xloc = this%grid%xloc (ilon) - yloc = this%grid%yloc (ilat) - - gdata%blk(xblk,yblk)%val(xloc,yloc) = & - gdata%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) - ENDIF - ENDDO - - deallocate (gbuff) - ENDIF - ENDDO - - ENDIF - - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - deallocate (pbuff(iproc)%val) - ENDIF - ENDDO - deallocate (pbuff) - ENDIF - - - END SUBROUTINE map_p2g_2d - - !----------------------------------------------------- - SUBROUTINE map_p2g_3d (this, pdata, gdata, spv, msk) - - USE MOD_Precision - USE MOD_Grid - USE MOD_DataType - USE MOD_SPMD_Task - IMPLICIT NONE - - class (mapping_pset2grid_type) :: this - - real(r8), intent(in) :: pdata(:,:) - type(block_data_real8_3d), intent(inout) :: gdata - - real(r8), intent(in), optional :: spv - logical, intent(in), optional :: msk(:) - - ! Local variables - integer :: iproc, idest, isrc - integer :: ig, ilon, ilat, iloc, iset - integer :: xblk, yblk, xloc, yloc - integer :: lb1, ub1, i1 - - real(r8), allocatable :: gbuff(:,:) - type(pointer_real8_2d), allocatable :: pbuff(:) - - - IF (p_is_worker) THEN - - allocate (pbuff (0:p_np_io-1)) - - lb1 = lbound(pdata,1) - ub1 = ubound(pdata,1) - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - allocate (pbuff(iproc)%val (lb1:ub1, this%glist(iproc)%ng)) - - IF (present(spv)) THEN - pbuff(iproc)%val(:,:) = spv - ELSE - pbuff(iproc)%val(:,:) = 0.0 - ENDIF - ENDIF - ENDDO - - DO iset = 1, this%npset - IF (present(msk)) THEN - IF (.not. msk(iset)) CYCLE - ENDIF - - DO ig = 1, size(this%olparea(iset)%val) - iproc = this%address(iset)%val(1,ig) - iloc = this%address(iset)%val(2,ig) - - DO i1 = lb1, ub1 - IF (present(spv)) THEN - IF (pdata(i1,iset) /= spv) THEN - IF (pbuff(iproc)%val(i1,iloc) /= spv) THEN - pbuff(iproc)%val(i1,iloc) = pbuff(iproc)%val(i1,iloc) & - + pdata(i1,iset) * this%olparea(iset)%val(ig) - ELSE - pbuff(iproc)%val(i1,iloc) = & - pdata(i1,iset) * this%olparea(iset)%val(ig) - ENDIF - ENDIF - ELSE - pbuff(iproc)%val(i1,iloc) = pbuff(iproc)%val(i1,iloc) & - + pdata(i1,iset) * this%olparea(iset)%val(ig) - ENDIF - ENDDO - ENDDO - ENDDO - -#ifdef USEMPI - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_io(iproc) - CALL mpi_send (pbuff(iproc)%val, & - (ub1-lb1+1) * this%glist(iproc)%ng, MPI_DOUBLE, & - idest, mpi_tag_data, p_comm_glb, p_err) - - ENDIF - ENDDO -#endif - - ENDIF - - IF (p_is_io) THEN - - lb1 = gdata%lb1 - ub1 = gdata%ub1 - - IF (present(spv)) THEN - CALL flush_block_data (gdata, spv) - ELSE - CALL flush_block_data (gdata, 0.0_r8) - ENDIF - - DO iproc = 0, p_np_worker-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (gbuff (lb1:ub1, this%glist(iproc)%ng)) - -#ifdef USEMPI - isrc = p_address_worker(iproc) - CALL mpi_recv (gbuff, & - (ub1-lb1+1) * this%glist(iproc)%ng, MPI_DOUBLE, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - gbuff = pbuff(0)%val -#endif - - DO ig = 1, this%glist(iproc)%ng - ilon = this%glist(iproc)%ilon(ig) - ilat = this%glist(iproc)%ilat(ig) - xblk = this%grid%xblk (ilon) - yblk = this%grid%yblk (ilat) - xloc = this%grid%xloc (ilon) - yloc = this%grid%yloc (ilat) - - DO i1 = lb1, ub1 - IF (present(spv)) THEN - IF (gbuff(i1,ig) /= spv) THEN - IF (gdata%blk(xblk,yblk)%val(i1,xloc,yloc) /= spv) THEN - gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = & - gdata%blk(xblk,yblk)%val(i1,xloc,yloc) + gbuff(i1,ig) - ELSE - gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = gbuff(i1,ig) - ENDIF - ENDIF - ELSE - gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = & - gdata%blk(xblk,yblk)%val(i1,xloc,yloc) + gbuff(i1,ig) - ENDIF - ENDDO - ENDDO - - deallocate (gbuff) - ENDIF - - ENDDO - - ENDIF - - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - deallocate (pbuff(iproc)%val) - ENDIF - ENDDO - deallocate (pbuff) - ENDIF - - END SUBROUTINE map_p2g_3d - - !----------------------------------------------------- - SUBROUTINE map_p2g_4d (this, pdata, gdata, spv, msk) - - USE MOD_Precision - USE MOD_Grid - USE MOD_DataType - USE MOD_SPMD_Task - IMPLICIT NONE - - class (mapping_pset2grid_type) :: this - - real(r8), intent(in) :: pdata(:,:,:) - type(block_data_real8_4d), intent(inout) :: gdata - - real(r8), intent(in), optional :: spv - logical, intent(in), optional :: msk(:) - - ! Local variables - integer :: iproc, idest, isrc - integer :: ig, ilon, ilat, iloc, iset - integer :: xblk, yblk, xloc, yloc - integer :: lb1, ub1, i1, ndim1, lb2, ub2, i2, ndim2 - - real(r8), allocatable :: gbuff(:,:,:) - type(pointer_real8_3d), allocatable :: pbuff(:) - - IF (p_is_worker) THEN - - allocate (pbuff (0:p_np_io-1)) - - lb1 = lbound(pdata,1) - ub1 = ubound(pdata,1) - ndim1 = ub1 - lb1 + 1 - - lb2 = lbound(pdata,2) - ub2 = ubound(pdata,2) - ndim2 = ub2 - lb2 + 1 - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - allocate (pbuff(iproc)%val (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) - - IF (present(spv)) THEN - pbuff(iproc)%val(:,:,:) = spv - ELSE - pbuff(iproc)%val(:,:,:) = 0.0 - ENDIF - ENDIF - ENDDO - - DO iset = 1, this%npset - IF (present(msk)) THEN - IF (.not. msk(iset)) CYCLE - ENDIF - - DO ig = 1, size(this%olparea(iset)%val) - iproc = this%address(iset)%val(1,ig) - iloc = this%address(iset)%val(2,ig) - - DO i1 = lb1, ub1 - DO i2 = lb2, ub2 - IF (present(spv)) THEN - IF (pdata(i1,i2,iset) /= spv) THEN - IF (pbuff(iproc)%val(i1,i2,iloc) /= spv) THEN - pbuff(iproc)%val(i1,i2,iloc) = pbuff(iproc)%val(i1,i2,iloc) & - + pdata(i1,i2,iset) * this%olparea(iset)%val(ig) - ELSE - pbuff(iproc)%val(i1,i2,iloc) = & - pdata(i1,i2,iset) * this%olparea(iset)%val(ig) - ENDIF - ENDIF - ELSE - pbuff(iproc)%val(i1,i2,iloc) = pbuff(iproc)%val(i1,i2,iloc) & - + pdata(i1,i2,iset) * this%olparea(iset)%val(ig) - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - -#ifdef USEMPI - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_io(iproc) - CALL mpi_send (pbuff(iproc)%val, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_DOUBLE, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO -#endif - - ENDIF - - IF (p_is_io) THEN - - lb1 = gdata%lb1 - ub1 = gdata%ub1 - ndim1 = ub1 - lb1 + 1 - - lb2 = gdata%lb2 - ub2 = gdata%ub2 - ndim2 = ub2 - lb2 + 1 - - IF (present(spv)) THEN - CALL flush_block_data (gdata, spv) - ELSE - CALL flush_block_data (gdata, 0.0_r8) - ENDIF - - DO iproc = 0, p_np_worker-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (gbuff (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) - -#ifdef USEMPI - isrc = p_address_worker(iproc) - CALL mpi_recv (gbuff, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_DOUBLE, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - gbuff = pbuff(0)%val -#endif - - DO ig = 1, this%glist(iproc)%ng - ilon = this%glist(iproc)%ilon(ig) - ilat = this%glist(iproc)%ilat(ig) - xblk = this%grid%xblk (ilon) - yblk = this%grid%yblk (ilat) - xloc = this%grid%xloc (ilon) - yloc = this%grid%yloc (ilat) - - DO i1 = lb1, ub1 - DO i2 = lb2, ub2 - IF (present(spv)) THEN - IF (gbuff(i1,i2,ig) /= spv) THEN - IF (gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) /= spv) THEN - gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = & - gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) + gbuff(i1,i2,ig) - ELSE - gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = gbuff(i1,i2,ig) - ENDIF - ENDIF - ELSE - gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = & - gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) + gbuff(i1,i2,ig) - ENDIF - ENDDO - ENDDO - ENDDO - - deallocate (gbuff) - ENDIF - ENDDO - ENDIF - - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - deallocate (pbuff(iproc)%val) - ENDIF - ENDDO - deallocate (pbuff) - ENDIF - - END SUBROUTINE map_p2g_4d - - !----------------------------------------------------- - SUBROUTINE map_p2g_split_to_3d (this, pdata, settyp, typidx, gdata, spv) - - USE MOD_Precision - USE MOD_Grid - USE MOD_DataType - USE MOD_SPMD_Task - IMPLICIT NONE - - class (mapping_pset2grid_type) :: this - - real(r8), intent(in) :: pdata (:) - integer , intent(in) :: settyp(:) - integer , intent(in) :: typidx(:) - type(block_data_real8_3d), intent(inout) :: gdata - - real(r8), intent(in) :: spv - - ! Local variables - integer :: iproc, idest, isrc - integer :: ig, ilon, ilat, iloc, iset, ityp, ntyps - integer :: xblk, yblk, xloc, yloc - - real(r8), allocatable :: gbuff(:) - type(pointer_real8_1d), allocatable :: pbuff (:) - - IF (p_is_worker) THEN - allocate (pbuff (0:p_np_io-1)) - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) - ENDIF - ENDDO - ENDIF - - IF (p_is_io) THEN - CALL flush_block_data (gdata, spv) - ENDIF - - ntyps = size(typidx) - - DO ityp = 1, ntyps - - IF (p_is_worker) THEN - - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - pbuff(iproc)%val(:) = spv - ENDIF - ENDDO - - DO iset = 1, this%npset - IF ((settyp(iset) == typidx(ityp)) .and. (pdata(iset) /= spv)) THEN - DO ig = 1, size(this%olparea(iset)%val) - iproc = this%address(iset)%val(1,ig) - iloc = this%address(iset)%val(2,ig) - - IF (pbuff(iproc)%val(iloc) /= spv) THEN - pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & - + pdata(iset) * this%olparea(iset)%val(ig) - ELSE - pbuff(iproc)%val(iloc) = & - pdata(iset) * this%olparea(iset)%val(ig) - ENDIF - ENDDO - ENDIF - ENDDO - -#ifdef USEMPI - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_io(iproc) - CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO -#endif - - ENDIF - - IF (p_is_io) THEN - - DO iproc = 0, p_np_worker-1 - IF (this%glist(iproc)%ng > 0) THEN - - allocate (gbuff (this%glist(iproc)%ng)) - -#ifdef USEMPI - isrc = p_address_worker(iproc) - CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - gbuff = pbuff(0)%val -#endif - - DO ig = 1, this%glist(iproc)%ng - IF (gbuff(ig) /= spv) THEN - ilon = this%glist(iproc)%ilon(ig) - ilat = this%glist(iproc)%ilat(ig) - xblk = this%grid%xblk (ilon) - yblk = this%grid%yblk (ilat) - xloc = this%grid%xloc (ilon) - yloc = this%grid%yloc (ilat) - - IF (gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) /= spv) THEN - gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) = & - gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) + gbuff(ig) - ELSE - gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) = gbuff(ig) - ENDIF - ENDIF - ENDDO - - deallocate (gbuff) - ENDIF - - ENDDO - - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - ENDDO - - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 - IF (this%glist(iproc)%ng > 0) THEN - deallocate (pbuff(iproc)%val) - ENDIF - ENDDO - deallocate (pbuff) - ENDIF - - END SUBROUTINE map_p2g_split_to_3d - - !----------------------------------------------------- - SUBROUTINE mapping_pset2grid_free_mem (this) - - USE MOD_SPMD_Task - IMPLICIT NONE - - type (mapping_pset2grid_type) :: this - - ! Local variables - integer :: iproc, iset - - IF (allocated (this%grid%xblk)) deallocate (this%grid%xblk) - IF (allocated (this%grid%yblk)) deallocate (this%grid%yblk) - - IF (allocated (this%grid%xloc)) deallocate (this%grid%xloc) - IF (allocated (this%grid%yloc)) deallocate (this%grid%yloc) - - IF (p_is_io) THEN - IF (allocated(this%glist)) THEN - DO iproc = 0, p_np_worker-1 - IF (allocated(this%glist(iproc)%ilat)) deallocate (this%glist(iproc)%ilat) - IF (allocated(this%glist(iproc)%ilon)) deallocate (this%glist(iproc)%ilon) - ENDDO - - deallocate (this%glist) - ENDIF - ENDIF - - IF (p_is_worker) THEN - IF (allocated(this%glist)) THEN - DO iproc = 0, p_np_io-1 - IF (allocated(this%glist(iproc)%ilat)) deallocate (this%glist(iproc)%ilat) - IF (allocated(this%glist(iproc)%ilon)) deallocate (this%glist(iproc)%ilon) - ENDDO - - deallocate (this%glist) - ENDIF - - IF (allocated(this%address)) THEN - DO iset = 1, this%npset - IF (allocated(this%address(iset)%val)) THEN - deallocate (this%address(iset)%val) - ENDIF - ENDDO - - deallocate (this%address) - ENDIF - - IF (allocated(this%olparea)) THEN - DO iset = 1, this%npset - IF (allocated(this%olparea(iset)%val)) THEN - deallocate (this%olparea(iset)%val) - ENDIF - ENDDO - - deallocate (this%olparea) - ENDIF - ENDIF - - END SUBROUTINE mapping_pset2grid_free_mem - -END MODULE MOD_Mapping_Pset2Grid diff --git a/share/MOD_Namelist.F90 b/share/MOD_Namelist.F90 index 23eab94c..b324ed0d 100644 --- a/share/MOD_Namelist.F90 +++ b/share/MOD_Namelist.F90 @@ -376,13 +376,13 @@ MODULE MOD_Namelist type (nl_forcing_type) :: DEF_forcing !CBL height - logical :: DEF_USE_CBL_HEIGHT = .false. + logical :: DEF_USE_CBL_HEIGHT = .false. - character(len=20) :: DEF_Forcing_Interp = 'areaweight' + character(len=20) :: DEF_Forcing_Interp_Method = 'arealweight' - logical :: DEF_USE_Forcing_Downscaling = .false. - character(len=5) :: DEF_DS_precipitation_adjust_scheme = 'II' - character(len=5) :: DEF_DS_longwave_adjust_scheme = 'II' + logical :: DEF_USE_Forcing_Downscaling = .false. + character(len=5) :: DEF_DS_precipitation_adjust_scheme = 'II' + character(len=5) :: DEF_DS_longwave_adjust_scheme = 'II' ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! ----- Part 13: history and restart ----- @@ -892,7 +892,8 @@ SUBROUTINE read_namelist (nlfile) DEF_forcing_namelist, & - DEF_Forcing_Interp, & + DEF_Forcing_Interp_Method, & + DEF_USE_Forcing_Downscaling, & DEF_DS_precipitation_adjust_scheme, & DEF_DS_longwave_adjust_scheme, & @@ -1337,7 +1338,7 @@ SUBROUTINE read_namelist (nlfile) CALL mpi_bcast (DEF_REST_CompressLevel, 1, mpi_integer, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_HIST_CompressLevel, 1, mpi_integer, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_Forcing_Interp, 20, mpi_character, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_Forcing_Interp_Method, 20, mpi_character, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_USE_Forcing_Downscaling, 1, mpi_logical, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_DS_precipitation_adjust_scheme, 5, mpi_character, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_DS_longwave_adjust_scheme, 5, mpi_character, p_root, p_comm_glb, p_err) diff --git a/share/MOD_NetCDFSerial.F90 b/share/MOD_NetCDFSerial.F90 index a87cbd51..71f0aa65 100644 --- a/share/MOD_NetCDFSerial.F90 +++ b/share/MOD_NetCDFSerial.F90 @@ -121,6 +121,8 @@ MODULE MOD_NetCDFSerial PUBLIC :: get_time_now + PUBLIC :: ncio_write_colm_dimension + CONTAINS ! ---- @@ -2273,4 +2275,50 @@ SUBROUTINE ncio_write_serial_real8_4d_time ( & END SUBROUTINE ncio_write_serial_real8_4d_time + !---------------------- + SUBROUTINE ncio_write_colm_dimension (filename) + + USE MOD_Vars_Global, only : nl_soil, maxsnl, nl_lake, nvegwcs + IMPLICIT NONE + + character(len=*), intent(in) :: filename + + ! Local Variables + integer :: soillayers(1:nl_soil) + integer :: soilsnowlayers(-maxsnl+nl_soil) + integer :: lakelayers(1:nl_lake) + integer :: vegnodes(1:nvegwcs) + integer :: i + + + soillayers = (/(i, i = 1,nl_soil)/) + CALL ncio_define_dimension (filename, 'soil', nl_soil) + CALL ncio_write_serial (filename, 'soil', soillayers, 'soil') + CALL ncio_put_attr_str (filename, 'soil', 'long_name', 'soil layers') + + soilsnowlayers = (/(i, i = maxsnl+1,nl_soil)/) + CALL ncio_define_dimension (filename, 'soilsnow', -maxsnl+nl_soil) + CALL ncio_write_serial (filename, 'soilsnow', soilsnowlayers, 'soilsnow') + CALL ncio_put_attr_str (filename, 'soilsnow', 'long_name', 'snow(<= 0) and soil(>0) layers') + + lakelayers = (/(i, i = 1,nl_lake)/) + CALL ncio_define_dimension (filename, 'lake', nl_lake) + CALL ncio_write_serial (filename, 'lake', lakelayers, 'lake') + CALL ncio_put_attr_str (filename, 'lake', 'long_name', 'vertical lake layers') + + vegnodes = (/(i, i = 1,nvegwcs)/) + CALL ncio_define_dimension (filename, 'vegnodes', nvegwcs) + CALL ncio_write_serial (filename, 'vegnodes', vegnodes, 'vegnodes') + CALL ncio_put_attr_str (filename, 'vegnodes', 'long_name', 'vegetation water potential nodes') + + CALL ncio_define_dimension (filename, 'band', 2) + CALL ncio_write_serial (filename, 'band', (/1,2/), 'band') + CALL ncio_put_attr_str (filename, 'band', 'long_name', '1 = visible; 2 = near-infrared') + + CALL ncio_define_dimension (filename, 'rtyp', 2) + CALL ncio_write_serial (filename, 'rtyp', (/1,2/), 'rtyp') + CALL ncio_put_attr_str (filename, 'rtyp', 'long_name', '1 = direct; 2 = diffuse') + + END SUBROUTINE ncio_write_colm_dimension + END MODULE MOD_NetCDFSerial diff --git a/share/MOD_Pixelset.F90 b/share/MOD_Pixelset.F90 index 50df57c5..af03364e 100644 --- a/share/MOD_Pixelset.F90 +++ b/share/MOD_Pixelset.F90 @@ -69,26 +69,30 @@ MODULE MOD_Pixelset integer :: nset - integer*8, allocatable :: eindex(:) + integer*8, allocatable :: eindex(:) ! global index of element to which pixelset belongs - integer, allocatable :: ipxstt(:) - integer, allocatable :: ipxend(:) - integer, allocatable :: settyp(:) + integer, allocatable :: ipxstt(:) ! start local index of pixel in the element + integer, allocatable :: ipxend(:) ! end local index of pixel in the element + integer, allocatable :: settyp(:) ! type of pixelset - integer, allocatable :: ielm(:) + integer, allocatable :: ielm(:) ! local index of element to which pixelset belongs - integer :: nblkgrp - integer, allocatable :: xblkgrp (:) - integer, allocatable :: yblkgrp (:) + integer :: nblkgrp ! number of blocks for this process's working group + integer, allocatable :: xblkgrp (:) ! block index in longitude for this process's group + integer, allocatable :: yblkgrp (:) ! block index in latitude for this process's group - integer :: nblkall - integer, allocatable :: xblkall (:) - integer, allocatable :: yblkall (:) + integer :: nblkall ! only for IO: number of blocks with nonzero pixelsets + integer, allocatable :: xblkall (:) ! only for IO: block index in longitude + integer, allocatable :: yblkall (:) ! only for IO: block index in latitude - type(vec_gather_scatter_type) :: vecgs + type(vec_gather_scatter_type) :: vecgs ! for vector gathering and scattering integer, allocatable :: vlenall(:,:) + logical :: has_shared = .false. + + real(r8), allocatable :: pctshared (:) + CONTAINS procedure, PUBLIC :: set_vecgs => vec_gather_scatter_set procedure, PUBLIC :: get_lonlat_radian => pixelset_get_lonlat_radian @@ -265,6 +269,8 @@ SUBROUTINE pixelset_free_mem (this) IF (allocated(this%vlenall)) deallocate(this%vlenall) + IF (allocated(this%pctshared)) deallocate(this%pctshared) + END SUBROUTINE pixelset_free_mem ! -------------------------------- @@ -289,6 +295,8 @@ SUBROUTINE pixelset_forc_free_mem (this) IF (allocated(this%vlenall)) deallocate(this%vlenall) + IF (allocated(this%pctshared)) deallocate(this%pctshared) + END SUBROUTINE pixelset_forc_free_mem ! -------------------------------- @@ -316,6 +324,10 @@ SUBROUTINE copy_pixelset(pixel_from, pixel_to) pixel_to%vlenall = pixel_from%vlenall + IF (pixel_from%has_shared) THEN + pixel_to%pctshared = pixel_from%pctshared + ENDIF + END SUBROUTINE ! -------------------------------- @@ -492,34 +504,43 @@ SUBROUTINE pixelset_pack (this, mask, nset_packed) logical, intent(in) :: mask(:) integer, intent(out) :: nset_packed - integer*8, allocatable :: eindex1(:) - integer, allocatable :: ipxstt1(:) - integer, allocatable :: ipxend1(:) - integer, allocatable :: settyp1(:) - integer, allocatable :: ielm1 (:) + integer*8, allocatable :: eindex_(:) + integer, allocatable :: ipxstt_(:) + integer, allocatable :: ipxend_(:) + integer, allocatable :: settyp_(:) + integer, allocatable :: ielm_ (:) + + real(r8), allocatable :: pctshared_(:) + integer :: s, e IF (p_is_worker) THEN IF (this%nset > 0) THEN IF (count(mask) < this%nset) THEN - allocate (eindex1(this%nset)) - allocate (ipxstt1(this%nset)) - allocate (ipxend1(this%nset)) - allocate (settyp1(this%nset)) - allocate (ielm1 (this%nset)) + allocate (eindex_(this%nset)) + allocate (ipxstt_(this%nset)) + allocate (ipxend_(this%nset)) + allocate (settyp_(this%nset)) + allocate (ielm_ (this%nset)) - eindex1 = this%eindex - ipxstt1 = this%ipxstt - ipxend1 = this%ipxend - settyp1 = this%settyp - ielm1 = this%ielm + eindex_ = this%eindex + ipxstt_ = this%ipxstt + ipxend_ = this%ipxend + settyp_ = this%settyp + ielm_ = this%ielm deallocate (this%eindex) deallocate (this%ipxstt) deallocate (this%ipxend) deallocate (this%settyp) deallocate (this%ielm ) + + IF (this%has_shared) THEN + allocate (pctshared_(this%nset)) + pctshared_ = this%pctshared + deallocate (this%pctshared) + ENDIF this%nset = count(mask) @@ -531,19 +552,48 @@ SUBROUTINE pixelset_pack (this, mask, nset_packed) allocate (this%settyp(this%nset)) allocate (this%ielm (this%nset)) - this%eindex = pack(eindex1, mask) - this%ipxstt = pack(ipxstt1, mask) - this%ipxend = pack(ipxend1, mask) - this%settyp = pack(settyp1, mask) - this%ielm = pack(ielm1 , mask) + this%eindex = pack(eindex_, mask) + this%ipxstt = pack(ipxstt_, mask) + this%ipxend = pack(ipxend_, mask) + this%settyp = pack(settyp_, mask) + this%ielm = pack(ielm_ , mask) + + IF (this%has_shared) THEN + + this%pctshared = pack(pctshared_, mask) + + s = 1 + DO WHILE (s < this%nset) + e = s + DO WHILE (e < this%nset) + IF ((this%ielm(e+1) == this%ielm(s)) & + .and. (this%ipxstt(e+1) == this%ipxstt(s))) THEN + e = e + 1 + ELSE + EXIT + ENDIF + ENDDO + + IF (e > s) THEN + this%pctshared(s:e) = this%pctshared(s:e)/sum(this%pctshared(s:e)) + ENDIF + + s = e + 1 + ENDDO + + ENDIF ENDIF - deallocate (eindex1) - deallocate (ipxstt1) - deallocate (ipxend1) - deallocate (settyp1) - deallocate (ielm1 ) + deallocate (eindex_) + deallocate (ipxstt_) + deallocate (ipxend_) + deallocate (settyp_) + deallocate (ielm_ ) + + IF (this%has_shared) THEN + deallocate (pctshared_) + ENDIF ENDIF ENDIF @@ -571,7 +621,7 @@ SUBROUTINE vec_gather_scatter_free_mem (this) END SUBROUTINE vec_gather_scatter_free_mem ! -------------------------------- - SUBROUTINE subset_build (this, superset, subset, use_frac, sharedfrac) + SUBROUTINE subset_build (this, superset, subset, use_frac) USE MOD_Mesh USE MOD_Pixel @@ -583,13 +633,16 @@ SUBROUTINE subset_build (this, superset, subset, use_frac, sharedfrac) type (pixelset_type), intent(in) :: superset type (pixelset_type), intent(in) :: subset logical, intent(in) :: use_frac - real(r8), intent(in), optional :: sharedfrac (:) ! Local Variables integer :: isuperset, isubset, ielm, ipxl, istt, iend IF (superset%nset <= 0) RETURN + IF (superset%has_shared) THEN + write(*,*) 'Warning: superset has shared area.' + ENDIF + IF (allocated(this%substt)) deallocate(this%substt) IF (allocated(this%subend)) deallocate(this%subend) @@ -637,8 +690,8 @@ SUBROUTINE subset_build (this, superset, subset, use_frac, sharedfrac) pixel%lon_w(mesh(ielm)%ilon(ipxl)), & pixel%lon_e(mesh(ielm)%ilon(ipxl)) ) ENDDO - IF (present(sharedfrac)) THEN - this%subfrc(isubset) = this%subfrc(isubset) * sharedfrac(isubset) + IF (subset%has_shared) THEN + this%subfrc(isubset) = this%subfrc(isubset) * subset%pctshared(isubset) ENDIF ENDDO diff --git a/share/MOD_SpatialMapping.F90 b/share/MOD_SpatialMapping.F90 new file mode 100644 index 00000000..732c1031 --- /dev/null +++ b/share/MOD_SpatialMapping.F90 @@ -0,0 +1,2558 @@ +#include + +MODULE MOD_SpatialMapping + +!--------------------------------------------------------------------------------! +! DESCRIPTION: ! +! ! +! Spatial Mapping module. ! +! ! +! Created by Shupeng Zhang, May 2024 ! +!--------------------------------------------------------------------------------! + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + ! ------ + type :: spatial_mapping_type + + type(grid_type) :: grid + + type(grid_list_type), allocatable :: glist (:) + + integer :: npset + integer, allocatable :: npart(:) + type(pointer_int32_2d), allocatable :: address (:) + + logical :: has_missing_value = .false. + real(r8) :: missing_value = spval + + type(pointer_real8_1d), allocatable :: areapart(:) ! intersection area + real(r8), allocatable :: areapset(:) + type(block_data_real8_2d) :: areagrid + + CONTAINS + + procedure, PUBLIC :: build_arealweighted => spatial_mapping_build_arealweighted + procedure, PUBLIC :: build_bilinear => spatial_mapping_build_bilinear + + procedure, PUBLIC :: set_missing_value => spatial_mapping_set_missing_value + + ! 1) from pixelset to grid + procedure, PRIVATE :: pset2grid_2d => spatial_mapping_pset2grid_2d + procedure, PRIVATE :: pset2grid_3d => spatial_mapping_pset2grid_3d + procedure, PRIVATE :: pset2grid_4d => spatial_mapping_pset2grid_4d + generic, PUBLIC :: pset2grid => pset2grid_2d, pset2grid_3d, pset2grid_4d + + procedure, PUBLIC :: pset2grid_max => spatial_mapping_pset2grid_max + procedure, PUBLIC :: pset2grid_split => spatial_mapping_pset2grid_split + + procedure, PUBLIC :: get_sumarea => spatial_mapping_get_sumarea + + ! 2) from grid to pixelset + procedure, PRIVATE :: grid2pset_2d => spatial_mapping_grid2pset_2d + procedure, PRIVATE :: grid2pset_3d => spatial_mapping_grid2pset_3d + generic, PUBLIC :: grid2pset => grid2pset_2d, grid2pset_3d + + procedure, PUBLIC :: grid2pset_dominant => spatial_mapping_dominant_2d + + ! 3) between grid and intersections + procedure, PUBLIC :: grid2part => spatial_mapping_grid2part + procedure, PUBLIC :: part2grid => spatial_mapping_part2grid + procedure, PUBLIC :: normalize => spatial_mapping_normalize + + ! 4) intersections to pixelset + procedure, PUBLIC :: part2pset => spatial_mapping_part2pset + + procedure, PUBLIC :: allocate_part => spatial_mapping_allocate_part + + final :: spatial_mapping_free_mem + + END type spatial_mapping_type + +!----------------------- +CONTAINS + + !------------------------------------------ + SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_Block + USE MOD_Pixel + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_Mesh + USE MOD_Utils + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(grid_type), intent(in) :: fgrid + type(pixelset_type), intent(in) :: pixelset + + ! Local variables + type(pointer_real8_1d), allocatable :: afrac(:) + type(grid_list_type), allocatable :: gfrom(:) + type(pointer_int32_1d), allocatable :: list_lat(:) + integer, allocatable :: ng_lat(:) + integer, allocatable :: ys(:), yn(:), xw(:), xe(:) + integer, allocatable :: xlist(:), ylist(:) + integer, allocatable :: ipt(:) + logical, allocatable :: msk(:) + + integer :: ie, iset + integer :: ng, ig, ng_all, iloc + integer :: npxl, ipxl, ilat, ilon + integer :: iworker, iproc, idest, isrc, nrecv + integer :: rmesg(2), smesg(2) + integer :: iy, ix, xblk, yblk, xloc, yloc + real(r8) :: lat_s, lat_n, lon_w, lon_e, area + logical :: skip, is_new + + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + + write(*,"(A, I0, A, I0, A)") & + 'Making areal weighted mapping between pixel set and grid: ', & + fgrid%nlat, ' grids in latitude ', fgrid%nlon, ' grids in longitude.' + + IF (.not. (lon_between_floor(pixel%edgew, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)) & + .and. lon_between_ceil(pixel%edgee, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)))) THEN + write(*,'(A)') 'Warning: Grid does not cover longitude range of modeling region.' + ENDIF + + IF (fgrid%yinc == 1) THEN + IF (.not. ((pixel%edges >= fgrid%lat_s(1)) & + .and. (pixel%edgen <= fgrid%lat_n(fgrid%nlat)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ELSE + IF (.not. ((pixel%edges >= fgrid%lat_s(fgrid%nlat)) & + .and. (pixel%edgen <= fgrid%lat_n(1)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ENDIF + + ENDIF + + allocate (this%grid%xblk (size(fgrid%xblk))); this%grid%xblk = fgrid%xblk + allocate (this%grid%yblk (size(fgrid%yblk))); this%grid%yblk = fgrid%yblk + allocate (this%grid%xloc (size(fgrid%xloc))); this%grid%xloc = fgrid%xloc + allocate (this%grid%yloc (size(fgrid%yloc))); this%grid%yloc = fgrid%yloc + allocate (this%grid%xcnt (size(fgrid%xcnt))); this%grid%xcnt = fgrid%xcnt + allocate (this%grid%ycnt (size(fgrid%ycnt))); this%grid%ycnt = fgrid%ycnt + + IF (p_is_worker) THEN + + this%npset = pixelset%nset + + allocate (afrac (pixelset%nset)) + allocate (gfrom (pixelset%nset)) + + allocate (ys (pixel%nlat)) + allocate (yn (pixel%nlat)) + allocate (xw (pixel%nlon)) + allocate (xe (pixel%nlon)) + + DO ilat = 1, pixel%nlat + ys(ilat) = find_nearest_south (pixel%lat_s(ilat), fgrid%nlat, fgrid%lat_s) + yn(ilat) = find_nearest_north (pixel%lat_n(ilat), fgrid%nlat, fgrid%lat_n) + ENDDO + + DO ilon = 1, pixel%nlon + xw(ilon) = find_nearest_west (pixel%lon_w(ilon), fgrid%nlon, fgrid%lon_w) + xe(ilon) = find_nearest_east (pixel%lon_e(ilon), fgrid%nlon, fgrid%lon_e) + ENDDO + + allocate (list_lat (fgrid%nlat)) + DO iy = 1, fgrid%nlat + allocate (list_lat(iy)%val (100)) + ENDDO + + allocate (ng_lat (fgrid%nlat)); ng_lat(:) = 0 + + DO iset = 1, pixelset%nset + + ie = pixelset%ielm(iset) + npxl = pixelset%ipxend(iset) - pixelset%ipxstt(iset) + 1 + + allocate (afrac(iset)%val (npxl)) + allocate (gfrom(iset)%ilat(npxl)) + allocate (gfrom(iset)%ilon(npxl)) + + gfrom(iset)%ng = 0 + DO ipxl = pixelset%ipxstt(iset), pixelset%ipxend(iset) + + ilat = mesh(ie)%ilat(ipxl) + ilon = mesh(ie)%ilon(ipxl) + + DO iy = ys(ilat), yn(ilat), fgrid%yinc + + lat_s = max(fgrid%lat_s(iy), pixel%lat_s(ilat)) + lat_n = min(fgrid%lat_n(iy), pixel%lat_n(ilat)) + + IF ((lat_n-lat_s) < 1.0e-6_r8) THEN + CYCLE + ENDIF + + ix = xw(ilon) + DO WHILE (.true.) + + IF (ix == xw(ilon)) THEN + lon_w = pixel%lon_w(ilon) + ELSE + lon_w = fgrid%lon_w(ix) + ENDIF + + IF (ix == xe(ilon)) THEN + lon_e = pixel%lon_e(ilon) + ELSE + lon_e = fgrid%lon_e(ix) + ENDIF + + skip = .false. + IF (.not. (lon_between_floor (lon_w, pixel%lon_w(ilon), lon_e) & + .and. lon_between_ceil (lon_e, lon_w, pixel%lon_e(ilon)))) THEN + skip = .true. + ELSE + IF (lon_e > lon_w) THEN + IF ((lon_e-lon_w) < 1.0e-6_r8) THEN + skip = .true. + ENDIF + ELSE + IF ((lon_e+360.0_r8-lon_w) < 1.0e-6_r8) THEN + skip = .true. + ENDIF + ENDIF + ENDIF + + IF (.not. skip) THEN + + area = areaquad (lat_s, lat_n, lon_w, lon_e) + + CALL insert_into_sorted_list2 ( ix, iy, & + gfrom(iset)%ng, gfrom(iset)%ilon, gfrom(iset)%ilat, & + iloc, is_new) + + IF (is_new) THEN + IF (iloc < gfrom(iset)%ng) THEN + afrac(iset)%val(iloc+1:gfrom(iset)%ng) & + = afrac(iset)%val(iloc:gfrom(iset)%ng-1) + ENDIF + + afrac(iset)%val(iloc) = area + ELSE + afrac(iset)%val(iloc) = afrac(iset)%val(iloc) + area + ENDIF + + IF (gfrom(iset)%ng == size(gfrom(iset)%ilat)) THEN + CALL expand_list (gfrom(iset)%ilat, 0.2_r8) + CALL expand_list (gfrom(iset)%ilon, 0.2_r8) + CALL expand_list (afrac(iset)%val, 0.2_r8) + ENDIF + + CALL insert_into_sorted_list1 ( & + ix, ng_lat(iy), list_lat(iy)%val, iloc) + + IF (ng_lat(iy) == size(list_lat(iy)%val)) THEN + CALL expand_list (list_lat(iy)%val, 0.2_r8) + ENDIF + + ENDIF + + IF (ix == xe(ilon)) EXIT + ix = mod(ix,fgrid%nlon) + 1 + ENDDO + ENDDO + + ENDDO + ENDDO + + deallocate (ys) + deallocate (yn) + deallocate (xw) + deallocate (xe) + + ng_all = sum(ng_lat) + allocate (xlist(ng_all)) + allocate (ylist(ng_all)) + + ig = 0 + DO iy = 1, fgrid%nlat + DO ix = 1, ng_lat(iy) + ig = ig + 1 + xlist(ig) = list_lat(iy)%val(ix) + ylist(ig) = iy + ENDDO + ENDDO + + deallocate (ng_lat) + DO iy = 1, fgrid%nlat + deallocate (list_lat(iy)%val) + ENDDO + deallocate (list_lat) + +#ifdef USEMPI + allocate (ipt (ng_all)) + allocate (msk (ng_all)) + DO ig = 1, ng_all + xblk = fgrid%xblk(xlist(ig)) + yblk = fgrid%yblk(ylist(ig)) + ipt(ig) = gblock%pio(xblk,yblk) + ENDDO +#endif + + allocate (this%glist (0:p_np_io-1)) + DO iproc = 0, p_np_io-1 +#ifdef USEMPI + msk = (ipt == p_address_io(iproc)) + ng = count(msk) +#else + ng = ng_all +#endif + + this%glist(iproc)%ng = ng + + IF (ng > 0) THEN + allocate (this%glist(iproc)%ilat (ng)) + allocate (this%glist(iproc)%ilon (ng)) + +#ifdef USEMPI + this%glist(iproc)%ilon = pack(xlist, msk) + this%glist(iproc)%ilat = pack(ylist, msk) +#else + this%glist(iproc)%ilon = xlist + this%glist(iproc)%ilat = ylist +#endif + ENDIF + ENDDO + +#ifdef USEMPI + deallocate (ipt) + deallocate (msk) +#endif + + allocate (this%address (pixelset%nset)) + allocate (this%areapart (pixelset%nset)) + + allocate (this%npart (pixelset%nset)) + + DO iset = 1, pixelset%nset + + ng = gfrom(iset)%ng + + this%npart(iset) = ng + + allocate (this%address(iset)%val (2,ng)) + allocate (this%areapart(iset)%val (ng)) + + this%areapart(iset)%val = afrac(iset)%val(1:ng) + + IF (pixelset%has_shared) THEN + this%areapart(iset)%val = this%areapart(iset)%val * pixelset%pctshared(iset) + ENDIF + + DO ig = 1, gfrom(iset)%ng + ilon = gfrom(iset)%ilon(ig) + ilat = gfrom(iset)%ilat(ig) + xblk = fgrid%xblk(ilon) + yblk = fgrid%yblk(ilat) + +#ifdef USEMPI + iproc = p_itis_io(gblock%pio(xblk,yblk)) +#else + iproc = 0 +#endif + + this%address(iset)%val(1,ig) = iproc + this%address(iset)%val(2,ig) = find_in_sorted_list2 ( & + ilon, ilat, this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + ENDDO + ENDDO + + deallocate (xlist) + deallocate (ylist) + + DO iset = 1, pixelset%nset + deallocate (afrac(iset)%val ) + deallocate (gfrom(iset)%ilon) + deallocate (gfrom(iset)%ilat) + ENDDO + + deallocate (afrac) + deallocate (gfrom) + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iproc = 0, p_np_io-1 + idest = p_address_io(iproc) + smesg = (/p_iam_glb, this%glist(iproc)%ng/) + + CALL mpi_send (smesg, 2, MPI_INTEGER, & + idest, mpi_tag_mesg, p_comm_glb, p_err) + + IF (this%glist(iproc)%ng > 0) THEN + CALL mpi_send (this%glist(iproc)%ilon, this%glist(iproc)%ng, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (this%glist(iproc)%ilat, this%glist(iproc)%ng, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO + + ENDIF + + IF (p_is_io) THEN + + allocate (this%glist (0:p_np_worker-1)) + + DO iworker = 0, p_np_worker-1 + + CALL mpi_recv (rmesg, 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + nrecv = rmesg(2) + iproc = p_itis_worker(isrc) + + this%glist(iproc)%ng = nrecv + + IF (nrecv > 0) THEN + allocate (this%glist(iproc)%ilon (nrecv)) + allocate (this%glist(iproc)%ilat (nrecv)) + + CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + ENDDO + + ENDIF +#endif + + IF (p_is_worker) THEN + IF (this%npset > 0) THEN + allocate (this%areapset (this%npset)) + this%areapset(:) = 0. + ENDIF + DO iset = 1, this%npset + IF (this%npart(iset) > 0) THEN + this%areapset(iset) = sum(this%areapart(iset)%val) + ENDIF + ENDDO + ENDIF + + IF (p_is_io) CALL allocate_block_data (fgrid, this%areagrid) + CALL this%get_sumarea (this%areagrid) + + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE spatial_mapping_build_arealweighted + + !------------------------------------------ + SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_Block + USE MOD_Pixel + USE MOD_Grid + USE MOD_DataType + USE MOD_Mesh + USE MOD_Pixelset + USE MOD_Utils + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: pi + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(grid_type), intent(in) :: fgrid + type(pixelset_type), intent(in) :: pixelset + + ! Local variables + integer, allocatable :: ys(:), yn(:), xw(:), xe(:) + integer, allocatable :: xlist(:), ylist(:), ipt(:) + + real(r8), allocatable :: rlon_pset(:), rlat_pset(:) + real(r8), allocatable :: nwgt(:), swgt(:), wwgt(:), ewgt(:) + + logical, allocatable :: msk(:) + + integer :: iset, ilat, ilon, iwest, ieast, ie, ipxl + integer :: nglist, iloc, ng, ig + integer :: iworker, iproc, iio, idest, isrc, nrecv + integer :: rmesg(2), smesg(2) + integer :: iy, ix, xblk, yblk, xloc, yloc + + real(r8) :: lon, lonw, lone, latn, lats + real(r8) :: distn, dists, distw, diste, diffw, diffe, areathis + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + + write(*,*) + write(*,"(A, I0, A, I0, A)") & + 'Building bilinear interpolation from grid to pixel set: ', & + fgrid%nlat, ' grids in latitude ', fgrid%nlon, ' grids in longitude.' + write(*,*) + + IF (.not. (lon_between_floor(pixel%edgew, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)) & + .and. lon_between_ceil(pixel%edgee, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)))) THEN + write(*,'(A)') 'Warning: Grid does not cover longitude range of modeling region.' + ENDIF + + IF (fgrid%yinc == 1) THEN + IF (.not. ((pixel%edges >= fgrid%lat_s(1)) & + .and. (pixel%edgen <= fgrid%lat_n(fgrid%nlat)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ELSE + IF (.not. ((pixel%edges >= fgrid%lat_s(fgrid%nlat)) & + .and. (pixel%edgen <= fgrid%lat_n(1)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ENDIF + + ENDIF + + this%grid%nlat = fgrid%nlat + this%grid%nlon = fgrid%nlon + + allocate (this%grid%xblk (size(fgrid%xblk))); this%grid%xblk = fgrid%xblk + allocate (this%grid%yblk (size(fgrid%yblk))); this%grid%yblk = fgrid%yblk + allocate (this%grid%xloc (size(fgrid%xloc))); this%grid%xloc = fgrid%xloc + allocate (this%grid%yloc (size(fgrid%yloc))); this%grid%yloc = fgrid%yloc + allocate (this%grid%xcnt (size(fgrid%xcnt))); this%grid%xcnt = fgrid%xcnt + allocate (this%grid%ycnt (size(fgrid%ycnt))); this%grid%ycnt = fgrid%ycnt + + IF (p_is_worker) THEN + + allocate (this%grid%lat_s(this%grid%nlat)); this%grid%lat_s = fgrid%lat_s + allocate (this%grid%lat_n(this%grid%nlat)); this%grid%lat_n = fgrid%lat_n + allocate (this%grid%lon_w(this%grid%nlon)); this%grid%lon_w = fgrid%lon_w + allocate (this%grid%lon_e(this%grid%nlon)); this%grid%lon_e = fgrid%lon_e + allocate (this%grid%rlon (this%grid%nlon)); CALL this%grid%set_rlon () + allocate (this%grid%rlat (this%grid%nlat)); CALL this%grid%set_rlat () + + this%npset = pixelset%nset + + allocate (yn (this%npset)) + allocate (ys (this%npset)) + allocate (xw (this%npset)) + allocate (xe (this%npset)) + allocate (rlon_pset (this%npset)) + allocate (rlat_pset (this%npset)) + + CALL pixelset%get_lonlat_radian (rlon_pset, rlat_pset) + + allocate (xlist(4*this%npset)) + allocate (ylist(4*this%npset)) + + allocate (nwgt (this%npset)) + allocate (swgt (this%npset)) + allocate (wwgt (this%npset)) + allocate (ewgt (this%npset)) + + nglist = 0 + + DO iset = 1, this%npset + + IF (this%grid%rlat(1) > this%grid%rlat(this%grid%nlat)) THEN + ! from north to south + ilat = 1 + DO WHILE ((rlat_pset(iset) < this%grid%rlat(ilat)) .and. (ilat < this%grid%nlat)) + ilat = ilat + 1 + ENDDO + + IF (rlat_pset(iset) >= this%grid%rlat(ilat)) THEN + yn(iset) = max(ilat-1,1) + ys(iset) = ilat + ELSE + yn(iset) = this%grid%nlat + ys(iset) = this%grid%nlat + ENDIF + ELSE + ! from south to north + ilat = this%grid%nlat + DO WHILE ((rlat_pset(iset) < this%grid%rlat(ilat)) .and. (ilat > 1)) + ilat = ilat - 1 + ENDDO + + IF (rlat_pset(iset) >= this%grid%rlat(ilat)) THEN + yn(iset) = min(ilat+1,this%grid%nlat) + ys(iset) = ilat + ELSE + yn(iset) = 1 + ys(iset) = 1 + ENDIF + ENDIF + + IF (yn(iset) /= ys(iset)) THEN + latn = this%grid%rlat(yn(iset)) + lats = this%grid%rlat(ys(iset)) + distn = arclen(rlat_pset(iset), rlon_pset(iset), latn, rlon_pset(iset)) + dists = arclen(rlat_pset(iset), rlon_pset(iset), lats, rlon_pset(iset)) + nwgt(iset) = dists/(dists+distn) + swgt(iset) = distn/(dists+distn) + ELSE + nwgt(iset) = 1.0 + swgt(iset) = 0.0 + ENDIF + + + lon = rlon_pset(iset)*180.0/pi + CALL normalize_longitude (lon) + + DO iwest = 1, this%grid%nlon + lonw = this%grid%rlon(iwest) *180.0/pi + CALL normalize_longitude (lonw) + + ieast = mod(iwest,this%grid%nlon) + 1 + lone = this%grid%rlon(ieast)*180.0/pi + CALL normalize_longitude (lone) + + IF (lon_between_floor(lon, lonw, lone)) EXIT + ENDDO + + xw(iset) = iwest + xe(iset) = ieast + + ! for the case grid does not cover [-180,180) + IF ((iwest == this%grid%nlon) .and. (this%grid%nlon > 1)) THEN + IF (lon_between_floor( & + this%grid%lon_e(this%grid%nlon), lonw, this%grid%lon_w(1))) THEN + + diffw = lon - lonw; IF (diffw < 0) diffw = diffw + 360.0 + diffe = lone - lon; IF (diffe < 0) diffe = diffe + 360.0 + + IF (diffw > diffe) THEN + xw(iset) = ieast + xe(iset) = ieast + ELSE + xw(iset) = iwest + xe(iset) = iwest + ENDIF + + ENDIF + ENDIF + + IF (xw(iset) /= xe(iset)) THEN + lonw = this%grid%rlon(xw(iset)) + lone = this%grid%rlon(xe(iset)) + distw = arclen(rlat_pset(iset), rlon_pset(iset), rlat_pset(iset), lonw) + diste = arclen(rlat_pset(iset), rlon_pset(iset), rlat_pset(iset), lone) + wwgt(iset) = diste/(distw+diste) + ewgt(iset) = distw/(distw+diste) + ELSE + wwgt(iset) = 1.0 + ewgt(iset) = 0.0 + ENDIF + + CALL insert_into_sorted_list2 ( xw(iset), yn(iset), nglist, xlist, ylist, iloc) + CALL insert_into_sorted_list2 ( xe(iset), yn(iset), nglist, xlist, ylist, iloc) + CALL insert_into_sorted_list2 ( xw(iset), ys(iset), nglist, xlist, ylist, iloc) + CALL insert_into_sorted_list2 ( xe(iset), ys(iset), nglist, xlist, ylist, iloc) + + ENDDO + +#ifdef USEMPI + allocate (ipt (nglist)) + allocate (msk (nglist)) + DO ig = 1, nglist + xblk = this%grid%xblk(xlist(ig)) + yblk = this%grid%yblk(ylist(ig)) + ipt(ig) = gblock%pio(xblk,yblk) + ENDDO +#endif + + allocate (this%glist (0:p_np_io-1)) + DO iproc = 0, p_np_io-1 +#ifdef USEMPI + msk = (ipt == p_address_io(iproc)) + ng = count(msk) +#else + ng = nglist +#endif + + this%glist(iproc)%ng = ng + + IF (ng > 0) THEN + allocate (this%glist(iproc)%ilat (ng)) + allocate (this%glist(iproc)%ilon (ng)) + +#ifdef USEMPI + this%glist(iproc)%ilon = pack(xlist(1:nglist), msk) + this%glist(iproc)%ilat = pack(ylist(1:nglist), msk) +#else + this%glist(iproc)%ilon = xlist(1:nglist) + this%glist(iproc)%ilat = ylist(1:nglist) +#endif + ENDIF + + ENDDO + + deallocate (xlist) + deallocate (ylist) + +#ifdef USEMPI + deallocate (ipt) + deallocate (msk) +#endif + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + idest = p_address_io(iproc) + smesg = (/p_iam_glb, this%glist(iproc)%ng/) + + CALL mpi_send (smesg, 2, MPI_INTEGER, & + idest, mpi_tag_mesg, p_comm_glb, p_err) + + IF (this%glist(iproc)%ng > 0) THEN + CALL mpi_send (this%glist(iproc)%ilon, this%glist(iproc)%ng, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (this%glist(iproc)%ilat, this%glist(iproc)%ng, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO + ENDIF + + IF (p_is_io) THEN + + allocate (this%glist (0:p_np_worker-1)) + + DO iworker = 0, p_np_worker-1 + + CALL mpi_recv (rmesg, 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + nrecv = rmesg(2) + iproc = p_itis_worker(isrc) + + this%glist(iproc)%ng = nrecv + + IF (nrecv > 0) THEN + allocate (this%glist(iproc)%ilon (nrecv)) + allocate (this%glist(iproc)%ilat (nrecv)) + + CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + + ENDDO + + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_worker) THEN + + allocate (this%address (this%npset)) + allocate (this%npart (this%npset)) + allocate (this%areapart(this%npset)) + + DO iset = 1, pixelset%nset + + this%npart(iset) = 4 + + allocate (this%address (iset)%val(2,4)) + allocate (this%areapart(iset)%val(4)) + + areathis = 0. + + ie = pixelset%ielm(iset) + DO ipxl = pixelset%ipxstt(iset), pixelset%ipxend(iset) + areathis = areathis + areaquad (& + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDDO + + IF (pixelset%has_shared) THEN + areathis = areathis * pixelset%pctshared(iset) + ENDIF + + ! northwest grid + ix = xw(iset); iy = yn(iset); +#ifdef USEMPI + xblk = this%grid%xblk(ix) + yblk = this%grid%yblk(iy) + iproc = p_itis_io(gblock%pio(xblk,yblk)) +#else + iproc = 0 +#endif + this%address(iset)%val(1,1) = iproc + this%address(iset)%val(2,1) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(1) = areathis * nwgt(iset) * wwgt(iset) + + ! northeast grid + ix = xe(iset); iy = yn(iset); +#ifdef USEMPI + xblk = this%grid%xblk(ix) + yblk = this%grid%yblk(iy) + iproc = p_itis_io(gblock%pio(xblk,yblk)) +#else + iproc = 0 +#endif + this%address(iset)%val(1,2) = iproc + this%address(iset)%val(2,2) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(2) = areathis * nwgt(iset) * ewgt(iset) + + ! southwest + ix = xw(iset); iy = ys(iset); +#ifdef USEMPI + xblk = this%grid%xblk(ix) + yblk = this%grid%yblk(iy) + iproc = p_itis_io(gblock%pio(xblk,yblk)) +#else + iproc = 0 +#endif + this%address(iset)%val(1,3) = iproc + this%address(iset)%val(2,3) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(3) = areathis * swgt(iset) * wwgt(iset) + + ! southeast + ix = xe(iset); iy = ys(iset); +#ifdef USEMPI + xblk = this%grid%xblk(ix) + yblk = this%grid%yblk(iy) + iproc = p_itis_io(gblock%pio(xblk,yblk)) +#else + iproc = 0 +#endif + this%address(iset)%val(1,4) = iproc + this%address(iset)%val(2,4) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(4) = areathis * swgt(iset) * ewgt(iset) + + ENDDO + + ENDIF + + IF (p_is_worker) THEN + IF (this%npset > 0) THEN + allocate (this%areapset (this%npset)) + ENDIF + DO iset = 1, this%npset + this%areapset(iset) = sum(this%areapart(iset)%val) + ENDDO + ENDIF + + IF (p_is_io) CALL allocate_block_data (fgrid, this%areagrid) + CALL this%get_sumarea (this%areagrid) + + + IF (allocated(this%grid%lat_s)) deallocate(this%grid%lat_s) + IF (allocated(this%grid%lat_n)) deallocate(this%grid%lat_n) + IF (allocated(this%grid%lon_w)) deallocate(this%grid%lon_w) + IF (allocated(this%grid%lon_e)) deallocate(this%grid%lon_e) + IF (allocated(this%grid%rlon )) deallocate(this%grid%rlon ) + IF (allocated(this%grid%rlat )) deallocate(this%grid%rlat ) + + IF (allocated(yn)) deallocate(yn) + IF (allocated(ys)) deallocate(ys) + IF (allocated(xw)) deallocate(xw) + IF (allocated(xe)) deallocate(xe) + + IF (allocated(rlon_pset)) deallocate(rlon_pset) + IF (allocated(rlat_pset)) deallocate(rlat_pset) + + IF (allocated(nwgt)) deallocate(nwgt) + IF (allocated(swgt)) deallocate(swgt) + IF (allocated(wwgt)) deallocate(wwgt) + IF (allocated(ewgt)) deallocate(ewgt) + + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE spatial_mapping_build_bilinear + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) + + USE MOD_Precision + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + real(r8), intent(in) :: missing_value + + logical, intent(inout), optional :: pmask(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart, iblkme + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + this%has_missing_value = .true. + this%missing_value = missing_value + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + WHERE (gdata%blk(xblk,yblk)%val == missing_value) + this%areagrid%blk(xblk,yblk)%val = 0. + ENDWHERE + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + + DO iset = 1, this%npset + + this%areapset(iset) = 0. + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (pbuff(iproc)%val(iloc) == missing_value) THEN + this%areapart(iset)%val(ipart) = 0. + ELSE + this%areapset(iset) = this%areapset(iset) + this%areapart(iset)%val(ipart) + ENDIF + ENDDO + + IF (present(pmask)) THEN + pmask(iset) = (this%areapset(iset) > 0.) + ENDIF + + ENDDO + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_set_missing_value + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:) + type(block_data_real8_2d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + + IF (present(spv)) THEN + pbuff(iproc)%val(:) = spv + ELSE + pbuff(iproc)%val(:) = 0.0 + ENDIF + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (present(spv)) THEN + IF (pdata(iset) == spv) CYCLE + ENDIF + + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (present(spv)) THEN + IF (pbuff(iproc)%val(iloc) /= spv) THEN + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + pdata(iset) * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(iloc) = & + pdata(iset) * this%areapart(iset)%val(ipart) + ENDIF + ELSE + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + pdata(iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + IF (present(spv)) THEN + CALL flush_block_data (gdata, spv) + ELSE + CALL flush_block_data (gdata, 0.0_r8) + ENDIF + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + IF (present(spv)) THEN + IF (gbuff(ig) /= spv) THEN + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + IF (gdata%blk(xblk,yblk)%val(xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + gdata%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ELSE + gdata%blk(xblk,yblk)%val(xloc,yloc) = gbuff(ig) + ENDIF + ENDIF + ELSE + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + gdata%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ENDIF + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + + END SUBROUTINE spatial_mapping_pset2grid_2d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:,:) + type(block_data_real8_3d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, iloc, iset, ipart + integer :: xblk, yblk, xloc, yloc + integer :: lb1, ub1, i1 + + real(r8), allocatable :: gbuff(:,:) + type(pointer_real8_2d), allocatable :: pbuff(:) + + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + lb1 = lbound(pdata,1) + ub1 = ubound(pdata,1) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (lb1:ub1, this%glist(iproc)%ng)) + + IF (present(spv)) THEN + pbuff(iproc)%val(:,:) = spv + ELSE + pbuff(iproc)%val(:,:) = 0.0 + ENDIF + ENDIF + ENDDO + + DO iset = 1, this%npset + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + DO i1 = lb1, ub1 + IF (present(spv)) THEN + IF (pdata(i1,iset) /= spv) THEN + IF (pbuff(iproc)%val(i1,iloc) /= spv) THEN + pbuff(iproc)%val(i1,iloc) = pbuff(iproc)%val(i1,iloc) & + + pdata(i1,iset) * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(i1,iloc) = & + pdata(i1,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDIF + ELSE + pbuff(iproc)%val(i1,iloc) = pbuff(iproc)%val(i1,iloc) & + + pdata(i1,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, & + (ub1-lb1+1) * this%glist(iproc)%ng, MPI_DOUBLE, & + idest, mpi_tag_data, p_comm_glb, p_err) + + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + lb1 = gdata%lb1 + ub1 = gdata%ub1 + + IF (present(spv)) THEN + CALL flush_block_data (gdata, spv) + ELSE + CALL flush_block_data (gdata, 0.0_r8) + ENDIF + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (lb1:ub1, this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, & + (ub1-lb1+1) * this%glist(iproc)%ng, MPI_DOUBLE, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + DO i1 = lb1, ub1 + IF (present(spv)) THEN + IF (gbuff(i1,ig) /= spv) THEN + IF (gdata%blk(xblk,yblk)%val(i1,xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) + gbuff(i1,ig) + ELSE + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = gbuff(i1,ig) + ENDIF + ENDIF + ELSE + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) + gbuff(i1,ig) + ENDIF + ENDDO + ENDDO + + deallocate (gbuff) + ENDIF + + ENDDO + + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_3d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:,:,:) + type(block_data_real8_4d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, iloc, iset, ipart + integer :: xblk, yblk, xloc, yloc + integer :: lb1, ub1, i1, ndim1, lb2, ub2, i2, ndim2 + + real(r8), allocatable :: gbuff(:,:,:) + type(pointer_real8_3d), allocatable :: pbuff(:) + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + lb1 = lbound(pdata,1) + ub1 = ubound(pdata,1) + ndim1 = ub1 - lb1 + 1 + + lb2 = lbound(pdata,2) + ub2 = ubound(pdata,2) + ndim2 = ub2 - lb2 + 1 + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) + + IF (present(spv)) THEN + pbuff(iproc)%val(:,:,:) = spv + ELSE + pbuff(iproc)%val(:,:,:) = 0.0 + ENDIF + ENDIF + ENDDO + + DO iset = 1, this%npset + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + DO i1 = lb1, ub1 + DO i2 = lb2, ub2 + IF (present(spv)) THEN + IF (pdata(i1,i2,iset) /= spv) THEN + IF (pbuff(iproc)%val(i1,i2,iloc) /= spv) THEN + pbuff(iproc)%val(i1,i2,iloc) = pbuff(iproc)%val(i1,i2,iloc) & + + pdata(i1,i2,iset) * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(i1,i2,iloc) = & + pdata(i1,i2,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDIF + ELSE + pbuff(iproc)%val(i1,i2,iloc) = pbuff(iproc)%val(i1,i2,iloc) & + + pdata(i1,i2,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_DOUBLE, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + lb1 = gdata%lb1 + ub1 = gdata%ub1 + ndim1 = ub1 - lb1 + 1 + + lb2 = gdata%lb2 + ub2 = gdata%ub2 + ndim2 = ub2 - lb2 + 1 + + IF (present(spv)) THEN + CALL flush_block_data (gdata, spv) + ELSE + CALL flush_block_data (gdata, 0.0_r8) + ENDIF + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_DOUBLE, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + DO i1 = lb1, ub1 + DO i2 = lb2, ub2 + IF (present(spv)) THEN + IF (gbuff(i1,i2,ig) /= spv) THEN + IF (gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) + gbuff(i1,i2,ig) + ELSE + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = gbuff(i1,i2,ig) + ENDIF + ENDIF + ELSE + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) + gbuff(i1,i2,ig) + ENDIF + ENDDO + ENDDO + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_4d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_max (this, pdata, gdata, spv, msk) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:) + type(block_data_real8_2d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + pbuff(iproc)%val(:) = spval + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (present(spv)) THEN + IF (pdata(iset) == spv) CYCLE + ENDIF + + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (pbuff(iproc)%val(iloc) /= spval) THEN + pbuff(iproc)%val(iloc) = max(pdata(iset), pbuff(iproc)%val(iloc)) + ELSE + pbuff(iproc)%val(iloc) = pdata(iset) + ENDIF + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + CALL flush_block_data (gdata, spval) + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + IF (gbuff(ig) /= spval) THEN + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + IF (gdata%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + max(gdata%blk(xblk,yblk)%val(xloc,yloc), gbuff(ig)) + ELSE + gdata%blk(xblk,yblk)%val(xloc,yloc) = gbuff(ig) + ENDIF + ENDIF + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_max + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, spv) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata (:) + integer , intent(in) :: settyp(:) + integer , intent(in) :: typidx(:) + type(block_data_real8_3d), intent(inout) :: gdata + + real(r8), intent(in) :: spv + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, iloc, iset, ipart, ityp, ntyps + integer :: xblk, yblk, xloc, yloc + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff (:) + + IF (p_is_worker) THEN + allocate (pbuff (0:p_np_io-1)) + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + ENDIF + ENDDO + ENDIF + + IF (p_is_io) THEN + CALL flush_block_data (gdata, spv) + ENDIF + + ntyps = size(typidx) + + DO ityp = 1, ntyps + + IF (p_is_worker) THEN + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + pbuff(iproc)%val(:) = spv + ENDIF + ENDDO + + DO iset = 1, this%npset + IF ((settyp(iset) == typidx(ityp)) .and. (pdata(iset) /= spv)) THEN + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (pbuff(iproc)%val(iloc) /= spv) THEN + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + pdata(iset) * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(iloc) = & + pdata(iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDIF + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + IF (gbuff(ig) /= spv) THEN + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + IF (gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) + gbuff(ig) + ELSE + gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) = gbuff(ig) + ENDIF + ENDIF + ENDDO + + deallocate (gbuff) + ENDIF + + ENDDO + + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + ENDDO + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_split + + ! ------------------------------ + SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(inout) :: sumarea + logical, intent(in), optional :: filter(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + pbuff(iproc)%val(:) = 0.0 + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (present(filter)) THEN + IF (.not. filter(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) + this%areapart(iset)%val(ipart) + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + CALL flush_block_data (sumarea, 0.0_r8) + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + sumarea%blk(xblk,yblk)%val(xloc,yloc) = & + sumarea%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_get_sumarea + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_grid2pset_2d (this, gdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + real(r8), intent(out) :: pdata(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (this%areapset(iset) > 0.) THEN + + pdata(iset) = 0. + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + pdata(iset) = pdata(iset) & + + pbuff(iproc)%val(iloc) * this%areapart(iset)%val(ipart) + ENDDO + + pdata(iset) = pdata(iset) / this%areapset(iset) + + ELSE + pdata(iset) = spval + ENDIF + + ENDDO + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_grid2pset_2d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_grid2pset_3d (this, gdata, ndim1, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_3d), intent(in) :: gdata + integer, intent(in) :: ndim1 + real(r8), intent(out) :: pdata(:,:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart, i + + real(r8), allocatable :: gbuff(:,:) + type(pointer_real8_2d), allocatable :: pbuff(:) + + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (ndim1, this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(:,ig) = gdata%blk(xblk,yblk)%val(:,xloc,yloc) + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, ndim1 * this%glist(iproc)%ng, MPI_DOUBLE, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (ndim1, this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, ndim1 * this%glist(iproc)%ng, MPI_DOUBLE, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + + DO iset = 1, this%npset + + IF (this%areapset(iset) > 0.) THEN + + pdata(:,iset) = 0. + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + pdata(:,iset) = pdata(:,iset) & + + pbuff(iproc)%val(:,iloc) * this%areapart(iset)%val(ipart) + ENDDO + + pdata(:,iset) = pdata(:,iset) / this%areapset(iset) + + ELSE + pdata(:,iset) = spval + ENDIF + + ENDDO + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_grid2pset_3d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_dominant_2d (this, gdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_int32_2d), intent(in) :: gdata + integer, intent(out) :: pdata(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + integer, allocatable :: gbuff(:) + type(pointer_int32_1d), allocatable :: pbuff(:) + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + DO iset = 1, this%npset + IF (this%areapset(iset) > 0.) THEN + ipart = maxloc(this%areapart(iset)%val, dim=1) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + pdata(iset) = pbuff(iproc)%val(iloc) + ELSE + pdata(iset) = -9999 + ENDIF + ENDDO + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_dominant_2d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_grid2part (this, gdata, sdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + type(pointer_real8_1d), intent(inout) :: sdata(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + DO iset = 1, this%npset + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + sdata(iset)%val(ipart) = pbuff(iproc)%val(iloc) + ENDDO + ENDDO + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_grid2part + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_part2grid (this, sdata, gdata) + + USE MOD_Precision + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(pointer_real8_1d), intent(in) :: sdata(:) + type(block_data_real8_2d), intent(inout) :: gdata + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + integer :: iblkme + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + pbuff(iproc)%val(:) = 0.0 + ENDIF + ENDDO + + DO iset = 1, this%npset + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + sdata(iset)%val(ipart) * this%areapart(iset)%val(ipart) + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_DOUBLE, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + CALL flush_block_data (gdata, 0.0_r8) + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_DOUBLE, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + gdata%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + WHERE (this%areagrid%blk(xblk,yblk)%val > 0) + gdata%blk(xblk,yblk)%val = & + gdata%blk(xblk,yblk)%val / this%areagrid%blk(xblk,yblk)%val + ELSEWHERE + gdata%blk(xblk,yblk)%val = this%missing_value + ENDWHERE + ENDDO + + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_part2grid + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_normalize (this, gdata, sdata) + + USE MOD_Precision + USE MOD_Block + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + type(pointer_real8_1d), intent(inout) :: sdata(:) + + ! Local variables + integer :: iblkme, xblk, yblk, iset, ipart + + type(block_data_real8_2d) :: sumdata + type(pointer_real8_1d), allocatable :: scaldata(:) + + + IF (p_is_io) CALL allocate_block_data (this%grid, sumdata) + IF (p_is_worker) CALL this%allocate_part (scaldata) + + CALL this%part2grid (sdata, sumdata) + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + WHERE (sumdata%blk(xblk,yblk)%val /= this%missing_value) + sumdata%blk(xblk,yblk)%val = gdata%blk(xblk,yblk)%val / sumdata%blk(xblk,yblk)%val + ENDWHERE + ENDDO + + ENDIF + + CALL this%grid2part (sumdata, scaldata) + + IF (p_is_worker) THEN + + DO iset = 1, this%npset + DO ipart = 1, this%npart(iset) + IF (this%areapart(iset)%val(ipart) > 0.) THEN + sdata(iset)%val(ipart) = sdata(iset)%val(ipart) * scaldata(iset)%val(ipart) + ELSE + sdata(iset)%val(ipart) = this%missing_value + ENDIF + ENDDO + ENDDO + + ENDIF + + IF (p_is_worker) deallocate(scaldata) + + END SUBROUTINE spatial_mapping_normalize + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_part2pset (this, sdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(pointer_real8_1d), intent(in) :: sdata(:) + real(r8), intent(out) :: pdata(:) + + ! Local variables + integer :: iset + + IF (p_is_worker) THEN + + pdata(:) = spval + + DO iset = 1, this%npset + IF (this%areapset(iset) > 0) THEN + pdata(iset) = sum(sdata(iset)%val * this%areapart(iset)%val) / this%areapset(iset) + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE spatial_mapping_part2pset + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_allocate_part (this, datapart) + + USE MOD_SPMD_Task + USE MOD_DataType + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(pointer_real8_1d), allocatable :: datapart (:) + + ! Local variables + integer :: iset + + IF (p_is_worker) THEN + + IF (this%npset > 0) THEN + allocate (datapart (this%npset)) + ENDIF + + DO iset = 1, this%npset + IF (this%npart(iset) > 0) THEN + allocate (datapart(iset)%val (this%npart(iset))) + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE spatial_mapping_allocate_part + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_free_mem (this) + + USE MOD_SPMD_Task + IMPLICIT NONE + + type (spatial_mapping_type) :: this + + ! Local variables + integer :: iproc, iset + + IF (allocated (this%grid%xblk)) deallocate (this%grid%xblk) + IF (allocated (this%grid%yblk)) deallocate (this%grid%yblk) + + IF (allocated (this%grid%xloc)) deallocate (this%grid%xloc) + IF (allocated (this%grid%yloc)) deallocate (this%grid%yloc) + + IF (allocated (this%grid%xcnt)) deallocate (this%grid%xcnt) + IF (allocated (this%grid%ycnt)) deallocate (this%grid%ycnt) + + IF (allocated(this%glist)) THEN + DO iproc = lbound(this%glist,1), ubound(this%glist,1) + IF (allocated(this%glist(iproc)%ilat)) deallocate (this%glist(iproc)%ilat) + IF (allocated(this%glist(iproc)%ilon)) deallocate (this%glist(iproc)%ilon) + ENDDO + + deallocate (this%glist) + ENDIF + + IF (p_is_worker) THEN + + IF (allocated(this%npart)) deallocate(this%npart) + + IF (allocated(this%address)) THEN + DO iset = lbound(this%address,1), ubound(this%address,1) + IF (allocated(this%address(iset)%val)) THEN + deallocate (this%address(iset)%val) + ENDIF + ENDDO + + deallocate (this%address) + ENDIF + + IF (allocated(this%areapart)) THEN + DO iset = lbound(this%areapart,1), ubound(this%areapart,1) + IF (allocated(this%areapart(iset)%val)) THEN + deallocate (this%areapart(iset)%val) + ENDIF + ENDDO + + deallocate (this%areapart) + ENDIF + + IF (allocated(this%areapset)) deallocate(this%areapset) + + ENDIF + + END SUBROUTINE spatial_mapping_free_mem + +END MODULE MOD_SpatialMapping From 606e18dc56f494007f2980c1210618baa8edaab9 Mon Sep 17 00:00:00 2001 From: zhangsp8 <21294631@qq.com> Date: Thu, 23 May 2024 23:05:22 +0800 Subject: [PATCH 2/3] minor modifications. --- main/MOD_Forcing.F90 | 3 - main/MOD_ForcingDownscaling.F90 | 33 +-- main/MOD_HistGridded.F90 | 494 ++++++++++++++++--------------- main/MOD_HistVector.F90 | 214 ++++++------- main/MOD_HistWriteBack.F90 | 13 +- main/MOD_Vars_TimeInvariants.F90 | 1 - share/MOD_Namelist.F90 | 2 +- 7 files changed, 385 insertions(+), 375 deletions(-) diff --git a/main/MOD_Forcing.F90 b/main/MOD_Forcing.F90 index 4e0afc0d..4b8ab955 100644 --- a/main/MOD_Forcing.F90 +++ b/main/MOD_Forcing.F90 @@ -128,9 +128,6 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) real(r8) :: missing_value integer :: ielm, istt, iend - real(r8), allocatable :: vecone(:) - integer :: iblkme, xblk, yblk, xloc, yloc - CALL init_user_specified_forcing ! CO2 data initialization diff --git a/main/MOD_ForcingDownscaling.F90 b/main/MOD_ForcingDownscaling.F90 index 2b9eb300..ce37a511 100644 --- a/main/MOD_ForcingDownscaling.F90 +++ b/main/MOD_ForcingDownscaling.F90 @@ -63,8 +63,6 @@ MODULE MOD_ForcingDownscaling SUBROUTINE downscale_forcings(& num_gridcells,num_columns,begc,endc,glaciers,wt_column,& - mask_g,& - !slp_c, asp_c, cur_c, svf_c, sf_c,& forc_topo_g ,forc_t_g ,forc_th_g ,forc_q_g ,forc_pbot_g ,& @@ -98,8 +96,6 @@ SUBROUTINE downscale_forcings(& logical, intent(in) :: glaciers (1:num_columns) ! true: glacier column (itypwat = 3) real(r8), intent(in) :: wt_column(1:num_columns) ! weight of the column relative to the grid cell - logical, intent(in) :: mask_g(1:num_columns) - ! topography factor !real(r8), intent(in) :: forc_slp_c(1:num_columns) ! slope factor !real(r8), intent(in) :: forc_asp_c(1:num_columns) ! aspect factor @@ -155,8 +151,6 @@ SUBROUTINE downscale_forcings(& ! Initialize column forcing (needs to be done for ALL active columns) DO g = 1, num_gridcells - IF (.not. mask_g(g)) CYCLE - DO c = begc(g), endc(g) forc_t_c (c) = forc_t_g (g) forc_th_c (c) = forc_th_g (g) @@ -167,10 +161,10 @@ SUBROUTINE downscale_forcings(& forc_prl_c (c) = forc_prl_g (g) forc_lwrad_c(c) = forc_lwrad_g(g) END DO - ! END DO + END DO - ! ! Downscale forc_t, forc_th, forc_q, forc_pbot, and forc_rho to columns. - ! DO g = 1, num_gridcells + ! Downscale forc_t, forc_th, forc_q, forc_pbot, and forc_rho to columns. + DO g = 1, num_gridcells hsurf_g = forc_topo_g(g) ! gridcell sfc elevation tbot_g = forc_t_g(g) ! atm sfc temp thbot_g = forc_th_g(g) ! atm sfc pot temp @@ -283,7 +277,7 @@ SUBROUTINE downscale_forcings(& END DO END DO - CALL downscale_longwave(num_gridcells, num_columns, begc, endc, glaciers, wt_column, mask_g,& + CALL downscale_longwave(num_gridcells, num_columns, begc, endc, glaciers, wt_column, & forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, & forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c) @@ -325,7 +319,7 @@ END FUNCTION rhos !----------------------------------------------------------------------------- SUBROUTINE downscale_longwave(& - num_gridcells, num_columns, begc, endc, glaciers, wt_column, mask_g,& + num_gridcells, num_columns, begc, endc, glaciers, wt_column, & forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, & forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c) @@ -345,8 +339,6 @@ SUBROUTINE downscale_longwave(& logical, intent(in) :: glaciers (1:num_columns) ! true: glacier column real(r8), intent(in) :: wt_column (1:num_columns) ! weight of the column relative to the grid cell - logical, intent(in) :: mask_g(1:num_columns) - real(r8), intent(in) :: forc_topo_g (1:num_gridcells) ! atmospheric surface height (m) real(r8), intent(in) :: forc_t_g (1:num_gridcells) ! atmospheric temperature [Kelvin] real(r8), intent(in) :: forc_q_g (1:num_gridcells) ! atmospheric specific humidity [kg/kg] @@ -381,25 +373,22 @@ SUBROUTINE downscale_longwave(& ! Initialize column forcing (needs to be done for ALL active columns) DO g = 1, num_gridcells - - IF (.not. mask_g(g)) CYCLE - DO c = begc(g), endc(g) forc_lwrad_c(c) = forc_lwrad_g(g) END DO - ! END DO + END DO ! Downscale the longwave radiation, conserving energy ! Initialize variables related to normalization - ! DO g = 1, num_gridcells + DO g = 1, num_gridcells sum_lwrad_g(g) = 0._r8 sum_wts_g(g) = 0._r8 newsum_lwrad_g(g) = 0._r8 - ! END DO + END DO ! Do the downscaling - ! DO g = 1, num_gridcells + DO g = 1, num_gridcells DO c = begc(g), endc(g) hsurf_g = forc_topo_g(g) @@ -477,10 +466,10 @@ SUBROUTINE downscale_longwave(& newsum_lwrad_g(g) = newsum_lwrad_g(g) + wt_column(c)*forc_lwrad_c(c) END DO - ! END DO + END DO ! Make sure that, after normalization, the grid cell mean is conserved - ! DO g = 1, num_gridcells + DO g = 1, num_gridcells IF (sum_wts_g(g) > 0._r8) THEN IF (abs((newsum_lwrad_g(g) / sum_wts_g(g)) - forc_lwrad_g(g)) > 1.e-8_r8) THEN write(6,*) 'g, newsum_lwrad_g, sum_wts_g, forc_lwrad_g: ', & diff --git a/main/MOD_HistGridded.F90 b/main/MOD_HistGridded.F90 index 6b40edbd..f82259f6 100644 --- a/main/MOD_HistGridded.F90 +++ b/main/MOD_HistGridded.F90 @@ -41,24 +41,26 @@ MODULE MOD_HistGridded !--------------------------------------- SUBROUTINE hist_gridded_init (dir_hist) - USE MOD_Vars_Global - USE MOD_Namelist - USE MOD_Block - USE MOD_LandPatch + USE MOD_Vars_Global + USE MOD_Namelist + USE MOD_Block + USE MOD_LandPatch #ifdef URBAN_MODEL - USE MOD_LandUrban + USE MOD_LandUrban #endif - USE MOD_Vars_1DAccFluxes - USE MOD_Forcing, only : gforc + USE MOD_Vars_1DAccFluxes + USE MOD_Forcing, only : gforc #ifdef SinglePoint - USE MOD_SingleSrfData + USE MOD_SingleSrfData #endif - USE MOD_Utils - IMPLICIT NONE + USE MOD_Utils + IMPLICIT NONE + + character(len=*), intent(in) :: dir_hist - character(len=*), intent(in) :: dir_hist - type(block_data_real8_2d) :: gridarea - integer :: iblkme, xblk, yblk, xloc, yloc, xglb, yglb + ! Local Variables + type(block_data_real8_2d) :: gridarea + integer :: iblkme, xblk, yblk, xloc, yloc, xglb, yglb IF (DEF_hist_grid_as_forcing) THEN CALL ghist%define_by_copy (gforc) @@ -110,30 +112,30 @@ SUBROUTINE flux_map_and_write_2d ( & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & longname, units) - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_DataType - USE MOD_Block - USE MOD_Grid - USE MOD_Vars_1DAccFluxes, only: nac - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - - ! Local variables - type(block_data_real8_2d) :: flux_xy_2d - integer :: iblkme, xblk, yblk, xloc, yloc - integer :: compress + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Block + USE MOD_Grid + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + + ! Local variables + type(block_data_real8_2d) :: flux_xy_2d + integer :: iblkme, xblk, yblk, xloc, yloc + integer :: compress IF (p_is_worker) WHERE (acc_vec /= spval) acc_vec = acc_vec / nac IF (p_is_io) CALL allocate_block_data (ghist, flux_xy_2d) @@ -175,30 +177,30 @@ SUBROUTINE flux_map_and_write_urb_2d ( & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & longname, units) - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_DataType - USE MOD_Block - USE MOD_Grid - USE MOD_Vars_1DAccFluxes, only: nac - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - - ! Local variables - type(block_data_real8_2d) :: flux_xy_2d - integer :: iblkme, xblk, yblk, xloc, yloc - integer :: compress + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Block + USE MOD_Grid + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + + ! Local variables + type(block_data_real8_2d) :: flux_xy_2d + integer :: iblkme, xblk, yblk, xloc, yloc + integer :: compress IF (p_is_worker) WHERE (acc_vec /= spval) acc_vec = acc_vec / nac IF (p_is_io) CALL allocate_block_data (ghist, flux_xy_2d) @@ -240,32 +242,32 @@ SUBROUTINE flux_map_and_write_3d ( & acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, sumarea, filter, & longname, units) - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_DataType - USE MOD_Block - USE MOD_Grid - USE MOD_Vars_1DAccFluxes, only: nac - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:,:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: dim1name - integer, intent(in) :: lb1, ndim1 - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - character (len=*), intent(in) :: longname - character (len=*), intent(in) :: units - - ! Local variables - type(block_data_real8_3d) :: flux_xy_3d - integer :: iblkme, xblk, yblk, xloc, yloc, i1 - integer :: compress + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Block + USE MOD_Grid + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:,:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: dim1name + integer, intent(in) :: lb1, ndim1 + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + character (len=*), intent(in) :: longname + character (len=*), intent(in) :: units + + ! Local variables + type(block_data_real8_3d) :: flux_xy_3d + integer :: iblkme, xblk, yblk, xloc, yloc, i1 + integer :: compress IF (p_is_worker) THEN WHERE (acc_vec /= spval) acc_vec = acc_vec / nac @@ -314,32 +316,32 @@ SUBROUTINE flux_map_and_write_4d ( & dim1name, lb1, ndim1, dim2name, lb2, ndim2, & sumarea, filter, longname, units) - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_DataType - USE MOD_Block - USE MOD_Grid - USE MOD_Vars_1DAccFluxes, only: nac - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:,:,:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: dim1name, dim2name - integer, intent(in) :: lb1, ndim1, lb2, ndim2 - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - character (len=*), intent(in) :: longname - character (len=*), intent(in) :: units - - ! Local variables - type(block_data_real8_4d) :: flux_xy_4d - integer :: iblkme, xblk, yblk, xloc, yloc, i1, i2 - integer :: compress + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Block + USE MOD_Grid + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:,:,:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: dim1name, dim2name + integer, intent(in) :: lb1, ndim1, lb2, ndim2 + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + character (len=*), intent(in) :: longname + character (len=*), intent(in) :: units + + ! Local variables + type(block_data_real8_4d) :: flux_xy_4d + integer :: iblkme, xblk, yblk, xloc, yloc, i1, i2 + integer :: compress IF (p_is_worker) THEN WHERE(acc_vec /= spval) acc_vec = acc_vec / nac @@ -389,30 +391,30 @@ SUBROUTINE flux_map_and_write_ln ( & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & longname, units) - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_DataType - USE MOD_Block - USE MOD_Grid - USE MOD_Vars_1DAccFluxes, only: nac_ln - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - character (len=*), intent(in), optional :: longname - character (len=*), intent(in), optional :: units - - ! Local variables - type(block_data_real8_2d) :: flux_xy_2d - integer :: i, iblkme, xblk, yblk, xloc, yloc - integer :: compress + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Block + USE MOD_Grid + USE MOD_Vars_1DAccFluxes, only: nac_ln + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + character (len=*), intent(in), optional :: longname + character (len=*), intent(in), optional :: units + + ! Local variables + type(block_data_real8_2d) :: flux_xy_2d + integer :: i, iblkme, xblk, yblk, xloc, yloc + integer :: compress IF (p_is_worker) THEN DO i = lbound(acc_vec,1), ubound(acc_vec,1) @@ -461,28 +463,29 @@ END SUBROUTINE flux_map_and_write_ln SUBROUTINE hist_gridded_write_time ( & filename, dataname, time, itime) - USE MOD_Namelist - USE MOD_Grid - USE MOD_Block - USE MOD_SPMD_Task - IMPLICIT NONE + USE MOD_Namelist + USE MOD_Grid + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: dataname + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname - integer, intent(in) :: time(3) - integer, intent(out) :: itime + integer, intent(in) :: time(3) + integer, intent(out) :: itime - ! Local variables - character(len=256) :: fileblock - integer :: iblkme, iblk, jblk - logical :: fexists + ! Local variables + character(len=256) :: fileblock + integer :: iblkme, iblk, jblk + logical :: fexists IF (trim(DEF_HIST_mode) == 'one') THEN IF (p_is_master) THEN #ifdef USEMPI IF (DEF_HIST_WriteBack) THEN CALL hist_writeback_latlon_time (filename, dataname, time, hist_concat) + itime = 1 ELSE #endif inquire (file=filename, exist=fexists) @@ -520,9 +523,7 @@ SUBROUTINE hist_gridded_write_time ( & ENDIF #ifdef USEMPI - IF (.not. DEF_HIST_WriteBack) THEN - CALL mpi_bcast (itime, 1, MPI_INTEGER, p_root, p_comm_glb, p_err) - ENDIF + CALL mpi_bcast (itime, 1, MPI_INTEGER, p_root, p_comm_glb, p_err) #endif ELSEIF (trim(DEF_HIST_mode) == 'block') THEN @@ -561,31 +562,31 @@ END SUBROUTINE hist_gridded_write_time SUBROUTINE hist_write_var_real8_2d ( & filename, dataname, grid, itime, wdata, compress, longname, units) - USE MOD_Namelist - USE MOD_Block - USE MOD_Grid - USE MOD_DataType - USE MOD_SPMD_Task - USE MOD_Vars_Global, only: spval - IMPLICIT NONE + USE MOD_Namelist + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: dataname - type (grid_type), intent(in) :: grid - integer, intent(in) :: itime + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + integer, intent(in) :: itime - type (block_data_real8_2d), intent(in) :: wdata + type (block_data_real8_2d), intent(in) :: wdata - integer, intent(in) :: compress - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units + integer, intent(in) :: compress + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units - ! Local variables - integer :: iblkme, iblk, jblk, idata, ixseg, iyseg - integer :: xcnt, ycnt, xbdsp, ybdsp, xgdsp, ygdsp - integer :: rmesg(3), smesg(3), isrc - character(len=256) :: fileblock - real(r8), allocatable :: rbuf(:,:), sbuf(:,:), vdata(:,:) + ! Local variables + integer :: iblkme, iblk, jblk, idata, ixseg, iyseg + integer :: xcnt, ycnt, xbdsp, ybdsp, xgdsp, ygdsp + integer :: rmesg(3), smesg(3), isrc + character(len=256) :: fileblock + real(r8), allocatable :: rbuf(:,:), sbuf(:,:), vdata(:,:) IF (trim(DEF_HIST_mode) == 'one') THEN @@ -650,8 +651,15 @@ SUBROUTINE hist_write_var_real8_2d ( & #ifdef USEMPI IF (.not. DEF_HIST_WriteBack) THEN #endif - CALL ncio_write_serial_time (filename, dataname, itime, vdata, & - 'lon', 'lat', 'time', compress) + IF (.not. & + ((trim(dataname) == 'landarea') .or. (trim(dataname) == 'landfraction'))) THEN + + CALL ncio_write_serial_time (filename, dataname, itime, vdata, & + 'lon', 'lat', 'time', compress) + + ELSEIF (itime == 1) THEN + CALL ncio_write_serial (filename, dataname, vdata, 'lon', 'lat', compress) + ENDIF IF (itime == 1) THEN CALL ncio_put_attr (filename, dataname, 'long_name', longname) @@ -716,8 +724,16 @@ SUBROUTINE hist_write_var_real8_2d ( & CALL get_filename_block (filename, iblk, jblk, fileblock) - CALL ncio_write_serial_time (fileblock, dataname, itime, & - wdata%blk(iblk,jblk)%val, 'lon', 'lat', 'time', compress) + IF (.not. & + ((trim(dataname) == 'landarea') .or. (trim(dataname) == 'landfraction'))) THEN + + CALL ncio_write_serial_time (fileblock, dataname, itime, & + wdata%blk(iblk,jblk)%val, 'lon', 'lat', 'time', compress) + + ELSEIF (itime == 1) THEN + CALL ncio_write_serial (fileblock, dataname, & + wdata%blk(iblk,jblk)%val, 'lon', 'lat', compress) + ENDIF ENDDO @@ -730,32 +746,32 @@ END SUBROUTINE hist_write_var_real8_2d SUBROUTINE hist_write_var_real8_3d ( & filename, dataname, dim1name, grid, itime, wdata, compress, longname, units) - USE MOD_Namelist - USE MOD_Block - USE MOD_Grid - USE MOD_DataType - USE MOD_SPMD_Task - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: dataname - character (len=*), intent(in) :: dim1name - type (grid_type), intent(in) :: grid - integer, intent(in) :: itime - - type (block_data_real8_3d), intent(in) :: wdata - - integer, intent(in) :: compress - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - ! Local variables - integer :: iblkme, iblk, jblk, idata, ixseg, iyseg - integer :: xcnt, ycnt, ndim1, xbdsp, ybdsp, xgdsp, ygdsp - integer :: rmesg(4), smesg(4), isrc - character(len=256) :: fileblock - real(r8), allocatable :: rbuf(:,:,:), sbuf(:,:,:), vdata(:,:,:) + USE MOD_Namelist + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + character (len=*), intent(in) :: dim1name + type (grid_type), intent(in) :: grid + integer, intent(in) :: itime + + type (block_data_real8_3d), intent(in) :: wdata + + integer, intent(in) :: compress + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + ! Local variables + integer :: iblkme, iblk, jblk, idata, ixseg, iyseg + integer :: xcnt, ycnt, ndim1, xbdsp, ybdsp, xgdsp, ygdsp + integer :: rmesg(4), smesg(4), isrc + character(len=256) :: fileblock + real(r8), allocatable :: rbuf(:,:,:), sbuf(:,:,:), vdata(:,:,:) IF (trim(DEF_HIST_mode) == 'one') THEN @@ -910,32 +926,32 @@ END SUBROUTINE hist_write_var_real8_3d SUBROUTINE hist_write_var_real8_4d ( & filename, dataname, dim1name, dim2name, grid, itime, wdata, compress, longname, units) - USE MOD_Namelist - USE MOD_Block - USE MOD_Grid - USE MOD_DataType - USE MOD_SPMD_Task - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: dataname - character (len=*), intent(in) :: dim1name, dim2name - type (grid_type), intent(in) :: grid - integer, intent(in) :: itime - - type (block_data_real8_4d), intent(in) :: wdata - - integer, intent(in) :: compress - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - ! Local variables - integer :: iblkme, iblk, jblk, idata, ixseg, iyseg - integer :: xcnt, ycnt, ndim1, ndim2, xbdsp, ybdsp, xgdsp, ygdsp - integer :: rmesg(5), smesg(5), isrc - character(len=256) :: fileblock - real(r8), allocatable :: rbuf(:,:,:,:), sbuf(:,:,:,:), vdata(:,:,:,:) + USE MOD_Namelist + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + character (len=*), intent(in) :: dim1name, dim2name + type (grid_type), intent(in) :: grid + integer, intent(in) :: itime + + type (block_data_real8_4d), intent(in) :: wdata + + integer, intent(in) :: compress + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + ! Local variables + integer :: iblkme, iblk, jblk, idata, ixseg, iyseg + integer :: xcnt, ycnt, ndim1, ndim2, xbdsp, ybdsp, xgdsp, ygdsp + integer :: rmesg(5), smesg(5), isrc + character(len=256) :: fileblock + real(r8), allocatable :: rbuf(:,:,:,:), sbuf(:,:,:,:), vdata(:,:,:,:) IF (trim(DEF_HIST_mode) == 'one') THEN @@ -1093,17 +1109,17 @@ END SUBROUTINE hist_write_var_real8_4d !------------------ SUBROUTINE hist_write_grid_info (fileblock, grid, iblk, jblk) - USE MOD_Block - USE MOD_Grid - IMPLICIT NONE + USE MOD_Block + USE MOD_Grid + IMPLICIT NONE - character(len=*), intent(in) :: fileblock - type (grid_type), intent(in) :: grid - integer, intent(in) :: iblk, jblk + character(len=*), intent(in) :: fileblock + type (grid_type), intent(in) :: grid + integer, intent(in) :: iblk, jblk - ! Local variable - integer :: yl, yu, xl, xu, nx - real(r8), allocatable :: lat_s(:), lat_n(:), lon_w(:), lon_e(:) + ! Local variable + integer :: yl, yu, xl, xu, nx + real(r8), allocatable :: lat_s(:), lat_n(:), lon_w(:), lon_e(:) allocate (lon_w (grid%xcnt(iblk))) allocate (lon_e (grid%xcnt(iblk))) diff --git a/main/MOD_HistVector.F90 b/main/MOD_HistVector.F90 index ddea1761..02ebb8ef 100644 --- a/main/MOD_HistVector.F90 +++ b/main/MOD_HistVector.F90 @@ -1,7 +1,7 @@ #include #if (defined UNSTRUCTURED || defined CATCHMENT) -module MOD_HistVector +MODULE MOD_HistVector !---------------------------------------------------------------------------- ! DESCRIPTION: @@ -13,7 +13,7 @@ module MOD_HistVector ! TODO...(need complement) !---------------------------------------------------------------------------- - use MOD_Precision + USE MOD_Precision USE MOD_SPMD_Task USE MOD_Namelist USE MOD_Vars_Global, only : spval @@ -30,7 +30,7 @@ module MOD_HistVector USE MOD_ElmVector #endif -contains +CONTAINS ! ----- subroutines ------ ! -- write history time -- @@ -46,52 +46,52 @@ SUBROUTINE hist_vector_write_time (filename, dataname, time, itime_in_file) ! Local Variables logical :: fexists - if (p_is_master) then + IF (p_is_master) THEN inquire (file=filename, exist=fexists) - if (.not. fexists) then - call ncio_create_file (trim(filename)) + IF (.not. fexists) THEN + CALL ncio_create_file (trim(filename)) CALL ncio_define_dimension(filename, 'time', 0) #ifdef CATCHMENT - call ncio_define_dimension(filename, 'hydrounit', totalnumhru) + CALL ncio_define_dimension(filename, 'hydrounit', totalnumhru) - call ncio_write_serial (filename, 'bsn_hru', eindx_hru, 'hydrounit') + CALL ncio_write_serial (filename, 'bsn_hru', eindx_hru, 'hydrounit') CALL ncio_put_attr (filename, 'bsn_hru', 'long_name', & 'basin index of hydrological units in mesh') - call ncio_write_serial (filename, 'typ_hru' , htype_hru, 'hydrounit') + CALL ncio_write_serial (filename, 'typ_hru' , htype_hru, 'hydrounit') CALL ncio_put_attr (filename, 'typ_hru' , 'long_name', & 'index of hydrological units inside basin') #else - call ncio_define_dimension(filename, 'element', totalnumelm) - call ncio_write_serial (filename, 'elmindex', eindex_glb, 'element') + CALL ncio_define_dimension(filename, 'element', totalnumelm) + CALL ncio_write_serial (filename, 'elmindex', eindex_glb, 'element') CALL ncio_put_attr (filename, 'elmindex', 'long_name', & 'element index in mesh') #endif CALL ncio_write_colm_dimension (filename) - endif + ENDIF - call ncio_write_time (filename, dataname, time, itime_in_file, DEF_HIST_FREQ) + CALL ncio_write_time (filename, dataname, time, itime_in_file, DEF_HIST_FREQ) ENDIF END SUBROUTINE hist_vector_write_time ! ------- - subroutine aggregate_to_vector_and_write_2d ( & + SUBROUTINE aggregate_to_vector_and_write_2d ( & acc_vec_patch, file_hist, varname, itime_in_file, filter, & longname, units) - use MOD_Precision - use MOD_SPMD_Task - use MOD_Namelist + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist USE MOD_LandPatch - use MOD_Vars_1DAccFluxes, only: nac - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE real(r8), intent(in) :: acc_vec_patch (:) character(len=*), intent(in) :: file_hist @@ -103,17 +103,17 @@ subroutine aggregate_to_vector_and_write_2d ( & character(len=*), intent(in) :: units ! Local variables - INTEGER :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress - LOGICAL, allocatable :: mask(:) - REAL(r8), allocatable :: frac(:) - REAL(r8), allocatable :: acc_vec(:), rcache(:) - REAL(r8) :: sumwt + integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress + logical, allocatable :: mask(:) + real(r8), allocatable :: frac(:) + real(r8), allocatable :: acc_vec(:), rcache(:) + real(r8) :: sumwt #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif - if (p_is_worker) then + IF (p_is_worker) THEN #ifdef CATCHMENT numset = numhru #else @@ -152,13 +152,13 @@ subroutine aggregate_to_vector_and_write_2d ( & deallocate(frac) ENDIF ENDDO - end if + ENDIF #ifdef USEMPI mesg = (/p_iam_glb, numset/) - call mpi_send (mesg, 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numset > 0) THEN - call mpi_send (acc_vec, numset, MPI_REAL8, & + CALL mpi_send (acc_vec, numset, MPI_REAL8, & p_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif @@ -178,14 +178,14 @@ subroutine aggregate_to_vector_and_write_2d ( & #ifdef USEMPI DO iwork = 0, p_np_worker-1 - call mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) isrc = mesg(1) ndata = mesg(2) IF (ndata > 0) THEN allocate(rcache (ndata)) - call mpi_recv (rcache, ndata, MPI_REAL8, isrc, & + CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, & mpi_tag_data, p_comm_glb, p_stat, p_err) #ifdef CATCHMENT @@ -210,14 +210,14 @@ subroutine aggregate_to_vector_and_write_2d ( & compress = DEF_HIST_CompressLevel #ifdef CATCHMENT - call ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & 'hydrounit', 'time', compress) #else - call ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & 'element', 'time', compress) #endif - IF (itime_in_file == 1) then + IF (itime_in_file == 1) THEN CALL ncio_put_attr (file_hist, varname, 'long_name', longname) CALL ncio_put_attr (file_hist, varname, 'units', units) CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) @@ -231,20 +231,20 @@ subroutine aggregate_to_vector_and_write_2d ( & CALL mpi_barrier (p_comm_glb, p_err) #endif - end subroutine aggregate_to_vector_and_write_2d + END SUBROUTINE aggregate_to_vector_and_write_2d ! ------- - subroutine aggregate_to_vector_and_write_3d ( & + SUBROUTINE aggregate_to_vector_and_write_3d ( & acc_vec_patch, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, filter, & longname, units) - use MOD_Precision - use MOD_SPMD_Task - use MOD_Namelist + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist USE MOD_LandPatch - use MOD_Vars_1DAccFluxes, only: nac - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE real(r8), intent(in) :: acc_vec_patch (lb1:,:) character(len=*), intent(in) :: file_hist @@ -259,12 +259,12 @@ subroutine aggregate_to_vector_and_write_3d ( & character(len=*), intent(in) :: units ! Local variables - INTEGER :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress - INTEGER :: ub1, i1 - LOGICAL, allocatable :: mask(:) - REAL(r8), allocatable :: frac(:) - REAL(r8), allocatable :: acc_vec(:,:), rcache(:,:) - REAL(r8) :: sumwt + integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress + integer :: ub1, i1 + logical, allocatable :: mask(:) + real(r8), allocatable :: frac(:) + real(r8), allocatable :: acc_vec(:,:), rcache(:,:) + real(r8) :: sumwt #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) @@ -272,7 +272,7 @@ subroutine aggregate_to_vector_and_write_3d ( & ub1 = lb1 + ndim1 - 1 - if (p_is_worker) then + IF (p_is_worker) THEN #ifdef CATCHMENT numset = numhru #else @@ -314,13 +314,13 @@ subroutine aggregate_to_vector_and_write_3d ( & deallocate(frac) ENDIF ENDDO - end if + ENDIF #ifdef USEMPI mesg = (/p_iam_glb, numset/) - call mpi_send (mesg, 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numset > 0) THEN - call mpi_send (acc_vec, ndim1 * numset, MPI_REAL8, & + CALL mpi_send (acc_vec, ndim1 * numset, MPI_REAL8, & p_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif @@ -340,14 +340,14 @@ subroutine aggregate_to_vector_and_write_3d ( & #ifdef USEMPI DO iwork = 0, p_np_worker-1 - call mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) isrc = mesg(1) ndata = mesg(2) IF (ndata > 0) THEN allocate(rcache (ndim1,ndata)) - call mpi_recv (rcache, ndim1*ndata, MPI_REAL8, isrc, & + CALL mpi_recv (rcache, ndim1*ndata, MPI_REAL8, isrc, & mpi_tag_data, p_comm_glb, p_stat, p_err) DO i1 = 1, ndim1 @@ -375,18 +375,18 @@ subroutine aggregate_to_vector_and_write_3d ( & IF (p_is_master) THEN - call ncio_define_dimension (file_hist, dim1name, ndim1) + CALL ncio_define_dimension (file_hist, dim1name, ndim1) compress = DEF_HIST_CompressLevel #ifdef CATCHMENT - call ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & dim1name, 'hydrounit', 'time', compress) #else - call ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & dim1name, 'element', 'time', compress) #endif - IF (itime_in_file == 1) then + IF (itime_in_file == 1) THEN CALL ncio_put_attr (file_hist, varname, 'long_name', longname) CALL ncio_put_attr (file_hist, varname, 'units', units) CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) @@ -400,21 +400,21 @@ subroutine aggregate_to_vector_and_write_3d ( & CALL mpi_barrier (p_comm_glb, p_err) #endif - end subroutine aggregate_to_vector_and_write_3d + END SUBROUTINE aggregate_to_vector_and_write_3d ! ------- - subroutine aggregate_to_vector_and_write_4d ( & + SUBROUTINE aggregate_to_vector_and_write_4d ( & acc_vec_patch, file_hist, varname, itime_in_file, & dim1name, lb1, ndim1, dim2name, lb2, ndim2, filter, & longname, units) - use MOD_Precision - use MOD_SPMD_Task - use MOD_Namelist + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist USE MOD_LandPatch - use MOD_Vars_1DAccFluxes, only: nac - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE real(r8), intent(in) :: acc_vec_patch (lb1:,lb2:,:) character(len=*), intent(in) :: file_hist @@ -429,12 +429,12 @@ subroutine aggregate_to_vector_and_write_4d ( & character(len=*), intent(in) :: units ! Local variables - INTEGER :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress - INTEGER :: ub1, i1, ub2, i2 - LOGICAL, allocatable :: mask(:) - REAL(r8), allocatable :: frac(:) - REAL(r8), allocatable :: acc_vec(:,:,:), rcache(:,:,:) - REAL(r8) :: sumwt + integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress + integer :: ub1, i1, ub2, i2 + logical, allocatable :: mask(:) + real(r8), allocatable :: frac(:) + real(r8), allocatable :: acc_vec(:,:,:), rcache(:,:,:) + real(r8) :: sumwt #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) @@ -443,7 +443,7 @@ subroutine aggregate_to_vector_and_write_4d ( & ub1 = lb1 + ndim1 - 1 ub2 = lb2 + ndim2 - 1 - if (p_is_worker) then + IF (p_is_worker) THEN #ifdef CATCHMENT numset = numhru #else @@ -487,13 +487,13 @@ subroutine aggregate_to_vector_and_write_4d ( & deallocate(frac) ENDIF ENDDO - end if + ENDIF #ifdef USEMPI mesg = (/p_iam_glb, numset/) - call mpi_send (mesg, 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numset > 0) THEN - call mpi_send (acc_vec, ndim1 * ndim2 * numset, MPI_REAL8, & + CALL mpi_send (acc_vec, ndim1 * ndim2 * numset, MPI_REAL8, & p_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif @@ -513,14 +513,14 @@ subroutine aggregate_to_vector_and_write_4d ( & #ifdef USEMPI DO iwork = 0, p_np_worker-1 - call mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) isrc = mesg(1) ndata = mesg(2) IF (ndata > 0) THEN allocate(rcache (ndim1,ndim2,ndata)) - call mpi_recv (rcache, ndim1 * ndim2 * ndata, MPI_REAL8, isrc, & + CALL mpi_recv (rcache, ndim1 * ndim2 * ndata, MPI_REAL8, isrc, & mpi_tag_data, p_comm_glb, p_stat, p_err) DO i1 = 1, ndim1 @@ -551,19 +551,19 @@ subroutine aggregate_to_vector_and_write_4d ( & IF (p_is_master) THEN - call ncio_define_dimension (file_hist, dim1name, ndim1) - call ncio_define_dimension (file_hist, dim2name, ndim2) + CALL ncio_define_dimension (file_hist, dim1name, ndim1) + CALL ncio_define_dimension (file_hist, dim2name, ndim2) compress = DEF_HIST_CompressLevel #ifdef CATCHMENT - call ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & dim1name, dim2name, 'hydrounit', 'time', compress) #else - call ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & dim1name, dim2name, 'element', 'time', compress) #endif - IF (itime_in_file == 1) then + IF (itime_in_file == 1) THEN CALL ncio_put_attr (file_hist, varname, 'long_name', longname) CALL ncio_put_attr (file_hist, varname, 'units', units) CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) @@ -577,20 +577,20 @@ subroutine aggregate_to_vector_and_write_4d ( & CALL mpi_barrier (p_comm_glb, p_err) #endif - end subroutine aggregate_to_vector_and_write_4d + END SUBROUTINE aggregate_to_vector_and_write_4d ! ------- - subroutine aggregate_to_vector_and_write_ln ( & + SUBROUTINE aggregate_to_vector_and_write_ln ( & acc_vec_patch, file_hist, varname, itime_in_file, filter, & longname, units) - use MOD_Precision - use MOD_SPMD_Task - use MOD_Namelist + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist USE MOD_LandPatch - use MOD_Vars_1DAccFluxes, only: nac_ln - use MOD_Vars_Global, only: spval - implicit none + USE MOD_Vars_1DAccFluxes, only: nac_ln + USE MOD_Vars_Global, only: spval + IMPLICIT NONE real(r8), intent(in) :: acc_vec_patch (:) character(len=*), intent(in) :: file_hist @@ -602,17 +602,17 @@ subroutine aggregate_to_vector_and_write_ln ( & character(len=*), intent(in) :: units ! Local variables - INTEGER :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress - LOGICAL, allocatable :: mask(:) - REAL(r8), allocatable :: frac(:) - REAL(r8), allocatable :: acc_vec(:), rcache(:) - REAL(r8) :: sumwt + integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress + logical, allocatable :: mask(:) + real(r8), allocatable :: frac(:) + real(r8), allocatable :: acc_vec(:), rcache(:) + real(r8) :: sumwt #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif - if (p_is_worker) then + IF (p_is_worker) THEN #ifdef CATCHMENT numset = numhru #else @@ -652,13 +652,13 @@ subroutine aggregate_to_vector_and_write_ln ( & deallocate(frac) ENDIF ENDDO - end if + ENDIF #ifdef USEMPI mesg = (/p_iam_glb, numset/) - call mpi_send (mesg, 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numset > 0) THEN - call mpi_send (acc_vec, numset, MPI_REAL8, & + CALL mpi_send (acc_vec, numset, MPI_REAL8, & p_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif @@ -678,14 +678,14 @@ subroutine aggregate_to_vector_and_write_ln ( & #ifdef USEMPI DO iwork = 0, p_np_worker-1 - call mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) isrc = mesg(1) ndata = mesg(2) IF (ndata > 0) THEN allocate(rcache (ndata)) - call mpi_recv (rcache, ndata, MPI_REAL8, isrc, & + CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, & mpi_tag_data, p_comm_glb, p_stat, p_err) #ifdef CATCHMENT @@ -710,14 +710,14 @@ subroutine aggregate_to_vector_and_write_ln ( & compress = DEF_HIST_CompressLevel #ifdef CATCHMENT - call ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & 'hydrounit', 'time', compress) #else - call ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & 'element', 'time', compress) #endif - IF (itime_in_file == 1) then + IF (itime_in_file == 1) THEN CALL ncio_put_attr (file_hist, varname, 'long_name', longname) CALL ncio_put_attr (file_hist, varname, 'units', units) CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) @@ -731,7 +731,7 @@ subroutine aggregate_to_vector_and_write_ln ( & CALL mpi_barrier (p_comm_glb, p_err) #endif - end subroutine aggregate_to_vector_and_write_ln + END SUBROUTINE aggregate_to_vector_and_write_ln -end module MOD_HistVector +END MODULE MOD_HistVector #endif diff --git a/main/MOD_HistWriteBack.F90 b/main/MOD_HistWriteBack.F90 index ce5e7a39..8d62a54e 100644 --- a/main/MOD_HistWriteBack.F90 +++ b/main/MOD_HistWriteBack.F90 @@ -371,8 +371,17 @@ SUBROUTINE hist_writeback_daemon () deallocate(wdata1d) CASE (2) - CALL ncio_write_serial_time (filename, dataname, itime_in_file, wdata2d, & - dim1name, dim2name, dim3name, compress) + IF (.not. & + ((trim(dataname) == 'landarea') .or. (trim(dataname) == 'landfraction'))) THEN + + CALL ncio_write_serial_time (filename, dataname, itime_in_file, wdata2d, & + dim1name, dim2name, dim3name, compress) + + ELSEIF (itime_in_file == 1) THEN + + CALL ncio_write_serial (filename, dataname, wdata2d, dim1name, dim2name, compress) + + ENDIF deallocate(wdata2d) CASE (3) diff --git a/main/MOD_Vars_TimeInvariants.F90 b/main/MOD_Vars_TimeInvariants.F90 index f2667218..f6f907c7 100644 --- a/main/MOD_Vars_TimeInvariants.F90 +++ b/main/MOD_Vars_TimeInvariants.F90 @@ -143,7 +143,6 @@ END SUBROUTINE deallocate_PFTimeInvariants SUBROUTINE check_PFTimeInvariants () USE MOD_RangeCheck - USE MOD_LandPatch IMPLICIT NONE CALL check_vector_data ('pftfrac', pftfrac) ! diff --git a/share/MOD_Namelist.F90 b/share/MOD_Namelist.F90 index b324ed0d..dc8c8c7b 100644 --- a/share/MOD_Namelist.F90 +++ b/share/MOD_Namelist.F90 @@ -378,7 +378,7 @@ MODULE MOD_Namelist !CBL height logical :: DEF_USE_CBL_HEIGHT = .false. - character(len=20) :: DEF_Forcing_Interp_Method = 'arealweight' + character(len=20) :: DEF_Forcing_Interp_Method = 'arealweight' ! 'arealweight' (default) or 'bilinear' logical :: DEF_USE_Forcing_Downscaling = .false. character(len=5) :: DEF_DS_precipitation_adjust_scheme = 'II' From cf29312f1d4c570e7cba0c43bce8c83d08691732 Mon Sep 17 00:00:00 2001 From: zhangsp8 <21294631@qq.com> Date: Thu, 23 May 2024 23:20:58 +0800 Subject: [PATCH 3/3] gnu libs. --- include/Makeoptions.gnu | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/include/Makeoptions.gnu b/include/Makeoptions.gnu index d9593b75..ea970844 100644 --- a/include/Makeoptions.gnu +++ b/include/Makeoptions.gnu @@ -4,11 +4,11 @@ FF = mpif90 -fopenmp -# NETCDF_LIB = /usr/lib/x86_64-linux-gnu -# NETCDF_INC = /usr/include +NETCDF_LIB = /usr/lib/x86_64-linux-gnu +NETCDF_INC = /usr/include - NETCDF_LIB = /opt/netcdf-c-4.9.2-fortran-4.6.0-gnu/lib - NETCDF_INC = /opt/netcdf-c-4.9.2-fortran-4.6.0-gnu/include +# NETCDF_LIB = /opt/netcdf-c-4.9.2-fortran-4.6.0-gnu/lib +# NETCDF_INC = /opt/netcdf-c-4.9.2-fortran-4.6.0-gnu/include MOD_CMD = -J