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

/WPS/geogrid/util/plotgrid/src/input_module.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 819 lines | 451 code | 123 blank | 245 comment | 142 complexity | 47b64d062de08f593910f1ef487bf256 MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. module input_module
    2. 

  2. 

  3.    use gridinfo_module
    4. 

  4.    use misc_definitions_module
    5. 

  5.    use module_debug
    6. 

  6. #ifdef IO_BINARY
    7. 

  7.    use module_internal_header_util
    8. 

  8. #endif
    9. 

  9.    use parallel_module
    10. 

  10.    use queue_module
    11. 

  11.  
    12. 

  12.    type (queue) :: unit_desc
    13. 

  13.  
    14. 

  14.    ! WRF I/O API related variables
    15. 

  15.    integer :: handle
    16. 

  16.  
    17. 

  17.    integer :: num_calls
    18. 

  18.  
    19. 

  19.    character (len=1) :: internal_gridtype
    20. 

  20.  
    21. 

  21.    contains
    22. 

  22.  
    23. 

  23.  
    24. 

  24.    subroutine input_init(nest_number, istatus)
    25. 

  25.  
    26. 

  26.       implicit none
    27. 

  27.   
    28. 

  28.       ! Arguments
    29. 

  29.       integer, intent(in) :: nest_number
    30. 

  30.       integer, intent(out) :: istatus
    31. 

  31.   
    32. 

  32. #include "wrf_io_flags.h"
    33. 

  33. #include "wrf_status_codes.h"
    34. 

  34.   
    35. 

  35.       ! Local variables
    36. 

  36.       integer :: i
    37. 

  37.       integer :: comm_1, comm_2
    38. 

  38.       character (len=MAX_FILENAME_LEN) :: input_fname
    39. 

  39.   
    40. 

  40.       istatus = 0
    41. 

  41.   
    42. 

  42.       if (my_proc_id == IO_NODE .or. do_tiled_input) then
    43. 

  43.   
    44. 

  44. #ifdef IO_BINARY
    45. 

  45.          if (io_form_input == BINARY) call ext_int_ioinit('sysdep info', istatus)
    46. 

  46. #endif
    47. 

  47. #ifdef IO_NETCDF
    48. 

  48.          if (io_form_input == NETCDF) call ext_ncd_ioinit('sysdep info', istatus)
    49. 

  49. #endif
    50. 

  50. #ifdef IO_GRIB1
    51. 

  51.          if (io_form_input == GRIB1) call ext_gr1_ioinit('sysdep info', istatus)
    52. 

  52. #endif
    53. 

  53.          call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_ioinit')
    54. 

  54.      
    55. 

  55.          comm_1 = 1
    56. 

  56.          comm_2 = 1
    57. 

  57.          input_fname = ' '
    58. 

  58.          if (gridtype == 'C') then
    59. 

  59. #ifdef IO_BINARY
    60. 

  60.             if (io_form_input == BINARY) input_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .int'
    61. 

  61. #endif
    62. 

  62. #ifdef IO_NETCDF
    63. 

  63.             if (io_form_input == NETCDF) input_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .nc'
    64. 

  64. #endif
    65. 

  65. #ifdef IO_GRIB1
    66. 

  66.             if (io_form_input == GRIB1) input_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .grib'
    67. 

  67. #endif
    68. 

  68.             i = len_trim(opt_output_from_geogrid_path)
    69. 

  69.             write(input_fname(i+9:i+10),'(i2.2)') nest_number
    70. 

  70.          else if (gridtype == 'E') then
    71. 

  71. #ifdef IO_BINARY
    72. 

  72.             if (io_form_input == BINARY) input_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .int'
    73. 

  73. #endif
    74. 

  74. #ifdef IO_NETCDF
    75. 

  75.             if (io_form_input == NETCDF) input_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .nc'
    76. 

  76. #endif
    77. 

  77. #ifdef IO_GRIB1
    78. 

  78.             if (io_form_input == GRIB1) input_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .grib'
    79. 

  79. #endif
    80. 

  80.             i = len_trim(opt_output_from_geogrid_path)
    81. 

  81.             write(input_fname(i+10:i+11),'(i2.2)') nest_number
    82. 

  82.          end if
    83. 

  83. 

  84.          if (nprocs > 1 .and. do_tiled_input) then
    85. 

  85.             write(input_fname(len_trim(input_fname)+1:len_trim(input_fname)+5), '(a1,i4.4)') &
    86. 

  86.                             '_', my_proc_id
    87. 

  87.          end if
    88. 

  88.      
    89. 

  89.          istatus = 0
    90. 

  90. #ifdef IO_BINARY
    91. 

  91.          if (io_form_input == BINARY) &
    92. 

  92.             call ext_int_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
    93. 

  93. #endif
    94. 

  94. #ifdef IO_NETCDF
    95. 

  95.          if (io_form_input == NETCDF) &
    96. 

  96.             call ext_ncd_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
    97. 

  97. #endif
    98. 

  98. #ifdef IO_GRIB1
    99. 

  99.          if (io_form_input == GRIB1) &
    100. 

  100.             call ext_gr1_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
    101. 

  101. #endif
    102. 

  102.          call mprintf((istatus /= 0),ERROR,'Couldn''t open file %s for input.',s1=input_fname)
    103. 

  103.      
    104. 

  104.          call q_init(unit_desc)
    105. 

  105.   
    106. 

  106.       end if ! (my_proc_id == IO_NODE .or. do_tiled_input)
    107. 

  107.   
    108. 

  108.       num_calls = 0
    109. 

  109.  
    110. 

  110.    end subroutine input_init
    111. 

  111.  
    112. 

  112.  
    113. 

  113.    subroutine read_next_field(start_patch_i, end_patch_i, &
    114. 

  114.                               start_patch_j, end_patch_j, &
    115. 

  115.                               start_patch_k, end_patch_k, &
    116. 

  116.                               cname, cunits, cdesc, memorder, stagger, &
    117. 

  117.                               dimnames, is_subgrid, real_array, istatus)
    118. 

  118.  
    119. 

  119.       implicit none
    120. 

  120.   
    121. 

  121.       ! Arguments
    122. 

  122.       integer, intent(out) :: start_patch_i, end_patch_i, &
    123. 

  123.                               start_patch_j, end_patch_j, &
    124. 

  124.                               start_patch_k, end_patch_k
    125. 

  125.       real, pointer, dimension(:,:,:) :: real_array
    126. 

  126.       character (len=*), intent(out) :: cname, memorder, stagger, cunits, cdesc
    127. 

  127.       character (len=128), dimension(3), intent(inout) :: dimnames
    128. 

  128.       logical, intent(out) :: is_subgrid
    129. 

  129.       integer, intent(inout) :: istatus
    130. 

  130.   
    131. 

  131. #include "wrf_io_flags.h"
    132. 

  132. #include "wrf_status_codes.h"
    133. 

  133.   
    134. 

  134.       ! Local variables
    135. 

  135.       integer :: ndim, wrftype
    136. 

  136.       integer :: sm1, em1, sm2, em2, sm3, em3, sp1, ep1, sp2, ep2, sp3, ep3
    137. 

  137.       integer, dimension(3) :: domain_start, domain_end, temp
    138. 

  138.       real, pointer, dimension(:,:,:) :: real_domain
    139. 

  139.       character (len=20) :: datestr
    140. 

  140.       type (q_data) :: qd
    141. 

  141.       integer :: sr_x, sr_y
    142. 

  142.   
    143. 

  143.       if (my_proc_id == IO_NODE .or. do_tiled_input) then
    144. 

  144.   
    145. 

  145.          if (num_calls == 0) then
    146. 

  146. #ifdef IO_BINARY
    147. 

  147.             if (io_form_input == BINARY) call ext_int_get_next_time(handle, datestr, istatus)
    148. 

  148. #endif
    149. 

  149. #ifdef IO_NETCDF
    150. 

  150.             if (io_form_input == NETCDF) call ext_ncd_get_next_time(handle, datestr, istatus)
    151. 

  151. #endif
    152. 

  152. #ifdef IO_GRIB1
    153. 

  153.             if (io_form_input == GRIB1) call ext_gr1_get_next_time(handle, datestr, istatus)
    154. 

  154. #endif
    155. 

  155.          end if
    156. 

  156.      
    157. 

  157.          num_calls = num_calls + 1
    158. 

  158.    
    159. 

  159. #ifdef IO_BINARY
    160. 

  160.          if (io_form_input == BINARY) call ext_int_get_next_var(handle, cname, istatus) 
    161. 

  161. #endif
    162. 

  162. #ifdef IO_NETCDF
    163. 

  163.          if (io_form_input == NETCDF) call ext_ncd_get_next_var(handle, cname, istatus) 
    164. 

  164. #endif
    165. 

  165. #ifdef IO_GRIB1
    166. 

  166.          if (io_form_input == GRIB1) call ext_gr1_get_next_var(handle, cname, istatus) 
    167. 

  167. #endif
    168. 

  168.       end if
    169. 

  169.   
    170. 

  170.       if (nprocs > 1 .and. .not. do_tiled_input) call parallel_bcast_int(istatus)
    171. 

  171.       if (istatus /= 0) return
    172. 

  172.   
    173. 

  173.       if (my_proc_id == IO_NODE .or. do_tiled_input) then
    174. 

  174.   
    175. 

  175.          istatus = 0
    176. 

  176. #ifdef IO_BINARY
    177. 

  177.          if (io_form_input == BINARY) then
    178. 

  178.             call ext_int_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
    179. 

  179.             call ext_int_get_var_ti_integer(handle, 'subgrid', &
    180. 

  180.                                             trim(cname), temp(1), 1, temp(3), istatus)
    181. 

  181.          end if
    182. 

  182. #endif
    183. 

  183. #ifdef IO_NETCDF
    184. 

  184.          if (io_form_input == NETCDF) then
    185. 

  185.             call ext_ncd_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
    186. 

  186.             call ext_ncd_get_var_ti_integer(handle, 'subgrid', &
    187. 

  187.                                             trim(cname), temp(1), 1, temp(3), istatus)
    188. 

  188.          end if
    189. 

  189. #endif
    190. 

  190. #ifdef IO_GRIB1
    191. 

  191.          if (io_form_input == GRIB1) then
    192. 

  192.             call ext_gr1_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
    193. 

  193.             call ext_gr1_get_var_ti_integer(handle, 'subgrid', &
    194. 

  194.                                             trim(cname), temp(1), 1, temp(3), istatus)
    195. 

  195.          end if
    196. 

  196. #endif
    197. 

  197. 

  198.          call ext_get_dom_ti_integer_scalar('sr_x', sr_x)
    199. 

  199.          call ext_get_dom_ti_integer_scalar('sr_y', sr_y)
    200. 

  200. 

  201.          if (temp(1) .eq. 1) then
    202. 

  202.            is_subgrid=.true.
    203. 

  203.          else
    204. 

  204.            is_subgrid=.false.
    205. 

  205.          end if
    206. 

  206.      
    207. 

  207.          call mprintf((istatus /= 0),ERROR,'In read_next_field(), problems with ext_pkg_get_var_info()')
    208. 

  208. 

  209.          start_patch_i = domain_start(1) 
    210. 

  210.          start_patch_j = domain_start(2) 
    211. 

  211.          end_patch_i = domain_end(1)
    212. 

  212.          end_patch_j = domain_end(2)
    213. 

  213.          if (ndim == 3) then
    214. 

  214.             start_patch_k = domain_start(3) 
    215. 

  215.             end_patch_k = domain_end(3) 
    216. 

  216.          else
    217. 

  217.             domain_start(3) = 1
    218. 

  218.             domain_end(3) = 1
    219. 

  219.             start_patch_k = 1
    220. 

  220.             end_patch_k = 1
    221. 

  221.          end if
    222. 

  222.      
    223. 

  223.          nullify(real_domain)
    224. 

  224.      
    225. 

  225.          allocate(real_domain(start_patch_i:end_patch_i, start_patch_j:end_patch_j, start_patch_k:end_patch_k))
    226. 

  226. #ifdef IO_BINARY
    227. 

  227.          if (io_form_input == BINARY) then
    228. 

  228.             call ext_int_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, WRF_REAL, &
    229. 

  229.                           1, 1, 0, memorder, stagger, &
    230. 

  230.                           dimnames, domain_start, domain_end, domain_start, domain_end, &
    231. 

  231.                           domain_start, domain_end, istatus)
    232. 

  232.          end if
    233. 

  233. #endif
    234. 

  234. #ifdef IO_NETCDF
    235. 

  235.          if (io_form_input == NETCDF) then
    236. 

  236.             call ext_ncd_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, WRF_REAL, &
    237. 

  237.                           1, 1, 0, memorder, stagger, &
    238. 

  238.                           dimnames, domain_start, domain_end, domain_start, domain_end, &
    239. 

  239.                           domain_start, domain_end, istatus)
    240. 

  240.          end if
    241. 

  241. #endif
    242. 

  242. #ifdef IO_GRIB1
    243. 

  243.          if (io_form_input == GRIB1) then
    244. 

  244.             call ext_gr1_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, WRF_REAL, &
    245. 

  245.                           1, 1, 0, memorder, stagger, &
    246. 

  246.                           dimnames, domain_start, domain_end, domain_start, domain_end, &
    247. 

  247.                           domain_start, domain_end, istatus)
    248. 

  248.          end if
    249. 

  249. #endif
    250. 

  250.      
    251. 

  251.          call mprintf((istatus /= 0),ERROR,'In read_next_field(), got error code %i.', i1=istatus)
    252. 

  252. 

  253.          if (io_form_input == BINARY) then
    254. 

  254.             qd = q_remove(unit_desc)
    255. 

  255.             cunits = qd%units
    256. 

  256.             cdesc = qd%description
    257. 

  257.             stagger = qd%stagger
    258. 

  258.          else
    259. 

  259.             cunits = ' '
    260. 

  260.             cdesc = ' '
    261. 

  261.             stagger = ' '
    262. 

  262.         
    263. 

  263. #ifdef IO_NETCDF
    264. 

  264.             if (io_form_input == NETCDF) then
    265. 

  265.                call ext_ncd_get_var_ti_char(handle, 'units', cname, cunits, istatus)
    266. 

  266.                call ext_ncd_get_var_ti_char(handle, 'description', cname, cdesc, istatus)
    267. 

  267.                call ext_ncd_get_var_ti_char(handle, 'stagger', cname, stagger, istatus)
    268. 

  268.             end if
    269. 

  269. #endif
    270. 

  270. #ifdef IO_GRIB1
    271. 

  271.             if (io_form_input == GRIB1) then
    272. 

  272.                call ext_gr1_get_var_ti_char(handle, 'units', cname, cunits, istatus)
    273. 

  273.                call ext_gr1_get_var_ti_char(handle, 'description', cname, cdesc, istatus)
    274. 

  274.                call ext_gr1_get_var_ti_char(handle, 'stagger', cname, stagger, istatus)
    275. 

  275.             end if
    276. 

  276. #endif
    277. 

  277.          end if
    278. 

  278.   
    279. 

  279.       end if ! (my_proc_id == IO_NODE .or. do_tiled_input)
    280. 

  280. 

  281.       if (nprocs > 1 .and. .not. do_tiled_input) then
    282. 

  282.          call parallel_bcast_char(cname, len(cname))
    283. 

  283.          call parallel_bcast_char(cunits, len(cunits))
    284. 

  284.          call parallel_bcast_char(cdesc, len(cdesc))
    285. 

  285.          call parallel_bcast_char(memorder, len(memorder))
    286. 

  286.          call parallel_bcast_char(stagger, len(stagger))
    287. 

  287.          call parallel_bcast_char(dimnames(1), 128)
    288. 

  288.          call parallel_bcast_char(dimnames(2), 128)
    289. 

  289.          call parallel_bcast_char(dimnames(3), 128)
    290. 

  290.          call parallel_bcast_int(domain_start(3))
    291. 

  291.          call parallel_bcast_int(domain_end(3))
    292. 

  292.          call parallel_bcast_logical(is_subgrid)
    293. 

  293.    
    294. 

  294.          sp1 = my_minx
    295. 

  295.          ep1 = my_maxx - 1
    296. 

  296.          sp2 = my_miny
    297. 

  297.          ep2 = my_maxy - 1
    298. 

  298.          sp3 = domain_start(3)
    299. 

  299.          ep3 = domain_end(3)
    300. 

  300.    
    301. 

  301.          if (internal_gridtype == 'C') then
    302. 

  302.             if (my_x /= nproc_x - 1 .or. stagger == 'U' .or. is_subgrid) then
    303. 

  303.                ep1 = ep1 + 1
    304. 

  304.             end if
    305. 

  305.             if (my_y /= nproc_y - 1 .or. stagger == 'V' .or. is_subgrid) then
    306. 

  306.                ep2 = ep2 + 1
    307. 

  307.             end if
    308. 

  308.          else if (internal_gridtype == 'E') then
    309. 

  309.             ep1 = ep1 + 1
    310. 

  310.             ep2 = ep2 + 1
    311. 

  311.          end if
    312. 

  312.    
    313. 

  313.          if (sr_x > 1) then
    314. 

  314.             sp1 = (sp1-1)*sr_x+1
    315. 

  315.             ep1 =  ep1   *sr_x
    316. 

  316.          end if
    317. 

  317.          if (sr_y > 1) then
    318. 

  318.             sp2 = (sp2-1)*sr_y+1
    319. 

  319.             ep2 =  ep2   *sr_y
    320. 

  320.          end if
    321. 

  321. 

  322.          sm1 = sp1
    323. 

  323.          em1 = ep1
    324. 

  324.          sm2 = sp2
    325. 

  325.          em2 = ep2
    326. 

  326.          sm3 = sp3
    327. 

  327.          em3 = ep3
    328. 

  328.    
    329. 

  329.          start_patch_i = sp1
    330. 

  330.          end_patch_i   = ep1
    331. 

  331.          start_patch_j = sp2
    332. 

  332.          end_patch_j   = ep2
    333. 

  333.          start_patch_k = sp3
    334. 

  334.          end_patch_k   = ep3
    335. 

  335.    
    336. 

  336.          allocate(real_array(sm1:em1,sm2:em2,sm3:em3))
    337. 

  337.          if (my_proc_id /= IO_NODE) then
    338. 

  338.             allocate(real_domain(1,1,1))
    339. 

  339.             domain_start(1) = 1
    340. 

  340.             domain_start(2) = 1
    341. 

  341.             domain_start(3) = 1
    342. 

  342.             domain_end(1) = 1
    343. 

  343.             domain_end(2) = 1
    344. 

  344.             domain_end(3) = 1
    345. 

  345.          end if
    346. 

  346.          call scatter_whole_field_r(real_array, &
    347. 

  347.                                    sm1, em1, sm2, em2, sm3, em3, &
    348. 

  348.                                    sp1, ep1, sp2, ep2, sp3, ep3, &
    349. 

  349.                                    real_domain, &
    350. 

  350.                                    domain_start(1), domain_end(1), &
    351. 

  351.                                    domain_start(2), domain_end(2), &
    352. 

  352.                                    domain_start(3), domain_end(3))
    353. 

  353.          deallocate(real_domain)
    354. 

  354. 

  355.       else
    356. 

  356.   
    357. 

  357.          real_array => real_domain
    358. 

  358. 

  359.       end if
    360. 

  360.  
    361. 

  361.    end subroutine read_next_field
    362. 

  362.  
    363. 

  363.    subroutine read_global_attrs(title, start_date, grid_type, dyn_opt,                                &
    364. 

  364.                                 west_east_dim, south_north_dim, bottom_top_dim,                       &
    365. 

  365.                                 we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag,             &
    366. 

  366.                                 sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag,             &
    367. 

  367.                                 map_proj, mminlu, num_land_cat, is_water, is_lake, is_ice, is_urban,  &
    368. 

  368.                                 isoilwater, grid_id, parent_id, i_parent_start, j_parent_start,       &
    369. 

  369.                                 i_parent_end, j_parent_end, dx, dy, cen_lat, moad_cen_lat, cen_lon,   &
    370. 

  370.                                 stand_lon, truelat1, truelat2, pole_lat, pole_lon, parent_grid_ratio, &
    371. 

  371.                                 corner_lats, corner_lons, sr_x, sr_y)
    372. 

  372.  
    373. 

  373.       implicit none
    374. 

  374.   
    375. 

  375.       ! Arguments
    376. 

  376.       integer, intent(out) :: dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, map_proj,   &
    377. 

  377.                  is_water, is_lake, we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag,      &
    378. 

  378.                  sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag,                         &
    379. 

  379.                  is_ice, is_urban, isoilwater, grid_id, parent_id, i_parent_start, j_parent_start, &
    380. 

  380.                  i_parent_end, j_parent_end, parent_grid_ratio, sr_x, sr_y, num_land_cat
    381. 

  381.       real, intent(out) :: dx, dy, cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2,  &
    382. 

  382.                  pole_lat, pole_lon
    383. 

  383.       real, dimension(16), intent(out) :: corner_lats, corner_lons
    384. 

  384.       character (len=128), intent(out) :: title, start_date, grid_type, mminlu
    385. 

  385.   
    386. 

  386.       ! Local variables
    387. 

  387.       integer :: istatus, i
    388. 

  388.       real :: wps_version
    389. 

  389.       character (len=128) :: cunits, cdesc, cstagger
    390. 

  390.       type (q_data) :: qd
    391. 

  391.   
    392. 

  392.       if (my_proc_id == IO_NODE .or. do_tiled_input) then
    393. 

  393.   
    394. 

  394. #ifdef IO_BINARY
    395. 

  395.          if (io_form_input == BINARY) then
    396. 

  396.             istatus = 0
    397. 

  397.             do while (istatus == 0) 
    398. 

  398.                cunits = ' '
    399. 

  399.                cdesc = ' '
    400. 

  400.                cstagger = ' '
    401. 

  401.                call ext_int_get_var_ti_char(handle, 'units', 'VAR', cunits, istatus)
    402. 

  402.          
    403. 

  403.                if (istatus == 0) then
    404. 

  404.                   call ext_int_get_var_ti_char(handle, 'description', 'VAR', cdesc, istatus)
    405. 

  405.           
    406. 

  406.                   if (istatus == 0) then
    407. 

  407.                      call ext_int_get_var_ti_char(handle, 'stagger', 'VAR', cstagger, istatus)
    408. 

  408.          
    409. 

  409.                      qd%units = cunits
    410. 

  410.                      qd%description = cdesc
    411. 

  411.                      qd%stagger = cstagger
    412. 

  412.                      call q_insert(unit_desc, qd)
    413. 

  413.         
    414. 

  414.                   end if
    415. 

  415.                end if
    416. 

  416.             end do
    417. 

  417.          end if
    418. 

  418. #endif
    419. 

  419.      
    420. 

  420.          call ext_get_dom_ti_char          ('TITLE', title)
    421. 

  421.          if (index(title,'GEOGRID V3.3') /= 0) then
    422. 

  422.             wps_version = 3.3
    423. 

  423.          else if (index(title,'GEOGRID V3.2.1') /= 0) then
    424. 

  424.             wps_version = 3.21
    425. 

  425.          else if (index(title,'GEOGRID V3.2') /= 0) then
    426. 

  426.             wps_version = 3.2
    427. 

  427.          else if (index(title,'GEOGRID V3.1.1') /= 0) then
    428. 

  428.             wps_version = 3.11
    429. 

  429.          else if (index(title,'GEOGRID V3.1') /= 0) then
    430. 

  430.             wps_version = 3.1
    431. 

  431.          else if (index(title,'GEOGRID V3.0.1') /= 0) then
    432. 

  432.             wps_version = 3.01
    433. 

  433.          else
    434. 

  434.             wps_version = 3.0
    435. 

  435.          end if
    436. 

  436.          call mprintf(.true.,DEBUG,'Reading static data from WPS version %f', f1=wps_version)
    437. 

  437.          call ext_get_dom_ti_char          ('SIMULATION_START_DATE', start_date)
    438. 

  438.          call ext_get_dom_ti_integer_scalar('WEST-EAST_GRID_DIMENSION', west_east_dim)
    439. 

  439.          call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_GRID_DIMENSION', south_north_dim)
    440. 

  440.          call ext_get_dom_ti_integer_scalar('BOTTOM-TOP_GRID_DIMENSION', bottom_top_dim)
    441. 

  441.          call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_START_UNSTAG', we_patch_s)
    442. 

  442.          call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_END_UNSTAG', we_patch_e)
    443. 

  443.          call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_START_STAG', we_patch_s_stag)
    444. 

  444.          call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_END_STAG', we_patch_e_stag)
    445. 

  445.          call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_UNSTAG', sn_patch_s)
    446. 

  446.          call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_UNSTAG', sn_patch_e)
    447. 

  447.          call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_STAG', sn_patch_s_stag)
    448. 

  448.          call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_STAG', sn_patch_e_stag)
    449. 

  449.          call ext_get_dom_ti_char          ('GRIDTYPE', grid_type)
    450. 

  450.          call ext_get_dom_ti_real_scalar   ('DX', dx)
    451. 

  451.          call ext_get_dom_ti_real_scalar   ('DY', dy)
    452. 

  452.          call ext_get_dom_ti_integer_scalar('DYN_OPT', dyn_opt)
    453. 

  453.          call ext_get_dom_ti_real_scalar   ('CEN_LAT', cen_lat)
    454. 

  454.          call ext_get_dom_ti_real_scalar   ('CEN_LON', cen_lon)
    455. 

  455.          call ext_get_dom_ti_real_scalar   ('TRUELAT1', truelat1)
    456. 

  456.          call ext_get_dom_ti_real_scalar   ('TRUELAT2', truelat2)
    457. 

  457.          call ext_get_dom_ti_real_scalar   ('MOAD_CEN_LAT', moad_cen_lat)
    458. 

  458.          call ext_get_dom_ti_real_scalar   ('STAND_LON', stand_lon)
    459. 

  459.          call ext_get_dom_ti_real_scalar   ('POLE_LAT', pole_lat)
    460. 

  460.          call ext_get_dom_ti_real_scalar   ('POLE_LON', pole_lon)
    461. 

  461.          call ext_get_dom_ti_real_vector   ('corner_lats', corner_lats, 16)
    462. 

  462.          call ext_get_dom_ti_real_vector   ('corner_lons', corner_lons, 16)
    463. 

  463.          call ext_get_dom_ti_integer_scalar('MAP_PROJ', map_proj)
    464. 

  464.          call ext_get_dom_ti_char          ('MMINLU', mminlu)
    465. 

  465.          if ( wps_version >= 3.01 ) then
    466. 

  466.             call ext_get_dom_ti_integer_scalar('NUM_LAND_CAT', num_land_cat)
    467. 

  467.          else
    468. 

  468.             num_land_cat = 24
    469. 

  469.          end if
    470. 

  470.          call ext_get_dom_ti_integer_scalar('ISWATER', is_water)
    471. 

  471.          if ( wps_version >= 3.01 ) then
    472. 

  472.             call ext_get_dom_ti_integer_scalar('ISLAKE', is_lake)
    473. 

  473.          else
    474. 

  474.             is_lake = -1
    475. 

  475.          end if
    476. 

  476.          call ext_get_dom_ti_integer_scalar('ISICE', is_ice)
    477. 

  477.          call ext_get_dom_ti_integer_scalar('ISURBAN', is_urban)
    478. 

  478.          call ext_get_dom_ti_integer_scalar('ISOILWATER', isoilwater)
    479. 

  479.          call ext_get_dom_ti_integer_scalar('grid_id', grid_id)
    480. 

  480.          call ext_get_dom_ti_integer_scalar('parent_id', parent_id)
    481. 

  481.          call ext_get_dom_ti_integer_scalar('i_parent_start', i_parent_start)
    482. 

  482.          call ext_get_dom_ti_integer_scalar('j_parent_start', j_parent_start)
    483. 

  483.          call ext_get_dom_ti_integer_scalar('i_parent_end', i_parent_end)
    484. 

  484.          call ext_get_dom_ti_integer_scalar('j_parent_end', j_parent_end)
    485. 

  485.          call ext_get_dom_ti_integer_scalar('parent_grid_ratio', parent_grid_ratio)
    486. 

  486.          call ext_get_dom_ti_integer_scalar('sr_x', sr_x)
    487. 

  487.          call ext_get_dom_ti_integer_scalar('sr_y', sr_y)
    488. 

  488.    
    489. 

  489.       end if
    490. 

  490. 

  491.   
    492. 

  492.       if (nprocs > 1 .and. .not. do_tiled_input) then
    493. 

  493.   
    494. 

  494.          call parallel_bcast_char(title, len(title))
    495. 

  495.          call parallel_bcast_char(start_date, len(start_date))
    496. 

  496.          call parallel_bcast_char(grid_type, len(grid_type))
    497. 

  497.          call parallel_bcast_int(west_east_dim)
    498. 

  498.          call parallel_bcast_int(south_north_dim)
    499. 

  499.          call parallel_bcast_int(bottom_top_dim)
    500. 

  500.          call parallel_bcast_int(we_patch_s)
    501. 

  501.          call parallel_bcast_int(we_patch_e)
    502. 

  502.          call parallel_bcast_int(we_patch_s_stag)
    503. 

  503.          call parallel_bcast_int(we_patch_e_stag)
    504. 

  504.          call parallel_bcast_int(sn_patch_s)
    505. 

  505.          call parallel_bcast_int(sn_patch_e)
    506. 

  506.          call parallel_bcast_int(sn_patch_s_stag)
    507. 

  507.          call parallel_bcast_int(sn_patch_e_stag)
    508. 

  508.          call parallel_bcast_int(sr_x)
    509. 

  509.          call parallel_bcast_int(sr_y)
    510. 

  510. 

  511.          ! Must figure out patch dimensions from info in parallel module
    512. 

  512. !         we_patch_s      = my_minx
    513. 

  513. !         we_patch_s_stag = my_minx
    514. 

  514. !         we_patch_e      = my_maxx - 1
    515. 

  515. !         sn_patch_s      = my_miny
    516. 

  516. !         sn_patch_s_stag = my_miny
    517. 

  517. !         sn_patch_e      = my_maxy - 1
    518. 

  518. !
    519. 

  519. !         if (trim(grid_type) == 'C') then
    520. 

  520. !            if (my_x /= nproc_x - 1) then
    521. 

  521. !               we_patch_e_stag = we_patch_e + 1
    522. 

  522. !            end if
    523. 

  523. !            if (my_y /= nproc_y - 1) then
    524. 

  524. !               sn_patch_e_stag = sn_patch_e + 1
    525. 

  525. !            end if
    526. 

  526. !         else if (trim(grid_type) == 'E') then
    527. 

  527. !            we_patch_e = we_patch_e + 1
    528. 

  528. !            sn_patch_e = sn_patch_e + 1
    529. 

  529. !            we_patch_e_stag = we_patch_e
    530. 

  530. !            sn_patch_e_stag = sn_patch_e
    531. 

  531. !         end if
    532. 

  532. 

  533.          call parallel_bcast_real(dx)
    534. 

  534.          call parallel_bcast_real(dy)
    535. 

  535.          call parallel_bcast_int(dyn_opt)
    536. 

  536.          call parallel_bcast_real(cen_lat)
    537. 

  537.          call parallel_bcast_real(cen_lon)
    538. 

  538.          call parallel_bcast_real(truelat1)
    539. 

  539.          call parallel_bcast_real(truelat2)
    540. 

  540.          call parallel_bcast_real(pole_lat)
    541. 

  541.          call parallel_bcast_real(pole_lon)
    542. 

  542.          call parallel_bcast_real(moad_cen_lat)
    543. 

  543.          call parallel_bcast_real(stand_lon)
    544. 

  544.          do i=1,16
    545. 

  545.             call parallel_bcast_real(corner_lats(i))
    546. 

  546.             call parallel_bcast_real(corner_lons(i))
    547. 

  547.          end do
    548. 

  548.          call parallel_bcast_int(map_proj)
    549. 

  549.          call parallel_bcast_char(mminlu, len(mminlu))
    550. 

  550.          call parallel_bcast_int(is_water)
    551. 

  551.          call parallel_bcast_int(is_lake)
    552. 

  552.          call parallel_bcast_int(is_ice)
    553. 

  553.          call parallel_bcast_int(is_urban)
    554. 

  554.          call parallel_bcast_int(isoilwater)
    555. 

  555.          call parallel_bcast_int(grid_id)
    556. 

  556.          call parallel_bcast_int(parent_id)
    557. 

  557.          call parallel_bcast_int(i_parent_start)
    558. 

  558.          call parallel_bcast_int(i_parent_end)
    559. 

  559.          call parallel_bcast_int(j_parent_start)
    560. 

  560.          call parallel_bcast_int(j_parent_end)
    561. 

  561.          call parallel_bcast_int(parent_grid_ratio)
    562. 

  562.       end if
    563. 

  563.   
    564. 

  564.       internal_gridtype = grid_type
    565. 

  565.  
    566. 

  566.    end subroutine read_global_attrs
    567. 

  567. 

  568. 

  569.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    570. 

  570.    ! Name: ext_get_dom_ti_integer
    571. 

  571.    !
    572. 

  572.    ! Purpose: Read a domain time-independent integer attribute from input.
    573. 

  573.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    574. 

  574.    subroutine ext_get_dom_ti_integer_scalar(var_name, var_value)
    575. 

  575. 

  576.       implicit none
    577. 

  577. 

  578.       ! Arguments
    579. 

  579.       integer, intent(out) :: var_value
    580. 

  580.       character (len=*), intent(in) :: var_name
    581. 

  581. 

  582.       ! Local variables
    583. 

  583.       integer :: istatus, outcount
    584. 

  584. 

  585. #ifdef IO_BINARY
    586. 

  586.       if (io_form_input == BINARY) then
    587. 

  587.          call ext_int_get_dom_ti_integer(handle, trim(var_name), &
    588. 

  588.                                          var_value, &
    589. 

  589.                                          1, outcount, istatus)
    590. 

  590.       end if
    591. 

  591. #endif
    592. 

  592. #ifdef IO_NETCDF
    593. 

  593.       if (io_form_input == NETCDF) then
    594. 

  594.          call ext_ncd_get_dom_ti_integer(handle, trim(var_name), &
    595. 

  595.                                          var_value, &
    596. 

  596.                                          1, outcount, istatus)
    597. 

  597.       end if
    598. 

  598. #endif
    599. 

  599. #ifdef IO_GRIB1
    600. 

  600.       if (io_form_input == GRIB1) then
    601. 

  601.          call ext_gr1_get_dom_ti_integer(handle, trim(var_name), &
    602. 

  602.                                          var_value, &
    603. 

  603.                                          1, outcount, istatus)
    604. 

  604.       end if
    605. 

  605. #endif
    606. 

  606. 

  607.       call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.')
    608. 

  608. 

  609.    end subroutine ext_get_dom_ti_integer_scalar
    610. 

  610. 

  611. 

  612.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    613. 

  613.    ! Name: ext_get_dom_ti_integer
    614. 

  614.    !
    615. 

  615.    ! Purpose: Read a domain time-independent integer attribute from input.
    616. 

  616.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    617. 

  617.    subroutine ext_get_dom_ti_integer_vector(var_name, var_value, n)
    618. 

  618. 

  619.       implicit none
    620. 

  620. 

  621.       ! Arguments
    622. 

  622.       integer, intent(in) :: n
    623. 

  623.       integer, dimension(n), intent(out) :: var_value
    624. 

  624.       character (len=*), intent(in) :: var_name
    625. 

  625. 

  626.       ! Local variables
    627. 

  627.       integer :: istatus, outcount
    628. 

  628. 

  629. #ifdef IO_BINARY
    630. 

  630.       if (io_form_input == BINARY) then
    631. 

  631.          call ext_int_get_dom_ti_integer(handle, trim(var_name), &
    632. 

  632.                                          var_value, &
    633. 

  633.                                          n, outcount, istatus)
    634. 

  634.       end if
    635. 

  635. #endif
    636. 

  636. #ifdef IO_NETCDF
    637. 

  637.       if (io_form_input == NETCDF) then
    638. 

  638.          call ext_ncd_get_dom_ti_integer(handle, trim(var_name), &
    639. 

  639.                                          var_value, &
    640. 

  640.                                          n, outcount, istatus)
    641. 

  641.       end if
    642. 

  642. #endif
    643. 

  643. #ifdef IO_GRIB1
    644. 

  644.       if (io_form_input == GRIB1) then
    645. 

  645.          call ext_gr1_get_dom_ti_integer(handle, trim(var_name), &
    646. 

  646.                                          var_value, &
    647. 

  647.                                          n, outcount, istatus)
    648. 

  648.       end if
    649. 

  649. #endif
    650. 

  650. 

  651.       call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.')
    652. 

  652. 

  653.    end subroutine ext_get_dom_ti_integer_vector
    654. 

  654. 

  655. 

  656.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    657. 

  657.    ! Name: ext_get_dom_ti_real
    658. 

  658.    !
    659. 

  659.    ! Purpose: Read a domain time-independent real attribute from input.
    660. 

  660.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    661. 

  661.    subroutine ext_get_dom_ti_real_scalar(var_name, var_value)
    662. 

  662. 

  663.       implicit none
    664. 

  664. 

  665.       ! Arguments
    666. 

  666.       real, intent(out) :: var_value
    667. 

  667.       character (len=*), intent(in) :: var_name
    668. 

  668. 

  669.       ! Local variables
    670. 

  670.       integer :: istatus, outcount
    671. 

  671. 

  672. #ifdef IO_BINARY
    673. 

  673.       if (io_form_input == BINARY) then
    674. 

  674.          call ext_int_get_dom_ti_real(handle, trim(var_name), &
    675. 

  675.                                          var_value, &
    676. 

  676.                                          1, outcount, istatus)
    677. 

  677.       end if
    678. 

  678. #endif
    679. 

  679. #ifdef IO_NETCDF
    680. 

  680.       if (io_form_input == NETCDF) then
    681. 

  681.          call ext_ncd_get_dom_ti_real(handle, trim(var_name), &
    682. 

  682.                                          var_value, &
    683. 

  683.                                          1, outcount, istatus)
    684. 

  684.       end if
    685. 

  685. #endif
    686. 

  686. #ifdef IO_GRIB1
    687. 

  687.       if (io_form_input == GRIB1) then
    688. 

  688.          call ext_gr1_get_dom_ti_real(handle, trim(var_name), &
    689. 

  689.                                          var_value, &
    690. 

  690.                                          1, outcount, istatus)
    691. 

  691.       end if
    692. 

  692. #endif
    693. 

  693. 

  694.       call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.')
    695. 

  695. 

  696.    end subroutine ext_get_dom_ti_real_scalar
    697. 

  697. 

  698. 

  699.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    700. 

  700.    ! Name: ext_get_dom_ti_real
    701. 

  701.    !
    702. 

  702.    ! Purpose: Read a domain time-independent real attribute from input.
    703. 

  703.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    704. 

  704.    subroutine ext_get_dom_ti_real_vector(var_name, var_value, n)
    705. 

  705. 

  706.       implicit none
    707. 

  707. 

  708.       ! Arguments
    709. 

  709.       integer, intent(in) :: n
    710. 

  710.       real, dimension(n), intent(out) :: var_value
    711. 

  711.       character (len=*), intent(in) :: var_name
    712. 

  712. 

  713.       ! Local variables
    714. 

  714.       integer :: istatus, outcount
    715. 

  715. 

  716. #ifdef IO_BINARY
    717. 

  717.       if (io_form_input == BINARY) then
    718. 

  718.          call ext_int_get_dom_ti_real(handle, trim(var_name), &
    719. 

  719.                                          var_value, &
    720. 

  720.                                          n, outcount, istatus)
    721. 

  721.       end if
    722. 

  722. #endif
    723. 

  723. #ifdef IO_NETCDF
    724. 

  724.       if (io_form_input == NETCDF) then
    725. 

  725.          call ext_ncd_get_dom_ti_real(handle, trim(var_name), &
    726. 

  726.                                          var_value, &
    727. 

  727.                                          n, outcount, istatus)
    728. 

  728.       end if
    729. 

  729. #endif
    730. 

  730. #ifdef IO_GRIB1
    731. 

  731.       if (io_form_input == GRIB1) then
    732. 

  732.          call ext_gr1_get_dom_ti_real(handle, trim(var_name), &
    733. 

  733.                                          var_value, &
    734. 

  734.                                          n, outcount, istatus)
    735. 

  735.       end if
    736. 

  736. #endif
    737. 

  737. 

  738.       call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.')
    739. 

  739. 

  740.    end subroutine ext_get_dom_ti_real_vector
    741. 

  741. 

  742. 

  743.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    744. 

  744.    ! Name: ext_get_dom_ti_char
    745. 

  745.    !
    746. 

  746.    ! Purpose: Read a domain time-independent character attribute from input.
    747. 

  747.    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    748. 

  748.    subroutine ext_get_dom_ti_char(var_name, var_value)
    749. 

  749. 

  750.       implicit none
    751. 

  751. 

  752.       ! Arguments
    753. 

  753.       character (len=*), intent(in) :: var_name
    754. 

  754.       character (len=128), intent(out) :: var_value
    755. 

  755. 

  756.       ! Local variables
    757. 

  757.       integer :: istatus
    758. 

  758. 

  759. #ifdef IO_BINARY
    760. 

  760.       if (io_form_input == BINARY) then
    761. 

  761.          call ext_int_get_dom_ti_char(handle, trim(var_name), &
    762. 

  762.                                          var_value, &
    763. 

  763.                                          istatus)
    764. 

  764.       end if
    765. 

  765. #endif
    766. 

  766. #ifdef IO_NETCDF
    767. 

  767.       if (io_form_input == NETCDF) then
    768. 

  768.          call ext_ncd_get_dom_ti_char(handle, trim(var_name), &
    769. 

  769.                                          var_value, &
    770. 

  770.                                          istatus)
    771. 

  771.       end if
    772. 

  772. #endif
    773. 

  773. #ifdef IO_GRIB1
    774. 

  774.       if (io_form_input == GRIB1) then
    775. 

  775.          call ext_gr1_get_dom_ti_char(handle, trim(var_name), &
    776. 

  776.                                          var_value, &
    777. 

  777.                                          istatus)
    778. 

  778.       end if
    779. 

  779. #endif
    780. 

  780. 

  781.       call mprintf((istatus /= 0),ERROR,'Error in reading domain time-independent attribute')
    782. 

  782. 

  783.    end subroutine ext_get_dom_ti_char
    784. 

  784. 

  785.  
    786. 

  786.    subroutine input_close()
    787. 

  787.  
    788. 

  788.       implicit none
    789. 

  789.   
    790. 

  790.       ! Local variables
    791. 

  791.       integer :: istatus
    792. 

  792.   
    793. 

  793.       istatus = 0
    794. 

  794.       if (my_proc_id == IO_NODE .or. do_tiled_input) then
    795. 

  795. #ifdef IO_BINARY
    796. 

  796.          if (io_form_input == BINARY) then
    797. 

  797.             call ext_int_ioclose(handle, istatus)
    798. 

  798.             call ext_int_ioexit(istatus)
    799. 

  799.          end if
    800. 

  800. #endif
    801. 

  801. #ifdef IO_NETCDF
    802. 

  802.          if (io_form_input == NETCDF) then
    803. 

  803.             call ext_ncd_ioclose(handle, istatus)
    804. 

  804.             call ext_ncd_ioexit(istatus)
    805. 

  805.          end if
    806. 

  806. #endif
    807. 

  807. #ifdef IO_GRIB1
    808. 

  808.          if (io_form_input == GRIB1) then
    809. 

  809.             call ext_gr1_ioclose(handle, istatus)
    810. 

  810.             call ext_gr1_ioexit(istatus)
    811. 

  811.          end if
    812. 

  812. #endif
    813. 

  813.       end if
    814. 

  814.  
    815. 

  815.       call q_destroy(unit_desc)
    816. 

  816.  
    817. 

  817.    end subroutine input_close
    818. 

  818.  
    819. 

  819. end module input_module
    820. 

  820.