!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! MODULE OUTPUT_MODULE ! ! This module handles the output of the fields that are generated by the main ! geogrid routines. This output may include output to a console and output to ! the WRF I/O API. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module output_module use parallel_module use gridinfo_module use misc_definitions_module use module_debug use module_internal_header_util integer, parameter :: MAX_DIMENSIONS = 3 integer :: NUM_FIELDS type field_info integer :: ndims, istagger integer, dimension(MAX_DIMENSIONS) :: dom_start, mem_start, patch_start integer, dimension(MAX_DIMENSIONS) :: dom_end, mem_end, patch_end integer :: sr_x, sr_y real, pointer, dimension(:,:,:) :: rdata_arr character (len=128), dimension(MAX_DIMENSIONS) :: dimnames character (len=128) :: fieldname, mem_order, stagger, units, descr end type field_info type (field_info), pointer, dimension(:) :: fields ! WRF I/O API related variables integer :: handle contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: output_init ! ! Purpose: To initialize the output module. Such initialization may include ! opening an X window, and making initialization calls to an I/O API. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine output_init(nest_number, title, datestr, grid_type, dynopt, & corner_lats, corner_lons, & start_dom_1, end_dom_1, start_dom_2, end_dom_2, & start_patch_1, end_patch_1, start_patch_2, end_patch_2, & start_mem_1, end_mem_1, start_mem_2, end_mem_2, & extra_col, extra_row) implicit none ! Arguments integer, intent(in) :: nest_number, dynopt, & start_dom_1, end_dom_1, start_dom_2, end_dom_2, & start_patch_1, end_patch_1, start_patch_2, end_patch_2, & start_mem_1, end_mem_1, start_mem_2, end_mem_2 real, dimension(16), intent(in) :: corner_lats, corner_lons logical, intent(in) :: extra_col, extra_row character (len=1), intent(in) :: grid_type character (len=19), intent(in) :: datestr character (len=*), intent(in) :: title integer, parameter :: WRF_FILE_NOT_OPENED = 100 integer, parameter :: WRF_FILE_OPENED_NOT_COMMITTED = 101 integer, parameter :: WRF_FILE_OPENED_FOR_WRITE = 102 integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 integer, parameter :: WRF_REAL = 104 integer, parameter :: WRF_DOUBLE = 105 integer, parameter :: WRF_FLOAT=WRF_REAL integer, parameter :: WRF_INTEGER = 106 integer, parameter :: WRF_LOGICAL = 107 integer, parameter :: WRF_COMPLEX = 108 integer, parameter :: WRF_DOUBLE_COMPLEX = 109 integer, parameter :: WRF_FILE_OPENED_FOR_UPDATE = 110 !WRF Error and Warning messages (1-999) !All i/o package-specific status codes you may want to add must be handled by your package (see below) ! WRF handles these and netCDF messages only integer, parameter :: WRF_NO_ERR = 0 !no error integer, parameter :: WRF_WARN_FILE_NF = -1 !file not found, or incomplete integer, parameter :: WRF_WARN_MD_NF = -2 !metadata not found integer, parameter :: WRF_WARN_TIME_NF = -3 !timestamp not found integer, parameter :: WRF_WARN_TIME_EOF = -4 !no more timestamps integer, parameter :: WRF_WARN_VAR_NF = -5 !variable not found integer, parameter :: WRF_WARN_VAR_EOF = -6 !no more variables for the current time integer, parameter :: WRF_WARN_TOO_MANY_FILES = -7 !too many open files integer, parameter :: WRF_WARN_TYPE_MISMATCH = -8 !data type mismatch integer, parameter :: WRF_WARN_WRITE_RONLY_FILE = -9 !attempt to write readonly file integer, parameter :: WRF_WARN_READ_WONLY_FILE = -10 !attempt to read writeonly file integer, parameter :: WRF_WARN_FILE_NOT_OPENED = -11 !attempt to access unopened file integer, parameter :: WRF_WARN_2DRYRUNS_1VARIABLE = -12 !attempt to do 2 trainings for 1 variable integer, parameter :: WRF_WARN_READ_PAST_EOF = -13 !attempt to read past EOF integer, parameter :: WRF_WARN_BAD_DATA_HANDLE = -14 !bad data handle integer, parameter :: WRF_WARN_WRTLEN_NE_DRRUNLEN = -15 !write length not equal to training length integer, parameter :: WRF_WARN_TOO_MANY_DIMS = -16 !more dimensions requested than training integer, parameter :: WRF_WARN_COUNT_TOO_LONG = -17 !attempt to read more data than exists integer, parameter :: WRF_WARN_DIMENSION_ERROR = -18 !input dimension inconsistent integer, parameter :: WRF_WARN_BAD_MEMORYORDER = -19 !input MemoryOrder not recognized integer, parameter :: WRF_WARN_DIMNAME_REDEFINED = -20 !a dimension name with 2 different lengths integer, parameter :: WRF_WARN_CHARSTR_GT_LENDATA = -21 !string longer than provided storage integer, parameter :: WRF_WARN_NOTSUPPORTED = -22 !function not supportable integer, parameter :: WRF_WARN_NOOP = -23 !package implements this routine as NOOP !Fatal errors integer, parameter :: WRF_ERR_FATAL_ALLOCATION_ERROR = -100 !allocation error integer, parameter :: WRF_ERR_FATAL_DEALLOCATION_ERR = -101 !dealloc error integer, parameter :: WRF_ERR_FATAL_BAD_FILE_STATUS = -102 !bad file status !Package specific errors (1000+) !Netcdf status codes !WRF will accept status codes of 1000+, but it is up to the package to handle ! and return the status to the user. integer, parameter :: WRF_ERR_FATAL_BAD_VARIABLE_DIM = -1004 integer, parameter :: WRF_ERR_FATAL_MDVAR_DIM_NOT_1D = -1005 integer, parameter :: WRF_ERR_FATAL_TOO_MANY_TIMES = -1006 integer, parameter :: WRF_WARN_BAD_DATA_TYPE = -1007 !this code not in either spec? integer, parameter :: WRF_WARN_FILE_NOT_COMMITTED = -1008 !this code not in either spec? integer, parameter :: WRF_WARN_FILE_OPEN_FOR_READ = -1009 integer, parameter :: WRF_IO_NOT_INITIALIZED = -1010 integer, parameter :: WRF_WARN_MD_AFTER_OPEN = -1011 integer, parameter :: WRF_WARN_TOO_MANY_VARIABLES = -1012 integer, parameter :: WRF_WARN_DRYRUN_CLOSE = -1013 integer, parameter :: WRF_WARN_DATESTR_BAD_LENGTH = -1014 integer, parameter :: WRF_WARN_ZERO_LENGTH_READ = -1015 integer, parameter :: WRF_WARN_DATA_TYPE_NOT_FOUND = -1016 integer, parameter :: WRF_WARN_DATESTR_ERROR = -1017 integer, parameter :: WRF_WARN_DRYRUN_READ = -1018 integer, parameter :: WRF_WARN_ZERO_LENGTH_GET = -1019 integer, parameter :: WRF_WARN_ZERO_LENGTH_PUT = -1020 integer, parameter :: WRF_WARN_NETCDF = -1021 integer, parameter :: WRF_WARN_LENGTH_LESS_THAN_1 = -1022 integer, parameter :: WRF_WARN_MORE_DATA_IN_FILE = -1023 integer, parameter :: WRF_WARN_DATE_LT_LAST_DATE = -1024 ! For HDF5 only integer, parameter :: WRF_HDF5_ERR_FILE = -200 integer, parameter :: WRF_HDF5_ERR_MD = -201 integer, parameter :: WRF_HDF5_ERR_TIME = -202 integer, parameter :: WRF_HDF5_ERR_TIME_EOF = -203 integer, parameter :: WRF_HDF5_ERR_MORE_DATA_IN_FILE = -204 integer, parameter :: WRF_HDF5_ERR_DATE_LT_LAST_DATE = -205 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_FILES = -206 integer, parameter :: WRF_HDF5_ERR_TYPE_MISMATCH = -207 integer, parameter :: WRF_HDF5_ERR_LENGTH_LESS_THAN_1 = -208 integer, parameter :: WRF_HDF5_ERR_WRITE_RONLY_FILE = -209 integer, parameter :: WRF_HDF5_ERR_READ_WONLY_FILE = -210 integer, parameter :: WRF_HDF5_ERR_FILE_NOT_OPENED = -211 integer, parameter :: WRF_HDF5_ERR_DATESTR_ERROR = -212 integer, parameter :: WRF_HDF5_ERR_DRYRUN_READ = -213 integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_GET = -214 integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_PUT = -215 integer, parameter :: WRF_HDF5_ERR_2DRYRUNS_1VARIABLE = -216 integer, parameter :: WRF_HDF5_ERR_DATA_TYPE_NOTFOUND = -217 integer, parameter :: WRF_HDF5_ERR_READ_PAST_EOF = -218 integer, parameter :: WRF_HDF5_ERR_BAD_DATA_HANDLE = -219 integer, parameter :: WRF_HDF5_ERR_WRTLEN_NE_DRRUNLEN = -220 integer, parameter :: WRF_HDF5_ERR_DRYRUN_CLOSE = -221 integer, parameter :: WRF_HDF5_ERR_DATESTR_BAD_LENGTH = -222 integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_READ = -223 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_DIMS = -224 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_VARIABLES = -225 integer, parameter :: WRF_HDF5_ERR_COUNT_TOO_LONG = -226 integer, parameter :: WRF_HDF5_ERR_DIMENSION_ERROR = -227 integer, parameter :: WRF_HDF5_ERR_BAD_MEMORYORDER = -228 integer, parameter :: WRF_HDF5_ERR_DIMNAME_REDEFINED = -229 integer, parameter :: WRF_HDF5_ERR_MD_AFTER_OPEN = -230 integer, parameter :: WRF_HDF5_ERR_CHARSTR_GT_LENDATA = -231 integer, parameter :: WRF_HDF5_ERR_BAD_DATA_TYPE = -232 integer, parameter :: WRF_HDF5_ERR_FILE_NOT_COMMITTED = -233 integer, parameter :: WRF_HDF5_ERR_ALLOCATION = -2001 integer, parameter :: WRF_HDF5_ERR_DEALLOCATION = -2002 integer, parameter :: WRF_HDF5_ERR_BAD_FILE_STATUS = -2003 integer, parameter :: WRF_HDF5_ERR_BAD_VARIABLE_DIM = -2004 integer, parameter :: WRF_HDF5_ERR_MDVAR_DIM_NOT_1D = -2005 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_TIMES = -2006 integer, parameter :: WRF_HDF5_ERR_DATA_ID_NOTFOUND = -2007 integer, parameter :: WRF_HDF5_ERR_DATASPACE = -300 integer, parameter :: WRF_HDF5_ERR_DATATYPE = -301 integer, parameter :: WRF_HDF5_ERR_PROPERTY_LIST = -302 integer, parameter :: WRF_HDF5_ERR_DATASET_CREATE = -303 integer, parameter :: WRF_HDF5_ERR_DATASET_READ = -304 integer, parameter :: WRF_HDF5_ERR_DATASET_WRITE = -305 integer, parameter :: WRF_HDF5_ERR_DATASET_OPEN = -306 integer, parameter :: WRF_HDF5_ERR_DATASET_GENERAL = -307 integer, parameter :: WRF_HDF5_ERR_GROUP = -308 integer, parameter :: WRF_HDF5_ERR_FILE_OPEN = -309 integer, parameter :: WRF_HDF5_ERR_FILE_CREATE = -310 integer, parameter :: WRF_HDF5_ERR_DATASET_CLOSE = -311 integer, parameter :: WRF_HDF5_ERR_FILE_CLOSE = -312 integer, parameter :: WRF_HDF5_ERR_CLOSE_GENERAL = -313 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CREATE = -314 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_READ = -315 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_WRITE = -316 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OPEN = -317 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_GENERAL = -318 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CLOSE = -319 integer, parameter :: WRF_HDF5_ERR_OTHERS = -320 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OTHERS = -321 integer, parameter :: WRF_GRIB2_ERR_GRIBCREATE = -401 integer, parameter :: WRF_GRIB2_ERR_ADDLOCAL = -402 integer, parameter :: WRF_GRIB2_ERR_ADDGRIB = -403 integer, parameter :: WRF_GRIB2_ERR_ADDFIELD = -404 integer, parameter :: WRF_GRIB2_ERR_GRIBEND = -405 integer, parameter :: WRF_GRIB2_ERR_WRITE = -406 integer, parameter :: WRF_GRIB2_ERR_GRIB2MAP = -407 integer, parameter :: WRF_GRIB2_ERR_GETGB2 = -408 integer, parameter :: WRF_GRIB2_ERR_READ = -409 ! Local variables integer :: i, istatus, save_domain, comm_1, comm_2 integer :: sp1, ep1, sp2, ep2, ep1_stag, ep2_stag integer :: ngeo_flags integer :: num_land_cat, min_land_cat, max_land_cat real :: dx, dy, cen_lat, cen_lon, moad_cen_lat character (len=128) :: coption, temp_fldname character (len=128), dimension(1) :: geo_flags character (len=MAX_FILENAME_LEN) :: output_fname logical :: supports_training, supports_3d_fields call init_output_fields(nest_number, grid_type, & start_dom_1, end_dom_1, start_dom_2, end_dom_2, & start_patch_1, end_patch_1, start_patch_2, end_patch_2, & start_mem_1, end_mem_1, start_mem_2, end_mem_2, & extra_col, extra_row) if (my_proc_id == IO_NODE .or. do_tiled_output) then istatus = 0 if (io_form_output == BINARY) call ext_int_ioinit('sysdep info', istatus) if (io_form_output == NETCDF) call ext_ncd_ioinit('sysdep info', istatus) if (io_form_output == GRIB1) call ext_gr1_ioinit('sysdep info', istatus) call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioinit') ! Find out what this implementation of WRF I/O API supports istatus = 0 if (io_form_output == BINARY) coption = 'REQUIRE' if (io_form_output == NETCDF) call ext_ncd_inquiry('OPEN_COMMIT_WRITE',coption,istatus) if (io_form_output == GRIB1) call ext_gr1_inquiry('OPEN_COMMIT_WRITE',coption,istatus) call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_inquiry') if (index(coption,'ALLOW') /= 0) then supports_training = .false. else if (index(coption,'REQUIRE') /= 0) then supports_training = .true. else if (index(coption,'NO') /= 0) then supports_training = .false. end if istatus = 0 if (io_form_output == BINARY) coption = 'YES' if (io_form_output == NETCDF) call ext_ncd_inquiry('SUPPORT_3D_FIELDS',coption,istatus) if (io_form_output == GRIB1) call ext_gr1_inquiry('SUPPORT_3D_FIELDS',coption,istatus) call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_inquiry') if (index(coption,'YES') /= 0) then supports_3d_fields = .true. else if (index(coption,'NO') /= 0) then supports_3d_fields = .false. ! BUG: What if we have no plans to write 3-d fields? We should take this into account. call mprintf(.true.,ERROR,'WRF I/O API implementation does NOT support 3-d fields.') end if comm_1 = 1 comm_2 = 1 output_fname = ' ' if (grid_type == 'C') then if (io_form_output == BINARY) then output_fname = trim(opt_output_from_metgrid_path)//'met_em.d .'//trim(datestr)//'.int' end if if (io_form_output == NETCDF) then output_fname = trim(opt_output_from_metgrid_path)//'met_em.d .'//trim(datestr)//'.nc' end if if (io_form_output == GRIB1) then output_fname = trim(opt_output_from_metgrid_path)//'met_em.d .'//trim(datestr)//'.grib' end if i = len_trim(opt_output_from_metgrid_path) write(output_fname(i+9:i+10),'(i2.2)') nest_number else if (grid_type == 'E') then if (io_form_output == BINARY) then output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d .'//trim(datestr)//'.int' end if if (io_form_output == NETCDF) then output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d .'//trim(datestr)//'.nc' end if if (io_form_output == GRIB1) then output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d .'//trim(datestr)//'.grib' end if i = len_trim(opt_output_from_metgrid_path) write(output_fname(i+10:i+11),'(i2.2)') nest_number end if if (nprocs > 1 .and. do_tiled_output) then write(output_fname(len_trim(output_fname)+1:len_trim(output_fname)+5), '(a1,i4.4)') & '_', my_proc_id end if end if call parallel_bcast_logical(supports_training) ! If the implementation requires or supports open_for_write begin/commit semantics if (supports_training) then if (my_proc_id == IO_NODE .or. do_tiled_output) then istatus = 0 if (io_form_output == BINARY) then call ext_int_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus) end if if (io_form_output == NETCDF) then call ext_ncd_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus) end if if (io_form_output == GRIB1) then call ext_gr1_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus) end if call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_open_for_write_begin.') end if do i=1,NUM_FIELDS allocate(fields(i)%rdata_arr(fields(i)%mem_start(1):fields(i)%mem_end(1), & fields(i)%mem_start(2):fields(i)%mem_end(2), & fields(i)%mem_start(3):fields(i)%mem_end(3))) call write_field(fields(i)%mem_start(1), fields(i)%mem_end(1), fields(i)%mem_start(2), & fields(i)%mem_end(2), fields(i)%mem_start(3), fields(i)%mem_end(3), & trim(fields(i)%fieldname), datestr, fields(i)%rdata_arr, is_training=.true.) deallocate(fields(i)%rdata_arr) end do if (my_proc_id == IO_NODE .or. do_tiled_output) then istatus = 0 if (io_form_output == BINARY) call ext_int_open_for_write_commit(handle, istatus) if (io_form_output == NETCDF) call ext_ncd_open_for_write_commit(handle, istatus) if (io_form_output == GRIB1) call ext_gr1_open_for_write_commit(handle, istatus) call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_write_commit') end if else ! No training required if (my_proc_id == IO_NODE .or. do_tiled_output) then istatus = 0 if (io_form_output == BINARY) then call ext_int_open_for_write(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus) end if if (io_form_output == NETCDF) then call ext_ncd_open_for_write(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus) end if if (io_form_output == GRIB1) then call mprintf(.true.,ERROR,'In output_init(), GRIB1 requires begin/commit open sequence.') end if call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_open_for_write_begin') end if end if end subroutine output_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: init_output_fields ! ! Purpose: To fill in structures describing each of the fields that will be ! written to the I/O API !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine init_output_fields(nest_num, grid_type, & start_dom_1, end_dom_1, start_dom_2, end_dom_2, & start_patch_1, end_patch_1, start_patch_2, end_patch_2, & start_mem_1, end_mem_1, start_mem_2, end_mem_2, & extra_col, extra_row) ! Modules use storage_module use parallel_module implicit none ! Arguments integer, intent(in) :: nest_num integer, intent(in) :: start_dom_1, end_dom_1, start_dom_2, end_dom_2, & start_patch_1, end_patch_1, start_patch_2, end_patch_2, & start_mem_1, end_mem_1, start_mem_2, end_mem_2 logical, intent(in) :: extra_col, extra_row character (len=1), intent(in) :: grid_type integer, parameter :: WRF_FILE_NOT_OPENED = 100 integer, parameter :: WRF_FILE_OPENED_NOT_COMMITTED = 101 integer, parameter :: WRF_FILE_OPENED_FOR_WRITE = 102 integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 integer, parameter :: WRF_REAL = 104 integer, parameter :: WRF_DOUBLE = 105 integer, parameter :: WRF_FLOAT=WRF_REAL integer, parameter :: WRF_INTEGER = 106 integer, parameter :: WRF_LOGICAL = 107 integer, parameter :: WRF_COMPLEX = 108 integer, parameter :: WRF_DOUBLE_COMPLEX = 109 integer, parameter :: WRF_FILE_OPENED_FOR_UPDATE = 110 !WRF Error and Warning messages (1-999) !All i/o package-specific status codes you may want to add must be handled by your package (see below) ! WRF handles these and netCDF messages only integer, parameter :: WRF_NO_ERR = 0 !no error integer, parameter :: WRF_WARN_FILE_NF = -1 !file not found, or incomplete integer, parameter :: WRF_WARN_MD_NF = -2 !metadata not found integer, parameter :: WRF_WARN_TIME_NF = -3 !timestamp not found integer, parameter :: WRF_WARN_TIME_EOF = -4 !no more timestamps integer, parameter :: WRF_WARN_VAR_NF = -5 !variable not found integer, parameter :: WRF_WARN_VAR_EOF = -6 !no more variables for the current time integer, parameter :: WRF_WARN_TOO_MANY_FILES = -7 !too many open files integer, parameter :: WRF_WARN_TYPE_MISMATCH = -8 !data type mismatch integer, parameter :: WRF_WARN_WRITE_RONLY_FILE = -9 !attempt to write readonly file integer, parameter :: WRF_WARN_READ_WONLY_FILE = -10 !attempt to read writeonly file integer, parameter :: WRF_WARN_FILE_NOT_OPENED = -11 !attempt to access unopened file integer, parameter :: WRF_WARN_2DRYRUNS_1VARIABLE = -12 !attempt to do 2 trainings for 1 variable integer, parameter :: WRF_WARN_READ_PAST_EOF = -13 !attempt to read past EOF integer, parameter :: WRF_WARN_BAD_DATA_HANDLE = -14 !bad data handle integer, parameter :: WRF_WARN_WRTLEN_NE_DRRUNLEN = -15 !write length not equal to training length integer, parameter :: WRF_WARN_TOO_MANY_DIMS = -16 !more dimensions requested than training integer, parameter :: WRF_WARN_COUNT_TOO_LONG = -17 !attempt to read more data than exists integer, parameter :: WRF_WARN_DIMENSION_ERROR = -18 !input dimension inconsistent integer, parameter :: WRF_WARN_BAD_MEMORYORDER = -19 !input MemoryOrder not recognized integer, parameter :: WRF_WARN_DIMNAME_REDEFINED = -20 !a dimension name with 2 different lengths integer, parameter :: WRF_WARN_CHARSTR_GT_LENDATA = -21 !string longer than provided storage integer, parameter :: WRF_WARN_NOTSUPPORTED = -22 !function not supportable integer, parameter :: WRF_WARN_NOOP = -23 !package implements this routine as NOOP !Fatal errors integer, parameter :: WRF_ERR_FATAL_ALLOCATION_ERROR = -100 !allocation error integer, parameter :: WRF_ERR_FATAL_DEALLOCATION_ERR = -101 !dealloc error integer, parameter :: WRF_ERR_FATAL_BAD_FILE_STATUS = -102 !bad file status !Package specific errors (1000+) !Netcdf status codes !WRF will accept status codes of 1000+, but it is up to the package to handle ! and return the status to the user. integer, parameter :: WRF_ERR_FATAL_BAD_VARIABLE_DIM = -1004 integer, parameter :: WRF_ERR_FATAL_MDVAR_DIM_NOT_1D = -1005 integer, parameter :: WRF_ERR_FATAL_TOO_MANY_TIMES = -1006 integer, parameter :: WRF_WARN_BAD_DATA_TYPE = -1007 !this code not in either spec? integer, parameter :: WRF_WARN_FILE_NOT_COMMITTED = -1008 !this code not in either spec? integer, parameter :: WRF_WARN_FILE_OPEN_FOR_READ = -1009 integer, parameter :: WRF_IO_NOT_INITIALIZED = -1010 integer, parameter :: WRF_WARN_MD_AFTER_OPEN = -1011 integer, parameter :: WRF_WARN_TOO_MANY_VARIABLES = -1012 integer, parameter :: WRF_WARN_DRYRUN_CLOSE = -1013 integer, parameter :: WRF_WARN_DATESTR_BAD_LENGTH = -1014 integer, parameter :: WRF_WARN_ZERO_LENGTH_READ = -1015 integer, parameter :: WRF_WARN_DATA_TYPE_NOT_FOUND = -1016 integer, parameter :: WRF_WARN_DATESTR_ERROR = -1017 integer, parameter :: WRF_WARN_DRYRUN_READ = -1018 integer, parameter :: WRF_WARN_ZERO_LENGTH_GET = -1019 integer, parameter :: WRF_WARN_ZERO_LENGTH_PUT = -1020 integer, parameter :: WRF_WARN_NETCDF = -1021 integer, parameter :: WRF_WARN_LENGTH_LESS_THAN_1 = -1022 integer, parameter :: WRF_WARN_MORE_DATA_IN_FILE = -1023 integer, parameter :: WRF_WARN_DATE_LT_LAST_DATE = -1024 ! For HDF5 only integer, parameter :: WRF_HDF5_ERR_FILE = -200 integer, parameter :: WRF_HDF5_ERR_MD = -201 integer, parameter :: WRF_HDF5_ERR_TIME = -202 integer, parameter :: WRF_HDF5_ERR_TIME_EOF = -203 integer, parameter :: WRF_HDF5_ERR_MORE_DATA_IN_FILE = -204 integer, parameter :: WRF_HDF5_ERR_DATE_LT_LAST_DATE = -205 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_FILES = -206 integer, parameter :: WRF_HDF5_ERR_TYPE_MISMATCH = -207 integer, parameter :: WRF_HDF5_ERR_LENGTH_LESS_THAN_1 = -208 integer, parameter :: WRF_HDF5_ERR_WRITE_RONLY_FILE = -209 integer, parameter :: WRF_HDF5_ERR_READ_WONLY_FILE = -210 integer, parameter :: WRF_HDF5_ERR_FILE_NOT_OPENED = -211 integer, parameter :: WRF_HDF5_ERR_DATESTR_ERROR = -212 integer, parameter :: WRF_HDF5_ERR_DRYRUN_READ = -213 integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_GET = -214 integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_PUT = -215 integer, parameter :: WRF_HDF5_ERR_2DRYRUNS_1VARIABLE = -216 integer, parameter :: WRF_HDF5_ERR_DATA_TYPE_NOTFOUND = -217 integer, parameter :: WRF_HDF5_ERR_READ_PAST_EOF = -218 integer, parameter :: WRF_HDF5_ERR_BAD_DATA_HANDLE = -219 integer, parameter :: WRF_HDF5_ERR_WRTLEN_NE_DRRUNLEN = -220 integer, parameter :: WRF_HDF5_ERR_DRYRUN_CLOSE = -221 integer, parameter :: WRF_HDF5_ERR_DATESTR_BAD_LENGTH = -222 integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_READ = -223 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_DIMS = -224 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_VARIABLES = -225 integer, parameter :: WRF_HDF5_ERR_COUNT_TOO_LONG = -226 integer, parameter :: WRF_HDF5_ERR_DIMENSION_ERROR = -227 integer, parameter :: WRF_HDF5_ERR_BAD_MEMORYORDER = -228 integer, parameter :: WRF_HDF5_ERR_DIMNAME_REDEFINED = -229 integer, parameter :: WRF_HDF5_ERR_MD_AFTER_OPEN = -230 integer, parameter :: WRF_HDF5_ERR_CHARSTR_GT_LENDATA = -231 integer, parameter :: WRF_HDF5_ERR_BAD_DATA_TYPE = -232 integer, parameter :: WRF_HDF5_ERR_FILE_NOT_COMMITTED = -233 integer, parameter :: WRF_HDF5_ERR_ALLOCATION = -2001 integer, parameter :: WRF_HDF5_ERR_DEALLOCATION = -2002 integer, parameter :: WRF_HDF5_ERR_BAD_FILE_STATUS = -2003 integer, parameter :: WRF_HDF5_ERR_BAD_VARIABLE_DIM = -2004 integer, parameter :: WRF_HDF5_ERR_MDVAR_DIM_NOT_1D = -2005 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_TIMES = -2006 integer, parameter :: WRF_HDF5_ERR_DATA_ID_NOTFOUND = -2007 integer, parameter :: WRF_HDF5_ERR_DATASPACE = -300 integer, parameter :: WRF_HDF5_ERR_DATATYPE = -301 integer, parameter :: WRF_HDF5_ERR_PROPERTY_LIST = -302 integer, parameter :: WRF_HDF5_ERR_DATASET_CREATE = -303 integer, parameter :: WRF_HDF5_ERR_DATASET_READ = -304 integer, parameter :: WRF_HDF5_ERR_DATASET_WRITE = -305 integer, parameter :: WRF_HDF5_ERR_DATASET_OPEN = -306 integer, parameter :: WRF_HDF5_ERR_DATASET_GENERAL = -307 integer, parameter :: WRF_HDF5_ERR_GROUP = -308 integer, parameter :: WRF_HDF5_ERR_FILE_OPEN = -309 integer, parameter :: WRF_HDF5_ERR_FILE_CREATE = -310 integer, parameter :: WRF_HDF5_ERR_DATASET_CLOSE = -311 integer, parameter :: WRF_HDF5_ERR_FILE_CLOSE = -312 integer, parameter :: WRF_HDF5_ERR_CLOSE_GENERAL = -313 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CREATE = -314 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_READ = -315 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_WRITE = -316 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OPEN = -317 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_GENERAL = -318 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CLOSE = -319 integer, parameter :: WRF_HDF5_ERR_OTHERS = -320 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OTHERS = -321 integer, parameter :: WRF_GRIB2_ERR_GRIBCREATE = -401 integer, parameter :: WRF_GRIB2_ERR_ADDLOCAL = -402 integer, parameter :: WRF_GRIB2_ERR_ADDGRIB = -403 integer, parameter :: WRF_GRIB2_ERR_ADDFIELD = -404 integer, parameter :: WRF_GRIB2_ERR_GRIBEND = -405 integer, parameter :: WRF_GRIB2_ERR_WRITE = -406 integer, parameter :: WRF_GRIB2_ERR_GRIB2MAP = -407 integer, parameter :: WRF_GRIB2_ERR_GETGB2 = -408 integer, parameter :: WRF_GRIB2_ERR_READ = -409 ! Local variables integer :: i, istagger, ifieldstatus, & nfields, min_category, max_category integer :: lhalo_width, rhalo_width, bhalo_width, thalo_width integer :: ndims integer :: optstatus character (len=128) :: fieldname character (len=128) :: derived_from character (len=128) :: memorder, units, description character (len=128), dimension(3) :: dimnames integer :: sr_x, sr_y ! ! First find out how many fields there are ! call reset_next_field() ifieldstatus = 0 nfields = 0 optstatus = 0 do while (ifieldstatus == 0) call get_next_output_fieldname(nest_num, fieldname, ndims, & min_category, max_category, & istagger, memorder, dimnames, & units, description, sr_x, sr_y, & derived_from, ifieldstatus) if (ifieldstatus == 0 .and. optstatus == 0) then nfields = nfields + 1 end if end do NUM_FIELDS = nfields ! ! Now set up the field_info structure for each user-specified field ! call reset_next_field() ifieldstatus = 0 allocate(fields(NUM_FIELDS)) nfields = 1 optstatus = 0 do while (ifieldstatus == 0) !{ call get_next_output_fieldname(nest_num, fieldname, ndims, & min_category, max_category, & istagger, memorder, dimnames, & units, description, sr_x, sr_y, & derived_from, ifieldstatus) if (ifieldstatus == 0 .and. optstatus == 0) then !{ fields(nfields)%ndims = ndims fields(nfields)%fieldname = fieldname fields(nfields)%istagger = istagger if (istagger == M) then fields(nfields)%stagger = 'M' else if (istagger == U) then fields(nfields)%stagger = 'U' else if (istagger == V) then fields(nfields)%stagger = 'V' else if (istagger == HH) then fields(nfields)%stagger = 'M' else if (istagger == VV) then fields(nfields)%stagger = 'V' else if (istagger == CORNER) then fields(nfields)%stagger = 'CORNER' end if fields(nfields)%mem_order = memorder fields(nfields)%dimnames(1) = dimnames(1) fields(nfields)%dimnames(2) = dimnames(2) fields(nfields)%dimnames(3) = dimnames(3) fields(nfields)%units = units fields(nfields)%descr = description fields(nfields)%dom_start(1) = start_dom_1 fields(nfields)%dom_start(2) = start_dom_2 fields(nfields)%dom_start(3) = min_category fields(nfields)%mem_start(1) = start_mem_1 fields(nfields)%mem_start(2) = start_mem_2 fields(nfields)%mem_start(3) = min_category fields(nfields)%patch_start(1) = start_patch_1 fields(nfields)%patch_start(2) = start_patch_2 fields(nfields)%patch_start(3) = min_category fields(nfields)%dom_end(1) = end_dom_1 fields(nfields)%dom_end(2) = end_dom_2 fields(nfields)%dom_end(3) = max_category fields(nfields)%mem_end(1) = end_mem_1 fields(nfields)%mem_end(2) = end_mem_2 fields(nfields)%mem_end(3) = max_category fields(nfields)%patch_end(1) = end_patch_1 fields(nfields)%patch_end(2) = end_patch_2 fields(nfields)%patch_end(3) = max_category fields(nfields)%sr_x=sr_x fields(nfields)%sr_y=sr_y if (extra_col .and. (istagger == U .or. istagger == CORNER .or. sr_x > 1)) then !{ fields(nfields)%dom_end(1) = fields(nfields)%dom_end(1) + 1 fields(nfields)%mem_end(1) = fields(nfields)%mem_end(1) + 1 fields(nfields)%patch_end(1) = fields(nfields)%patch_end(1) + 1 else if ((istagger == U .or. istagger == CORNER .or. sr_x > 1) & .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then fields(nfields)%dom_end(1)=fields(nfields)%dom_end(1) + 1 end if !} if (extra_row .and. (istagger == V .or. istagger == CORNER .or. sr_y > 1)) then !{ fields(nfields)%dom_end(2) = fields(nfields)%dom_end(2) + 1 fields(nfields)%mem_end(2) = fields(nfields)%mem_end(2) + 1 fields(nfields)%patch_end(2) = fields(nfields)%patch_end(2) + 1 else if ((istagger == V .or. istagger == CORNER .or. sr_y > 1) & .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then fields(nfields)%dom_end(2)=fields(nfields)%dom_end(2) + 1 end if !} lhalo_width = start_patch_1 - start_mem_1 ! Halo width on left of patch rhalo_width = end_mem_1 - end_patch_1 ! Halo width on right of patch bhalo_width = start_patch_2 - start_mem_2 ! Halo width on bottom of patch thalo_width = end_mem_2 - end_patch_2 ! Halo width on top of patch if (sr_x > 1) then fields(nfields)%mem_start(1) = (fields(nfields)%mem_start(1) + lhalo_width - 1)*sr_x + 1 - lhalo_width fields(nfields)%patch_start(1) = (fields(nfields)%patch_start(1) - 1)*sr_x + 1 fields(nfields)%dom_start(1) = (fields(nfields)%dom_start(1) - 1)*sr_x + 1 fields(nfields)%mem_end(1) = (fields(nfields)%mem_end(1) - rhalo_width)*sr_x + rhalo_width fields(nfields)%patch_end(1) = (fields(nfields)%patch_end(1) )*sr_x fields(nfields)%dom_end(1) = (fields(nfields)%dom_end(1) )*sr_x endif if (sr_y > 1) then fields(nfields)%mem_start(2) = (fields(nfields)%mem_start(2) + bhalo_width - 1)*sr_y + 1 - bhalo_width fields(nfields)%patch_start(2) = (fields(nfields)%patch_start(2) - 1)*sr_y + 1 fields(nfields)%dom_start(2) = (fields(nfields)%dom_start(2) - 1)*sr_y + 1 fields(nfields)%mem_end(2) = (fields(nfields)%mem_end(2) - thalo_width)*sr_y + thalo_width fields(nfields)%patch_end(2) = (fields(nfields)%patch_end(2) )*sr_y fields(nfields)%dom_end(2) = (fields(nfields)%dom_end(2) )*sr_y endif nfields = nfields + 1 end if ! the next field given by get_next_fieldname() is valid } end do ! for each user-specified field } end subroutine init_output_fields !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: write_field ! ! Purpose: This routine writes the provided field to any output devices or APIs !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine write_field(start_mem_i, end_mem_i, & start_mem_j, end_mem_j, & start_mem_k, end_mem_k, & cname, datestr, real_array, is_training) implicit none ! Arguments integer, intent(in) :: start_mem_i, end_mem_i, start_mem_j, end_mem_j, start_mem_k, end_mem_k real, target, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j, start_mem_k:end_mem_k), & intent(in) :: real_array logical, intent(in), optional :: is_training character (len=19), intent(in) :: datestr character (len=*), intent(in) :: cname integer, parameter :: WRF_FILE_NOT_OPENED = 100 integer, parameter :: WRF_FILE_OPENED_NOT_COMMITTED = 101 integer, parameter :: WRF_FILE_OPENED_FOR_WRITE = 102 integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 integer, parameter :: WRF_REAL = 104 integer, parameter :: WRF_DOUBLE = 105 integer, parameter :: WRF_FLOAT=WRF_REAL integer, parameter :: WRF_INTEGER = 106 integer, parameter :: WRF_LOGICAL = 107 integer, parameter :: WRF_COMPLEX = 108 integer, parameter :: WRF_DOUBLE_COMPLEX = 109 integer, parameter :: WRF_FILE_OPENED_FOR_UPDATE = 110 !WRF Error and Warning messages (1-999) !All i/o package-specific status codes you may want to add must be handled by your package (see below) ! WRF handles these and netCDF messages only integer, parameter :: WRF_NO_ERR = 0 !no error integer, parameter :: WRF_WARN_FILE_NF = -1 !file not found, or incomplete integer, parameter :: WRF_WARN_MD_NF = -2 !metadata not found integer, parameter :: WRF_WARN_TIME_NF = -3 !timestamp not found integer, parameter :: WRF_WARN_TIME_EOF = -4 !no more timestamps integer, parameter :: WRF_WARN_VAR_NF = -5 !variable not found integer, parameter :: WRF_WARN_VAR_EOF = -6 !no more variables for the current time integer, parameter :: WRF_WARN_TOO_MANY_FILES = -7 !too many open files integer, parameter :: WRF_WARN_TYPE_MISMATCH = -8 !data type mismatch integer, parameter :: WRF_WARN_WRITE_RONLY_FILE = -9 !attempt to write readonly file integer, parameter :: WRF_WARN_READ_WONLY_FILE = -10 !attempt to read writeonly file integer, parameter :: WRF_WARN_FILE_NOT_OPENED = -11 !attempt to access unopened file integer, parameter :: WRF_WARN_2DRYRUNS_1VARIABLE = -12 !attempt to do 2 trainings for 1 variable integer, parameter :: WRF_WARN_READ_PAST_EOF = -13 !attempt to read past EOF integer, parameter :: WRF_WARN_BAD_DATA_HANDLE = -14 !bad data handle integer, parameter :: WRF_WARN_WRTLEN_NE_DRRUNLEN = -15 !write length not equal to training length integer, parameter :: WRF_WARN_TOO_MANY_DIMS = -16 !more dimensions requested than training integer, parameter :: WRF_WARN_COUNT_TOO_LONG = -17 !attempt to read more data than exists integer, parameter :: WRF_WARN_DIMENSION_ERROR = -18 !input dimension inconsistent integer, parameter :: WRF_WARN_BAD_MEMORYORDER = -19 !input MemoryOrder not recognized integer, parameter :: WRF_WARN_DIMNAME_REDEFINED = -20 !a dimension name with 2 different lengths integer, parameter :: WRF_WARN_CHARSTR_GT_LENDATA = -21 !string longer than provided storage integer, parameter :: WRF_WARN_NOTSUPPORTED = -22 !function not supportable integer, parameter :: WRF_WARN_NOOP = -23 !package implements this routine as NOOP !Fatal errors integer, parameter :: WRF_ERR_FATAL_ALLOCATION_ERROR = -100 !allocation error integer, parameter :: WRF_ERR_FATAL_DEALLOCATION_ERR = -101 !dealloc error integer, parameter :: WRF_ERR_FATAL_BAD_FILE_STATUS = -102 !bad file status !Package specific errors (1000+) !Netcdf status codes !WRF will accept status codes of 1000+, but it is up to the package to handle ! and return the status to the user. integer, parameter :: WRF_ERR_FATAL_BAD_VARIABLE_DIM = -1004 integer, parameter :: WRF_ERR_FATAL_MDVAR_DIM_NOT_1D = -1005 integer, parameter :: WRF_ERR_FATAL_TOO_MANY_TIMES = -1006 integer, parameter :: WRF_WARN_BAD_DATA_TYPE = -1007 !this code not in either spec? integer, parameter :: WRF_WARN_FILE_NOT_COMMITTED = -1008 !this code not in either spec? integer, parameter :: WRF_WARN_FILE_OPEN_FOR_READ = -1009 integer, parameter :: WRF_IO_NOT_INITIALIZED = -1010 integer, parameter :: WRF_WARN_MD_AFTER_OPEN = -1011 integer, parameter :: WRF_WARN_TOO_MANY_VARIABLES = -1012 integer, parameter :: WRF_WARN_DRYRUN_CLOSE = -1013 integer, parameter :: WRF_WARN_DATESTR_BAD_LENGTH = -1014 integer, parameter :: WRF_WARN_ZERO_LENGTH_READ = -1015 integer, parameter :: WRF_WARN_DATA_TYPE_NOT_FOUND = -1016 integer, parameter :: WRF_WARN_DATESTR_ERROR = -1017 integer, parameter :: WRF_WARN_DRYRUN_READ = -1018 integer, parameter :: WRF_WARN_ZERO_LENGTH_GET = -1019 integer, parameter :: WRF_WARN_ZERO_LENGTH_PUT = -1020 integer, parameter :: WRF_WARN_NETCDF = -1021 integer, parameter :: WRF_WARN_LENGTH_LESS_THAN_1 = -1022 integer, parameter :: WRF_WARN_MORE_DATA_IN_FILE = -1023 integer, parameter :: WRF_WARN_DATE_LT_LAST_DATE = -1024 ! For HDF5 only integer, parameter :: WRF_HDF5_ERR_FILE = -200 integer, parameter :: WRF_HDF5_ERR_MD = -201 integer, parameter :: WRF_HDF5_ERR_TIME = -202 integer, parameter :: WRF_HDF5_ERR_TIME_EOF = -203 integer, parameter :: WRF_HDF5_ERR_MORE_DATA_IN_FILE = -204 integer, parameter :: WRF_HDF5_ERR_DATE_LT_LAST_DATE = -205 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_FILES = -206 integer, parameter :: WRF_HDF5_ERR_TYPE_MISMATCH = -207 integer, parameter :: WRF_HDF5_ERR_LENGTH_LESS_THAN_1 = -208 integer, parameter :: WRF_HDF5_ERR_WRITE_RONLY_FILE = -209 integer, parameter :: WRF_HDF5_ERR_READ_WONLY_FILE = -210 integer, parameter :: WRF_HDF5_ERR_FILE_NOT_OPENED = -211 integer, parameter :: WRF_HDF5_ERR_DATESTR_ERROR = -212 integer, parameter :: WRF_HDF5_ERR_DRYRUN_READ = -213 integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_GET = -214 integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_PUT = -215 integer, parameter :: WRF_HDF5_ERR_2DRYRUNS_1VARIABLE = -216 integer, parameter :: WRF_HDF5_ERR_DATA_TYPE_NOTFOUND = -217 integer, parameter :: WRF_HDF5_ERR_READ_PAST_EOF = -218 integer, parameter :: WRF_HDF5_ERR_BAD_DATA_HANDLE = -219 integer, parameter :: WRF_HDF5_ERR_WRTLEN_NE_DRRUNLEN = -220 integer, parameter :: WRF_HDF5_ERR_DRYRUN_CLOSE = -221 integer, parameter :: WRF_HDF5_ERR_DATESTR_BAD_LENGTH = -222 integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_READ = -223 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_DIMS = -224 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_VARIABLES = -225 integer, parameter :: WRF_HDF5_ERR_COUNT_TOO_LONG = -226 integer, parameter :: WRF_HDF5_ERR_DIMENSION_ERROR = -227 integer, parameter :: WRF_HDF5_ERR_BAD_MEMORYORDER = -228 integer, parameter :: WRF_HDF5_ERR_DIMNAME_REDEFINED = -229 integer, parameter :: WRF_HDF5_ERR_MD_AFTER_OPEN = -230 integer, parameter :: WRF_HDF5_ERR_CHARSTR_GT_LENDATA = -231 integer, parameter :: WRF_HDF5_ERR_BAD_DATA_TYPE = -232 integer, parameter :: WRF_HDF5_ERR_FILE_NOT_COMMITTED = -233 integer, parameter :: WRF_HDF5_ERR_ALLOCATION = -2001 integer, parameter :: WRF_HDF5_ERR_DEALLOCATION = -2002 integer, parameter :: WRF_HDF5_ERR_BAD_FILE_STATUS = -2003 integer, parameter :: WRF_HDF5_ERR_BAD_VARIABLE_DIM = -2004 integer, parameter :: WRF_HDF5_ERR_MDVAR_DIM_NOT_1D = -2005 integer, parameter :: WRF_HDF5_ERR_TOO_MANY_TIMES = -2006 integer, parameter :: WRF_HDF5_ERR_DATA_ID_NOTFOUND = -2007 integer, parameter :: WRF_HDF5_ERR_DATASPACE = -300 integer, parameter :: WRF_HDF5_ERR_DATATYPE = -301 integer, parameter :: WRF_HDF5_ERR_PROPERTY_LIST = -302 integer, parameter :: WRF_HDF5_ERR_DATASET_CREATE = -303 integer, parameter :: WRF_HDF5_ERR_DATASET_READ = -304 integer, parameter :: WRF_HDF5_ERR_DATASET_WRITE = -305 integer, parameter :: WRF_HDF5_ERR_DATASET_OPEN = -306 integer, parameter :: WRF_HDF5_ERR_DATASET_GENERAL = -307 integer, parameter :: WRF_HDF5_ERR_GROUP = -308 integer, parameter :: WRF_HDF5_ERR_FILE_OPEN = -309 integer, parameter :: WRF_HDF5_ERR_FILE_CREATE = -310 integer, parameter :: WRF_HDF5_ERR_DATASET_CLOSE = -311 integer, parameter :: WRF_HDF5_ERR_FILE_CLOSE = -312 integer, parameter :: WRF_HDF5_ERR_CLOSE_GENERAL = -313 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CREATE = -314 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_READ = -315 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_WRITE = -316 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OPEN = -317 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_GENERAL = -318 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CLOSE = -319 integer, parameter :: WRF_HDF5_ERR_OTHERS = -320 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OTHERS = -321 integer, parameter :: WRF_GRIB2_ERR_GRIBCREATE = -401 integer, parameter :: WRF_GRIB2_ERR_ADDLOCAL = -402 integer, parameter :: WRF_GRIB2_ERR_ADDGRIB = -403 integer, parameter :: WRF_GRIB2_ERR_ADDFIELD = -404 integer, parameter :: WRF_GRIB2_ERR_GRIBEND = -405 integer, parameter :: WRF_GRIB2_ERR_WRITE = -406 integer, parameter :: WRF_GRIB2_ERR_GRIB2MAP = -407 integer, parameter :: WRF_GRIB2_ERR_GETGB2 = -408 integer, parameter :: WRF_GRIB2_ERR_READ = -409 ! Local variables integer :: i integer :: istatus, comm_1, comm_2, domain_desc integer, dimension(3) :: sd, ed, sp, ep, sm, em real, pointer, dimension(:,:,:) :: real_dom_array logical :: allocated_real_locally allocated_real_locally = .false. ! If we are running distributed memory and need to gather all tiles onto a single processor for output if (nprocs > 1 .and. .not. do_tiled_output) then do i=1,NUM_FIELDS if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. & (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then istatus = 0 ! For the gather routines below, the IO_NODE should give the full domain dimensions, but the ! memory and patch dimensions should indicate what the processor already has in its patch_array. ! This is because an array with dimensions of the full domain will be allocated, and the patch_array ! will be copied from local memory into the full domain array in the area specified by the patch ! dimensions. sd = fields(i)%dom_start ed = fields(i)%dom_end sp = fields(i)%patch_start ep = fields(i)%patch_end sm = fields(i)%mem_start em = fields(i)%mem_end allocate(real_dom_array(sd(1):ed(1),sd(2):ed(2),sd(3):ed(3))) allocated_real_locally = .true. call gather_whole_field_r(real_array, & sm(1), em(1), sm(2), em(2), sm(3), em(3), & sp(1), ep(1), sp(2), ep(2), sp(3), ep(3), & real_dom_array, & sd(1), ed(1), sd(2), ed(2), sd(3), ed(3)) exit end if end do else do i=1,NUM_FIELDS if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. & (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then istatus = 0 real_dom_array => real_array exit end if end do end if ! Now a write call is only done if each processor writes its own file, or if we are the IO_NODE if (my_proc_id == IO_NODE .or. do_tiled_output) then comm_1 = 1 comm_2 = 1 domain_desc = 0 do i=1,NUM_FIELDS if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. & (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then ! Here, the output array has dimensions of the full grid if it was gathered together ! from all processors if (my_proc_id == IO_NODE .and. nprocs > 1 .and. .not. do_tiled_output) then sd = fields(i)%dom_start ed = fields(i)%dom_end sm = sd em = ed sp = sd ep = ed ! If we are writing one file per processor, then each processor only writes out the ! part of the domain that it has in memory else ! BUG: Shouldn't we set sd/ed to be domain_start/domain_end? ! Maybe not, since patch is already adjusted for staggering; but maybe so, and also adjust ! for staggering if it is alright to pass true domain dimensions to write_field. sd = fields(i)%patch_start ed = fields(i)%patch_end sp = fields(i)%patch_start ep = fields(i)%patch_end sm = fields(i)%mem_start em = fields(i)%mem_end end if istatus = 0 if (io_form_output == BINARY) then call ext_int_write_field(handle, datestr, trim(fields(i)%fieldname), & real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), & trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus) end if if (io_form_output == NETCDF) then call ext_ncd_write_field(handle, datestr, trim(fields(i)%fieldname), & real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), & trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus) end if if (io_form_output == GRIB1) then call ext_gr1_write_field(handle, datestr, trim(fields(i)%fieldname), & real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), & trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus) end if call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_write_field') if (present(is_training)) then if (is_training) then if (io_form_output == BINARY) then call ext_int_put_var_ti_char(handle, 'units', & trim(fields(i)%fieldname), trim(fields(i)%units), istatus) call ext_int_put_var_ti_char(handle, 'description', & trim(fields(i)%fieldname), trim(fields(i)%descr), istatus) call ext_int_put_var_ti_char(handle, 'stagger', & trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus) call ext_int_put_var_ti_integer(handle,'sr_x', & trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus) call ext_int_put_var_ti_integer(handle,'sr_y', & trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus) end if if (io_form_output == NETCDF) then call ext_ncd_put_var_ti_char(handle, 'units', & trim(fields(i)%fieldname), trim(fields(i)%units), istatus) call ext_ncd_put_var_ti_char(handle, 'description', & trim(fields(i)%fieldname), trim(fields(i)%descr), istatus) call ext_ncd_put_var_ti_char(handle, 'stagger', & trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus) call ext_ncd_put_var_ti_integer(handle,'sr_x', & trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus) call ext_ncd_put_var_ti_integer(handle,'sr_y', & trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus) end if if (io_form_output == GRIB1) then call ext_gr1_put_var_ti_char(handle, 'units', & trim(fields(i)%fieldname), trim(fields(i)%units), istatus) call ext_gr1_put_var_ti_char(handle, 'description', & trim(fields(i)%fieldname), trim(fields(i)%descr), istatus) call ext_gr1_put_var_ti_char(handle, 'stagger', & trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus) call ext_gr1_put_var_ti_integer(handle,'sr_x', & trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus) call ext_gr1_put_var_ti_integer(handle,'sr_y', & trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus) end if end if end if exit end if end do end if if (allocated_real_locally) deallocate(real_dom_array) end subroutine write_field !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: write_global_attrs ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine write_global_attrs(title, start_date, grid_type, dyn_opt, & west_east_dim, south_north_dim, bottom_top_dim, & we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, & sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, & map_proj, cmminlu, num_land_cat, is_water, is_lake, is_ice, & is_urban, i_soilwater, grid_id, parent_id, & i_parent_start, j_parent_start, i_parent_end, j_parent_end, & dx, dy, cen_lat, moad_cen_lat, cen_lon, & stand_lon, truelat1, truelat2, pole_lat, pole_lon, & parent_grid_ratio, sr_x, sr_y, corner_lats, corner_lons, & num_metgrid_soil_levs, & flags, nflags, flag_excluded_middle) implicit none ! Arguments integer, intent(in) :: dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, & we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, & sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, & map_proj, is_water, is_lake, is_ice, is_urban, i_soilwater, & grid_id, parent_id, i_parent_start, j_parent_start, & i_parent_end, j_parent_end, parent_grid_ratio, sr_x, sr_y, num_land_cat integer, intent(in), optional :: num_metgrid_soil_levs integer, intent(in), optional :: nflags integer, intent(in), optional :: flag_excluded_middle real, intent(in) :: dx, dy, cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, & pole_lat, pole_lon real, dimension(16), intent(in) :: corner_lats, corner_lons character (len=*), intent(in) :: title, start_date, grid_type character (len=128), intent(in) :: cmminlu character (len=128), dimension(:), intent(in), optional :: flags ! Local variables integer :: local_we_patch_s, local_we_patch_s_stag, & local_we_patch_e, local_we_patch_e_stag, & local_sn_patch_s, local_sn_patch_s_stag, & local_sn_patch_e, local_sn_patch_e_stag integer :: i real, dimension(16) :: local_corner_lats, local_corner_lons local_we_patch_s = we_patch_s local_we_patch_s_stag = we_patch_s_stag local_we_patch_e = we_patch_e local_we_patch_e_stag = we_patch_e_stag local_sn_patch_s = sn_patch_s local_sn_patch_s_stag = sn_patch_s_stag local_sn_patch_e = sn_patch_e local_sn_patch_e_stag = sn_patch_e_stag local_corner_lats = corner_lats local_corner_lons = corner_lons if (nprocs > 1) then if (.not. do_tiled_output) then call parallel_bcast_int(local_we_patch_s, processors(0, 0)) call parallel_bcast_int(local_we_patch_s_stag, processors(0, 0)) call parallel_bcast_int(local_sn_patch_s, processors(0, 0)) call parallel_bcast_int(local_sn_patch_s_stag, processors(0, 0)) call parallel_bcast_int(local_we_patch_e, processors(nproc_x-1, nproc_y-1)) call parallel_bcast_int(local_we_patch_e_stag, processors(nproc_x-1, nproc_y-1)) call parallel_bcast_int(local_sn_patch_e, processors(nproc_x-1, nproc_y-1)) call parallel_bcast_int(local_sn_patch_e_stag, processors(nproc_x-1, nproc_y-1)) end if call parallel_bcast_real(local_corner_lats(1), processors(0, 0)) call parallel_bcast_real(local_corner_lats(2), processors(0, nproc_y-1)) call parallel_bcast_real(local_corner_lats(3), processors(nproc_x-1, nproc_y-1)) call parallel_bcast_real(local_corner_lats(4), processors(nproc_x-1, 0)) call parallel_bcast_real(local_corner_lats(5), processors(0, 0)) call parallel_bcast_real(local_corner_lats(6), processors(0, nproc_y-1)) call parallel_bcast_real(local_corner_lats(7), processors(nproc_x-1, nproc_y-1)) call parallel_bcast_real(local_corner_lats(8), processors(nproc_x-1, 0)) call parallel_bcast_real(local_corner_lats(9), processors(0, 0)) call parallel_bcast_real(local_corner_lats(10), processors(0, nproc_y-1)) call parallel_bcast_real(local_corner_lats(11), processors(nproc_x-1, nproc_y-1)) call parallel_bcast_real(local_corner_lats(12), processors(nproc_x-1, 0)) call parallel_bcast_real(local_corner_lats(13), processors(0, 0)) call parallel_bcast_real(local_corner_lats(14), processors(0, nproc_y-1)) call parallel_bcast_real(local_corner_lats(15), processors(nproc_x-1, nproc_y-1)) call parallel_bcast_real(local_corner_lats(16), processors(nproc_x-1, 0)) call parallel_bcast_real(local_corner_lons(1), processors(0, 0)) call parallel_bcast_real(local_corner_lons(2), processors(0, nproc_y-1)) call parallel_bcast_real(local_corner_lons(3), processors(nproc_x-1, nproc_y-1)) call parallel_bcast_real(local_corner_lons(4), processors(nproc_x-1, 0)) call parallel_bcast_real(local_corner_lons(5), processors(0, 0)) call parallel_bcast_real(local_corner_lons(6), processors(0, nproc_y-1)) call parallel_bcast_real(local_corner_lons(7), processors(nproc_x-1, nproc_y-1)) call parallel_bcast_real(local_corner_lons(8), processors(nproc_x-1, 0)) call parallel_bcast_real(local_corner_lons(9), processors(0, 0)) call parallel_bcast_real(local_corner_lons(10), processors(0, nproc_y-1)) call parallel_bcast_real(local_corner_lons(11), processors(nproc_x-1, nproc_y-1)) call parallel_bcast_real(local_corner_lons(12), processors(nproc_x-1, 0)) call parallel_bcast_real(local_corner_lons(13), processors(0, 0)) call parallel_bcast_real(local_corner_lons(14), processors(0, nproc_y-1)) call parallel_bcast_real(local_corner_lons(15), processors(nproc_x-1, nproc_y-1)) call parallel_bcast_real(local_corner_lons(16), processors(nproc_x-1, 0)) end if if (my_proc_id == IO_NODE .or. do_tiled_output) then call ext_put_dom_ti_char ('TITLE', title) call ext_put_dom_ti_char ('SIMULATION_START_DATE', start_date) call ext_put_dom_ti_integer_scalar('WEST-EAST_GRID_DIMENSION', west_east_dim) call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_GRID_DIMENSION', south_north_dim) call ext_put_dom_ti_integer_scalar('BOTTOM-TOP_GRID_DIMENSION', bottom_top_dim) call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_UNSTAG', local_we_patch_s) call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_UNSTAG', local_we_patch_e) call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_STAG', local_we_patch_s_stag) call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_STAG', local_we_patch_e_stag) call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_UNSTAG', local_sn_patch_s) call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_UNSTAG', local_sn_patch_e) call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_STAG', local_sn_patch_s_stag) call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_STAG', local_sn_patch_e_stag) call ext_put_dom_ti_char ('GRIDTYPE', grid_type) call ext_put_dom_ti_real_scalar ('DX', dx) call ext_put_dom_ti_real_scalar ('DY', dy) call ext_put_dom_ti_integer_scalar('DYN_OPT', dyn_opt) call ext_put_dom_ti_real_scalar ('CEN_LAT', cen_lat) call ext_put_dom_ti_real_scalar ('CEN_LON', cen_lon) call ext_put_dom_ti_real_scalar ('TRUELAT1', truelat1) call ext_put_dom_ti_real_scalar ('TRUELAT2', truelat2) call ext_put_dom_ti_real_scalar ('MOAD_CEN_LAT', moad_cen_lat) call ext_put_dom_ti_real_scalar ('STAND_LON', stand_lon) call ext_put_dom_ti_real_scalar ('POLE_LAT', pole_lat) call ext_put_dom_ti_real_scalar ('POLE_LON', pole_lon) call ext_put_dom_ti_real_vector ('corner_lats', local_corner_lats, 16) call ext_put_dom_ti_real_vector ('corner_lons', local_corner_lons, 16) call ext_put_dom_ti_integer_scalar('MAP_PROJ', map_proj) call ext_put_dom_ti_char ('MMINLU', trim(cmminlu)) call ext_put_dom_ti_integer_scalar('NUM_LAND_CAT', num_land_cat) call ext_put_dom_ti_integer_scalar('ISWATER', is_water) call ext_put_dom_ti_integer_scalar('ISLAKE', is_lake) call ext_put_dom_ti_integer_scalar('ISICE', is_ice) call ext_put_dom_ti_integer_scalar('ISURBAN', is_urban) call ext_put_dom_ti_integer_scalar('ISOILWATER', i_soilwater) call ext_put_dom_ti_integer_scalar('grid_id', grid_id) call ext_put_dom_ti_integer_scalar('parent_id', parent_id) call ext_put_dom_ti_integer_scalar('i_parent_start', i_parent_start) call ext_put_dom_ti_integer_scalar('j_parent_start', j_parent_start) call ext_put_dom_ti_integer_scalar('i_parent_end', i_parent_end) call ext_put_dom_ti_integer_scalar('j_parent_end', j_parent_end) call ext_put_dom_ti_integer_scalar('parent_grid_ratio', parent_grid_ratio) call ext_put_dom_ti_integer_scalar('sr_x',sr_x) call ext_put_dom_ti_integer_scalar('sr_y',sr_y) if (present(num_metgrid_soil_levs)) then call ext_put_dom_ti_integer_scalar('NUM_METGRID_SOIL_LEVELS', num_metgrid_soil_levs) end if call ext_put_dom_ti_integer_scalar('FLAG_METGRID', 1) if (present(flag_excluded_middle)) then call ext_put_dom_ti_integer_scalar('FLAG_EXCLUDED_MIDDLE', flag_excluded_middle) end if if (present(nflags) .and. present(flags)) then do i=1,nflags if (flags(i) /= ' ') then call ext_put_dom_ti_integer_scalar(trim(flags(i)), 1) end if end do end if end if end subroutine write_global_attrs !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: ext_put_dom_ti_integer ! ! Purpose: Write a domain time-independent integer attribute to output. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine ext_put_dom_ti_integer_scalar(var_name, var_value) implicit none ! Arguments integer, intent(in) :: var_value character (len=*), intent(in) :: var_name ! Local variables integer :: istatus if (io_form_output == BINARY) then call ext_int_put_dom_ti_integer(handle, trim(var_name), & var_value, & 1, istatus) end if if (io_form_output == NETCDF) then call ext_ncd_put_dom_ti_integer(handle, trim(var_name), & var_value, & 1, istatus) end if if (io_form_output == GRIB1) then call ext_gr1_put_dom_ti_integer(handle, trim(var_name), & var_value, & 1, istatus) end if call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute') end subroutine ext_put_dom_ti_integer_scalar !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: ext_put_dom_ti_integer ! ! Purpose: Write a domain time-independent integer attribute to output. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine ext_put_dom_ti_integer_vector(var_name, var_value, n) implicit none ! Arguments integer, intent(in) :: n integer, dimension(n), intent(in) :: var_value character (len=*), intent(in) :: var_name ! Local variables integer :: istatus if (io_form_output == BINARY) then call ext_int_put_dom_ti_integer(handle, trim(var_name), & var_value, & n, istatus) end if if (io_form_output == NETCDF) then call ext_ncd_put_dom_ti_integer(handle, trim(var_name), & var_value, & n, istatus) end if if (io_form_output == GRIB1) then call ext_gr1_put_dom_ti_integer(handle, trim(var_name), & var_value, & n, istatus) end if call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute') end subroutine ext_put_dom_ti_integer_vector !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: ext_put_dom_ti_real ! ! Purpose: Write a domain time-independent real attribute to output. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine ext_put_dom_ti_real_scalar(var_name, var_value) implicit none ! Arguments real, intent(in) :: var_value character (len=*), intent(in) :: var_name ! Local variables integer :: istatus if (io_form_output == BINARY) then call ext_int_put_dom_ti_real(handle, trim(var_name), & var_value, & 1, istatus) end if if (io_form_output == NETCDF) then call ext_ncd_put_dom_ti_real(handle, trim(var_name), & var_value, & 1, istatus) end if if (io_form_output == GRIB1) then call ext_gr1_put_dom_ti_real(handle, trim(var_name), & var_value, & 1, istatus) end if call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute') end subroutine ext_put_dom_ti_real_scalar !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: ext_put_dom_ti_real ! ! Purpose: Write a domain time-independent real attribute to output. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine ext_put_dom_ti_real_vector(var_name, var_value, n) implicit none ! Arguments integer, intent(in) :: n real, dimension(n), intent(in) :: var_value character (len=*), intent(in) :: var_name ! Local variables integer :: istatus if (io_form_output == BINARY) then call ext_int_put_dom_ti_real(handle, trim(var_name), & var_value, & n, istatus) end if if (io_form_output == NETCDF) then call ext_ncd_put_dom_ti_real(handle, trim(var_name), & var_value, & n, istatus) end if if (io_form_output == GRIB1) then call ext_gr1_put_dom_ti_real(handle, trim(var_name), & var_value, & n, istatus) end if call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute') end subroutine ext_put_dom_ti_real_vector !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: ext_put_dom_ti_char ! ! Purpose: Write a domain time-independent character attribute to output. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine ext_put_dom_ti_char(var_name, var_value) implicit none ! Arguments character (len=*), intent(in) :: var_name, var_value ! Local variables integer :: istatus if (io_form_output == BINARY) then call ext_int_put_dom_ti_char(handle, trim(var_name), & trim(var_value), & istatus) end if if (io_form_output == NETCDF) then call ext_ncd_put_dom_ti_char(handle, trim(var_name), & trim(var_value), & istatus) end if if (io_form_output == GRIB1) then call ext_gr1_put_dom_ti_char(handle, trim(var_name), & trim(var_value), & istatus) end if call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute') end subroutine ext_put_dom_ti_char !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: output_close ! ! Purpose: Finalizes all output. This may include closing windows, calling I/O ! API termination routines, or closing files. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine output_close() implicit none ! Local variables integer :: istatus if (my_proc_id == IO_NODE .or. do_tiled_output) then istatus = 0 if (io_form_output == BINARY) call ext_int_ioclose(handle, istatus) if (io_form_output == NETCDF) call ext_ncd_ioclose(handle, istatus) if (io_form_output == GRIB1) call ext_gr1_ioclose(handle, istatus) call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioclose') istatus = 0 if (io_form_output == BINARY) call ext_int_ioexit(istatus) if (io_form_output == NETCDF) call ext_ncd_ioexit(istatus) if (io_form_output == GRIB1) call ext_gr1_ioexit(istatus) call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioexit') end if if (associated(fields)) deallocate(fields) end subroutine output_close end module output_module