Line data Source code
1 : !> \file mo_mpr_restart.f90
2 : !> \brief \copybrief mo_mpr_restart
3 : !> \details \copydetails mo_mpr_restart
4 :
5 : !> \brief reading and writing states, fluxes and configuration for restart of mHM.
6 : !> \details routines are seperated for reading and writing variables for:
7 : !! - states and fluxes, and
8 : !! - configuration.
9 : !!
10 : !! Reading of L11 configuration is also seperated from the rest, since it is only required when routing is activated.
11 : !> \authors Stephan Thober
12 : !> \date Jul 2013
13 : !> \copyright Copyright 2005-\today, the mHM Developers, Luis Samaniego, Sabine Attinger: All rights reserved.
14 : !! mHM is released under the LGPLv3+ license \license_note
15 : !> \ingroup f_mpr
16 : MODULE mo_mpr_restart
17 :
18 : ! This module is a restart for the UFZ CHS mesoscale hydrologic model mHM.
19 :
20 : ! Written Stephan Thober, Apr 2011
21 :
22 : IMPLICIT NONE
23 :
24 : PRIVATE
25 :
26 : PUBLIC :: write_eff_params ! read restart files for configuration from a given path
27 : PUBLIC :: write_mpr_restart_files ! write restart files for configuration to a given path
28 :
29 :
30 : !> \brief unpack parameter fields and write them to file
31 : !> \param[inout] "type(NcDataset) :: nc" NcDataset to add variable to
32 : !> \param[in] "character(*) :: var_name" variable name
33 : !> \param[in] "type(NcDimension), dimension(:) :: var_dims" vector of Variable dimensions
34 : !> \param[in] "integer(i4) :: fill_value" fill value used for missing values
35 : !> \param[in] "integer(i4/dp), dimension(...) :: data" packed data to be set to variable
36 : !> \param[in] "logical, dimension(:, :) :: mask" mask used for unpacking
37 : !> \param[in] "character(*), optional :: var_long_name" variable long name attribute
38 : !> \authors Robert Schweppe
39 : !> \date Jun 2018
40 : INTERFACE unpack_field_and_write
41 : MODULE PROCEDURE unpack_field_and_write_1d_i4, &
42 : unpack_field_and_write_1d_dp, &
43 : unpack_field_and_write_2d_dp, &
44 : unpack_field_and_write_3d_dp
45 : end interface unpack_field_and_write
46 :
47 :
48 : CONTAINS
49 :
50 : !> \brief write restart files for each domain
51 : !> \details write restart files for each domain. For each domain
52 : !! three restart files are written. These are xxx_states.nc,
53 : !! xxx_L11_config.nc, and xxx_config.nc (xxx being the three digit
54 : !! domain index). If a variable is added here, it should also be added
55 : !! in the read restart routines below.
56 : !! ADDITIONAL INFORMATION
57 : !! write_restart
58 : !> \changelog
59 : !! - Stephan Thober Aug 2015
60 : !! - moved write of routing states to mRM
61 : !! - David Schaefer Nov 2015
62 : !! - mo_netcdf
63 : !! - Stephan Thober Nov 2016
64 : !! - moved processMatrix to common variables
65 : !! - Zink M. Demirel C. Mar 2017
66 : !! - Added Jarvis soil water stress function at SM process(3)
67 : !> \authors Stephan Thober
68 : !> \date Jun 2014
69 82 : subroutine write_mpr_restart_files(OutFile)
70 :
71 : use mo_common_restart, only : write_grid_info
72 : use mo_common_variables, only : level1, nLCoverScene, domainMeta, LC_year_start, LC_year_end
73 : use mo_kind, only : i4, dp
74 : use mo_message, only : message
75 : use mo_mpr_global_variables, only : nLAI, nSoilHorizons_mHM, HorizonDepth_mHM
76 : use mo_netcdf, only : NcDataset, NcDimension
77 : use mo_string_utils, only : num2str
78 : use mo_common_constants, only : soilHorizonsVarName, landCoverPeriodsVarName, LAIVarName
79 :
80 : implicit none
81 :
82 : character(256) :: Fname
83 :
84 : !> Output Path for each domain
85 : character(256), dimension(:), intent(in) :: OutFile
86 :
87 : integer(i4) :: iDomain, domainID
88 :
89 : ! start index at level 1
90 : integer(i4) :: s1
91 :
92 : ! end index at level 1
93 : integer(i4) :: e1
94 :
95 : ! mask at level 1
96 0 : logical, dimension(:, :), allocatable :: mask1
97 :
98 : type(NcDataset) :: nc
99 :
100 : type(NcDimension) :: rows1, cols1, soil1, lcscenes, lais
101 :
102 0 : real(dp), dimension(:), allocatable :: dummy_1D
103 :
104 :
105 0 : domain_loop : do iDomain = 1, domainMeta%nDomains
106 0 : domainID = domainMeta%indices(iDomain)
107 :
108 : ! write restart file for iDomain
109 0 : Fname = trim(OutFile(iDomain))
110 : ! print a message
111 0 : call message(" Writing Restart-file: ", trim(adjustl(Fname)), " ...")
112 :
113 0 : nc = NcDataset(fname, "w")
114 :
115 0 : call write_grid_info(level1(iDomain), "1", nc)
116 :
117 0 : rows1 = nc%getDimension("nrows1")
118 0 : cols1 = nc%getDimension("ncols1")
119 :
120 : ! write the dimension to the file and also save bounds
121 0 : allocate(dummy_1D(nSoilHorizons_mHM+1))
122 0 : dummy_1D(1) = 0.0_dp
123 0 : dummy_1D(2:nSoilHorizons_mHM+1) = HorizonDepth_mHM(:)
124 0 : soil1 = nc%setCoordinate(trim(soilHorizonsVarName), nSoilHorizons_mHM, dummy_1D, 2_i4)
125 0 : deallocate(dummy_1D)
126 0 : allocate(dummy_1D(nLCoverScene+1))
127 0 : dummy_1D(1:nLCoverScene) = LC_year_start(:)
128 : ! this is done because bounds are always stored as real so e.g.
129 : ! 1981-1990,1991-2000 is thus saved as 1981.0-1991.0,1991.0-2001.0
130 : ! it is translated back into ints correctly during reading
131 0 : dummy_1D(nLCoverScene+1) = LC_year_end(nLCoverScene) + 1
132 0 : lcscenes = nc%setCoordinate(trim(landCoverPeriodsVarName), nLCoverScene, dummy_1D, 0_i4)
133 0 : deallocate(dummy_1D)
134 : ! write the dimension to the file
135 0 : lais = nc%setDimension(trim(LAIVarName), nLAI)
136 :
137 : ! for appending and intialization
138 0 : allocate(mask1(rows1%getLength(), cols1%getLength()))
139 0 : s1 = level1(iDomain)%iStart
140 0 : e1 = level1(iDomain)%iEnd
141 0 : mask1 = level1(iDomain)%mask
142 :
143 0 : call write_eff_params(mask1, s1, e1, rows1, cols1, soil1, lcscenes, lais, nc)
144 0 : deallocate(mask1)
145 0 : call nc%close()
146 :
147 : end do domain_loop
148 :
149 0 : end subroutine write_mpr_restart_files
150 :
151 :
152 : !> \brief write effective parameter fields to given restart file
153 : !> \changelog
154 : !! - Rohini Kumar Oct 2021
155 : !! - Added Neutron count module to mHM integrate into develop branch (5.11.2)
156 : !! - Sebastian Müller Mar 2023
157 : !! - made L1_alpha, L1_kSlowFlow, L1_kBaseFlow and L1_kPerco land cover dependent
158 : !> \authors Robert Schweppe
159 : !> \date Jun 2018
160 16 : subroutine write_eff_params(mask1, s1, e1, rows1, cols1, soil1, lcscenes, lais, nc)
161 :
162 0 : use mo_common_constants, only : nodata_dp, nodata_i4
163 : use mo_common_variables, only : LC_year_end, LC_year_start, processMatrix
164 : use mo_kind, only : i4
165 : use mo_mpr_global_variables, only : L1_HarSamCoeff, L1_PrieTayAlpha, L1_aeroResist, &
166 : L1_alpha, L1_degDay, L1_degDayInc, L1_degDayMax, L1_degDayNoPre, L1_fAsp, &
167 : L1_fRoots, L1_fSealed, L1_jarvis_thresh_c1, L1_kBaseFlow, L1_kPerco, &
168 : L1_kSlowFlow, L1_karstLoss, L1_kfastFlow, L1_maxInter, L1_petLAIcorFactor, &
169 : L1_sealedThresh, L1_soilMoistExp, L1_soilMoistFC, L1_soilMoistSat, L1_surfResist, &
170 : L1_tempThresh, L1_unsatThresh, L1_wiltingPoint, &
171 : ! neutron count
172 : L1_No_Count, L1_bulkDens, L1_latticeWater, L1_COSMICL3
173 :
174 : use mo_netcdf, only : NcDataset, NcDimension, NcVariable
175 :
176 : implicit none
177 :
178 : logical, dimension(:, :), allocatable, intent(in) :: mask1 !< mask at level 1
179 : integer(i4), intent(in) :: s1 !< start index at level 1
180 : integer(i4), intent(in) :: e1 !< end index at level 1
181 : type(NcDimension), intent(in) :: rows1 !< y dimension
182 : type(NcDimension), intent(in) :: cols1 !< x dimension
183 : type(NcDimension), intent(in) :: soil1 !< soil dimension
184 : type(NcDimension), intent(in) :: lcscenes !< land conver scenes dimension
185 : type(NcDimension), intent(in) :: lais !< LAI dimension
186 : type(NcDataset), intent(inout) :: nc !< NetCDF file to write to
187 :
188 : type(NcVariable) :: var
189 :
190 : !-------------------------------------------
191 : ! EFFECTIVE PARAMETERS
192 : !-------------------------------------------
193 : call unpack_field_and_write(nc, "L1_fSealed", &
194 0 : (/rows1, cols1, lcscenes/), nodata_dp, L1_fSealed(s1 : e1, 1, :), mask1, &
195 64 : "fraction of Sealed area at level 1")
196 :
197 : call unpack_field_and_write(nc, "L1_alpha", &
198 0 : (/rows1, cols1, lcscenes/), nodata_dp, L1_alpha(s1 : e1, 1, :), mask1, &
199 64 : "exponent for the upper reservoir at level 1")
200 :
201 : call unpack_field_and_write(nc, "L1_degDayInc", &
202 0 : (/rows1, cols1, lcscenes/), nodata_dp, L1_degDayInc(s1 : e1, 1, :), mask1, &
203 64 : "increase of the Degree-day factor per mm of increase in precipitation at level 1")
204 :
205 : call unpack_field_and_write(nc, "L1_degDayMax", &
206 0 : (/rows1, cols1, lcscenes/), nodata_dp, L1_degDayMax(s1 : e1, 1, :), mask1, &
207 64 : "maximum degree-day factor at level 1")
208 :
209 : call unpack_field_and_write(nc, "L1_degDayNoPre", &
210 0 : (/rows1, cols1, lcscenes/), nodata_dp, L1_degDayNoPre(s1 : e1, 1, :), mask1, &
211 64 : "degree-day factor with no precipitation at level 1")
212 :
213 : call unpack_field_and_write(nc, "L1_degDay", &
214 0 : (/rows1, cols1, lcscenes/), nodata_dp, L1_degDay(s1 : e1, 1, :), mask1, &
215 64 : "degree-day factor with no precipitation at level 1")
216 :
217 : call unpack_field_and_write(nc, "L1_karstLoss", &
218 0 : (/rows1, cols1/), nodata_dp, L1_karstLoss(s1 : e1, 1, 1), mask1, &
219 48 : "Karstic percolation loss at level 1")
220 :
221 : call unpack_field_and_write(nc, "L1_fRoots", &
222 0 : (/rows1, cols1, soil1, lcscenes/), nodata_dp, L1_fRoots(s1 : e1, :, :), mask1, &
223 80 : "Fraction of roots in soil horizons at level 1")
224 :
225 : call unpack_field_and_write(nc, "L1_maxInter", &
226 0 : (/rows1, cols1, lais/), nodata_dp, L1_maxInter(s1 : e1, :, 1), mask1, &
227 64 : "Maximum interception at level 1")
228 :
229 : call unpack_field_and_write(nc, "L1_kfastFlow", &
230 0 : (/rows1, cols1, lcscenes/), nodata_dp, L1_kfastFlow(s1 : e1, 1, :), mask1, &
231 64 : "fast interflow recession coefficient at level 1")
232 :
233 : call unpack_field_and_write(nc, "L1_kSlowFlow", &
234 0 : (/rows1, cols1, lcscenes/), nodata_dp, L1_kSlowFlow(s1 : e1, 1, :), mask1, &
235 64 : "slow interflow recession coefficient at level 1")
236 :
237 : call unpack_field_and_write(nc, "L1_kBaseFlow", &
238 0 : (/rows1, cols1, lcscenes/), nodata_dp, L1_kBaseFlow(s1 : e1, 1, :), mask1, &
239 64 : "baseflow recession coefficient at level 1")
240 :
241 : call unpack_field_and_write(nc, "L1_kPerco", &
242 0 : (/rows1, cols1, lcscenes/), nodata_dp, L1_kPerco(s1 : e1, 1, :), mask1, &
243 64 : "percolation coefficient at level 1")
244 :
245 : call unpack_field_and_write(nc, "L1_soilMoistFC", &
246 0 : (/rows1, cols1, soil1, lcscenes/), nodata_dp, L1_soilMoistFC(s1 : e1, :, :), mask1, &
247 80 : "SM below which actual ET is reduced linearly till PWP at level 1 for processCase(3)=1")
248 :
249 : call unpack_field_and_write(nc, "L1_soilMoistSat", &
250 0 : (/rows1, cols1, soil1, lcscenes/), nodata_dp, L1_soilMoistSat(s1 : e1, :, :), mask1, &
251 80 : "Saturation soil moisture for each horizon [mm] at level 1")
252 :
253 : call unpack_field_and_write(nc, "L1_soilMoistExp", &
254 0 : (/rows1, cols1, soil1, lcscenes/), nodata_dp, L1_soilMoistExp(s1 : e1, :, :), mask1, &
255 80 : "Exponential parameter to how non-linear is the soil water retention at level 1")
256 :
257 45 : if (any(processMatrix(3, 1) == (/2, 3/))) then
258 : call unpack_field_and_write(nc, "L1_jarvis_thresh_c1", &
259 0 : (/rows1, cols1/), nodata_dp, L1_jarvis_thresh_c1(s1 : e1, 1, 1), mask1, &
260 6 : "jarvis critical value for normalized soil water content")
261 : end if
262 :
263 16 : if (processMatrix(5, 1) == -1) then
264 : call unpack_field_and_write(nc, "L1_petLAIcorFactor", &
265 0 : (/rows1, cols1, lais, lcscenes/), nodata_dp, L1_petLAIcorFactor(s1 : e1, :, :), mask1, &
266 10 : "PET correction factor based on LAI")
267 : end if
268 :
269 : call unpack_field_and_write(nc, "L1_tempThresh", &
270 0 : (/rows1, cols1, lcscenes/), nodata_dp, L1_tempThresh(s1 : e1, 1, :), mask1, &
271 64 : "Threshold temperature for snow/rain at level 1")
272 :
273 : call unpack_field_and_write(nc, "L1_unsatThresh", &
274 0 : (/rows1, cols1/), nodata_dp, L1_unsatThresh(s1 : e1, 1, 1), mask1, &
275 48 : "Threshold water depth controlling fast interflow at level 1")
276 :
277 : call unpack_field_and_write(nc, "L1_sealedThresh", &
278 0 : (/rows1, cols1/), nodata_dp, L1_sealedThresh(s1 : e1, 1, 1), mask1, &
279 48 : "Threshold water depth for surface runoff in sealed surfaces at level 1")
280 :
281 : call unpack_field_and_write(nc, "L1_wiltingPoint", &
282 0 : (/rows1, cols1, soil1, lcscenes/), nodata_dp, L1_wiltingPoint(s1 : e1, :, :), mask1, &
283 80 : "Permanent wilting point at level 1")
284 :
285 29 : select case (processMatrix(5, 1))
286 : case(-1 : 0) ! PET is input
287 : call unpack_field_and_write(nc, "L1_fAsp", &
288 0 : (/rows1, cols1/), nodata_dp, L1_fAsp(s1 : e1, 1, 1), mask1, &
289 39 : "PET correction factor due to terrain aspect at level 1")
290 :
291 : case(1) ! Hargreaves-Samani
292 : call unpack_field_and_write(nc, "L1_fAsp", &
293 0 : (/rows1, cols1/), nodata_dp, L1_fAsp(s1 : e1, 1, 1), mask1, &
294 6 : "PET correction factor due to terrain aspect at level 1")
295 :
296 : call unpack_field_and_write(nc, "L1_HarSamCoeff", &
297 0 : (/rows1, cols1/), nodata_dp, L1_HarSamCoeff(s1 : e1, 1, 1), mask1, &
298 6 : "Hargreaves-Samani coefficient")
299 :
300 : case(2) ! Priestley-Taylor
301 : call unpack_field_and_write(nc, "L1_PrieTayAlpha", &
302 0 : (/rows1, cols1, lais/), nodata_dp, L1_PrieTayAlpha(s1 : e1, :, 1), mask1, &
303 4 : "Priestley Taylor coeffiecient (alpha)")
304 :
305 : case(3) ! Penman-Monteith
306 : call unpack_field_and_write(nc, "L1_aeroResist", &
307 0 : (/rows1, cols1, lais, lcscenes/), nodata_dp, L1_aeroResist(s1 : e1, :, :), mask1, &
308 0 : "aerodynamical resitance")
309 :
310 : call unpack_field_and_write(nc, "L1_surfResist", &
311 0 : (/rows1, cols1, lais/), nodata_dp, L1_surfResist(s1 : e1, :, 1), mask1, &
312 16 : "bulk surface resitance")
313 :
314 : end select
315 :
316 : ! neutron count
317 16 : select case (processMatrix(10, 1))
318 : case(1) ! deslet
319 : call unpack_field_and_write(nc, "L1_No_Count", &
320 0 : (/rows1, cols1/), nodata_dp, L1_No_Count(s1:e1, 1, 1), mask1, &
321 0 : "N0 count at level 1")
322 : call unpack_field_and_write(nc, "L1_bulkDens", &
323 0 : (/rows1, cols1, soil1, lcscenes/), nodata_dp, L1_bulkDens(s1:e1, :, :), mask1, &
324 0 : "Bulk density at level 1 for processCase(10)")
325 : call unpack_field_and_write(nc, "L1_latticeWater", &
326 0 : (/rows1, cols1, soil1, lcscenes/), nodata_dp, L1_latticeWater(s1:e1, :, :), mask1, &
327 0 : "Lattice water content at level 1 for processCase(10)")
328 :
329 : case(2) ! COSMIC
330 : call unpack_field_and_write(nc, "L1_No_Count", &
331 0 : (/rows1, cols1/), nodata_dp, L1_No_Count(s1 : e1, 1, 1), mask1, &
332 0 : "N0 count at level 1")
333 : call unpack_field_and_write(nc, "L1_bulkDens", &
334 0 : (/rows1, cols1, soil1, lcscenes/), nodata_dp, L1_bulkDens(s1 : e1, :, :), mask1, &
335 0 : "Bulk density at level 1 for processCase(10)")
336 : call unpack_field_and_write(nc, "L1_latticeWater", &
337 0 : (/rows1, cols1, soil1, lcscenes/), nodata_dp, L1_latticeWater(s1 : e1, :, :), mask1, &
338 0 : "Lattice water content at level 1 for processCase(10)")
339 : call unpack_field_and_write(nc, "L1_COSMICL3", &
340 0 : (/rows1, cols1, soil1, lcscenes/), nodata_dp, L1_COSMICL3(s1 : e1, :, :), mask1, &
341 16 : "COSMIC L3 parameter at level 1 for processCase(10)")
342 : end select
343 :
344 16 : end subroutine write_eff_params
345 :
346 : !> \copydoc unpack_field_and_write
347 : subroutine unpack_field_and_write_1d_i4(nc, var_name, var_dims, fill_value, data, mask, var_long_name)
348 :
349 16 : use mo_kind, only : i4
350 : use mo_netcdf, only : NcDataset, NcDimension, NcVariable
351 :
352 : implicit none
353 :
354 : ! NcDataset to add variable to
355 : type(NcDataset), intent(inout) :: nc
356 :
357 : ! variable name
358 : character(*), intent(in) :: var_name
359 :
360 : ! vector of Variable dimensions
361 : type(NcDimension), dimension(:), intent(in) :: var_dims
362 :
363 : ! fill value used for missing values
364 : integer(i4), intent(in) :: fill_value
365 :
366 : ! packed data to be set to variable
367 : integer(i4), dimension(:), intent(in) :: data
368 :
369 : ! mask used for unpacking
370 : logical, dimension(:, :), intent(in) :: mask
371 :
372 : ! variable long name attribute
373 : character(*), optional, intent(in) :: var_long_name
374 :
375 : type(NcVariable) :: var
376 :
377 :
378 : ! set variable
379 : var = nc%setVariable(var_name, "i32", var_dims)
380 : call var%setFillValue(fill_value)
381 :
382 : ! set the unpacked data
383 : call var%setData(unpack(data, mask, fill_value))
384 :
385 : ! optionally set attributes
386 : if (present(var_long_name)) then
387 : call var%setAttribute("long_name", trim(var_long_name))
388 : end if
389 :
390 : end subroutine
391 :
392 : !> \copydoc unpack_field_and_write
393 134 : subroutine unpack_field_and_write_1d_dp(nc, var_name, var_dims, fill_value, data, mask, var_long_name)
394 :
395 : use mo_kind, only : dp
396 : use mo_netcdf, only : NcDataset, NcDimension, NcVariable
397 :
398 : implicit none
399 :
400 : ! NcDataset to add variable to
401 : type(NcDataset), intent(inout) :: nc
402 :
403 : ! variable name
404 : character(*), intent(in) :: var_name
405 :
406 : ! vector of Variable dimensions
407 : type(NcDimension), dimension(:), intent(in) :: var_dims
408 :
409 : ! fill value used for missing values
410 : real(dp), intent(in) :: fill_value
411 :
412 : ! packed data to be set to variable
413 : real(dp), dimension(:), intent(in) :: data
414 :
415 : ! mask used for unpacking
416 : logical, dimension(:, :), intent(in) :: mask
417 :
418 : ! variable long name attribute
419 : character(*), optional, intent(in) :: var_long_name
420 :
421 : type(NcVariable) :: var
422 :
423 :
424 : ! set variable
425 67 : var = nc%setVariable(var_name, "f64", var_dims)
426 67 : call var%setFillValue(fill_value)
427 :
428 : ! set the unpacked data
429 67 : call var%setData(unpack(data, mask, fill_value))
430 :
431 : ! optionally set attributes
432 67 : if (present(var_long_name)) then
433 67 : call var%setAttribute("long_name", trim(var_long_name))
434 : end if
435 :
436 67 : end subroutine
437 :
438 : !> \copydoc unpack_field_and_write
439 386 : subroutine unpack_field_and_write_2d_dp(nc, var_name, var_dims, fill_value, data, mask, var_long_name)
440 :
441 67 : use mo_kind, only : dp, i4
442 : use mo_netcdf, only : NcDataset, NcDimension, NcVariable
443 :
444 : implicit none
445 :
446 : ! NcDataset to add variable to
447 : type(NcDataset), intent(inout) :: nc
448 :
449 : ! variable name
450 : character(*), intent(in) :: var_name
451 :
452 : ! vector of Variable dimensions
453 : type(NcDimension), dimension(:), intent(in) :: var_dims
454 :
455 : ! fill value used for missing values
456 : real(dp), intent(in) :: fill_value
457 :
458 : ! packed data to be set to variable
459 : real(dp), dimension(:, :), intent(in) :: data
460 :
461 : ! mask used for unpacking
462 : logical, dimension(:, :), intent(in) :: mask
463 :
464 : ! variable long name attribute
465 : character(*), optional, intent(in) :: var_long_name
466 :
467 : type(NcVariable) :: var
468 :
469 193 : real(dp), dimension(:, :, :), allocatable :: dummy_arr
470 :
471 : integer(i4), dimension(3) :: dim_length
472 :
473 : integer(i4) :: ii
474 :
475 :
476 : ! set variable
477 193 : var = nc%setVariable(var_name, "f64", var_dims)
478 193 : call var%setFillValue(fill_value)
479 :
480 772 : dim_length = var%getShape()
481 965 : allocate(dummy_arr(dim_length(1), dim_length(2), dim_length(3)))
482 767 : do ii = 1, size(data, 2)
483 767 : dummy_arr(:, :, ii) = unpack(data(:, ii), mask, fill_value)
484 : end do
485 :
486 : ! set the unpacked data
487 193 : call var%setData(dummy_arr)
488 :
489 : ! optionally set attributes
490 193 : if (present(var_long_name)) then
491 193 : call var%setAttribute("long_name", trim(var_long_name))
492 : end if
493 :
494 193 : end subroutine
495 :
496 : !> \copydoc unpack_field_and_write
497 164 : subroutine unpack_field_and_write_3d_dp(nc, var_name, var_dims, fill_value, data, mask, var_long_name)
498 :
499 193 : use mo_kind, only : dp, i4
500 : use mo_netcdf, only : NcDataset, NcDimension, NcVariable
501 :
502 : implicit none
503 :
504 : ! NcDataset to add variable to
505 : type(NcDataset), intent(inout) :: nc
506 :
507 : ! variable name
508 : character(*), intent(in) :: var_name
509 :
510 : ! vector of Variable dimensions
511 : type(NcDimension), dimension(:), intent(in) :: var_dims
512 :
513 : ! fill value used for missing values
514 : real(dp), intent(in) :: fill_value
515 :
516 : ! packed data to be set to variable
517 : real(dp), dimension(:, :, :), intent(in) :: data
518 :
519 : ! mask used for unpacking
520 : logical, dimension(:, :), intent(in) :: mask
521 :
522 : ! variable long name attribute
523 : character(*), optional, intent(in) :: var_long_name
524 :
525 : type(NcVariable) :: var
526 :
527 82 : real(dp), dimension(:, :, :, :), allocatable :: dummy_arr
528 :
529 : integer(i4), dimension(4) :: dim_length
530 :
531 : integer(i4) :: ii, jj
532 :
533 :
534 : ! set variable
535 82 : var = nc%setVariable(var_name, "f64", var_dims)
536 82 : call var%setFillValue(fill_value)
537 :
538 410 : dim_length = var%getShape()
539 492 : allocate(dummy_arr(dim_length(1), dim_length(2), dim_length(3), dim_length(4)))
540 266 : do ii = 1, size(data, 2)
541 634 : do jj = 1, size(data, 3)
542 552 : dummy_arr(:, :, ii, jj) = unpack(data(:, ii, jj), mask, fill_value)
543 : end do
544 : end do
545 :
546 : ! set the unpacked data
547 82 : call var%setData(dummy_arr)
548 :
549 : ! optionally set attributes
550 82 : if (present(var_long_name)) then
551 82 : call var%setAttribute("long_name", trim(var_long_name))
552 : end if
553 :
554 82 : end subroutine
555 :
556 : END MODULE mo_mpr_restart
|
