PageRenderTime 34ms CodeModel.GetById 20ms RepoModel.GetById 0ms app.codeStats 0ms

/WPS/geogrid/src/output_module.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 1554 lines | 1004 code | 223 blank | 327 comment | 267 complexity | 2341ce0b6302f974d847a80d4c8f496c MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    2. 

  2. ! MODULE OUTPUT_MODULE
    3. 

  3. !
    4. 

  4. ! This module handles the output of the fields that are generated by the main
    5. 

  5. !   geogrid routines. This output may include output to a console and output to 
    6. 

  6. !   the WRF I/O API.
    7. 

  7. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    8. 

  8. module output_module
    9. 

  9. 

  10.    use parallel_module
    11. 

  11.    use gridinfo_module
    12. 

  12.    use misc_definitions_module
    13. 

  13.    use module_debug
    14. 

  14. #ifdef IO_BINARY
    15. 

  15.    use module_internal_header_util
    16. 

  16. #endif
    17. 

  17.  
    18. 

  18.    integer, parameter :: MAX_DIMENSIONS = 3
    19. 

  19.  
    20. 

  20. #ifdef _GEOGRID
    21. 

  21.    ! Information about fields that will be written
    22. 

  22.    integer :: NUM_AUTOMATIC_FIELDS    ! Set later, but very near to a parameter
    23. 

  23. #endif
    24. 

  24.  
    25. 

  25.    integer :: NUM_FIELDS
    26. 

  26.  
    27. 

  27.    type field_info
    28. 

  28.       integer :: ndims, istagger
    29. 

  29.       integer, dimension(MAX_DIMENSIONS) :: dom_start, mem_start, patch_start
    30. 

  30.       integer, dimension(MAX_DIMENSIONS) :: dom_end, mem_end, patch_end
    31. 

  31.       logical :: is_subgrid
    32. 

  32.       real, pointer, dimension(:,:,:) :: rdata_arr
    33. 

  33.   
    34. 

  34.       character (len=128), dimension(MAX_DIMENSIONS) :: dimnames
    35. 

  35.       character (len=128) :: fieldname, mem_order, stagger, units, descr
    36. 

  36.    end type field_info
    37. 

  37.  
    38. 

  38.    type (field_info), pointer, dimension(:) :: fields 
    39. 

  39.  
    40. 

  40.    ! WRF I/O API related variables
    41. 

  41.    integer :: handle 
    42. 

  42.  
    43. 

  43.    contains
    44. 

  44.  
    45. 

  45.  
    46. 

  46.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  
    47. 

  47.    ! Name: output_init
    48. 

  48.    ! 
    49. 

  49.    ! Purpose: To initialize the output module. Such initialization may include 
    50. 

  50.    !   opening an X window, and making initialization calls to an I/O API.
    51. 

  51.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  
    52. 

  52.    subroutine output_init(nest_number, title, datestr, grid_type, dynopt, &
    53. 

  53.                           corner_lats, corner_lons, &
    54. 

  54.                           start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
    55. 

  55.                           start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
    56. 

  56.                           start_mem_1, end_mem_1, start_mem_2, end_mem_2, &
    57. 

  57.                           extra_col, extra_row)
    58. 

  58.  
    59. 

  59. #ifdef _GEOGRID
    60. 

  60.       use llxy_module
    61. 

  61.       use source_data_module
    62. 

  62. #endif
    63. 

  63.   
    64. 

  64.       implicit none
    65. 

  65.   
    66. 

  66.       ! Arguments
    67. 

  67.       integer, intent(in) :: nest_number, dynopt, &
    68. 

  68.                              start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
    69. 

  69.                              start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
    70. 

  70.                              start_mem_1, end_mem_1, start_mem_2, end_mem_2
    71. 

  71.       real, dimension(16), intent(in) :: corner_lats, corner_lons
    72. 

  72.       logical, intent(in) :: extra_col, extra_row
    73. 

  73.       character (len=1), intent(in) :: grid_type
    74. 

  74.       character (len=19), intent(in) :: datestr
    75. 

  75.       character (len=*), intent(in) :: title
    76. 

  76.   
    77. 

  77. #include "wrf_io_flags.h"
    78. 

  78. #include "wrf_status_codes.h"
    79. 

  79.   
    80. 

  80.       ! Local variables
    81. 

  81.       integer :: i, istatus, save_domain, comm_1, comm_2
    82. 

  82.       integer :: sp1, ep1, sp2, ep2, ep1_stag, ep2_stag
    83. 

  83.       integer :: ngeo_flags
    84. 

  84.       integer :: num_land_cat, min_land_cat, max_land_cat
    85. 

  85.       real :: dx, dy, cen_lat, cen_lon, moad_cen_lat
    86. 

  86.       character (len=128) :: coption, temp_fldname
    87. 

  87.       character (len=128), dimension(1) :: geo_flags
    88. 

  88.       character (len=MAX_FILENAME_LEN) :: output_fname
    89. 

  89.       logical :: supports_training, supports_3d_fields
    90. 

  90.   
    91. 

  91.       call init_output_fields(nest_number, grid_type, &
    92. 

  92.                               start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
    93. 

  93.                               start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
    94. 

  94.                               start_mem_1, end_mem_1, start_mem_2, end_mem_2, &
    95. 

  95.                               extra_col, extra_row)
    96. 

  96.   
    97. 

  97.       if (my_proc_id == IO_NODE .or. do_tiled_output) then
    98. 

  98.       istatus = 0
    99. 

  99. #ifdef IO_BINARY
    100. 

  100.       if (io_form_output == BINARY) call ext_int_ioinit('sysdep info', istatus)
    101. 

  101. #endif
    102. 

  102. #ifdef IO_NETCDF
    103. 

  103.       if (io_form_output == NETCDF) call ext_ncd_ioinit('sysdep info', istatus)
    104. 

  104. #endif
    105. 

  105. #ifdef IO_GRIB1
    106. 

  106.       if (io_form_output == GRIB1) call ext_gr1_ioinit('sysdep info', istatus)
    107. 

  107. #endif
    108. 

  108.       call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioinit')
    109. 

  109.       
    110. 

  110.       ! Find out what this implementation of WRF I/O API supports
    111. 

  111.       istatus = 0
    112. 

  112. #ifdef IO_BINARY
    113. 

  113.       if (io_form_output == BINARY) coption = 'REQUIRE'
    114. 

  114. #endif
    115. 

  115. #ifdef IO_NETCDF
    116. 

  116.       if (io_form_output == NETCDF) call ext_ncd_inquiry('OPEN_COMMIT_WRITE',coption,istatus)
    117. 

  117. #endif
    118. 

  118. #ifdef IO_GRIB1
    119. 

  119.       if (io_form_output == GRIB1) call ext_gr1_inquiry('OPEN_COMMIT_WRITE',coption,istatus)
    120. 

  120. #endif
    121. 

  121.       call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_inquiry')
    122. 

  122.   
    123. 

  123.       if (index(coption,'ALLOW') /= 0) then
    124. 

  124.          supports_training = .false.
    125. 

  125.       else if (index(coption,'REQUIRE') /= 0) then
    126. 

  126.          supports_training = .true.
    127. 

  127.       else if (index(coption,'NO') /= 0) then
    128. 

  128.          supports_training = .false.
    129. 

  129.       end if 
    130. 

  130.   
    131. 

  131.       istatus = 0
    132. 

  132. #ifdef IO_BINARY
    133. 

  133.       if (io_form_output == BINARY) coption = 'YES'
    134. 

  134. #endif
    135. 

  135. #ifdef IO_NETCDF
    136. 

  136.       if (io_form_output == NETCDF) call ext_ncd_inquiry('SUPPORT_3D_FIELDS',coption,istatus)
    137. 

  137. #endif
    138. 

  138. #ifdef IO_GRIB1
    139. 

  139.       if (io_form_output == GRIB1) call ext_gr1_inquiry('SUPPORT_3D_FIELDS',coption,istatus)
    140. 

  140. #endif
    141. 

  141.       call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_inquiry')
    142. 

  142.   
    143. 

  143.       if (index(coption,'YES') /= 0) then
    144. 

  144.          supports_3d_fields = .true.
    145. 

  145.       else if (index(coption,'NO') /= 0) then
    146. 

  146.          supports_3d_fields = .false.
    147. 

  147. ! BUG: What if we have no plans to write 3-d fields? We should take this into account.
    148. 

  148.          call mprintf(.true.,ERROR,'WRF I/O API implementation does NOT support 3-d fields.')
    149. 

  149.       end if
    150. 

  150.   
    151. 

  151.       comm_1 = 1
    152. 

  152.       comm_2 = 1
    153. 

  153.   
    154. 

  154. #ifdef _GEOGRID
    155. 

  155.       output_fname = ' '
    156. 

  156.       if (grid_type == 'C') then
    157. 

  157. #ifdef IO_BINARY
    158. 

  158.          if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .int'
    159. 

  159. #endif
    160. 

  160. #ifdef IO_NETCDF
    161. 

  161.          if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .nc'
    162. 

  162. #endif
    163. 

  163. #ifdef IO_GRIB1
    164. 

  164.          if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .grib'
    165. 

  165. #endif
    166. 

  166.          i = len_trim(opt_output_from_geogrid_path)
    167. 

  167.          write(output_fname(i+9:i+10),'(i2.2)') nest_number
    168. 

  168.       else if (grid_type == 'E') then
    169. 

  169.          if (nest_number == 1) then
    170. 

  170. #ifdef IO_BINARY
    171. 

  171.             if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .int'
    172. 

  172. #endif
    173. 

  173. #ifdef IO_NETCDF
    174. 

  174.             if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .nc'
    175. 

  175. #endif
    176. 

  176. #ifdef IO_GRIB1
    177. 

  177.             if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .grib'
    178. 

  178. #endif
    179. 

  179.             i = len_trim(opt_output_from_geogrid_path)
    180. 

  180.             write(output_fname(i+10:i+11),'(i2.2)') nest_number
    181. 

  181.          else
    182. 

  182. #ifdef IO_BINARY
    183. 

  183.             if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l  .int'
    184. 

  184. #endif
    185. 

  185. #ifdef IO_NETCDF
    186. 

  186.             if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l  .nc'
    187. 

  187. #endif
    188. 

  188. #ifdef IO_GRIB1
    189. 

  189.             if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l  .grib'
    190. 

  190. #endif
    191. 

  191.             i = len_trim(opt_output_from_geogrid_path)
    192. 

  192.             write(output_fname(i+15:i+16),'(i2.2)') nest_number-1
    193. 

  193.          end if
    194. 

  194.       end if
    195. 

  195. 

  196.       if (nprocs > 1 .and. do_tiled_output) then
    197. 

  197.          write(output_fname(len_trim(output_fname)+1:len_trim(output_fname)+5), '(a1,i4.4)') &
    198. 

  198.               '_', my_proc_id 
    199. 

  199.       end if
    200. 

  200. #endif
    201. 

  201.   
    202. 

  202. #ifdef _METGRID
    203. 

  203.       output_fname = ' '
    204. 

  204.       if (grid_type == 'C') then
    205. 

  205. #ifdef IO_BINARY
    206. 

  206.          if (io_form_output == BINARY) then
    207. 

  207.             output_fname = trim(opt_output_from_metgrid_path)//'met_em.d  .'//trim(datestr)//'.int'
    208. 

  208.          end if
    209. 

  209. #endif
    210. 

  210. #ifdef IO_NETCDF
    211. 

  211.          if (io_form_output == NETCDF) then
    212. 

  212.             output_fname = trim(opt_output_from_metgrid_path)//'met_em.d  .'//trim(datestr)//'.nc'
    213. 

  213.          end if
    214. 

  214. #endif
    215. 

  215. #ifdef IO_GRIB1
    216. 

  216.          if (io_form_output == GRIB1) then
    217. 

  217.             output_fname = trim(opt_output_from_metgrid_path)//'met_em.d  .'//trim(datestr)//'.grib'
    218. 

  218.          end if
    219. 

  219. #endif
    220. 

  220.          i = len_trim(opt_output_from_metgrid_path)
    221. 

  221.          write(output_fname(i+9:i+10),'(i2.2)') nest_number
    222. 

  222.       else if (grid_type == 'E') then
    223. 

  223. #ifdef IO_BINARY
    224. 

  224.          if (io_form_output == BINARY) then
    225. 

  225.             output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d  .'//trim(datestr)//'.int'
    226. 

  226.          end if
    227. 

  227. #endif
    228. 

  228. #ifdef IO_NETCDF
    229. 

  229.          if (io_form_output == NETCDF) then
    230. 

  230.             output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d  .'//trim(datestr)//'.nc'
    231. 

  231.          end if
    232. 

  232. #endif
    233. 

  233. #ifdef IO_GRIB1
    234. 

  234.          if (io_form_output == GRIB1) then
    235. 

  235.             output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d  .'//trim(datestr)//'.grib'
    236. 

  236.          end if
    237. 

  237. #endif
    238. 

  238.          i = len_trim(opt_output_from_metgrid_path)
    239. 

  239.          write(output_fname(i+10:i+11),'(i2.2)') nest_number
    240. 

  240.       end if
    241. 

  241. 

  242.       if (nprocs > 1 .and. do_tiled_output) then
    243. 

  243.          write(output_fname(len_trim(output_fname)+1:len_trim(output_fname)+5), '(a1,i4.4)') &
    244. 

  244.               '_', my_proc_id 
    245. 

  245.       end if
    246. 

  246. #endif
    247. 

  247.       end if
    248. 

  248.   
    249. 

  249.       call parallel_bcast_logical(supports_training)
    250. 

  250.   
    251. 

  251.       ! If the implementation requires or supports open_for_write begin/commit semantics
    252. 

  252.       if (supports_training) then
    253. 

  253.   
    254. 

  254.          if (my_proc_id == IO_NODE .or. do_tiled_output) then
    255. 

  255.             istatus = 0
    256. 

  256. #ifdef IO_BINARY
    257. 

  257.             if (io_form_output == BINARY) then
    258. 

  258.                call ext_int_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
    259. 

  259.             end if
    260. 

  260. #endif
    261. 

  261. #ifdef IO_NETCDF
    262. 

  262.             if (io_form_output == NETCDF) then
    263. 

  263.                call ext_ncd_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
    264. 

  264.             end if
    265. 

  265. #endif
    266. 

  266. #ifdef IO_GRIB1
    267. 

  267.             if (io_form_output == GRIB1) then
    268. 

  268.                call ext_gr1_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
    269. 

  269.             end if
    270. 

  270. #endif
    271. 

  271.             call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_open_for_write_begin.')
    272. 

  272.          end if
    273. 

  273.    
    274. 

  274.          do i=1,NUM_FIELDS
    275. 

  275.    
    276. 

  276.             allocate(fields(i)%rdata_arr(fields(i)%mem_start(1):fields(i)%mem_end(1), &
    277. 

  277.                                          fields(i)%mem_start(2):fields(i)%mem_end(2), &
    278. 

  278.                                          fields(i)%mem_start(3):fields(i)%mem_end(3)))
    279. 

  279.      
    280. 

  280.             call write_field(fields(i)%mem_start(1), fields(i)%mem_end(1), fields(i)%mem_start(2), &
    281. 

  281.                              fields(i)%mem_end(2), fields(i)%mem_start(3), fields(i)%mem_end(3), &
    282. 

  282.                              trim(fields(i)%fieldname), datestr, fields(i)%rdata_arr, is_training=.true.)
    283. 

  283.      
    284. 

  284.             deallocate(fields(i)%rdata_arr)
    285. 

  285.     
    286. 

  286.          end do
    287. 

  287.    
    288. 

  288.          if (my_proc_id == IO_NODE .or. do_tiled_output) then
    289. 

  289.             istatus = 0
    290. 

  290. #ifdef IO_BINARY
    291. 

  291.             if (io_form_output == BINARY) call ext_int_open_for_write_commit(handle, istatus)
    292. 

  292. #endif
    293. 

  293. #ifdef IO_NETCDF
    294. 

  294.             if (io_form_output == NETCDF) call ext_ncd_open_for_write_commit(handle, istatus)
    295. 

  295. #endif
    296. 

  296. #ifdef IO_GRIB1
    297. 

  297.             if (io_form_output == GRIB1) call ext_gr1_open_for_write_commit(handle, istatus)
    298. 

  298. #endif
    299. 

  299.             call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_write_commit')
    300. 

  300.          end if
    301. 

  301.   
    302. 

  302.       else ! No training required
    303. 

  303.   
    304. 

  304.          if (my_proc_id == IO_NODE .or. do_tiled_output) then
    305. 

  305.             istatus = 0
    306. 

  306. #ifdef IO_BINARY
    307. 

  307.             if (io_form_output == BINARY) then
    308. 

  308.                call ext_int_open_for_write(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
    309. 

  309.             end if
    310. 

  310. #endif
    311. 

  311. #ifdef IO_NETCDF
    312. 

  312.             if (io_form_output == NETCDF) then
    313. 

  313.                call ext_ncd_open_for_write(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
    314. 

  314.             end if
    315. 

  315. #endif
    316. 

  316. #ifdef IO_GRIB1
    317. 

  317.             if (io_form_output == GRIB1) then
    318. 

  318.                call mprintf(.true.,ERROR,'In output_init(), GRIB1 requires begin/commit open sequence.')
    319. 

  319.             end if
    320. 

  320. #endif
    321. 

  321.             call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_open_for_write_begin')
    322. 

  322.          end if
    323. 

  323.   
    324. 

  324.       end if 
    325. 

  325.   
    326. 

  326. #ifdef _GEOGRID
    327. 

  327.       sp1 = start_patch_1
    328. 

  328.       ep1 = end_patch_1
    329. 

  329.       sp2 = start_patch_2
    330. 

  330.       ep2 = end_patch_2
    331. 

  331.   
    332. 

  332.       if (grid_type == 'C') then
    333. 

  333.          if (extra_col .or. (my_proc_id == IO_NODE .and. .not. do_tiled_output)) then
    334. 

  334.             ep1_stag = ep1 + 1
    335. 

  335.          else
    336. 

  336.             ep1_stag = ep1
    337. 

  337.          end if
    338. 

  338.          if (extra_row .or. (my_proc_id == IO_NODE .and. .not. do_tiled_output)) then
    339. 

  339.             ep2_stag = ep2 + 1
    340. 

  340.          else
    341. 

  341.             ep2_stag = ep2
    342. 

  342.          end if
    343. 

  343.       else if (grid_type == 'E') then
    344. 

  344.          ep1 = ep1
    345. 

  345.          ep2 = ep2
    346. 

  346.          ep1_stag = ep1
    347. 

  347.          ep2_stag = ep2
    348. 

  348.       end if
    349. 

  349. 

  350.       if (grid_type == 'C') then
    351. 

  351.          dx = proj_stack(nest_number)%dx
    352. 

  352.          dy = proj_stack(nest_number)%dy
    353. 

  353. 

  354.          save_domain = iget_selected_domain()
    355. 

  355. 

  356.          ! Note: In the following, we use ixdim/2 rather than (ixdim+1)/2 because
    357. 

  357.          !       the i/j coordinates given to xytoll must be with respect to the
    358. 

  358.          !       mass grid, and ixdim and jydim are the full grid dimensions.
    359. 

  359. 

  360.          ! Get MOAD_CEN_LAT
    361. 

  361.          call select_domain(1)
    362. 

  362.          call xytoll(real(ixdim(1))/2.,real(jydim(1))/2., moad_cen_lat, cen_lon, M)
    363. 

  363. 

  364.          ! Get CEN_LAT and CEN_LON for this nest
    365. 

  365.          call select_domain(nest_number)
    366. 

  366.          call xytoll(real(ixdim(nest_number))/2.,real(jydim(nest_number))/2., cen_lat, cen_lon, M)
    367. 

  367. 

  368.          call select_domain(save_domain)
    369. 

  369. 

  370.          ngeo_flags = 1
    371. 

  371.          geo_flags(1) = 'FLAG_MF_XY' 
    372. 

  372.       else if (grid_type == 'E') then
    373. 

  373.          dx = dxkm / 3**(nest_number-1)   ! For NMM, nest_number is really nesting level
    374. 

  374.          dy = dykm / 3**(nest_number-1)
    375. 

  375.          moad_cen_lat = 0.
    376. 

  376.          cen_lat=known_lat
    377. 

  377.          cen_lon=known_lon
    378. 

  378. 

  379.          ngeo_flags = 0
    380. 

  380.       end if
    381. 

  381. 

  382.       write(temp_fldname,'(a)') 'LANDUSEF'
    383. 

  383.       call get_max_categories(temp_fldname, min_land_cat, max_land_cat, istatus)
    384. 

  384.       num_land_cat = max_land_cat - min_land_cat + 1
    385. 

  385.   
    386. 

  386.       ! We may now write global attributes to the file
    387. 

  387.       call write_global_attrs(title, datestr, grid_type, dynopt, ixdim(nest_number), jydim(nest_number), &
    388. 

  388.                               0, sp1, ep1, sp1, ep1_stag, sp2, ep2, sp2, ep2_stag,                       &
    389. 

  389.                               iproj_type, source_mminlu, num_land_cat, source_iswater, source_islake,    &
    390. 

  390.                               source_isice, source_isurban, source_isoilwater, nest_number,              &
    391. 

  391.                               parent_id(nest_number),                                                    &
    392. 

  392.                               nint(parent_ll_x(nest_number)), nint(parent_ll_y(nest_number)),            &
    393. 

  393.                               nint(parent_ur_x(nest_number)), nint(parent_ur_y(nest_number)),            &
    394. 

  394.                               dx, dy, cen_lat, moad_cen_lat,                                             &
    395. 

  395.                               cen_lon, stand_lon, truelat1, truelat2, pole_lat, pole_lon,                &
    396. 

  396.                               parent_grid_ratio(nest_number),                                            &
    397. 

  397.                               subgrid_ratio_x(nest_number), subgrid_ratio_y(nest_number),                &
    398. 

  398.                               corner_lats, corner_lons, flags=geo_flags, nflags=ngeo_flags)
    399. 

  399. #endif
    400. 

  400.  
    401. 

  401.    end subroutine output_init
    402. 

  402.  
    403. 

  403.  
    404. 

  404.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  
    405. 

  405.    ! Name: init_output_fields
    406. 

  406.    ! 
    407. 

  407.    ! Purpose: To fill in structures describing each of the fields that will be 
    408. 

  408.    !   written to the I/O API 
    409. 

  409.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  
    410. 

  410.    subroutine init_output_fields(nest_num, grid_type, &
    411. 

  411.                                  start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
    412. 

  412.                                  start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
    413. 

  413.                                  start_mem_1, end_mem_1, start_mem_2, end_mem_2, &
    414. 

  414.                                  extra_col, extra_row)
    415. 

  415.  
    416. 

  416.  
    417. 

  417.       ! Modules
    418. 

  418. #ifdef _GEOGRID
    419. 

  419.       use source_data_module
    420. 

  420. #endif
    421. 

  421. #ifdef _METGRID
    422. 

  422.       use storage_module
    423. 

  423. #endif
    424. 

  424.       use parallel_module
    425. 

  425.       use gridinfo_module, only : subgrid_ratio_x, subgrid_ratio_y
    426. 

  426.   
    427. 

  427.       implicit none
    428. 

  428.   
    429. 

  429.       ! Arguments
    430. 

  430.       integer, intent(in) :: nest_num
    431. 

  431.       integer, intent(in) :: start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
    432. 

  432.                              start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
    433. 

  433.                              start_mem_1, end_mem_1, start_mem_2, end_mem_2
    434. 

  434.       logical, intent(in) :: extra_col, extra_row
    435. 

  435.       character (len=1), intent(in) :: grid_type
    436. 

  436.   
    437. 

  437. #include "wrf_io_flags.h"
    438. 

  438. #include "wrf_status_codes.h"
    439. 

  439.   
    440. 

  440.       ! Local variables
    441. 

  441.       integer :: i, istagger, ifieldstatus, &
    442. 

  442.                  nfields, min_category, max_category
    443. 

  443.       integer :: lhalo_width, rhalo_width, bhalo_width, thalo_width
    444. 

  444.       integer :: ndims
    445. 

  445.       character (len=128) :: fieldname
    446. 

  446.       character (len=128) :: memorder, units, description
    447. 

  447.       character (len=128), dimension(3) :: dimnames 
    448. 

  448.       integer :: sr_x, sr_y, istatus
    449. 

  449.       logical :: subgrid_var
    450. 

  450.  
    451. 

  451.       !
    452. 

  452.       ! Get local nest subgrid refinement ratio
    453. 

  453.       !
    454. 

  454.       sr_x=subgrid_ratio_x(nest_num)
    455. 

  455.       sr_y=subgrid_ratio_y(nest_num)
    456. 

  456. 

  457.       !
    458. 

  458.       ! First find out how many fields there are
    459. 

  459.       !
    460. 

  460.       call reset_next_field()
    461. 

  461.   
    462. 

  462.       ifieldstatus = 0
    463. 

  463.       nfields = 0
    464. 

  464.       do while (ifieldstatus == 0)
    465. 

  465.          call get_next_output_fieldname(nest_num, fieldname, ndims, &
    466. 

  466.                                         min_category, max_category, &
    467. 

  467.                                         istagger, memorder, dimnames, &
    468. 

  468.                                         units, description, subgrid_var, ifieldstatus)
    469. 

  469.    
    470. 

  470.          if (ifieldstatus == 0) nfields = nfields + 1
    471. 

  471.       end do
    472. 

  472.   
    473. 

  473. #ifdef _METGRID
    474. 

  474.       NUM_FIELDS = nfields
    475. 

  475. #endif
    476. 

  476.   
    477. 

  477. #ifdef _GEOGRID
    478. 

  478.       if (grid_type == 'C') NUM_AUTOMATIC_FIELDS = 24
    479. 

  479.       if (grid_type == 'E') NUM_AUTOMATIC_FIELDS = 7
    480. 

  480.   
    481. 

  481.       NUM_FIELDS = nfields+NUM_AUTOMATIC_FIELDS
    482. 

  482.       allocate(fields(NUM_FIELDS))
    483. 

  483.   
    484. 

  484.       !
    485. 

  485.       ! There are some fields that will always be computed
    486. 

  486.       !   Initialize those fields first, followed by all user-specified fields
    487. 

  487.       !
    488. 

  488.       if (grid_type == 'C') then
    489. 

  489.          fields(1)%fieldname = 'XLAT_M'
    490. 

  490.          fields(1)%units = 'degrees latitude'
    491. 

  491.          fields(1)%descr = 'Latitude on mass grid'
    492. 

  492.    
    493. 

  493.          fields(2)%fieldname = 'XLONG_M'
    494. 

  494.          fields(2)%units = 'degrees longitude'
    495. 

  495.          fields(2)%descr = 'Longitude on mass grid'
    496. 

  496.    
    497. 

  497.          fields(3)%fieldname = 'XLAT_V'
    498. 

  498.          fields(3)%units = 'degrees latitude'
    499. 

  499.          fields(3)%descr = 'Latitude on V grid'
    500. 

  500.    
    501. 

  501.          fields(4)%fieldname = 'XLONG_V'
    502. 

  502.          fields(4)%units = 'degrees longitude'
    503. 

  503.          fields(4)%descr = 'Longitude on V grid'
    504. 

  504.    
    505. 

  505.          fields(5)%fieldname = 'XLAT_U'
    506. 

  506.          fields(5)%units = 'degrees latitude'
    507. 

  507.          fields(5)%descr = 'Latitude on U grid'
    508. 

  508.    
    509. 

  509.          fields(6)%fieldname = 'XLONG_U'
    510. 

  510.          fields(6)%units = 'degrees longitude'
    511. 

  511.          fields(6)%descr = 'Longitude on U grid'
    512. 

  512.   
    513. 

  513.          fields(7)%fieldname = 'CLAT'
    514. 

  514.          fields(7)%units = 'degrees latitude'
    515. 

  515.          fields(7)%descr = 'Computational latitude on mass grid'
    516. 

  516.    
    517. 

  517.          fields(8)%fieldname = 'CLONG'
    518. 

  518.          fields(8)%units = 'degrees longitude'
    519. 

  519.          fields(8)%descr = 'Computational longitude on mass grid'
    520. 

  520. 

  521.          fields(9)%fieldname = 'MAPFAC_M'
    522. 

  522.          fields(9)%units = 'none'
    523. 

  523.          fields(9)%descr = 'Mapfactor on mass grid'
    524. 

  524. 

  525.          fields(10)%fieldname = 'MAPFAC_V'
    526. 

  526.          fields(10)%units = 'none'
    527. 

  527.          fields(10)%descr = 'Mapfactor on V grid'
    528. 

  528. 

  529.          fields(11)%fieldname = 'MAPFAC_U'
    530. 

  530.          fields(11)%units = 'none'
    531. 

  531.          fields(11)%descr = 'Mapfactor on U grid'
    532. 

  532.    
    533. 

  533.          fields(12)%fieldname = 'MAPFAC_MX'
    534. 

  534.          fields(12)%units = 'none'
    535. 

  535.          fields(12)%descr = 'Mapfactor (x-dir) on mass grid'
    536. 

  536.    
    537. 

  537.          fields(13)%fieldname = 'MAPFAC_VX'
    538. 

  538.          fields(13)%units = 'none'
    539. 

  539.          fields(13)%descr = 'Mapfactor (x-dir) on V grid'
    540. 

  540.    
    541. 

  541.          fields(14)%fieldname = 'MAPFAC_UX'
    542. 

  542.          fields(14)%units = 'none'
    543. 

  543.          fields(14)%descr = 'Mapfactor (x-dir) on U grid'
    544. 

  544. 

  545.          fields(15)%fieldname = 'MAPFAC_MY'
    546. 

  546.          fields(15)%units = 'none'
    547. 

  547.          fields(15)%descr = 'Mapfactor (y-dir) on mass grid'
    548. 

  548.    
    549. 

  549.          fields(16)%fieldname = 'MAPFAC_VY'
    550. 

  550.          fields(16)%units = 'none'
    551. 

  551.          fields(16)%descr = 'Mapfactor (y-dir) on V grid'
    552. 

  552.    
    553. 

  553.          fields(17)%fieldname = 'MAPFAC_UY'
    554. 

  554.          fields(17)%units = 'none'
    555. 

  555.          fields(17)%descr = 'Mapfactor (y-dir) on U grid'
    556. 

  556.    
    557. 

  557.          fields(18)%fieldname = 'E'
    558. 

  558.          fields(18)%units = '-'
    559. 

  559.          fields(18)%descr = 'Coriolis E parameter'
    560. 

  560.    
    561. 

  561.          fields(19)%fieldname = 'F'
    562. 

  562.          fields(19)%units = '-'
    563. 

  563.          fields(19)%descr = 'Coriolis F parameter'
    564. 

  564.    
    565. 

  565.          fields(20)%fieldname = 'SINALPHA'
    566. 

  566.          fields(20)%units = 'none'
    567. 

  567.          fields(20)%descr = 'Sine of rotation angle'
    568. 

  568.    
    569. 

  569.          fields(21)%fieldname = 'COSALPHA'
    570. 

  570.          fields(21)%units = 'none'
    571. 

  571.          fields(21)%descr = 'Cosine of rotation angle'
    572. 

  572.    
    573. 

  573.          fields(22)%fieldname = 'LANDMASK'
    574. 

  574.          fields(22)%units = 'none'
    575. 

  575.          fields(22)%descr = 'Landmask : 1=land, 0=water'
    576. 

  576. 

  577.          fields(23)%fieldname = 'FXLONG'
    578. 

  578.          fields(23)%units = 'degrees longitude'
    579. 

  579.          fields(23)%descr = 'Longitude on refined grid'
    580. 

  580. 

  581.          fields(24)%fieldname = 'FXLAT'
    582. 

  582.          fields(24)%units = 'degrees latitude'
    583. 

  583.          fields(24)%descr = 'Latitude on refined grid'
    584. 

  584. 

  585.       else if (grid_type == 'E') then
    586. 

  586.          fields(1)%fieldname = 'XLAT_M'
    587. 

  587.          fields(1)%units = 'degrees latitude'
    588. 

  588.          fields(1)%descr = 'Latitude on mass grid'
    589. 

  589.    
    590. 

  590.          fields(2)%fieldname = 'XLONG_M'
    591. 

  591.          fields(2)%units = 'degrees longitude'
    592. 

  592.          fields(2)%descr = 'Longitude on mass grid'
    593. 

  593.    
    594. 

  594.          fields(3)%fieldname = 'XLAT_V'
    595. 

  595.          fields(3)%units = 'degrees latitude'
    596. 

  596.          fields(3)%descr = 'Latitude on velocity grid'
    597. 

  597.    
    598. 

  598.          fields(4)%fieldname = 'XLONG_V'
    599. 

  599.          fields(4)%units = 'degrees longitude'
    600. 

  600.          fields(4)%descr = 'Longitude on velocity grid'
    601. 

  601.    
    602. 

  602.          fields(5)%fieldname = 'E'
    603. 

  603.          fields(5)%units = '-'
    604. 

  604.          fields(5)%descr = 'Coriolis E parameter'
    605. 

  605.    
    606. 

  606.          fields(6)%fieldname = 'F'
    607. 

  607.          fields(6)%units = '-'
    608. 

  608.          fields(6)%descr = 'Coriolis F parameter'
    609. 

  609.    
    610. 

  610.          fields(7)%fieldname = 'LANDMASK'
    611. 

  611.          fields(7)%units = 'none'
    612. 

  612.          fields(7)%descr = 'Landmask : 1=land, 0=water'
    613. 

  613.   
    614. 

  614.       end if
    615. 

  615.   
    616. 

  616.       !
    617. 

  617.       ! General defaults for "always computed" fields 
    618. 

  618.       !
    619. 

  619.       do i=1,NUM_AUTOMATIC_FIELDS
    620. 

  620.          fields(i)%ndims = 2
    621. 

  621.          fields(i)%dom_start(1) = start_dom_1 
    622. 

  622.          fields(i)%dom_start(2) = start_dom_2
    623. 

  623.          fields(i)%dom_start(3) = 1
    624. 

  624.          fields(i)%mem_start(1) = start_mem_1 
    625. 

  625.          fields(i)%mem_start(2) = start_mem_2
    626. 

  626.          fields(i)%mem_start(3) = 1
    627. 

  627.          fields(i)%patch_start(1) = start_patch_1
    628. 

  628.          fields(i)%patch_start(2) = start_patch_2
    629. 

  629.          fields(i)%patch_start(3) = 1
    630. 

  630.          fields(i)%dom_end(1) = end_dom_1
    631. 

  631.          fields(i)%dom_end(2) = end_dom_2
    632. 

  632.          fields(i)%dom_end(3) = 1
    633. 

  633.          fields(i)%mem_end(1) = end_mem_1
    634. 

  634.          fields(i)%mem_end(2) = end_mem_2
    635. 

  635.          fields(i)%mem_end(3) = 1
    636. 

  636.          fields(i)%patch_end(1) = end_patch_1
    637. 

  637.          fields(i)%patch_end(2) = end_patch_2
    638. 

  638.          fields(i)%patch_end(3) = 1
    639. 

  639.          fields(i)%dimnames(3) = ' '
    640. 

  640.          fields(i)%mem_order = 'XY'
    641. 

  641.          fields(i)%stagger = 'M'
    642. 

  642.          fields(i)%is_subgrid = .false.
    643. 

  643.          if (grid_type == 'C') then
    644. 

  644.             fields(i)%istagger = M
    645. 

  645.          else if (grid_type == 'E') then
    646. 

  646.             fields(i)%istagger = HH
    647. 

  647.          end if
    648. 

  648.          fields(i)%dimnames(1) = 'west_east'
    649. 

  649.          fields(i)%dimnames(2) = 'south_north'
    650. 

  650.       end do
    651. 

  651.   
    652. 

  652.       !
    653. 

  653.       ! Perform adjustments to metadata for non-mass-staggered "always computed" fields
    654. 

  654.       !
    655. 

  655.       if (grid_type == 'C') then
    656. 

  656.          ! Lat V
    657. 

  657.          if (extra_row) then
    658. 

  658.             fields(3)%dom_end(2) = fields(3)%dom_end(2) + 1
    659. 

  659.             fields(3)%mem_end(2) = fields(3)%mem_end(2) + 1
    660. 

  660.             fields(3)%patch_end(2) = fields(3)%patch_end(2) + 1
    661. 

  661.          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    662. 

  662.             fields(3)%dom_end(2) = fields(3)%dom_end(2) + 1
    663. 

  663.          end if
    664. 

  664.          fields(3)%dimnames(2) = 'south_north_stag'
    665. 

  665.          fields(3)%stagger = 'V'
    666. 

  666.          fields(3)%istagger = V
    667. 

  667.    
    668. 

  668.          ! Lon V
    669. 

  669.          if (extra_row) then
    670. 

  670.             fields(4)%dom_end(2) = fields(4)%dom_end(2) + 1
    671. 

  671.             fields(4)%mem_end(2) = fields(4)%mem_end(2) + 1
    672. 

  672.             fields(4)%patch_end(2) = fields(4)%patch_end(2) + 1
    673. 

  673.          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    674. 

  674.             fields(4)%dom_end(2) = fields(4)%dom_end(2) + 1
    675. 

  675.          end if
    676. 

  676.          fields(4)%dimnames(2) = 'south_north_stag'
    677. 

  677.          fields(4)%stagger = 'V'
    678. 

  678.          fields(4)%istagger = V
    679. 

  679.    
    680. 

  680.          ! Lat U
    681. 

  681.          if (extra_col) then
    682. 

  682.             fields(5)%dom_end(1) = fields(5)%dom_end(1) + 1
    683. 

  683.             fields(5)%mem_end(1) = fields(5)%mem_end(1) + 1
    684. 

  684.             fields(5)%patch_end(1) = fields(5)%patch_end(1) + 1
    685. 

  685.          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    686. 

  686.             fields(5)%dom_end(1) = fields(5)%dom_end(1) + 1
    687. 

  687.          end if
    688. 

  688.          fields(5)%dimnames(1) = 'west_east_stag'
    689. 

  689.          fields(5)%stagger = 'U'
    690. 

  690.          fields(5)%istagger = U
    691. 

  691.    
    692. 

  692.          ! Lon U
    693. 

  693.          if (extra_col) then
    694. 

  694.             fields(6)%dom_end(1) = fields(6)%dom_end(1) + 1
    695. 

  695.             fields(6)%mem_end(1) = fields(6)%mem_end(1) + 1
    696. 

  696.             fields(6)%patch_end(1) = fields(6)%patch_end(1) + 1
    697. 

  697.          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    698. 

  698.             fields(6)%dom_end(1) = fields(6)%dom_end(1) + 1
    699. 

  699.          end if
    700. 

  700.          fields(6)%dimnames(1) = 'west_east_stag'
    701. 

  701.          fields(6)%stagger = 'U'
    702. 

  702.          fields(6)%istagger = U
    703. 

  703. 

  704.          ! Mapfac V
    705. 

  705.          if (extra_row) then
    706. 

  706.             fields(10)%dom_end(2) = fields(10)%dom_end(2) + 1
    707. 

  707.             fields(10)%mem_end(2) = fields(10)%mem_end(2) + 1
    708. 

  708.             fields(10)%patch_end(2) = fields(10)%patch_end(2) + 1
    709. 

  709.          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    710. 

  710.             fields(10)%dom_end(2) = fields(10)%dom_end(2) + 1
    711. 

  711.          end if
    712. 

  712.          fields(10)%dimnames(2) = 'south_north_stag'
    713. 

  713.          fields(10)%stagger = 'V'
    714. 

  714.          fields(10)%istagger = V
    715. 

  715. 

  716.          ! Mapfac U
    717. 

  717.          if (extra_col) then
    718. 

  718.             fields(11)%dom_end(1) = fields(11)%dom_end(1) + 1
    719. 

  719.             fields(11)%mem_end(1) = fields(11)%mem_end(1) + 1
    720. 

  720.             fields(11)%patch_end(1) = fields(11)%patch_end(1) + 1
    721. 

  721.          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    722. 

  722.             fields(11)%dom_end(1) = fields(11)%dom_end(1) + 1
    723. 

  723.          end if
    724. 

  724.          fields(11)%dimnames(1) = 'west_east_stag'
    725. 

  725.          fields(11)%stagger = 'U' 
    726. 

  726.          fields(11)%istagger = U
    727. 

  727.    
    728. 

  728.          ! Mapfac V-X
    729. 

  729.          if (extra_row) then
    730. 

  730.             fields(13)%dom_end(2) = fields(13)%dom_end(2) + 1
    731. 

  731.             fields(13)%mem_end(2) = fields(13)%mem_end(2) + 1
    732. 

  732.             fields(13)%patch_end(2) = fields(13)%patch_end(2) + 1
    733. 

  733.          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    734. 

  734.             fields(13)%dom_end(2) = fields(13)%dom_end(2) + 1
    735. 

  735.          end if
    736. 

  736.          fields(13)%dimnames(2) = 'south_north_stag'
    737. 

  737.          fields(13)%stagger = 'V'
    738. 

  738.          fields(13)%istagger = V
    739. 

  739.    
    740. 

  740.          ! Mapfac U-X
    741. 

  741.          if (extra_col) then
    742. 

  742.             fields(14)%dom_end(1) = fields(14)%dom_end(1) + 1
    743. 

  743.             fields(14)%mem_end(1) = fields(14)%mem_end(1) + 1
    744. 

  744.             fields(14)%patch_end(1) = fields(14)%patch_end(1) + 1
    745. 

  745.          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    746. 

  746.             fields(14)%dom_end(1) = fields(14)%dom_end(1) + 1
    747. 

  747.          end if
    748. 

  748.          fields(14)%dimnames(1) = 'west_east_stag'
    749. 

  749.          fields(14)%stagger = 'U'
    750. 

  750.          fields(14)%istagger = U
    751. 

  751. 

  752.          ! Mapfac V-Y
    753. 

  753.          if (extra_row) then
    754. 

  754.             fields(16)%dom_end(2) = fields(16)%dom_end(2) + 1
    755. 

  755.             fields(16)%mem_end(2) = fields(16)%mem_end(2) + 1
    756. 

  756.             fields(16)%patch_end(2) = fields(16)%patch_end(2) + 1
    757. 

  757.          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    758. 

  758.             fields(16)%dom_end(2) = fields(16)%dom_end(2) + 1
    759. 

  759.          end if
    760. 

  760.          fields(16)%dimnames(2) = 'south_north_stag'
    761. 

  761.          fields(16)%stagger = 'V'
    762. 

  762.          fields(16)%istagger = V
    763. 

  763. 

  764.          ! Mapfac U-Y
    765. 

  765.          if (extra_col) then
    766. 

  766.             fields(17)%dom_end(1) = fields(17)%dom_end(1) + 1
    767. 

  767.             fields(17)%mem_end(1) = fields(17)%mem_end(1) + 1
    768. 

  768.             fields(17)%patch_end(1) = fields(17)%patch_end(1) + 1
    769. 

  769.          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    770. 

  770.             fields(17)%dom_end(1) = fields(17)%dom_end(1) + 1
    771. 

  771.          end if
    772. 

  772.          fields(17)%dimnames(1) = 'west_east_stag'
    773. 

  773.          fields(17)%stagger = 'U'
    774. 

  774.          fields(17)%istagger = U
    775. 

  775.   
    776. 

  776.          !
    777. 

  777.          ! Perform adjustments for subgrid lat/lon fields
    778. 

  778.          !
    779. 

  779.          do i=23,24
    780. 

  780.             fields(i)%is_subgrid=.true.
    781. 

  781.             call get_subgrid_dim_name(fields(i)%dimnames(1:2))
    782. 

  782.             fields(i)%mem_start(1)   = (fields(i)%mem_start(1) - 1)*sr_x + 1
    783. 

  783.             fields(i)%patch_start(1) = (fields(i)%patch_start(1) - 1)*sr_x + 1
    784. 

  784.             fields(i)%dom_start(1)   = (fields(i)%dom_start(1) - 1)*sr_x + 1
    785. 

  785. 

  786.             fields(i)%mem_end(1)     = (fields(i)%mem_end(1) + 1)*sr_x
    787. 

  787.             fields(i)%patch_end(1)   = (fields(i)%patch_end(1) + 1)*sr_x
    788. 

  788.             fields(i)%dom_end(1)     = (fields(i)%dom_end(1) + 1)*sr_x
    789. 

  789. 

  790.             fields(i)%mem_start(2)   = (fields(i)%mem_start(2) - 1)*sr_y + 1
    791. 

  791.             fields(i)%patch_start(2) = (fields(i)%patch_start(2) - 1)*sr_y + 1
    792. 

  792.             fields(i)%dom_start(2)   = (fields(i)%dom_start(2) - 1)*sr_y + 1
    793. 

  793. 

  794.             fields(i)%mem_end(2)     = (fields(i)%mem_end(2) + 1)*sr_y
    795. 

  795.             fields(i)%patch_end(2)   = (fields(i)%patch_end(2) + 1)*sr_y
    796. 

  796.             fields(i)%dom_end(2)     = (fields(i)%dom_end(2) + 1)*sr_y
    797. 

  797.          enddo
    798. 

  798.  
    799. 

  799.       else if (grid_type == 'E') then
    800. 

  800.          ! Lat V
    801. 

  801.          fields(3)%stagger = 'V'
    802. 

  802.          fields(3)%istagger = VV
    803. 

  803.    
    804. 

  804.          ! Lon V
    805. 

  805.          fields(4)%stagger = 'V'
    806. 

  806.          fields(4)%istagger = VV
    807. 

  807.    
    808. 

  808.       end if
    809. 

  809. #endif
    810. 

  810.   
    811. 

  811.       !
    812. 

  812.       ! Now set up the field_info structure for each user-specified field
    813. 

  813.       !
    814. 

  814.       call reset_next_field()
    815. 

  815.   
    816. 

  816.       ifieldstatus = 0
    817. 

  817. #ifdef _GEOGRID
    818. 

  818.       nfields = NUM_AUTOMATIC_FIELDS+1
    819. 

  819. #endif
    820. 

  820. #ifdef _METGRID
    821. 

  821.       allocate(fields(NUM_FIELDS))
    822. 

  822.       nfields = 1
    823. 

  823. #endif
    824. 

  824.   
    825. 

  825.       do while (ifieldstatus == 0)  !{
    826. 

  826.          call get_next_output_fieldname(nest_num, fieldname, ndims, &
    827. 

  827.                                       min_category, max_category, &
    828. 

  828.                                       istagger, memorder, dimnames, &
    829. 

  829.                                       units, description, subgrid_var, ifieldstatus)
    830. 

  830.    
    831. 

  831.          if (ifieldstatus == 0) then !{
    832. 

  832.      
    833. 

  833.             fields(nfields)%ndims = ndims
    834. 

  834.             fields(nfields)%fieldname = fieldname
    835. 

  835.             fields(nfields)%istagger = istagger
    836. 

  836.             if (istagger == M) then
    837. 

  837.                fields(nfields)%stagger = 'M'
    838. 

  838.             else if (istagger == U) then
    839. 

  839.                fields(nfields)%stagger = 'U'
    840. 

  840.             else if (istagger == V) then
    841. 

  841.                fields(nfields)%stagger = 'V'
    842. 

  842.             else if (istagger == HH) then
    843. 

  843.                fields(nfields)%stagger = 'M'
    844. 

  844.             else if (istagger == VV) then
    845. 

  845.                fields(nfields)%stagger = 'V'
    846. 

  846.             end if
    847. 

  847.             fields(nfields)%mem_order = memorder
    848. 

  848.             fields(nfields)%dimnames(1) = dimnames(1)
    849. 

  849.             fields(nfields)%dimnames(2) = dimnames(2)
    850. 

  850.             fields(nfields)%dimnames(3) = dimnames(3)
    851. 

  851.             fields(nfields)%units = units
    852. 

  852.             fields(nfields)%descr = description
    853. 

  853.     
    854. 

  854.             fields(nfields)%dom_start(1)   = start_dom_1
    855. 

  855.             fields(nfields)%dom_start(2)   = start_dom_2
    856. 

  856.             fields(nfields)%dom_start(3)   = min_category
    857. 

  857.             fields(nfields)%mem_start(1)   = start_mem_1
    858. 

  858.             fields(nfields)%mem_start(2)   = start_mem_2
    859. 

  859.             fields(nfields)%mem_start(3)   = min_category
    860. 

  860.             fields(nfields)%patch_start(1) = start_patch_1
    861. 

  861.             fields(nfields)%patch_start(2) = start_patch_2
    862. 

  862.             fields(nfields)%patch_start(3) = min_category
    863. 

  863.     
    864. 

  864.             fields(nfields)%dom_end(1)   = end_dom_1
    865. 

  865.             fields(nfields)%dom_end(2)   = end_dom_2
    866. 

  866.             fields(nfields)%dom_end(3)   = max_category
    867. 

  867.             fields(nfields)%mem_end(1)   = end_mem_1
    868. 

  868.             fields(nfields)%mem_end(2)   = end_mem_2
    869. 

  869.             fields(nfields)%mem_end(3)   = max_category
    870. 

  870.             fields(nfields)%patch_end(1) = end_patch_1
    871. 

  871.             fields(nfields)%patch_end(2) = end_patch_2
    872. 

  872.             fields(nfields)%patch_end(3) = max_category
    873. 

  873. 

  874.             fields(nfields)%is_subgrid=subgrid_var
    875. 

  875.     
    876. 

  876.             if (extra_col .and. (istagger == U .or. subgrid_var)) then !{
    877. 

  877.                fields(nfields)%dom_end(1)   = fields(nfields)%dom_end(1) + 1
    878. 

  878.                fields(nfields)%mem_end(1)   = fields(nfields)%mem_end(1) + 1
    879. 

  879.                fields(nfields)%patch_end(1) = fields(nfields)%patch_end(1) + 1
    880. 

  880.             else if ((istagger == U .or. subgrid_var) .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    881. 

  881.                fields(nfields)%dom_end(1)=fields(nfields)%dom_end(1) + 1
    882. 

  882.             end if !}
    883. 

  883.     
    884. 

  884.             if (extra_row .and. (istagger == V .or. subgrid_var)) then !{
    885. 

  885.                fields(nfields)%dom_end(2)   = fields(nfields)%dom_end(2) + 1
    886. 

  886.                fields(nfields)%mem_end(2)   = fields(nfields)%mem_end(2) + 1
    887. 

  887.                fields(nfields)%patch_end(2) = fields(nfields)%patch_end(2) + 1
    888. 

  888.             else if ((istagger == V .or. subgrid_var) .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then
    889. 

  889.                fields(nfields)%dom_end(2)=fields(nfields)%dom_end(2) + 1
    890. 

  890.             end if !}
    891. 

  891. 

  892. #ifdef _METGRID
    893. 

  893.             lhalo_width = start_patch_1 - start_mem_1      ! Halo width on left of patch
    894. 

  894.             rhalo_width = end_mem_1     - end_patch_1      ! Halo width on right of patch
    895. 

  895.             bhalo_width = start_patch_2 - start_mem_2      ! Halo width on bottom of patch
    896. 

  896.             thalo_width = end_mem_2     - end_patch_2      ! Halo width on top of patch
    897. 

  897. #else
    898. 

  898.             lhalo_width = 0
    899. 

  899.             rhalo_width = 0
    900. 

  900.             bhalo_width = 0
    901. 

  901.             thalo_width = 0
    902. 

  902. #endif
    903. 

  903. 

  904.             if (subgrid_var) then
    905. 

  905.                fields(nfields)%mem_start(1)   = (fields(nfields)%mem_start(1) + lhalo_width - 1)*sr_x + 1 - lhalo_width
    906. 

  906.                fields(nfields)%patch_start(1) = (fields(nfields)%patch_start(1)             - 1)*sr_x + 1
    907. 

  907.                fields(nfields)%dom_start(1)   = (fields(nfields)%dom_start(1)               - 1)*sr_x + 1
    908. 

  908. 

  909.                fields(nfields)%mem_end(1)     = (fields(nfields)%mem_end(1) - rhalo_width)*sr_x + rhalo_width
    910. 

  910.                fields(nfields)%patch_end(1)   = (fields(nfields)%patch_end(1)            )*sr_x
    911. 

  911.                fields(nfields)%dom_end(1)     = (fields(nfields)%dom_end(1)              )*sr_x
    912. 

  912. 

  913.                fields(nfields)%mem_start(2)   = (fields(nfields)%mem_start(2) + bhalo_width - 1)*sr_y + 1 - bhalo_width
    914. 

  914.                fields(nfields)%patch_start(2) = (fields(nfields)%patch_start(2)             - 1)*sr_y + 1
    915. 

  915.                fields(nfields)%dom_start(2)   = (fields(nfields)%dom_start(2)               - 1)*sr_y + 1
    916. 

  916. 

  917.                fields(nfields)%mem_end(2)     = (fields(nfields)%mem_end(2) - thalo_width)*sr_y + thalo_width
    918. 

  918.                fields(nfields)%patch_end(2)   = (fields(nfields)%patch_end(2)            )*sr_y
    919. 

  919.                fields(nfields)%dom_end(2)     = (fields(nfields)%dom_end(2)              )*sr_y
    920. 

  920. 

  921.            endif
    922. 

  922. 

  923.             nfields = nfields + 1
    924. 

  924.    
    925. 

  925.          end if  ! the next field given by get_next_fieldname() is valid }
    926. 

  926.     
    927. 

  927.       end do  ! for each user-specified field }
    928. 

  928.   
    929. 

  929.    end subroutine init_output_fields
    930. 

  930.  
    931. 

  931.  
    932. 

  932.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    933. 

  933.    ! Name: write_field
    934. 

  934.    !
    935. 

  935.    ! Purpose: This routine writes the provided field to any output devices or APIs
    936. 

  936.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    937. 

  937.    subroutine write_field(start_mem_i, end_mem_i, &
    938. 

  938.                           start_mem_j, end_mem_j, &
    939. 

  939.                           start_mem_k, end_mem_k, &
    940. 

  940.                           cname, datestr, real_array, is_training)
    941. 

  941.  
    942. 

  942.       implicit none
    943. 

  943.   
    944. 

  944.       ! Arguments
    945. 

  945.       integer, intent(in) :: start_mem_i, end_mem_i, start_mem_j, end_mem_j, start_mem_k, end_mem_k
    946. 

  946.       real, target, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j, start_mem_k:end_mem_k), &
    947. 

  947.                               intent(in) :: real_array
    948. 

  948.       logical, intent(in), optional :: is_training
    949. 

  949.       character (len=19), intent(in) :: datestr
    950. 

  950.       character (len=*), intent(in) :: cname
    951. 

  951.   
    952. 

  952. #include "wrf_io_flags.h"
    953. 

  953. #include "wrf_status_codes.h"
    954. 

  954.   
    955. 

  955.       ! Local variables
    956. 

  956.       integer :: i
    957. 

  957.       integer :: istatus, comm_1, comm_2, domain_desc
    958. 

  958.       integer, dimension(3) :: sd, ed, sp, ep, sm, em
    959. 

  959.       real, pointer, dimension(:,:,:) :: real_dom_array
    960. 

  960.       logical :: allocated_real_locally
    961. 

  961.       integer :: is_subgrid
    962. 

  962.   
    963. 

  963.       allocated_real_locally = .false.
    964. 

  964.   
    965. 

  965.       ! If we are running distributed memory and need to gather all tiles onto a single processor for output
    966. 

  966.       if (nprocs > 1 .and. .not. do_tiled_output) then
    967. 

  967.          do i=1,NUM_FIELDS
    968. 

  968.             if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
    969. 

  969.                   (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
    970. 

  970.                istatus = 0
    971. 

  971.      
    972. 

  972.                ! For the gather routines below, the IO_NODE should give the full domain dimensions, but the
    973. 

  973.                !   memory and patch dimensions should indicate what the processor already has in its patch_array.
    974. 

  974.                ! This is because an array with dimensions of the full domain will be allocated, and the patch_array
    975. 

  975.                !   will be copied from local memory into the full domain array in the area specified by the patch
    976. 

  976.                !   dimensions.
    977. 

  977.                sd = fields(i)%dom_start
    978. 

  978.                ed = fields(i)%dom_end
    979. 

  979.                sp = fields(i)%patch_start
    980. 

  980.                ep = fields(i)%patch_end
    981. 

  981.                sm = fields(i)%mem_start
    982. 

  982.                em = fields(i)%mem_end
    983. 

  983.      
    984. 

  984.                allocate(real_dom_array(sd(1):ed(1),sd(2):ed(2),sd(3):ed(3)))
    985. 

  985.                allocated_real_locally = .true.
    986. 

  986.                call gather_whole_field_r(real_array, &
    987. 

  987.                                          sm(1), em(1), sm(2), em(2), sm(3), em(3), &
    988. 

  988.                                          sp(1), ep(1), sp(2), ep(2), sp(3), ep(3), &
    989. 

  989.                                          real_dom_array, &
    990. 

  990.                                          sd(1), ed(1), sd(2), ed(2), sd(3), ed(3))
    991. 

  991.                exit
    992. 

  992.             end if 
    993. 

  993.          end do
    994. 

  994.       else
    995. 

  995.          do i=1,NUM_FIELDS
    996. 

  996.             if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
    997. 

  997.                  (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
    998. 

  998.                istatus = 0
    999. 

  999.                real_dom_array => real_array
    1000. 

  1000.                exit
    1001. 

  1001.             end if 
    1002. 

  1002.          end do
    1003. 

  1003.       end if
    1004. 

  1004.   
    1005. 

  1005.       ! Now a write call is only done if each processor writes its own file, or if we are the IO_NODE
    1006. 

  1006.       if (my_proc_id == IO_NODE .or. do_tiled_output) then
    1007. 

  1007.          comm_1 = 1
    1008. 

  1008.          comm_2 = 1
    1009. 

  1009.          domain_desc = 0
    1010. 

  1010.    
    1011. 

  1011.          do i=1,NUM_FIELDS
    1012. 

  1012.             if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
    1013. 

  1013.                  (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
    1014. 

  1014.    
    1015. 

  1015.                if (fields(i)%is_subgrid) then
    1016. 

  1016.                  is_subgrid=1
    1017. 

  1017.                else
    1018. 

  1018.                  is_subgrid=0
    1019. 

  1019.                end if
    1020. 

  1020. 

  1021.                ! Here, the output array has dimensions of the full grid if it was gathered together
    1022. 

  1022.                !   from all processors
    1023. 

  1023.                if (my_proc_id == IO_NODE .and. nprocs > 1 .and. .not. do_tiled_output) then
    1024. 

  1024.                   sd = fields(i)%dom_start
    1025. 

  1025.                   ed = fields(i)%dom_end
    1026. 

  1026.                   sm = sd
    1027. 

  1027.                   em = ed
    1028. 

  1028.                   sp = sd  
    1029. 

  1029.                   ep = ed
    1030. 

  1030.                ! If we are writing one file per processor, then each processor only writes out the 
    1031. 

  1031.                !   part of the domain that it has in memory
    1032. 

  1032.                else
    1033. 

  1033. ! BUG: Shouldn't we set sd/ed to be domain_start/domain_end?
    1034. 

  1034. !      Maybe not, since patch is already adjusted for staggering; but maybe so, and also adjust
    1035. 

  1035. !      for staggering if it is alright to pass true domain dimensions to write_field.
    1036. 

  1036.                   sd = fields(i)%patch_start
    1037. 

  1037.                   ed = fields(i)%patch_end
    1038. 

  1038.                   sp = fields(i)%patch_start
    1039. 

  1039.                   ep = fields(i)%patch_end
    1040. 

  1040.                   sm = fields(i)%mem_start
    1041. 

  1041.                   em = fields(i)%mem_end
    1042. 

  1042.                end if
    1043. 

  1043.      
    1044. 

  1044.                istatus = 0
    1045. 

  1045. #ifdef IO_BINARY
    1046. 

  1046.                if (io_form_output == BINARY) then
    1047. 

  1047.                   call ext_int_write_field(handle, datestr, trim(fields(i)%fieldname), &
    1048. 

  1048.                        real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
    1049. 

  1049.                        trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
    1050. 

  1050.                end if
    1051. 

  1051. #endif
    1052. 

  1052. #ifdef IO_NETCDF
    1053. 

  1053.                if (io_form_output == NETCDF) then
    1054. 

  1054.                   call ext_ncd_write_field(handle, datestr, trim(fields(i)%fieldname), &
    1055. 

  1055.                        real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
    1056. 

  1056.                        trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
    1057. 

  1057.                end if
    1058. 

  1058. #endif
    1059. 

  1059. #ifdef IO_GRIB1
    1060. 

  1060.                if (io_form_output == GRIB1) then
    1061. 

  1061.                   call ext_gr1_write_field(handle, datestr, trim(fields(i)%fieldname), &
    1062. 

  1062.                        real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
    1063. 

  1063.                        trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
    1064. 

  1064.                end if
    1065. 

  1065. #endif
    1066. 

  1066.                call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_write_field')
    1067. 

  1067. 

  1068.                if (present(is_training)) then
    1069. 

  1069.                   if (is_training) then
    1070. 

  1070. #ifdef IO_BINARY
    1071. 

  1071.                      if (io_form_output == BINARY) then
    1072. 

  1072.                         call ext_int_put_var_ti_char(handle, 'units', &
    1073. 

  1073.                                                 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
    1074. 

  1074.                         call ext_int_put_var_ti_char(handle, 'description', &
    1075. 

  1075.                                                 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
    1076. 

  1076.                         call ext_int_put_var_ti_char(handle, 'stagger', &
    1077. 

  1077.                                                 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
    1078. 

  1078.                         call ext_int_put_var_ti_integer(handle,'subgrid', &
    1079. 

  1079.                                                 trim(fields(i)%fieldname),(/is_subgrid/),1, istatus)
    1080. 

  1080.                      end if
    1081. 

  1081. #endif
    1082. 

  1082. #ifdef IO_NETCDF
    1083. 

  1083.                      if (io_form_output == NETCDF) then
    1084. 

  1084.                         call ext_ncd_put_var_ti_char(handle, 'units', &
    1085. 

  1085.                                                 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
    1086. 

  1086.                         call ext_ncd_put_var_ti_char(handle, 'description', &
    1087. 

  1087.                                                 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
    1088. 

  1088.                         call ext_ncd_put_var_ti_char(handle, 'stagger', &
    1089. 

  1089.                                                 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
    1090. 

  1090.                         call ext_ncd_put_var_ti_integer(handle,'subgrid', &
    1091. 

  1091.                                                 trim(fields(i)%fieldname),(/is_subgrid/),1, istatus)
    1092. 

  1092.                     end if
    1093. 

  1093. #endif
    1094. 

  1094. #ifdef IO_GRIB1
    1095. 

  1095.                      if (io_form_output == GRIB1) then
    1096. 

  1096.                         call ext_gr1_put_var_ti_char(handle, 'units', &
    1097. 

  1097.                                                 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
    1098. 

  1098.                         call ext_gr1_put_var_ti_char(handle, 'description', &
    1099. 

  1099.                                                 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
    1100. 

  1100.                         call ext_gr1_put_var_ti_char(handle, 'stagger', &
    1101. 

  1101.                                                 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
    1102. 

  1102.                         call ext_gr1_put_var_ti_integer(handle,'subgrid', &
    1103. 

  1103.                                                 trim(fields(i)%fieldname),(/is_subgrid/),1, istatus)
    1104. 

  1104.                     end if
    1105. 

  1105. #endif
    1106. 

  1106.                   end if
    1107. 

  1107.                end if
    1108. 

  1108.                exit
    1109. 

  1109.             end if
    1110. 

  1110.          end do
    1111. 

  1111.    
    1112. 

  1112.       end if
    1113. 

  1113.   
    1114. 

  1114.       if (allocated_real_locally) deallocate(real_dom_array)
    1115. 

  1115.   
    1116. 

  1116.    end subroutine write_field
    1117. 

  1117.  
    1118. 

  1118.  
    1119. 

  1119.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1120. 

  1120.    ! Name: write_global_attrs
    1121. 

  1121.    !
    1122. 

  1122.    ! Purpose:
    1123. 

  1123.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1124. 

  1124.    subroutine write_global_attrs(title, start_date, grid_type, dyn_opt,                             &
    1125. 

  1125.                                 west_east_dim, south_north_dim, bottom_top_dim,                     &
    1126. 

  1126.                                 we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag,           &
    1127. 

  1127.                                 sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag,           &
    1128. 

  1128.                                 map_proj, cmminlu, num_land_cat, is_water, is_lake, is_ice,         &
    1129. 

  1129.                                 is_urban, i_soilwater, grid_id, parent_id,                          &
    1130. 

  1130.                                 i_parent_start, j_parent_start, i_parent_end, j_parent_end,         &
    1131. 

  1131.                                 dx, dy, cen_lat, moad_cen_lat, cen_lon,                             &
    1132. 

  1132.                                 stand_lon, truelat1, truelat2, pole_lat, pole_lon,                  &
    1133. 

  1133.                                 parent_grid_ratio, sr_x, sr_y, corner_lats, corner_lons,            &
    1134. 

  1134.                                 num_metgrid_soil_levs,                                              &
    1135. 

  1135.                                 flags, nflags, flag_excluded_middle)
    1136. 

  1136.  
    1137. 

  1137.       implicit none
    1138. 

  1138.   
    1139. 

  1139.       ! Arguments
    1140. 

  1140.       integer, intent(in) :: dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, &
    1141. 

  1141.                  we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag,            &
    1142. 

  1142.                  sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag,            &
    1143. 

  1143.                  map_proj, is_water, is_lake, is_ice, is_urban, i_soilwater,          &
    1144. 

  1144.                  grid_id, parent_id, i_parent_start, j_parent_start,                  &
    1145. 

  1145.                  i_parent_end, j_parent_end, parent_grid_ratio, sr_x, sr_y, num_land_cat
    1146. 

  1146.       integer, intent(in), optional :: num_metgrid_soil_levs
    1147. 

  1147.       integer, intent(in), optional :: nflags
    1148. 

  1148.       integer, intent(in), optional :: flag_excluded_middle
    1149. 

  1149.       real, intent(in) :: dx, dy, cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, &
    1150. 

  1150.                  pole_lat, pole_lon
    1151. 

  1151.       real, dimension(16), intent(in) :: corner_lats, corner_lons
    1152. 

  1152.       character (len=*), intent(in) :: title, start_date, grid_type
    1153. 

  1153.       character (len=128), intent(in) :: cmminlu
    1154. 

  1154.       character (len=128), dimension(:), intent(in), optional :: flags
    1155. 

  1155.   
    1156. 

  1156.       ! Local variables
    1157. 

  1157.       integer :: local_we_patch_s, local_we_patch_s_stag, &
    1158. 

  1158.                  local_we_patch_e, local_we_patch_e_stag, &
    1159. 

  1159.                  local_sn_patch_s, local_sn_patch_s_stag, &
    1160. 

  1160.                  local_sn_patch_e, local_sn_patch_e_stag
    1161. 

  1161.       integer :: i
    1162. 

  1162.       real, dimension(16) :: local_corner_lats, local_corner_lons
    1163. 

  1163. 

  1164.       local_we_patch_s      = we_patch_s
    1165. 

  1165.       local_we_patch_s_stag = we_patch_s_stag 
    1166. 

  1166.       local_we_patch_e      = we_patch_e
    1167. 

  1167.       local_we_patch_e_stag = we_patch_e_stag 
    1168. 

  1168.       local_sn_patch_s      = sn_patch_s
    1169. 

  1169.       local_sn_patch_s_stag = sn_patch_s_stag 
    1170. 

  1170.       local_sn_patch_e      = sn_patch_e
    1171. 

  1171.       local_sn_patch_e_stag = sn_patch_e_stag 
    1172. 

  1172.       local_corner_lats = corner_lats
    1173. 

  1173.       local_corner_lons = corner_lons
    1174. 

  1174. 

  1175.       if (nprocs > 1) then
    1176. 

  1176. 

  1177.          if (.not. do_tiled_output) then
    1178. 

  1178.             call parallel_bcast_int(local_we_patch_s,      processors(0, 0))
    1179. 

  1179.             call parallel_bcast_int(local_we_patch_s_stag, processors(0, 0))
    1180. 

  1180.             call parallel_bcast_int(local_sn_patch_s,      processors(0, 0))
    1181. 

  1181.             call parallel_bcast_int(local_sn_patch_s_stag, processors(0, 0))
    1182. 

  1182. 

  1183.             call parallel_bcast_int(local_we_patch_e,      processors(nproc_x-1, nproc_y-1))
    1184. 

  1184.             call parallel_bcast_int(local_we_patch_e_stag, processors(nproc_x-1, nproc_y-1))
    1185. 

  1185.             call parallel_bcast_int(local_sn_patch_e,      processors(nproc_x-1, nproc_y-1))
    1186. 

  1186.             call parallel_bcast_int(local_sn_patch_e_stag, processors(nproc_x-1, nproc_y-1))
    1187. 

  1187.          end if
    1188. 

  1188. 

  1189.          call parallel_bcast_real(local_corner_lats(1),  processors(0,         0))
    1190. 

  1190.          call parallel_bcast_real(local_corner_lats(2),  processors(0,         nproc_y-1))
    1191. 

  1191.          call parallel_bcast_real(local_corner_lats(3),  processors(nproc_x-1, nproc_y-1))
    1192. 

  1192.          call parallel_bcast_real(local_corner_lats(4),  processors(nproc_x-1, 0))
    1193. 

  1193.          call parallel_bcast_real(local_corner_lats(5),  processors(0,         0))
    1194. 

  1194.          call parallel_bcast_real(local_corner_lats(6),  processors(0,         nproc_y-1))
    1195. 

  1195.          call parallel_bcast_real(local_corner_lats(7),  processors(nproc_x-1, nproc_y-1))
    1196. 

  1196.          call parallel_bcast_real(local_corner_lats(8),  processors(nproc_x-1, 0))
    1197. 

  1197.          call parallel_bcast_real(local_corner_lats(9),  processors(0,         0))
    1198. 

  1198.          call parallel_bcast_real(local_corner_lats(10), processors(0,         nproc_y-1))
    1199. 

  1199.          call parallel_bcast_real(local_corner_lats(11), processors(nproc_x-1, nproc_y-1))
    1200. 

  1200.          call parallel_bcast_real(local_corner_lats(12), processors(nproc_x-1, 0))
    1201. 

  1201.          call parallel_bcast_real(local_corner_lats(13), processors(0,         0))
    1202. 

  1202.          call parallel_bcast_real(local_corner_lats(14), processors(0,         nproc_y-1))
    1203. 

  1203.          call parallel_bcast_real(local_corner_lats(15), processors(nproc_x-1, nproc_y-1))
    1204. 

  1204.          call parallel_bcast_real(local_corner_lats(16), processors(nproc_x-1, 0))
    1205. 

  1205. 

  1206.          call parallel_bcast_real(local_corner_lons(1),  processors(0,         0))
    1207. 

  1207.          call parallel_bcast_real(local_corner_lons(2),  processors(0,         nproc_y-1))
    1208. 

  1208.          call parallel_bcast_real(local_corner_lons(3),  processors(nproc_x-1, nproc_y-1))
    1209. 

  1209.          call parallel_bcast_real(local_corner_lons(4),  processors(nproc_x-1, 0))
    1210. 

  1210.          call parallel_bcast_real(local_corner_lons(5),  processors(0,         0))
    1211. 

  1211.          call parallel_bcast_real(local_corner_lons(6),  processors(0,         nproc_y-1))
    1212. 

  1212.          call parallel_bcast_real(local_corner_lons(7),  processors(nproc_x-1, nproc_y-1))
    1213. 

  1213.          call parallel_bcast_real(local_corner_lons(8),  processors(nproc_x-1, 0))
    1214. 

  1214.          call parallel_bcast_real(local_corner_lons(9),  processors(0,         0))
    1215. 

  1215.          call parallel_bcast_real(local_corner_lons(10), processors(0,         nproc_y-1))
    1216. 

  1216.          call parallel_bcast_real(local_corner_lons(11), processors(nproc_x-1, nproc_y-1))
    1217. 

  1217.          call parallel_bcast_real(local_corner_lons(12), processors(nproc_x-1, 0))
    1218. 

  1218.          call parallel_bcast_real(local_corner_lons(13), processors(0,         0))
    1219. 

  1219.          call parallel_bcast_real(local_corner_lons(14), processors(0,         nproc_y-1))
    1220. 

  1220.          call parallel_bcast_real(local_corner_lons(15), processors(nproc_x-1, nproc_y-1))
    1221. 

  1221.          call parallel_bcast_real(local_corner_lons(16), processors(nproc_x-1, 0))
    1222. 

  1222.       end if
    1223. 

  1223.   
    1224. 

  1224.       if (my_proc_id == IO_NODE .or. do_tiled_output) then
    1225. 

  1225.   
    1226. 

  1226.          call ext_put_dom_ti_char          ('TITLE', title)
    1227. 

  1227.          call ext_put_dom_ti_char          ('SIMULATION_START_DATE', start_date)
    1228. 

  1228.          call ext_put_dom_ti_integer_scalar('WEST-EAST_GRID_DIMENSION', west_east_dim)
    1229. 

  1229.          call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_GRID_DIMENSION', south_north_dim)
    1230. 

  1230.          call ext_put_dom_ti_integer_scalar('BOTTOM-TOP_GRID_DIMENSION', bottom_top_dim)
    1231. 

  1231.          call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_UNSTAG', local_we_patch_s)
    1232. 

  1232.          call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_UNSTAG', local_we_patch_e)
    1233. 

  1233.          call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_STAG', local_we_patch_s_stag)
    1234. 

  1234.          call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_STAG', local_we_patch_e_stag)
    1235. 

  1235.          call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_UNSTAG', local_sn_patch_s)
    1236. 

  1236.          call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_UNSTAG', local_sn_patch_e)
    1237. 

  1237.          call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_STAG', local_sn_patch_s_stag)
    1238. 

  1238.          call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_STAG', local_sn_patch_e_stag)
    1239. 

  1239.          call ext_put_dom_ti_char          ('GRIDTYPE', grid_type)
    1240. 

  1240.          call ext_put_dom_ti_real_scalar   ('DX', dx)
    1241. 

  1241.          call ext_put_dom_ti_real_scalar   ('DY', dy)
    1242. 

  1242.          call ext_put_dom_ti_integer_scalar('DYN_OPT', dyn_opt)
    1243. 

  1243.          call ext_put_dom_ti_real_scalar   ('CEN_LAT', cen_lat)
    1244. 

  1244.          call ext_put_dom_ti_real_scalar   ('CEN_LON', cen_lon)
    1245. 

  1245.          call ext_put_dom_ti_real_scalar   ('TRUELAT1', truelat1)
    1246. 

  1246.          call ext_put_dom_ti_real_scalar   ('TRUELAT2', truelat2)
    1247. 

  1247.          call ext_put_dom_ti_real_scalar   ('MOAD_CEN_LAT', moad_cen_lat)
    1248. 

  1248.          call ext_put_dom_ti_real_scalar   ('STAND_LON', stand_lon)
    1249. 

  1249.          call ext_put_dom_ti_real_scalar   ('POLE_LAT', pole_lat)
    1250. 

  1250.          call ext_put_dom_ti_real_scalar   ('POLE_LON', pole_lon)
    1251. 

  1251.          call ext_put_dom_ti_real_vector   ('corner_lats', local_corner_lats, 16) 
    1252. 

  1252.          call ext_put_dom_ti_real_vector   ('corner_lons', local_corner_lons, 16) 
    1253. 

  1253.          call ext_put_dom_ti_integer_scalar('MAP_PROJ', map_proj)
    1254. 

  1254.          call ext_put_dom_ti_char          ('MMINLU', trim(cmminlu))
    1255. 

  1255.          call ext_put_dom_ti_integer_scalar('NUM_LAND_CAT', num_land_cat)
    1256. 

  1256.          call ext_put_dom_ti_integer_scalar('ISWATER', is_water)
    1257. 

  1257.          call ext_put_dom_ti_integer_scalar('ISLAKE', is_lake)
    1258. 

  1258.          call ext_put_dom_ti_integer_scalar('ISICE', is_ice)
    1259. 

  1259.          call ext_put_dom_ti_integer_scalar('ISURBAN', is_urban)
    1260. 

  1260.          call ext_put_dom_ti_integer_scalar('ISOILWATER', i_soilwater)
    1261. 

  1261.          call ext_put_dom_ti_integer_scalar('grid_id', grid_id)
    1262. 

  1262.          call ext_put_dom_ti_integer_scalar('parent_id', parent_id)
    1263. 

  1263.          call ext_put_dom_ti_integer_scalar('i_parent_start', i_parent_start)
    1264. 

  1264.          call ext_put_dom_ti_integer_scalar('j_parent_start', j_parent_start)
    1265. 

  1265.          call ext_put_dom_ti_integer_scalar('i_parent_end', i_parent_end)
    1266. 

  1266.          call ext_put_dom_ti_integer_scalar('j_parent_end', j_parent_end)
    1267. 

  1267.          call ext_put_dom_ti_integer_scalar('parent_grid_ratio', parent_grid_ratio)
    1268. 

  1268.          call ext_put_dom_ti_integer_scalar('sr_x',sr_x)
    1269. 

  1269.          call ext_put_dom_ti_integer_scalar('sr_y',sr_y)
    1270. 

  1270. #ifdef _METGRID
    1271. 

  1271.          if (present(num_metgrid_soil_levs)) then
    1272. 

  1272.             call ext_put_dom_ti_integer_scalar('NUM_METGRID_SOIL_LEVELS', num_metgrid_soil_levs)
    1273. 

  1273.          end if
    1274. 

  1274.          call ext_put_dom_ti_integer_scalar('FLAG_METGRID', 1)
    1275. 

  1275.          if (present(flag_excluded_middle)) then
    1276. 

  1276.             call ext_put_dom_ti_integer_scalar('FLAG_EXCLUDED_MIDDLE', flag_excluded_middle)
    1277. 

  1277.          end if
    1278. 

  1278. #endif
    1279. 

  1279. 

  1280.          if (present(nflags) .and. present(flags)) then
    1281. 

  1281.             do i=1,nflags
    1282. 

  1282.                if (flags(i) /= ' ') then
    1283. 

  1283.                   call ext_put_dom_ti_integer_scalar(trim(flags(i)), 1)
    1284. 

  1284.                end if
    1285. 

  1285.             end do
    1286. 

  1286.          end if
    1287. 

  1287. 

  1288.       end if
    1289. 

  1289.  
    1290. 

  1290.    end subroutine write_global_attrs
    1291. 

  1291. 

  1292. 

  1293.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1294. 

  1294.    ! Name: ext_put_dom_ti_integer
    1295. 

  1295.    !
    1296. 

  1296.    ! Purpose: Write a domain time-independent integer attribute to output. 
    1297. 

  1297.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1298. 

  1298.    subroutine ext_put_dom_ti_integer_scalar(var_name, var_value)
    1299. 

  1299. 

  1300.       implicit none
    1301. 

  1301. 

  1302.       ! Arguments
    1303. 

  1303.       integer, intent(in) :: var_value
    1304. 

  1304.       character (len=*), intent(in) :: var_name
    1305. 

  1305. 

  1306.       ! Local variables
    1307. 

  1307.       integer :: istatus
    1308. 

  1308. 

  1309. #ifdef IO_BINARY
    1310. 

  1310.       if (io_form_output == BINARY) then
    1311. 

  1311.          call ext_int_put_dom_ti_integer(handle, trim(var_name), &
    1312. 

  1312.                                          var_value, &
    1313. 

  1313.                                          1, istatus)
    1314. 

  1314.       end if
    1315. 

  1315. #endif
    1316. 

  1316. #ifdef IO_NETCDF
    1317. 

  1317.       if (io_form_output == NETCDF) then
    1318. 

  1318.          call ext_ncd_put_dom_ti_integer(handle, trim(var_name), &
    1319. 

  1319.                                          var_value, &
    1320. 

  1320.                                          1, istatus)
    1321. 

  1321.       end if
    1322. 

  1322. #endif
    1323. 

  1323. #ifdef IO_GRIB1
    1324. 

  1324.       if (io_form_output == GRIB1) then
    1325. 

  1325.          call ext_gr1_put_dom_ti_integer(handle, trim(var_name), &
    1326. 

  1326.                                          var_value, &
    1327. 

  1327.                                          1, istatus)
    1328. 

  1328.       end if
    1329. 

  1329. #endif
    1330. 

  1330. 

  1331.       call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
    1332. 

  1332. 

  1333.    end subroutine ext_put_dom_ti_integer_scalar
    1334. 

  1334. 

  1335. 

  1336.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1337. 

  1337.    ! Name: ext_put_dom_ti_integer
    1338. 

  1338.    !
    1339. 

  1339.    ! Purpose: Write a domain time-independent integer attribute to output. 
    1340. 

  1340.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1341. 

  1341.    subroutine ext_put_dom_ti_integer_vector(var_name, var_value, n)
    1342. 

  1342. 

  1343.       implicit none
    1344. 

  1344. 

  1345.       ! Arguments
    1346. 

  1346.       integer, intent(in) :: n
    1347. 

  1347.       integer, dimension(n), intent(in) :: var_value
    1348. 

  1348.       character (len=*), intent(in) :: var_name
    1349. 

  1349. 

  1350.       ! Local variables
    1351. 

  1351.       integer :: istatus
    1352. 

  1352. 

  1353. #ifdef IO_BINARY
    1354. 

  1354.       if (io_form_output == BINARY) then
    1355. 

  1355.          call ext_int_put_dom_ti_integer(handle, trim(var_name), &
    1356. 

  1356.                                          var_value, &
    1357. 

  1357.                                          n, istatus)
    1358. 

  1358.       end if
    1359. 

  1359. #endif
    1360. 

  1360. #ifdef IO_NETCDF
    1361. 

  1361.       if (io_form_output == NETCDF) then
    1362. 

  1362.          call ext_ncd_put_dom_ti_integer(handle, trim(var_name), &
    1363. 

  1363.                                          var_value, &
    1364. 

  1364.                                          n, istatus)
    1365. 

  1365.       end if
    1366. 

  1366. #endif
    1367. 

  1367. #ifdef IO_GRIB1
    1368. 

  1368.       if (io_form_output == GRIB1) then
    1369. 

  1369.          call ext_gr1_put_dom_ti_integer(handle, trim(var_name), &
    1370. 

  1370.                                          var_value, &
    1371. 

  1371.                                          n, istatus)
    1372. 

  1372.       end if
    1373. 

  1373. #endif
    1374. 

  1374. 

  1375.       call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
    1376. 

  1376. 

  1377.    end subroutine ext_put_dom_ti_integer_vector
    1378. 

  1378. 

  1379. 

  1380.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1381. 

  1381.    ! Name: ext_put_dom_ti_real
    1382. 

  1382.    !
    1383. 

  1383.    ! Purpose: Write a domain time-independent real attribute to output. 
    1384. 

  1384.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1385. 

  1385.    subroutine ext_put_dom_ti_real_scalar(var_name, var_value)
    1386. 

  1386. 

  1387.       implicit none
    1388. 

  1388. 

  1389.       ! Arguments
    1390. 

  1390.       real, intent(in) :: var_value
    1391. 

  1391.       character (len=*), intent(in) :: var_name
    1392. 

  1392. 

  1393.       ! Local variables
    1394. 

  1394.       integer :: istatus
    1395. 

  1395. 

  1396. #ifdef IO_BINARY
    1397. 

  1397.       if (io_form_output == BINARY) then
    1398. 

  1398.          call ext_int_put_dom_ti_real(handle, trim(var_name), &
    1399. 

  1399.                                          var_value, &
    1400. 

  1400.                                          1, istatus)
    1401. 

  1401.       end if
    1402. 

  1402. #endif
    1403. 

  1403. #ifdef IO_NETCDF
    1404. 

  1404.       if (io_form_output == NETCDF) then
    1405. 

  1405.          call ext_ncd_put_dom_ti_real(handle, trim(var_name), &
    1406. 

  1406.                                          var_value, &
    1407. 

  1407.                                          1, istatus)
    1408. 

  1408.       end if
    1409. 

  1409. #endif
    1410. 

  1410. #ifdef IO_GRIB1
    1411. 

  1411.       if (io_form_output == GRIB1) then
    1412. 

  1412.          call ext_gr1_put_dom_ti_real(handle, trim(var_name), &
    1413. 

  1413.                                          var_value, &
    1414. 

  1414.                                          1, istatus)
    1415. 

  1415.       end if
    1416. 

  1416. #endif
    1417. 

  1417. 

  1418.       call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
    1419. 

  1419. 

  1420.    end subroutine ext_put_dom_ti_real_scalar
    1421. 

  1421. 

  1422. 

  1423.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1424. 

  1424.    ! Name: ext_put_dom_ti_real
    1425. 

  1425.    !
    1426. 

  1426.    ! Purpose: Write a domain time-independent real attribute to output. 
    1427. 

  1427.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1428. 

  1428.    subroutine ext_put_dom_ti_real_vector(var_name, var_value, n)
    1429. 

  1429. 

  1430.       implicit none
    1431. 

  1431. 

  1432.       ! Arguments
    1433. 

  1433.       integer, intent(in) :: n
    1434. 

  1434.       real, dimension(n), intent(in) :: var_value
    1435. 

  1435.       character (len=*), intent(in) :: var_name
    1436. 

  1436. 

  1437.       ! Local variables
    1438. 

  1438.       integer :: istatus
    1439. 

  1439. 

  1440. #ifdef IO_BINARY
    1441. 

  1441.       if (io_form_output == BINARY) then
    1442. 

  1442.          call ext_int_put_dom_ti_real(handle, trim(var_name), &
    1443. 

  1443.                                          var_value, &
    1444. 

  1444.                                          n, istatus)
    1445. 

  1445.       end if
    1446. 

  1446. #endif
    1447. 

  1447. #ifdef IO_NETCDF
    1448. 

  1448.       if (io_form_output == NETCDF) then
    1449. 

  1449.          call ext_ncd_put_dom_ti_real(handle, trim(var_name), &
    1450. 

  1450.                                          var_value, &
    1451. 

  1451.                                          n, istatus)
    1452. 

  1452.       end if
    1453. 

  1453. #endif
    1454. 

  1454. #ifdef IO_GRIB1
    1455. 

  1455.       if (io_form_output == GRIB1) then
    1456. 

  1456.          call ext_gr1_put_dom_ti_real(handle, trim(var_name), &
    1457. 

  1457.                                          var_value, &
    1458. 

  1458.                                          n, istatus)
    1459. 

  1459.       end if
    1460. 

  1460. #endif
    1461. 

  1461. 

  1462.       call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
    1463. 

  1463. 

  1464.    end subroutine ext_put_dom_ti_real_vector
    1465. 

  1465. 

  1466. 

  1467.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1468. 

  1468.    ! Name: ext_put_dom_ti_char
    1469. 

  1469.    !
    1470. 

  1470.    ! Purpose: Write a domain time-independent character attribute to output. 
    1471. 

  1471.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1472. 

  1472.    subroutine ext_put_dom_ti_char(var_name, var_value)
    1473. 

  1473. 

  1474.       implicit none
    1475. 

  1475. 

  1476.       ! Arguments
    1477. 

  1477.       character (len=*), intent(in) :: var_name, var_value
    1478. 

  1478. 

  1479.       ! Local variables
    1480. 

  1480.       integer :: istatus
    1481. 

  1481. 

  1482. #ifdef IO_BINARY
    1483. 

  1483.       if (io_form_output == BINARY) then
    1484. 

  1484.          call ext_int_put_dom_ti_char(handle, trim(var_name), &
    1485. 

  1485.                                          trim(var_value), &
    1486. 

  1486.                                          istatus)
    1487. 

  1487.       end if
    1488. 

  1488. #endif
    1489. 

  1489. #ifdef IO_NETCDF
    1490. 

  1490.       if (io_form_output == NETCDF) then
    1491. 

  1491.          call ext_ncd_put_dom_ti_char(handle, trim(var_name), &
    1492. 

  1492.                                          trim(var_value), &
    1493. 

  1493.                                          istatus)
    1494. 

  1494.       end if
    1495. 

  1495. #endif
    1496. 

  1496. #ifdef IO_GRIB1
    1497. 

  1497.       if (io_form_output == GRIB1) then
    1498. 

  1498.          call ext_gr1_put_dom_ti_char(handle, trim(var_name), &
    1499. 

  1499.                                          trim(var_value), &
    1500. 

  1500.                                          istatus)
    1501. 

  1501.       end if
    1502. 

  1502. #endif
    1503. 

  1503. 

  1504.       call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
    1505. 

  1505. 

  1506.    end subroutine ext_put_dom_ti_char
    1507. 

  1507.                                    
    1508. 

  1508.  
    1509. 

  1509.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1510. 

  1510.    ! Name: output_close
    1511. 

  1511.    !
    1512. 

  1512.    ! Purpose: Finalizes all output. This may include closing windows, calling I/O
    1513. 

  1513.    !    API termination routines, or closing files.
    1514. 

  1514.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    1515. 

  1515.    subroutine output_close()
    1516. 

  1516.   
    1517. 

  1517.       implicit none
    1518. 

  1518.   
    1519. 

  1519.       ! Local variables
    1520. 

  1520.       integer :: istatus
    1521. 

  1521.   
    1522. 

  1522.       if (my_proc_id == IO_NODE .or. do_tiled_output) then
    1523. 

  1523.   
    1524. 

  1524.          istatus = 0
    1525. 

  1525. #ifdef IO_BINARY
    1526. 

  1526.          if (io_form_output == BINARY) call ext_int_ioclose(handle, istatus)
    1527. 

  1527. #endif
    1528. 

  1528. #ifdef IO_NETCDF
    1529. 

  1529.          if (io_form_output == NETCDF) call ext_ncd_ioclose(handle, istatus)
    1530. 

  1530. #endif
    1531. 

  1531. #ifdef IO_GRIB1
    1532. 

  1532.          if (io_form_output == GRIB1) call ext_gr1_ioclose(handle, istatus)
    1533. 

  1533. #endif
    1534. 

  1534.          call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioclose')
    1535. 

  1535.    
    1536. 

  1536.          istatus = 0
    1537. 

  1537. #ifdef IO_BINARY
    1538. 

  1538.          if (io_form_output == BINARY) call ext_int_ioexit(istatus)
    1539. 

  1539. #endif
    1540. 

  1540. #ifdef IO_NETCDF
    1541. 

  1541.          if (io_form_output == NETCDF) call ext_ncd_ioexit(istatus)
    1542. 

  1542. #endif
    1543. 

  1543. #ifdef IO_GRIB1
    1544. 

  1544.          if (io_form_output == GRIB1) call ext_gr1_ioexit(istatus)
    1545. 

  1545. #endif
    1546. 

  1546.          call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioexit')
    1547. 

  1547.   
    1548. 

  1548.       end if
    1549. 

  1549.   
    1550. 

  1550.       if (associated(fields)) deallocate(fields)
    1551. 

  1551.  
    1552. 

  1552.    end subroutine output_close
    1553. 

  1553.  
    1554. 

  1554. end module output_module
    1555. 

  1555.