Line data Source code
1 : module cam_grid_support
2 : use shr_kind_mod, only: r8=>shr_kind_r8, r4=>shr_kind_r4, max_chars=>shr_kind_cl
3 : use shr_kind_mod, only: i8=>shr_kind_i8, i4=>shr_kind_i4
4 : use shr_sys_mod, only: shr_sys_flush
5 : use pio, only: iMap=>PIO_OFFSET_KIND, var_desc_t
6 : use cam_abortutils, only: endrun
7 : use cam_logfile, only: iulog
8 : use spmd_utils, only: masterproc
9 : use cam_pio_utils, only: cam_pio_handle_error
10 : use cam_map_utils, only: cam_filemap_t
11 :
12 : implicit none
13 : private
14 :
15 : public iMap
16 :
17 : integer, parameter, public :: max_hcoordname_len = 16
18 : integer, parameter, public :: maxsplitfiles = 2
19 :
20 : type, public :: vardesc_ptr_t
21 : type(var_desc_t), pointer :: p => NULL()
22 : end type vardesc_ptr_t
23 : !---------------------------------------------------------------------------
24 : !
25 : ! horiz_coord_t: Information for horizontal dimension attributes
26 : !
27 : !---------------------------------------------------------------------------
28 : type, public :: horiz_coord_t
29 : private
30 : character(len=max_hcoordname_len) :: name = '' ! coordinate name
31 : character(len=max_hcoordname_len) :: dimname = '' ! dimension name
32 : ! NB: If dimname is blank, it is assumed to be name
33 : integer :: dimsize = 0 ! global size of dimension
34 : character(len=max_chars) :: long_name = '' ! 'long_name' attribute
35 : character(len=max_chars) :: units = '' ! 'units' attribute
36 : real(r8), pointer :: values(:) => NULL() ! dim values (local if map)
37 : integer(iMap), pointer :: map(:) => NULL() ! map (dof) for dist. coord
38 : logical :: latitude ! .false. means longitude
39 : real(r8), pointer :: bnds(:,:) => NULL() ! bounds, if present
40 : type(vardesc_ptr_t) :: vardesc(maxsplitfiles) ! If we are to write coord
41 : type(vardesc_ptr_t) :: bndsvdesc(maxsplitfiles) ! If we are to write bounds
42 : contains
43 : procedure :: get_coord_len => horiz_coord_len
44 : procedure :: num_elem => horiz_coord_num_elem
45 : procedure :: global_size => horiz_coord_find_size
46 : procedure :: get_coord_name => horiz_coord_name
47 : procedure :: get_dim_name => horiz_coord_dim_name
48 : procedure :: get_long_name => horiz_coord_long_name
49 : procedure :: get_units => horiz_coord_units
50 : procedure :: write_attr => write_horiz_coord_attr
51 : procedure :: write_var => write_horiz_coord_var
52 : end type horiz_coord_t
53 :
54 : !---------------------------------------------------------------------------
55 : !
56 : ! cam_grid_attribute_t: Auxiliary quantity for a CAM grid
57 : !
58 : !---------------------------------------------------------------------------
59 : type, abstract :: cam_grid_attribute_t
60 : character(len=max_hcoordname_len) :: name = '' ! attribute name
61 : character(len=max_chars) :: long_name = '' ! attribute long_name
62 : type(vardesc_ptr_t) :: vardesc(maxsplitfiles)
63 : ! We aren't going to use this until we sort out PGI issues
64 : class(cam_grid_attribute_t), pointer :: next => NULL()
65 : contains
66 : procedure :: cam_grid_attr_init
67 : procedure(write_cam_grid_attr), deferred :: write_attr
68 : procedure(write_cam_grid_attr), deferred :: write_val
69 : procedure(print_attr_spec), deferred :: print_attr
70 : procedure :: print_attr_base
71 : end type cam_grid_attribute_t
72 :
73 : !---------------------------------------------------------------------------
74 : !
75 : ! cam_grid_attribute_0d_int_t: Global integral attribute
76 : !
77 : !---------------------------------------------------------------------------
78 : type, extends(cam_grid_attribute_t) :: cam_grid_attribute_0d_int_t
79 : integer :: ival
80 : contains
81 : procedure :: cam_grid_attr_init_0d_int
82 : procedure :: write_attr => write_cam_grid_attr_0d_int
83 : procedure :: write_val => write_cam_grid_val_0d_int
84 : procedure :: print_attr => print_attr_0d_int
85 : end type cam_grid_attribute_0d_int_t
86 :
87 : !---------------------------------------------------------------------------
88 : !
89 : ! cam_grid_attribute_0d_char_t: Global string attribute
90 : !
91 : !---------------------------------------------------------------------------
92 : type, extends(cam_grid_attribute_t) :: cam_grid_attribute_0d_char_t
93 : character(len=max_chars) :: val
94 : contains
95 : procedure :: cam_grid_attr_init_0d_char
96 : procedure :: write_attr => write_cam_grid_attr_0d_char
97 : procedure :: write_val => write_cam_grid_val_0d_char
98 : procedure :: print_attr => print_attr_0d_char
99 : end type cam_grid_attribute_0d_char_t
100 :
101 : !---------------------------------------------------------------------------
102 : !
103 : ! cam_grid_attribute_1d_int_t: 1-d integer attribute
104 : !
105 : !---------------------------------------------------------------------------
106 : type, extends(cam_grid_attribute_t) :: cam_grid_attribute_1d_int_t
107 : character(len=max_hcoordname_len) :: dimname ! attribute dimension
108 : integer :: dimsize ! Global array/map size
109 : integer, pointer :: values(:) => NULL()
110 : integer(iMap), pointer :: map(:) => NULL() ! map (dof) for I/O
111 : contains
112 : procedure :: cam_grid_attr_init_1d_int
113 : procedure :: write_attr => write_cam_grid_attr_1d_int
114 : procedure :: write_val => write_cam_grid_val_1d_int
115 : procedure :: print_attr => print_attr_1d_int
116 : end type cam_grid_attribute_1d_int_t
117 :
118 : !---------------------------------------------------------------------------
119 : !
120 : ! cam_grid_attribute_1d_r8_t: 1-d real*8 attribute
121 : !
122 : !---------------------------------------------------------------------------
123 : type, extends(cam_grid_attribute_t) :: cam_grid_attribute_1d_r8_t
124 : character(len=max_hcoordname_len) :: dimname ! attribute dimension
125 : integer :: dimsize ! Global array/map size
126 : real(r8), pointer :: values(:) => NULL()
127 : integer(iMap), pointer :: map(:) => NULL() ! map (dof) for I/O
128 : contains
129 : procedure :: cam_grid_attr_init_1d_r8
130 : procedure :: write_attr => write_cam_grid_attr_1d_r8
131 : procedure :: write_val => write_cam_grid_val_1d_r8
132 : procedure :: print_attr => print_attr_1d_r8
133 : end type cam_grid_attribute_1d_r8_t
134 :
135 : !---------------------------------------------------------------------------
136 : !
137 : ! cam_grid_attr_ptr_t: linked list of CAM grid attributes
138 : !
139 : !---------------------------------------------------------------------------
140 : type :: cam_grid_attr_ptr_t
141 : private
142 : class(cam_grid_attribute_t), pointer :: attr => NULL()
143 : type(cam_grid_attr_ptr_t), pointer :: next => NULL()
144 : contains
145 : private
146 : procedure, public :: initialize => initializeAttrPtr
147 : procedure, public :: getAttr => getAttrPtrAttr
148 : procedure, public :: getNext => getAttrPtrNext
149 : procedure, public :: setNext => setAttrPtrNext
150 : end type cam_grid_attr_ptr_t
151 :
152 : !---------------------------------------------------------------------------
153 : !
154 : ! cam_grid_t: Information for a CAM grid (defined by a dycore)
155 : !
156 : !---------------------------------------------------------------------------
157 : type :: cam_grid_t
158 : character(len=max_hcoordname_len) :: name = '' ! grid name
159 : integer :: id ! e.g., dyn_decomp
160 : type(horiz_coord_t), pointer :: lat_coord => NULL() ! Latitude coord
161 : type(horiz_coord_t), pointer :: lon_coord => NULL() ! Longitude coord
162 : logical :: unstructured ! Is this needed?
163 : logical :: block_indexed ! .false. for lon/lat
164 : logical :: attrs_defined(2) = .false.
165 : logical :: zonal_grid = .false.
166 : type(cam_filemap_t), pointer :: map => null() ! global dim map (dof)
167 : type(cam_grid_attr_ptr_t), pointer :: attributes => NULL()
168 : contains
169 : procedure :: print_cam_grid
170 : procedure :: is_unstructured => cam_grid_unstructured
171 : procedure :: is_block_indexed => cam_grid_block_indexed
172 : procedure :: is_zonal_grid => cam_grid_zonal_grid
173 : procedure :: coord_lengths => cam_grid_get_dims
174 : procedure :: coord_names => cam_grid_coord_names
175 : procedure :: dim_names => cam_grid_dim_names
176 : procedure :: num_elem => cam_grid_local_size
177 : procedure :: set_map => cam_grid_set_map
178 : procedure :: get_patch_mask => cam_grid_get_patch_mask
179 : procedure :: get_lon_lat => cam_grid_get_lon_lat
180 : procedure :: find_src_dims => cam_grid_find_src_dims
181 : procedure :: find_dest_dims => cam_grid_find_dest_dims
182 : procedure :: find_dimids => cam_grid_find_dimids
183 : procedure :: get_decomp => cam_grid_get_pio_decomp
184 : procedure :: read_darray_2d_int => cam_grid_read_darray_2d_int
185 : procedure :: read_darray_3d_int => cam_grid_read_darray_3d_int
186 : procedure :: read_darray_2d_double => cam_grid_read_darray_2d_double
187 : procedure :: read_darray_3d_double => cam_grid_read_darray_3d_double
188 : procedure :: read_darray_2d_real => cam_grid_read_darray_2d_real
189 : procedure :: read_darray_3d_real => cam_grid_read_darray_3d_real
190 : procedure :: write_darray_2d_int => cam_grid_write_darray_2d_int
191 : procedure :: write_darray_3d_int => cam_grid_write_darray_3d_int
192 : procedure :: write_darray_2d_double => cam_grid_write_darray_2d_double
193 : procedure :: write_darray_3d_double => cam_grid_write_darray_3d_double
194 : procedure :: write_darray_2d_real => cam_grid_write_darray_2d_real
195 : procedure :: write_darray_3d_real => cam_grid_write_darray_3d_real
196 : end type cam_grid_t
197 :
198 : !---------------------------------------------------------------------------
199 : !
200 : ! cam_grid_patch_t: Information for a patch of a CAM grid
201 : !
202 : !---------------------------------------------------------------------------
203 : type, public :: cam_grid_patch_t
204 : private
205 : integer :: grid_id = -1 ! grid containing patch points
206 : integer :: global_size = 0 ! var patch dim size
207 : integer :: global_lat_size = 0 ! lat patch dim size
208 : integer :: global_lon_size = 0 ! lon patch dim size
209 : integer :: num_points = 0 ! task-local size
210 : real(r8) :: lon_range(2)
211 : real(r8) :: lat_range(2)
212 : logical :: collected_columns ! Output unstructured
213 : type(cam_filemap_t), pointer :: mask => null() ! map for active pts
214 : integer(iMap), pointer :: latmap(:) => null() ! map for patch coords
215 : integer(iMap), pointer :: lonmap(:) => null() ! map for patch coords
216 : real(r8), pointer :: lonvals(:) => null() ! For collected output
217 : real(r8), pointer :: latvals(:) => null() ! For collected output
218 : contains
219 : procedure :: gridid => cam_grid_patch_get_id
220 : procedure :: get_axis_names => cam_grid_patch_get_axis_names
221 : procedure :: get_coord_long_name => cam_grid_patch_get_coord_long_name
222 : procedure :: get_coord_units => cam_grid_patch_get_coord_units
223 : procedure :: set_patch => cam_grid_patch_set_patch
224 : procedure :: get_decomp => cam_grid_patch_get_decomp
225 : procedure :: compact => cam_grid_patch_compact
226 : procedure :: active_cols => cam_grid_patch_get_active_cols
227 : procedure :: write_coord_vals => cam_grid_patch_write_vals
228 : procedure :: grid_index => cam_grid_patch_get_grid_index
229 : procedure :: deallocate => cam_grid_patch_deallocate
230 : !!XXgoldyXX: PGI workaround?
231 : ! COMPILER_BUG(goldy, 2014-11-28, pgi <= 14.9); Commented code should work
232 : ! procedure :: global_size_map => cam_grid_patch_get_global_size_map
233 : ! procedure :: global_size_axes => cam_grid_patch_get_global_size_axes
234 : ! generic :: get_global_size => global_size_map, global_size_axes
235 : procedure :: cam_grid_patch_get_global_size_map
236 : procedure :: cam_grid_patch_get_global_size_axes
237 : generic :: get_global_size => cam_grid_patch_get_global_size_map, cam_grid_patch_get_global_size_axes
238 : end type cam_grid_patch_t
239 :
240 : !---------------------------------------------------------------------------
241 : !
242 : ! cam_grid_header_info_t: Hold NetCDF dimension information for a CAM grid
243 : !
244 : !---------------------------------------------------------------------------
245 : type, public :: cam_grid_header_info_t
246 : private
247 : integer :: grid_id = -1 ! e.g., dyn_decomp
248 : integer, allocatable :: hdims(:) ! horizontal dimension ids
249 : type(var_desc_t), pointer :: lon_varid => NULL() ! lon coord variable
250 : type(var_desc_t), pointer :: lat_varid => NULL() ! lat coord variable
251 : contains
252 : procedure :: get_gridid => cam_grid_header_info_get_gridid
253 : procedure :: set_gridid => cam_grid_header_info_set_gridid
254 : procedure :: set_hdims => cam_grid_header_info_set_hdims
255 : procedure :: num_hdims => cam_grid_header_info_num_hdims
256 : procedure :: get_hdimid => cam_grid_header_info_hdim
257 : !!XXgoldyXX: Maybe replace this with horiz_coords for patches?
258 : procedure :: set_varids => cam_grid_header_info_set_varids
259 : procedure :: get_lon_varid => cam_grid_header_info_lon_varid
260 : procedure :: get_lat_varid => cam_grid_header_info_lat_varid
261 : procedure :: deallocate => cam_grid_header_info_deallocate
262 : end type cam_grid_header_info_t
263 :
264 : !---------------------------------------------------------------------------
265 : !
266 : ! END: types BEGIN: interfaces for types
267 : !
268 : !---------------------------------------------------------------------------
269 :
270 : ! Abstract interface for write_attr procedure of cam_grid_attribute_t class
271 : ! NB: This will not compile on some pre-13 Intel compilers
272 : ! (fails on 12.1.0.233 on Frankfurt, passes on 13.0.1.117 on Yellowstone)
273 : abstract interface
274 : subroutine write_cam_grid_attr(attr, File, file_index)
275 : use pio, only: file_desc_t
276 : import :: cam_grid_attribute_t
277 : ! Dummy arguments
278 : class(cam_grid_attribute_t), intent(inout) :: attr
279 : type(file_desc_t), intent(inout) :: File ! PIO file Handle
280 : integer, optional, intent(in) :: file_index
281 : end subroutine write_cam_grid_attr
282 : end interface
283 :
284 : ! Abstract interface for print_attr procedure of cam_grid_attribute_t class
285 : abstract interface
286 : subroutine print_attr_spec(this)
287 : import :: cam_grid_attribute_t
288 : ! Dummy arguments
289 : class(cam_grid_attribute_t), intent(in) :: this
290 : end subroutine print_attr_spec
291 : end interface
292 :
293 : !! Grid variables
294 : integer, parameter :: maxhgrids = 16 ! arbitrary limit
295 : integer, save :: registeredhgrids = 0
296 : type(cam_grid_t), save :: cam_grids(maxhgrids)
297 :
298 : public :: horiz_coord_create
299 :
300 : ! Setup and I/O functions for grids rely on the grid's ID, not its index.
301 : public :: cam_grid_register, cam_grid_attribute_register
302 : public :: cam_grid_attribute_copy
303 : public :: cam_grid_write_attr, cam_grid_write_var
304 : public :: cam_grid_read_dist_array, cam_grid_write_dist_array
305 : ! Access functions for grids rely on the grid's ID or name, not its index.
306 : public :: cam_grid_dimensions, cam_grid_num_grids
307 : public :: cam_grid_check ! T/F if grid ID exists
308 : public :: cam_grid_id ! Grid ID (decomp) or -1 if error
309 : public :: cam_grid_get_local_size
310 : public :: cam_grid_get_file_dimids
311 : public :: cam_grid_get_decomp
312 : public :: cam_grid_get_gcid
313 : public :: cam_grid_get_array_bounds
314 : public :: cam_grid_get_coord_names, cam_grid_get_dim_names
315 : public :: cam_grid_has_blocksize, cam_grid_get_block_count
316 : public :: cam_grid_get_latvals, cam_grid_get_lonvals
317 : public :: cam_grid_get_coords
318 : public :: cam_grid_is_unstructured, cam_grid_is_block_indexed
319 : public :: cam_grid_attr_exists
320 : public :: cam_grid_is_zonal
321 : ! Functions for dealing with patch masks
322 : public :: cam_grid_compute_patch
323 : ! Functions for dealing with grid areas
324 : public :: cam_grid_get_areawt
325 :
326 : interface cam_grid_attribute_register
327 : module procedure add_cam_grid_attribute_0d_int
328 : module procedure add_cam_grid_attribute_0d_char
329 : module procedure add_cam_grid_attribute_1d_int
330 : module procedure add_cam_grid_attribute_1d_r8
331 : end interface
332 :
333 : interface cam_grid_dimensions
334 : module procedure cam_grid_dimensions_id
335 : module procedure cam_grid_dimensions_name
336 : end interface
337 :
338 : interface cam_grid_get_dim_names
339 : module procedure cam_grid_get_dim_names_id
340 : module procedure cam_grid_get_dim_names_name
341 : end interface
342 :
343 : interface cam_grid_read_dist_array
344 : module procedure cam_grid_read_dist_array_2d_int
345 : module procedure cam_grid_read_dist_array_3d_int
346 : module procedure cam_grid_read_dist_array_2d_double
347 : module procedure cam_grid_read_dist_array_3d_double
348 : module procedure cam_grid_read_dist_array_2d_real
349 : module procedure cam_grid_read_dist_array_3d_real
350 : end interface
351 :
352 : interface cam_grid_write_dist_array
353 : module procedure cam_grid_write_dist_array_2d_int
354 : module procedure cam_grid_write_dist_array_3d_int
355 : module procedure cam_grid_write_dist_array_2d_double
356 : module procedure cam_grid_write_dist_array_3d_double
357 : module procedure cam_grid_write_dist_array_2d_real
358 : module procedure cam_grid_write_dist_array_3d_real
359 : end interface
360 :
361 : ! Private interfaces
362 : interface get_cam_grid_index
363 : module procedure get_cam_grid_index_char ! For lookup by name
364 : module procedure get_cam_grid_index_int ! For lookup by ID
365 : end interface
366 :
367 : contains
368 :
369 : !!#######################################################################
370 : !!
371 : !! Horizontal coordinate functions
372 : !!
373 : !!#######################################################################
374 :
375 13824 : integer function horiz_coord_find_size(this, dimname) result(dimsize)
376 : ! Dummy arguments
377 : class(horiz_coord_t), intent(in) :: this
378 : character(len=*), intent(in) :: dimname
379 :
380 13824 : dimsize = -1
381 13824 : if (len_trim(this%dimname) == 0) then
382 0 : if(trim(dimname) == trim(this%name)) then
383 0 : dimsize = this%dimsize
384 : end if
385 : else
386 13824 : if(trim(dimname) == trim(this%dimname)) then
387 13824 : dimsize = this%dimsize
388 : end if
389 : end if
390 :
391 13824 : end function horiz_coord_find_size
392 :
393 0 : integer function horiz_coord_num_elem(this)
394 : ! Dummy arguments
395 : class(horiz_coord_t), intent(in) :: this
396 :
397 0 : if (associated(this%values)) then
398 0 : horiz_coord_num_elem = size(this%values)
399 : else
400 : horiz_coord_num_elem = 0
401 : end if
402 :
403 0 : end function horiz_coord_num_elem
404 :
405 280320 : subroutine horiz_coord_len(this, clen)
406 : ! Dummy arguments
407 : class(horiz_coord_t), intent(in) :: this
408 : integer, intent(out) :: clen
409 :
410 280320 : clen = this%dimsize
411 280320 : end subroutine horiz_coord_len
412 :
413 0 : subroutine horiz_coord_name(this, name)
414 : ! Dummy arguments
415 : class(horiz_coord_t), intent(in) :: this
416 : character(len=*), intent(out) :: name
417 :
418 0 : if (len(name) < len_trim(this%name)) then
419 0 : call endrun('horiz_coord_name: input name too short')
420 : end if
421 0 : name = trim(this%name)
422 0 : end subroutine horiz_coord_name
423 :
424 1089024 : subroutine horiz_coord_dim_name(this, dimname)
425 : ! Dummy arguments
426 : class(horiz_coord_t), intent(in) :: this
427 : character(len=*), intent(out) :: dimname
428 :
429 1089024 : if (len_trim(this%dimname) > 0) then
430 : ! We have a separate dimension name (e.g., ncol)
431 1089024 : if (len(dimname) < len_trim(this%dimname)) then
432 0 : call endrun('horiz_coord_dimname: input name too short')
433 : end if
434 1089024 : dimname = trim(this%dimname)
435 : else
436 : ! No dimension name so we use the coordinate's name
437 : ! i.e., The dimension name is the same as the coordinate variable
438 0 : if (len(dimname) < len_trim(this%name)) then
439 0 : call endrun('horiz_coord_dimname: input name too short')
440 : end if
441 0 : dimname = trim(this%name)
442 : end if
443 1089024 : end subroutine horiz_coord_dim_name
444 :
445 0 : subroutine horiz_coord_long_name(this, name)
446 :
447 : ! Dummy arguments
448 : class(horiz_coord_t), intent(in) :: this
449 : character(len=*), intent(out) :: name
450 :
451 0 : if (len(name) < len_trim(this%long_name)) then
452 0 : call endrun('horiz_coord_long_name: input name too short')
453 : else
454 0 : name = trim(this%long_name)
455 : end if
456 :
457 0 : end subroutine horiz_coord_long_name
458 :
459 0 : subroutine horiz_coord_units(this, units)
460 :
461 : ! Dummy arguments
462 : class(horiz_coord_t), intent(in) :: this
463 : character(len=*), intent(out) :: units
464 :
465 0 : if (len(units) < len_trim(this%units)) then
466 0 : call endrun('horiz_coord_units: input units too short')
467 : else
468 0 : units = trim(this%units)
469 : end if
470 :
471 0 : end subroutine horiz_coord_units
472 :
473 13824 : function horiz_coord_create(name, dimname, dimsize, long_name, units, &
474 13824 : lbound, ubound, values, map, bnds) result(newcoord)
475 :
476 : ! Dummy arguments
477 : character(len=*), intent(in) :: name
478 : character(len=*), intent(in) :: dimname
479 : integer, intent(in) :: dimsize
480 : character(len=*), intent(in) :: long_name
481 : character(len=*), intent(in) :: units
482 : ! NB: Sure, pointers would have made sense but . . . PGI
483 : integer, intent(in) :: lbound
484 : integer, intent(in) :: ubound
485 : real(r8), intent(in) :: values(lbound:ubound)
486 : integer(iMap), intent(in), optional :: map(ubound-lbound+1)
487 : real(r8), intent(in), optional :: bnds(2,lbound:ubound)
488 : type(horiz_coord_t), pointer :: newcoord
489 :
490 69120 : allocate(newcoord)
491 :
492 13824 : newcoord%name = trim(name)
493 13824 : newcoord%dimname = trim(dimname)
494 13824 : newcoord%dimsize = dimsize
495 13824 : newcoord%long_name = trim(long_name)
496 13824 : newcoord%units = trim(units)
497 : ! Figure out if this is a latitude or a longitude using CF standard
498 : ! http://cfconventions.org/Data/cf-conventions/cf-conventions-1.6/build/cf-conventions.html#latitude-coordinate
499 : ! http://cfconventions.org/Data/cf-conventions/cf-conventions-1.6/build/cf-conventions.html#longitude-coordinate
500 : if ( (trim(units) == 'degrees_north') .or. &
501 : (trim(units) == 'degree_north') .or. &
502 : (trim(units) == 'degree_N') .or. &
503 : (trim(units) == 'degrees_N') .or. &
504 13824 : (trim(units) == 'degreeN') .or. &
505 : (trim(units) == 'degreesN')) then
506 6912 : newcoord%latitude = .true.
507 : else if ((trim(units) == 'degrees_east') .or. &
508 : (trim(units) == 'degree_east') .or. &
509 : (trim(units) == 'degree_E') .or. &
510 : (trim(units) == 'degrees_E') .or. &
511 6912 : (trim(units) == 'degreeE') .or. &
512 : (trim(units) == 'degreesE')) then
513 6912 : newcoord%latitude = .false.
514 : else
515 0 : call endrun("horiz_coord_create: unsupported units: '"//trim(units)//"'")
516 : end if
517 41472 : allocate(newcoord%values(lbound:ubound))
518 13824 : if (ubound >= lbound) then
519 1119168 : newcoord%values(:) = values(:)
520 : end if
521 :
522 13824 : if (present(map)) then
523 1119168 : if (ANY(map < 0)) then
524 0 : call endrun("horiz_coord_create "//trim(name)//": map vals < 0")
525 : end if
526 41472 : allocate(newcoord%map(ubound - lbound + 1))
527 13824 : if (ubound >= lbound) then
528 1119168 : newcoord%map(:) = map(:)
529 : end if
530 : else
531 0 : nullify(newcoord%map)
532 : end if
533 :
534 13824 : if (present(bnds)) then
535 0 : allocate(newcoord%bnds(2, lbound:ubound))
536 0 : if (ubound >= lbound) then
537 0 : newcoord%bnds = bnds
538 : end if
539 : else
540 13824 : nullify(newcoord%bnds)
541 : end if
542 :
543 27648 : end function horiz_coord_create
544 :
545 : !---------------------------------------------------------------------------
546 : !
547 : ! write_horiz_coord_attr
548 : !
549 : ! Write the dimension and coordinate attributes for a horizontal grid
550 : ! coordinate.
551 : !
552 : !---------------------------------------------------------------------------
553 :
554 497664 : subroutine write_horiz_coord_attr(this, File, dimid_out, file_index)
555 : use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_double
556 : use pio, only: pio_bcast_error, pio_seterrorhandling, pio_inq_varid
557 : use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var
558 :
559 : ! Dummy arguments
560 : class(horiz_coord_t), intent(inout) :: this
561 : type(file_desc_t), intent(inout) :: File ! PIO file Handle
562 : integer, optional, intent(out) :: dimid_out
563 : integer, optional, intent(in) :: file_index
564 :
565 : ! Local variables
566 : type(var_desc_t) :: vardesc
567 : character(len=max_hcoordname_len) :: dimname
568 : integer :: dimid ! PIO dimension ID
569 : integer :: bnds_dimid ! PIO dim ID for bounds
570 : integer :: err_handling
571 : integer :: ierr
572 : integer :: file_index_loc
573 :
574 : ! We will handle errors for this routine
575 497664 : call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling)
576 :
577 497664 : if (present(file_index)) then
578 497664 : file_index_loc = file_index
579 : else
580 : file_index_loc = 1
581 : end if
582 :
583 : ! Make sure the dimension exists in the file
584 497664 : call this%get_dim_name(dimname)
585 : call cam_pio_def_dim(File, trim(dimname), this%dimsize, dimid, &
586 497664 : existOK=.true.)
587 : ! Should we define the variable?
588 497664 : ierr = pio_inq_varid(File, trim(this%name), vardesc)
589 497664 : if (ierr /= PIO_NOERR) then
590 : ! Variable not already defined, it is up to us to define the variable
591 497664 : if (associated(this%vardesc(file_index_loc)%p)) then
592 : ! This should not happen (i.e., internal error)
593 0 : call endrun('write_horiz_coord_attr: vardesc already allocated for '//trim(dimname))
594 : end if
595 497664 : allocate(this%vardesc(file_index_loc)%p)
596 : call cam_pio_def_var(File, trim(this%name), pio_double, &
597 995328 : (/ dimid /), this%vardesc(file_index_loc)%p, existOK=.false.)
598 : ! long_name
599 497664 : ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'long_name', trim(this%long_name))
600 497664 : call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_horiz_coord_attr')
601 : ! units
602 497664 : ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'units', trim(this%units))
603 497664 : call cam_pio_handle_error(ierr, 'Error writing "units" attr in write_horiz_coord_attr')
604 : ! Take care of bounds if they exist
605 497664 : if (associated(this%bnds)) then
606 0 : allocate(this%bndsvdesc(file_index_loc)%p)
607 0 : ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'bounds', trim(this%name)//'_bnds')
608 0 : call cam_pio_handle_error(ierr, 'Error writing "'//trim(this%name)//'_bnds" attr in write_horiz_coord_attr')
609 0 : call cam_pio_def_dim(File, 'nbnd', 2, bnds_dimid, existOK=.true.)
610 : call cam_pio_def_var(File, trim(this%name)//'_bnds', pio_double, &
611 0 : (/ bnds_dimid, dimid /), this%bndsvdesc(file_index_loc)%p, existOK=.false.)
612 0 : call cam_pio_handle_error(ierr, 'Error defining "'//trim(this%name)//'bnds" in write_horiz_coord_attr')
613 : ! long_name
614 0 : ierr=pio_put_att(File, this%bndsvdesc(file_index_loc)%p, 'long_name', trim(this%name)//' bounds')
615 0 : call cam_pio_handle_error(ierr, 'Error writing bounds "long_name" attr in write_horiz_coord_attr')
616 : ! units
617 0 : ierr=pio_put_att(File, this%bndsvdesc(file_index_loc)%p, 'units', trim(this%units))
618 0 : call cam_pio_handle_error(ierr, 'Error writing bounds "units" attr in write_horiz_coord_attr')
619 : end if ! There are bounds for this coordinate
620 : end if ! We define the variable
621 :
622 497664 : if (present(dimid_out)) then
623 497664 : dimid_out = dimid
624 : end if
625 :
626 : ! Back to old error handling
627 497664 : call pio_seterrorhandling(File, err_handling)
628 :
629 497664 : end subroutine write_horiz_coord_attr
630 :
631 : !---------------------------------------------------------------------------
632 : !
633 : ! write_horiz_coord_var
634 : !
635 : ! Write the coordinate values for this coordinate
636 : !
637 : !---------------------------------------------------------------------------
638 :
639 497664 : subroutine write_horiz_coord_var(this, File, file_index)
640 497664 : use cam_pio_utils, only: cam_pio_get_decomp
641 : use pio, only: file_desc_t, pio_double, iosystem_desc_t
642 : use pio, only: pio_put_var, pio_write_darray
643 : use pio, only: pio_bcast_error, pio_seterrorhandling
644 : !!XXgoldyXX: HACK to get around circular dependencies. Fix this!!
645 : !!XXgoldyXX: The issue is cam_pio_utils depending on stuff in this module
646 : use pio, only: pio_initdecomp, io_desc_t, pio_freedecomp, pio_syncfile
647 : use cam_instance, only: atm_id
648 : use shr_pio_mod, only: shr_pio_getiosys
649 : !!XXgoldyXX: End of this part of the hack
650 :
651 : ! Dummy arguments
652 : class(horiz_coord_t), intent(inout) :: this
653 : type(file_desc_t), intent(inout) :: File ! PIO file Handle
654 : integer, optional, intent(in) :: file_index
655 :
656 : ! Local variables
657 : character(len=120) :: errormsg
658 : integer :: ierr
659 : integer :: ldims(1)
660 : integer :: fdims(1)
661 : integer :: err_handling
662 : type(io_desc_t) :: iodesc
663 : integer :: file_index_loc
664 : !!XXgoldyXX: HACK to get around circular dependencies. Fix this!!
665 : type(iosystem_desc_t), pointer :: piosys
666 : !!XXgoldyXX: End of this part of the hack
667 :
668 497664 : if (present(file_index)) then
669 491520 : file_index_loc = file_index
670 : else
671 : file_index_loc = 1
672 : end if
673 :
674 : ! Check to make sure we are supposed to write this var
675 497664 : if (associated(this%vardesc(file_index_loc)%p)) then
676 : ! We will handle errors for this routine
677 497664 : call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling)
678 :
679 : ! Write out the values for this dimension variable
680 497664 : if (associated(this%map)) then
681 : ! This is a distributed variable, use pio_write_darray
682 : #if 0
683 : ldims(1) = this%num_elem()
684 : call this%get_coord_len(fdims(1))
685 : allocate(iodesc)
686 : call cam_pio_get_decomp(iodesc, ldims, fdims, PIO_DOUBLE, this%map)
687 : call pio_write_darray(File, this%vardesc(file_index_loc)%p, iodesc, this%values, ierr)
688 : nullify(iodesc) ! CAM PIO system takes over memory management of iodesc
689 : #else
690 : !!XXgoldyXX: HACK to get around circular dependencies. Fix this!!
691 497664 : piosys => shr_pio_getiosys(atm_id)
692 : call pio_initdecomp(piosys, pio_double, (/this%dimsize/), this%map, &
693 995328 : iodesc)
694 497664 : call pio_write_darray(File, this%vardesc(file_index_loc)%p, iodesc, this%values, ierr)
695 :
696 497664 : call pio_syncfile(File)
697 497664 : call pio_freedecomp(File, iodesc)
698 : ! Take care of bounds if they exist
699 497664 : if (associated(this%bnds) .and. associated(this%bndsvdesc(file_index_loc)%p)) then
700 : call pio_initdecomp(piosys, pio_double, (/2, this%dimsize/), &
701 0 : this%map, iodesc)
702 0 : call pio_write_darray(File, this%bndsvdesc(file_index_loc)%p, iodesc, this%bnds, ierr)
703 0 : call pio_syncfile(File)
704 0 : call pio_freedecomp(File, iodesc)
705 : end if
706 : #endif
707 : !!XXgoldyXX: End of this part of the hack
708 : else
709 : ! This is a local variable, pio_put_var should work fine
710 0 : ierr = pio_put_var(File, this%vardesc(file_index_loc)%p, this%values)
711 : ! Take care of bounds if they exist
712 0 : if (associated(this%bnds) .and. associated(this%bndsvdesc(file_index_loc)%p)) then
713 0 : ierr = pio_put_var(File, this%bndsvdesc(file_index_loc)%p, this%bnds)
714 : end if
715 : end if
716 497664 : write(errormsg, *) 'Error writing variable values for ',trim(this%name),&
717 995328 : ' in write_horiz_coord_var'
718 497664 : call cam_pio_handle_error(ierr, errormsg)
719 :
720 : ! Back to old error handling
721 497664 : call pio_seterrorhandling(File, err_handling)
722 :
723 : ! We are done with this variable descriptor, reset for next file
724 497664 : deallocate(this%vardesc(file_index_loc)%p)
725 497664 : nullify(this%vardesc(file_index_loc)%p)
726 : ! Same with the bounds descriptor
727 497664 : if (associated(this%bndsvdesc(file_index_loc)%p)) then
728 0 : deallocate(this%bndsvdesc(file_index_loc)%p)
729 0 : nullify(this%bndsvdesc(file_index_loc)%p)
730 : end if
731 : end if ! Do we write the variable?
732 :
733 497664 : end subroutine write_horiz_coord_var
734 :
735 : !!#######################################################################
736 : !!
737 : !! CAM grid functions
738 : !!
739 : !!#######################################################################
740 :
741 2441701968 : integer function get_cam_grid_index_char(gridname)
742 : ! Dummy arguments
743 : character(len=*), intent(in) :: gridname
744 : ! Local variables
745 : integer :: i
746 :
747 2441701968 : get_cam_grid_index_char = -1
748 10984512744 : do i = 1, registeredhgrids
749 10984512744 : if(trim(gridname) == trim(cam_grids(i)%name)) then
750 2441695056 : get_cam_grid_index_char = i
751 2441695056 : exit
752 : end if
753 : end do
754 :
755 497664 : end function get_cam_grid_index_char
756 :
757 610864272 : integer function get_cam_grid_index_int(gridid)
758 : ! Dummy arguments
759 : integer, intent(in) :: gridid
760 : ! Local variables
761 : integer :: i
762 :
763 610864272 : get_cam_grid_index_int = -1
764 2747094000 : do i = 1, registeredhgrids
765 2747094000 : if(gridid == cam_grids(i)%id) then
766 : get_cam_grid_index_int = i
767 : exit
768 : end if
769 : end do
770 :
771 610864272 : end function get_cam_grid_index_int
772 :
773 30720 : subroutine find_cam_grid_attr(gridind, name, attr)
774 : ! Dummy arguments
775 : integer, intent(in) :: gridind
776 : character(len=*), intent(in) :: name
777 : class(cam_grid_attribute_t), pointer, intent(out) :: attr
778 : ! Local variable
779 : type(cam_grid_attr_ptr_t), pointer :: attrPtr
780 :
781 30720 : nullify(attr)
782 30720 : attrPtr => cam_grids(gridind)%attributes
783 72960 : do while (associated(attrPtr))
784 : !!XXgoldyXX: Is this not working in PGI?
785 : ! attr => attrPtr%getAttr()
786 45312 : attr => attrPtr%attr
787 72960 : if (trim(name) == trim(attr%name)) then
788 : exit
789 : else
790 : !!XXgoldyXX: Is this not working in PGI?
791 : ! attrPtr => attrPtr%getNext()
792 42240 : attrPtr => attrPtr%next
793 42240 : nullify(attr)
794 : end if
795 : end do
796 30720 : return ! attr should be NULL if not found
797 : end subroutine find_cam_grid_attr
798 :
799 1536 : logical function cam_grid_attr_exists(gridname, name)
800 : ! Dummy arguments
801 : character(len=*), intent(in) :: gridname
802 : character(len=*), intent(in) :: name
803 : ! Local variables
804 : class(cam_grid_attribute_t), pointer :: attr
805 : integer :: gridind
806 :
807 1536 : gridind = get_cam_grid_index(trim(gridname))
808 1536 : if (gridind > 0) then
809 1536 : call find_cam_grid_attr(gridind, name, attr)
810 1536 : cam_grid_attr_exists = associated(attr)
811 1536 : nullify(attr)
812 : else
813 0 : call endrun('cam_grid_attr_exists: Bad grid name, "'//trim(gridname)//'"')
814 : end if
815 1536 : end function cam_grid_attr_exists
816 :
817 : integer function num_cam_grid_attrs(gridind)
818 : ! Dummy arguments
819 : integer, intent(in) :: gridind
820 :
821 : ! Local variables
822 : class(cam_grid_attr_ptr_t), pointer :: attrPtr
823 :
824 : num_cam_grid_attrs = 0
825 : attrPtr => cam_grids(gridind)%attributes
826 : do while (associated(attrPtr))
827 : num_cam_grid_attrs = num_cam_grid_attrs + 1
828 : !!XXgoldyXX: Is this not working in PGI?
829 : ! attrPtr => attrPtr%getNext()
830 : attrPtr => attrPtr%next
831 : end do
832 : end function num_cam_grid_attrs
833 :
834 6912 : subroutine cam_grid_register(name, id, lat_coord, lon_coord, map, &
835 : unstruct, block_indexed, zonal_grid, src_in, dest_in)
836 : ! Dummy arguments
837 : character(len=*), intent(in) :: name
838 : integer, intent(in) :: id
839 : type(horiz_coord_t), pointer, intent(in) :: lat_coord
840 : type(horiz_coord_t), pointer, intent(in) :: lon_coord
841 : integer(iMap), pointer, intent(in) :: map(:,:)
842 : logical, optional, intent(in) :: unstruct
843 : logical, optional, intent(in) :: block_indexed
844 : logical, optional, intent(in) :: zonal_grid
845 : integer, optional, intent(in) :: src_in(2)
846 : integer, optional, intent(in) :: dest_in(2)
847 :
848 : ! Local variables
849 : character(len=max_hcoordname_len) :: latdimname, londimname
850 : character(len=120) :: errormsg
851 : integer :: i
852 : integer :: src(2), dest(2)
853 : character(len=*), parameter :: subname = 'CAM_GRID_REGISTER'
854 :
855 : ! For a values grid, we do not allow multiple calls
856 6912 : if (get_cam_grid_index(trim(name)) > 0) then
857 0 : call endrun(trim(subname)//': Grid, '//trim(name)//', already exists')
858 6912 : else if (get_cam_grid_index(id) > 0) then
859 0 : i = get_cam_grid_index(id)
860 0 : write(errormsg, '(4a,i5,3a)') trim(subname), ': Attempt to add grid, ', &
861 0 : trim(name), ' with id = ', id, ', however, grid ', &
862 0 : trim(cam_grids(i)%name), ' already has that ID'
863 0 : call endrun(trim(errormsg))
864 6912 : else if (registeredhgrids >= maxhgrids) then
865 0 : call endrun(trim(subname)//": Too many grids")
866 : else
867 6912 : registeredhgrids = registeredhgrids + 1
868 6912 : cam_grids(registeredhgrids)%name = trim(name)
869 6912 : cam_grids(registeredhgrids)%id = id
870 : ! Quick sanity checks to make sure these aren't mixed up
871 6912 : if (.not. lat_coord%latitude) then
872 0 : call endrun(subname//': lat_coord is not a latitude coordinate')
873 : end if
874 6912 : if (lon_coord%latitude) then
875 0 : call endrun(subname//': lon_coord is not a longitude coordinate')
876 : end if
877 6912 : cam_grids(registeredhgrids)%lat_coord => lat_coord
878 6912 : cam_grids(registeredhgrids)%lon_coord => lon_coord
879 6912 : call lat_coord%get_dim_name(latdimname)
880 6912 : call lon_coord%get_dim_name(londimname)
881 6912 : if (present(unstruct)) then
882 6912 : cam_grids(registeredhgrids)%unstructured = unstruct
883 : else
884 0 : if (trim(latdimname) == trim(londimname)) then
885 0 : cam_grids(registeredhgrids)%unstructured = .true.
886 : else
887 0 : cam_grids(registeredhgrids)%unstructured = .false.
888 : end if
889 : end if
890 6912 : if (present(block_indexed)) then
891 6912 : cam_grids(registeredhgrids)%block_indexed = block_indexed
892 : else
893 0 : cam_grids(registeredhgrids)%block_indexed = cam_grids(registeredhgrids)%unstructured
894 : end if
895 6912 : if (present(zonal_grid)) then
896 : ! Check the size of the longitude coordinate
897 0 : call lon_coord%get_coord_len(i)
898 0 : if (i /= 1) then
899 0 : call endrun(subname//': lon_coord is not of size 1 for a zonal grid')
900 : end if
901 0 : cam_grids(registeredhgrids)%zonal_grid = zonal_grid
902 : else
903 6912 : cam_grids(registeredhgrids)%zonal_grid = .false.
904 : end if
905 6912 : if (associated(cam_grids(registeredhgrids)%map)) then
906 0 : call endrun(trim(subname)//": new grid map should not be associated")
907 : end if
908 6912 : if (present(src_in)) then
909 0 : src = src_in
910 : else
911 6912 : src(1) = 1
912 6912 : src(2) = -1
913 : end if
914 6912 : if (present(dest_in)) then
915 0 : dest = dest_in
916 : else
917 6912 : dest(1) = 1
918 6912 : if (cam_grids(registeredhgrids)%unstructured) then
919 6912 : dest(2) = 0
920 : else
921 0 : dest(2) = 2
922 : end if
923 : end if
924 76032 : allocate(cam_grids(registeredhgrids)%map)
925 : call cam_grids(registeredhgrids)%map%init(map, &
926 6912 : cam_grids(registeredhgrids)%unstructured, src, dest)
927 6912 : call cam_grids(registeredhgrids)%print_cam_grid()
928 : end if
929 :
930 6912 : end subroutine cam_grid_register
931 :
932 6912 : subroutine print_cam_grid(this)
933 : class(cam_grid_t) :: this
934 :
935 : type(cam_grid_attr_ptr_t), pointer :: attrPtr
936 : class(cam_grid_attribute_t), pointer :: attr
937 6912 : if (masterproc) then
938 9 : write(iulog, '(3a,i4,4a,3(a,l2))') 'Grid: ', trim(this%name), &
939 9 : ', ID = ', this%id, &
940 9 : ', lat coord = ', trim(this%lat_coord%name), &
941 9 : ', lon coord = ', trim(this%lon_coord%name), &
942 9 : ', unstruct = ', this%unstructured, &
943 9 : ', block_ind = ', this%block_indexed, &
944 18 : ', zonal_grid = ', this%zonal_grid
945 9 : attrPtr => this%attributes
946 9 : do while (associated(attrPtr))
947 : !!XXgoldyXX: Is this not working in PGI?
948 : ! attr => attrPtr%getAttr()
949 0 : attr => attrPtr%attr
950 0 : call attr%print_attr()
951 : !!XXgoldyXX: Is this not working in PGI?
952 : ! attrPtr => attrPtr%getNext()
953 0 : attrPtr => attrPtr%next
954 : end do
955 : end if
956 6912 : end subroutine print_cam_grid
957 :
958 51456 : integer function cam_grid_num_grids()
959 51456 : cam_grid_num_grids = registeredhgrids
960 51456 : end function cam_grid_num_grids
961 :
962 : ! Return .true. iff id represents a valid CAM grid
963 45312 : logical function cam_grid_check(id)
964 : ! Dummy argument
965 : integer, intent(in) :: id
966 :
967 : cam_grid_check = ((get_cam_grid_index(id) > 0) .and. &
968 45312 : (get_cam_grid_index(id) <= cam_grid_num_grids()))
969 45312 : end function cam_grid_check
970 :
971 2441662032 : integer function cam_grid_id(name)
972 : ! Dummy argument
973 : character(len=*), intent(in) :: name
974 :
975 : ! Local variable
976 : integer :: index
977 :
978 2441662032 : index = get_cam_grid_index(name)
979 2441662032 : if (index > 0) then
980 2441662032 : cam_grid_id = cam_grids(index)%id
981 : else
982 : cam_grid_id = -1
983 : end if
984 :
985 2441662032 : end function cam_grid_id
986 :
987 : ! Return the size of a local array for grid, ID.
988 : ! With no optional argument, return the basic 2D array size
989 : ! nlev represents levels or the total column size (product(mdims))
990 0 : integer function cam_grid_get_local_size(id, nlev)
991 :
992 : ! Dummy arguments
993 : integer, intent(in) :: id
994 : integer, optional, intent(in) :: nlev
995 :
996 : ! Local variables
997 : integer :: gridid
998 : character(len=128) :: errormsg
999 :
1000 0 : gridid = get_cam_grid_index(id)
1001 0 : if (gridid > 0) then
1002 0 : cam_grid_get_local_size = cam_grids(gridid)%num_elem()
1003 0 : if (present(nlev)) then
1004 0 : cam_grid_get_local_size = cam_grid_get_local_size * nlev
1005 : end if
1006 : else
1007 0 : write(errormsg, *) 'cam_grid_get_local_size: Bad grid ID, ', id
1008 0 : call endrun(errormsg)
1009 : end if
1010 :
1011 0 : end function cam_grid_get_local_size
1012 :
1013 : ! Given some array information, find the dimension NetCDF IDs on <File> for this grid
1014 1536 : subroutine cam_grid_get_file_dimids(id, File, dimids)
1015 : use pio, only: file_desc_t
1016 :
1017 : ! Dummy arguments
1018 : integer, intent(in) :: id
1019 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1020 : integer, intent(out) :: dimids(:)
1021 :
1022 : ! Local variables
1023 : integer :: gridid
1024 : character(len=128) :: errormsg
1025 :
1026 1536 : gridid = get_cam_grid_index(id)
1027 1536 : if (gridid > 0) then
1028 1536 : call cam_grids(gridid)%find_dimids(File, dimids)
1029 : else
1030 0 : write(errormsg, *) 'cam_grid_get_file_dimids: Bad grid ID, ', id
1031 0 : call endrun(errormsg)
1032 : end if
1033 :
1034 1536 : end subroutine cam_grid_get_file_dimids
1035 :
1036 : ! Given some array information, find or compute a PIO decomposition
1037 40704 : subroutine cam_grid_get_decomp(id, field_lens, file_lens, dtype, iodesc, &
1038 40704 : field_dnames, file_dnames)
1039 : use pio, only: io_desc_t
1040 :
1041 : ! Dummy arguments
1042 : integer, intent(in) :: id
1043 : integer, intent(in) :: field_lens(:) ! Array dim sizes
1044 : integer, intent(in) :: file_lens(:) ! File dim sizes
1045 : integer, intent(in) :: dtype
1046 : type(io_desc_t), pointer, intent(out) :: iodesc
1047 : character(len=*), optional, intent(in) :: field_dnames(:)
1048 : character(len=*), optional, intent(in) :: file_dnames(:)
1049 :
1050 : ! Local variables
1051 : integer :: gridid
1052 : character(len=128) :: errormsg
1053 :
1054 40704 : gridid = get_cam_grid_index(id)
1055 40704 : if (gridid > 0) then
1056 0 : call cam_grids(gridid)%get_decomp(field_lens, file_lens, dtype, iodesc, &
1057 66816 : field_dnames, file_dnames)
1058 : else
1059 0 : write(errormsg, *) 'cam_grid_get_decomp: Bad grid ID, ', id
1060 0 : call endrun(errormsg)
1061 : end if
1062 :
1063 40704 : end subroutine cam_grid_get_decomp
1064 :
1065 : !---------------------------------------------------------------------------
1066 : !
1067 : ! cam_grid_read_dist_array_2d_int
1068 : !
1069 : ! Interface function for the grid%read_darray_2d_int method
1070 : !
1071 : !---------------------------------------------------------------------------
1072 768 : subroutine cam_grid_read_dist_array_2d_int(File, id, adims, fdims, hbuf, varid)
1073 : use pio, only: file_desc_t
1074 :
1075 : ! Dummy arguments
1076 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1077 : integer, intent(in) :: id
1078 : integer, intent(in) :: adims(:)
1079 : integer, intent(in) :: fdims(:)
1080 : integer, intent(out) :: hbuf(:,:)
1081 : type(var_desc_t), intent(inout) :: varid
1082 :
1083 : ! Local variable
1084 : integer :: gridid
1085 : character(len=120) :: errormsg
1086 :
1087 768 : gridid = get_cam_grid_index(id)
1088 768 : if (gridid > 0) then
1089 768 : call cam_grids(gridid)%read_darray_2d_int(File, adims, fdims, hbuf, varid)
1090 : else
1091 0 : write(errormsg, *) 'cam_grid_read_dist_array_2d_int: Bad grid ID, ', id
1092 0 : call endrun(errormsg)
1093 : end if
1094 :
1095 768 : end subroutine cam_grid_read_dist_array_2d_int
1096 :
1097 : !---------------------------------------------------------------------------
1098 : !
1099 : ! cam_grid_read_dist_array_3d_int
1100 : !
1101 : ! Interface function for the grid%read_darray_2d_ method
1102 : !
1103 : !---------------------------------------------------------------------------
1104 0 : subroutine cam_grid_read_dist_array_3d_int(File, id, adims, fdims, hbuf, varid)
1105 : use pio, only: file_desc_t
1106 :
1107 : ! Dummy arguments
1108 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1109 : integer, intent(in) :: id
1110 : integer, intent(in) :: adims(:)
1111 : integer, intent(in) :: fdims(:)
1112 : integer, intent(out) :: hbuf(:,:,:)
1113 : type(var_desc_t), intent(inout) :: varid
1114 :
1115 : ! Local variable
1116 : integer :: gridid
1117 : character(len=120) :: errormsg
1118 :
1119 0 : gridid = get_cam_grid_index(id)
1120 0 : if (gridid > 0) then
1121 0 : call cam_grids(gridid)%read_darray_3d_int(File, adims, fdims, hbuf, varid)
1122 : else
1123 0 : write(errormsg, *) 'cam_grid_read_dist_array_3d_int: Bad grid ID, ', id
1124 0 : call endrun(errormsg)
1125 : end if
1126 :
1127 0 : end subroutine cam_grid_read_dist_array_3d_int
1128 :
1129 : !---------------------------------------------------------------------------
1130 : !
1131 : ! cam_grid_read_dist_array_2d_double
1132 : !
1133 : ! Interface function for the grid%read_darray_2d_double method
1134 : !
1135 : !---------------------------------------------------------------------------
1136 18432 : subroutine cam_grid_read_dist_array_2d_double(File, id, adims, fdims, hbuf, varid)
1137 : use pio, only: file_desc_t
1138 :
1139 : ! Dummy arguments
1140 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1141 : integer, intent(in) :: id
1142 : integer, intent(in) :: adims(:)
1143 : integer, intent(in) :: fdims(:)
1144 : real(r8), intent(out) :: hbuf(:,:)
1145 : type(var_desc_t), intent(inout) :: varid
1146 :
1147 : ! Local variable
1148 : integer :: gridid
1149 : character(len=120) :: errormsg
1150 :
1151 18432 : gridid = get_cam_grid_index(id)
1152 18432 : if (gridid > 0) then
1153 18432 : call cam_grids(gridid)%read_darray_2d_double(File, adims, fdims, hbuf, varid)
1154 : else
1155 0 : write(errormsg, *) 'cam_grid_read_dist_array_2d_double: Bad grid ID, ', id
1156 0 : call endrun(errormsg)
1157 : end if
1158 :
1159 18432 : end subroutine cam_grid_read_dist_array_2d_double
1160 :
1161 : !---------------------------------------------------------------------------
1162 : !
1163 : ! cam_grid_read_dist_array_3d_double
1164 : !
1165 : ! Interface function for the grid%read_darray_3d_double method
1166 : !
1167 : !---------------------------------------------------------------------------
1168 66816 : subroutine cam_grid_read_dist_array_3d_double(File, id, adims, fdims, hbuf, varid)
1169 : use pio, only: file_desc_t
1170 :
1171 : ! Dummy arguments
1172 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1173 : integer, intent(in) :: id
1174 : integer, intent(in) :: adims(:)
1175 : integer, intent(in) :: fdims(:)
1176 : real(r8), intent(out) :: hbuf(:,:,:)
1177 : type(var_desc_t), intent(inout) :: varid
1178 :
1179 : ! Local variable
1180 : integer :: gridid
1181 : character(len=120) :: errormsg
1182 :
1183 66816 : gridid = get_cam_grid_index(id)
1184 66816 : if (gridid > 0) then
1185 66816 : call cam_grids(gridid)%read_darray_3d_double(File, adims, fdims, hbuf, varid)
1186 : else
1187 0 : write(errormsg, *) 'cam_grid_read_dist_array_3d_double: Bad grid ID, ', id
1188 0 : call endrun(errormsg)
1189 : end if
1190 :
1191 66816 : end subroutine cam_grid_read_dist_array_3d_double
1192 :
1193 : !---------------------------------------------------------------------------
1194 : !
1195 : ! cam_grid_read_dist_array_2d_real
1196 : !
1197 : ! Interface function for the grid%read_darray_2d_real method
1198 : !
1199 : !---------------------------------------------------------------------------
1200 0 : subroutine cam_grid_read_dist_array_2d_real(File, id, adims, fdims, hbuf, varid)
1201 : use pio, only: file_desc_t
1202 :
1203 : ! Dummy arguments
1204 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1205 : integer, intent(in) :: id
1206 : integer, intent(in) :: adims(:)
1207 : integer, intent(in) :: fdims(:)
1208 : real(r4), intent(out) :: hbuf(:,:)
1209 : type(var_desc_t), intent(inout) :: varid
1210 :
1211 : ! Local variable
1212 : integer :: gridid
1213 : character(len=120) :: errormsg
1214 :
1215 0 : gridid = get_cam_grid_index(id)
1216 0 : if (gridid > 0) then
1217 0 : call cam_grids(gridid)%read_darray_2d_real(File, adims, fdims, hbuf, varid)
1218 : else
1219 0 : write(errormsg, *) 'cam_grid_read_dist_array_2d_real: Bad grid ID, ', id
1220 0 : call endrun(errormsg)
1221 : end if
1222 :
1223 0 : end subroutine cam_grid_read_dist_array_2d_real
1224 :
1225 : !---------------------------------------------------------------------------
1226 : !
1227 : ! cam_grid_read_dist_array_3d_real
1228 : !
1229 : ! Interface function for the grid%read_darray_3d_real method
1230 : !
1231 : !---------------------------------------------------------------------------
1232 0 : subroutine cam_grid_read_dist_array_3d_real(File, id, adims, fdims, hbuf, varid)
1233 : use pio, only: file_desc_t
1234 :
1235 : ! Dummy arguments
1236 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1237 : integer, intent(in) :: id
1238 : integer, intent(in) :: adims(:)
1239 : integer, intent(in) :: fdims(:)
1240 : real(r4), intent(out) :: hbuf(:,:,:)
1241 : type(var_desc_t), intent(inout) :: varid
1242 :
1243 : ! Local variable
1244 : integer :: gridid
1245 : character(len=120) :: errormsg
1246 :
1247 0 : gridid = get_cam_grid_index(id)
1248 0 : if (gridid > 0) then
1249 0 : call cam_grids(gridid)%read_darray_3d_real(File, adims, fdims, hbuf, varid)
1250 : else
1251 0 : write(errormsg, *) 'cam_grid_read_dist_array_3d_real: Bad grid ID, ', id
1252 0 : call endrun(errormsg)
1253 : end if
1254 :
1255 0 : end subroutine cam_grid_read_dist_array_3d_real
1256 :
1257 : !---------------------------------------------------------------------------
1258 : !
1259 : ! cam_grid_write_dist_array_2d_int
1260 : !
1261 : ! Interface function for the grid%write_darray_2d_int method
1262 : !
1263 : !---------------------------------------------------------------------------
1264 1536 : subroutine cam_grid_write_dist_array_2d_int(File, id, adims, fdims, hbuf, varid)
1265 : use pio, only: file_desc_t
1266 :
1267 : ! Dummy arguments
1268 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1269 : integer, intent(in) :: id
1270 : integer, intent(in) :: adims(:)
1271 : integer, intent(in) :: fdims(:)
1272 : integer, intent(in) :: hbuf(:,:)
1273 : type(var_desc_t), intent(inout) :: varid
1274 :
1275 : ! Local variable
1276 : integer :: gridid
1277 : character(len=120) :: errormsg
1278 :
1279 1536 : gridid = get_cam_grid_index(id)
1280 1536 : if (gridid > 0) then
1281 1536 : call cam_grids(gridid)%write_darray_2d_int(File, adims, fdims, hbuf, varid)
1282 : else
1283 0 : write(errormsg, *) 'cam_grid_write_dist_array_2d_int: Bad grid ID, ', id
1284 0 : call endrun(errormsg)
1285 : end if
1286 :
1287 1536 : end subroutine cam_grid_write_dist_array_2d_int
1288 :
1289 : !---------------------------------------------------------------------------
1290 : !
1291 : ! cam_grid_write_dist_array_3d_int
1292 : !
1293 : ! Interface function for the grid%write_darray_3d_int method
1294 : !
1295 : !---------------------------------------------------------------------------
1296 0 : subroutine cam_grid_write_dist_array_3d_int(File, id, adims, fdims, hbuf, varid)
1297 : use pio, only: file_desc_t
1298 :
1299 : ! Dummy arguments
1300 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1301 : integer, intent(in) :: id
1302 : integer, intent(in) :: adims(:)
1303 : integer, intent(in) :: fdims(:)
1304 : integer, intent(in) :: hbuf(:,:,:)
1305 : type(var_desc_t), intent(inout) :: varid
1306 :
1307 : ! Local variable
1308 : integer :: gridid
1309 : character(len=120) :: errormsg
1310 :
1311 0 : gridid = get_cam_grid_index(id)
1312 0 : if (gridid > 0) then
1313 0 : call cam_grids(gridid)%write_darray_3d_int(File, adims, fdims, hbuf, varid)
1314 : else
1315 0 : write(errormsg, *) 'cam_grid_write_dist_array_3d_int: Bad grid ID, ', id
1316 0 : call endrun(errormsg)
1317 : end if
1318 :
1319 0 : end subroutine cam_grid_write_dist_array_3d_int
1320 :
1321 : !---------------------------------------------------------------------------
1322 : !
1323 : ! cam_grid_write_dist_array_2d_double
1324 : !
1325 : ! Interface function for the grid%write_darray_2d_double method
1326 : !
1327 : !---------------------------------------------------------------------------
1328 36864 : subroutine cam_grid_write_dist_array_2d_double(File, id, adims, fdims, hbuf, varid)
1329 : use pio, only: file_desc_t
1330 :
1331 : ! Dummy arguments
1332 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1333 : integer, intent(in) :: id
1334 : integer, intent(in) :: adims(:)
1335 : integer, intent(in) :: fdims(:)
1336 : real(r8), intent(in) :: hbuf(:,:)
1337 : type(var_desc_t), intent(inout) :: varid
1338 :
1339 : ! Local variable
1340 : integer :: gridid
1341 : character(len=120) :: errormsg
1342 :
1343 36864 : gridid = get_cam_grid_index(id)
1344 36864 : if (gridid > 0) then
1345 36864 : call cam_grids(gridid)%write_darray_2d_double(File, adims, fdims, hbuf, varid)
1346 : else
1347 0 : write(errormsg, *) 'cam_grid_write_dist_array_2d_double: Bad grid ID, ', id
1348 0 : call endrun(errormsg)
1349 : end if
1350 :
1351 36864 : end subroutine cam_grid_write_dist_array_2d_double
1352 :
1353 : !---------------------------------------------------------------------------
1354 : !
1355 : ! cam_grid_write_dist_array_3d_double
1356 : !
1357 : ! Interface function for the grid%write_darray_3d_double method
1358 : !
1359 : !---------------------------------------------------------------------------
1360 133632 : subroutine cam_grid_write_dist_array_3d_double(File, id, adims, fdims, hbuf, varid)
1361 : use pio, only: file_desc_t
1362 :
1363 : ! Dummy arguments
1364 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1365 : integer, intent(in) :: id
1366 : integer, intent(in) :: adims(:)
1367 : integer, intent(in) :: fdims(:)
1368 : real(r8), intent(in) :: hbuf(:,:,:)
1369 : type(var_desc_t), intent(inout) :: varid
1370 :
1371 : ! Local variable
1372 : integer :: gridid
1373 : character(len=120) :: errormsg
1374 :
1375 133632 : gridid = get_cam_grid_index(id)
1376 133632 : if (gridid > 0) then
1377 133632 : call cam_grids(gridid)%write_darray_3d_double(File, adims, fdims, hbuf, varid)
1378 : else
1379 0 : write(errormsg, *) 'cam_grid_write_dist_array_3d_double: Bad grid ID, ', id
1380 0 : call endrun(errormsg)
1381 : end if
1382 :
1383 133632 : end subroutine cam_grid_write_dist_array_3d_double
1384 :
1385 : !---------------------------------------------------------------------------
1386 : !
1387 : ! cam_grid_write_dist_array_2d_real
1388 : !
1389 : ! Interface function for the grid%write_darray_2d_real method
1390 : !
1391 : !---------------------------------------------------------------------------
1392 7127040 : subroutine cam_grid_write_dist_array_2d_real(File, id, adims, fdims, hbuf, varid)
1393 : use pio, only: file_desc_t
1394 :
1395 : ! Dummy arguments
1396 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1397 : integer, intent(in) :: id
1398 : integer, intent(in) :: adims(:)
1399 : integer, intent(in) :: fdims(:)
1400 : real(r4), intent(in) :: hbuf(:,:)
1401 : type(var_desc_t), intent(inout) :: varid
1402 :
1403 : ! Local variable
1404 : integer :: gridid
1405 : character(len=120) :: errormsg
1406 :
1407 7127040 : gridid = get_cam_grid_index(id)
1408 7127040 : if (gridid > 0) then
1409 7127040 : call cam_grids(gridid)%write_darray_2d_real(File, adims, fdims, hbuf, varid)
1410 : else
1411 0 : write(errormsg, *) 'cam_grid_write_dist_array_2d_real: Bad grid ID, ', id
1412 0 : call endrun(errormsg)
1413 : end if
1414 :
1415 7127040 : end subroutine cam_grid_write_dist_array_2d_real
1416 :
1417 : !---------------------------------------------------------------------------
1418 : !
1419 : ! cam_grid_write_dist_array_3d_real
1420 : !
1421 : ! Interface function for the grid%write_darray_3d_real method
1422 : !
1423 : !---------------------------------------------------------------------------
1424 10813440 : subroutine cam_grid_write_dist_array_3d_real(File, id, adims, fdims, hbuf, varid)
1425 : use pio, only: file_desc_t
1426 :
1427 : ! Dummy arguments
1428 : type(file_desc_t), intent(inout) :: File ! PIO file handle
1429 : integer, intent(in) :: id
1430 : integer, intent(in) :: adims(:)
1431 : integer, intent(in) :: fdims(:)
1432 : real(r4), intent(in) :: hbuf(:,:,:)
1433 : type(var_desc_t), intent(inout) :: varid
1434 :
1435 : ! Local variable
1436 : integer :: gridid
1437 : character(len=120) :: errormsg
1438 :
1439 10813440 : gridid = get_cam_grid_index(id)
1440 10813440 : if (gridid > 0) then
1441 10813440 : call cam_grids(gridid)%write_darray_3d_real(File, adims, fdims, hbuf, varid)
1442 : else
1443 0 : write(errormsg, *) 'cam_grid_write_dist_array_3d_real: Bad grid ID, ', id
1444 0 : call endrun(errormsg)
1445 : end if
1446 :
1447 10813440 : end subroutine cam_grid_write_dist_array_3d_real
1448 :
1449 2304 : subroutine cam_grid_get_gcid(id, gcid)
1450 :
1451 : ! Dummy arguments
1452 : integer, intent(in) :: id
1453 : integer(iMap), pointer :: gcid(:)
1454 :
1455 : ! Local variables
1456 : integer :: gridid
1457 : integer :: fieldbounds(2,2)
1458 : integer :: fieldlens(2)
1459 : integer :: filelens(2)
1460 : type(cam_filemap_t), pointer :: map
1461 :
1462 2304 : gridid = get_cam_grid_index(id)
1463 2304 : if (gridid > 0) then
1464 2304 : map => cam_grids(gridid)%map
1465 2304 : call cam_grids(gridid)%coord_lengths(filelens)
1466 2304 : call map%array_bounds(fieldbounds)
1467 6912 : fieldlens(:) = fieldbounds(:,2) - fieldbounds(:,1) + 1
1468 2304 : call map%get_filemap(fieldlens, filelens, gcid)
1469 : else
1470 0 : call endrun('cam_grid_get_gcid: Bad grid ID')
1471 : end if
1472 2304 : end subroutine cam_grid_get_gcid
1473 :
1474 2184960 : subroutine cam_grid_get_array_bounds(id, dims)
1475 :
1476 : ! Dummy arguments
1477 : integer, intent(in) :: id
1478 : integer, intent(inout) :: dims(:,:)
1479 :
1480 : ! Local variables
1481 : integer :: gridid
1482 2184960 : gridid = get_cam_grid_index(id)
1483 2184960 : if (gridid > 0) then
1484 2184960 : if (.not. associated(cam_grids(gridid)%map)) then
1485 0 : call endrun('cam_grid_get_array_bounds: Grid, '//trim(cam_grids(gridid)%name)//', has no map')
1486 : else
1487 2184960 : call cam_grids(gridid)%map%array_bounds(dims)
1488 : end if
1489 : else
1490 0 : call endrun('cam_grid_get_array_bounds: Bad grid ID')
1491 : end if
1492 :
1493 2184960 : end subroutine cam_grid_get_array_bounds
1494 :
1495 : !---------------------------------------------------------------------------
1496 : !
1497 : ! cam_grid_get_coord_names: Return the names of the grid axes
1498 : !
1499 : !---------------------------------------------------------------------------
1500 0 : subroutine cam_grid_get_coord_names(id, lon_name, lat_name)
1501 :
1502 : ! Dummy arguments
1503 : integer, intent(in) :: id
1504 : character(len=*), intent(out) :: lon_name
1505 : character(len=*), intent(out) :: lat_name
1506 :
1507 : ! Local variables
1508 : integer :: gridid
1509 0 : gridid = get_cam_grid_index(id)
1510 0 : if (gridid > 0) then
1511 0 : call cam_grids(gridid)%coord_names(lon_name, lat_name)
1512 : else
1513 0 : call endrun('cam_grid_get_coord_names: Bad grid ID')
1514 : end if
1515 :
1516 0 : end subroutine cam_grid_get_coord_names
1517 :
1518 : !---------------------------------------------------------------------------
1519 : !
1520 : ! cam_grid_get_dim_names: Return the names of the grid axes dimensions.
1521 : ! Note that these may be the same
1522 : !
1523 : !---------------------------------------------------------------------------
1524 2304 : subroutine cam_grid_get_dim_names_id(id, name1, name2)
1525 :
1526 : ! Dummy arguments
1527 : integer, intent(in) :: id
1528 : character(len=*), intent(out) :: name1
1529 : character(len=*), intent(out) :: name2
1530 :
1531 : ! Local variables
1532 : integer :: gridid
1533 2304 : gridid = get_cam_grid_index(id)
1534 2304 : if (gridid > 0) then
1535 2304 : call cam_grids(gridid)%dim_names(name1, name2)
1536 : else
1537 0 : call endrun('cam_grid_get_dim_names_id: Bad grid ID')
1538 : end if
1539 :
1540 2304 : end subroutine cam_grid_get_dim_names_id
1541 :
1542 0 : subroutine cam_grid_get_dim_names_name(gridname, name1, name2)
1543 :
1544 : ! Dummy arguments
1545 : character(len=*), intent(in) :: gridname
1546 : character(len=*), intent(out) :: name1
1547 : character(len=*), intent(out) :: name2
1548 :
1549 : ! Local variables
1550 : integer :: gridind
1551 : character(len=120) :: errormsg
1552 :
1553 0 : gridind = get_cam_grid_index(trim(gridname))
1554 0 : if (gridind < 0) then
1555 0 : write(errormsg, *) 'No CAM grid with name = ', trim(gridname)
1556 0 : call endrun('cam_grid_get_dim_names_name: '//errormsg)
1557 : else
1558 0 : call cam_grids(gridind)%dim_names(name1, name2)
1559 : end if
1560 :
1561 0 : end subroutine cam_grid_get_dim_names_name
1562 :
1563 0 : logical function cam_grid_has_blocksize(id)
1564 :
1565 : ! Dummy arguments
1566 : integer, intent(in) :: id
1567 :
1568 : ! Local variables
1569 : integer :: gridid
1570 0 : gridid = get_cam_grid_index(id)
1571 0 : if (gridid > 0) then
1572 0 : if (.not. associated(cam_grids(gridid)%map)) then
1573 0 : call endrun('cam_grid_has_blocksize: Grid, '//trim(cam_grids(gridid)%name)//', has no map')
1574 : else
1575 0 : cam_grid_has_blocksize = cam_grids(gridid)%map%has_blocksize()
1576 : end if
1577 : else
1578 0 : call endrun('cam_grid_has_blocksize: Bad grid ID')
1579 : end if
1580 0 : end function cam_grid_has_blocksize
1581 :
1582 : ! Return the number of active columns in the block specified by block_id
1583 585236880 : integer function cam_grid_get_block_count(id, block_id) result(ncol)
1584 :
1585 : ! Dummy arguments
1586 : integer, intent(in) :: id
1587 : integer, intent(in) :: block_id
1588 :
1589 : ! Local variables
1590 : integer :: gridid
1591 585236880 : gridid = get_cam_grid_index(id)
1592 585236880 : if (gridid > 0) then
1593 585236880 : if (.not. associated(cam_grids(gridid)%map)) then
1594 0 : call endrun('cam_grid_get_block_count: Grid, '//trim(cam_grids(gridid)%name)//', has no map')
1595 : else
1596 585236880 : ncol = cam_grids(gridid)%map%blocksize(block_id)
1597 : end if
1598 : else
1599 0 : call endrun('cam_grid_get_block_count: Bad grid ID')
1600 : end if
1601 585236880 : end function cam_grid_get_block_count
1602 :
1603 768 : function cam_grid_get_latvals(id) result(latvals)
1604 :
1605 : ! Dummy argument
1606 : integer, intent(in) :: id
1607 : real(r8), pointer :: latvals(:)
1608 :
1609 : ! Local variables
1610 : integer :: gridid
1611 768 : gridid = get_cam_grid_index(id)
1612 768 : if (gridid > 0) then
1613 768 : if (.not. associated(cam_grids(gridid)%lat_coord%values)) then
1614 0 : nullify(latvals)
1615 : else
1616 768 : latvals => cam_grids(gridid)%lat_coord%values
1617 : end if
1618 : else
1619 0 : call endrun('cam_grid_get_latvals: Bad grid ID')
1620 : end if
1621 768 : end function cam_grid_get_latvals
1622 :
1623 768 : function cam_grid_get_lonvals(id) result(lonvals)
1624 :
1625 : ! Dummy arguments
1626 : integer, intent(in) :: id
1627 : real(r8), pointer :: lonvals(:)
1628 :
1629 : ! Local variables
1630 : integer :: gridid
1631 768 : gridid = get_cam_grid_index(id)
1632 768 : if (gridid > 0) then
1633 768 : if (.not. associated(cam_grids(gridid)%lon_coord%values)) then
1634 0 : nullify(lonvals)
1635 : else
1636 768 : lonvals => cam_grids(gridid)%lon_coord%values
1637 : end if
1638 : else
1639 0 : call endrun('cam_grid_get_lonvals: Bad grid ID')
1640 : end if
1641 768 : end function cam_grid_get_lonvals
1642 :
1643 0 : function cam_grid_get_areawt(id) result(wtvals)
1644 :
1645 : ! Dummy argument
1646 : integer, intent(in) :: id
1647 : real(r8), pointer :: wtvals(:)
1648 :
1649 : ! Local variables
1650 : character(len=max_chars) :: wtname
1651 : integer :: gridind
1652 : class(cam_grid_attribute_t), pointer :: attrptr
1653 : character(len=120) :: errormsg
1654 :
1655 0 : nullify(attrptr)
1656 0 : gridind = get_cam_grid_index(id)
1657 0 : if (gridind > 0) then
1658 0 : select case(trim(cam_grids(gridind)%name))
1659 : case('GLL')
1660 0 : wtname='area_weight_gll'
1661 : case('EUL')
1662 0 : wtname='gw'
1663 : case('FV')
1664 0 : wtname='gw'
1665 : case('INI')
1666 0 : wtname='area_weight_ini'
1667 : case('physgrid')
1668 0 : wtname='areawt'
1669 : case('FVM')
1670 0 : wtname='area_weight_fvm'
1671 : case('mpas_cell')
1672 0 : wtname='area_weight_mpas'
1673 : case default
1674 0 : call endrun('cam_grid_get_areawt: Invalid gridname:'//trim(cam_grids(gridind)%name))
1675 : end select
1676 :
1677 0 : call find_cam_grid_attr(gridind, trim(wtname), attrptr)
1678 0 : if (.not.associated(attrptr)) then
1679 : write(errormsg, '(4a)') &
1680 0 : 'cam_grid_get_areawt: error retrieving weight attribute ', trim(wtname), &
1681 0 : ' for cam grid ', cam_grids(gridind)%name
1682 0 : call endrun(errormsg)
1683 : else
1684 0 : call attrptr%print_attr()
1685 : select type(attrptr)
1686 : type is (cam_grid_attribute_1d_r8_t)
1687 0 : wtvals => attrptr%values
1688 : class default
1689 0 : call endrun('cam_grid_get_areawt: wt attribute is not a real datatype')
1690 : end select
1691 : end if
1692 : end if
1693 :
1694 0 : end function cam_grid_get_areawt
1695 :
1696 : ! Find the longitude and latitude of a range of map entries
1697 : ! beg and end are the range of the first source index. blk is a block or chunk index
1698 0 : subroutine cam_grid_get_coords(id, beg, end, blk, lon, lat)
1699 :
1700 : ! Dummy arguments
1701 : integer, intent(in) :: id
1702 : integer, intent(in) :: beg
1703 : integer, intent(in) :: end
1704 : integer, intent(in) :: blk
1705 : real(r8), intent(inout) :: lon(:)
1706 : real(r8), intent(inout) :: lat(:)
1707 :
1708 : ! Local variables
1709 : integer :: gridid
1710 : integer :: i
1711 0 : gridid = get_cam_grid_index(id)
1712 0 : if (gridid > 0) then
1713 0 : do i = beg, end
1714 0 : if (cam_grids(gridid)%is_unstructured()) then
1715 0 : call endrun('cam_grid_get_coords: Not implemented')
1716 : else
1717 0 : call endrun('cam_grid_get_coords: Not implemented')
1718 : end if
1719 : end do
1720 : else
1721 0 : call endrun('cam_grid_get_coords: Bad grid ID')
1722 : end if
1723 0 : end subroutine cam_grid_get_coords
1724 :
1725 0 : logical function cam_grid_is_unstructured(id) result(unstruct)
1726 :
1727 : ! Dummy arguments
1728 : integer, intent(in) :: id
1729 :
1730 : ! Local variables
1731 : integer :: gridid
1732 0 : gridid = get_cam_grid_index(id)
1733 0 : if (gridid > 0) then
1734 0 : unstruct = cam_grids(gridid)%is_unstructured()
1735 : else
1736 0 : call endrun('cam_grid_is_unstructured: Bad grid ID')
1737 : end if
1738 0 : end function cam_grid_is_unstructured
1739 :
1740 2184960 : logical function cam_grid_is_block_indexed(id) result(block_indexed)
1741 :
1742 : ! Dummy arguments
1743 : integer, intent(in) :: id
1744 :
1745 : ! Local variables
1746 : integer :: gridid
1747 2184960 : gridid = get_cam_grid_index(id)
1748 2184960 : if (gridid > 0) then
1749 2184960 : block_indexed = cam_grids(gridid)%is_block_indexed()
1750 : else
1751 0 : call endrun('s: Bad grid ID')
1752 : end if
1753 2184960 : end function cam_grid_is_block_indexed
1754 :
1755 2184960 : logical function cam_grid_is_zonal(id) result(zonal)
1756 :
1757 : ! Dummy arguments
1758 : integer, intent(in) :: id
1759 :
1760 : ! Local variables
1761 : integer :: gridid
1762 2184960 : gridid = get_cam_grid_index(id)
1763 2184960 : if (gridid > 0) then
1764 2184960 : zonal = cam_grids(gridid)%is_zonal_grid()
1765 : else
1766 0 : call endrun('s: Bad grid ID')
1767 : end if
1768 2184960 : end function cam_grid_is_zonal
1769 :
1770 : ! Compute or update a grid patch mask
1771 0 : subroutine cam_grid_compute_patch(id, patch, lonl, lonu, latl, latu, cco)
1772 :
1773 : ! Dummy arguments
1774 : integer, intent(in) :: id
1775 : type(cam_grid_patch_t), intent(inout) :: patch
1776 : real(r8), intent(in) :: lonl
1777 : real(r8), intent(in) :: lonu
1778 : real(r8), intent(in) :: latl
1779 : real(r8), intent(in) :: latu
1780 : logical, intent(in) :: cco ! Collect columns?
1781 :
1782 : ! Local variables
1783 : integer :: gridid
1784 :
1785 0 : gridid = get_cam_grid_index(id)
1786 0 : if (gridid > 0) then
1787 0 : call cam_grids(gridid)%get_patch_mask(lonl, lonu, latl, latu, patch, cco)
1788 : else
1789 0 : call endrun('cam_grid_compute_patch: Bad grid ID')
1790 : end if
1791 :
1792 0 : end subroutine cam_grid_compute_patch
1793 :
1794 : !!#######################################################################
1795 : !!
1796 : !! CAM grid attribute functions
1797 : !!
1798 : !!#######################################################################
1799 :
1800 0 : subroutine cam_grid_attr_init(this, name, long_name, next)
1801 : ! Dummy arguments
1802 : class(cam_grid_attribute_t) :: this
1803 : character(len=*), intent(in) :: name
1804 : character(len=*), intent(in) :: long_name
1805 : class(cam_grid_attribute_t), pointer :: next
1806 :
1807 0 : this%name = trim(name)
1808 0 : this%long_name = trim(long_name)
1809 0 : this%next => next
1810 0 : end subroutine cam_grid_attr_init
1811 :
1812 26112 : subroutine print_attr_base(this)
1813 : ! Dummy arguments
1814 : class(cam_grid_attribute_t), intent(in) :: this
1815 26112 : if (masterproc) then
1816 34 : write(iulog, '(5a)') 'Attribute: ', trim(this%name), ", long name = '", &
1817 68 : trim(this%long_name), "'"
1818 : end if
1819 26112 : end subroutine print_attr_base
1820 :
1821 9216 : subroutine cam_grid_attr_init_0d_int(this, name, long_name, val)
1822 : ! Dummy arguments
1823 : class(cam_grid_attribute_0d_int_t) :: this
1824 : character(len=*), intent(in) :: name
1825 : character(len=*), intent(in) :: long_name
1826 : integer, intent(in) :: val
1827 :
1828 : ! call this%cam_grid_attr_init(name, '')
1829 9216 : this%name = trim(name)
1830 9216 : this%long_name = trim(long_name)
1831 9216 : this%ival = val
1832 9216 : end subroutine cam_grid_attr_init_0d_int
1833 :
1834 12288 : subroutine print_attr_0d_int(this)
1835 : ! Dummy arguments
1836 : class(cam_grid_attribute_0d_int_t), intent(in) :: this
1837 :
1838 12288 : call this%print_attr_base()
1839 12288 : if (masterproc) then
1840 16 : write(iulog, *) ' value = ', this%ival
1841 : end if
1842 12288 : end subroutine print_attr_0d_int
1843 :
1844 0 : subroutine cam_grid_attr_init_0d_char(this, name, long_name, val)
1845 : ! Dummy arguments
1846 : class(cam_grid_attribute_0d_char_t) :: this
1847 : character(len=*), intent(in) :: name
1848 : character(len=*), intent(in) :: long_name
1849 : character(len=*), intent(in) :: val
1850 :
1851 : ! call this%cam_grid_attr_init(name, '')
1852 0 : this%name = trim(name)
1853 0 : this%long_name = trim(long_name)
1854 0 : this%val = trim(val)
1855 0 : end subroutine cam_grid_attr_init_0d_char
1856 :
1857 0 : subroutine print_attr_0d_char(this)
1858 : ! Dummy arguments
1859 : class(cam_grid_attribute_0d_char_t), intent(in) :: this
1860 :
1861 0 : call this%print_attr_base()
1862 0 : if (masterproc) then
1863 0 : write(iulog, *) ' value = ', trim(this%val)
1864 : end if
1865 0 : end subroutine print_attr_0d_char
1866 :
1867 0 : subroutine cam_grid_attr_init_1d_int(this, name, long_name, dimname, &
1868 0 : dimsize, values, map)
1869 : ! Dummy arguments
1870 : class(cam_grid_attribute_1d_int_t) :: this
1871 : character(len=*), intent(in) :: name
1872 : character(len=*), intent(in) :: long_name
1873 : character(len=*), intent(in) :: dimname
1874 : integer, intent(in) :: dimsize
1875 : integer, target, intent(in) :: values(:)
1876 : integer(iMap), optional, target, intent(in) :: map(:)
1877 :
1878 : ! call this%cam_grid_attr_init(trim(name), trim(long_name))
1879 0 : if (len_trim(name) > max_hcoordname_len) then
1880 0 : call endrun('cam_grid_attr_1d_int: name too long')
1881 : end if
1882 0 : this%name = trim(name)
1883 0 : if (len_trim(long_name) > max_chars) then
1884 0 : call endrun('cam_grid_attr_1d_int: long_name too long')
1885 : end if
1886 0 : this%long_name = trim(long_name)
1887 :
1888 0 : if (len_trim(dimname) > max_hcoordname_len) then
1889 0 : call endrun('cam_grid_attr_1d_int: dimname too long')
1890 : end if
1891 0 : this%dimname = trim(dimname)
1892 0 : this%dimsize = dimsize
1893 0 : this%values => values
1894 : ! Fill in the optional map
1895 0 : if (present(map)) then
1896 0 : allocate(this%map(size(map)))
1897 0 : this%map(:) = map(:)
1898 : else
1899 0 : nullify(this%map)
1900 : end if
1901 0 : end subroutine cam_grid_attr_init_1d_int
1902 :
1903 13824 : subroutine cam_grid_attr_init_1d_r8(this, name, long_name, dimname, &
1904 13824 : dimsize, values, map)
1905 : ! Dummy arguments
1906 : class(cam_grid_attribute_1d_r8_t) :: this
1907 : character(len=*), intent(in) :: name
1908 : character(len=*), intent(in) :: long_name
1909 : character(len=*), intent(in) :: dimname
1910 : integer, intent(in) :: dimsize
1911 : real(r8), target, intent(in) :: values(:)
1912 : integer(iMap), optional, target, intent(in) :: map(:)
1913 :
1914 : ! call this%cam_grid_attr_init(trim(name), trim(long_name), next)
1915 13824 : this%name = trim(name)
1916 13824 : this%long_name = trim(long_name)
1917 :
1918 13824 : this%dimname = trim(dimname)
1919 13824 : this%dimsize = dimsize
1920 13824 : this%values => values
1921 : ! Fill in the optional map
1922 13824 : if (present(map)) then
1923 41472 : allocate(this%map(size(map)))
1924 1119168 : this%map(:) = map(:)
1925 : else
1926 0 : nullify(this%map)
1927 : end if
1928 13824 : end subroutine cam_grid_attr_init_1d_r8
1929 :
1930 0 : subroutine print_attr_1d_int(this)
1931 : ! Dummy arguments
1932 : class(cam_grid_attribute_1d_int_t), intent(in) :: this
1933 0 : call this%print_attr_base()
1934 0 : if (masterproc) then
1935 0 : write(iulog, *) ' dimname = ', trim(this%dimname)
1936 : end if
1937 0 : end subroutine print_attr_1d_int
1938 :
1939 13824 : subroutine print_attr_1d_r8(this)
1940 : ! Dummy arguments
1941 : class(cam_grid_attribute_1d_r8_t), intent(in) :: this
1942 13824 : call this%print_attr_base()
1943 13824 : if (masterproc) then
1944 18 : write(iulog, *) ' dimname = ', trim(this%dimname)
1945 : end if
1946 13824 : end subroutine print_attr_1d_r8
1947 :
1948 26112 : subroutine insert_grid_attribute(gridind, attr)
1949 : integer, intent(in) :: gridind
1950 : class(cam_grid_attribute_t), pointer :: attr
1951 :
1952 : ! Push a new attribute onto the grid
1953 : type(cam_grid_attr_ptr_t), pointer :: attrPtr
1954 :
1955 26112 : allocate(attrPtr)
1956 26112 : call attrPtr%initialize(attr)
1957 26112 : call attrPtr%setNext(cam_grids(gridind)%attributes)
1958 26112 : cam_grids(gridind)%attributes => attrPtr
1959 26112 : call attrPtr%attr%print_attr()
1960 26112 : end subroutine insert_grid_attribute
1961 :
1962 9216 : subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val)
1963 : ! Dummy arguments
1964 : character(len=*), intent(in) :: gridname
1965 : character(len=*), intent(in) :: name
1966 : character(len=*), intent(in) :: long_name
1967 : integer, intent(in) :: val
1968 :
1969 : ! Local variables
1970 : type(cam_grid_attribute_0d_int_t), pointer :: attr
1971 : class(cam_grid_attribute_t), pointer :: attptr
1972 : character(len=120) :: errormsg
1973 : integer :: gridind
1974 :
1975 9216 : gridind = get_cam_grid_index(trim(gridname))
1976 9216 : if (gridind > 0) then
1977 9216 : call find_cam_grid_attr(gridind, trim(name), attptr)
1978 9216 : if (associated(attptr)) then
1979 : ! Attribute found, can't add it again!
1980 : write(errormsg, '(4a)') &
1981 0 : 'add_cam_grid_attribute_0d_int: attribute ', trim(name), &
1982 0 : ' already exists for ', cam_grids(gridind)%name
1983 0 : call endrun(errormsg)
1984 : else
1985 : ! Need a new attribute.
1986 27648 : allocate(attr)
1987 9216 : call attr%cam_grid_attr_init_0d_int(trim(name), trim(long_name), val)
1988 9216 : attptr => attr
1989 9216 : call insert_grid_attribute(gridind, attptr)
1990 : end if
1991 : else
1992 0 : write(errormsg, '(3a)') 'add_cam_grid_attribute_0d_int: grid ', &
1993 0 : trim(gridname), ' was not found'
1994 0 : call endrun(errormsg)
1995 : end if
1996 : ! call cam_grids(gridind)%print_cam_grid()
1997 9216 : end subroutine add_cam_grid_attribute_0d_int
1998 :
1999 0 : subroutine add_cam_grid_attribute_0d_char(gridname, name, val)
2000 : ! Dummy arguments
2001 : character(len=*), intent(in) :: gridname
2002 : character(len=*), intent(in) :: name
2003 : character(len=*), intent(in) :: val
2004 :
2005 : ! Local variables
2006 : type(cam_grid_attribute_0d_char_t), pointer :: attr
2007 : class(cam_grid_attribute_t), pointer :: attptr
2008 : character(len=120) :: errormsg
2009 : integer :: gridind
2010 :
2011 0 : gridind = get_cam_grid_index(trim(gridname))
2012 0 : if (gridind > 0) then
2013 0 : call find_cam_grid_attr(gridind, trim(name), attptr)
2014 0 : if (associated(attptr)) then
2015 : ! Attribute found, can't add it again!
2016 : write(errormsg, '(4a)') &
2017 0 : 'add_cam_grid_attribute_0d_char: attribute ', trim(name), &
2018 0 : ' already exists for ', cam_grids(gridind)%name
2019 0 : call endrun(errormsg)
2020 : else
2021 : ! Need a new attribute.
2022 0 : allocate(attr)
2023 0 : call attr%cam_grid_attr_init_0d_char(trim(name), '', val)
2024 0 : attptr => attr
2025 0 : call insert_grid_attribute(gridind, attptr)
2026 : end if
2027 : else
2028 0 : write(errormsg, '(3a)') 'add_cam_grid_attribute_0d_char: grid ', &
2029 0 : trim(gridname), ' was not found'
2030 0 : call endrun(errormsg)
2031 : end if
2032 : ! call cam_grids(gridind)%print_cam_grid()
2033 0 : end subroutine add_cam_grid_attribute_0d_char
2034 :
2035 0 : subroutine add_cam_grid_attribute_1d_int(gridname, name, long_name, &
2036 0 : dimname, values, map)
2037 : ! Dummy arguments
2038 : character(len=*), intent(in) :: gridname
2039 : character(len=*), intent(in) :: name
2040 : character(len=*), intent(in) :: long_name
2041 : character(len=*), intent(in) :: dimname
2042 : integer, intent(in), target :: values(:)
2043 : integer(iMap), intent(in), target, optional :: map(:)
2044 :
2045 : ! Local variables
2046 : type(cam_grid_attribute_1d_int_t), pointer :: attr
2047 : class(cam_grid_attribute_t), pointer :: attptr
2048 : character(len=120) :: errormsg
2049 : integer :: gridind
2050 : integer :: dimsize
2051 :
2052 0 : nullify(attr)
2053 0 : nullify(attptr)
2054 0 : gridind = get_cam_grid_index(trim(gridname))
2055 0 : if (gridind > 0) then
2056 0 : call find_cam_grid_attr(gridind, trim(name), attptr)
2057 0 : if (associated(attptr)) then
2058 : ! Attribute found, can't add it again!
2059 : write(errormsg, '(4a)') &
2060 0 : 'add_cam_grid_attribute_1d_int: attribute ', trim(name), &
2061 0 : ' already exists for ', cam_grids(gridind)%name
2062 0 : call endrun(errormsg)
2063 : else
2064 : ! Need a new attribute.
2065 0 : dimsize = cam_grids(gridind)%lat_coord%global_size(trim(dimname))
2066 0 : if (dimsize < 1) then
2067 0 : dimsize = cam_grids(gridind)%lon_coord%global_size(trim(dimname))
2068 : end if
2069 0 : if (dimsize < 1) then
2070 0 : write(errormsg, *) 'add_cam_grid_attribute_1d_int: attribute ', &
2071 0 : 'dimension ', trim(dimname), ' for ', trim(name), ', not found'
2072 0 : call endrun(errormsg)
2073 : end if
2074 0 : allocate(attr)
2075 : call attr%cam_grid_attr_init_1d_int(trim(name), trim(long_name), &
2076 0 : trim(dimname), dimsize, values, map)
2077 0 : attptr => attr
2078 0 : call insert_grid_attribute(gridind, attptr)
2079 : end if
2080 : else
2081 0 : write(errormsg, '(3a)') 'add_cam_grid_attribute_1d_int: grid ', &
2082 0 : trim(gridname), ' was not found'
2083 0 : call endrun(errormsg)
2084 : end if
2085 : ! call cam_grids(gridind)%print_cam_grid()
2086 0 : end subroutine add_cam_grid_attribute_1d_int
2087 :
2088 13824 : subroutine add_cam_grid_attribute_1d_r8(gridname, name, long_name, &
2089 13824 : dimname, values, map)
2090 : ! Dummy arguments
2091 : character(len=*), intent(in) :: gridname
2092 : character(len=*), intent(in) :: name
2093 : character(len=*), intent(in) :: long_name
2094 : character(len=*), intent(in) :: dimname
2095 : real(r8), intent(in), target :: values(:)
2096 : integer(iMap), intent(in), target, optional :: map(:)
2097 :
2098 : ! Local variables
2099 : type(cam_grid_attribute_1d_r8_t), pointer :: attr
2100 : class(cam_grid_attribute_t), pointer :: attptr
2101 : character(len=120) :: errormsg
2102 : integer :: gridind
2103 : integer :: dimsize
2104 :
2105 13824 : gridind = get_cam_grid_index(trim(gridname))
2106 13824 : if (gridind > 0) then
2107 13824 : call find_cam_grid_attr(gridind, trim(name), attptr)
2108 13824 : if (associated(attptr)) then
2109 : ! Attribute found, can't add it again!
2110 : write(errormsg, '(4a)') &
2111 0 : 'add_cam_grid_attribute_1d_r8: attribute ', trim(name), &
2112 0 : ' already exists for ', cam_grids(gridind)%name
2113 0 : call endrun(errormsg)
2114 : else
2115 : ! Need a new attribute.
2116 13824 : dimsize = cam_grids(gridind)%lat_coord%global_size(trim(dimname))
2117 13824 : if (dimsize < 1) then
2118 0 : dimsize = cam_grids(gridind)%lon_coord%global_size(trim(dimname))
2119 : end if
2120 13824 : if (dimsize < 1) then
2121 0 : write(errormsg, *) 'add_cam_grid_attribute_1d_r8: attribute ', &
2122 0 : 'dimension ', trim(dimname), ' for ', trim(name), ', not found'
2123 0 : call endrun(errormsg)
2124 : end if
2125 41472 : allocate(attr)
2126 : call attr%cam_grid_attr_init_1d_r8(trim(name), trim(long_name), &
2127 13824 : trim(dimname), dimsize, values, map)
2128 13824 : attptr => attr
2129 13824 : call insert_grid_attribute(gridind, attptr)
2130 : end if
2131 : else
2132 0 : write(errormsg, '(3a)') 'add_cam_grid_attribute_1d_r8: grid ', &
2133 0 : trim(gridname), ' was not found'
2134 0 : call endrun(errormsg)
2135 : end if
2136 : ! call cam_grids(gridind)%print_cam_grid()
2137 13824 : end subroutine add_cam_grid_attribute_1d_r8
2138 :
2139 : !!#######################################################################
2140 : !!
2141 : !! CAM grid attribute pointer (list node) functions
2142 : !!
2143 : !!#######################################################################
2144 :
2145 26112 : subroutine initializeAttrPtr(this, attr)
2146 : ! Dummy arguments
2147 : class(cam_grid_attr_ptr_t) :: this
2148 : class(cam_grid_attribute_t), target :: attr
2149 :
2150 26112 : if (associated(this%next)) then
2151 0 : if (masterproc) then
2152 0 : write(iulog, *) 'WARNING: Overwriting attr pointer for cam_grid_attr_ptr_t'
2153 : end if
2154 : end if
2155 26112 : this%attr => attr
2156 26112 : end subroutine initializeAttrPtr
2157 :
2158 0 : function getAttrPtrAttr(this)
2159 : ! Dummy variable
2160 : class(cam_grid_attr_ptr_t) :: this
2161 : class(cam_grid_attribute_t), pointer :: getAttrPtrAttr
2162 :
2163 0 : getAttrPtrAttr => this%attr
2164 0 : end function getAttrPtrAttr
2165 :
2166 0 : function getAttrPtrNext(this)
2167 : ! Dummy arguments
2168 : class(cam_grid_attr_ptr_t) :: this
2169 : type(cam_grid_attr_ptr_t), pointer :: getAttrPtrNext
2170 :
2171 0 : getAttrPtrNext => this%next
2172 0 : end function getAttrPtrNext
2173 :
2174 26112 : subroutine setAttrPtrNext(this, next)
2175 : ! Dummy arguments
2176 : class(cam_grid_attr_ptr_t) :: this
2177 : type(cam_grid_attr_ptr_t), pointer :: next
2178 :
2179 26112 : if (associated(this%next)) then
2180 0 : if (masterproc) then
2181 0 : write(iulog, *) 'WARNING: Overwriting next pointer for cam_grid_attr_ptr_t'
2182 : end if
2183 : end if
2184 26112 : this%next => next
2185 26112 : end subroutine setAttrPtrNext
2186 :
2187 : !---------------------------------------------------------------------------
2188 : !
2189 : ! write_cam_grid_attr_0d_int
2190 : !
2191 : ! Write a grid attribute
2192 : !
2193 : !---------------------------------------------------------------------------
2194 :
2195 497664 : subroutine write_cam_grid_attr_0d_int(attr, File, file_index)
2196 : use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_int, &
2197 : pio_inq_att, PIO_GLOBAL
2198 : use cam_pio_utils, only: cam_pio_def_var
2199 :
2200 : ! Dummy arguments
2201 : class(cam_grid_attribute_0d_int_t), intent(inout) :: attr
2202 : type(file_desc_t), intent(inout) :: File ! PIO file Handle
2203 : integer, optional, intent(in) :: file_index
2204 :
2205 : ! Local variables
2206 : integer :: attrtype
2207 : integer(imap) :: attrlen
2208 : integer :: ierr
2209 : integer :: file_index_loc
2210 :
2211 497664 : if (present(file_index)) then
2212 497664 : file_index_loc = file_index
2213 : else
2214 : file_index_loc = 1
2215 : end if
2216 :
2217 : ! Since more than one grid can share an attribute, assume that if the
2218 : ! vardesc is associated, that grid defined the attribute
2219 497664 : if (.not. associated(attr%vardesc(file_index_loc)%p)) then
2220 497664 : if (len_trim(attr%long_name) > 0) then
2221 : ! This 0d attribute is a scalar variable with a long_name attribute
2222 : ! First, define the variable
2223 0 : allocate(attr%vardesc(file_index_loc)%p)
2224 : call cam_pio_def_var(File, trim(attr%name), pio_int, attr%vardesc(file_index_loc)%p, &
2225 0 : existOK=.false.)
2226 0 : ierr=pio_put_att(File, attr%vardesc(file_index_loc)%p, 'long_name', trim(attr%long_name))
2227 0 : call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_cam_grid_attr_0d_int')
2228 : else
2229 : ! This 0d attribute is a global attribute
2230 : ! Check to see if the attribute already exists in the file
2231 497664 : ierr = pio_inq_att(File, PIO_GLOBAL, attr%name, attrtype, attrlen)
2232 497664 : if (ierr /= PIO_NOERR) then
2233 : ! Time to define the attribute
2234 494592 : ierr = pio_put_att(File, PIO_GLOBAL, trim(attr%name), attr%ival)
2235 494592 : call cam_pio_handle_error(ierr, 'Unable to define attribute in write_cam_grid_attr_0d_int')
2236 : end if
2237 : end if
2238 : end if
2239 :
2240 497664 : end subroutine write_cam_grid_attr_0d_int
2241 :
2242 : !---------------------------------------------------------------------------
2243 : !
2244 : ! write_cam_grid_attr_0d_char
2245 : !
2246 : ! Write a grid attribute
2247 : !
2248 : !---------------------------------------------------------------------------
2249 :
2250 0 : subroutine write_cam_grid_attr_0d_char(attr, File, file_index)
2251 497664 : use pio, only: file_desc_t, pio_put_att, pio_noerr, &
2252 : pio_inq_att, PIO_GLOBAL
2253 :
2254 : ! Dummy arguments
2255 : class(cam_grid_attribute_0d_char_t), intent(inout) :: attr
2256 : type(file_desc_t), intent(inout) :: File ! PIO file Handle
2257 : integer, optional, intent(in) :: file_index
2258 :
2259 : ! Local variables
2260 : integer :: attrtype
2261 : integer(imap) :: attrlen
2262 : integer :: ierr
2263 : integer :: file_index_loc
2264 :
2265 0 : if (present(file_index)) then
2266 0 : file_index_loc = file_index
2267 : else
2268 : file_index_loc = 1
2269 : end if
2270 :
2271 : ! Since more than one grid can share an attribute, assume that if the
2272 : ! vardesc is associated, that grid defined the attribute
2273 0 : if (.not. associated(attr%vardesc(file_index_loc)%p)) then
2274 : ! The 0d char attributes are global attribues
2275 : ! Check to see if the attribute already exists in the file
2276 0 : ierr = pio_inq_att(File, PIO_GLOBAL, attr%name, attrtype, attrlen)
2277 0 : if (ierr /= PIO_NOERR) then
2278 : ! Time to define the variable
2279 0 : ierr = pio_put_att(File, PIO_GLOBAL, trim(attr%name), attr%val)
2280 0 : call cam_pio_handle_error(ierr, 'Unable to define attribute in write_cam_grid_attr_0d_char')
2281 : end if
2282 : end if
2283 :
2284 0 : end subroutine write_cam_grid_attr_0d_char
2285 :
2286 : !---------------------------------------------------------------------------
2287 : !
2288 : ! write_cam_grid_attr_1d_int
2289 : !
2290 : ! Write a grid attribute
2291 : !
2292 : !---------------------------------------------------------------------------
2293 :
2294 0 : subroutine write_cam_grid_attr_1d_int(attr, File, file_index)
2295 : use pio, only: file_desc_t, pio_put_att, pio_noerr
2296 : use pio, only: pio_inq_dimid, pio_int
2297 : use cam_pio_utils, only: cam_pio_def_var, cam_pio_closefile
2298 :
2299 : ! Dummy arguments
2300 : class(cam_grid_attribute_1d_int_t), intent(inout) :: attr
2301 : type(file_desc_t), intent(inout) :: File ! PIO file Handle
2302 : integer, optional, intent(in) :: file_index
2303 :
2304 : ! Local variables
2305 : integer :: dimid ! PIO dimension ID
2306 : character(len=120) :: errormsg
2307 : integer :: ierr
2308 : integer :: file_index_loc
2309 :
2310 0 : if (present(file_index)) then
2311 0 : file_index_loc = file_index
2312 : else
2313 : file_index_loc = 1
2314 : end if
2315 :
2316 : ! Since more than one grid can share an attribute, assume that if the
2317 : ! vardesc is associated, that grid defined the attribute
2318 0 : if (.not. associated(attr%vardesc(file_index_loc)%p)) then
2319 : ! Check to see if the dimension already exists in the file
2320 0 : ierr = pio_inq_dimid(File, trim(attr%dimname), dimid)
2321 0 : if (ierr /= PIO_NOERR) then
2322 : ! The dimension has not yet been defined. This is an error
2323 : ! NB: It should have been defined as part of a coordinate
2324 0 : write(errormsg, *) 'write_cam_grid_attr_1d_int: dimension, ', &
2325 0 : trim(attr%dimname), ', does not exist'
2326 0 : call cam_pio_closefile(File)
2327 0 : call endrun(errormsg)
2328 : end if
2329 : ! Time to define the variable
2330 0 : allocate(attr%vardesc(file_index_loc)%p)
2331 : call cam_pio_def_var(File, trim(attr%name), pio_int, (/dimid/), &
2332 0 : attr%vardesc(file_index_loc)%p, existOK=.false.)
2333 0 : ierr = pio_put_att(File, attr%vardesc(file_index_loc)%p, 'long_name', trim(attr%long_name))
2334 0 : call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_cam_grid_attr_1d_int')
2335 : end if
2336 :
2337 0 : end subroutine write_cam_grid_attr_1d_int
2338 :
2339 : !---------------------------------------------------------------------------
2340 : !
2341 : ! write_cam_grid_attr_1d_r8
2342 : !
2343 : ! Write a grid attribute
2344 : !
2345 : !---------------------------------------------------------------------------
2346 :
2347 497664 : subroutine write_cam_grid_attr_1d_r8(attr, File, file_index)
2348 0 : use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_double, &
2349 : pio_inq_dimid
2350 : use cam_pio_utils, only: cam_pio_def_var, cam_pio_closefile
2351 :
2352 : ! Dummy arguments
2353 : class(cam_grid_attribute_1d_r8_t), intent(inout) :: attr
2354 : type(file_desc_t), intent(inout) :: File ! PIO file Handle
2355 : integer, optional, intent(in) :: file_index
2356 :
2357 : ! Local variables
2358 : integer :: dimid ! PIO dimension ID
2359 : character(len=120) :: errormsg
2360 : integer :: ierr
2361 : integer :: file_index_loc
2362 :
2363 497664 : if (present(file_index)) then
2364 497664 : file_index_loc = file_index
2365 : else
2366 : file_index_loc = 1
2367 : end if
2368 :
2369 : ! Since more than one grid can share an attribute, assume that if the
2370 : ! vardesc is associated, that grid defined the attribute
2371 497664 : if (.not. associated(attr%vardesc(file_index_loc)%p)) then
2372 : ! Check to see if the dimension already exists in the file
2373 497664 : ierr = pio_inq_dimid(File, trim(attr%dimname), dimid)
2374 497664 : if (ierr /= PIO_NOERR) then
2375 : ! The dimension has not yet been defined. This is an error
2376 : ! NB: It should have been defined as part of a coordinate
2377 0 : write(errormsg, *) 'write_cam_grid_attr_1d_r8: dimension, ', &
2378 0 : trim(attr%dimname), ', does not exist'
2379 0 : call cam_pio_closefile(File)
2380 0 : call endrun(errormsg)
2381 : end if
2382 : ! Time to define the variable
2383 497664 : allocate(attr%vardesc(file_index_loc)%p)
2384 : call cam_pio_def_var(File, trim(attr%name), pio_double, (/dimid/), &
2385 995328 : attr%vardesc(file_index_loc)%p, existOK=.false.)
2386 : ! long_name
2387 497664 : ierr = pio_put_att(File, attr%vardesc(file_index_loc)%p, 'long_name', trim(attr%long_name))
2388 497664 : call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_cam_grid_attr_1d_r8')
2389 : end if
2390 :
2391 497664 : end subroutine write_cam_grid_attr_1d_r8
2392 :
2393 : !---------------------------------------------------------------------------
2394 : !
2395 : ! cam_grid_attribute_copy
2396 : !
2397 : ! Copy an attribute from a source grid to a destination grid
2398 : !
2399 : !---------------------------------------------------------------------------
2400 3072 : subroutine cam_grid_attribute_copy(src_grid, dest_grid, attribute_name)
2401 : ! Dummy arguments
2402 : character(len=*), intent(in) :: src_grid
2403 : character(len=*), intent(in) :: dest_grid
2404 : character(len=*), intent(in) :: attribute_name
2405 :
2406 : ! Local variables
2407 : character(len=120) :: errormsg
2408 : integer :: src_ind, dest_ind
2409 : class(cam_grid_attribute_t), pointer :: attr
2410 :
2411 : ! Find the source and destination grid indices
2412 3072 : src_ind = get_cam_grid_index(trim(src_grid))
2413 3072 : dest_ind = get_cam_grid_index(trim(dest_grid))
2414 :
2415 3072 : call find_cam_grid_attr(dest_ind, trim(attribute_name), attr)
2416 3072 : if (associated(attr)) then
2417 : ! Attribute found, can't add it again!
2418 0 : write(errormsg, '(4a)') 'CAM_GRID_ATTRIBUTE_COPY: attribute ', &
2419 0 : trim(attribute_name),' already exists for ',cam_grids(dest_ind)%name
2420 0 : call endrun(errormsg)
2421 : else
2422 3072 : call find_cam_grid_attr(src_ind, trim(attribute_name), attr)
2423 3072 : if (associated(attr)) then
2424 : ! Copy the attribute
2425 3072 : call insert_grid_attribute(dest_ind, attr)
2426 : else
2427 0 : write(errormsg, '(4a)') ": Did not find attribute, '", &
2428 0 : trim(attribute_name), "' in ", cam_grids(src_ind)%name
2429 0 : call endrun("CAM_GRID_ATTRIBUTE_COPY"//errormsg)
2430 : end if
2431 : end if
2432 :
2433 497664 : end subroutine cam_grid_attribute_copy
2434 :
2435 : !---------------------------------------------------------------------------
2436 : !
2437 : ! cam_grid_write_attr
2438 : !
2439 : ! Write the dimension and coordinate attributes for the horizontal history
2440 : ! coordinates.
2441 : !
2442 : !---------------------------------------------------------------------------
2443 248832 : subroutine cam_grid_write_attr(File, grid_id, header_info, file_index)
2444 : use pio, only: file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling
2445 :
2446 : ! Dummy arguments
2447 : type(file_desc_t), intent(inout) :: File ! PIO file Handle
2448 : integer, intent(in) :: grid_id
2449 : type(cam_grid_header_info_t), intent(inout) :: header_info
2450 : integer, optional, intent(in) :: file_index
2451 :
2452 : ! Local variables
2453 : integer :: gridind
2454 : class(cam_grid_attribute_t), pointer :: attr
2455 : type(cam_grid_attr_ptr_t), pointer :: attrPtr
2456 : integer :: dimids(2)
2457 : integer :: err_handling
2458 : integer :: file_index_loc
2459 :
2460 248832 : if (present(file_index)) then
2461 245760 : file_index_loc = file_index
2462 : else
2463 3072 : file_index_loc = 1
2464 : end if
2465 :
2466 248832 : gridind = get_cam_grid_index(grid_id)
2467 : !! Fill this in to make sure history finds grid
2468 248832 : header_info%grid_id = grid_id
2469 :
2470 248832 : if (allocated(header_info%hdims)) then
2471 122880 : deallocate(header_info%hdims)
2472 : end if
2473 :
2474 248832 : if (associated(header_info%lon_varid)) then
2475 : ! This could be a sign of bad memory management
2476 0 : call endrun('CAM_GRID_WRITE_ATTR: lon_varid should be NULL')
2477 : end if
2478 248832 : if (associated(header_info%lat_varid)) then
2479 : ! This could be a sign of bad memory management
2480 0 : call endrun('CAM_GRID_WRITE_ATTR: lat_varid should be NULL')
2481 : end if
2482 :
2483 : ! Only write this grid if not already defined
2484 248832 : if (cam_grids(gridind)%attrs_defined(file_index_loc)) then
2485 : ! We need to fill out the hdims info for this grid
2486 0 : call cam_grids(gridind)%find_dimids(File, dimids)
2487 0 : if (dimids(2) < 0) then
2488 0 : allocate(header_info%hdims(1))
2489 0 : header_info%hdims(1) = dimids(1)
2490 : else
2491 0 : allocate(header_info%hdims(2))
2492 0 : header_info%hdims(1:2) = dimids(1:2)
2493 : end if
2494 : else
2495 : ! Write the horizontal coord attributes first so that we have the dims
2496 248832 : call cam_grids(gridind)%lat_coord%write_attr(File, dimids(2), file_index=file_index_loc)
2497 248832 : call cam_grids(gridind)%lon_coord%write_attr(File, dimids(1), file_index=file_index_loc)
2498 :
2499 248832 : if (dimids(2) == dimids(1)) then
2500 248832 : allocate(header_info%hdims(1))
2501 : else
2502 0 : allocate(header_info%hdims(2))
2503 0 : header_info%hdims(2) = dimids(2)
2504 : end if
2505 248832 : header_info%hdims(1) = dimids(1)
2506 :
2507 : ! We will handle errors for this routine
2508 248832 : call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling)
2509 :
2510 248832 : attrPtr => cam_grids(gridind)%attributes
2511 1244160 : do while (associated(attrPtr))
2512 : !!XXgoldyXX: Is this not working in PGI?
2513 : ! attr => attrPtr%getAttr()
2514 995328 : attr => attrPtr%attr
2515 995328 : call attr%write_attr(File, file_index=file_index_loc)
2516 : !!XXgoldyXX: Is this not working in PGI?
2517 : ! attrPtr => attrPtr%getNext()
2518 995328 : attrPtr => attrPtr%next
2519 : end do
2520 :
2521 : ! Back to previous I/O error handling
2522 248832 : call pio_seterrorhandling(File, err_handling)
2523 248832 : cam_grids(gridind)%attrs_defined(file_index_loc) = .true.
2524 : end if
2525 :
2526 248832 : end subroutine cam_grid_write_attr
2527 :
2528 497664 : subroutine write_cam_grid_val_0d_int(attr, File, file_index)
2529 : use pio, only: file_desc_t, pio_put_var
2530 :
2531 : ! Dummy arguments
2532 : class(cam_grid_attribute_0d_int_t), intent(inout) :: attr
2533 : type(file_desc_t), intent(inout) :: File
2534 : integer, optional, intent(in) :: file_index
2535 :
2536 : ! Local variables
2537 : integer :: ierr
2538 : integer :: file_index_loc
2539 :
2540 497664 : if (present(file_index)) then
2541 497664 : file_index_loc = file_index
2542 : else
2543 : file_index_loc = 1
2544 : end if
2545 :
2546 : ! We only write this var if it is a variable
2547 497664 : if (associated(attr%vardesc(file_index_loc)%p)) then
2548 0 : ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, attr%ival)
2549 0 : call cam_pio_handle_error(ierr, 'Error writing value in write_cam_grid_val_0d_int')
2550 0 : deallocate(attr%vardesc(file_index_loc)%p)
2551 0 : nullify(attr%vardesc(file_index_loc)%p)
2552 : end if
2553 :
2554 497664 : end subroutine write_cam_grid_val_0d_int
2555 :
2556 0 : subroutine write_cam_grid_val_0d_char(attr, File, file_index)
2557 : use pio, only: file_desc_t
2558 :
2559 : ! Dummy arguments
2560 : class(cam_grid_attribute_0d_char_t), intent(inout) :: attr
2561 : type(file_desc_t), intent(inout) :: File
2562 : integer, optional, intent(in) :: file_index
2563 :
2564 : ! This subroutine is a stub because global attributes are written
2565 : ! in define mode
2566 0 : return
2567 : end subroutine write_cam_grid_val_0d_char
2568 :
2569 0 : subroutine write_cam_grid_val_1d_int(attr, File, file_index)
2570 : use pio, only: file_desc_t, pio_put_var, pio_int, &
2571 : pio_write_darray, io_desc_t, pio_freedecomp
2572 : use cam_pio_utils, only: cam_pio_newdecomp
2573 :
2574 : ! Dummy arguments
2575 : class(cam_grid_attribute_1d_int_t), intent(inout) :: attr
2576 : type(file_desc_t), intent(inout) :: File
2577 : integer, optional, intent(in) :: file_index
2578 :
2579 : ! Local variables
2580 : integer :: ierr
2581 : type(io_desc_t), pointer :: iodesc
2582 : integer :: file_index_loc
2583 :
2584 0 : if (present(file_index)) then
2585 0 : file_index_loc = file_index
2586 : else
2587 : file_index_loc = 1
2588 : end if
2589 :
2590 0 : nullify(iodesc)
2591 : ! Since more than one grid can share an attribute, assume that if the
2592 : ! vardesc is not associated, another grid write the values
2593 0 : if (associated(attr%vardesc(file_index_loc)%p)) then
2594 : ! Write out the values for this dimension variable
2595 0 : if (associated(attr%map)) then
2596 : ! This is a distributed variable, use pio_write_darray
2597 0 : allocate(iodesc)
2598 0 : call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, pio_int)
2599 0 : call pio_write_darray(File, attr%vardesc(file_index_loc)%p, iodesc, attr%values, ierr)
2600 0 : call pio_freedecomp(File, iodesc)
2601 0 : deallocate(iodesc)
2602 : nullify(iodesc)
2603 : else
2604 : ! This is a local variable, pio_put_var should work fine
2605 0 : ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, attr%values)
2606 : end if
2607 0 : call cam_pio_handle_error(ierr, 'Error writing variable values in write_cam_grid_val_1d_int')
2608 0 : deallocate(attr%vardesc(file_index_loc)%p)
2609 0 : nullify(attr%vardesc(file_index_loc)%p)
2610 : end if
2611 :
2612 0 : end subroutine write_cam_grid_val_1d_int
2613 :
2614 497664 : subroutine write_cam_grid_val_1d_r8(attr, File, file_index)
2615 0 : use pio, only: file_desc_t, pio_put_var, pio_double, &
2616 : pio_write_darray, io_desc_t, pio_freedecomp
2617 : use cam_pio_utils, only: cam_pio_newdecomp
2618 :
2619 : ! Dummy arguments
2620 : class(cam_grid_attribute_1d_r8_t), intent(inout) :: attr
2621 : type(file_desc_t), intent(inout) :: File
2622 : integer, optional, intent(in) :: file_index
2623 :
2624 : ! Local variables
2625 : integer :: ierr
2626 : type(io_desc_t), pointer :: iodesc
2627 : integer :: file_index_loc
2628 :
2629 497664 : if (present(file_index)) then
2630 497664 : file_index_loc = file_index
2631 : else
2632 : file_index_loc = 1
2633 : end if
2634 :
2635 497664 : nullify(iodesc)
2636 : ! Since more than one grid can share an attribute, assume that if the
2637 : ! vardesc is not associated, another grid write the values
2638 497664 : if (associated(attr%vardesc(file_index_loc)%p)) then
2639 : ! Write out the values for this dimension variable
2640 497664 : if (associated(attr%map)) then
2641 : ! This is a distributed variable, use pio_write_darray
2642 497664 : allocate(iodesc)
2643 995328 : call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, pio_double)
2644 497664 : call pio_write_darray(File, attr%vardesc(file_index_loc)%p, iodesc, attr%values, ierr)
2645 497664 : call pio_freedecomp(File, iodesc)
2646 497664 : deallocate(iodesc)
2647 : nullify(iodesc)
2648 : else
2649 : ! This is a local variable, pio_put_var should work fine
2650 0 : ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, attr%values)
2651 : end if
2652 497664 : call cam_pio_handle_error(ierr, 'Error writing variable values in write_cam_grid_val_1d_r8')
2653 497664 : deallocate(attr%vardesc(file_index_loc)%p)
2654 497664 : nullify(attr%vardesc(file_index_loc)%p)
2655 : end if
2656 :
2657 497664 : end subroutine write_cam_grid_val_1d_r8
2658 :
2659 248832 : subroutine cam_grid_write_var(File, grid_id, file_index)
2660 497664 : use pio, only: file_desc_t, pio_bcast_error, pio_seterrorhandling
2661 :
2662 : ! Dummy arguments
2663 : type(file_desc_t), intent(inout) :: File ! PIO file Handle
2664 : integer, intent(in) :: grid_id
2665 : integer, optional, intent(in) :: file_index
2666 :
2667 : ! Local variables
2668 : integer :: gridind
2669 : integer :: err_handling
2670 : class(cam_grid_attribute_t), pointer :: attr
2671 : type(cam_grid_attr_ptr_t), pointer :: attrPtr
2672 : integer :: file_index_loc
2673 :
2674 248832 : if (present(file_index)) then
2675 245760 : file_index_loc = file_index
2676 : else
2677 3072 : file_index_loc = 1
2678 : end if
2679 248832 : gridind = get_cam_grid_index(grid_id)
2680 : ! Only write if not already done
2681 248832 : if (cam_grids(gridind)%attrs_defined(file_index_loc)) then
2682 : ! Write the horizontal coorinate values
2683 248832 : call cam_grids(gridind)%lon_coord%write_var(File, file_index)
2684 248832 : call cam_grids(gridind)%lat_coord%write_var(File, file_index)
2685 :
2686 : ! We will handle errors for this routine
2687 248832 : call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling)
2688 :
2689 : ! Write out the variable values for each grid attribute
2690 248832 : attrPtr => cam_grids(gridind)%attributes
2691 1244160 : do while (associated(attrPtr))
2692 : !!XXgoldyXX: Is this not working in PGI?
2693 : ! attr => attrPtr%getAttr()
2694 995328 : attr => attrPtr%attr
2695 995328 : call attr%write_val(File, file_index=file_index_loc)
2696 : !!XXgoldyXX: Is this not working in PGI?
2697 : ! attrPtr => attrPtr%getNext()
2698 995328 : attrPtr => attrPtr%next
2699 : end do
2700 :
2701 : ! Back to previous I/O error handling
2702 248832 : call pio_seterrorhandling(File, err_handling)
2703 :
2704 248832 : cam_grids(gridind)%attrs_defined(file_index_loc) = .false.
2705 : end if
2706 :
2707 248832 : end subroutine cam_grid_write_var
2708 :
2709 2184960 : logical function cam_grid_block_indexed(this)
2710 : class(cam_grid_t) :: this
2711 :
2712 2184960 : cam_grid_block_indexed = this%block_indexed
2713 2184960 : end function cam_grid_block_indexed
2714 :
2715 2184960 : logical function cam_grid_zonal_grid(this)
2716 : class(cam_grid_t) :: this
2717 :
2718 2184960 : cam_grid_zonal_grid = this%zonal_grid
2719 2184960 : end function cam_grid_zonal_grid
2720 :
2721 280320 : logical function cam_grid_unstructured(this)
2722 : class(cam_grid_t) :: this
2723 :
2724 280320 : cam_grid_unstructured = this%unstructured
2725 280320 : end function cam_grid_unstructured
2726 :
2727 : !---------------------------------------------------------------------------
2728 : !
2729 : ! cam_grid_get_dims: Return the dimensions of the grid
2730 : ! For lon/lat grids, this is (nlon, nlat)
2731 : ! For unstructured grids, this is (ncols, 1)
2732 : !
2733 : !---------------------------------------------------------------------------
2734 280320 : subroutine cam_grid_get_dims(this, dims)
2735 : ! Dummy arguments
2736 : class(cam_grid_t) :: this
2737 : integer, intent(inout) :: dims(2)
2738 :
2739 280320 : if (this%is_unstructured()) then
2740 280320 : call this%lon_coord%get_coord_len(dims(1))
2741 280320 : dims(2) = 1
2742 : else
2743 0 : call this%lon_coord%get_coord_len(dims(1))
2744 0 : call this%lat_coord%get_coord_len(dims(2))
2745 : end if
2746 :
2747 280320 : end subroutine cam_grid_get_dims
2748 :
2749 : !---------------------------------------------------------------------------
2750 : !
2751 : ! cam_grid_coord_names: Return the names of the grid axes
2752 : !
2753 : !---------------------------------------------------------------------------
2754 0 : subroutine cam_grid_coord_names(this, lon_name, lat_name)
2755 : ! Dummy arguments
2756 : class(cam_grid_t) :: this
2757 : character(len=*), intent(out) :: lon_name
2758 : character(len=*), intent(out) :: lat_name
2759 :
2760 0 : call this%lon_coord%get_coord_name(lon_name)
2761 0 : call this%lat_coord%get_coord_name(lat_name)
2762 :
2763 0 : end subroutine cam_grid_coord_names
2764 :
2765 : !---------------------------------------------------------------------------
2766 : !
2767 : ! cam_grid_dim_names: Return the names of the dimensions of the grid axes.
2768 : ! Note that these may be the same
2769 : !
2770 : !---------------------------------------------------------------------------
2771 288768 : subroutine cam_grid_dim_names(this, name1, name2)
2772 : ! Dummy arguments
2773 : class(cam_grid_t) :: this
2774 : character(len=*), intent(out) :: name1
2775 : character(len=*), intent(out) :: name2
2776 :
2777 288768 : call this%lon_coord%get_dim_name(name1)
2778 288768 : call this%lat_coord%get_dim_name(name2)
2779 :
2780 288768 : end subroutine cam_grid_dim_names
2781 :
2782 : !---------------------------------------------------------------------------
2783 : !
2784 : ! cam_grid_dimensions_id: Return the dimensions of the grid
2785 : ! For lon/lat grids, this is (nlon, nlat)
2786 : ! For unstructured grids, this is (ncols, 1)
2787 : !
2788 : !---------------------------------------------------------------------------
2789 275712 : subroutine cam_grid_dimensions_id(gridid, dims, rank)
2790 : ! Dummy arguments
2791 : integer, intent(in) :: gridid
2792 : integer, intent(inout) :: dims(2)
2793 : integer, optional, intent(out) :: rank
2794 :
2795 : ! Local variables
2796 : integer :: index
2797 : character(len=max_hcoordname_len) :: dname1, dname2
2798 : character(len=120) :: errormsg
2799 :
2800 275712 : index = get_cam_grid_index(gridid)
2801 275712 : if (index < 0) then
2802 0 : write(errormsg, *) 'No CAM grid with ID =', gridid
2803 0 : call endrun(errormsg)
2804 : else
2805 275712 : call cam_grids(index)%coord_lengths(dims)
2806 : end if
2807 275712 : if (present(rank)) then
2808 229632 : call cam_grids(index)%dim_names(dname1, dname2)
2809 229632 : if (trim(dname1) == trim(dname2)) then
2810 229632 : rank = 1
2811 : else
2812 0 : rank = 2
2813 : end if
2814 : end if
2815 :
2816 275712 : end subroutine cam_grid_dimensions_id
2817 :
2818 : !---------------------------------------------------------------------------
2819 : !
2820 : ! cam_grid_dimensions_name: Return the dimensions of the grid
2821 : ! For lon/lat grids, this is (nlon, nlat)
2822 : ! For unstructured grids, this is (ncols, 1)
2823 : !
2824 : !---------------------------------------------------------------------------
2825 2304 : subroutine cam_grid_dimensions_name(gridname, dims, rank)
2826 : ! Dummy arguments
2827 : character(len=*), intent(in) :: gridname
2828 : integer, intent(inout) :: dims(2)
2829 : integer, optional, intent(out) :: rank
2830 :
2831 : ! Local variables
2832 : integer :: gridind
2833 : character(len=max_hcoordname_len) :: dname1, dname2
2834 : character(len=120) :: errormsg
2835 :
2836 2304 : gridind = get_cam_grid_index(trim(gridname))
2837 2304 : if (gridind < 0) then
2838 0 : write(errormsg, *) 'No CAM grid with name = ', trim(gridname)
2839 0 : call endrun(errormsg)
2840 : else
2841 2304 : call cam_grids(gridind)%coord_lengths(dims)
2842 : end if
2843 2304 : if (present(rank)) then
2844 0 : call cam_grids(gridind)%dim_names(dname1, dname2)
2845 0 : if (trim(dname1) == trim(dname2)) then
2846 0 : rank = 1
2847 : else
2848 0 : rank = 2
2849 : end if
2850 : end if
2851 :
2852 2304 : end subroutine cam_grid_dimensions_name
2853 :
2854 : !---------------------------------------------------------------------------
2855 : !
2856 : ! cam_grid_set_map: Set a grid's distribution map
2857 : ! This maps the local grid elements to global file order
2858 : !
2859 : !---------------------------------------------------------------------------
2860 0 : subroutine cam_grid_set_map(this, map, src, dest)
2861 : use spmd_utils, only: mpi_sum, mpi_integer, mpicom
2862 : ! Dummy arguments
2863 : class(cam_grid_t) :: this
2864 : integer(iMap), pointer :: map(:,:)
2865 : integer, intent(in) :: src(2) ! decomp info
2866 : integer, intent(in) :: dest(2) ! Standard dim(s) in file
2867 :
2868 : ! Local variables
2869 : integer :: dims(2)
2870 : integer :: dstrt, dend
2871 : integer :: gridlen, gridloc, ierr
2872 :
2873 : ! Check to make sure the map meets our needs
2874 0 : call this%coord_lengths(dims)
2875 0 : dend = size(map, 1)
2876 : ! We always have to have one source and one destination
2877 0 : if (dest(2) > 0) then
2878 0 : dstrt = dend - 1
2879 : else
2880 : dstrt = dend
2881 : end if
2882 0 : if ((src(2) /= 0) .and. (dstrt < 3)) then
2883 0 : call endrun('cam_grid_set_map: src & dest too large for map')
2884 0 : else if (dstrt < 2) then
2885 0 : call endrun('cam_grid_set_map: dest too large for map')
2886 : ! No else needed
2887 : end if
2888 0 : if (dstrt == dend) then
2889 0 : gridloc = count(map(dend,:) /= 0)
2890 : else
2891 0 : gridloc = count((map(dstrt,:) /= 0) .and. (map(dend,:) /= 0))
2892 : end if
2893 0 : call MPI_Allreduce(gridloc, gridlen, 1, MPI_INTEGER, MPI_SUM, mpicom, ierr)
2894 0 : if (gridlen /= product(dims)) then
2895 0 : call endrun('cam_grid_set_map: Bad map size for '//trim(this%name))
2896 : else
2897 0 : if (.not. associated(this%map)) then
2898 0 : allocate(this%map)
2899 : end if
2900 0 : call this%map%init(map, this%unstructured, src, dest)
2901 : end if
2902 0 : end subroutine cam_grid_set_map
2903 :
2904 : !---------------------------------------------------------------------------
2905 : !
2906 : ! cam_grid_local_size: return the local size of a 2D array on this grid
2907 : !
2908 : !---------------------------------------------------------------------------
2909 0 : integer function cam_grid_local_size(this)
2910 :
2911 : ! Dummy argument
2912 : class(cam_grid_t) :: this
2913 :
2914 : ! Local variable
2915 : character(len=128) :: errormsg
2916 :
2917 0 : if (.not. associated(this%map)) then
2918 0 : write(errormsg, *) 'Grid, '//trim(this%name)//', has no map'
2919 0 : call endrun('cam_grid_local_size: '//trim(errormsg))
2920 : else
2921 0 : cam_grid_local_size = this%map%num_elem()
2922 : end if
2923 :
2924 0 : end function cam_grid_local_size
2925 :
2926 : !---------------------------------------------------------------------------
2927 : !
2928 : ! cam_grid_get_lon_lat: Find the latitude and longitude for a given
2929 : ! grid map index. Note if point is not mapped
2930 : !
2931 : !---------------------------------------------------------------------------
2932 0 : subroutine cam_grid_get_lon_lat(this, index, lon, lat, isMapped)
2933 :
2934 : ! Dummy arguments
2935 : class(cam_grid_t) :: this
2936 : integer, intent(in) :: index
2937 : real(r8), intent(out) :: lon
2938 : real(r8), intent(out) :: lat
2939 : logical, intent(out) :: isMapped
2940 :
2941 : ! Local variables
2942 : integer :: latindex, lonindex
2943 : character(len=*), parameter :: subname = "cam_grid_get_lon_lat"
2944 :
2945 0 : if (this%block_indexed) then
2946 0 : lonindex = index
2947 0 : latindex = index
2948 0 : isMapped = this%map%is_mapped(index)
2949 : else
2950 0 : call this%map%coord_vals(index, lonindex, latindex, isMapped)
2951 : end if
2952 :
2953 : !!XXgoldyXX: May be able to relax all the checks
2954 0 : if ( (latindex < LBOUND(this%lat_coord%values, 1)) .or. &
2955 : (latindex > UBOUND(this%lat_coord%values, 1))) then
2956 0 : call endrun(trim(subname)//": index out of range for latvals")
2957 : else
2958 0 : lat = this%lat_coord%values(latindex)
2959 : end if
2960 :
2961 0 : if ( (lonindex < LBOUND(this%lon_coord%values, 1)) .or. &
2962 : (lonindex > UBOUND(this%lon_coord%values, 1))) then
2963 0 : call endrun(trim(subname)//": index out of range for lonvals")
2964 : else
2965 0 : lon = this%lon_coord%values(lonindex)
2966 : end if
2967 :
2968 0 : end subroutine cam_grid_get_lon_lat
2969 :
2970 : !---------------------------------------------------------------------------
2971 : !
2972 : ! cam_grid_find_src_dims: Find the correct src array dims for this grid
2973 : !
2974 : !---------------------------------------------------------------------------
2975 27648 : subroutine cam_grid_find_src_dims(this, field_dnames, src_out)
2976 : ! Dummy arguments
2977 : class(cam_grid_t) :: this
2978 : character(len=*), intent(in) :: field_dnames(:)
2979 : integer, pointer :: src_out(:)
2980 :
2981 : ! Local variables
2982 : integer :: i, j
2983 : integer :: num_coords
2984 : character(len=max_hcoordname_len) :: coord_dimnames(2)
2985 :
2986 27648 : call this%dim_names(coord_dimnames(1), coord_dimnames(2))
2987 27648 : if (associated(src_out)) then
2988 0 : deallocate(src_out)
2989 : nullify(src_out)
2990 : end if
2991 27648 : if (trim(coord_dimnames(1)) == trim(coord_dimnames(2))) then
2992 : num_coords = 1
2993 : else
2994 0 : num_coords = 2
2995 : end if
2996 27648 : allocate(src_out(2)) ! Currently, all cases have two source dims
2997 55296 : do i = 1, num_coords
2998 110592 : do j = 1, size(field_dnames)
2999 82944 : if (trim(field_dnames(j)) == trim(coord_dimnames(i))) then
3000 27648 : src_out(i) = j
3001 : end if
3002 : end do
3003 : end do
3004 27648 : if (num_coords < 2) then
3005 27648 : src_out(2) = -1 ! Assume a block structure for unstructured grids
3006 : end if
3007 :
3008 27648 : end subroutine cam_grid_find_src_dims
3009 :
3010 : !---------------------------------------------------------------------------
3011 : !
3012 : ! cam_grid_find_dest_dims: Find the correct file array dims for this grid
3013 : !
3014 : !---------------------------------------------------------------------------
3015 27648 : subroutine cam_grid_find_dest_dims(this, file_dnames, dest_out)
3016 : ! Dummy arguments
3017 : class(cam_grid_t) :: this
3018 : character(len=*), intent(in) :: file_dnames(:)
3019 : integer, pointer :: dest_out(:)
3020 :
3021 : ! Local variables
3022 : integer :: i, j
3023 : integer :: num_coords
3024 : character(len=max_hcoordname_len) :: coord_dimnames(2)
3025 :
3026 27648 : call this%dim_names(coord_dimnames(1), coord_dimnames(2))
3027 27648 : if (associated(dest_out)) then
3028 0 : deallocate(dest_out)
3029 : nullify(dest_out)
3030 : end if
3031 27648 : if (trim(coord_dimnames(1)) == trim(coord_dimnames(2))) then
3032 : num_coords = 1
3033 : else
3034 0 : num_coords = 2
3035 : end if
3036 82944 : allocate(dest_out(num_coords))
3037 55296 : dest_out = 0
3038 55296 : do i = 1, num_coords
3039 110592 : do j = 1, size(file_dnames)
3040 82944 : if (trim(file_dnames(j)) == trim(coord_dimnames(i))) then
3041 27648 : dest_out(i) = j
3042 : end if
3043 : end do
3044 : end do
3045 :
3046 27648 : end subroutine cam_grid_find_dest_dims
3047 :
3048 : !---------------------------------------------------------------------------
3049 : !
3050 : ! cam_grid_get_pio_decomp: Find or create a PIO decomp on this grid
3051 : !
3052 : !---------------------------------------------------------------------------
3053 40704 : subroutine cam_grid_get_pio_decomp(this, field_lens, file_lens, dtype, &
3054 40704 : iodesc, field_dnames, file_dnames)
3055 : use pio, only: io_desc_t
3056 : use cam_pio_utils, only: cam_pio_get_decomp, calc_permutation
3057 :
3058 : ! Dummy arguments
3059 : class(cam_grid_t) :: this
3060 : integer, intent(in) :: field_lens(:)
3061 : integer, intent(in) :: file_lens(:)
3062 : integer, intent(in) :: dtype
3063 : type(io_desc_t), pointer, intent(out) :: iodesc
3064 : character(len=*), optional, intent(in) :: field_dnames(:)
3065 : character(len=*), optional, intent(in) :: file_dnames(:)
3066 :
3067 : ! Local variables
3068 40704 : integer, pointer :: src_in(:)
3069 40704 : integer, pointer :: dest_in(:)
3070 40704 : integer, allocatable :: permutation(:)
3071 : logical :: is_perm
3072 : character(len=128) :: errormsg
3073 :
3074 40704 : nullify(src_in)
3075 40704 : nullify(dest_in)
3076 40704 : is_perm = .false.
3077 40704 : if (.not. associated(this%map)) then
3078 0 : write(errormsg, *) 'Grid, '//trim(this%name)//', has no map'
3079 0 : call endrun('cam_grid_get_pio_decomp: '//trim(errormsg))
3080 : else
3081 40704 : if (present(field_dnames)) then
3082 27648 : call this%find_src_dims(field_dnames, src_in)
3083 : end if
3084 40704 : if (present(file_dnames)) then
3085 27648 : call this%find_dest_dims(file_dnames, dest_in)
3086 : end if
3087 40704 : if (present(file_dnames) .and. present(field_dnames)) then
3088 : ! This only works if the arrays are the same size
3089 27648 : if (size(file_dnames) == size(field_dnames)) then
3090 82944 : allocate(permutation(size(file_dnames)))
3091 27648 : call calc_permutation(file_dnames, field_dnames, permutation, is_perm)
3092 : end if
3093 : end if
3094 : ! Call cam_pio_get_decomp with the appropriate options
3095 40704 : if (present(field_dnames) .and. present(file_dnames)) then
3096 27648 : if (is_perm) then
3097 : call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, &
3098 : this%map, field_dist_in=src_in, file_dist_in=dest_in, &
3099 0 : permute=permutation)
3100 : else
3101 : call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, &
3102 27648 : this%map, field_dist_in=src_in, file_dist_in=dest_in)
3103 : end if
3104 13056 : else if (present(field_dnames)) then
3105 : call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, &
3106 0 : this%map, field_dist_in=src_in)
3107 13056 : else if (present(file_dnames)) then
3108 : call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, &
3109 0 : this%map, file_dist_in=dest_in)
3110 : else
3111 13056 : call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, this%map)
3112 : end if
3113 : end if
3114 40704 : if (associated(src_in)) then
3115 27648 : deallocate(src_in)
3116 : nullify(src_in)
3117 : end if
3118 40704 : if (associated(dest_in)) then
3119 27648 : deallocate(dest_in)
3120 : nullify(dest_in)
3121 : end if
3122 40704 : if (allocated(permutation)) then
3123 27648 : deallocate(permutation)
3124 : end if
3125 :
3126 81408 : end subroutine cam_grid_get_pio_decomp
3127 :
3128 : !-------------------------------------------------------------------------------
3129 : !
3130 : ! cam_grid_find_dimids: Find the dimension NetCDF IDs on <File> for this grid
3131 : !
3132 : !-------------------------------------------------------------------------------
3133 1536 : subroutine cam_grid_find_dimids(this, File, dimids)
3134 40704 : use pio, only: file_desc_t, pio_noerr, pio_inq_dimid
3135 : use pio, only: pio_seterrorhandling, pio_bcast_error
3136 :
3137 : ! Dummy arguments
3138 : class(cam_grid_t) :: this
3139 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3140 : integer, intent(out) :: dimids(:)
3141 :
3142 : ! Local vaariables
3143 : integer :: ierr
3144 : integer :: err_handling
3145 : character(len=max_hcoordname_len) :: dimname1, dimname2
3146 :
3147 : ! We will handle errors for this routine
3148 1536 : call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling)
3149 :
3150 1536 : call this%dim_names(dimname1, dimname2)
3151 1536 : if (size(dimids) < 1) then
3152 0 : call endrun('CAM_GRID_FIND_DIMIDS: dimids must have positive size')
3153 : end if
3154 6144 : dimids = -1
3155 : ! Check the first dimension
3156 1536 : ierr = pio_inq_dimid(File, trim(dimname1), dimids(1))
3157 1536 : if(ierr /= PIO_NOERR) then
3158 0 : call endrun('CAM_GRID_FIND_DIMIDS: '//trim(this%name)//' dimension, '//trim(dimname1)//', does not exist on file')
3159 : end if
3160 1536 : if (trim(dimname1) /= trim(dimname2)) then
3161 : ! Structured grid, find second dimid
3162 0 : if (size(dimids) < 2) then
3163 0 : call endrun('CAM_GRID_FIND_DIMIDS: dimids too small for '//trim(this%name))
3164 : end if
3165 0 : ierr = pio_inq_dimid(File, trim(dimname2), dimids(2))
3166 0 : if(ierr /= PIO_NOERR) then
3167 0 : call endrun('CAM_GRID_FIND_DIMIDS: '//trim(this%name)//' dimension, '//trim(dimname2)//', does not exist on file')
3168 : end if
3169 : end if
3170 :
3171 : ! Back to whatever error handling was running before this routine
3172 1536 : call pio_seterrorhandling(File, err_handling)
3173 :
3174 1536 : end subroutine cam_grid_find_dimids
3175 :
3176 : !---------------------------------------------------------------------------
3177 : !
3178 : ! cam_grid_read_darray_2d_int: Read a variable defined on this grid
3179 : !
3180 : !---------------------------------------------------------------------------
3181 768 : subroutine cam_grid_read_darray_2d_int(this, File, adims, fdims, hbuf, varid)
3182 : use pio, only: file_desc_t, io_desc_t, pio_read_darray, PIO_INT
3183 : use cam_pio_utils, only: cam_pio_get_decomp
3184 :
3185 : ! Dummy arguments
3186 : class(cam_grid_t) :: this
3187 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3188 : integer, intent(in) :: adims(:)
3189 : integer, intent(in) :: fdims(:)
3190 : integer, intent(out) :: hbuf(:,:)
3191 : type(var_desc_t), intent(inout) :: varid
3192 :
3193 : ! Local variables
3194 : type(io_desc_t), pointer :: iodesc
3195 : integer :: ierr
3196 :
3197 768 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map)
3198 768 : call pio_read_darray(File, varid, iodesc, hbuf, ierr)
3199 768 : call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_int: Error reading variable')
3200 768 : end subroutine cam_grid_read_darray_2d_int
3201 :
3202 : !---------------------------------------------------------------------------
3203 : !
3204 : ! cam_grid_read_darray_3d_int: Read a variable defined on this grid
3205 : !
3206 : !---------------------------------------------------------------------------
3207 0 : subroutine cam_grid_read_darray_3d_int(this, File, adims, fdims, hbuf, varid)
3208 768 : use pio, only: file_desc_t, io_desc_t, pio_read_darray, PIO_INT
3209 : use cam_pio_utils, only: cam_pio_get_decomp
3210 :
3211 : ! Dummy arguments
3212 : class(cam_grid_t) :: this
3213 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3214 : integer, intent(in) :: adims(:)
3215 : integer, intent(in) :: fdims(:)
3216 : integer, intent(out) :: hbuf(:,:,:)
3217 : type(var_desc_t), intent(inout) :: varid
3218 :
3219 : ! Local variables
3220 : type(io_desc_t), pointer :: iodesc
3221 : integer :: ierr
3222 :
3223 0 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map)
3224 0 : call pio_read_darray(File, varid, iodesc, hbuf, ierr)
3225 0 : call cam_pio_handle_error(ierr, 'cam_grid_read_darray_3d_int: Error reading variable')
3226 0 : end subroutine cam_grid_read_darray_3d_int
3227 :
3228 : !---------------------------------------------------------------------------
3229 : !
3230 : ! cam_grid_read_darray_2d_double: Read a variable defined on this grid
3231 : !
3232 : !---------------------------------------------------------------------------
3233 18432 : subroutine cam_grid_read_darray_2d_double(this, File, adims, fdims, hbuf, varid)
3234 0 : use pio, only: file_desc_t, io_desc_t, pio_read_darray
3235 : use pio, only: PIO_DOUBLE
3236 : use cam_pio_utils, only: cam_pio_get_decomp
3237 :
3238 : ! Dummy arguments
3239 : class(cam_grid_t) :: this
3240 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3241 : integer, intent(in) :: adims(:)
3242 : integer, intent(in) :: fdims(:)
3243 : real(r8), intent(out) :: hbuf(:,:)
3244 : type(var_desc_t), intent(inout) :: varid
3245 :
3246 : ! Local variables
3247 : type(io_desc_t), pointer :: iodesc
3248 : integer :: ierr
3249 :
3250 18432 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map)
3251 18432 : call pio_read_darray(File, varid, iodesc, hbuf, ierr)
3252 18432 : call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_double: Error reading variable')
3253 18432 : end subroutine cam_grid_read_darray_2d_double
3254 :
3255 : !---------------------------------------------------------------------------
3256 : !
3257 : ! cam_grid_read_darray_3d_double: Read a variable defined on this grid
3258 : !
3259 : !---------------------------------------------------------------------------
3260 66816 : subroutine cam_grid_read_darray_3d_double(this, File, adims, fdims, hbuf, varid)
3261 18432 : use pio, only: file_desc_t, io_desc_t, pio_read_darray
3262 : use pio, only: PIO_DOUBLE
3263 : use cam_pio_utils, only: cam_pio_get_decomp
3264 :
3265 : ! Dummy arguments
3266 : class(cam_grid_t) :: this
3267 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3268 : integer, intent(in) :: adims(:)
3269 : integer, intent(in) :: fdims(:)
3270 : real(r8), intent(out) :: hbuf(:,:,:)
3271 : type(var_desc_t), intent(inout) :: varid
3272 :
3273 : ! Local variables
3274 : type(io_desc_t), pointer :: iodesc
3275 : integer :: ierr
3276 :
3277 66816 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map)
3278 66816 : call pio_read_darray(File, varid, iodesc, hbuf, ierr)
3279 66816 : call cam_pio_handle_error(ierr, 'cam_grid_read_darray_3d_double: Error reading variable')
3280 66816 : end subroutine cam_grid_read_darray_3d_double
3281 :
3282 : !---------------------------------------------------------------------------
3283 : !
3284 : ! cam_grid_read_darray_2d_real: Read a variable defined on this grid
3285 : !
3286 : !---------------------------------------------------------------------------
3287 0 : subroutine cam_grid_read_darray_2d_real(this, File, adims, fdims, hbuf, varid)
3288 66816 : use pio, only: file_desc_t, io_desc_t, pio_read_darray
3289 : use pio, only: PIO_REAL
3290 : use cam_pio_utils, only: cam_pio_get_decomp
3291 :
3292 : ! Dummy arguments
3293 : class(cam_grid_t) :: this
3294 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3295 : integer, intent(in) :: adims(:)
3296 : integer, intent(in) :: fdims(:)
3297 : real(r4), intent(out) :: hbuf(:,:)
3298 : type(var_desc_t), intent(inout) :: varid
3299 :
3300 : ! Local variables
3301 : type(io_desc_t), pointer :: iodesc
3302 : integer :: ierr
3303 :
3304 0 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map)
3305 0 : call pio_read_darray(File, varid, iodesc, hbuf, ierr)
3306 0 : call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_real: Error reading variable')
3307 0 : end subroutine cam_grid_read_darray_2d_real
3308 :
3309 : !---------------------------------------------------------------------------
3310 : !
3311 : ! cam_grid_read_darray_3d_real: Read a variable defined on this grid
3312 : !
3313 : !---------------------------------------------------------------------------
3314 0 : subroutine cam_grid_read_darray_3d_real(this, File, adims, fdims, hbuf, varid)
3315 0 : use pio, only: file_desc_t, io_desc_t, pio_read_darray
3316 : use pio, only: PIO_REAL
3317 : use cam_pio_utils, only: cam_pio_get_decomp
3318 :
3319 : ! Dummy arguments
3320 : class(cam_grid_t) :: this
3321 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3322 : integer, intent(in) :: adims(:)
3323 : integer, intent(in) :: fdims(:)
3324 : real(r4), intent(out) :: hbuf(:,:,:)
3325 : type(var_desc_t), intent(inout) :: varid
3326 :
3327 : ! Local variables
3328 : type(io_desc_t), pointer :: iodesc
3329 : integer :: ierr
3330 :
3331 0 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map)
3332 0 : call pio_read_darray(File, varid, iodesc, hbuf, ierr)
3333 0 : call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_: Error reading variable')
3334 0 : end subroutine cam_grid_read_darray_3d_real
3335 :
3336 : !---------------------------------------------------------------------------
3337 : !
3338 : ! cam_grid_write_darray_2d_int: Write a variable defined on this grid
3339 : !
3340 : !---------------------------------------------------------------------------
3341 1536 : subroutine cam_grid_write_darray_2d_int(this, File, adims, fdims, hbuf, varid)
3342 0 : use pio, only: file_desc_t, io_desc_t
3343 : use pio, only: pio_write_darray, PIO_INT
3344 :
3345 : use cam_pio_utils, only: cam_pio_get_decomp
3346 :
3347 : ! Dummy arguments
3348 : class(cam_grid_t) :: this
3349 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3350 : integer, intent(in) :: adims(:)
3351 : integer, intent(in) :: fdims(:)
3352 : integer, intent(in) :: hbuf(:,:)
3353 : type(var_desc_t), intent(inout) :: varid
3354 :
3355 : ! Local variables
3356 : type(io_desc_t), pointer :: iodesc
3357 : integer :: ierr
3358 :
3359 1536 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map)
3360 1536 : call pio_write_darray(File, varid, iodesc, hbuf, ierr)
3361 1536 : call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_int: Error writing variable')
3362 1536 : end subroutine cam_grid_write_darray_2d_int
3363 :
3364 : !---------------------------------------------------------------------------
3365 : !
3366 : ! cam_grid_write_darray_3d_int: Write a variable defined on this grid
3367 : !
3368 : !---------------------------------------------------------------------------
3369 0 : subroutine cam_grid_write_darray_3d_int(this, File, adims, fdims, hbuf, varid)
3370 1536 : use pio, only: file_desc_t, io_desc_t
3371 : use pio, only: pio_write_darray, PIO_INT
3372 : use cam_pio_utils, only: cam_pio_get_decomp
3373 :
3374 : ! Dummy arguments
3375 : class(cam_grid_t) :: this
3376 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3377 : integer, intent(in) :: adims(:)
3378 : integer, intent(in) :: fdims(:)
3379 : integer, intent(in) :: hbuf(:,:,:)
3380 : type(var_desc_t), intent(inout) :: varid
3381 :
3382 : ! Local variables
3383 : type(io_desc_t), pointer :: iodesc
3384 : integer :: ierr
3385 :
3386 0 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map)
3387 0 : call pio_write_darray(File, varid, iodesc, hbuf, ierr)
3388 0 : call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_int: Error writing variable')
3389 0 : end subroutine cam_grid_write_darray_3d_int
3390 :
3391 : !---------------------------------------------------------------------------
3392 : !
3393 : ! cam_grid_write_darray_2d_double: Write a variable defined on this grid
3394 : !
3395 : !---------------------------------------------------------------------------
3396 36864 : subroutine cam_grid_write_darray_2d_double(this, File, adims, fdims, hbuf, varid)
3397 0 : use pio, only: file_desc_t, io_desc_t
3398 : use pio, only: pio_write_darray, PIO_DOUBLE
3399 : use cam_pio_utils, only: cam_pio_get_decomp
3400 :
3401 : ! Dummy arguments
3402 : class(cam_grid_t) :: this
3403 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3404 : integer, intent(in) :: adims(:)
3405 : integer, intent(in) :: fdims(:)
3406 : real(r8), intent(in) :: hbuf(:,:)
3407 : type(var_desc_t), intent(inout) :: varid
3408 :
3409 : ! Local variables
3410 : type(io_desc_t), pointer :: iodesc
3411 : integer :: ierr
3412 :
3413 36864 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map)
3414 36864 : call pio_write_darray(File, varid, iodesc, hbuf, ierr)
3415 36864 : call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_double: Error writing variable')
3416 36864 : end subroutine cam_grid_write_darray_2d_double
3417 :
3418 : !---------------------------------------------------------------------------
3419 : !
3420 : ! cam_grid_write_darray_3d_double: Write a variable defined on this grid
3421 : !
3422 : !---------------------------------------------------------------------------
3423 133632 : subroutine cam_grid_write_darray_3d_double(this, File, adims, fdims, hbuf, varid)
3424 36864 : use pio, only: file_desc_t, io_desc_t
3425 : use pio, only: pio_write_darray, PIO_DOUBLE
3426 : use cam_pio_utils, only: cam_pio_get_decomp
3427 :
3428 : ! Dummy arguments
3429 : class(cam_grid_t) :: this
3430 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3431 : integer, intent(in) :: adims(:)
3432 : integer, intent(in) :: fdims(:)
3433 : real(r8), intent(in) :: hbuf(:,:,:)
3434 : type(var_desc_t), intent(inout) :: varid
3435 :
3436 : ! Local variables
3437 : type(io_desc_t), pointer :: iodesc
3438 : integer :: ierr
3439 :
3440 133632 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map)
3441 133632 : call pio_write_darray(File, varid, iodesc, hbuf, ierr)
3442 133632 : call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_double: Error writing variable')
3443 :
3444 133632 : end subroutine cam_grid_write_darray_3d_double
3445 :
3446 : !---------------------------------------------------------------------------
3447 : !
3448 : ! cam_grid_write_darray_2d_real: Write a variable defined on this grid
3449 : !
3450 : !---------------------------------------------------------------------------
3451 7127040 : subroutine cam_grid_write_darray_2d_real(this, File, adims, fdims, hbuf, varid)
3452 133632 : use pio, only: file_desc_t, io_desc_t
3453 : use pio, only: pio_write_darray, PIO_REAL
3454 : use cam_pio_utils, only: cam_pio_get_decomp
3455 :
3456 : ! Dummy arguments
3457 : class(cam_grid_t) :: this
3458 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3459 : integer, intent(in) :: adims(:)
3460 : integer, intent(in) :: fdims(:)
3461 : real(r4), intent(in) :: hbuf(:,:)
3462 : type(var_desc_t), intent(inout) :: varid
3463 :
3464 : ! Local variables
3465 : type(io_desc_t), pointer :: iodesc
3466 : integer :: ierr
3467 :
3468 7127040 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map)
3469 7127040 : call pio_write_darray(File, varid, iodesc, hbuf, ierr)
3470 7127040 : call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_real: Error writing variable')
3471 7127040 : end subroutine cam_grid_write_darray_2d_real
3472 :
3473 : !---------------------------------------------------------------------------
3474 : !
3475 : ! cam_grid_write_darray_3d_real: Write a variable defined on this grid
3476 : !
3477 : !---------------------------------------------------------------------------
3478 10813440 : subroutine cam_grid_write_darray_3d_real(this, File, adims, fdims, hbuf, varid)
3479 7127040 : use pio, only: file_desc_t, io_desc_t
3480 : use pio, only: pio_write_darray, PIO_REAL
3481 : use cam_pio_utils, only: cam_pio_get_decomp
3482 :
3483 : ! Dummy arguments
3484 : class(cam_grid_t) :: this
3485 : type(file_desc_t), intent(inout) :: File ! PIO file handle
3486 : integer, intent(in) :: adims(:)
3487 : integer, intent(in) :: fdims(:)
3488 : real(r4), intent(in) :: hbuf(:,:,:)
3489 : type(var_desc_t), intent(inout) :: varid
3490 :
3491 : ! Local variables
3492 : type(io_desc_t), pointer :: iodesc
3493 : integer :: ierr
3494 :
3495 10813440 : nullify(iodesc)
3496 10813440 : call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map)
3497 10813440 : call pio_write_darray(File, varid, iodesc, hbuf, ierr)
3498 10813440 : call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_real: Error writing variable')
3499 10813440 : end subroutine cam_grid_write_darray_3d_real
3500 :
3501 : !---------------------------------------------------------------------------
3502 : !
3503 : ! cam_grid_get_patch_mask: Compute a map which is defined for locations
3504 : ! within the input patch.
3505 : !
3506 : !---------------------------------------------------------------------------
3507 0 : subroutine cam_grid_get_patch_mask(this, lonl, lonu, latl, latu, patch, cco)
3508 10813440 : use spmd_utils, only: mpi_min, mpi_max, mpi_real8, mpicom
3509 : use physconst, only: pi
3510 :
3511 : ! Dummy arguments
3512 : class(cam_grid_t) :: this
3513 : real(r8), intent(in) :: lonl, lonu ! Longitude bounds
3514 : real(r8), intent(in) :: latl, latu ! Latitude bounds
3515 : type(cam_grid_patch_t), intent(inout) :: patch
3516 : logical, intent(in) :: cco ! Collect columns?
3517 :
3518 : ! Local arguments
3519 : real(r8) :: mindist, minlondist
3520 : real(r8) :: dist, temp1, temp2 ! Test distance calc
3521 : real(r8) :: londeg, latdeg
3522 : real(r8) :: lon, lat
3523 : real(r8) :: londeg_min, latdeg_min
3524 : real(r8) :: lonmin, lonmax, latmin, latmax
3525 : integer :: minind ! Location of closest point
3526 : integer :: mapind ! Grid map index
3527 : integer :: latind, lonind
3528 : integer :: ierr ! For MPI calls
3529 : integer :: dims(2) ! Global dim sizes
3530 : integer :: gridloc ! local size of grid
3531 : logical :: unstructured ! grid type
3532 : logical :: findClosest ! .false. == patch output
3533 : logical :: isMapped ! .true. iff point in map
3534 :
3535 : real(r8), parameter :: maxangle = pi / 4.0_r8
3536 : real(r8), parameter :: deg2rad = pi / 180.0_r8
3537 : real(r8), parameter :: maxtol = 0.99999_r8 ! max cos value
3538 : real(r8), parameter :: maxlat = pi * maxtol / 2.0_r8
3539 : character(len=*), parameter :: subname = 'cam_grid_get_patch_mask'
3540 :
3541 0 : if (.not. associated(this%map)) then
3542 0 : call endrun('cam_grid_get_patch_mask: Grid, '//trim(this%name)//', has no map')
3543 : end if
3544 0 : gridloc = this%map%num_elem()
3545 0 : unstructured = this%is_unstructured()
3546 0 : call this%coord_lengths(dims)
3547 0 : if (associated(patch%mask)) then
3548 0 : if (patch%mask%num_elem() /= gridloc) then
3549 : ! The mask needs to be the same size as the map
3550 0 : call endrun(subname//': mask is incorrect size')
3551 : ! No else, just needed a check
3552 : ! In particular, we are not zeroing the mask since multiple calls with
3553 : ! the same mask can be used for collected-column output
3554 : ! NB: Compacting the mask must be done after all calls (for a
3555 : ! particular mask) to this function.
3556 : end if
3557 0 : if (patch%collected_columns .neqv. cco) then
3558 0 : call endrun(subname//': collected_column mismatch')
3559 : end if
3560 : else
3561 0 : if (associated(patch%latmap)) then
3562 0 : call endrun(subname//': unallocated patch has latmap')
3563 : end if
3564 0 : if (associated(patch%lonmap)) then
3565 0 : call endrun(subname//': unallocated patch has lonmap')
3566 : end if
3567 0 : call patch%set_patch(lonl, lonu, latl, latu, cco, this%id, this%map)
3568 0 : if (patch%mask%num_elem() /= gridloc) then
3569 : ! Basic check to make sure the copy worked
3570 0 : call endrun(subname//': grid map is invalid')
3571 : end if
3572 0 : call patch%mask%clear()
3573 : ! Set up the lat/lon maps
3574 0 : if (cco) then
3575 : ! For collected column output, we need to collect coordinates and values
3576 0 : allocate(patch%latmap(patch%mask%num_elem()))
3577 0 : patch%latmap = 0
3578 0 : allocate(patch%latvals(patch%mask%num_elem()))
3579 0 : patch%latvals = 91.0_r8
3580 0 : allocate(patch%lonmap(patch%mask%num_elem()))
3581 0 : patch%lonmap = 0
3582 0 : allocate(patch%lonvals(patch%mask%num_elem()))
3583 0 : patch%lonvals = 361.0_r8
3584 : else
3585 0 : if (associated(this%lat_coord%values)) then
3586 0 : allocate(patch%latmap(LBOUND(this%lat_coord%values, 1):UBOUND(this%lat_coord%values, 1)))
3587 0 : patch%latmap = 0
3588 : else
3589 0 : nullify(patch%latmap)
3590 : end if
3591 0 : if (associated(this%lon_coord%values)) then
3592 0 : allocate(patch%lonmap(LBOUND(this%lon_coord%values, 1):UBOUND(this%lon_coord%values, 1)))
3593 0 : patch%lonmap = 0
3594 : else
3595 0 : nullify(patch%lonmap)
3596 : end if
3597 : end if
3598 : end if
3599 :
3600 : ! We have to iterate through each grid point to check
3601 : ! We have four cases, structured vs. unstructured grid *
3602 : ! patch area vs. closest column
3603 : ! Note that a 1-d patch 'area' is not allowed for unstructured grids
3604 0 : findClosest = .false.
3605 : ! Make sure our search items are in order
3606 0 : lonmin = min(lonl, lonu)
3607 0 : lonmax = max(lonl, lonu)
3608 0 : latmin = min(latl, latu)
3609 0 : latmax = max(latl, latu)
3610 0 : if (lonl == lonu) then
3611 0 : if (latl == latu) then
3612 : findClosest = .true.
3613 0 : else if (unstructured) then
3614 0 : call endrun(subname//': 1-D patch (lon) not allowed for unstructured grids')
3615 : else
3616 : ! Find closest lon line to lonu
3617 : ! This is a lat lon grid so it should have coordinate axes
3618 0 : lonmin = 365.0_r8
3619 0 : mindist = 365.0_r8
3620 0 : if (associated(this%lon_coord%values)) then
3621 0 : do lonind = LBOUND(this%lon_coord%values, 1), UBOUND(this%lon_coord%values, 1)
3622 0 : dist = abs(this%lon_coord%values(lonind) - lonu)
3623 0 : if (dist < mindist) then
3624 0 : lonmin = this%lon_coord%values(lonind)
3625 0 : mindist = dist
3626 : end if
3627 : end do
3628 : end if
3629 : ! Get the global minimum
3630 0 : dist = mindist
3631 0 : call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr)
3632 0 : if (dist == mindist) then
3633 : ! We have a ringer so use only that longitude
3634 : lonmax = lonmin
3635 : else
3636 : ! We don't have a minimum dist so count no points
3637 0 : lonmax = lonmin - 1.0_r8
3638 : end if
3639 : end if
3640 0 : else if (latl == latu) then
3641 0 : if (unstructured) then
3642 0 : call endrun(subname//': 1-D patch (lat) not allowed for unstructured grids')
3643 : else
3644 : ! Find closest lat line to latu
3645 : ! This is a lat lon grid so it should have coordinate axes
3646 0 : latmin = 91.0_r8
3647 0 : mindist = 181.0_r8
3648 0 : if (associated(this%lat_coord%values)) then
3649 0 : do latind = LBOUND(this%lat_coord%values, 1), UBOUND(this%lat_coord%values, 1)
3650 0 : dist = abs(this%lat_coord%values(latind) - latl)
3651 0 : if (dist < mindist) then
3652 0 : latmin = this%lat_coord%values(latind)
3653 0 : mindist = dist
3654 : end if
3655 : end do
3656 : end if
3657 : ! Get the global minimum
3658 0 : dist = mindist
3659 0 : call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr)
3660 0 : if (dist == mindist) then
3661 : ! We have a ringer so use only that latitude
3662 : latmax = latmin
3663 : else
3664 : ! We don't have a minimum dist so count no points
3665 0 : latmax = latmin - 1.0_r8
3666 : end if
3667 : end if
3668 : end if
3669 :
3670 : ! Convert to radians
3671 0 : lonmin = lonmin * deg2rad
3672 0 : lonmax = lonmax * deg2rad
3673 0 : latmin = latmin * deg2rad
3674 0 : latmax = latmax * deg2rad
3675 : ! Loop through all the local grid elements and find the closest match
3676 : ! (or all matches depending on the value of findClosest)
3677 0 : minind = -1
3678 0 : londeg_min = 361.0_r8
3679 0 : latdeg_min = 91.0_r8
3680 0 : mindist = 2.0_r8 * pi
3681 :
3682 0 : do mapind = 1, patch%mask%num_elem()
3683 0 : call this%get_lon_lat(mapind, londeg, latdeg, isMapped)
3684 0 : if (isMapped) then
3685 0 : lon = londeg * deg2rad
3686 0 : lat = latdeg * deg2rad
3687 0 : if (findClosest) then
3688 : ! Use the Spherical Law of Cosines to find the great-circle distance.
3689 : ! Might as well use the unit sphere since we just want differences
3690 0 : if ( (abs(lat - latmin) <= maxangle) .and. &
3691 : (abs(lon - lonmin) <= maxangle)) then
3692 : ! maxangle could be pi but why waste all those trig functions?
3693 : ! XXgoldyXX: What should we use for maxangle given coarse Eul grids?
3694 0 : if ((lat == latmin) .and. (lon == lonmin)) then
3695 0 : dist = 0.0_r8
3696 : else
3697 : temp1 = (sin(latmin) * sin(lat)) + &
3698 0 : (cos(latmin) * cos(lat) * cos(lon - lonmin))
3699 0 : if (temp1 > maxtol) then
3700 : ! Use haversine formula
3701 0 : temp1 = sin(latmin - lat)
3702 0 : temp2 = sin((lonmin - lon) / 2.0_r8)
3703 0 : dist = 2.0_r8 * asin((temp1*temp1) + (cos(latmin)*cos(lat)*temp2*temp2))
3704 : else
3705 0 : dist = acos(temp1)
3706 : end if
3707 : end if
3708 0 : if ( (dist < mindist) .or. &
3709 : ((dist == mindist) .and. &
3710 : (abs(lon - lonmin) < abs(londeg_min*deg2rad - lonmin)))) then
3711 0 : minind = mapind
3712 0 : mindist = dist
3713 0 : londeg_min = londeg
3714 0 : latdeg_min = latdeg
3715 : end if
3716 : end if
3717 : else
3718 : if ( (latmin <= lat) .and. (lat <= latmax) .and. &
3719 0 : (lonmin <= lon) .and. (lon <= lonmax)) then
3720 0 : if (patch%mask%num_elem() >= mapind) then
3721 0 : if (.not. patch%mask%is_mapped(mapind)) then
3722 0 : call patch%mask%copy_elem(this%map, mapind)
3723 0 : patch%num_points = patch%num_points + 1
3724 0 : if (cco) then
3725 0 : if (patch%num_points > size(patch%latvals, 1)) then
3726 0 : call endrun(subname//': Number of cols larger than mask!?')
3727 : end if
3728 0 : call this%map%coord_dests(mapind, lonind, latind)
3729 0 : if (latind > 0) then
3730 : ! Grid is structured, get unique index
3731 0 : lonind = lonind + (latind * dims(1))
3732 : end if
3733 0 : patch%latmap(patch%num_points) = lonind
3734 0 : patch%latvals(patch%num_points) = latdeg
3735 0 : patch%lonmap(patch%num_points) = lonind
3736 0 : patch%lonvals(patch%num_points) = londeg
3737 0 : else if ((this%block_indexed) .or. unstructured) then
3738 0 : call this%map%coord_dests(mapind, lonind, latind)
3739 0 : if (latind == 0) then
3740 0 : latind = lonind
3741 : end if
3742 0 : if (associated(patch%latmap)) then
3743 0 : patch%latmap(mapind) = latind
3744 : end if
3745 0 : if (associated(patch%lonmap)) then
3746 0 : patch%lonmap(mapind) = lonind
3747 : end if
3748 : else
3749 0 : call this%map%coord_vals(mapind, lonind, latind)
3750 0 : if (associated(patch%latmap)) then
3751 0 : patch%latmap(latind) = latind
3752 : end if
3753 0 : if (associated(patch%lonmap)) then
3754 0 : patch%lonmap(lonind) = lonind
3755 : end if
3756 : end if
3757 : ! else do nothing, we already found this point
3758 : end if
3759 : else
3760 0 : call endrun(subname//': PE has patch points but mask too small')
3761 : end if
3762 : end if
3763 : end if ! findClosest
3764 : end if ! isMapped
3765 : end do
3766 0 : if (findClosest) then
3767 : ! We need to find the minimum mindist and use only that value
3768 0 : dist = mindist
3769 0 : call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr)
3770 : ! Special case for pole points
3771 0 : if (latdeg_min > 90.0_r8) then
3772 0 : temp1 = 0.0_r8
3773 : else
3774 0 : temp1 = abs(latdeg_min*deg2rad)
3775 : end if
3776 0 : call MPI_allreduce(temp1, lat, 1, mpi_real8, mpi_max, mpicom, ierr)
3777 0 : if ((abs(latmin) > maxlat) .or. (lat > maxlat)) then
3778 0 : if (dist == mindist) then
3779 : ! Only distance winners can compete
3780 0 : lon = abs(londeg_min - lonl)
3781 : else
3782 0 : lon = 361.0_r8
3783 : end if
3784 0 : call MPI_allreduce(lon, minlondist, 1, mpi_real8, mpi_min, mpicom, ierr)
3785 : ! Kill the losers
3786 0 : if (lon /= minlondist) then
3787 0 : dist = dist + 1.0_r8
3788 : end if
3789 : end if
3790 : ! Now, only task(s) which have real minimum distance should set their mask
3791 : ! minind test allows for no match
3792 0 : if (dist == mindist) then
3793 0 : if (minind < 0) then
3794 0 : call endrun("cam_grid_get_patch_mask: No closest point found!!")
3795 : else
3796 0 : if (patch%mask%num_elem() >= minind) then
3797 0 : if (.not. patch%mask%is_mapped(minind)) then
3798 0 : call patch%mask%copy_elem(this%map, minind)
3799 0 : patch%num_points = patch%num_points + 1
3800 0 : if (cco) then
3801 0 : if (patch%num_points > size(patch%latvals, 1)) then
3802 0 : call endrun(subname//': Number of columns larger than mask!?')
3803 : end if
3804 0 : call this%map%coord_dests(minind, lonind, latind)
3805 0 : if (latind > 0) then
3806 : ! Grid is structured, get unique index
3807 0 : lonind = lonind + (latind * dims(1))
3808 : end if
3809 0 : patch%latmap(patch%num_points) = lonind
3810 0 : patch%latvals(patch%num_points) = latdeg_min
3811 0 : patch%lonmap(patch%num_points) = lonind
3812 0 : patch%lonvals(patch%num_points) = londeg_min
3813 0 : else if ((this%block_indexed) .or. unstructured) then
3814 0 : call this%map%coord_dests(minind, lonind, latind)
3815 0 : if (latind == 0) then
3816 0 : latind = lonind
3817 : end if
3818 0 : if (associated(patch%latmap)) then
3819 0 : patch%latmap(minind) = latind
3820 : end if
3821 0 : if (associated(patch%lonmap)) then
3822 0 : patch%lonmap(minind) = lonind
3823 : end if
3824 : else
3825 0 : call this%map%coord_vals(minind, lonind, latind)
3826 0 : if (associated(patch%latmap)) then
3827 0 : patch%latmap(latind) = latind
3828 : end if
3829 0 : if (associated(patch%lonmap)) then
3830 0 : patch%lonmap(lonind) = lonind
3831 : end if
3832 : end if
3833 : ! else do nothing, we already found this point
3834 : end if
3835 : else
3836 0 : call endrun(subname//': PE has patch closest point but mask too small')
3837 : end if
3838 : end if
3839 : end if
3840 : end if ! findClosest
3841 :
3842 0 : end subroutine cam_grid_get_patch_mask
3843 :
3844 : !---------------------------------------------------------------------------
3845 : !
3846 : ! Grid Patch functions
3847 : !
3848 : !---------------------------------------------------------------------------
3849 :
3850 0 : integer function cam_grid_patch_get_id(this) result(id)
3851 :
3852 : ! Dummy argument
3853 : class(cam_grid_patch_t) :: this
3854 :
3855 0 : id = this%grid_id
3856 0 : end function cam_grid_patch_get_id
3857 :
3858 0 : subroutine cam_grid_patch_get_global_size_map(this, gsize)
3859 :
3860 : ! Dummy arguments
3861 : class(cam_grid_patch_t), intent(in) :: this
3862 : integer, intent(out) :: gsize
3863 :
3864 0 : gsize = this%global_size
3865 :
3866 0 : end subroutine cam_grid_patch_get_global_size_map
3867 :
3868 0 : subroutine cam_grid_patch_get_global_size_axes(this, latsize, lonsize)
3869 :
3870 : ! Dummy arguments
3871 : class(cam_grid_patch_t), intent(in) :: this
3872 : integer, intent(out) :: latsize
3873 : integer, intent(out) :: lonsize
3874 :
3875 0 : latsize = this%global_lat_size
3876 0 : lonsize = this%global_lon_size
3877 :
3878 0 : end subroutine cam_grid_patch_get_global_size_axes
3879 :
3880 : ! cam_grid_patch_get_axis_names
3881 : ! Collect or compute unique names for the latitude and longitude axes
3882 : ! If the grid is unstructured or col_output is .true., the column
3883 : ! dimension name is also generated (e.g., ncol)
3884 0 : subroutine cam_grid_patch_get_axis_names(this, lat_name, lon_name, &
3885 : col_name, col_output)
3886 :
3887 : ! Dummy arguments
3888 : class(cam_grid_patch_t) :: this
3889 : character(len=*), intent(out) :: lat_name
3890 : character(len=*), intent(out) :: lon_name
3891 : character(len=*), intent(out) :: col_name
3892 : logical, intent(in) :: col_output
3893 :
3894 : ! Local variable
3895 : integer :: index
3896 : character(len=120) :: errormsg
3897 : character(len=max_hcoordname_len) :: grid_name
3898 : logical :: unstruct
3899 :
3900 0 : if (cam_grid_check(this%grid_id)) then
3901 0 : index = this%grid_index()
3902 0 : unstruct = cam_grids(index)%is_unstructured()
3903 : ! Get coordinate and dim names
3904 0 : call cam_grids(index)%lat_coord%get_coord_name(lat_name)
3905 0 : call cam_grids(index)%lon_coord%get_coord_name(lon_name)
3906 0 : grid_name = cam_grids(index)%name
3907 0 : if (col_output .or. unstruct) then
3908 : ! In this case, we are using collect_column_output on a lat/lon grid
3909 0 : col_name = 'ncol_'//trim(grid_name)
3910 0 : lat_name = trim(lat_name)//'_'//trim(grid_name)
3911 0 : lon_name = trim(lon_name)//'_'//trim(grid_name)
3912 : else
3913 : ! Separate patch output for a lat/lon grid
3914 0 : col_name = ''
3915 0 : lat_name = trim(lat_name)//'_'//trim(grid_name)
3916 0 : lon_name = trim(lon_name)//'_'//trim(grid_name)
3917 : end if
3918 : else
3919 0 : write(errormsg, *) 'Bad grid ID:', this%grid_id
3920 0 : call endrun('cam_grid_patch_get_axis_names: '//errormsg)
3921 : end if
3922 :
3923 0 : end subroutine cam_grid_patch_get_axis_names
3924 :
3925 0 : subroutine cam_grid_patch_get_coord_long_name(this, axis, name)
3926 :
3927 : ! Dummy arguments
3928 : class(cam_grid_patch_t) :: this
3929 : character(len=*), intent(in) :: axis
3930 : character(len=*), intent(out) :: name
3931 :
3932 : ! Local variable
3933 : character(len=120) :: errormsg
3934 : integer :: index
3935 :
3936 0 : if (cam_grid_check(this%grid_id)) then
3937 0 : index = this%grid_index()
3938 0 : if (trim(axis) == 'lat') then
3939 0 : call cam_grids(index)%lat_coord%get_long_name(name)
3940 0 : else if (trim(axis) == 'lon') then
3941 0 : call cam_grids(index)%lon_coord%get_long_name(name)
3942 : else
3943 0 : write(errormsg, *) 'Bad axis name:', axis
3944 0 : call endrun('cam_grid_patch_get_coord_long_name: '//errormsg)
3945 : end if
3946 : else
3947 0 : write(errormsg, *) 'Bad grid ID:', this%grid_id
3948 0 : call endrun('cam_grid_patch_get_coord_long_name: '//errormsg)
3949 : end if
3950 :
3951 0 : end subroutine cam_grid_patch_get_coord_long_name
3952 :
3953 0 : subroutine cam_grid_patch_get_coord_units(this, axis, units)
3954 :
3955 : ! Dummy arguments
3956 : class(cam_grid_patch_t) :: this
3957 : character(len=*), intent(in) :: axis
3958 : character(len=*), intent(out) :: units
3959 :
3960 : ! Local variable
3961 : character(len=120) :: errormsg
3962 : integer :: index
3963 :
3964 0 : if (cam_grid_check(this%grid_id)) then
3965 0 : index = this%grid_index()
3966 0 : if (trim(axis) == 'lat') then
3967 0 : call cam_grids(index)%lat_coord%get_units(units)
3968 0 : else if (trim(axis) == 'lon') then
3969 0 : call cam_grids(index)%lon_coord%get_units(units)
3970 : else
3971 0 : write(errormsg, *) 'Bad axis name:', axis
3972 0 : call endrun('cam_grid_patch_get_coord_units: '//errormsg)
3973 : end if
3974 : else
3975 0 : write(errormsg, *) 'Bad grid ID:', this%grid_id
3976 0 : call endrun('cam_grid_patch_get_coord_units: '//errormsg)
3977 : end if
3978 :
3979 0 : end subroutine cam_grid_patch_get_coord_units
3980 :
3981 0 : subroutine cam_grid_patch_set_patch(this, lonl, lonu, latl, latu, cco, id, map)
3982 :
3983 : ! Dummy arguments
3984 : class(cam_grid_patch_t) :: this
3985 : real(r8), intent(in) :: lonl, lonu ! Longitude bounds
3986 : real(r8), intent(in) :: latl, latu ! Latitude bounds
3987 : logical, intent(in) :: cco ! Collect columns?
3988 : integer, intent(in) :: id
3989 : type(cam_filemap_t), intent(in) :: map
3990 :
3991 0 : this%grid_id = id
3992 0 : this%lon_range(1) = lonl
3993 0 : this%lon_range(2) = lonu
3994 0 : this%lat_range(1) = latl
3995 0 : this%lat_range(2) = latu
3996 0 : this%collected_columns = cco
3997 0 : if (.not. associated(this%mask)) then
3998 0 : allocate(this%mask)
3999 : end if
4000 0 : call this%mask%copy(map)
4001 0 : call this%mask%new_index()
4002 :
4003 0 : end subroutine cam_grid_patch_set_patch
4004 :
4005 0 : subroutine cam_grid_patch_get_decomp(this, field_lens, file_lens, dtype, &
4006 0 : iodesc, file_dest_in)
4007 : use pio, only: io_desc_t
4008 : use cam_pio_utils, only: cam_pio_get_decomp
4009 :
4010 : ! Dummy arguments
4011 : class(cam_grid_patch_t) :: this
4012 : integer, intent(in) :: field_lens(:)
4013 : integer, intent(in) :: file_lens(:)
4014 : integer, intent(in) :: dtype
4015 : type(io_desc_t), pointer, intent(out) :: iodesc
4016 : integer, optional, intent(in) :: file_dest_in(:)
4017 :
4018 : call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, this%mask, &
4019 0 : file_dist_in=file_dest_in)
4020 :
4021 0 : end subroutine cam_grid_patch_get_decomp
4022 :
4023 0 : subroutine cam_grid_patch_compact(this, collected_output)
4024 :
4025 : ! Dummy arguments
4026 : class(cam_grid_patch_t) :: this
4027 : logical, optional, intent(in) :: collected_output
4028 :
4029 : ! Local variables
4030 : integer :: index ! Our grid's index
4031 : logical :: dups_ok
4032 :
4033 0 : index = this%grid_index()
4034 0 : if (index > 0) then
4035 0 : dups_ok = cam_grids(index)%is_unstructured()
4036 : else
4037 : ! This is probably an error condition but someone else will catch it first
4038 0 : dups_ok = .false.
4039 : end if
4040 0 : if (present(collected_output)) then
4041 0 : dups_ok = dups_ok .or. collected_output
4042 : end if
4043 : call this%mask%compact(this%lonmap, this%latmap, &
4044 : num_lons=this%global_lon_size, num_lats=this%global_lat_size, &
4045 : num_mapped=this%global_size, columnize=collected_output, &
4046 0 : dups_ok_in=dups_ok)
4047 :
4048 0 : end subroutine cam_grid_patch_compact
4049 :
4050 0 : subroutine cam_grid_patch_get_active_cols(this, lchnk, active, srcdim_in)
4051 :
4052 : ! Dummy arguments
4053 : class(cam_grid_patch_t) :: this
4054 : integer, intent(in) :: lchnk
4055 : logical, intent(out) :: active(:)
4056 : integer, optional, intent(in) :: srcdim_in
4057 :
4058 0 : if (.not. associated(this%mask)) then
4059 0 : call endrun('cam_grid_patch_get_active_cols: No mask')
4060 : else
4061 0 : call this%mask%active_cols(lchnk, active, srcdim_in)
4062 : end if
4063 :
4064 0 : end subroutine cam_grid_patch_get_active_cols
4065 :
4066 : ! cam_grid_patch_write_vals: Write lat and lon coord values to File
4067 0 : subroutine cam_grid_patch_write_vals(this, File, header_info)
4068 : use pio, only: file_desc_t, io_desc_t
4069 : use pio, only: pio_write_darray, PIO_DOUBLE
4070 : use pio, only: pio_initdecomp, pio_freedecomp
4071 : use cam_pio_utils, only: cam_pio_handle_error, pio_subsystem
4072 :
4073 : ! Dummy arguments
4074 : class(cam_grid_patch_t) :: this
4075 : type(file_desc_t), intent(inout) :: File ! PIO file handle
4076 : type(cam_grid_header_info_t), intent(inout) :: header_info
4077 :
4078 : ! Local variables
4079 : type(io_desc_t) :: iodesc
4080 : type(var_desc_t), pointer :: vdesc
4081 0 : real(r8), pointer :: coord_p(:)
4082 0 : real(r8), pointer :: coord(:)
4083 0 : integer(iMap), pointer :: map(:)
4084 : integer :: field_lens(1)
4085 : integer :: file_lens(1)
4086 : integer :: ierr
4087 :
4088 0 : nullify(vdesc)
4089 0 : nullify(coord_p)
4090 0 : nullify(coord)
4091 0 : nullify(map)
4092 0 : if (this%grid_id /= header_info%get_gridid()) then
4093 0 : call endrun('CAM_GRID_PATCH_WRITE_VALS: Grid id mismatch')
4094 : end if
4095 : ! Write out lon
4096 0 : if (associated(this%lonmap)) then
4097 0 : field_lens(1) = size(this%lonmap, 1)
4098 0 : map => this%lonmap
4099 : else
4100 0 : field_lens(1) = 0
4101 0 : allocate(map(0))
4102 : end if
4103 0 : file_lens(1) = this%global_lon_size
4104 : !! XXgoldyXX: Think about caching these decomps
4105 0 : call pio_initdecomp(pio_subsystem, pio_double, file_lens, map, iodesc)
4106 0 : if (associated(this%lonvals)) then
4107 0 : coord => this%lonvals
4108 : else
4109 0 : coord_p => cam_grid_get_lonvals(this%grid_id)
4110 0 : if (associated(coord_p)) then
4111 0 : coord => coord_p
4112 : else
4113 0 : allocate(coord(0))
4114 : end if
4115 : end if
4116 0 : vdesc => header_info%get_lon_varid()
4117 0 : call pio_write_darray(File, vdesc, iodesc, coord, ierr)
4118 0 : call cam_pio_handle_error(ierr, 'cam_grid_patch_write_vals: Error writing longitude')
4119 0 : if (.not. associated(this%lonmap)) then
4120 0 : deallocate(map)
4121 : nullify(map)
4122 : end if
4123 0 : if (.not. (associated(coord_p) .or. associated(this%lonvals))) then
4124 0 : deallocate(coord)
4125 : nullify(coord)
4126 : end if
4127 0 : call pio_freedecomp(File, iodesc)
4128 : ! Write out lat
4129 0 : if (associated(this%latmap)) then
4130 0 : field_lens(1) = size(this%latmap, 1)
4131 0 : map => this%latmap
4132 : else
4133 0 : field_lens(1) = 0
4134 0 : allocate(map(0))
4135 : end if
4136 0 : file_lens(1) = this%global_lat_size
4137 : !! XXgoldyXX: Think about caching these decomps
4138 0 : call pio_initdecomp(pio_subsystem, pio_double, file_lens, map, iodesc)
4139 :
4140 0 : if (associated(this%latvals)) then
4141 0 : coord => this%latvals
4142 : else
4143 0 : coord_p => cam_grid_get_latvals(this%grid_id)
4144 0 : if (associated(coord_p)) then
4145 0 : coord => coord_p
4146 : else
4147 0 : allocate(coord(0))
4148 : end if
4149 : end if
4150 0 : vdesc => header_info%get_lat_varid()
4151 0 : call pio_write_darray(File, vdesc, iodesc, coord, ierr)
4152 0 : call cam_pio_handle_error(ierr, 'cam_grid_patch_write_vals: Error writing latitude')
4153 0 : if (.not. associated(this%latmap)) then
4154 0 : deallocate(map)
4155 : nullify(map)
4156 : end if
4157 0 : if (.not. (associated(coord_p) .or. associated(this%latvals))) then
4158 0 : deallocate(coord)
4159 : nullify(coord)
4160 : end if
4161 0 : call pio_freedecomp(File, iodesc)
4162 :
4163 0 : end subroutine cam_grid_patch_write_vals
4164 :
4165 0 : integer function cam_grid_patch_get_grid_index(this) result(index)
4166 : ! Dummy argument
4167 : class(cam_grid_patch_t) :: this
4168 :
4169 : ! Local variable
4170 : integer :: i
4171 :
4172 0 : index = -1
4173 : ! Find the grid index associated with our grid_id which is a decomp
4174 0 : do i = 1, cam_grid_num_grids()
4175 0 : if (cam_grids(i)%id == this%grid_id) then
4176 : index = i
4177 : exit
4178 : end if
4179 : end do
4180 :
4181 0 : end function cam_grid_patch_get_grid_index
4182 :
4183 0 : subroutine cam_grid_patch_deallocate(this)
4184 : ! Dummy argument
4185 : class(cam_grid_patch_t) :: this
4186 :
4187 0 : if (associated(this%mask)) then
4188 0 : deallocate(this%mask)
4189 0 : nullify(this%mask)
4190 : end if
4191 :
4192 0 : end subroutine cam_grid_patch_deallocate
4193 :
4194 17940480 : integer function cam_grid_header_info_get_gridid(this) result(id)
4195 : ! Dummy argument
4196 : class(cam_grid_header_info_t) :: this
4197 :
4198 17940480 : id = this%grid_id
4199 :
4200 17940480 : end function cam_grid_header_info_get_gridid
4201 :
4202 0 : subroutine cam_grid_header_info_set_gridid(this, id)
4203 : ! Dummy argument
4204 : class(cam_grid_header_info_t) :: this
4205 : integer, intent(in) :: id
4206 :
4207 0 : this%grid_id = id
4208 :
4209 0 : end subroutine cam_grid_header_info_set_gridid
4210 :
4211 0 : subroutine cam_grid_header_info_set_hdims(this, hdim1, hdim2)
4212 : ! Dummy arguments
4213 : class(cam_grid_header_info_t) :: this
4214 : integer, intent(in) :: hdim1
4215 : integer, optional, intent(in) :: hdim2
4216 :
4217 : ! Local variables
4218 : integer :: hdsize
4219 :
4220 0 : if (present(hdim2)) then
4221 : hdsize = 2
4222 : else
4223 0 : hdsize = 1
4224 : end if
4225 :
4226 0 : if (allocated(this%hdims)) then
4227 : ! This can happen, for instance on opening a new version of the file
4228 0 : if (size(this%hdims) /= hdsize) then
4229 0 : call endrun('cam_grid_header_info_set_hdims: hdims is wrong size')
4230 : end if
4231 : else
4232 0 : allocate(this%hdims(hdsize))
4233 : end if
4234 0 : this%hdims(1) = hdim1
4235 0 : if (present(hdim2)) then
4236 0 : this%hdims(2) = hdim2
4237 : end if
4238 :
4239 0 : end subroutine cam_grid_header_info_set_hdims
4240 :
4241 17942016 : integer function cam_grid_header_info_num_hdims(this) result(num)
4242 : ! Dummy argument
4243 : class(cam_grid_header_info_t) :: this
4244 :
4245 17942016 : if (allocated(this%hdims)) then
4246 17942016 : num = size(this%hdims)
4247 : else
4248 : num = 0
4249 : end if
4250 :
4251 17942016 : end function cam_grid_header_info_num_hdims
4252 :
4253 17943552 : integer function cam_grid_header_info_hdim(this, index) result(id)
4254 : ! Dummy arguments
4255 : class(cam_grid_header_info_t) :: this
4256 : integer, intent(in) :: index
4257 :
4258 : ! Local variable
4259 : character(len=120) :: errormsg
4260 :
4261 17943552 : if (allocated(this%hdims)) then
4262 17943552 : if ((index >= 1) .and. (index <= size(this%hdims))) then
4263 17943552 : id = this%hdims(index)
4264 : else
4265 0 : write(errormsg, '(a,i0,a)') 'Index out of range, (',index,')'
4266 0 : call endrun('cam_grid_header_info_hdim: '//errormsg)
4267 : end if
4268 : else
4269 0 : write(errormsg, '(a)') 'No hdims allocated'
4270 0 : call endrun('cam_grid_header_info_hdim: '//errormsg)
4271 : end if
4272 :
4273 17943552 : end function cam_grid_header_info_hdim
4274 :
4275 0 : subroutine cam_grid_header_info_set_varids(this, lon_varid, lat_varid)
4276 :
4277 : ! Dummy arguments
4278 : class(cam_grid_header_info_t) :: this
4279 : type(var_desc_t), pointer :: lon_varid
4280 : type(var_desc_t), pointer :: lat_varid
4281 :
4282 0 : if (associated(this%lon_varid)) then
4283 0 : deallocate(this%lon_varid)
4284 0 : nullify(this%lon_varid)
4285 : end if
4286 0 : this%lon_varid => lon_varid
4287 0 : if (associated(this%lat_varid)) then
4288 0 : deallocate(this%lat_varid)
4289 0 : nullify(this%lat_varid)
4290 : end if
4291 0 : this%lat_varid => lat_varid
4292 :
4293 0 : end subroutine cam_grid_header_info_set_varids
4294 :
4295 0 : function cam_grid_header_info_lon_varid(this) result(id)
4296 :
4297 : ! Dummy arguments
4298 : class(cam_grid_header_info_t) :: this
4299 : type(var_desc_t), pointer :: id
4300 :
4301 0 : id => this%lon_varid
4302 :
4303 0 : end function cam_grid_header_info_lon_varid
4304 :
4305 0 : function cam_grid_header_info_lat_varid(this) result(id)
4306 :
4307 : ! Dummy arguments
4308 : class(cam_grid_header_info_t) :: this
4309 : type(var_desc_t), pointer :: id
4310 :
4311 0 : id => this%lat_varid
4312 :
4313 0 : end function cam_grid_header_info_lat_varid
4314 :
4315 122880 : subroutine cam_grid_header_info_deallocate(this)
4316 : ! Dummy argument
4317 : class(cam_grid_header_info_t) :: this
4318 :
4319 122880 : this%grid_id = -1
4320 122880 : if (allocated(this%hdims)) then
4321 122880 : deallocate(this%hdims)
4322 : end if
4323 122880 : if (associated(this%lon_varid)) then
4324 0 : deallocate(this%lon_varid)
4325 0 : nullify(this%lon_varid)
4326 : end if
4327 122880 : if (associated(this%lat_varid)) then
4328 0 : deallocate(this%lat_varid)
4329 0 : nullify(this%lat_varid)
4330 : end if
4331 :
4332 122880 : end subroutine cam_grid_header_info_deallocate
4333 :
4334 0 : end module cam_grid_support
|
