| blob | 072ca5471208ea27c4e5204139bf8f3dabf25c2d |
1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 ! MODULE OUTPUT_MODULE
3 !
4 ! This module handles the output of the fields that are generated by the main
5 ! geogrid routines. This output may include output to a console and output to
6 ! the WRF I/O API.
7 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8 module output_module
10 use parallel_module
11 use gridinfo_module
12 use misc_definitions_module
13 use module_debug
14 #ifdef IO_BINARY
15 use module_internal_header_util
16 #endif
18 integer, parameter :: MAX_DIMENSIONS = 3
20 #ifdef _GEOGRID
21 ! Information about fields that will be written
22 integer :: NUM_AUTOMATIC_FIELDS ! Set later, but very near to a parameter
23 #endif
25 integer :: NUM_FIELDS
27 type field_info
28 integer :: ndims, istagger
29 integer, dimension(MAX_DIMENSIONS) :: dom_start, mem_start, patch_start
30 integer, dimension(MAX_DIMENSIONS) :: dom_end, mem_end, patch_end
31 integer :: sr_x, sr_y
32 real, pointer, dimension(:,:,:) :: rdata_arr
34 character (len=128), dimension(MAX_DIMENSIONS) :: dimnames
35 character (len=128) :: fieldname, mem_order, stagger, units, descr
36 end type field_info
38 type (field_info), pointer, dimension(:) :: fields
40 ! WRF I/O API related variables
41 integer :: handle
43 contains
46 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
47 ! Name: output_init
48 !
49 ! Purpose: To initialize the output module. Such initialization may include
50 ! opening an X window, and making initialization calls to an I/O API.
51 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
52 subroutine output_init(nest_number, title, datestr, grid_type, dynopt, &
53 corner_lats, corner_lons, &
54 start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
55 start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
56 start_mem_1, end_mem_1, start_mem_2, end_mem_2, &
57 extra_col, extra_row)
59 #ifdef _GEOGRID
60 use llxy_module
61 use source_data_module
62 #endif
64 implicit none
66 ! Arguments
67 integer, intent(in) :: nest_number, dynopt, &
68 start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
69 start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
70 start_mem_1, end_mem_1, start_mem_2, end_mem_2
71 real, dimension(16), intent(in) :: corner_lats, corner_lons
72 logical, intent(in) :: extra_col, extra_row
73 character (len=1), intent(in) :: grid_type
74 character (len=19), intent(in) :: datestr
75 character (len=*), intent(in) :: title
77 #include "wrf_io_flags.h"
78 #include "wrf_status_codes.h"
80 ! Local variables
81 integer :: i, istatus, save_domain, comm_1, comm_2
82 integer :: sp1, ep1, sp2, ep2, ep1_stag, ep2_stag
83 integer :: ngeo_flags
84 integer :: num_land_cat, min_land_cat, max_land_cat
85 real :: dx, dy, cen_lat, cen_lon, moad_cen_lat
86 character (len=128) :: coption, temp_fldname
87 character (len=128), dimension(1) :: geo_flags
88 character (len=MAX_FILENAME_LEN) :: output_fname
89 logical :: supports_training, supports_3d_fields
90 #ifdef _GEOGRID
91 character (len=128) :: output_flag
92 #endif
94 call init_output_fields(nest_number, grid_type, &
95 start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
96 start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
97 start_mem_1, end_mem_1, start_mem_2, end_mem_2, &
98 extra_col, extra_row)
100 if (my_proc_id == IO_NODE .or. do_tiled_output) then
101 istatus = 0
102 #ifdef IO_BINARY
103 if (io_form_output == BINARY) call ext_int_ioinit('sysdep info', istatus)
104 #endif
105 #ifdef IO_NETCDF
106 if (io_form_output == NETCDF) call ext_ncd_ioinit('sysdep info', istatus)
107 #endif
108 #ifdef IO_GRIB1
109 if (io_form_output == GRIB1) call ext_gr1_ioinit('sysdep info', istatus)
110 #endif
111 call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioinit')
113 ! Find out what this implementation of WRF I/O API supports
114 istatus = 0
115 #ifdef IO_BINARY
116 if (io_form_output == BINARY) coption = 'REQUIRE'
117 #endif
118 #ifdef IO_NETCDF
119 if (io_form_output == NETCDF) call ext_ncd_inquiry('OPEN_COMMIT_WRITE',coption,istatus)
120 #endif
121 #ifdef IO_GRIB1
122 if (io_form_output == GRIB1) call ext_gr1_inquiry('OPEN_COMMIT_WRITE',coption,istatus)
123 #endif
124 call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_inquiry')
126 if (index(coption,'ALLOW') /= 0) then
127 supports_training = .false.
128 else if (index(coption,'REQUIRE') /= 0) then
129 supports_training = .true.
130 else if (index(coption,'NO') /= 0) then
131 supports_training = .false.
132 end if
134 istatus = 0
135 #ifdef IO_BINARY
136 if (io_form_output == BINARY) coption = 'YES'
137 #endif
138 #ifdef IO_NETCDF
139 if (io_form_output == NETCDF) call ext_ncd_inquiry('SUPPORT_3D_FIELDS',coption,istatus)
140 #endif
141 #ifdef IO_GRIB1
142 if (io_form_output == GRIB1) call ext_gr1_inquiry('SUPPORT_3D_FIELDS',coption,istatus)
143 #endif
144 call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_inquiry')
146 if (index(coption,'YES') /= 0) then
147 supports_3d_fields = .true.
148 else if (index(coption,'NO') /= 0) then
149 supports_3d_fields = .false.
150 ! BUG: What if we have no plans to write 3-d fields? We should take this into account.
151 call mprintf(.true.,ERROR,'WRF I/O API implementation does NOT support 3-d fields.')
152 end if
154 comm_1 = 1
155 comm_2 = 1
157 #ifdef _GEOGRID
158 output_fname = ' '
159 if (grid_type == 'C') then
160 #ifdef IO_BINARY
161 if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d .int'
162 #endif
163 #ifdef IO_NETCDF
164 if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d .nc'
165 #endif
166 #ifdef IO_GRIB1
167 if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d .grib'
168 #endif
169 i = len_trim(opt_output_from_geogrid_path)
170 write(output_fname(i+9:i+10),'(i2.2)') nest_number
171 else if (grid_type == 'E') then
172 if (nest_number == 1) then
173 #ifdef IO_BINARY
174 if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d .int'
175 #endif
176 #ifdef IO_NETCDF
177 if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d .nc'
178 #endif
179 #ifdef IO_GRIB1
180 if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d .grib'
181 #endif
182 i = len_trim(opt_output_from_geogrid_path)
183 write(output_fname(i+10:i+11),'(i2.2)') nest_number
184 else
185 #ifdef IO_BINARY
186 if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l .int'
187 #endif
188 #ifdef IO_NETCDF
189 if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l .nc'
190 #endif
191 #ifdef IO_GRIB1
192 if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l .grib'
193 #endif
194 i = len_trim(opt_output_from_geogrid_path)
195 write(output_fname(i+15:i+16),'(i2.2)') nest_number-1
196 end if
197 end if
199 if (nprocs > 1 .and. do_tiled_output) then
200 write(output_fname(len_trim(output_fname)+1:len_trim(output_fname)+5), '(a1,i4.4)') &
201 '_', my_proc_id
202 end if
203 #endif
205 #ifdef _METGRID
206 output_fname = ' '
207 if (grid_type == 'C') then
208 #ifdef IO_BINARY
209 if (io_form_output == BINARY) then
210 output_fname = trim(opt_output_from_metgrid_path)//'met_em.d .'//trim(datestr)//'.int'
211 end if
212 #endif
213 #ifdef IO_NETCDF
214 if (io_form_output == NETCDF) then
215 output_fname = trim(opt_output_from_metgrid_path)//'met_em.d .'//trim(datestr)//'.nc'
216 end if
217 #endif
218 #ifdef IO_GRIB1
219 if (io_form_output == GRIB1) then
220 output_fname = trim(opt_output_from_metgrid_path)//'met_em.d .'//trim(datestr)//'.grib'
221 end if
222 #endif
223 i = len_trim(opt_output_from_metgrid_path)
224 write(output_fname(i+9:i+10),'(i2.2)') nest_number
225 else if (grid_type == 'E') then
226 #ifdef IO_BINARY
227 if (io_form_output == BINARY) then
228 output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d .'//trim(datestr)//'.int'
229 end if
230 #endif
231 #ifdef IO_NETCDF
232 if (io_form_output == NETCDF) then
233 output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d .'//trim(datestr)//'.nc'
234 end if
235 #endif
236 #ifdef IO_GRIB1
237 if (io_form_output == GRIB1) then
238 output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d .'//trim(datestr)//'.grib'
239 end if
240 #endif
241 i = len_trim(opt_output_from_metgrid_path)
242 write(output_fname(i+10:i+11),'(i2.2)') nest_number
243 end if
245 if (nprocs > 1 .and. do_tiled_output) then
246 write(output_fname(len_trim(output_fname)+1:len_trim(output_fname)+5), '(a1,i4.4)') &
247 '_', my_proc_id
248 end if
249 #endif
250 end if
252 call parallel_bcast_logical(supports_training)
254 ! If the implementation requires or supports open_for_write begin/commit semantics
255 if (supports_training) then
257 if (my_proc_id == IO_NODE .or. do_tiled_output) then
258 istatus = 0
259 #ifdef IO_BINARY
260 if (io_form_output == BINARY) then
261 call ext_int_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
262 end if
263 #endif
264 #ifdef IO_NETCDF
265 if (io_form_output == NETCDF) then
266 call ext_ncd_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
267 end if
268 #endif
269 #ifdef IO_GRIB1
270 if (io_form_output == GRIB1) then
271 call ext_gr1_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
272 end if
273 #endif
274 call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_open_for_write_begin.')
275 end if
277 do i=1,NUM_FIELDS
279 allocate(fields(i)%rdata_arr(fields(i)%mem_start(1):fields(i)%mem_end(1), &
280 fields(i)%mem_start(2):fields(i)%mem_end(2), &
281 fields(i)%mem_start(3):fields(i)%mem_end(3)))
283 call write_field(fields(i)%mem_start(1), fields(i)%mem_end(1), fields(i)%mem_start(2), &
284 fields(i)%mem_end(2), fields(i)%mem_start(3), fields(i)%mem_end(3), &
285 trim(fields(i)%fieldname), datestr, fields(i)%rdata_arr, is_training=.true.)
287 deallocate(fields(i)%rdata_arr)
289 end do
291 if (my_proc_id == IO_NODE .or. do_tiled_output) then
292 istatus = 0
293 #ifdef IO_BINARY
294 if (io_form_output == BINARY) call ext_int_open_for_write_commit(handle, istatus)
295 #endif
296 #ifdef IO_NETCDF
297 if (io_form_output == NETCDF) call ext_ncd_open_for_write_commit(handle, istatus)
298 #endif
299 #ifdef IO_GRIB1
300 if (io_form_output == GRIB1) call ext_gr1_open_for_write_commit(handle, istatus)
301 #endif
302 call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_write_commit')
303 end if
305 else ! No training required
307 if (my_proc_id == IO_NODE .or. do_tiled_output) then
308 istatus = 0
309 #ifdef IO_BINARY
310 if (io_form_output == BINARY) then
311 call ext_int_open_for_write(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
312 end if
313 #endif
314 #ifdef IO_NETCDF
315 if (io_form_output == NETCDF) then
316 call ext_ncd_open_for_write(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
317 end if
318 #endif
319 #ifdef IO_GRIB1
320 if (io_form_output == GRIB1) then
321 call mprintf(.true.,ERROR,'In output_init(), GRIB1 requires begin/commit open sequence.')
322 end if
323 #endif
324 call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_open_for_write_begin')
325 end if
327 end if
329 #ifdef _GEOGRID
330 sp1 = start_patch_1
331 ep1 = end_patch_1
332 sp2 = start_patch_2
333 ep2 = end_patch_2
335 if (grid_type == 'C') then
336 if (extra_col .or. (my_proc_id == IO_NODE .and. .not. do_tiled_output)) then
337 ep1_stag = ep1 + 1
338 else
339 ep1_stag = ep1
340 end if
341 if (extra_row .or. (my_proc_id == IO_NODE .and. .not. do_tiled_output)) then
342 ep2_stag = ep2 + 1
343 else
344 ep2_stag = ep2
345 end if
346 else if (grid_type == 'E') then
347 ep1 = ep1
348 ep2 = ep2
349 ep1_stag = ep1
350 ep2_stag = ep2
351 end if
353 if (grid_type == 'C') then
354 dx = proj_stack(nest_number)%dx
355 dy = proj_stack(nest_number)%dy
357 save_domain = iget_selected_domain()
359 ! Note: In the following, we use ixdim/2 rather than (ixdim+1)/2 because
360 ! the i/j coordinates given to xytoll must be with respect to the
361 ! mass grid, and ixdim and jydim are the full grid dimensions.
363 ! Get MOAD_CEN_LAT
364 call select_domain(1)
365 call xytoll(real(ixdim(1))/2.,real(jydim(1))/2., moad_cen_lat, cen_lon, M)
367 ! Get CEN_LAT and CEN_LON for this nest
368 call select_domain(nest_number)
369 call xytoll(real(ixdim(nest_number))/2.,real(jydim(nest_number))/2., cen_lat, cen_lon, M)
371 call select_domain(save_domain)
373 ngeo_flags = 1
374 geo_flags(1) = 'FLAG_MF_XY'
375 else if (grid_type == 'E') then
376 dx = dxkm / 3**(nest_number-1) ! For NMM, nest_number is really nesting level
377 dy = dykm / 3**(nest_number-1)
378 moad_cen_lat = 0.
379 cen_lat=known_lat
380 cen_lon=known_lon
382 ngeo_flags = 0
383 end if
385 write(temp_fldname,'(a)') 'LANDUSEF'
386 call get_max_categories(temp_fldname, min_land_cat, max_land_cat, istatus)
387 num_land_cat = max_land_cat - min_land_cat + 1
389 ! We may now write global attributes to the file
390 call write_global_attrs(title, datestr, grid_type, dynopt, ixdim(nest_number), jydim(nest_number), &
391 0, sp1, ep1, sp1, ep1_stag, sp2, ep2, sp2, ep2_stag, &
392 iproj_type, source_mminlu, num_land_cat, source_iswater, source_islake, &
393 source_isice, source_isurban, source_isoilwater, nest_number, &
394 parent_id(nest_number), &
395 nint(parent_ll_x(nest_number)), nint(parent_ll_y(nest_number)), &
396 nint(parent_ur_x(nest_number)), nint(parent_ur_y(nest_number)), &
397 dx, dy, cen_lat, moad_cen_lat, &
398 cen_lon, stand_lon, truelat1, truelat2, pole_lat, pole_lon, &
399 parent_grid_ratio(nest_number), &
400 subgrid_ratio_x(nest_number), subgrid_ratio_y(nest_number), &
401 corner_lats, corner_lons, flags=geo_flags, nflags=ngeo_flags)
403 do i=1,NUM_FIELDS
404 call get_output_flag(trim(fields(i)%fieldname), output_flag, istatus)
405 if (istatus == 0) then
406 if (my_proc_id == IO_NODE .or. do_tiled_output) then
407 call ext_put_dom_ti_integer_scalar(trim(output_flag), 1)
408 end if
409 end if
410 end do
411 #endif
413 end subroutine output_init
416 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
417 ! Name: init_output_fields
418 !
419 ! Purpose: To fill in structures describing each of the fields that will be
420 ! written to the I/O API
421 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
422 subroutine init_output_fields(nest_num, grid_type, &
423 start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
424 start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
425 start_mem_1, end_mem_1, start_mem_2, end_mem_2, &
426 extra_col, extra_row)
429 ! Modules
430 #ifdef _GEOGRID
431 use source_data_module
432 #endif
433 #ifdef _METGRID
434 use storage_module
435 #endif
436 use parallel_module
438 implicit none
440 ! Arguments
441 integer, intent(in) :: nest_num
442 integer, intent(in) :: start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
443 start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
444 start_mem_1, end_mem_1, start_mem_2, end_mem_2
445 logical, intent(in) :: extra_col, extra_row
446 character (len=1), intent(in) :: grid_type
448 #include "wrf_io_flags.h"
449 #include "wrf_status_codes.h"
451 ! Local variables
452 integer :: i, istagger, ifieldstatus, &
453 nfields, min_category, max_category
454 integer :: lhalo_width, rhalo_width, bhalo_width, thalo_width
455 integer :: ndims
456 integer :: optstatus
457 character (len=128) :: fieldname
458 character (len=128) :: derived_from
459 character (len=128) :: memorder, units, description
460 character (len=128), dimension(3) :: dimnames
461 integer :: sr_x, sr_y
462 logical :: is_subgrid_var, sub_status
464 !
465 ! First find out how many fields there are
466 !
467 call reset_next_field()
469 ifieldstatus = 0
470 nfields = 0
471 optstatus = 0
472 do while (ifieldstatus == 0)
474 call get_next_output_fieldname(nest_num, fieldname, ndims, &
475 min_category, max_category, &
476 istagger, memorder, dimnames, &
477 units, description, sr_x, sr_y, &
478 is_subgrid_var, derived_from, ifieldstatus)
479 sub_status = (.not. is_subgrid_var .or. (sr_x > 0 .or. sr_y > 0))
480 #ifdef _GEOGRID
481 if (len_trim(derived_from) > 0) then
482 call get_source_opt_status(trim(derived_from), 0, optstatus)
483 else
484 call get_source_opt_status(trim(fieldname), 0, optstatus)
485 end if
486 #endif
488 if (ifieldstatus == 0 .and. optstatus == 0 .and. sub_status) then
489 nfields = nfields + 1
490 end if
491 end do
493 #ifdef _METGRID
494 NUM_FIELDS = nfields
495 #endif
497 #ifdef _GEOGRID
498 if (grid_type == 'C') NUM_AUTOMATIC_FIELDS = 28
499 if (grid_type == 'E') NUM_AUTOMATIC_FIELDS = 7
501 NUM_FIELDS = nfields+NUM_AUTOMATIC_FIELDS
502 allocate(fields(NUM_FIELDS))
504 ! Automatic fields will always be on the non-refined grid
505 sr_x=1
506 sr_y=1
508 !
509 ! There are some fields that will always be computed
510 ! Initialize those fields first, followed by all user-specified fields
511 !
512 if (grid_type == 'C') then
513 fields(1)%fieldname = 'XLAT_M'
514 fields(1)%units = 'degrees latitude'
515 fields(1)%descr = 'Latitude on mass grid'
517 fields(2)%fieldname = 'XLONG_M'
518 fields(2)%units = 'degrees longitude'
519 fields(2)%descr = 'Longitude on mass grid'
521 fields(3)%fieldname = 'XLAT_V'
522 fields(3)%units = 'degrees latitude'
523 fields(3)%descr = 'Latitude on V grid'
525 fields(4)%fieldname = 'XLONG_V'
526 fields(4)%units = 'degrees longitude'
527 fields(4)%descr = 'Longitude on V grid'
529 fields(5)%fieldname = 'XLAT_U'
530 fields(5)%units = 'degrees latitude'
531 fields(5)%descr = 'Latitude on U grid'
533 fields(6)%fieldname = 'XLONG_U'
534 fields(6)%units = 'degrees longitude'
535 fields(6)%descr = 'Longitude on U grid'
537 fields(7)%fieldname = 'CLAT'
538 fields(7)%units = 'degrees latitude'
539 fields(7)%descr = 'Computational latitude on mass grid'
541 fields(8)%fieldname = 'CLONG'
542 fields(8)%units = 'degrees longitude'
543 fields(8)%descr = 'Computational longitude on mass grid'
545 fields(9)%fieldname = 'MAPFAC_M'
546 fields(9)%units = 'none'
547 fields(9)%descr = 'Mapfactor on mass grid'
549 fields(10)%fieldname = 'MAPFAC_V'
550 fields(10)%units = 'none'
551 fields(10)%descr = 'Mapfactor on V grid'
553 fields(11)%fieldname = 'MAPFAC_U'
554 fields(11)%units = 'none'
555 fields(11)%descr = 'Mapfactor on U grid'
557 fields(12)%fieldname = 'MAPFAC_MX'
558 fields(12)%units = 'none'
559 fields(12)%descr = 'Mapfactor (x-dir) on mass grid'
561 fields(13)%fieldname = 'MAPFAC_VX'
562 fields(13)%units = 'none'
563 fields(13)%descr = 'Mapfactor (x-dir) on V grid'
565 fields(14)%fieldname = 'MAPFAC_UX'
566 fields(14)%units = 'none'
567 fields(14)%descr = 'Mapfactor (x-dir) on U grid'
569 fields(15)%fieldname = 'MAPFAC_MY'
570 fields(15)%units = 'none'
571 fields(15)%descr = 'Mapfactor (y-dir) on mass grid'
573 fields(16)%fieldname = 'MAPFAC_VY'
574 fields(16)%units = 'none'
575 fields(16)%descr = 'Mapfactor (y-dir) on V grid'
577 fields(17)%fieldname = 'MAPFAC_UY'
578 fields(17)%units = 'none'
579 fields(17)%descr = 'Mapfactor (y-dir) on U grid'
581 fields(18)%fieldname = 'E'
582 fields(18)%units = '-'
583 fields(18)%descr = 'Coriolis E parameter'
585 fields(19)%fieldname = 'F'
586 fields(19)%units = '-'
587 fields(19)%descr = 'Coriolis F parameter'
589 fields(20)%fieldname = 'SINALPHA'
590 fields(20)%units = 'none'
591 fields(20)%descr = 'Sine of rotation angle'
593 fields(21)%fieldname = 'COSALPHA'
594 fields(21)%units = 'none'
595 fields(21)%descr = 'Cosine of rotation angle'
597 fields(22)%fieldname = 'LANDMASK'
598 fields(22)%units = 'none'
599 fields(22)%descr = 'Landmask : 1=land, 0=water'
601 fields(23)%fieldname = 'XLAT_C'
602 fields(23)%units = 'degrees latitude'
603 fields(23)%descr = 'Latitude at grid cell corners'
605 fields(24)%fieldname = 'XLONG_C'
606 fields(24)%units = 'degrees longitude'
607 fields(24)%descr = 'Longitude at grid cell corners'
609 fields(25)%fieldname = 'SINALPHA_U'
610 fields(25)%units = 'none'
611 fields(25)%descr = 'Sine of rotation angle on U grid'
613 fields(26)%fieldname = 'COSALPHA_U'
614 fields(26)%units = 'none'
615 fields(26)%descr = 'Cosine of rotation angle on U grid'
617 fields(27)%fieldname = 'SINALPHA_V'
618 fields(27)%units = 'none'
619 fields(27)%descr = 'Sine of rotation angle on V grid'
621 fields(28)%fieldname = 'COSALPHA_V'
622 fields(28)%units = 'none'
623 fields(28)%descr = 'Cosine of rotation angle on V grid'
625 else if (grid_type == 'E') then
626 fields(1)%fieldname = 'XLAT_M'
627 fields(1)%units = 'degrees latitude'
628 fields(1)%descr = 'Latitude on mass grid'
630 fields(2)%fieldname = 'XLONG_M'
631 fields(2)%units = 'degrees longitude'
632 fields(2)%descr = 'Longitude on mass grid'
634 fields(3)%fieldname = 'XLAT_V'
635 fields(3)%units = 'degrees latitude'
636 fields(3)%descr = 'Latitude on velocity grid'
638 fields(4)%fieldname = 'XLONG_V'
639 fields(4)%units = 'degrees longitude'
640 fields(4)%descr = 'Longitude on velocity grid'
642 fields(5)%fieldname = 'E'
643 fields(5)%units = '-'
644 fields(5)%descr = 'Coriolis E parameter'
646 fields(6)%fieldname = 'F'
647 fields(6)%units = '-'
648 fields(6)%descr = 'Coriolis F parameter'
650 fields(7)%fieldname = 'LANDMASK'
651 fields(7)%units = 'none'
652 fields(7)%descr = 'Landmask : 1=land, 0=water'
654 end if
656 !
657 ! General defaults for "always computed" fields
658 !
659 do i=1,NUM_AUTOMATIC_FIELDS
660 fields(i)%ndims = 2
661 fields(i)%dom_start(1) = start_dom_1
662 fields(i)%dom_start(2) = start_dom_2
663 fields(i)%dom_start(3) = 1
664 fields(i)%mem_start(1) = start_mem_1
665 fields(i)%mem_start(2) = start_mem_2
666 fields(i)%mem_start(3) = 1
667 fields(i)%patch_start(1) = start_patch_1
668 fields(i)%patch_start(2) = start_patch_2
669 fields(i)%patch_start(3) = 1
670 fields(i)%dom_end(1) = end_dom_1
671 fields(i)%dom_end(2) = end_dom_2
672 fields(i)%dom_end(3) = 1
673 fields(i)%mem_end(1) = end_mem_1
674 fields(i)%mem_end(2) = end_mem_2
675 fields(i)%mem_end(3) = 1
676 fields(i)%patch_end(1) = end_patch_1
677 fields(i)%patch_end(2) = end_patch_2
678 fields(i)%patch_end(3) = 1
679 fields(i)%dimnames(3) = ' '
680 fields(i)%mem_order = 'XY'
681 fields(i)%stagger = 'M'
682 fields(i)%sr_x = 1
683 fields(i)%sr_y = 1
684 if (grid_type == 'C') then
685 fields(i)%istagger = M
686 else if (grid_type == 'E') then
687 fields(i)%istagger = HH
688 end if
689 fields(i)%dimnames(1) = 'west_east'
690 fields(i)%dimnames(2) = 'south_north'
691 end do
693 !
694 ! Perform adjustments to metadata for non-mass-staggered "always computed" fields
695 !
696 if (grid_type == 'C') then
697 ! Lat V
698 if (extra_row) then
699 fields(3)%dom_end(2) = fields(3)%dom_end(2) + 1
700 fields(3)%mem_end(2) = fields(3)%mem_end(2) + 1
701 fields(3)%patch_end(2) = fields(3)%patch_end(2) + 1
702 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
703 fields(3)%dom_end(2) = fields(3)%dom_end(2) + 1
704 end if
705 fields(3)%dimnames(2) = 'south_north_stag'
706 fields(3)%stagger = 'V'
707 fields(3)%istagger = V
709 ! Lon V
710 if (extra_row) then
711 fields(4)%dom_end(2) = fields(4)%dom_end(2) + 1
712 fields(4)%mem_end(2) = fields(4)%mem_end(2) + 1
713 fields(4)%patch_end(2) = fields(4)%patch_end(2) + 1
714 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
715 fields(4)%dom_end(2) = fields(4)%dom_end(2) + 1
716 end if
717 fields(4)%dimnames(2) = 'south_north_stag'
718 fields(4)%stagger = 'V'
719 fields(4)%istagger = V
721 ! Lat U
722 if (extra_col) then
723 fields(5)%dom_end(1) = fields(5)%dom_end(1) + 1
724 fields(5)%mem_end(1) = fields(5)%mem_end(1) + 1
725 fields(5)%patch_end(1) = fields(5)%patch_end(1) + 1
726 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
727 fields(5)%dom_end(1) = fields(5)%dom_end(1) + 1
728 end if
729 fields(5)%dimnames(1) = 'west_east_stag'
730 fields(5)%stagger = 'U'
731 fields(5)%istagger = U
733 ! Lon U
734 if (extra_col) then
735 fields(6)%dom_end(1) = fields(6)%dom_end(1) + 1
736 fields(6)%mem_end(1) = fields(6)%mem_end(1) + 1
737 fields(6)%patch_end(1) = fields(6)%patch_end(1) + 1
738 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
739 fields(6)%dom_end(1) = fields(6)%dom_end(1) + 1
740 end if
741 fields(6)%dimnames(1) = 'west_east_stag'
742 fields(6)%stagger = 'U'
743 fields(6)%istagger = U
745 ! Mapfac V
746 if (extra_row) then
747 fields(10)%dom_end(2) = fields(10)%dom_end(2) + 1
748 fields(10)%mem_end(2) = fields(10)%mem_end(2) + 1
749 fields(10)%patch_end(2) = fields(10)%patch_end(2) + 1
750 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
751 fields(10)%dom_end(2) = fields(10)%dom_end(2) + 1
752 end if
753 fields(10)%dimnames(2) = 'south_north_stag'
754 fields(10)%stagger = 'V'
755 fields(10)%istagger = V
757 ! Mapfac U
758 if (extra_col) then
759 fields(11)%dom_end(1) = fields(11)%dom_end(1) + 1
760 fields(11)%mem_end(1) = fields(11)%mem_end(1) + 1
761 fields(11)%patch_end(1) = fields(11)%patch_end(1) + 1
762 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
763 fields(11)%dom_end(1) = fields(11)%dom_end(1) + 1
764 end if
765 fields(11)%dimnames(1) = 'west_east_stag'
766 fields(11)%stagger = 'U'
767 fields(11)%istagger = U
769 ! Mapfac V-X
770 if (extra_row) then
771 fields(13)%dom_end(2) = fields(13)%dom_end(2) + 1
772 fields(13)%mem_end(2) = fields(13)%mem_end(2) + 1
773 fields(13)%patch_end(2) = fields(13)%patch_end(2) + 1
774 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
775 fields(13)%dom_end(2) = fields(13)%dom_end(2) + 1
776 end if
777 fields(13)%dimnames(2) = 'south_north_stag'
778 fields(13)%stagger = 'V'
779 fields(13)%istagger = V
781 ! Mapfac U-X
782 if (extra_col) then
783 fields(14)%dom_end(1) = fields(14)%dom_end(1) + 1
784 fields(14)%mem_end(1) = fields(14)%mem_end(1) + 1
785 fields(14)%patch_end(1) = fields(14)%patch_end(1) + 1
786 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
787 fields(14)%dom_end(1) = fields(14)%dom_end(1) + 1
788 end if
789 fields(14)%dimnames(1) = 'west_east_stag'
790 fields(14)%stagger = 'U'
791 fields(14)%istagger = U
793 ! Mapfac V-Y
794 if (extra_row) then
795 fields(16)%dom_end(2) = fields(16)%dom_end(2) + 1
796 fields(16)%mem_end(2) = fields(16)%mem_end(2) + 1
797 fields(16)%patch_end(2) = fields(16)%patch_end(2) + 1
798 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
799 fields(16)%dom_end(2) = fields(16)%dom_end(2) + 1
800 end if
801 fields(16)%dimnames(2) = 'south_north_stag'
802 fields(16)%stagger = 'V'
803 fields(16)%istagger = V
805 ! Mapfac U-Y
806 if (extra_col) then
807 fields(17)%dom_end(1) = fields(17)%dom_end(1) + 1
808 fields(17)%mem_end(1) = fields(17)%mem_end(1) + 1
809 fields(17)%patch_end(1) = fields(17)%patch_end(1) + 1
810 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
811 fields(17)%dom_end(1) = fields(17)%dom_end(1) + 1
812 end if
813 fields(17)%dimnames(1) = 'west_east_stag'
814 fields(17)%stagger = 'U'
815 fields(17)%istagger = U
817 ! Lat (unstaggered)
818 if (extra_row) then
819 fields(23)%dom_end(2) = fields(23)%dom_end(2) + 1
820 fields(23)%mem_end(2) = fields(23)%mem_end(2) + 1
821 fields(23)%patch_end(2) = fields(23)%patch_end(2) + 1
822 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
823 fields(23)%dom_end(2) = fields(23)%dom_end(2) + 1
824 end if
825 if (extra_col) then
826 fields(23)%dom_end(1) = fields(23)%dom_end(1) + 1
827 fields(23)%mem_end(1) = fields(23)%mem_end(1) + 1
828 fields(23)%patch_end(1) = fields(23)%patch_end(1) + 1
829 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
830 fields(23)%dom_end(1) = fields(23)%dom_end(1) + 1
831 end if
832 fields(23)%dimnames(1) = 'west_east_stag'
833 fields(23)%dimnames(2) = 'south_north_stag'
834 fields(23)%stagger = 'CORNER'
835 fields(23)%istagger = CORNER
837 ! Lon (unstaggered)
838 if (extra_row) then
839 fields(24)%dom_end(2) = fields(24)%dom_end(2) + 1
840 fields(24)%mem_end(2) = fields(24)%mem_end(2) + 1
841 fields(24)%patch_end(2) = fields(24)%patch_end(2) + 1
842 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
843 fields(24)%dom_end(2) = fields(24)%dom_end(2) + 1
844 end if
845 if (extra_col) then
846 fields(24)%dom_end(1) = fields(24)%dom_end(1) + 1
847 fields(24)%mem_end(1) = fields(24)%mem_end(1) + 1
848 fields(24)%patch_end(1) = fields(24)%patch_end(1) + 1
849 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
850 fields(24)%dom_end(1) = fields(24)%dom_end(1) + 1
851 end if
852 fields(24)%dimnames(1) = 'west_east_stag'
853 fields(24)%dimnames(2) = 'south_north_stag'
854 fields(24)%stagger = 'CORNER'
855 fields(24)%istagger = CORNER
857 ! SINALPHA on U
858 if (extra_col) then
859 fields(25)%dom_end(1) = fields(25)%dom_end(1) + 1
860 fields(25)%mem_end(1) = fields(25)%mem_end(1) + 1
861 fields(25)%patch_end(1) = fields(25)%patch_end(1) + 1
862 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
863 fields(25)%dom_end(1) = fields(25)%dom_end(1) + 1
864 end if
865 fields(25)%dimnames(1) = 'west_east_stag'
866 fields(25)%stagger = 'U'
867 fields(25)%istagger = U
869 ! COSALPHA on U
870 if (extra_col) then
871 fields(26)%dom_end(1) = fields(26)%dom_end(1) + 1
872 fields(26)%mem_end(1) = fields(26)%mem_end(1) + 1
873 fields(26)%patch_end(1) = fields(26)%patch_end(1) + 1
874 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
875 fields(26)%dom_end(1) = fields(26)%dom_end(1) + 1
876 end if
877 fields(26)%dimnames(1) = 'west_east_stag'
878 fields(26)%stagger = 'U'
879 fields(26)%istagger = U
881 ! SINALPHA on V
882 if (extra_row) then
883 fields(27)%dom_end(2) = fields(27)%dom_end(2) + 1
884 fields(27)%mem_end(2) = fields(27)%mem_end(2) + 1
885 fields(27)%patch_end(2) = fields(27)%patch_end(2) + 1
886 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
887 fields(27)%dom_end(2) = fields(27)%dom_end(2) + 1
888 end if
889 fields(27)%dimnames(2) = 'south_north_stag'
890 fields(27)%stagger = 'V'
891 fields(27)%istagger = V
893 ! COSALPHA on V
894 if (extra_row) then
895 fields(28)%dom_end(2) = fields(28)%dom_end(2) + 1
896 fields(28)%mem_end(2) = fields(28)%mem_end(2) + 1
897 fields(28)%patch_end(2) = fields(28)%patch_end(2) + 1
898 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
899 fields(28)%dom_end(2) = fields(28)%dom_end(2) + 1
900 end if
901 fields(28)%dimnames(2) = 'south_north_stag'
902 fields(28)%stagger = 'V'
903 fields(28)%istagger = V
905 else if (grid_type == 'E') then
906 ! Lat V
907 fields(3)%stagger = 'V'
908 fields(3)%istagger = VV
910 ! Lon V
911 fields(4)%stagger = 'V'
912 fields(4)%istagger = VV
914 end if
915 #endif
917 !
918 ! Now set up the field_info structure for each user-specified field
919 !
920 call reset_next_field()
922 ifieldstatus = 0
923 #ifdef _GEOGRID
924 nfields = NUM_AUTOMATIC_FIELDS+1
925 #endif
926 #ifdef _METGRID
927 allocate(fields(NUM_FIELDS))
928 nfields = 1
929 #endif
931 optstatus = 0
932 do while (ifieldstatus == 0) !{
933 call get_next_output_fieldname(nest_num, fieldname, ndims, &
934 min_category, max_category, &
935 istagger, memorder, dimnames, &
936 units, description, sr_x, sr_y, &
937 is_subgrid_var, derived_from, ifieldstatus)
938 sub_status = (.not. is_subgrid_var .or. (sr_x > 0 .or. sr_y > 0))
939 #ifdef _GEOGRID
940 if (len_trim(derived_from) > 0) then
941 call get_source_opt_status(trim(derived_from), 0, optstatus)
942 else
943 call get_source_opt_status(trim(fieldname), 0, optstatus)
944 end if
945 #endif
948 if (ifieldstatus == 0 .and. optstatus == 0 .and. sub_status) then !{
950 fields(nfields)%ndims = ndims
951 fields(nfields)%fieldname = fieldname
952 fields(nfields)%istagger = istagger
953 if (istagger == M) then
954 fields(nfields)%stagger = 'M'
955 else if (istagger == U) then
956 fields(nfields)%stagger = 'U'
957 else if (istagger == V) then
958 fields(nfields)%stagger = 'V'
959 else if (istagger == HH) then
960 fields(nfields)%stagger = 'M'
961 else if (istagger == VV) then
962 fields(nfields)%stagger = 'V'
963 else if (istagger == CORNER) then
964 fields(nfields)%stagger = 'CORNER'
965 end if
966 fields(nfields)%mem_order = memorder
967 fields(nfields)%dimnames(1) = dimnames(1)
968 fields(nfields)%dimnames(2) = dimnames(2)
969 fields(nfields)%dimnames(3) = dimnames(3)
970 fields(nfields)%units = units
971 fields(nfields)%descr = description
973 fields(nfields)%dom_start(1) = start_dom_1
974 fields(nfields)%dom_start(2) = start_dom_2
975 fields(nfields)%dom_start(3) = min_category
976 fields(nfields)%mem_start(1) = start_mem_1
977 fields(nfields)%mem_start(2) = start_mem_2
978 fields(nfields)%mem_start(3) = min_category
979 fields(nfields)%patch_start(1) = start_patch_1
980 fields(nfields)%patch_start(2) = start_patch_2
981 fields(nfields)%patch_start(3) = min_category
983 fields(nfields)%dom_end(1) = end_dom_1
984 fields(nfields)%dom_end(2) = end_dom_2
985 fields(nfields)%dom_end(3) = max_category
986 fields(nfields)%mem_end(1) = end_mem_1
987 fields(nfields)%mem_end(2) = end_mem_2
988 fields(nfields)%mem_end(3) = max_category
989 fields(nfields)%patch_end(1) = end_patch_1
990 fields(nfields)%patch_end(2) = end_patch_2
991 fields(nfields)%patch_end(3) = max_category
993 fields(nfields)%sr_x=sr_x
994 fields(nfields)%sr_y=sr_y
996 if (extra_col .and. (istagger == U .or. istagger == CORNER .or. sr_x > 1)) then !{
997 fields(nfields)%dom_end(1) = fields(nfields)%dom_end(1) + 1
998 fields(nfields)%mem_end(1) = fields(nfields)%mem_end(1) + 1
999 fields(nfields)%patch_end(1) = fields(nfields)%patch_end(1) + 1
1000 else if ((istagger == U .or. istagger == CORNER .or. sr_x > 1) &
1001 .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then
1002 fields(nfields)%dom_end(1)=fields(nfields)%dom_end(1) + 1
1003 end if !}
1005 if (extra_row .and. (istagger == V .or. istagger == CORNER .or. sr_y > 1)) then !{
1006 fields(nfields)%dom_end(2) = fields(nfields)%dom_end(2) + 1
1007 fields(nfields)%mem_end(2) = fields(nfields)%mem_end(2) + 1
1008 fields(nfields)%patch_end(2) = fields(nfields)%patch_end(2) + 1
1009 else if ((istagger == V .or. istagger == CORNER .or. sr_y > 1) &
1010 .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then
1011 fields(nfields)%dom_end(2)=fields(nfields)%dom_end(2) + 1
1012 end if !}
1014 #ifdef _METGRID
1015 lhalo_width = start_patch_1 - start_mem_1 ! Halo width on left of patch
1016 rhalo_width = end_mem_1 - end_patch_1 ! Halo width on right of patch
1017 bhalo_width = start_patch_2 - start_mem_2 ! Halo width on bottom of patch
1018 thalo_width = end_mem_2 - end_patch_2 ! Halo width on top of patch
1019 #else
1020 lhalo_width = 0
1021 rhalo_width = 0
1022 bhalo_width = 0
1023 thalo_width = 0
1024 #endif
1026 if (sr_x > 1) then
1027 fields(nfields)%mem_start(1) = (fields(nfields)%mem_start(1) + lhalo_width - 1)*sr_x + 1 - lhalo_width
1028 fields(nfields)%patch_start(1) = (fields(nfields)%patch_start(1) - 1)*sr_x + 1
1029 fields(nfields)%dom_start(1) = (fields(nfields)%dom_start(1) - 1)*sr_x + 1
1031 fields(nfields)%mem_end(1) = (fields(nfields)%mem_end(1) - rhalo_width)*sr_x + rhalo_width
1032 fields(nfields)%patch_end(1) = (fields(nfields)%patch_end(1) )*sr_x
1033 fields(nfields)%dom_end(1) = (fields(nfields)%dom_end(1) )*sr_x
1034 endif
1036 if (sr_y > 1) then
1037 fields(nfields)%mem_start(2) = (fields(nfields)%mem_start(2) + bhalo_width - 1)*sr_y + 1 - bhalo_width
1038 fields(nfields)%patch_start(2) = (fields(nfields)%patch_start(2) - 1)*sr_y + 1
1039 fields(nfields)%dom_start(2) = (fields(nfields)%dom_start(2) - 1)*sr_y + 1
1041 fields(nfields)%mem_end(2) = (fields(nfields)%mem_end(2) - thalo_width)*sr_y + thalo_width
1042 fields(nfields)%patch_end(2) = (fields(nfields)%patch_end(2) )*sr_y
1043 fields(nfields)%dom_end(2) = (fields(nfields)%dom_end(2) )*sr_y
1044 endif
1047 nfields = nfields + 1
1049 end if ! the next field given by get_next_fieldname() is valid }
1051 end do ! for each user-specified field }
1053 end subroutine init_output_fields
1056 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1057 ! Name: write_field
1058 !
1059 ! Purpose: This routine writes the provided field to any output devices or APIs
1060 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1061 subroutine write_field(start_mem_i, end_mem_i, &
1062 start_mem_j, end_mem_j, &
1063 start_mem_k, end_mem_k, &
1064 cname, datestr, real_array, is_training)
1066 implicit none
1068 ! Arguments
1069 integer, intent(in) :: start_mem_i, end_mem_i, start_mem_j, end_mem_j, start_mem_k, end_mem_k
1070 real, target, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j, start_mem_k:end_mem_k), &
1071 intent(in) :: real_array
1072 logical, intent(in), optional :: is_training
1073 character (len=19), intent(in) :: datestr
1074 character (len=*), intent(in) :: cname
1076 #include "wrf_io_flags.h"
1077 #include "wrf_status_codes.h"
1079 ! Local variables
1080 integer :: i
1081 integer :: istatus, comm_1, comm_2, domain_desc
1082 integer, dimension(3) :: sd, ed, sp, ep, sm, em
1083 real, pointer, dimension(:,:,:) :: real_dom_array
1084 logical :: allocated_real_locally
1086 allocated_real_locally = .false.
1088 ! If we are running distributed memory and need to gather all tiles onto a single processor for output
1089 if (nprocs > 1 .and. .not. do_tiled_output) then
1090 do i=1,NUM_FIELDS
1091 if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
1092 (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
1093 istatus = 0
1095 ! For the gather routines below, the IO_NODE should give the full domain dimensions, but the
1096 ! memory and patch dimensions should indicate what the processor already has in its patch_array.
1097 ! This is because an array with dimensions of the full domain will be allocated, and the patch_array
1098 ! will be copied from local memory into the full domain array in the area specified by the patch
1099 ! dimensions.
1100 sd = fields(i)%dom_start
1101 ed = fields(i)%dom_end
1102 sp = fields(i)%patch_start
1103 ep = fields(i)%patch_end
1104 sm = fields(i)%mem_start
1105 em = fields(i)%mem_end
1107 allocate(real_dom_array(sd(1):ed(1),sd(2):ed(2),sd(3):ed(3)))
1108 allocated_real_locally = .true.
1109 call gather_whole_field_r(real_array, &
1110 sm(1), em(1), sm(2), em(2), sm(3), em(3), &
1111 sp(1), ep(1), sp(2), ep(2), sp(3), ep(3), &
1112 real_dom_array, &
1113 sd(1), ed(1), sd(2), ed(2), sd(3), ed(3))
1114 exit
1115 end if
1116 end do
1117 else
1118 do i=1,NUM_FIELDS
1119 if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
1120 (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
1121 istatus = 0
1122 real_dom_array => real_array
1123 exit
1124 end if
1125 end do
1126 end if
1128 ! Now a write call is only done if each processor writes its own file, or if we are the IO_NODE
1129 if (my_proc_id == IO_NODE .or. do_tiled_output) then
1130 comm_1 = 1
1131 comm_2 = 1
1132 domain_desc = 0
1134 do i=1,NUM_FIELDS
1135 if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
1136 (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
1138 ! Here, the output array has dimensions of the full grid if it was gathered together
1139 ! from all processors
1140 if (my_proc_id == IO_NODE .and. nprocs > 1 .and. .not. do_tiled_output) then
1141 sd = fields(i)%dom_start
1142 ed = fields(i)%dom_end
1143 sm = sd
1144 em = ed
1145 sp = sd
1146 ep = ed
1147 ! If we are writing one file per processor, then each processor only writes out the
1148 ! part of the domain that it has in memory
1149 else
1150 ! BUG: Shouldn't we set sd/ed to be domain_start/domain_end?
1151 ! Maybe not, since patch is already adjusted for staggering; but maybe so, and also adjust
1152 ! for staggering if it is alright to pass true domain dimensions to write_field.
1153 sd = fields(i)%patch_start
1154 ed = fields(i)%patch_end
1155 sp = fields(i)%patch_start
1156 ep = fields(i)%patch_end
1157 sm = fields(i)%mem_start
1158 em = fields(i)%mem_end
1159 end if
1161 istatus = 0
1162 #ifdef IO_BINARY
1163 if (io_form_output == BINARY) then
1164 call ext_int_write_field(handle, datestr, trim(fields(i)%fieldname), &
1165 real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
1166 trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
1167 end if
1168 #endif
1169 #ifdef IO_NETCDF
1170 if (io_form_output == NETCDF) then
1171 call ext_ncd_write_field(handle, datestr, trim(fields(i)%fieldname), &
1172 real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
1173 trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
1174 end if
1175 #endif
1176 #ifdef IO_GRIB1
1177 if (io_form_output == GRIB1) then
1178 call ext_gr1_write_field(handle, datestr, trim(fields(i)%fieldname), &
1179 real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
1180 trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
1181 end if
1182 #endif
1183 call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_write_field')
1185 if (present(is_training)) then
1186 if (is_training) then
1187 #ifdef IO_BINARY
1188 if (io_form_output == BINARY) then
1189 call ext_int_put_var_ti_char(handle, 'units', &
1190 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
1191 call ext_int_put_var_ti_char(handle, 'description', &
1192 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
1193 call ext_int_put_var_ti_char(handle, 'stagger', &
1194 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
1195 call ext_int_put_var_ti_integer(handle,'sr_x', &
1196 trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus)
1197 call ext_int_put_var_ti_integer(handle,'sr_y', &
1198 trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus)
1199 end if
1200 #endif
1201 #ifdef IO_NETCDF
1202 if (io_form_output == NETCDF) then
1203 call ext_ncd_put_var_ti_char(handle, 'units', &
1204 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
1205 call ext_ncd_put_var_ti_char(handle, 'description', &
1206 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
1207 call ext_ncd_put_var_ti_char(handle, 'stagger', &
1208 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
1209 call ext_ncd_put_var_ti_integer(handle,'sr_x', &
1210 trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus)
1211 call ext_ncd_put_var_ti_integer(handle,'sr_y', &
1212 trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus)
1213 end if
1214 #endif
1215 #ifdef IO_GRIB1
1216 if (io_form_output == GRIB1) then
1217 call ext_gr1_put_var_ti_char(handle, 'units', &
1218 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
1219 call ext_gr1_put_var_ti_char(handle, 'description', &
1220 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
1221 call ext_gr1_put_var_ti_char(handle, 'stagger', &
1222 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
1223 call ext_gr1_put_var_ti_integer(handle,'sr_x', &
1224 trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus)
1225 call ext_gr1_put_var_ti_integer(handle,'sr_y', &
1226 trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus)
1227 end if
1228 #endif
1229 end if
1230 end if
1231 exit
1232 end if
1233 end do
1235 end if
1237 if (allocated_real_locally) deallocate(real_dom_array)
1239 end subroutine write_field
1242 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1243 ! Name: write_global_attrs
1244 !
1245 ! Purpose:
1246 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1247 subroutine write_global_attrs(title, start_date, grid_type, dyn_opt, &
1248 west_east_dim, south_north_dim, bottom_top_dim, &
1249 we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, &
1250 sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, &
1251 map_proj, cmminlu, num_land_cat, is_water, is_lake, is_ice, &
1252 is_urban, i_soilwater, grid_id, parent_id, &
1253 i_parent_start, j_parent_start, i_parent_end, j_parent_end, &
1254 dx, dy, cen_lat, moad_cen_lat, cen_lon, &
1255 stand_lon, truelat1, truelat2, pole_lat, pole_lon, &
1256 parent_grid_ratio, sr_x, sr_y, corner_lats, corner_lons, &
1257 num_metgrid_soil_levs, &
1258 flags, nflags, flag_excluded_middle)
1260 implicit none
1262 ! Arguments
1263 integer, intent(in) :: dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, &
1264 we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, &
1265 sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, &
1266 map_proj, is_water, is_lake, is_ice, is_urban, i_soilwater, &
1267 grid_id, parent_id, i_parent_start, j_parent_start, &
1268 i_parent_end, j_parent_end, parent_grid_ratio, sr_x, sr_y, num_land_cat
1269 integer, intent(in), optional :: num_metgrid_soil_levs
1270 integer, intent(in), optional :: nflags
1271 integer, intent(in), optional :: flag_excluded_middle
1272 real, intent(in) :: dx, dy, cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, &
1273 pole_lat, pole_lon
1274 real, dimension(16), intent(in) :: corner_lats, corner_lons
1275 character (len=*), intent(in) :: title, start_date, grid_type
1276 character (len=128), intent(in) :: cmminlu
1277 character (len=128), dimension(:), intent(in), optional :: flags
1279 ! Local variables
1280 integer :: local_we_patch_s, local_we_patch_s_stag, &
1281 local_we_patch_e, local_we_patch_e_stag, &
1282 local_sn_patch_s, local_sn_patch_s_stag, &
1283 local_sn_patch_e, local_sn_patch_e_stag
1284 integer :: i
1285 real, dimension(16) :: local_corner_lats, local_corner_lons
1287 local_we_patch_s = we_patch_s
1288 local_we_patch_s_stag = we_patch_s_stag
1289 local_we_patch_e = we_patch_e
1290 local_we_patch_e_stag = we_patch_e_stag
1291 local_sn_patch_s = sn_patch_s
1292 local_sn_patch_s_stag = sn_patch_s_stag
1293 local_sn_patch_e = sn_patch_e
1294 local_sn_patch_e_stag = sn_patch_e_stag
1295 local_corner_lats = corner_lats
1296 local_corner_lons = corner_lons
1298 if (nprocs > 1) then
1300 if (.not. do_tiled_output) then
1301 call parallel_bcast_int(local_we_patch_s, processors(0, 0))
1302 call parallel_bcast_int(local_we_patch_s_stag, processors(0, 0))
1303 call parallel_bcast_int(local_sn_patch_s, processors(0, 0))
1304 call parallel_bcast_int(local_sn_patch_s_stag, processors(0, 0))
1306 call parallel_bcast_int(local_we_patch_e, processors(nproc_x-1, nproc_y-1))
1307 call parallel_bcast_int(local_we_patch_e_stag, processors(nproc_x-1, nproc_y-1))
1308 call parallel_bcast_int(local_sn_patch_e, processors(nproc_x-1, nproc_y-1))
1309 call parallel_bcast_int(local_sn_patch_e_stag, processors(nproc_x-1, nproc_y-1))
1310 end if
1312 call parallel_bcast_real(local_corner_lats(1), processors(0, 0))
1313 call parallel_bcast_real(local_corner_lats(2), processors(0, nproc_y-1))
1314 call parallel_bcast_real(local_corner_lats(3), processors(nproc_x-1, nproc_y-1))
1315 call parallel_bcast_real(local_corner_lats(4), processors(nproc_x-1, 0))
1316 call parallel_bcast_real(local_corner_lats(5), processors(0, 0))
1317 call parallel_bcast_real(local_corner_lats(6), processors(0, nproc_y-1))
1318 call parallel_bcast_real(local_corner_lats(7), processors(nproc_x-1, nproc_y-1))
1319 call parallel_bcast_real(local_corner_lats(8), processors(nproc_x-1, 0))
1320 call parallel_bcast_real(local_corner_lats(9), processors(0, 0))
1321 call parallel_bcast_real(local_corner_lats(10), processors(0, nproc_y-1))
1322 call parallel_bcast_real(local_corner_lats(11), processors(nproc_x-1, nproc_y-1))
1323 call parallel_bcast_real(local_corner_lats(12), processors(nproc_x-1, 0))
1324 call parallel_bcast_real(local_corner_lats(13), processors(0, 0))
1325 call parallel_bcast_real(local_corner_lats(14), processors(0, nproc_y-1))
1326 call parallel_bcast_real(local_corner_lats(15), processors(nproc_x-1, nproc_y-1))
1327 call parallel_bcast_real(local_corner_lats(16), processors(nproc_x-1, 0))
1329 call parallel_bcast_real(local_corner_lons(1), processors(0, 0))
1330 call parallel_bcast_real(local_corner_lons(2), processors(0, nproc_y-1))
1331 call parallel_bcast_real(local_corner_lons(3), processors(nproc_x-1, nproc_y-1))
1332 call parallel_bcast_real(local_corner_lons(4), processors(nproc_x-1, 0))
1333 call parallel_bcast_real(local_corner_lons(5), processors(0, 0))
1334 call parallel_bcast_real(local_corner_lons(6), processors(0, nproc_y-1))
1335 call parallel_bcast_real(local_corner_lons(7), processors(nproc_x-1, nproc_y-1))
1336 call parallel_bcast_real(local_corner_lons(8), processors(nproc_x-1, 0))
1337 call parallel_bcast_real(local_corner_lons(9), processors(0, 0))
1338 call parallel_bcast_real(local_corner_lons(10), processors(0, nproc_y-1))
1339 call parallel_bcast_real(local_corner_lons(11), processors(nproc_x-1, nproc_y-1))
1340 call parallel_bcast_real(local_corner_lons(12), processors(nproc_x-1, 0))
1341 call parallel_bcast_real(local_corner_lons(13), processors(0, 0))
1342 call parallel_bcast_real(local_corner_lons(14), processors(0, nproc_y-1))
1343 call parallel_bcast_real(local_corner_lons(15), processors(nproc_x-1, nproc_y-1))
1344 call parallel_bcast_real(local_corner_lons(16), processors(nproc_x-1, 0))
1345 end if
1347 if (my_proc_id == IO_NODE .or. do_tiled_output) then
1349 call ext_put_dom_ti_char ('TITLE', title)
1350 call ext_put_dom_ti_char ('SIMULATION_START_DATE', start_date)
1351 call ext_put_dom_ti_integer_scalar('WEST-EAST_GRID_DIMENSION', west_east_dim)
1352 call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_GRID_DIMENSION', south_north_dim)
1353 call ext_put_dom_ti_integer_scalar('BOTTOM-TOP_GRID_DIMENSION', bottom_top_dim)
1354 call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_UNSTAG', local_we_patch_s)
1355 call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_UNSTAG', local_we_patch_e)
1356 call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_STAG', local_we_patch_s_stag)
1357 call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_STAG', local_we_patch_e_stag)
1358 call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_UNSTAG', local_sn_patch_s)
1359 call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_UNSTAG', local_sn_patch_e)
1360 call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_STAG', local_sn_patch_s_stag)
1361 call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_STAG', local_sn_patch_e_stag)
1362 call ext_put_dom_ti_char ('GRIDTYPE', grid_type)
1363 call ext_put_dom_ti_real_scalar ('DX', dx)
1364 call ext_put_dom_ti_real_scalar ('DY', dy)
1365 call ext_put_dom_ti_integer_scalar('DYN_OPT', dyn_opt)
1366 call ext_put_dom_ti_real_scalar ('CEN_LAT', cen_lat)
1367 call ext_put_dom_ti_real_scalar ('CEN_LON', cen_lon)
1368 call ext_put_dom_ti_real_scalar ('TRUELAT1', truelat1)
1369 call ext_put_dom_ti_real_scalar ('TRUELAT2', truelat2)
1370 call ext_put_dom_ti_real_scalar ('MOAD_CEN_LAT', moad_cen_lat)
1371 call ext_put_dom_ti_real_scalar ('STAND_LON', stand_lon)
1372 call ext_put_dom_ti_real_scalar ('POLE_LAT', pole_lat)
1373 call ext_put_dom_ti_real_scalar ('POLE_LON', pole_lon)
1374 call ext_put_dom_ti_real_vector ('corner_lats', local_corner_lats, 16)
1375 call ext_put_dom_ti_real_vector ('corner_lons', local_corner_lons, 16)
1376 call ext_put_dom_ti_integer_scalar('MAP_PROJ', map_proj)
1377 call ext_put_dom_ti_char ('MMINLU', trim(cmminlu))
1378 call ext_put_dom_ti_integer_scalar('NUM_LAND_CAT', num_land_cat)
1379 call ext_put_dom_ti_integer_scalar('ISWATER', is_water)
1380 call ext_put_dom_ti_integer_scalar('ISLAKE', is_lake)
1381 call ext_put_dom_ti_integer_scalar('ISICE', is_ice)
1382 call ext_put_dom_ti_integer_scalar('ISURBAN', is_urban)
1383 call ext_put_dom_ti_integer_scalar('ISOILWATER', i_soilwater)
1384 call ext_put_dom_ti_integer_scalar('grid_id', grid_id)
1385 call ext_put_dom_ti_integer_scalar('parent_id', parent_id)
1386 call ext_put_dom_ti_integer_scalar('i_parent_start', i_parent_start)
1387 call ext_put_dom_ti_integer_scalar('j_parent_start', j_parent_start)
1388 call ext_put_dom_ti_integer_scalar('i_parent_end', i_parent_end)
1389 call ext_put_dom_ti_integer_scalar('j_parent_end', j_parent_end)
1390 call ext_put_dom_ti_integer_scalar('parent_grid_ratio', parent_grid_ratio)
1391 call ext_put_dom_ti_integer_scalar('sr_x',sr_x)
1392 call ext_put_dom_ti_integer_scalar('sr_y',sr_y)
1393 #ifdef _METGRID
1394 if (present(num_metgrid_soil_levs)) then
1395 call ext_put_dom_ti_integer_scalar('NUM_METGRID_SOIL_LEVELS', num_metgrid_soil_levs)
1396 end if
1397 call ext_put_dom_ti_integer_scalar('FLAG_METGRID', 1)
1398 if (present(flag_excluded_middle)) then
1399 call ext_put_dom_ti_integer_scalar('FLAG_EXCLUDED_MIDDLE', flag_excluded_middle)
1400 end if
1401 #endif
1403 if (present(nflags) .and. present(flags)) then
1404 do i=1,nflags
1405 if (flags(i) /= ' ') then
1406 call ext_put_dom_ti_integer_scalar(trim(flags(i)), 1)
1407 end if
1408 end do
1409 end if
1411 end if
1413 end subroutine write_global_attrs
1416 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1417 ! Name: ext_put_dom_ti_integer
1418 !
1419 ! Purpose: Write a domain time-independent integer attribute to output.
1420 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1421 subroutine ext_put_dom_ti_integer_scalar(var_name, var_value)
1423 implicit none
1425 ! Arguments
1426 integer, intent(in) :: var_value
1427 character (len=*), intent(in) :: var_name
1429 ! Local variables
1430 integer :: istatus
1432 #ifdef IO_BINARY
1433 if (io_form_output == BINARY) then
1434 call ext_int_put_dom_ti_integer(handle, trim(var_name), &
1435 (/ var_value /), &
1436 1, istatus)
1437 end if
1438 #endif
1439 #ifdef IO_NETCDF
1440 if (io_form_output == NETCDF) then
1441 call ext_ncd_put_dom_ti_integer(handle, trim(var_name), &
1442 (/ var_value /), &
1443 1, istatus)
1444 end if
1445 #endif
1446 #ifdef IO_GRIB1
1447 if (io_form_output == GRIB1) then
1448 call ext_gr1_put_dom_ti_integer(handle, trim(var_name), &
1449 (/ var_value /), &
1450 1, istatus)
1451 end if
1452 #endif
1454 call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1456 end subroutine ext_put_dom_ti_integer_scalar
1459 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1460 ! Name: ext_put_dom_ti_integer
1461 !
1462 ! Purpose: Write a domain time-independent integer attribute to output.
1463 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1464 subroutine ext_put_dom_ti_integer_vector(var_name, var_value, n)
1466 implicit none
1468 ! Arguments
1469 integer, intent(in) :: n
1470 integer, dimension(n), intent(in) :: var_value
1471 character (len=*), intent(in) :: var_name
1473 ! Local variables
1474 integer :: istatus
1476 #ifdef IO_BINARY
1477 if (io_form_output == BINARY) then
1478 call ext_int_put_dom_ti_integer(handle, trim(var_name), &
1479 var_value, &
1480 n, istatus)
1481 end if
1482 #endif
1483 #ifdef IO_NETCDF
1484 if (io_form_output == NETCDF) then
1485 call ext_ncd_put_dom_ti_integer(handle, trim(var_name), &
1486 var_value, &
1487 n, istatus)
1488 end if
1489 #endif
1490 #ifdef IO_GRIB1
1491 if (io_form_output == GRIB1) then
1492 call ext_gr1_put_dom_ti_integer(handle, trim(var_name), &
1493 var_value, &
1494 n, istatus)
1495 end if
1496 #endif
1498 call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1500 end subroutine ext_put_dom_ti_integer_vector
1503 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1504 ! Name: ext_put_dom_ti_real
1505 !
1506 ! Purpose: Write a domain time-independent real attribute to output.
1507 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1508 subroutine ext_put_dom_ti_real_scalar(var_name, var_value)
1510 implicit none
1512 ! Arguments
1513 real, intent(in) :: var_value
1514 character (len=*), intent(in) :: var_name
1516 ! Local variables
1517 integer :: istatus
1519 #ifdef IO_BINARY
1520 if (io_form_output == BINARY) then
1521 call ext_int_put_dom_ti_real(handle, trim(var_name), &
1522 (/ var_value /), &
1523 1, istatus)
1524 end if
1525 #endif
1526 #ifdef IO_NETCDF
1527 if (io_form_output == NETCDF) then
1528 call ext_ncd_put_dom_ti_real(handle, trim(var_name), &
1529 (/ var_value /), &
1530 1, istatus)
1531 end if
1532 #endif
1533 #ifdef IO_GRIB1
1534 if (io_form_output == GRIB1) then
1535 call ext_gr1_put_dom_ti_real(handle, trim(var_name), &
1536 (/ var_value /), &
1537 1, istatus)
1538 end if
1539 #endif
1541 call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1543 end subroutine ext_put_dom_ti_real_scalar
1546 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1547 ! Name: ext_put_dom_ti_real
1548 !
1549 ! Purpose: Write a domain time-independent real attribute to output.
1550 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1551 subroutine ext_put_dom_ti_real_vector(var_name, var_value, n)
1553 implicit none
1555 ! Arguments
1556 integer, intent(in) :: n
1557 real, dimension(n), intent(in) :: var_value
1558 character (len=*), intent(in) :: var_name
1560 ! Local variables
1561 integer :: istatus
1563 #ifdef IO_BINARY
1564 if (io_form_output == BINARY) then
1565 call ext_int_put_dom_ti_real(handle, trim(var_name), &
1566 var_value, &
1567 n, istatus)
1568 end if
1569 #endif
1570 #ifdef IO_NETCDF
1571 if (io_form_output == NETCDF) then
1572 call ext_ncd_put_dom_ti_real(handle, trim(var_name), &
1573 var_value, &
1574 n, istatus)
1575 end if
1576 #endif
1577 #ifdef IO_GRIB1
1578 if (io_form_output == GRIB1) then
1579 call ext_gr1_put_dom_ti_real(handle, trim(var_name), &
1580 var_value, &
1581 n, istatus)
1582 end if
1583 #endif
1585 call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1587 end subroutine ext_put_dom_ti_real_vector
1590 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1591 ! Name: ext_put_dom_ti_char
1592 !
1593 ! Purpose: Write a domain time-independent character attribute to output.
1594 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1595 subroutine ext_put_dom_ti_char(var_name, var_value)
1597 implicit none
1599 ! Arguments
1600 character (len=*), intent(in) :: var_name, var_value
1602 ! Local variables
1603 integer :: istatus
1605 #ifdef IO_BINARY
1606 if (io_form_output == BINARY) then
1607 call ext_int_put_dom_ti_char(handle, trim(var_name), &
1608 trim(var_value), &
1609 istatus)
1610 end if
1611 #endif
1612 #ifdef IO_NETCDF
1613 if (io_form_output == NETCDF) then
1614 call ext_ncd_put_dom_ti_char(handle, trim(var_name), &
1615 trim(var_value), &
1616 istatus)
1617 end if
1618 #endif
1619 #ifdef IO_GRIB1
1620 if (io_form_output == GRIB1) then
1621 call ext_gr1_put_dom_ti_char(handle, trim(var_name), &
1622 trim(var_value), &
1623 istatus)
1624 end if
1625 #endif
1627 call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1629 end subroutine ext_put_dom_ti_char
1632 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1633 ! Name: output_close
1634 !
1635 ! Purpose: Finalizes all output. This may include closing windows, calling I/O
1636 ! API termination routines, or closing files.
1637 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1638 subroutine output_close()
1640 implicit none
1642 ! Local variables
1643 integer :: istatus
1645 if (my_proc_id == IO_NODE .or. do_tiled_output) then
1647 istatus = 0
1648 #ifdef IO_BINARY
1649 if (io_form_output == BINARY) call ext_int_ioclose(handle, istatus)
1650 #endif
1651 #ifdef IO_NETCDF
1652 if (io_form_output == NETCDF) call ext_ncd_ioclose(handle, istatus)
1653 #endif
1654 #ifdef IO_GRIB1
1655 if (io_form_output == GRIB1) call ext_gr1_ioclose(handle, istatus)
1656 #endif
1657 call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioclose')
1659 istatus = 0
1660 #ifdef IO_BINARY
1661 if (io_form_output == BINARY) call ext_int_ioexit(istatus)
1662 #endif
1663 #ifdef IO_NETCDF
1664 if (io_form_output == NETCDF) call ext_ncd_ioexit(istatus)
1665 #endif
1666 #ifdef IO_GRIB1
1667 if (io_form_output == GRIB1) call ext_gr1_ioexit(istatus)
1668 #endif
1669 call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioexit')
1671 end if
1673 if (associated(fields)) deallocate(fields)
1675 end subroutine output_close
1677 end module output_module