metgrid/src/input_module.F

   1 module input_module
   2
   3    use gridinfo_module
   4    use misc_definitions_module
   5    use module_debug
   6 #ifdef IO_BINARY
   7    use module_internal_header_util
   8 #endif
   9    use parallel_module
  10    use queue_module
  11
  12    type (queue) :: unit_desc
  13
  14    ! WRF I/O API related variables
  15    integer :: handle
  16
  17    integer :: num_calls
  18
  19    character (len=1) :: internal_gridtype
  20
  21    contains
  22
  23
  24    subroutine input_init(nest_number, istatus)
  25
  26       implicit none
  27
  28       ! Arguments
  29       integer, intent(in) :: nest_number
  30       integer, intent(out) :: istatus
  31
  32 #include "wrf_io_flags.h"
  33 #include "wrf_status_codes.h"
  34
  35       ! Local variables
  36       integer :: i
  37       integer :: comm_1, comm_2
  38       character (len=MAX_FILENAME_LEN) :: input_fname
  39
  40       istatus = 0
  41
  42       if (my_proc_id == IO_NODE .or. do_tiled_input) then
  43
  44 #ifdef IO_BINARY
  45          if (io_form_input == BINARY) call ext_int_ioinit('sysdep info', istatus)
  46 #endif
  47 #ifdef IO_NETCDF
  48          if (io_form_input == NETCDF) call ext_ncd_ioinit('sysdep info', istatus)
  49 #endif
  50 #ifdef IO_GRIB1
  51          if (io_form_input == GRIB1) call ext_gr1_ioinit('sysdep info', istatus)
  52 #endif
  53          call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_ioinit')
  54
  55          comm_1 = 1
  56          comm_2 = 1
  57          input_fname = ' '
  58          if (gridtype == 'C') then
  59 #ifdef IO_BINARY
  60             if (io_form_input == BINARY) input_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .int'
  61 #endif
  62 #ifdef IO_NETCDF
  63             if (io_form_input == NETCDF) input_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .nc'
  64 #endif
  65 #ifdef IO_GRIB1
  66             if (io_form_input == GRIB1) input_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .grib'
  67 #endif
  68             i = len_trim(opt_output_from_geogrid_path)
  69             write(input_fname(i+9:i+10),'(i2.2)') nest_number
  70          else if (gridtype == 'E') then
  71 #ifdef IO_BINARY
  72             if (io_form_input == BINARY) input_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .int'
  73 #endif
  74 #ifdef IO_NETCDF
  75             if (io_form_input == NETCDF) input_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .nc'
  76 #endif
  77 #ifdef IO_GRIB1
  78             if (io_form_input == GRIB1) input_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .grib'
  79 #endif
  80             i = len_trim(opt_output_from_geogrid_path)
  81             write(input_fname(i+10:i+11),'(i2.2)') nest_number
  82          end if
  83
  84          if (nprocs > 1 .and. do_tiled_input) then
  85             write(input_fname(len_trim(input_fname)+1:len_trim(input_fname)+5), '(a1,i4.4)') &
  86                             '_', my_proc_id
  87          end if
  88
  89          istatus = 0
  90 #ifdef IO_BINARY
  91          if (io_form_input == BINARY) &
  92             call ext_int_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
  93 #endif
  94 #ifdef IO_NETCDF
  95          if (io_form_input == NETCDF) &
  96             call ext_ncd_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
  97 #endif
  98 #ifdef IO_GRIB1
  99          if (io_form_input == GRIB1) &
 100             call ext_gr1_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
 101 #endif
 102          call mprintf((istatus /= 0),ERROR,'Couldn''t open file %s for input.',s1=input_fname)
 103
 104          call q_init(unit_desc)
 105
 106       end if ! (my_proc_id == IO_NODE .or. do_tiled_input)
 107
 108       num_calls = 0
 109
 110    end subroutine input_init
 111
 112
 113    subroutine read_next_field(start_patch_i, end_patch_i, &
 114                               start_patch_j, end_patch_j, &
 115                               start_patch_k, end_patch_k, &
 116                               cname, cunits, cdesc, memorder, stagger, &
 117                               dimnames, sr_x, sr_y, real_array, istatus)
 118
 119       implicit none
 120
 121       ! Arguments
 122       integer, intent(out) :: start_patch_i, end_patch_i, &
 123                               start_patch_j, end_patch_j, &
 124                               start_patch_k, end_patch_k, &
 125                               sr_x, sr_y
 126       real, pointer, dimension(:,:,:) :: real_array
 127       character (len=*), intent(out) :: cname, memorder, stagger, cunits, cdesc
 128       character (len=128), dimension(3), intent(inout) :: dimnames
 129       integer, intent(inout) :: istatus
 130
 131 #include "wrf_io_flags.h"
 132 #include "wrf_status_codes.h"
 133
 134       ! Local variables
 135       integer :: ndim, wrftype
 136       integer :: sm1, em1, sm2, em2, sm3, em3, sp1, ep1, sp2, ep2, sp3, ep3
 137       integer, dimension(3) :: domain_start, domain_end, temp
 138       real, pointer, dimension(:,:,:) :: real_domain
 139       character (len=20) :: datestr
 140       type (q_data) :: qd
 141
 142       if (my_proc_id == IO_NODE .or. do_tiled_input) then
 143
 144          if (num_calls == 0) then
 145 #ifdef IO_BINARY
 146             if (io_form_input == BINARY) call ext_int_get_next_time(handle, datestr, istatus)
 147 #endif
 148 #ifdef IO_NETCDF
 149             if (io_form_input == NETCDF) call ext_ncd_get_next_time(handle, datestr, istatus)
 150 #endif
 151 #ifdef IO_GRIB1
 152             if (io_form_input == GRIB1) call ext_gr1_get_next_time(handle, datestr, istatus)
 153 #endif
 154          end if
 155
 156          num_calls = num_calls + 1
 157
 158 #ifdef IO_BINARY
 159          if (io_form_input == BINARY) call ext_int_get_next_var(handle, cname, istatus)
 160 #endif
 161 #ifdef IO_NETCDF
 162          if (io_form_input == NETCDF) call ext_ncd_get_next_var(handle, cname, istatus)
 163 #endif
 164 #ifdef IO_GRIB1
 165          if (io_form_input == GRIB1) call ext_gr1_get_next_var(handle, cname, istatus)
 166 #endif
 167       end if
 168
 169       if (nprocs > 1 .and. .not. do_tiled_input) call parallel_bcast_int(istatus)
 170       if (istatus /= 0) return
 171
 172       if (my_proc_id == IO_NODE .or. do_tiled_input) then
 173
 174          istatus = 0
 175 #ifdef IO_BINARY
 176          if (io_form_input == BINARY) then
 177             call ext_int_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
 178          end if
 179 #endif
 180 #ifdef IO_NETCDF
 181          if (io_form_input == NETCDF) then
 182             call ext_ncd_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
 183             call ext_ncd_get_var_ti_integer(handle, 'sr_x', &
 184                                             trim(cname), temp(1), 1, temp(3), istatus)
 185             call ext_ncd_get_var_ti_integer(handle, 'sr_y', &
 186                                             trim(cname), temp(2), 1, temp(3), istatus)
 187          end if
 188 #endif
 189 #ifdef IO_GRIB1
 190          if (io_form_input == GRIB1) then
 191             call ext_gr1_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
 192             call ext_gr1_get_var_ti_integer(handle, 'sr_x', &
 193                                             trim(cname), temp(1), 1, temp(3), istatus)
 194             call ext_gr1_get_var_ti_integer(handle, 'sr_y', &
 195                                             trim(cname), temp(2), 1, temp(3), istatus)
 196          end if
 197 #endif
 198
 199          call mprintf((istatus /= 0),ERROR,'In read_next_field(), problems with ext_pkg_get_var_info()')
 200
 201          start_patch_i = domain_start(1)
 202          start_patch_j = domain_start(2)
 203          end_patch_i = domain_end(1)
 204          end_patch_j = domain_end(2)
 205          if (ndim == 3) then
 206             start_patch_k = domain_start(3)
 207             end_patch_k = domain_end(3)
 208          else
 209             domain_start(3) = 1
 210             domain_end(3) = 1
 211             start_patch_k = 1
 212             end_patch_k = 1
 213          end if
 214
 215          nullify(real_domain)
 216
 217          allocate(real_domain(start_patch_i:end_patch_i, start_patch_j:end_patch_j, start_patch_k:end_patch_k))
 218 #ifdef IO_BINARY
 219          if (io_form_input == BINARY) then
 220             call ext_int_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, WRF_REAL, &
 221                           1, 1, 0, memorder, stagger, &
 222                           dimnames, domain_start, domain_end, domain_start, domain_end, &
 223                           domain_start, domain_end, istatus)
 224          end if
 225 #endif
 226 #ifdef IO_NETCDF
 227          if (io_form_input == NETCDF) then
 228             call ext_ncd_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, WRF_REAL, &
 229                           1, 1, 0, memorder, stagger, &
 230                           dimnames, domain_start, domain_end, domain_start, domain_end, &
 231                           domain_start, domain_end, istatus)
 232          end if
 233 #endif
 234 #ifdef IO_GRIB1
 235          if (io_form_input == GRIB1) then
 236             call ext_gr1_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, WRF_REAL, &
 237                           1, 1, 0, memorder, stagger, &
 238                           dimnames, domain_start, domain_end, domain_start, domain_end, &
 239                           domain_start, domain_end, istatus)
 240          end if
 241 #endif
 242
 243          call mprintf((istatus /= 0),ERROR,'In read_next_field(), got error code %i.', i1=istatus)
 244
 245          if (io_form_input == BINARY) then
 246             qd = q_remove(unit_desc)
 247             cunits = qd%units
 248             cdesc = qd%description
 249             stagger = qd%stagger
 250             sr_x = qd%sr_x
 251             sr_y = qd%sr_y
 252          else
 253             cunits = ' '
 254             cdesc = ' '
 255             stagger = ' '
 256             sr_x = temp(1)
 257             sr_y = temp(2)
 258
 259 #ifdef IO_NETCDF
 260             if (io_form_input == NETCDF) then
 261                call ext_ncd_get_var_ti_char(handle, 'units', cname, cunits, istatus)
 262                call ext_ncd_get_var_ti_char(handle, 'description', cname, cdesc, istatus)
 263                call ext_ncd_get_var_ti_char(handle, 'stagger', cname, stagger, istatus)
 264             end if
 265 #endif
 266 #ifdef IO_GRIB1
 267             if (io_form_input == GRIB1) then
 268                call ext_gr1_get_var_ti_char(handle, 'units', cname, cunits, istatus)
 269                call ext_gr1_get_var_ti_char(handle, 'description', cname, cdesc, istatus)
 270                call ext_gr1_get_var_ti_char(handle, 'stagger', cname, stagger, istatus)
 271             end if
 272 #endif
 273          end if
 274
 275       end if ! (my_proc_id == IO_NODE .or. do_tiled_input)
 276
 277       if (nprocs > 1 .and. .not. do_tiled_input) then
 278          call parallel_bcast_char(cname, len(cname))
 279          call parallel_bcast_char(cunits, len(cunits))
 280          call parallel_bcast_char(cdesc, len(cdesc))
 281          call parallel_bcast_char(memorder, len(memorder))
 282          call parallel_bcast_char(stagger, len(stagger))
 283          call parallel_bcast_char(dimnames(1), 128)
 284          call parallel_bcast_char(dimnames(2), 128)
 285          call parallel_bcast_char(dimnames(3), 128)
 286          call parallel_bcast_int(domain_start(3))
 287          call parallel_bcast_int(domain_end(3))
 288          call parallel_bcast_int(sr_x)
 289          call parallel_bcast_int(sr_y)
 290
 291          sp1 = my_minx
 292          ep1 = my_maxx - 1
 293          sp2 = my_miny
 294          ep2 = my_maxy - 1
 295          sp3 = domain_start(3)
 296          ep3 = domain_end(3)
 297
 298          if (internal_gridtype == 'C') then
 299             if (my_x /= nproc_x - 1 .or. stagger == 'U' .or. stagger == 'CORNER' .or. sr_x > 1) then
 300                ep1 = ep1 + 1
 301             end if
 302             if (my_y /= nproc_y - 1 .or. stagger == 'V' .or. stagger == 'CORNER' .or. sr_y > 1) then
 303                ep2 = ep2 + 1
 304             end if
 305          else if (internal_gridtype == 'E') then
 306             ep1 = ep1 + 1
 307             ep2 = ep2 + 1
 308          end if
 309
 310          if (sr_x > 1) then
 311             sp1 = (sp1-1)*sr_x+1
 312             ep1 =  ep1   *sr_x
 313          end if
 314          if (sr_y > 1) then
 315             sp2 = (sp2-1)*sr_y+1
 316             ep2 =  ep2   *sr_y
 317          end if
 318
 319          sm1 = sp1
 320          em1 = ep1
 321          sm2 = sp2
 322          em2 = ep2
 323          sm3 = sp3
 324          em3 = ep3
 325
 326          start_patch_i = sp1
 327          end_patch_i   = ep1
 328          start_patch_j = sp2
 329          end_patch_j   = ep2
 330          start_patch_k = sp3
 331          end_patch_k   = ep3
 332
 333          allocate(real_array(sm1:em1,sm2:em2,sm3:em3))
 334          if (my_proc_id /= IO_NODE) then
 335             allocate(real_domain(1,1,1))
 336             domain_start(1) = 1
 337             domain_start(2) = 1
 338             domain_start(3) = 1
 339             domain_end(1) = 1
 340             domain_end(2) = 1
 341             domain_end(3) = 1
 342          end if
 343          call scatter_whole_field_r(real_array, &
 344                                    sm1, em1, sm2, em2, sm3, em3, &
 345                                    sp1, ep1, sp2, ep2, sp3, ep3, &
 346                                    real_domain, &
 347                                    domain_start(1), domain_end(1), &
 348                                    domain_start(2), domain_end(2), &
 349                                    domain_start(3), domain_end(3))
 350          deallocate(real_domain)
 351
 352       else
 353
 354          real_array => real_domain
 355
 356       end if
 357
 358    end subroutine read_next_field
 359
 360    subroutine read_global_attrs(title, start_date, grid_type, dyn_opt,                                &
 361                                 west_east_dim, south_north_dim, bottom_top_dim,                       &
 362                                 we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag,             &
 363                                 sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag,             &
 364                                 map_proj, mminlu, num_land_cat, is_water, is_lake, is_ice, is_urban,  &
 365                                 isoilwater, grid_id, parent_id, i_parent_start, j_parent_start,       &
 366                                 i_parent_end, j_parent_end, dx, dy, cen_lat, moad_cen_lat, cen_lon,   &
 367                                 stand_lon, truelat1, truelat2, pole_lat, pole_lon, parent_grid_ratio, &
 368                                 corner_lats, corner_lons, sr_x, sr_y)
 369
 370       implicit none
 371
 372       ! Arguments
 373       integer, intent(out) :: dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, map_proj,   &
 374                  is_water, is_lake, we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag,      &
 375                  sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag,                         &
 376                  is_ice, is_urban, isoilwater, grid_id, parent_id, i_parent_start, j_parent_start, &
 377                  i_parent_end, j_parent_end, parent_grid_ratio, sr_x, sr_y, num_land_cat
 378       real, intent(out) :: dx, dy, cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2,  &
 379                  pole_lat, pole_lon
 380       real, dimension(16), intent(out) :: corner_lats, corner_lons
 381       character (len=128), intent(out) :: title, start_date, grid_type, mminlu
 382
 383       ! Local variables
 384       integer :: istatus, i
 385       real :: wps_version
 386       character (len=128) :: cunits, cdesc, cstagger
 387       integer, dimension(3) :: sr
 388       type (q_data) :: qd
 389
 390       if (my_proc_id == IO_NODE .or. do_tiled_input) then
 391
 392 #ifdef IO_BINARY
 393          if (io_form_input == BINARY) then
 394             istatus = 0
 395             do while (istatus == 0)
 396                cunits = ' '
 397                cdesc = ' '
 398                cstagger = ' '
 399                sr = 0
 400                call ext_int_get_var_ti_char(handle, 'units', 'VAR', cunits, istatus)
 401
 402                if (istatus == 0) then
 403                   call ext_int_get_var_ti_char(handle, 'description', 'VAR', cdesc, istatus)
 404
 405                   if (istatus == 0) then
 406                      call ext_int_get_var_ti_char(handle, 'stagger', 'VAR', cstagger, istatus)
 407
 408                     if (istatus == 0) then
 409                     call ext_int_get_var_ti_integer(handle, 'sr_x', 'VAR', sr(1), 1, sr(3), istatus)
 410
 411                         if (istatus == 0) then
 412                         call ext_int_get_var_ti_integer(handle, 'sr_y', 'VAR', sr(2), 1, sr(3), istatus)
 413
 414                              qd%units = cunits
 415                              qd%description = cdesc
 416                              qd%stagger = cstagger
 417                              qd%sr_x = sr(1)
 418                              qd%sr_y = sr(2)
 419                              call q_insert(unit_desc, qd)
 420
 421                         end if
 422                     end if
 423                   end if
 424                end if
 425             end do
 426          end if
 427 #endif
 428
 429          call ext_get_dom_ti_char('TITLE', title)
 430          if (index(title,'GEOGRID V4.4') /= 0) then
 431             wps_version = 4.4
 432          else if (index(title,'GEOGRID V4.3.1') /= 0) then
 433             wps_version = 4.31
 434          else if (index(title,'GEOGRID V4.3') /= 0) then
 435             wps_version = 4.3
 436          else if (index(title,'GEOGRID V4.2') /= 0) then
 437             wps_version = 4.2
 438          else if (index(title,'GEOGRID V4.1') /= 0) then
 439             wps_version = 4.1
 440          else if (index(title,'GEOGRID V4.0.3') /= 0) then
 441             wps_version = 4.03
 442          else if (index(title,'GEOGRID V4.0.2') /= 0) then
 443             wps_version = 4.02
 444          else if (index(title,'GEOGRID V4.0.1') /= 0) then
 445             wps_version = 4.01
 446          else if (index(title,'GEOGRID V4.0') /= 0) then
 447             wps_version = 4.0
 448          else if (index(title,'GEOGRID V3.9.1') /= 0) then
 449             wps_version = 3.91
 450          else if (index(title,'GEOGRID V3.9.0.1') /= 0) then
 451             wps_version = 3.901
 452          else if (index(title,'GEOGRID V3.9') /= 0) then
 453             wps_version = 3.9
 454          else if (index(title,'GEOGRID V3.8.1') /= 0) then
 455             wps_version = 3.81
 456          else if (index(title,'GEOGRID V3.8') /= 0) then
 457             wps_version = 3.8
 458          else if (index(title,'GEOGRID V3.7.1') /= 0) then
 459             wps_version = 3.71
 460          else if (index(title,'GEOGRID V3.7') /= 0) then
 461             wps_version = 3.7
 462          else if (index(title,'GEOGRID V3.6.1') /= 0) then
 463             wps_version = 3.61
 464          else if (index(title,'GEOGRID V3.6') /= 0) then
 465             wps_version = 3.6
 466          else if (index(title,'GEOGRID V3.5.1') /= 0) then
 467             wps_version = 3.51
 468          else if (index(title,'GEOGRID V3.5') /= 0) then
 469             wps_version = 3.5
 470          else if (index(title,'GEOGRID V3.4.1') /= 0) then
 471             wps_version = 3.41
 472          else if (index(title,'GEOGRID V3.4') /= 0) then
 473             wps_version = 3.4
 474          else if (index(title,'GEOGRID V3.3.1') /= 0) then
 475             wps_version = 3.31
 476          else if (index(title,'GEOGRID V3.3') /= 0) then
 477             wps_version = 3.3
 478          else if (index(title,'GEOGRID V3.2.1') /= 0) then
 479             wps_version = 3.21
 480          else if (index(title,'GEOGRID V3.2') /= 0) then
 481             wps_version = 3.2
 482          else if (index(title,'GEOGRID V3.1.1') /= 0) then
 483             wps_version = 3.11
 484          else if (index(title,'GEOGRID V3.1') /= 0) then
 485             wps_version = 3.1
 486          else if (index(title,'GEOGRID V3.0.1') /= 0) then
 487             wps_version = 3.01
 488          else
 489             wps_version = 3.0
 490          end if
 491          call mprintf(.true.,DEBUG,'Reading static data from WPS version %f', f1=wps_version)
 492          call ext_get_dom_ti_char          ('SIMULATION_START_DATE', start_date)
 493          call ext_get_dom_ti_integer_scalar('WEST-EAST_GRID_DIMENSION', west_east_dim)
 494          call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_GRID_DIMENSION', south_north_dim)
 495          call ext_get_dom_ti_integer_scalar('BOTTOM-TOP_GRID_DIMENSION', bottom_top_dim)
 496          call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_START_UNSTAG', we_patch_s)
 497          call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_END_UNSTAG', we_patch_e)
 498          call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_START_STAG', we_patch_s_stag)
 499          call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_END_STAG', we_patch_e_stag)
 500          call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_UNSTAG', sn_patch_s)
 501          call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_UNSTAG', sn_patch_e)
 502          call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_STAG', sn_patch_s_stag)
 503          call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_STAG', sn_patch_e_stag)
 504          call ext_get_dom_ti_char          ('GRIDTYPE', grid_type)
 505          call ext_get_dom_ti_real_scalar   ('DX', dx)
 506          call ext_get_dom_ti_real_scalar   ('DY', dy)
 507          call ext_get_dom_ti_integer_scalar('DYN_OPT', dyn_opt)
 508          call ext_get_dom_ti_real_scalar   ('CEN_LAT', cen_lat)
 509          call ext_get_dom_ti_real_scalar   ('CEN_LON', cen_lon)
 510          call ext_get_dom_ti_real_scalar   ('TRUELAT1', truelat1)
 511          call ext_get_dom_ti_real_scalar   ('TRUELAT2', truelat2)
 512          call ext_get_dom_ti_real_scalar   ('MOAD_CEN_LAT', moad_cen_lat)
 513          call ext_get_dom_ti_real_scalar   ('STAND_LON', stand_lon)
 514          call ext_get_dom_ti_real_scalar   ('POLE_LAT', pole_lat)
 515          call ext_get_dom_ti_real_scalar   ('POLE_LON', pole_lon)
 516          call ext_get_dom_ti_real_vector   ('corner_lats', corner_lats, 16)
 517          call ext_get_dom_ti_real_vector   ('corner_lons', corner_lons, 16)
 518          call ext_get_dom_ti_integer_scalar('MAP_PROJ', map_proj)
 519          call ext_get_dom_ti_char          ('MMINLU', mminlu)
 520          if ( wps_version >= 3.01 ) then
 521             call ext_get_dom_ti_integer_scalar('NUM_LAND_CAT', num_land_cat)
 522          else
 523             num_land_cat = 24
 524          end if
 525          call ext_get_dom_ti_integer_scalar('ISWATER', is_water)
 526          if ( wps_version >= 3.01 ) then
 527             call ext_get_dom_ti_integer_scalar('ISLAKE', is_lake)
 528          else
 529             is_lake = -1
 530          end if
 531          call ext_get_dom_ti_integer_scalar('ISICE', is_ice)
 532          call ext_get_dom_ti_integer_scalar('ISURBAN', is_urban)
 533          call ext_get_dom_ti_integer_scalar('ISOILWATER', isoilwater)
 534          call ext_get_dom_ti_integer_scalar('grid_id', grid_id)
 535          call ext_get_dom_ti_integer_scalar('parent_id', parent_id)
 536          call ext_get_dom_ti_integer_scalar('i_parent_start', i_parent_start)
 537          call ext_get_dom_ti_integer_scalar('j_parent_start', j_parent_start)
 538          call ext_get_dom_ti_integer_scalar('i_parent_end', i_parent_end)
 539          call ext_get_dom_ti_integer_scalar('j_parent_end', j_parent_end)
 540          call ext_get_dom_ti_integer_scalar('parent_grid_ratio', parent_grid_ratio)
 541          call ext_get_dom_ti_integer_scalar('sr_x', sr_x)
 542          call ext_get_dom_ti_integer_scalar('sr_y', sr_y)
 543
 544       end if
 545
 546
 547       if (nprocs > 1 .and. .not. do_tiled_input) then
 548
 549          call parallel_bcast_char(title, len(title))
 550          call parallel_bcast_char(start_date, len(start_date))
 551          call parallel_bcast_char(grid_type, len(grid_type))
 552          call parallel_bcast_int(west_east_dim)
 553          call parallel_bcast_int(south_north_dim)
 554          call parallel_bcast_int(bottom_top_dim)
 555          call parallel_bcast_int(we_patch_s)
 556          call parallel_bcast_int(we_patch_e)
 557          call parallel_bcast_int(we_patch_s_stag)
 558          call parallel_bcast_int(we_patch_e_stag)
 559          call parallel_bcast_int(sn_patch_s)
 560          call parallel_bcast_int(sn_patch_e)
 561          call parallel_bcast_int(sn_patch_s_stag)
 562          call parallel_bcast_int(sn_patch_e_stag)
 563          call parallel_bcast_int(sr_x)
 564          call parallel_bcast_int(sr_y)
 565
 566          ! Must figure out patch dimensions from info in parallel module
 567 !         we_patch_s      = my_minx
 568 !         we_patch_s_stag = my_minx
 569 !         we_patch_e      = my_maxx - 1
 570 !         sn_patch_s      = my_miny
 571 !         sn_patch_s_stag = my_miny
 572 !         sn_patch_e      = my_maxy - 1
 573 !
 574 !         if (trim(grid_type) == 'C') then
 575 !            if (my_x /= nproc_x - 1) then
 576 !               we_patch_e_stag = we_patch_e + 1
 577 !            end if
 578 !            if (my_y /= nproc_y - 1) then
 579 !               sn_patch_e_stag = sn_patch_e + 1
 580 !            end if
 581 !         else if (trim(grid_type) == 'E') then
 582 !            we_patch_e = we_patch_e + 1
 583 !            sn_patch_e = sn_patch_e + 1
 584 !            we_patch_e_stag = we_patch_e
 585 !            sn_patch_e_stag = sn_patch_e
 586 !         end if
 587
 588          call parallel_bcast_real(dx)
 589          call parallel_bcast_real(dy)
 590          call parallel_bcast_int(dyn_opt)
 591          call parallel_bcast_real(cen_lat)
 592          call parallel_bcast_real(cen_lon)
 593          call parallel_bcast_real(truelat1)
 594          call parallel_bcast_real(truelat2)
 595          call parallel_bcast_real(pole_lat)
 596          call parallel_bcast_real(pole_lon)
 597          call parallel_bcast_real(moad_cen_lat)
 598          call parallel_bcast_real(stand_lon)
 599          do i=1,16
 600             call parallel_bcast_real(corner_lats(i))
 601             call parallel_bcast_real(corner_lons(i))
 602          end do
 603          call parallel_bcast_int(map_proj)
 604          call parallel_bcast_char(mminlu, len(mminlu))
 605          call parallel_bcast_int(is_water)
 606          call parallel_bcast_int(is_lake)
 607          call parallel_bcast_int(is_ice)
 608          call parallel_bcast_int(is_urban)
 609          call parallel_bcast_int(isoilwater)
 610          call parallel_bcast_int(grid_id)
 611          call parallel_bcast_int(parent_id)
 612          call parallel_bcast_int(i_parent_start)
 613          call parallel_bcast_int(i_parent_end)
 614          call parallel_bcast_int(j_parent_start)
 615          call parallel_bcast_int(j_parent_end)
 616          call parallel_bcast_int(parent_grid_ratio)
 617       end if
 618
 619       internal_gridtype = grid_type
 620
 621    end subroutine read_global_attrs
 622
 623
 624    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 625    ! Name: ext_get_dom_ti_integer
 626    !
 627    ! Purpose: Read a domain time-independent integer attribute from input.
 628    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 629    subroutine ext_get_dom_ti_integer_scalar(var_name, var_value, suppress_errors)
 630
 631       implicit none
 632
 633       ! Arguments
 634       integer, intent(out) :: var_value
 635       character (len=*), intent(in) :: var_name
 636       logical, intent(in), optional :: suppress_errors
 637
 638       ! Local variables
 639       integer :: istatus, outcount
 640       integer, dimension(1) :: var_value_arr
 641
 642 #ifdef IO_BINARY
 643       if (io_form_input == BINARY) then
 644          call ext_int_get_dom_ti_integer(handle, trim(var_name), &
 645                                          var_value_arr, &
 646                                          1, outcount, istatus)
 647       end if
 648 #endif
 649 #ifdef IO_NETCDF
 650       if (io_form_input == NETCDF) then
 651          call ext_ncd_get_dom_ti_integer(handle, trim(var_name), &
 652                                          var_value_arr, &
 653                                          1, outcount, istatus)
 654       end if
 655 #endif
 656 #ifdef IO_GRIB1
 657       if (io_form_input == GRIB1) then
 658          call ext_gr1_get_dom_ti_integer(handle, trim(var_name), &
 659                                          var_value_arr, &
 660                                          1, outcount, istatus)
 661       end if
 662 #endif
 663
 664       if (present(suppress_errors)) then
 665          call mprintf((istatus /= 0 .and. .not.suppress_errors),ERROR,'Error while reading domain time-independent attribute.')
 666       else
 667          call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.')
 668       end if
 669
 670       var_value = var_value_arr(1)
 671
 672    end subroutine ext_get_dom_ti_integer_scalar
 673
 674
 675    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 676    ! Name: ext_get_dom_ti_integer
 677    !
 678    ! Purpose: Read a domain time-independent integer attribute from input.
 679    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 680    subroutine ext_get_dom_ti_integer_vector(var_name, var_value, n)
 681
 682       implicit none
 683
 684       ! Arguments
 685       integer, intent(in) :: n
 686       integer, dimension(n), intent(out) :: var_value
 687       character (len=*), intent(in) :: var_name
 688
 689       ! Local variables
 690       integer :: istatus, outcount
 691
 692 #ifdef IO_BINARY
 693       if (io_form_input == BINARY) then
 694          call ext_int_get_dom_ti_integer(handle, trim(var_name), &
 695                                          var_value, &
 696                                          n, outcount, istatus)
 697       end if
 698 #endif
 699 #ifdef IO_NETCDF
 700       if (io_form_input == NETCDF) then
 701          call ext_ncd_get_dom_ti_integer(handle, trim(var_name), &
 702                                          var_value, &
 703                                          n, outcount, istatus)
 704       end if
 705 #endif
 706 #ifdef IO_GRIB1
 707       if (io_form_input == GRIB1) then
 708          call ext_gr1_get_dom_ti_integer(handle, trim(var_name), &
 709                                          var_value, &
 710                                          n, outcount, istatus)
 711       end if
 712 #endif
 713
 714       call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.')
 715
 716    end subroutine ext_get_dom_ti_integer_vector
 717
 718
 719    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 720    ! Name: ext_get_dom_ti_real
 721    !
 722    ! Purpose: Read a domain time-independent real attribute from input.
 723    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 724    subroutine ext_get_dom_ti_real_scalar(var_name, var_value)
 725
 726       implicit none
 727
 728       ! Arguments
 729       real, intent(out) :: var_value
 730       character (len=*), intent(in) :: var_name
 731
 732       ! Local variables
 733       integer :: istatus, outcount
 734       real, dimension(1) :: var_value_arr
 735
 736 #ifdef IO_BINARY
 737       if (io_form_input == BINARY) then
 738          call ext_int_get_dom_ti_real(handle, trim(var_name), &
 739                                          var_value_arr, &
 740                                          1, outcount, istatus)
 741       end if
 742 #endif
 743 #ifdef IO_NETCDF
 744       if (io_form_input == NETCDF) then
 745          call ext_ncd_get_dom_ti_real(handle, trim(var_name), &
 746                                          var_value_arr, &
 747                                          1, outcount, istatus)
 748       end if
 749 #endif
 750 #ifdef IO_GRIB1
 751       if (io_form_input == GRIB1) then
 752          call ext_gr1_get_dom_ti_real(handle, trim(var_name), &
 753                                          var_value_arr, &
 754                                          1, outcount, istatus)
 755       end if
 756 #endif
 757
 758       call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.')
 759
 760       var_value = var_value_arr(1)
 761
 762    end subroutine ext_get_dom_ti_real_scalar
 763
 764
 765    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 766    ! Name: ext_get_dom_ti_real
 767    !
 768    ! Purpose: Read a domain time-independent real attribute from input.
 769    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 770    subroutine ext_get_dom_ti_real_vector(var_name, var_value, n)
 771
 772       implicit none
 773
 774       ! Arguments
 775       integer, intent(in) :: n
 776       real, dimension(n), intent(out) :: var_value
 777       character (len=*), intent(in) :: var_name
 778
 779       ! Local variables
 780       integer :: istatus, outcount
 781
 782 #ifdef IO_BINARY
 783       if (io_form_input == BINARY) then
 784          call ext_int_get_dom_ti_real(handle, trim(var_name), &
 785                                          var_value, &
 786                                          n, outcount, istatus)
 787       end if
 788 #endif
 789 #ifdef IO_NETCDF
 790       if (io_form_input == NETCDF) then
 791          call ext_ncd_get_dom_ti_real(handle, trim(var_name), &
 792                                          var_value, &
 793                                          n, outcount, istatus)
 794       end if
 795 #endif
 796 #ifdef IO_GRIB1
 797       if (io_form_input == GRIB1) then
 798          call ext_gr1_get_dom_ti_real(handle, trim(var_name), &
 799                                          var_value, &
 800                                          n, outcount, istatus)
 801       end if
 802 #endif
 803
 804       call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.')
 805
 806    end subroutine ext_get_dom_ti_real_vector
 807
 808
 809    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 810    ! Name: ext_get_dom_ti_char
 811    !
 812    ! Purpose: Read a domain time-independent character attribute from input.
 813    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 814    subroutine ext_get_dom_ti_char(var_name, var_value)
 815
 816       implicit none
 817
 818       ! Arguments
 819       character (len=*), intent(in) :: var_name
 820       character (len=128), intent(out) :: var_value
 821
 822       ! Local variables
 823       integer :: istatus
 824
 825 #ifdef IO_BINARY
 826       if (io_form_input == BINARY) then
 827          call ext_int_get_dom_ti_char(handle, trim(var_name), &
 828                                          var_value, &
 829                                          istatus)
 830       end if
 831 #endif
 832 #ifdef IO_NETCDF
 833       if (io_form_input == NETCDF) then
 834          call ext_ncd_get_dom_ti_char(handle, trim(var_name), &
 835                                          var_value, &
 836                                          istatus)
 837       end if
 838 #endif
 839 #ifdef IO_GRIB1
 840       if (io_form_input == GRIB1) then
 841          call ext_gr1_get_dom_ti_char(handle, trim(var_name), &
 842                                          var_value, &
 843                                          istatus)
 844       end if
 845 #endif
 846
 847       call mprintf((istatus /= 0),ERROR,'Error in reading domain time-independent attribute')
 848
 849    end subroutine ext_get_dom_ti_char
 850
 851
 852    subroutine input_close()
 853
 854       implicit none
 855
 856       ! Local variables
 857       integer :: istatus
 858
 859       istatus = 0
 860       if (my_proc_id == IO_NODE .or. do_tiled_input) then
 861 #ifdef IO_BINARY
 862          if (io_form_input == BINARY) then
 863             call ext_int_ioclose(handle, istatus)
 864             call ext_int_ioexit(istatus)
 865          end if
 866 #endif
 867 #ifdef IO_NETCDF
 868          if (io_form_input == NETCDF) then
 869             call ext_ncd_ioclose(handle, istatus)
 870             call ext_ncd_ioexit(istatus)
 871          end if
 872 #endif
 873 #ifdef IO_GRIB1
 874          if (io_form_input == GRIB1) then
 875             call ext_gr1_ioclose(handle, istatus)
 876             call ext_gr1_ioexit(istatus)
 877          end if
 878 #endif
 879       end if
 880
 881       call q_destroy(unit_desc)
 882
 883    end subroutine input_close
 884
 885 end module input_module