| blob | 5eb0584f6dc9718d926647562392a1f5c87815ce |
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
463 !
464 ! First find out how many fields there are
465 !
466 call reset_next_field()
468 ifieldstatus = 0
469 nfields = 0
470 optstatus = 0
471 do while (ifieldstatus == 0)
473 call get_next_output_fieldname(nest_num, fieldname, ndims, &
474 min_category, max_category, &
475 istagger, memorder, dimnames, &
476 units, description, sr_x, sr_y, &
477 derived_from, ifieldstatus)
478 #ifdef _GEOGRID
479 if (len_trim(derived_from) > 0) then
480 call get_source_opt_status(trim(derived_from), 0, optstatus)
481 else
482 call get_source_opt_status(trim(fieldname), 0, optstatus)
483 end if
484 #endif
486 if (ifieldstatus == 0 .and. optstatus == 0) then
487 nfields = nfields + 1
488 end if
489 end do
491 #ifdef _METGRID
492 NUM_FIELDS = nfields
493 #endif
495 #ifdef _GEOGRID
496 if (grid_type == 'C') NUM_AUTOMATIC_FIELDS = 28
497 if (grid_type == 'E') NUM_AUTOMATIC_FIELDS = 7
499 NUM_FIELDS = nfields+NUM_AUTOMATIC_FIELDS
500 allocate(fields(NUM_FIELDS))
502 ! Automatic fields will always be on the non-refined grid
503 sr_x=1
504 sr_y=1
506 !
507 ! There are some fields that will always be computed
508 ! Initialize those fields first, followed by all user-specified fields
509 !
510 if (grid_type == 'C') then
511 fields(1)%fieldname = 'XLAT_M'
512 fields(1)%units = 'degrees latitude'
513 fields(1)%descr = 'Latitude on mass grid'
515 fields(2)%fieldname = 'XLONG_M'
516 fields(2)%units = 'degrees longitude'
517 fields(2)%descr = 'Longitude on mass grid'
519 fields(3)%fieldname = 'XLAT_V'
520 fields(3)%units = 'degrees latitude'
521 fields(3)%descr = 'Latitude on V grid'
523 fields(4)%fieldname = 'XLONG_V'
524 fields(4)%units = 'degrees longitude'
525 fields(4)%descr = 'Longitude on V grid'
527 fields(5)%fieldname = 'XLAT_U'
528 fields(5)%units = 'degrees latitude'
529 fields(5)%descr = 'Latitude on U grid'
531 fields(6)%fieldname = 'XLONG_U'
532 fields(6)%units = 'degrees longitude'
533 fields(6)%descr = 'Longitude on U grid'
535 fields(7)%fieldname = 'CLAT'
536 fields(7)%units = 'degrees latitude'
537 fields(7)%descr = 'Computational latitude on mass grid'
539 fields(8)%fieldname = 'CLONG'
540 fields(8)%units = 'degrees longitude'
541 fields(8)%descr = 'Computational longitude on mass grid'
543 fields(9)%fieldname = 'MAPFAC_M'
544 fields(9)%units = 'none'
545 fields(9)%descr = 'Mapfactor on mass grid'
547 fields(10)%fieldname = 'MAPFAC_V'
548 fields(10)%units = 'none'
549 fields(10)%descr = 'Mapfactor on V grid'
551 fields(11)%fieldname = 'MAPFAC_U'
552 fields(11)%units = 'none'
553 fields(11)%descr = 'Mapfactor on U grid'
555 fields(12)%fieldname = 'MAPFAC_MX'
556 fields(12)%units = 'none'
557 fields(12)%descr = 'Mapfactor (x-dir) on mass grid'
559 fields(13)%fieldname = 'MAPFAC_VX'
560 fields(13)%units = 'none'
561 fields(13)%descr = 'Mapfactor (x-dir) on V grid'
563 fields(14)%fieldname = 'MAPFAC_UX'
564 fields(14)%units = 'none'
565 fields(14)%descr = 'Mapfactor (x-dir) on U grid'
567 fields(15)%fieldname = 'MAPFAC_MY'
568 fields(15)%units = 'none'
569 fields(15)%descr = 'Mapfactor (y-dir) on mass grid'
571 fields(16)%fieldname = 'MAPFAC_VY'
572 fields(16)%units = 'none'
573 fields(16)%descr = 'Mapfactor (y-dir) on V grid'
575 fields(17)%fieldname = 'MAPFAC_UY'
576 fields(17)%units = 'none'
577 fields(17)%descr = 'Mapfactor (y-dir) on U grid'
579 fields(18)%fieldname = 'E'
580 fields(18)%units = '-'
581 fields(18)%descr = 'Coriolis E parameter'
583 fields(19)%fieldname = 'F'
584 fields(19)%units = '-'
585 fields(19)%descr = 'Coriolis F parameter'
587 fields(20)%fieldname = 'SINALPHA'
588 fields(20)%units = 'none'
589 fields(20)%descr = 'Sine of rotation angle'
591 fields(21)%fieldname = 'COSALPHA'
592 fields(21)%units = 'none'
593 fields(21)%descr = 'Cosine of rotation angle'
595 fields(22)%fieldname = 'LANDMASK'
596 fields(22)%units = 'none'
597 fields(22)%descr = 'Landmask : 1=land, 0=water'
599 fields(23)%fieldname = 'XLAT_C'
600 fields(23)%units = 'degrees latitude'
601 fields(23)%descr = 'Latitude at grid cell corners'
603 fields(24)%fieldname = 'XLONG_C'
604 fields(24)%units = 'degrees longitude'
605 fields(24)%descr = 'Longitude at grid cell corners'
607 fields(25)%fieldname = 'SINALPHA_U'
608 fields(25)%units = 'none'
609 fields(25)%descr = 'Sine of rotation angle on U grid'
611 fields(26)%fieldname = 'COSALPHA_U'
612 fields(26)%units = 'none'
613 fields(26)%descr = 'Cosine of rotation angle on U grid'
615 fields(27)%fieldname = 'SINALPHA_V'
616 fields(27)%units = 'none'
617 fields(27)%descr = 'Sine of rotation angle on V grid'
619 fields(28)%fieldname = 'COSALPHA_V'
620 fields(28)%units = 'none'
621 fields(28)%descr = 'Cosine of rotation angle on V grid'
623 else if (grid_type == 'E') then
624 fields(1)%fieldname = 'XLAT_M'
625 fields(1)%units = 'degrees latitude'
626 fields(1)%descr = 'Latitude on mass grid'
628 fields(2)%fieldname = 'XLONG_M'
629 fields(2)%units = 'degrees longitude'
630 fields(2)%descr = 'Longitude on mass grid'
632 fields(3)%fieldname = 'XLAT_V'
633 fields(3)%units = 'degrees latitude'
634 fields(3)%descr = 'Latitude on velocity grid'
636 fields(4)%fieldname = 'XLONG_V'
637 fields(4)%units = 'degrees longitude'
638 fields(4)%descr = 'Longitude on velocity grid'
640 fields(5)%fieldname = 'E'
641 fields(5)%units = '-'
642 fields(5)%descr = 'Coriolis E parameter'
644 fields(6)%fieldname = 'F'
645 fields(6)%units = '-'
646 fields(6)%descr = 'Coriolis F parameter'
648 fields(7)%fieldname = 'LANDMASK'
649 fields(7)%units = 'none'
650 fields(7)%descr = 'Landmask : 1=land, 0=water'
652 end if
654 !
655 ! General defaults for "always computed" fields
656 !
657 do i=1,NUM_AUTOMATIC_FIELDS
658 fields(i)%ndims = 2
659 fields(i)%dom_start(1) = start_dom_1
660 fields(i)%dom_start(2) = start_dom_2
661 fields(i)%dom_start(3) = 1
662 fields(i)%mem_start(1) = start_mem_1
663 fields(i)%mem_start(2) = start_mem_2
664 fields(i)%mem_start(3) = 1
665 fields(i)%patch_start(1) = start_patch_1
666 fields(i)%patch_start(2) = start_patch_2
667 fields(i)%patch_start(3) = 1
668 fields(i)%dom_end(1) = end_dom_1
669 fields(i)%dom_end(2) = end_dom_2
670 fields(i)%dom_end(3) = 1
671 fields(i)%mem_end(1) = end_mem_1
672 fields(i)%mem_end(2) = end_mem_2
673 fields(i)%mem_end(3) = 1
674 fields(i)%patch_end(1) = end_patch_1
675 fields(i)%patch_end(2) = end_patch_2
676 fields(i)%patch_end(3) = 1
677 fields(i)%dimnames(3) = ' '
678 fields(i)%mem_order = 'XY'
679 fields(i)%stagger = 'M'
680 fields(i)%sr_x = 1
681 fields(i)%sr_y = 1
682 if (grid_type == 'C') then
683 fields(i)%istagger = M
684 else if (grid_type == 'E') then
685 fields(i)%istagger = HH
686 end if
687 fields(i)%dimnames(1) = 'west_east'
688 fields(i)%dimnames(2) = 'south_north'
689 end do
691 !
692 ! Perform adjustments to metadata for non-mass-staggered "always computed" fields
693 !
694 if (grid_type == 'C') then
695 ! Lat V
696 if (extra_row) then
697 fields(3)%dom_end(2) = fields(3)%dom_end(2) + 1
698 fields(3)%mem_end(2) = fields(3)%mem_end(2) + 1
699 fields(3)%patch_end(2) = fields(3)%patch_end(2) + 1
700 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
701 fields(3)%dom_end(2) = fields(3)%dom_end(2) + 1
702 end if
703 fields(3)%dimnames(2) = 'south_north_stag'
704 fields(3)%stagger = 'V'
705 fields(3)%istagger = V
707 ! Lon V
708 if (extra_row) then
709 fields(4)%dom_end(2) = fields(4)%dom_end(2) + 1
710 fields(4)%mem_end(2) = fields(4)%mem_end(2) + 1
711 fields(4)%patch_end(2) = fields(4)%patch_end(2) + 1
712 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
713 fields(4)%dom_end(2) = fields(4)%dom_end(2) + 1
714 end if
715 fields(4)%dimnames(2) = 'south_north_stag'
716 fields(4)%stagger = 'V'
717 fields(4)%istagger = V
719 ! Lat U
720 if (extra_col) then
721 fields(5)%dom_end(1) = fields(5)%dom_end(1) + 1
722 fields(5)%mem_end(1) = fields(5)%mem_end(1) + 1
723 fields(5)%patch_end(1) = fields(5)%patch_end(1) + 1
724 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
725 fields(5)%dom_end(1) = fields(5)%dom_end(1) + 1
726 end if
727 fields(5)%dimnames(1) = 'west_east_stag'
728 fields(5)%stagger = 'U'
729 fields(5)%istagger = U
731 ! Lon U
732 if (extra_col) then
733 fields(6)%dom_end(1) = fields(6)%dom_end(1) + 1
734 fields(6)%mem_end(1) = fields(6)%mem_end(1) + 1
735 fields(6)%patch_end(1) = fields(6)%patch_end(1) + 1
736 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
737 fields(6)%dom_end(1) = fields(6)%dom_end(1) + 1
738 end if
739 fields(6)%dimnames(1) = 'west_east_stag'
740 fields(6)%stagger = 'U'
741 fields(6)%istagger = U
743 ! Mapfac V
744 if (extra_row) then
745 fields(10)%dom_end(2) = fields(10)%dom_end(2) + 1
746 fields(10)%mem_end(2) = fields(10)%mem_end(2) + 1
747 fields(10)%patch_end(2) = fields(10)%patch_end(2) + 1
748 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
749 fields(10)%dom_end(2) = fields(10)%dom_end(2) + 1
750 end if
751 fields(10)%dimnames(2) = 'south_north_stag'
752 fields(10)%stagger = 'V'
753 fields(10)%istagger = V
755 ! Mapfac U
756 if (extra_col) then
757 fields(11)%dom_end(1) = fields(11)%dom_end(1) + 1
758 fields(11)%mem_end(1) = fields(11)%mem_end(1) + 1
759 fields(11)%patch_end(1) = fields(11)%patch_end(1) + 1
760 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
761 fields(11)%dom_end(1) = fields(11)%dom_end(1) + 1
762 end if
763 fields(11)%dimnames(1) = 'west_east_stag'
764 fields(11)%stagger = 'U'
765 fields(11)%istagger = U
767 ! Mapfac V-X
768 if (extra_row) then
769 fields(13)%dom_end(2) = fields(13)%dom_end(2) + 1
770 fields(13)%mem_end(2) = fields(13)%mem_end(2) + 1
771 fields(13)%patch_end(2) = fields(13)%patch_end(2) + 1
772 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
773 fields(13)%dom_end(2) = fields(13)%dom_end(2) + 1
774 end if
775 fields(13)%dimnames(2) = 'south_north_stag'
776 fields(13)%stagger = 'V'
777 fields(13)%istagger = V
779 ! Mapfac U-X
780 if (extra_col) then
781 fields(14)%dom_end(1) = fields(14)%dom_end(1) + 1
782 fields(14)%mem_end(1) = fields(14)%mem_end(1) + 1
783 fields(14)%patch_end(1) = fields(14)%patch_end(1) + 1
784 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
785 fields(14)%dom_end(1) = fields(14)%dom_end(1) + 1
786 end if
787 fields(14)%dimnames(1) = 'west_east_stag'
788 fields(14)%stagger = 'U'
789 fields(14)%istagger = U
791 ! Mapfac V-Y
792 if (extra_row) then
793 fields(16)%dom_end(2) = fields(16)%dom_end(2) + 1
794 fields(16)%mem_end(2) = fields(16)%mem_end(2) + 1
795 fields(16)%patch_end(2) = fields(16)%patch_end(2) + 1
796 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
797 fields(16)%dom_end(2) = fields(16)%dom_end(2) + 1
798 end if
799 fields(16)%dimnames(2) = 'south_north_stag'
800 fields(16)%stagger = 'V'
801 fields(16)%istagger = V
803 ! Mapfac U-Y
804 if (extra_col) then
805 fields(17)%dom_end(1) = fields(17)%dom_end(1) + 1
806 fields(17)%mem_end(1) = fields(17)%mem_end(1) + 1
807 fields(17)%patch_end(1) = fields(17)%patch_end(1) + 1
808 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
809 fields(17)%dom_end(1) = fields(17)%dom_end(1) + 1
810 end if
811 fields(17)%dimnames(1) = 'west_east_stag'
812 fields(17)%stagger = 'U'
813 fields(17)%istagger = U
815 ! Lat (unstaggered)
816 if (extra_row) then
817 fields(23)%dom_end(2) = fields(23)%dom_end(2) + 1
818 fields(23)%mem_end(2) = fields(23)%mem_end(2) + 1
819 fields(23)%patch_end(2) = fields(23)%patch_end(2) + 1
820 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
821 fields(23)%dom_end(2) = fields(23)%dom_end(2) + 1
822 end if
823 if (extra_col) then
824 fields(23)%dom_end(1) = fields(23)%dom_end(1) + 1
825 fields(23)%mem_end(1) = fields(23)%mem_end(1) + 1
826 fields(23)%patch_end(1) = fields(23)%patch_end(1) + 1
827 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
828 fields(23)%dom_end(1) = fields(23)%dom_end(1) + 1
829 end if
830 fields(23)%dimnames(1) = 'west_east_stag'
831 fields(23)%dimnames(2) = 'south_north_stag'
832 fields(23)%stagger = 'CORNER'
833 fields(23)%istagger = CORNER
835 ! Lon (unstaggered)
836 if (extra_row) then
837 fields(24)%dom_end(2) = fields(24)%dom_end(2) + 1
838 fields(24)%mem_end(2) = fields(24)%mem_end(2) + 1
839 fields(24)%patch_end(2) = fields(24)%patch_end(2) + 1
840 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
841 fields(24)%dom_end(2) = fields(24)%dom_end(2) + 1
842 end if
843 if (extra_col) then
844 fields(24)%dom_end(1) = fields(24)%dom_end(1) + 1
845 fields(24)%mem_end(1) = fields(24)%mem_end(1) + 1
846 fields(24)%patch_end(1) = fields(24)%patch_end(1) + 1
847 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
848 fields(24)%dom_end(1) = fields(24)%dom_end(1) + 1
849 end if
850 fields(24)%dimnames(1) = 'west_east_stag'
851 fields(24)%dimnames(2) = 'south_north_stag'
852 fields(24)%stagger = 'CORNER'
853 fields(24)%istagger = CORNER
855 ! SINALPHA on U
856 if (extra_col) then
857 fields(25)%dom_end(1) = fields(25)%dom_end(1) + 1
858 fields(25)%mem_end(1) = fields(25)%mem_end(1) + 1
859 fields(25)%patch_end(1) = fields(25)%patch_end(1) + 1
860 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
861 fields(25)%dom_end(1) = fields(25)%dom_end(1) + 1
862 end if
863 fields(25)%dimnames(1) = 'west_east_stag'
864 fields(25)%stagger = 'U'
865 fields(25)%istagger = U
867 ! COSALPHA on U
868 if (extra_col) then
869 fields(26)%dom_end(1) = fields(26)%dom_end(1) + 1
870 fields(26)%mem_end(1) = fields(26)%mem_end(1) + 1
871 fields(26)%patch_end(1) = fields(26)%patch_end(1) + 1
872 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
873 fields(26)%dom_end(1) = fields(26)%dom_end(1) + 1
874 end if
875 fields(26)%dimnames(1) = 'west_east_stag'
876 fields(26)%stagger = 'U'
877 fields(26)%istagger = U
879 ! SINALPHA on V
880 if (extra_row) then
881 fields(27)%dom_end(2) = fields(27)%dom_end(2) + 1
882 fields(27)%mem_end(2) = fields(27)%mem_end(2) + 1
883 fields(27)%patch_end(2) = fields(27)%patch_end(2) + 1
884 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
885 fields(27)%dom_end(2) = fields(27)%dom_end(2) + 1
886 end if
887 fields(27)%dimnames(2) = 'south_north_stag'
888 fields(27)%stagger = 'V'
889 fields(27)%istagger = V
891 ! COSALPHA on V
892 if (extra_row) then
893 fields(28)%dom_end(2) = fields(28)%dom_end(2) + 1
894 fields(28)%mem_end(2) = fields(28)%mem_end(2) + 1
895 fields(28)%patch_end(2) = fields(28)%patch_end(2) + 1
896 else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
897 fields(28)%dom_end(2) = fields(28)%dom_end(2) + 1
898 end if
899 fields(28)%dimnames(2) = 'south_north_stag'
900 fields(28)%stagger = 'V'
901 fields(28)%istagger = V
903 else if (grid_type == 'E') then
904 ! Lat V
905 fields(3)%stagger = 'V'
906 fields(3)%istagger = VV
908 ! Lon V
909 fields(4)%stagger = 'V'
910 fields(4)%istagger = VV
912 end if
913 #endif
915 !
916 ! Now set up the field_info structure for each user-specified field
917 !
918 call reset_next_field()
920 ifieldstatus = 0
921 #ifdef _GEOGRID
922 nfields = NUM_AUTOMATIC_FIELDS+1
923 #endif
924 #ifdef _METGRID
925 allocate(fields(NUM_FIELDS))
926 nfields = 1
927 #endif
929 optstatus = 0
930 do while (ifieldstatus == 0) !{
931 call get_next_output_fieldname(nest_num, fieldname, ndims, &
932 min_category, max_category, &
933 istagger, memorder, dimnames, &
934 units, description, sr_x, sr_y, &
935 derived_from, ifieldstatus)
936 #ifdef _GEOGRID
937 if (len_trim(derived_from) > 0) then
938 call get_source_opt_status(trim(derived_from), 0, optstatus)
939 else
940 call get_source_opt_status(trim(fieldname), 0, optstatus)
941 end if
942 #endif
945 if (ifieldstatus == 0 .and. optstatus == 0) then !{
947 fields(nfields)%ndims = ndims
948 fields(nfields)%fieldname = fieldname
949 fields(nfields)%istagger = istagger
950 if (istagger == M) then
951 fields(nfields)%stagger = 'M'
952 else if (istagger == U) then
953 fields(nfields)%stagger = 'U'
954 else if (istagger == V) then
955 fields(nfields)%stagger = 'V'
956 else if (istagger == HH) then
957 fields(nfields)%stagger = 'M'
958 else if (istagger == VV) then
959 fields(nfields)%stagger = 'V'
960 else if (istagger == CORNER) then
961 fields(nfields)%stagger = 'CORNER'
962 end if
963 fields(nfields)%mem_order = memorder
964 fields(nfields)%dimnames(1) = dimnames(1)
965 fields(nfields)%dimnames(2) = dimnames(2)
966 fields(nfields)%dimnames(3) = dimnames(3)
967 fields(nfields)%units = units
968 fields(nfields)%descr = description
970 fields(nfields)%dom_start(1) = start_dom_1
971 fields(nfields)%dom_start(2) = start_dom_2
972 fields(nfields)%dom_start(3) = min_category
973 fields(nfields)%mem_start(1) = start_mem_1
974 fields(nfields)%mem_start(2) = start_mem_2
975 fields(nfields)%mem_start(3) = min_category
976 fields(nfields)%patch_start(1) = start_patch_1
977 fields(nfields)%patch_start(2) = start_patch_2
978 fields(nfields)%patch_start(3) = min_category
980 fields(nfields)%dom_end(1) = end_dom_1
981 fields(nfields)%dom_end(2) = end_dom_2
982 fields(nfields)%dom_end(3) = max_category
983 fields(nfields)%mem_end(1) = end_mem_1
984 fields(nfields)%mem_end(2) = end_mem_2
985 fields(nfields)%mem_end(3) = max_category
986 fields(nfields)%patch_end(1) = end_patch_1
987 fields(nfields)%patch_end(2) = end_patch_2
988 fields(nfields)%patch_end(3) = max_category
990 fields(nfields)%sr_x=sr_x
991 fields(nfields)%sr_y=sr_y
993 if (extra_col .and. (istagger == U .or. istagger == CORNER .or. sr_x > 1)) then !{
994 fields(nfields)%dom_end(1) = fields(nfields)%dom_end(1) + 1
995 fields(nfields)%mem_end(1) = fields(nfields)%mem_end(1) + 1
996 fields(nfields)%patch_end(1) = fields(nfields)%patch_end(1) + 1
997 else if ((istagger == U .or. istagger == CORNER .or. sr_x > 1) &
998 .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then
999 fields(nfields)%dom_end(1)=fields(nfields)%dom_end(1) + 1
1000 end if !}
1002 if (extra_row .and. (istagger == V .or. istagger == CORNER .or. sr_y > 1)) then !{
1003 fields(nfields)%dom_end(2) = fields(nfields)%dom_end(2) + 1
1004 fields(nfields)%mem_end(2) = fields(nfields)%mem_end(2) + 1
1005 fields(nfields)%patch_end(2) = fields(nfields)%patch_end(2) + 1
1006 else if ((istagger == V .or. istagger == CORNER .or. sr_y > 1) &
1007 .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then
1008 fields(nfields)%dom_end(2)=fields(nfields)%dom_end(2) + 1
1009 end if !}
1011 #ifdef _METGRID
1012 lhalo_width = start_patch_1 - start_mem_1 ! Halo width on left of patch
1013 rhalo_width = end_mem_1 - end_patch_1 ! Halo width on right of patch
1014 bhalo_width = start_patch_2 - start_mem_2 ! Halo width on bottom of patch
1015 thalo_width = end_mem_2 - end_patch_2 ! Halo width on top of patch
1016 #else
1017 lhalo_width = 0
1018 rhalo_width = 0
1019 bhalo_width = 0
1020 thalo_width = 0
1021 #endif
1023 if (sr_x > 1) then
1024 fields(nfields)%mem_start(1) = (fields(nfields)%mem_start(1) + lhalo_width - 1)*sr_x + 1 - lhalo_width
1025 fields(nfields)%patch_start(1) = (fields(nfields)%patch_start(1) - 1)*sr_x + 1
1026 fields(nfields)%dom_start(1) = (fields(nfields)%dom_start(1) - 1)*sr_x + 1
1028 fields(nfields)%mem_end(1) = (fields(nfields)%mem_end(1) - rhalo_width)*sr_x + rhalo_width
1029 fields(nfields)%patch_end(1) = (fields(nfields)%patch_end(1) )*sr_x
1030 fields(nfields)%dom_end(1) = (fields(nfields)%dom_end(1) )*sr_x
1031 endif
1033 if (sr_y > 1) then
1034 fields(nfields)%mem_start(2) = (fields(nfields)%mem_start(2) + bhalo_width - 1)*sr_y + 1 - bhalo_width
1035 fields(nfields)%patch_start(2) = (fields(nfields)%patch_start(2) - 1)*sr_y + 1
1036 fields(nfields)%dom_start(2) = (fields(nfields)%dom_start(2) - 1)*sr_y + 1
1038 fields(nfields)%mem_end(2) = (fields(nfields)%mem_end(2) - thalo_width)*sr_y + thalo_width
1039 fields(nfields)%patch_end(2) = (fields(nfields)%patch_end(2) )*sr_y
1040 fields(nfields)%dom_end(2) = (fields(nfields)%dom_end(2) )*sr_y
1041 endif
1044 nfields = nfields + 1
1046 end if ! the next field given by get_next_fieldname() is valid }
1048 end do ! for each user-specified field }
1050 end subroutine init_output_fields
1053 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1054 ! Name: write_field
1055 !
1056 ! Purpose: This routine writes the provided field to any output devices or APIs
1057 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1058 subroutine write_field(start_mem_i, end_mem_i, &
1059 start_mem_j, end_mem_j, &
1060 start_mem_k, end_mem_k, &
1061 cname, datestr, real_array, is_training)
1063 implicit none
1065 ! Arguments
1066 integer, intent(in) :: start_mem_i, end_mem_i, start_mem_j, end_mem_j, start_mem_k, end_mem_k
1067 real, target, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j, start_mem_k:end_mem_k), &
1068 intent(in) :: real_array
1069 logical, intent(in), optional :: is_training
1070 character (len=19), intent(in) :: datestr
1071 character (len=*), intent(in) :: cname
1073 #include "wrf_io_flags.h"
1074 #include "wrf_status_codes.h"
1076 ! Local variables
1077 integer :: i
1078 integer :: istatus, comm_1, comm_2, domain_desc
1079 integer, dimension(3) :: sd, ed, sp, ep, sm, em
1080 real, pointer, dimension(:,:,:) :: real_dom_array
1081 logical :: allocated_real_locally
1083 allocated_real_locally = .false.
1085 ! If we are running distributed memory and need to gather all tiles onto a single processor for output
1086 if (nprocs > 1 .and. .not. do_tiled_output) then
1087 do i=1,NUM_FIELDS
1088 if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
1089 (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
1090 istatus = 0
1092 ! For the gather routines below, the IO_NODE should give the full domain dimensions, but the
1093 ! memory and patch dimensions should indicate what the processor already has in its patch_array.
1094 ! This is because an array with dimensions of the full domain will be allocated, and the patch_array
1095 ! will be copied from local memory into the full domain array in the area specified by the patch
1096 ! dimensions.
1097 sd = fields(i)%dom_start
1098 ed = fields(i)%dom_end
1099 sp = fields(i)%patch_start
1100 ep = fields(i)%patch_end
1101 sm = fields(i)%mem_start
1102 em = fields(i)%mem_end
1104 allocate(real_dom_array(sd(1):ed(1),sd(2):ed(2),sd(3):ed(3)))
1105 allocated_real_locally = .true.
1106 call gather_whole_field_r(real_array, &
1107 sm(1), em(1), sm(2), em(2), sm(3), em(3), &
1108 sp(1), ep(1), sp(2), ep(2), sp(3), ep(3), &
1109 real_dom_array, &
1110 sd(1), ed(1), sd(2), ed(2), sd(3), ed(3))
1111 exit
1112 end if
1113 end do
1114 else
1115 do i=1,NUM_FIELDS
1116 if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
1117 (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
1118 istatus = 0
1119 real_dom_array => real_array
1120 exit
1121 end if
1122 end do
1123 end if
1125 ! Now a write call is only done if each processor writes its own file, or if we are the IO_NODE
1126 if (my_proc_id == IO_NODE .or. do_tiled_output) then
1127 comm_1 = 1
1128 comm_2 = 1
1129 domain_desc = 0
1131 do i=1,NUM_FIELDS
1132 if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
1133 (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
1135 ! Here, the output array has dimensions of the full grid if it was gathered together
1136 ! from all processors
1137 if (my_proc_id == IO_NODE .and. nprocs > 1 .and. .not. do_tiled_output) then
1138 sd = fields(i)%dom_start
1139 ed = fields(i)%dom_end
1140 sm = sd
1141 em = ed
1142 sp = sd
1143 ep = ed
1144 ! If we are writing one file per processor, then each processor only writes out the
1145 ! part of the domain that it has in memory
1146 else
1147 ! BUG: Shouldn't we set sd/ed to be domain_start/domain_end?
1148 ! Maybe not, since patch is already adjusted for staggering; but maybe so, and also adjust
1149 ! for staggering if it is alright to pass true domain dimensions to write_field.
1150 sd = fields(i)%patch_start
1151 ed = fields(i)%patch_end
1152 sp = fields(i)%patch_start
1153 ep = fields(i)%patch_end
1154 sm = fields(i)%mem_start
1155 em = fields(i)%mem_end
1156 end if
1158 istatus = 0
1159 #ifdef IO_BINARY
1160 if (io_form_output == BINARY) then
1161 call ext_int_write_field(handle, datestr, trim(fields(i)%fieldname), &
1162 real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
1163 trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
1164 end if
1165 #endif
1166 #ifdef IO_NETCDF
1167 if (io_form_output == NETCDF) then
1168 call ext_ncd_write_field(handle, datestr, trim(fields(i)%fieldname), &
1169 real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
1170 trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
1171 end if
1172 #endif
1173 #ifdef IO_GRIB1
1174 if (io_form_output == GRIB1) then
1175 call ext_gr1_write_field(handle, datestr, trim(fields(i)%fieldname), &
1176 real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
1177 trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
1178 end if
1179 #endif
1180 call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_write_field')
1182 if (present(is_training)) then
1183 if (is_training) then
1184 #ifdef IO_BINARY
1185 if (io_form_output == BINARY) then
1186 call ext_int_put_var_ti_char(handle, 'units', &
1187 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
1188 call ext_int_put_var_ti_char(handle, 'description', &
1189 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
1190 call ext_int_put_var_ti_char(handle, 'stagger', &
1191 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
1192 call ext_int_put_var_ti_integer(handle,'sr_x', &
1193 trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus)
1194 call ext_int_put_var_ti_integer(handle,'sr_y', &
1195 trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus)
1196 end if
1197 #endif
1198 #ifdef IO_NETCDF
1199 if (io_form_output == NETCDF) then
1200 call ext_ncd_put_var_ti_char(handle, 'units', &
1201 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
1202 call ext_ncd_put_var_ti_char(handle, 'description', &
1203 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
1204 call ext_ncd_put_var_ti_char(handle, 'stagger', &
1205 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
1206 call ext_ncd_put_var_ti_integer(handle,'sr_x', &
1207 trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus)
1208 call ext_ncd_put_var_ti_integer(handle,'sr_y', &
1209 trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus)
1210 end if
1211 #endif
1212 #ifdef IO_GRIB1
1213 if (io_form_output == GRIB1) then
1214 call ext_gr1_put_var_ti_char(handle, 'units', &
1215 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
1216 call ext_gr1_put_var_ti_char(handle, 'description', &
1217 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
1218 call ext_gr1_put_var_ti_char(handle, 'stagger', &
1219 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
1220 call ext_gr1_put_var_ti_integer(handle,'sr_x', &
1221 trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus)
1222 call ext_gr1_put_var_ti_integer(handle,'sr_y', &
1223 trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus)
1224 end if
1225 #endif
1226 end if
1227 end if
1228 exit
1229 end if
1230 end do
1232 end if
1234 if (allocated_real_locally) deallocate(real_dom_array)
1236 end subroutine write_field
1239 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1240 ! Name: write_global_attrs
1241 !
1242 ! Purpose:
1243 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1244 subroutine write_global_attrs(title, start_date, grid_type, dyn_opt, &
1245 west_east_dim, south_north_dim, bottom_top_dim, &
1246 we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, &
1247 sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, &
1248 map_proj, cmminlu, num_land_cat, is_water, is_lake, is_ice, &
1249 is_urban, i_soilwater, grid_id, parent_id, &
1250 i_parent_start, j_parent_start, i_parent_end, j_parent_end, &
1251 dx, dy, cen_lat, moad_cen_lat, cen_lon, &
1252 stand_lon, truelat1, truelat2, pole_lat, pole_lon, &
1253 parent_grid_ratio, sr_x, sr_y, corner_lats, corner_lons, &
1254 num_metgrid_soil_levs, &
1255 flags, nflags, flag_excluded_middle)
1257 implicit none
1259 ! Arguments
1260 integer, intent(in) :: dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, &
1261 we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, &
1262 sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, &
1263 map_proj, is_water, is_lake, is_ice, is_urban, i_soilwater, &
1264 grid_id, parent_id, i_parent_start, j_parent_start, &
1265 i_parent_end, j_parent_end, parent_grid_ratio, sr_x, sr_y, num_land_cat
1266 integer, intent(in), optional :: num_metgrid_soil_levs
1267 integer, intent(in), optional :: nflags
1268 integer, intent(in), optional :: flag_excluded_middle
1269 real, intent(in) :: dx, dy, cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, &
1270 pole_lat, pole_lon
1271 real, dimension(16), intent(in) :: corner_lats, corner_lons
1272 character (len=*), intent(in) :: title, start_date, grid_type
1273 character (len=128), intent(in) :: cmminlu
1274 character (len=128), dimension(:), intent(in), optional :: flags
1276 ! Local variables
1277 integer :: local_we_patch_s, local_we_patch_s_stag, &
1278 local_we_patch_e, local_we_patch_e_stag, &
1279 local_sn_patch_s, local_sn_patch_s_stag, &
1280 local_sn_patch_e, local_sn_patch_e_stag
1281 integer :: i
1282 real, dimension(16) :: local_corner_lats, local_corner_lons
1284 local_we_patch_s = we_patch_s
1285 local_we_patch_s_stag = we_patch_s_stag
1286 local_we_patch_e = we_patch_e
1287 local_we_patch_e_stag = we_patch_e_stag
1288 local_sn_patch_s = sn_patch_s
1289 local_sn_patch_s_stag = sn_patch_s_stag
1290 local_sn_patch_e = sn_patch_e
1291 local_sn_patch_e_stag = sn_patch_e_stag
1292 local_corner_lats = corner_lats
1293 local_corner_lons = corner_lons
1295 if (nprocs > 1) then
1297 if (.not. do_tiled_output) then
1298 call parallel_bcast_int(local_we_patch_s, processors(0, 0))
1299 call parallel_bcast_int(local_we_patch_s_stag, processors(0, 0))
1300 call parallel_bcast_int(local_sn_patch_s, processors(0, 0))
1301 call parallel_bcast_int(local_sn_patch_s_stag, processors(0, 0))
1303 call parallel_bcast_int(local_we_patch_e, processors(nproc_x-1, nproc_y-1))
1304 call parallel_bcast_int(local_we_patch_e_stag, processors(nproc_x-1, nproc_y-1))
1305 call parallel_bcast_int(local_sn_patch_e, processors(nproc_x-1, nproc_y-1))
1306 call parallel_bcast_int(local_sn_patch_e_stag, processors(nproc_x-1, nproc_y-1))
1307 end if
1309 call parallel_bcast_real(local_corner_lats(1), processors(0, 0))
1310 call parallel_bcast_real(local_corner_lats(2), processors(0, nproc_y-1))
1311 call parallel_bcast_real(local_corner_lats(3), processors(nproc_x-1, nproc_y-1))
1312 call parallel_bcast_real(local_corner_lats(4), processors(nproc_x-1, 0))
1313 call parallel_bcast_real(local_corner_lats(5), processors(0, 0))
1314 call parallel_bcast_real(local_corner_lats(6), processors(0, nproc_y-1))
1315 call parallel_bcast_real(local_corner_lats(7), processors(nproc_x-1, nproc_y-1))
1316 call parallel_bcast_real(local_corner_lats(8), processors(nproc_x-1, 0))
1317 call parallel_bcast_real(local_corner_lats(9), processors(0, 0))
1318 call parallel_bcast_real(local_corner_lats(10), processors(0, nproc_y-1))
1319 call parallel_bcast_real(local_corner_lats(11), processors(nproc_x-1, nproc_y-1))
1320 call parallel_bcast_real(local_corner_lats(12), processors(nproc_x-1, 0))
1321 call parallel_bcast_real(local_corner_lats(13), processors(0, 0))
1322 call parallel_bcast_real(local_corner_lats(14), processors(0, nproc_y-1))
1323 call parallel_bcast_real(local_corner_lats(15), processors(nproc_x-1, nproc_y-1))
1324 call parallel_bcast_real(local_corner_lats(16), processors(nproc_x-1, 0))
1326 call parallel_bcast_real(local_corner_lons(1), processors(0, 0))
1327 call parallel_bcast_real(local_corner_lons(2), processors(0, nproc_y-1))
1328 call parallel_bcast_real(local_corner_lons(3), processors(nproc_x-1, nproc_y-1))
1329 call parallel_bcast_real(local_corner_lons(4), processors(nproc_x-1, 0))
1330 call parallel_bcast_real(local_corner_lons(5), processors(0, 0))
1331 call parallel_bcast_real(local_corner_lons(6), processors(0, nproc_y-1))
1332 call parallel_bcast_real(local_corner_lons(7), processors(nproc_x-1, nproc_y-1))
1333 call parallel_bcast_real(local_corner_lons(8), processors(nproc_x-1, 0))
1334 call parallel_bcast_real(local_corner_lons(9), processors(0, 0))
1335 call parallel_bcast_real(local_corner_lons(10), processors(0, nproc_y-1))
1336 call parallel_bcast_real(local_corner_lons(11), processors(nproc_x-1, nproc_y-1))
1337 call parallel_bcast_real(local_corner_lons(12), processors(nproc_x-1, 0))
1338 call parallel_bcast_real(local_corner_lons(13), processors(0, 0))
1339 call parallel_bcast_real(local_corner_lons(14), processors(0, nproc_y-1))
1340 call parallel_bcast_real(local_corner_lons(15), processors(nproc_x-1, nproc_y-1))
1341 call parallel_bcast_real(local_corner_lons(16), processors(nproc_x-1, 0))
1342 end if
1344 if (my_proc_id == IO_NODE .or. do_tiled_output) then
1346 call ext_put_dom_ti_char ('TITLE', title)
1347 call ext_put_dom_ti_char ('SIMULATION_START_DATE', start_date)
1348 call ext_put_dom_ti_integer_scalar('WEST-EAST_GRID_DIMENSION', west_east_dim)
1349 call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_GRID_DIMENSION', south_north_dim)
1350 call ext_put_dom_ti_integer_scalar('BOTTOM-TOP_GRID_DIMENSION', bottom_top_dim)
1351 call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_UNSTAG', local_we_patch_s)
1352 call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_UNSTAG', local_we_patch_e)
1353 call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_STAG', local_we_patch_s_stag)
1354 call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_STAG', local_we_patch_e_stag)
1355 call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_UNSTAG', local_sn_patch_s)
1356 call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_UNSTAG', local_sn_patch_e)
1357 call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_STAG', local_sn_patch_s_stag)
1358 call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_STAG', local_sn_patch_e_stag)
1359 call ext_put_dom_ti_char ('GRIDTYPE', grid_type)
1360 call ext_put_dom_ti_real_scalar ('DX', dx)
1361 call ext_put_dom_ti_real_scalar ('DY', dy)
1362 call ext_put_dom_ti_integer_scalar('DYN_OPT', dyn_opt)
1363 call ext_put_dom_ti_real_scalar ('CEN_LAT', cen_lat)
1364 call ext_put_dom_ti_real_scalar ('CEN_LON', cen_lon)
1365 call ext_put_dom_ti_real_scalar ('TRUELAT1', truelat1)
1366 call ext_put_dom_ti_real_scalar ('TRUELAT2', truelat2)
1367 call ext_put_dom_ti_real_scalar ('MOAD_CEN_LAT', moad_cen_lat)
1368 call ext_put_dom_ti_real_scalar ('STAND_LON', stand_lon)
1369 call ext_put_dom_ti_real_scalar ('POLE_LAT', pole_lat)
1370 call ext_put_dom_ti_real_scalar ('POLE_LON', pole_lon)
1371 call ext_put_dom_ti_real_vector ('corner_lats', local_corner_lats, 16)
1372 call ext_put_dom_ti_real_vector ('corner_lons', local_corner_lons, 16)
1373 call ext_put_dom_ti_integer_scalar('MAP_PROJ', map_proj)
1374 call ext_put_dom_ti_char ('MMINLU', trim(cmminlu))
1375 call ext_put_dom_ti_integer_scalar('NUM_LAND_CAT', num_land_cat)
1376 call ext_put_dom_ti_integer_scalar('ISWATER', is_water)
1377 call ext_put_dom_ti_integer_scalar('ISLAKE', is_lake)
1378 call ext_put_dom_ti_integer_scalar('ISICE', is_ice)
1379 call ext_put_dom_ti_integer_scalar('ISURBAN', is_urban)
1380 call ext_put_dom_ti_integer_scalar('ISOILWATER', i_soilwater)
1381 call ext_put_dom_ti_integer_scalar('grid_id', grid_id)
1382 call ext_put_dom_ti_integer_scalar('parent_id', parent_id)
1383 call ext_put_dom_ti_integer_scalar('i_parent_start', i_parent_start)
1384 call ext_put_dom_ti_integer_scalar('j_parent_start', j_parent_start)
1385 call ext_put_dom_ti_integer_scalar('i_parent_end', i_parent_end)
1386 call ext_put_dom_ti_integer_scalar('j_parent_end', j_parent_end)
1387 call ext_put_dom_ti_integer_scalar('parent_grid_ratio', parent_grid_ratio)
1388 call ext_put_dom_ti_integer_scalar('sr_x',sr_x)
1389 call ext_put_dom_ti_integer_scalar('sr_y',sr_y)
1390 #ifdef _METGRID
1391 if (present(num_metgrid_soil_levs)) then
1392 call ext_put_dom_ti_integer_scalar('NUM_METGRID_SOIL_LEVELS', num_metgrid_soil_levs)
1393 end if
1394 call ext_put_dom_ti_integer_scalar('FLAG_METGRID', 1)
1395 if (present(flag_excluded_middle)) then
1396 call ext_put_dom_ti_integer_scalar('FLAG_EXCLUDED_MIDDLE', flag_excluded_middle)
1397 end if
1398 #endif
1400 if (present(nflags) .and. present(flags)) then
1401 do i=1,nflags
1402 if (flags(i) /= ' ') then
1403 call ext_put_dom_ti_integer_scalar(trim(flags(i)), 1)
1404 end if
1405 end do
1406 end if
1408 end if
1410 end subroutine write_global_attrs
1413 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1414 ! Name: ext_put_dom_ti_integer
1415 !
1416 ! Purpose: Write a domain time-independent integer attribute to output.
1417 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1418 subroutine ext_put_dom_ti_integer_scalar(var_name, var_value)
1420 implicit none
1422 ! Arguments
1423 integer, intent(in) :: var_value
1424 character (len=*), intent(in) :: var_name
1426 ! Local variables
1427 integer :: istatus
1429 #ifdef IO_BINARY
1430 if (io_form_output == BINARY) then
1431 call ext_int_put_dom_ti_integer(handle, trim(var_name), &
1432 var_value, &
1433 1, istatus)
1434 end if
1435 #endif
1436 #ifdef IO_NETCDF
1437 if (io_form_output == NETCDF) then
1438 call ext_ncd_put_dom_ti_integer(handle, trim(var_name), &
1439 var_value, &
1440 1, istatus)
1441 end if
1442 #endif
1443 #ifdef IO_GRIB1
1444 if (io_form_output == GRIB1) then
1445 call ext_gr1_put_dom_ti_integer(handle, trim(var_name), &
1446 var_value, &
1447 1, istatus)
1448 end if
1449 #endif
1451 call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1453 end subroutine ext_put_dom_ti_integer_scalar
1456 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1457 ! Name: ext_put_dom_ti_integer
1458 !
1459 ! Purpose: Write a domain time-independent integer attribute to output.
1460 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1461 subroutine ext_put_dom_ti_integer_vector(var_name, var_value, n)
1463 implicit none
1465 ! Arguments
1466 integer, intent(in) :: n
1467 integer, dimension(n), intent(in) :: var_value
1468 character (len=*), intent(in) :: var_name
1470 ! Local variables
1471 integer :: istatus
1473 #ifdef IO_BINARY
1474 if (io_form_output == BINARY) then
1475 call ext_int_put_dom_ti_integer(handle, trim(var_name), &
1476 var_value, &
1477 n, istatus)
1478 end if
1479 #endif
1480 #ifdef IO_NETCDF
1481 if (io_form_output == NETCDF) then
1482 call ext_ncd_put_dom_ti_integer(handle, trim(var_name), &
1483 var_value, &
1484 n, istatus)
1485 end if
1486 #endif
1487 #ifdef IO_GRIB1
1488 if (io_form_output == GRIB1) then
1489 call ext_gr1_put_dom_ti_integer(handle, trim(var_name), &
1490 var_value, &
1491 n, istatus)
1492 end if
1493 #endif
1495 call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1497 end subroutine ext_put_dom_ti_integer_vector
1500 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1501 ! Name: ext_put_dom_ti_real
1502 !
1503 ! Purpose: Write a domain time-independent real attribute to output.
1504 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1505 subroutine ext_put_dom_ti_real_scalar(var_name, var_value)
1507 implicit none
1509 ! Arguments
1510 real, intent(in) :: var_value
1511 character (len=*), intent(in) :: var_name
1513 ! Local variables
1514 integer :: istatus
1516 #ifdef IO_BINARY
1517 if (io_form_output == BINARY) then
1518 call ext_int_put_dom_ti_real(handle, trim(var_name), &
1519 var_value, &
1520 1, istatus)
1521 end if
1522 #endif
1523 #ifdef IO_NETCDF
1524 if (io_form_output == NETCDF) then
1525 call ext_ncd_put_dom_ti_real(handle, trim(var_name), &
1526 var_value, &
1527 1, istatus)
1528 end if
1529 #endif
1530 #ifdef IO_GRIB1
1531 if (io_form_output == GRIB1) then
1532 call ext_gr1_put_dom_ti_real(handle, trim(var_name), &
1533 var_value, &
1534 1, istatus)
1535 end if
1536 #endif
1538 call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1540 end subroutine ext_put_dom_ti_real_scalar
1543 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1544 ! Name: ext_put_dom_ti_real
1545 !
1546 ! Purpose: Write a domain time-independent real attribute to output.
1547 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1548 subroutine ext_put_dom_ti_real_vector(var_name, var_value, n)
1550 implicit none
1552 ! Arguments
1553 integer, intent(in) :: n
1554 real, dimension(n), intent(in) :: var_value
1555 character (len=*), intent(in) :: var_name
1557 ! Local variables
1558 integer :: istatus
1560 #ifdef IO_BINARY
1561 if (io_form_output == BINARY) then
1562 call ext_int_put_dom_ti_real(handle, trim(var_name), &
1563 var_value, &
1564 n, istatus)
1565 end if
1566 #endif
1567 #ifdef IO_NETCDF
1568 if (io_form_output == NETCDF) then
1569 call ext_ncd_put_dom_ti_real(handle, trim(var_name), &
1570 var_value, &
1571 n, istatus)
1572 end if
1573 #endif
1574 #ifdef IO_GRIB1
1575 if (io_form_output == GRIB1) then
1576 call ext_gr1_put_dom_ti_real(handle, trim(var_name), &
1577 var_value, &
1578 n, istatus)
1579 end if
1580 #endif
1582 call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1584 end subroutine ext_put_dom_ti_real_vector
1587 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1588 ! Name: ext_put_dom_ti_char
1589 !
1590 ! Purpose: Write a domain time-independent character attribute to output.
1591 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1592 subroutine ext_put_dom_ti_char(var_name, var_value)
1594 implicit none
1596 ! Arguments
1597 character (len=*), intent(in) :: var_name, var_value
1599 ! Local variables
1600 integer :: istatus
1602 #ifdef IO_BINARY
1603 if (io_form_output == BINARY) then
1604 call ext_int_put_dom_ti_char(handle, trim(var_name), &
1605 trim(var_value), &
1606 istatus)
1607 end if
1608 #endif
1609 #ifdef IO_NETCDF
1610 if (io_form_output == NETCDF) then
1611 call ext_ncd_put_dom_ti_char(handle, trim(var_name), &
1612 trim(var_value), &
1613 istatus)
1614 end if
1615 #endif
1616 #ifdef IO_GRIB1
1617 if (io_form_output == GRIB1) then
1618 call ext_gr1_put_dom_ti_char(handle, trim(var_name), &
1619 trim(var_value), &
1620 istatus)
1621 end if
1622 #endif
1624 call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1626 end subroutine ext_put_dom_ti_char
1629 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1630 ! Name: output_close
1631 !
1632 ! Purpose: Finalizes all output. This may include closing windows, calling I/O
1633 ! API termination routines, or closing files.
1634 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1635 subroutine output_close()
1637 implicit none
1639 ! Local variables
1640 integer :: istatus
1642 if (my_proc_id == IO_NODE .or. do_tiled_output) then
1644 istatus = 0
1645 #ifdef IO_BINARY
1646 if (io_form_output == BINARY) call ext_int_ioclose(handle, istatus)
1647 #endif
1648 #ifdef IO_NETCDF
1649 if (io_form_output == NETCDF) call ext_ncd_ioclose(handle, istatus)
1650 #endif
1651 #ifdef IO_GRIB1
1652 if (io_form_output == GRIB1) call ext_gr1_ioclose(handle, istatus)
1653 #endif
1654 call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioclose')
1656 istatus = 0
1657 #ifdef IO_BINARY
1658 if (io_form_output == BINARY) call ext_int_ioexit(istatus)
1659 #endif
1660 #ifdef IO_NETCDF
1661 if (io_form_output == NETCDF) call ext_ncd_ioexit(istatus)
1662 #endif
1663 #ifdef IO_GRIB1
1664 if (io_form_output == GRIB1) call ext_gr1_ioexit(istatus)
1665 #endif
1666 call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioexit')
1668 end if
1670 if (associated(fields)) deallocate(fields)
1672 end subroutine output_close
1674 end module output_module