!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Module: source_data_module ! ! Description: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module source_data_module use hash_module use list_module use module_debug use misc_definitions_module ! Parameters integer, parameter :: RETURN_LANDMASK = 0, & RETURN_DOMCAT_LM = 1, & RETURN_DFDX_LM = 2, & RETURN_DFDY_LM = 3, & RETURN_FIELDNAME = 4, & RETURN_DOMCAT = 5, & RETURN_DFDX = 6, & RETURN_DFDY = 7 integer, parameter :: MAX_LANDMASK_CATEGORIES = 100 ! Module variables integer :: num_entries integer :: next_field = 1 integer :: output_field_state = RETURN_LANDMASK character (len=128) :: last_output_fieldname = '' integer, pointer, dimension(:) :: source_proj, source_wordsize, source_endian, source_fieldtype, & source_dest_fieldtype, source_priority, source_tile_x, source_tile_y, & source_tile_z, source_tile_z_start, source_tile_z_end, source_tile_bdr, & source_category_min, source_category_max, source_smooth_option, & source_smooth_passes, source_output_stagger, source_row_order, & source_filename_digits integer :: source_iswater, source_islake, source_isice, source_isurban, source_isoilwater real, pointer, dimension(:) :: source_dx, source_dy, source_known_x, source_known_y, & source_known_lat, source_known_lon, source_masked, source_truelat1, source_truelat2, & source_stdlon, source_scale_factor, source_missing_value, source_fill_missing character (len=128), pointer, dimension(:) :: source_fieldname, source_path, source_interp_string, & source_dominant_category, source_dominant_only, source_dfdx, source_dfdy, & source_z_dim_name, source_units, source_descr, source_output_flag, source_res character (len=128) :: source_mminlu logical, pointer, dimension(:) :: is_proj, is_wordsize, is_endian, is_fieldtype, & is_dest_fieldtype, is_priority, is_tile_x, is_tile_y, is_tile_z, & is_tile_z_start, is_tile_z_end, is_tile_bdr, is_category_min, & is_category_max, is_masked, & is_dx, is_dy, is_known_x, is_known_y, & is_known_lat, is_known_lon, is_truelat1, is_truelat2, is_stdlon, & is_scale_factor, is_fieldname, is_path, is_dominant_category, & is_dominant_only, is_dfdx, is_dfdy, is_z_dim_name, & is_smooth_option, is_smooth_passes, is_signed, is_missing_value, & is_fill_missing, is_halt_missing, is_output_stagger, is_row_order, & is_units, is_descr, is_subgrid, is_output_flag, is_optional, is_not_found type (list), pointer, dimension(:) :: source_res_path, source_interp_option, source_landmask_land, & source_landmask_water type (hashtable) :: bad_files ! Track which files produce errors when we try to open them type (hashtable) :: duplicate_fnames ! Remember which output fields we have returned contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_datalist ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_datalist() use gridinfo_module use stringutil implicit none ! Parameters integer, parameter :: BUFSIZE = 256 ! Local variables integer :: nparams, idx, eos, ispace, comma, i, j, funit logical :: have_specification, is_used character (len=128) :: res_string, path_string, interp_string, landmask_string character (len=BUFSIZE) :: buffer nparams = 0 num_entries = 0 do funit=10,100 inquire(unit=funit, opened=is_used) if (.not. is_used) exit end do open(funit,file=trim(opt_geogrid_tbl_path)//'GEOGRID.TBL',form='formatted',status='old',err=1000) ! ! We will first go through the file to determine how many field ! specifications there are ! 10 read(funit,'(a)',end=20,err=1001) buffer call despace(buffer) ! Is this line a comment? if (buffer(1:1) == '#') then ! Are we beginning a new field specification? else if (index(buffer,'=====') /= 0) then if (nparams > 0) num_entries = num_entries + 1 nparams = 0 else eos = index(buffer,'#') if (eos /= 0) buffer(eos:BUFSIZE) = ' ' ! Does this line contain at least one parameter specification? if (index(buffer,'=') /= 0) then nparams = nparams + 1 end if end if go to 10 20 rewind(funit) ! In case the last entry ended without a ======== line if (nparams > 0) num_entries = num_entries + 1 call mprintf(.true.,STDOUT,'Parsed %i entries in GEOGRID.TBL', i1=num_entries) ! ! Now that we know how many fields the user has specified, allocate ! the properly sized arrays ! allocate(source_wordsize(num_entries)) allocate(source_endian(num_entries)) allocate(source_fieldtype(num_entries)) allocate(source_dest_fieldtype(num_entries)) allocate(source_proj(num_entries)) allocate(source_priority(num_entries)) allocate(source_dx(num_entries)) allocate(source_dy(num_entries)) allocate(source_known_x(num_entries)) allocate(source_known_y(num_entries)) allocate(source_known_lat(num_entries)) allocate(source_known_lon(num_entries)) allocate(source_truelat1(num_entries)) allocate(source_truelat2(num_entries)) allocate(source_stdlon(num_entries)) allocate(source_fieldname(num_entries)) allocate(source_path(num_entries)) allocate(source_interp_string(num_entries)) allocate(source_tile_x(num_entries)) allocate(source_tile_y(num_entries)) allocate(source_tile_z(num_entries)) allocate(source_tile_z_start(num_entries)) allocate(source_tile_z_end(num_entries)) allocate(source_filename_digits(num_entries)) allocate(source_category_min(num_entries)) allocate(source_category_max(num_entries)) allocate(source_tile_bdr(num_entries)) allocate(source_masked(num_entries)) allocate(source_output_stagger(num_entries)) allocate(source_row_order(num_entries)) allocate(source_dominant_category(num_entries)) allocate(source_dominant_only(num_entries)) allocate(source_dfdx(num_entries)) allocate(source_dfdy(num_entries)) allocate(source_scale_factor(num_entries)) allocate(source_z_dim_name(num_entries)) allocate(source_units(num_entries)) allocate(source_descr(num_entries)) allocate(source_res(num_entries)) allocate(source_smooth_option(num_entries)) allocate(source_smooth_passes(num_entries)) allocate(source_missing_value(num_entries)) allocate(source_fill_missing(num_entries)) allocate(source_res_path(num_entries)) allocate(source_interp_option(num_entries)) allocate(source_landmask_land(num_entries)) allocate(source_landmask_water(num_entries)) allocate(source_output_flag(num_entries)) do i=1,num_entries call list_init(source_res_path(i)) call list_init(source_interp_option(i)) call list_init(source_landmask_land(i)) call list_init(source_landmask_water(i)) end do allocate(is_wordsize(num_entries)) allocate(is_endian(num_entries)) allocate(is_fieldtype(num_entries)) allocate(is_dest_fieldtype(num_entries)) allocate(is_proj(num_entries)) allocate(is_priority(num_entries)) allocate(is_dx(num_entries)) allocate(is_dy(num_entries)) allocate(is_known_x(num_entries)) allocate(is_known_y(num_entries)) allocate(is_known_lat(num_entries)) allocate(is_known_lon(num_entries)) allocate(is_truelat1(num_entries)) allocate(is_truelat2(num_entries)) allocate(is_stdlon(num_entries)) allocate(is_fieldname(num_entries)) allocate(is_path(num_entries)) allocate(is_tile_x(num_entries)) allocate(is_tile_y(num_entries)) allocate(is_tile_z(num_entries)) allocate(is_tile_z_start(num_entries)) allocate(is_tile_z_end(num_entries)) allocate(is_category_min(num_entries)) allocate(is_category_max(num_entries)) allocate(is_tile_bdr(num_entries)) allocate(is_masked(num_entries)) allocate(is_halt_missing(num_entries)) allocate(is_output_stagger(num_entries)) allocate(is_row_order(num_entries)) allocate(is_dominant_category(num_entries)) allocate(is_dominant_only(num_entries)) allocate(is_dfdx(num_entries)) allocate(is_dfdy(num_entries)) allocate(is_scale_factor(num_entries)) allocate(is_z_dim_name(num_entries)) allocate(is_units(num_entries)) allocate(is_descr(num_entries)) allocate(is_smooth_option(num_entries)) allocate(is_smooth_passes(num_entries)) allocate(is_signed(num_entries)) allocate(is_missing_value(num_entries)) allocate(is_fill_missing(num_entries)) allocate(is_subgrid(num_entries)) allocate(is_output_flag(num_entries)) allocate(is_optional(num_entries)) allocate(is_not_found(num_entries)) source_wordsize=0 source_endian=0 source_fieldtype=0 source_dest_fieldtype=0 source_proj=0 source_priority=0 source_dx=0 source_dy=0 source_known_x=0 source_known_y=0 source_known_lat=0 source_known_lon=0 source_truelat1=0 source_truelat2=0 source_stdlon=0 source_fieldname=' ' source_path=' ' source_interp_string=' ' source_tile_x=0 source_tile_y=0 source_tile_z=0 source_tile_z_start=0 source_tile_z_end=0 source_filename_digits=5 source_category_min=0 source_category_max=0 source_tile_bdr=0 source_masked=0 source_output_stagger=0 source_row_order=0 source_dominant_category=' ' source_dominant_only=' ' source_dfdx=' ' source_dfdy=' ' source_scale_factor=0 source_z_dim_name=' ' source_units=' ' source_descr=' ' source_res=' ' source_smooth_option=0 source_smooth_passes=0 source_missing_value=0 source_fill_missing=0 source_output_flag=' ' is_wordsize=.false. is_endian=.false. is_fieldtype=.false. is_dest_fieldtype=.false. is_proj=.false. is_priority=.false. is_dx=.false. is_dy=.false. is_known_x=.false. is_known_y=.false. is_known_lat=.false. is_known_lon=.false. is_truelat1=.false. is_truelat2=.false. is_stdlon=.false. is_fieldname=.false. is_path=.false. is_tile_x=.false. is_tile_y=.false. is_tile_z=.false. is_tile_z_start=.false. is_tile_z_end=.false. is_category_min=.false. is_category_max=.false. is_tile_bdr=.false. is_masked=.false. is_halt_missing=.false. is_output_stagger=.false. is_row_order=.false. is_dominant_category=.false. is_dominant_only=.false. is_dfdx=.false. is_dfdy=.false. is_scale_factor=.false. is_z_dim_name=.false. is_units=.false. is_descr=.false. is_smooth_option=.false. is_smooth_passes=.false. is_signed=.false. is_missing_value=.false. is_fill_missing=.false. is_subgrid=.false. is_output_flag=.false. is_optional=.false. is_not_found=.false. ! This is the default value of source_mminlu ! If this default is changed then you must also modify the variable ! default_mminlu in get_source_params write(source_mminlu,'(a4)') 'USGS' source_iswater = 16 source_islake = -1 source_isice = 24 source_isurban = 1 source_isoilwater = 14 ! ! Actually read and save the specifications ! nparams = 0 i = 1 30 buffer = ' ' read(funit,'(a)',end=40,err=1001) buffer call despace(buffer) ! Is this line a comment? if (buffer(1:1) == '#') then ! Do nothing. ! Are we beginning a new field specification? else if (index(buffer,'=====') /= 0) then !{ if (nparams > 0) i = i + 1 nparams = 0 if (i <= num_entries) then !BUG: Are these initializations needed now that we've added initializations for ! all options after their initial allocation above? is_path(i) = .false. is_masked(i) = .false. is_halt_missing(i) = .false. is_output_stagger(i) = .false. is_dominant_category(i) = .false. is_dominant_only(i) = .false. is_dfdx(i) = .false. is_dfdy(i) = .false. is_dest_fieldtype(i) = .false. is_priority(i) = .false. is_z_dim_name(i) = .false. is_smooth_option(i) = .false. is_smooth_passes(i) = .false. is_fill_missing(i) = .false. is_subgrid(i) = .false. is_output_flag(i) = .false. is_optional(i) = .false. end if else ! Check whether the current line is a comment if (buffer(1:1) /= '#') then have_specification = .true. else have_specification = .false. end if ! If only part of the line is a comment, just turn the comment into spaces eos = index(buffer,'#') if (eos /= 0) buffer(eos:BUFSIZE) = ' ' do while (have_specification) !{ ! If this line has no semicolon, it may contain a single specification, ! so we set have_specification = .false. to prevent the line from being ! processed again and "pretend" that the last character was a semicolon eos = index(buffer,';') if (eos == 0) then have_specification = .false. eos = BUFSIZE end if idx = index(buffer(1:eos-1),'=') if (idx /= 0) then !{ nparams = nparams + 1 if (index('name',trim(buffer(1:idx-1))) /= 0) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do is_fieldname(i) = .true. source_fieldname(i) = ' ' source_fieldname(i)(1:ispace-idx) = buffer(idx+1:ispace-1) else if (index('priority',trim(buffer(1:idx-1))) /= 0) then is_priority(i) = .true. read(buffer(idx+1:eos-1),'(i10)') source_priority(i) else if (index('dest_type',trim(buffer(1:idx-1))) /= 0) then if (index('continuous',trim(buffer(idx+1:eos-1))) /= 0) then is_dest_fieldtype(i) = .true. source_dest_fieldtype(i) = CONTINUOUS else if (index('categorical',trim(buffer(idx+1:eos-1))) /= 0) then is_dest_fieldtype(i) = .true. source_dest_fieldtype(i) = CATEGORICAL end if else if (index('interp_option',trim(buffer(1:idx-1))) /= 0) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do interp_string = ' ' interp_string(1:ispace-idx-1) = buffer(idx+1:ispace-1) ispace = index(interp_string,':') if (ispace /= 0) then write(res_string,'(a)') interp_string(1:ispace-1) else res_string = 'default' end if write(interp_string,'(a)') trim(interp_string(ispace+1:128)) if (list_search(source_interp_option(i), ckey=res_string, cvalue=interp_string)) then call mprintf(.true., WARN, & 'In GEOGRID.TBL entry %i, multiple interpolation methods are '// & 'given for resolution %s. %s will be used.', & i1=i, s1=trim(res_string), s2=trim(interp_string)) else call list_insert(source_interp_option(i), ckey=res_string, cvalue=interp_string) end if else if (index('smooth_option',trim(buffer(1:idx-1))) /= 0) then if ((index('1-2-1',trim(buffer(idx+1:eos-1))) /= 0) .and. & (len_trim(buffer(idx+1:eos-1)) == len('1-2-1'))) then is_smooth_option(i) = .true. source_smooth_option(i) = ONETWOONE else if ((index('smth-desmth',trim(buffer(idx+1:eos-1))) /= 0) .and. & (len_trim(buffer(idx+1:eos-1)) == len('smth-desmth'))) then is_smooth_option(i) = .true. source_smooth_option(i) = SMTHDESMTH else if ((index('smth-desmth_special',trim(buffer(idx+1:eos-1))) /= 0) .and. & (len_trim(buffer(idx+1:eos-1)) == len('smth-desmth_special'))) then is_smooth_option(i) = .true. source_smooth_option(i) = SMTHDESMTH_SPECIAL end if else if (index('smooth_passes',trim(buffer(1:idx-1))) /= 0) then is_smooth_passes(i) = .true. read(buffer(idx+1:eos-1),'(i10)') source_smooth_passes(i) else if (index('rel_path',trim(buffer(1:idx-1))) /= 0) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do path_string = ' ' path_string(1:ispace-idx-1) = buffer(idx+1:ispace-1) if (path_string(ispace-idx-1:ispace-idx-1) /= '/') & path_string(ispace-idx:ispace-idx) = '/' if (path_string(1:1) == '/') then path_string(1:127) = path_string(2:128) path_string(128:128) = ' ' end if ispace = index(path_string,':') if (ispace /= 0) then write(res_string,'(a)') path_string(1:ispace-1) else res_string = 'default' end if write(path_string,'(a)') trim(geog_data_path)//trim(path_string(ispace+1:128)) if (list_search(source_res_path(i), ckey=res_string, cvalue=path_string)) then call mprintf(.true., WARN, & 'In GEOGRID.TBL entry %i, multiple paths are given for '// & 'resolution %s. %s will be used.', & i1=i, s1=trim(res_string), s2=trim(path_string)) else call list_insert(source_res_path(i), ckey=res_string, cvalue=path_string) end if else if (index('abs_path',trim(buffer(1:idx-1))) /= 0) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do path_string = ' ' path_string(1:ispace-idx-1) = buffer(idx+1:ispace-1) if (path_string(ispace-idx-1:ispace-idx-1) /= '/') & path_string(ispace-idx:ispace-idx) = '/' ispace = index(path_string,':') if (ispace /= 0) then write(res_string,'(a)') path_string(1:ispace-1) else res_string = 'default' end if write(path_string,'(a)') trim(path_string(ispace+1:128)) if (list_search(source_res_path(i), ckey=res_string, cvalue=path_string)) then call mprintf(.true., WARN, & 'In GEOGRID.TBL entry %i, multiple paths are given for '// & 'resolution %s. %s will be used.', & i1=i, s1=trim(res_string), s2=trim(path_string)) else call list_insert(source_res_path(i), ckey=res_string, cvalue=path_string) end if else if (index('output_stagger',trim(buffer(1:idx-1))) /= 0) then if (index('M',trim(buffer(idx+1:eos-1))) /= 0) then is_output_stagger(i) = .true. source_output_stagger(i) = M else if (index('U',trim(buffer(idx+1:eos-1))) /= 0) then is_output_stagger(i) = .true. source_output_stagger(i) = U else if (index('V',trim(buffer(idx+1:eos-1))) /= 0) then is_output_stagger(i) = .true. source_output_stagger(i) = V else if (index('HH',trim(buffer(idx+1:eos-1))) /= 0) then is_output_stagger(i) = .true. source_output_stagger(i) = HH else if (index('VV',trim(buffer(idx+1:eos-1))) /= 0) then is_output_stagger(i) = .true. source_output_stagger(i) = VV end if else if ((index('landmask_water',trim(buffer(1:idx-1))) /= 0) .and. & (len_trim(buffer(1:idx-1)) == 14)) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do landmask_string = ' ' landmask_string(1:ispace-idx-1) = buffer(idx+1:ispace-1) ispace = index(landmask_string,':') if (ispace /= 0) then write(res_string,'(a)') landmask_string(1:ispace-1) else res_string = 'default' end if write(landmask_string,'(a)') trim(landmask_string(ispace+1:128)) if (list_search(source_landmask_water(i), ckey=res_string, cvalue=landmask_string)) then call mprintf(.true., WARN, & 'In GEOGRID.TBL entry %i, multiple landmask category specifications are given for '// & 'resolution %s. %s will be used.', & i1=i, s1=trim(res_string), s2=trim(landmask_string)) else call list_insert(source_landmask_water(i), ckey=res_string, cvalue=landmask_string) end if else if ((index('landmask_land',trim(buffer(1:idx-1))) /= 0) .and. & (len_trim(buffer(1:idx-1)) == 13)) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do landmask_string = ' ' landmask_string(1:ispace-idx-1) = buffer(idx+1:ispace-1) ispace = index(landmask_string,':') if (ispace /= 0) then write(res_string,'(a)') landmask_string(1:ispace-1) else res_string = 'default' end if write(landmask_string,'(a)') trim(landmask_string(ispace+1:128)) if (list_search(source_landmask_land(i), ckey=res_string, cvalue=landmask_string)) then call mprintf(.true., WARN, & 'In GEOGRID.TBL entry %i, multiple landmask category specifications are given for '// & 'resolution %s. %s will be used.', & i1=i, s1=trim(res_string), s2=trim(landmask_string)) else call list_insert(source_landmask_land(i), ckey=res_string, cvalue=landmask_string) end if else if ((index('masked',trim(buffer(1:idx-1))) /= 0) .and. & (len_trim(buffer(1:idx-1)) == 6)) then if (index('water',trim(buffer(idx+1:eos-1))) /= 0) then is_masked(i) = .true. source_masked(i) = 0. else if (index('land',trim(buffer(idx+1:eos-1))) /= 0) then is_masked(i) = .true. source_masked(i) = 1. end if else if (index('fill_missing',trim(buffer(1:idx-1))) /= 0) then is_fill_missing(i) = .true. read(buffer(idx+1:eos-1),*) source_fill_missing(i) else if (index('halt_on_missing',trim(buffer(1:idx-1))) /= 0) then if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then is_halt_missing(i) = .true. else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then is_halt_missing(i) = .false. end if else if (index('dominant_category',trim(buffer(1:idx-1))) /= 0) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do is_dominant_category(i) = .true. source_dominant_category(i) = ' ' source_dominant_category(i)(1:ispace-idx) = buffer(idx+1:ispace-1) else if (index('dominant_only',trim(buffer(1:idx-1))) /= 0) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do is_dominant_only(i) = .true. source_dominant_only(i) = ' ' source_dominant_only(i)(1:ispace-idx) = buffer(idx+1:ispace-1) else if (index('df_dx',trim(buffer(1:idx-1))) /= 0) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do is_dfdx(i) = .true. source_dfdx(i) = ' ' source_dfdx(i)(1:ispace-idx) = buffer(idx+1:ispace-1) else if (index('df_dy',trim(buffer(1:idx-1))) /= 0) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do is_dfdy(i) = .true. source_dfdy(i) = ' ' source_dfdy(i)(1:ispace-idx) = buffer(idx+1:ispace-1) else if (index('z_dim_name',trim(buffer(1:idx-1))) /= 0) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do is_z_dim_name(i) = .true. source_z_dim_name(i) = ' ' source_z_dim_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1) else if (index('subgrid',trim(buffer(1:idx-1))) /= 0) then if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then is_subgrid(i) = .true. else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then is_subgrid(i) = .false. end if else if (index('flag_in_output',trim(buffer(1:idx-1))) /= 0) then ispace = idx+1 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) ispace = ispace + 1 end do is_output_flag(i) = .true. source_output_flag(i)(1:ispace-idx) = buffer(idx+1:ispace-1) else if (index('optional',trim(buffer(1:idx-1))) /= 0) then if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then is_optional(i) = .true. else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then is_subgrid(i) = .false. end if else call mprintf(.true., WARN, 'In GEOGRID.TBL, unrecognized option %s in '// & 'entry %i.',i1=idx, s1=buffer(i:idx-1)) end if end if !} index(buffer(1:eos-1),'=') /= 0 buffer = buffer(eos+1:BUFSIZE) end do ! while eos /= 0 } end if !} index(buffer, '=====') /= 0 go to 30 40 close(funit) ! Check the user specifications for gross errors if ( .not. check_data_specification() ) then call datalist_destroy() call mprintf(.true.,ERROR,'Errors were found in either index files or GEOGRID.TBL.') end if call hash_init(bad_files) return 1000 call mprintf(.true.,ERROR,'Could not open GEOGRID.TBL') 1001 call mprintf(.true.,ERROR,'Encountered error while reading GEOGRID.TBL') end subroutine get_datalist !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_source_params ! ! Purpose: For each field, this routine reads in the metadata in the index file ! for the first available resolution of data specified by res_string. Also ! based on res_string, this routine sets the interpolation sequence for the ! field. This routine should be called prior to processing a field for each ! domain. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_source_params(res_string) use stringutil implicit none ! Parameters integer, parameter :: BUFSIZE = 256 ! Arguments character (len=128), intent(in) :: res_string ! Local variables integer :: idx, i, is, ie, ispace, eos, iquoted, funit, iostatus character (len=128) :: temp_data, temp_interp character (len=256) :: test_fname character (len=BUFSIZE) :: buffer logical :: have_specification, is_used logical :: landusef_already_found character (len=128) :: cur_mminlu, previous_mminlu character (len=128), parameter :: default_mminlu = 'USGS' logical :: mminlu_found_in_this_entry landusef_already_found = .FALSE. previous_mminlu = 'NOT_YET_SET' ! For each entry in the GEOGRID.TBL file ENTRY_LOOP: do idx=1,num_entries mminlu_found_in_this_entry = .FALSE. ! Initialize metadata is_wordsize(idx) = .false. is_endian(idx) = .false. is_row_order(idx) = .false. is_fieldtype(idx) = .false. is_proj(idx) = .false. is_dx(idx) = .false. is_dy(idx) = .false. is_known_x(idx) = .false. is_known_y(idx) = .false. is_known_lat(idx) = .false. is_known_lon(idx) = .false. is_truelat1(idx) = .false. is_truelat2(idx) = .false. is_stdlon(idx) = .false. is_tile_x(idx) = .false. is_tile_y(idx) = .false. is_tile_z(idx) = .false. is_tile_z_start(idx) = .false. is_tile_z_end(idx) = .false. is_category_min(idx) = .false. is_category_max(idx) = .false. is_tile_bdr(idx) = .false. is_fieldname(idx) = .false. is_scale_factor(idx) = .false. is_units(idx) = .false. is_descr(idx) = .false. is_signed(idx) = .false. is_missing_value(idx) = .false. is_not_found(idx) = .false. ! Set the interpolator sequence for the field to be the first value in res_string that matches ! the resolution keyword for an interp_sequence specification is = 1 ie = index(res_string(is:128),'+') - 1 if (ie <= 0) ie = 128 temp_interp = res_string(is:ie) do while (.not. list_search(source_interp_option(idx), ckey=temp_interp, cvalue=source_interp_string(idx)) & .and. is <= 128) call mprintf(.true., INFORM, 'For %s, couldn''t find interpolator sequence for '// & 'resolution %s.', & s1=trim(source_fieldname(idx)), s2=trim(temp_interp)) is = ie+2 ie = is + index(res_string(is:128),'+') - 2 if (ie - is <= 0) ie = 128 temp_interp = res_string(is:ie) end do if (is > 128) then temp_interp = 'default' if (list_search(source_interp_option(idx), ckey=temp_interp, cvalue=source_interp_string(idx))) then call mprintf(.true., INFORM, 'Using default interpolator sequence for %s.', & s1=trim(source_fieldname(idx))) else if (is_optional(idx)) then is_not_found(idx) = .true. call mprintf(.true., INFORM, 'Could not find interpolator sequence for requested resolution '// & 'for this entry of %s in GEOGRID.TBL and no default interpolator was specified.',& s1=trim(source_fieldname(idx))) call mprintf(.true., INFORM, 'This entry in GEOGRID.TBL of %s is optional and will not be '// & 'processed. However, there may be other entries for %s in GEOGRID.TBL and ' // & 'thus this field may yet be processed.', s1=trim(source_fieldname(idx)), & s2=trim(source_fieldname(idx))) cycle ENTRY_LOOP else call mprintf(.true., ERROR, 'Could not find interpolator sequence for requested resolution for %s.'// & ' The sources specified in namelist.wps is not listed in GEOGRID.TBL.', & s1=trim(source_fieldname(idx))) end if end if else call mprintf(.true., INFORM, 'Using %s interpolator sequence for %s.', & s1=temp_interp, s2=trim(source_fieldname(idx))) end if ! Set the data source for the field to be the first value in res_string that matches ! the resolution keyword for an abs_path or rel_path specification is = 1 ie = index(res_string(is:128),'+') - 1 if (ie <= 0) ie = 128 temp_data = res_string(is:ie) do while (.not. list_search(source_res_path(idx), ckey=temp_data, cvalue=source_path(idx)) & .and. is <= 128) call mprintf(.true., INFORM, 'For %s, couldn''t find %s data source.', & s1=trim(source_fieldname(idx)), s2=trim(temp_data)) is = ie+2 ie = is + index(res_string(is:128),'+') - 2 if (ie - is <= 0) ie = 128 temp_data = res_string(is:ie) end do if (is > 128) then temp_data = 'default' if (list_search(source_res_path(idx), ckey=temp_data, cvalue=source_path(idx))) then call mprintf(.true., INFORM, 'Using default data source for %s.', & s1=trim(source_fieldname(idx))) else call mprintf(.true., ERROR, 'Could not find data resolution for requested resolution for %s. '// & 'The source specified in namelist.wps is not listed in GEOGRID.TBL.', & s1=trim(source_fieldname(idx))) end if else call mprintf(.true., INFORM, 'Using %s data source for %s.', & s1=temp_data, s2=trim(source_fieldname(idx))) end if source_res(idx) = temp_data call mprintf(trim(temp_data) /= trim(temp_interp),WARN,'For %s, using %s data source with %s interpolation sequence.', & s1=source_fieldname(idx), s2=temp_data, s3=temp_interp) write(test_fname, '(a)') trim(source_path(idx))//'index' ! ! Open the index file for the data source for this field, and read in metadata specs ! do funit=10,100 inquire(unit=funit, opened=is_used) if (.not. is_used) exit end do open(funit,file=trim(test_fname),form='formatted',status='old',iostat=iostatus) if (iostatus /= 0) then if (is_optional(idx)) then is_not_found(idx) = .true. call mprintf(.true.,INFORM,'Could not read ''index'' file %s for field %s', s1=trim(test_fname), & s2=trim(source_fieldname(idx))) call mprintf(.true.,INFORM,'This field is optional and will not be processed.') else call mprintf(.true.,ERROR,'Could not open %s', s1=trim(test_fname)) end if cycle ENTRY_LOOP end if 30 buffer = ' ' read(funit,'(a)',end=40, err=1001) buffer call despace(buffer) ! Is this line a comment? if (buffer(1:1) == '#') then ! Do nothing. else have_specification = .true. ! If only part of the line is a comment, just turn the comment into spaces eos = index(buffer,'#') if (eos /= 0) buffer(eos:BUFSIZE) = ' ' do while (have_specification) !{ ! If this line has no semicolon, it may contain a single specification, ! so we set have_specification = .false. to prevent the line from being ! processed again and pretend that the last character was a semicolon eos = index(buffer,';') if (eos == 0) then have_specification = .false. eos = BUFSIZE end if i = index(buffer(1:eos-1),'=') if (i /= 0) then !{ if (index('projection',trim(buffer(1:i-1))) /= 0) then if (index('lambert',trim(buffer(i+1:eos-1))) /= 0) then is_proj(idx) = .true. source_proj(idx) = PROJ_LC else if (index('polar_wgs84',trim(buffer(i+1:eos-1))) /= 0 .and. & len_trim('polar_wgs84') == len_trim(buffer(i+1:eos-1))) then is_proj(idx) = .true. source_proj(idx) = PROJ_PS_WGS84 else if (index('albers_nad83',trim(buffer(i+1:eos-1))) /= 0 .and. & len_trim('albers_nad83') == len_trim(buffer(i+1:eos-1))) then is_proj(idx) = .true. source_proj(idx) = PROJ_ALBERS_NAD83 else if (index('polar',trim(buffer(i+1:eos-1))) /= 0 .and. & len_trim('polar') == len_trim(buffer(i+1:eos-1))) then is_proj(idx) = .true. source_proj(idx) = PROJ_PS else if (index('mercator',trim(buffer(i+1:eos-1))) /= 0) then is_proj(idx) = .true. source_proj(idx) = PROJ_MERC else if (index('regular_ll',trim(buffer(i+1:eos-1))) /= 0) then is_proj(idx) = .true. source_proj(idx) = PROJ_LATLON end if else if (index('type',trim(buffer(1:i-1))) /= 0) then if (index('continuous',trim(buffer(i+1:eos-1))) /= 0) then is_fieldtype(idx) = .true. source_fieldtype(idx) = CONTINUOUS else if (index('categorical',trim(buffer(i+1:eos-1))) /= 0) then is_fieldtype(idx) = .true. source_fieldtype(idx) = CATEGORICAL end if else if (index('signed',trim(buffer(1:i-1))) /= 0) then if (index('yes',trim(buffer(i+1:eos-1))) /= 0) then is_signed(idx) = .true. else if (index('no',trim(buffer(i+1:eos-1))) /= 0) then is_signed(idx) = .false. end if else if (index('units',trim(buffer(1:i-1))) /= 0) then ispace = i+1 iquoted = 0 do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1)) if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2) ispace = ispace + 1 end do is_units(idx) = .true. source_units(idx) = ' ' if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1 if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1 source_units(idx)(1:ispace-i) = buffer(i+1:ispace-1) else if (index('description',trim(buffer(1:i-1))) /= 0) then ispace = i+1 iquoted = 0 do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1)) if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2) ispace = ispace + 1 end do is_descr(idx) = .true. source_descr(idx) = ' ' if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1 if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1 source_descr(idx)(1:ispace-i) = buffer(i+1:ispace-1) else if (index('mminlu',trim(buffer(1:i-1))) /= 0) then ispace = i+1 iquoted = 0 do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1)) if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2) ispace = ispace + 1 end do if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1 if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1 source_mminlu(1:ispace-i) = buffer(i+1:ispace-1) mminlu_found_in_this_entry = .TRUE. else if (index('iswater',trim(buffer(1:i-1))) /= 0) then read(buffer(i+1:eos-1),*) source_iswater else if (index('islake',trim(buffer(1:i-1))) /= 0) then read(buffer(i+1:eos-1),*) source_islake else if (index('isice',trim(buffer(1:i-1))) /= 0) then read(buffer(i+1:eos-1),*) source_isice else if (index('isurban',trim(buffer(1:i-1))) /= 0) then read(buffer(i+1:eos-1),*) source_isurban else if (index('isoilwater',trim(buffer(1:i-1))) /= 0) then read(buffer(i+1:eos-1),*) source_isoilwater else if (index('dx',trim(buffer(1:i-1))) /= 0) then is_dx(idx) = .true. read(buffer(i+1:eos-1),*) source_dx(idx) else if (index('dy',trim(buffer(1:i-1))) /= 0) then is_dy(idx) = .true. read(buffer(i+1:eos-1),*) source_dy(idx) else if (index('known_x',trim(buffer(1:i-1))) /= 0) then is_known_x(idx) = .true. read(buffer(i+1:eos-1),*) source_known_x(idx) else if (index('known_y',trim(buffer(1:i-1))) /= 0) then is_known_y(idx) = .true. read(buffer(i+1:eos-1),*) source_known_y(idx) else if (index('known_lat',trim(buffer(1:i-1))) /= 0) then is_known_lat(idx) = .true. read(buffer(i+1:eos-1),*) source_known_lat(idx) else if (index('known_lon',trim(buffer(1:i-1))) /= 0) then is_known_lon(idx) = .true. read(buffer(i+1:eos-1),*) source_known_lon(idx) else if (index('stdlon',trim(buffer(1:i-1))) /= 0) then is_stdlon(idx) = .true. read(buffer(i+1:eos-1),*) source_stdlon(idx) else if (index('truelat1',trim(buffer(1:i-1))) /= 0) then is_truelat1(idx) = .true. read(buffer(i+1:eos-1),*) source_truelat1(idx) else if (index('truelat2',trim(buffer(1:i-1))) /= 0) then is_truelat2(idx) = .true. read(buffer(i+1:eos-1),*) source_truelat2(idx) else if (index('wordsize',trim(buffer(1:i-1))) /= 0) then is_wordsize(idx) = .true. read(buffer(i+1:eos-1),'(i10)') source_wordsize(idx) else if (index('endian',trim(buffer(1:i-1))) /= 0) then if (index('big',trim(buffer(i+1:eos-1))) /= 0) then is_endian(idx) = .true. source_endian(idx) = BIG_ENDIAN else if (index('little',trim(buffer(i+1:eos-1))) /= 0) then is_endian(idx) = .true. source_endian(idx) = LITTLE_ENDIAN else call mprintf(.true.,WARN,'Invalid value for keyword ''endian'' '// & 'specified in index file. BIG_ENDIAN will be used.') end if else if (index('row_order',trim(buffer(1:i-1))) /= 0) then if (index('bottom_top',trim(buffer(i+1:eos-1))) /= 0) then is_row_order(idx) = .true. source_row_order(idx) = BOTTOM_TOP else if (index('top_bottom',trim(buffer(i+1:eos-1))) /= 0) then is_row_order(idx) = .true. source_row_order(idx) = TOP_BOTTOM end if else if (index('tile_x',trim(buffer(1:i-1))) /= 0) then is_tile_x(idx) = .true. read(buffer(i+1:eos-1),'(i10)') source_tile_x(idx) else if (index('tile_y',trim(buffer(1:i-1))) /= 0) then is_tile_y(idx) = .true. read(buffer(i+1:eos-1),'(i10)') source_tile_y(idx) else if (index('tile_z',trim(buffer(1:i-1))) /= 0) then is_tile_z(idx) = .true. read(buffer(i+1:eos-1),'(i10)') source_tile_z(idx) else if (index('tile_z_start',trim(buffer(1:i-1))) /= 0) then is_tile_z_start(idx) = .true. read(buffer(i+1:eos-1),'(i10)') source_tile_z_start(idx) else if (index('tile_z_end',trim(buffer(1:i-1))) /= 0) then is_tile_z_end(idx) = .true. read(buffer(i+1:eos-1),'(i10)') source_tile_z_end(idx) else if (index('filename_digits',trim(buffer(1:i-1))) /= 0) then read(buffer(i+1:eos-1),'(i10)') source_filename_digits(idx) else if (index('category_min',trim(buffer(1:i-1))) /= 0) then is_category_min(idx) = .true. read(buffer(i+1:eos-1),'(i10)') source_category_min(idx) else if (index('category_max',trim(buffer(1:i-1))) /= 0) then is_category_max(idx) = .true. read(buffer(i+1:eos-1),'(i10)') source_category_max(idx) else if (index('tile_bdr',trim(buffer(1:i-1))) /= 0) then is_tile_bdr(idx) = .true. read(buffer(i+1:eos-1),'(i10)') source_tile_bdr(idx) else if (index('missing_value',trim(buffer(1:i-1))) /= 0) then is_missing_value(idx) = .true. read(buffer(i+1:eos-1),*) source_missing_value(idx) else if (index('scale_factor',trim(buffer(1:i-1))) /= 0) then is_scale_factor(idx) = .true. read(buffer(i+1:eos-1),*) source_scale_factor(idx) else call mprintf(.true., WARN, 'In %s, unrecognized option %s in entry %i.', & s1=trim(test_fname), s2=buffer(i:i-1), i1=i) end if end if !} index(buffer(1:eos-1),'=') /= 0 buffer = buffer(eos+1:BUFSIZE) end do ! while eos /= 0 } end if !} index(buffer, '=====') /= 0 go to 30 40 close(funit) !Make sure we do not use two sources of land use data that use different !categories (e.g., USGS categories for some and NLCD2006 for others) if( trim(source_fieldname(idx)) .eq. 'LANDUSEF' ) then !If mminlu was defined for the current LANDUSEF entry then store that as the !current value, otherwise use the default value if( mminlu_found_in_this_entry ) then cur_mminlu = source_mminlu else cur_mminlu = default_mminlu end if !If a previous entry in GEOGRID.TBL already read in LANDUSEF if ( landusef_already_found ) then !Check mminlu string found for previous LANDUSEF entry to see if it matches the current entry if ( previous_mminlu .ne. cur_mminlu ) then if( mminlu_found_in_this_entry ) then !Current entry DID have an MMINLU setting !Previous LANDUSEF entry used default mminlu (either explicitly specified mminlu that is the !default or did not specify anything and defaulted to this value) if ( previous_mminlu .ne. default_mminlu ) then call mprintf(.true., ERROR, 'MMINLU values differ among input fields. Based on reading '// & '%s using entry %i from GEOGRID.TBL mminlu = %s but a previous GEOGRID.TBL ' // & 'entry resulted in mminlu being set to to %s', & s1=trim(source_fieldname(idx)),i1=idx,s2=trim(cur_mminlu), & s3=trim(previous_mminlu)) !Previous LANDUSEF entry did NOT use default mminlu else call mprintf(.true., ERROR, 'MMINLU values differ among input fields. Based on reading '// & '%s using entry %i from GEOGRID.TBL mminlu = %s but a previous GEOGRID.TBL '// & 'entry resulted in mminlu being set to (or defaulting to) %s.', & s1=trim(source_fieldname(idx)),i1=idx, & s2=trim(cur_mminlu), s3=trim(previous_mminlu)) end if !If previous LANDUSEF entry used default MMINLU !Current entry did not have an MMINLU setting else call mprintf(.true., ERROR, 'MMINLU values differ among input fields. Reading %s using ' // & 'entry %i from GEOGRID.TBL did not set mminlu, and thus the default value ' // & 'of %s is assumed. However, mminlu was previously set to %s', & s1=trim(source_fieldname(idx)),i1=idx,s2=trim(cur_mminlu), & s3=trim(previous_mminlu)) end if !If the current entry explicitly set MMINLU end if !If MMINLU associated with previous LANDUSEF entry matches current LANDUSEF entry end if !If previous GEOGRID.TBL entry already read in LANDUSEF landusef_already_found = .TRUE. previous_mminlu = cur_mminlu end if end do ENTRY_LOOP return 1001 call mprintf(.true.,ERROR,'Encountered error while reading %s', s1=trim(test_fname)) end subroutine get_source_params !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: datalist_destroy() ! ! Purpose: This routine deallocates any memory that was allocated by the ! get_datalist() subroutine. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine datalist_destroy() implicit none ! Local variables integer :: i if (associated(source_wordsize)) then deallocate(source_wordsize) deallocate(source_endian) deallocate(source_fieldtype) deallocate(source_dest_fieldtype) deallocate(source_proj) deallocate(source_priority) deallocate(source_dx) deallocate(source_dy) deallocate(source_known_x) deallocate(source_known_y) deallocate(source_known_lat) deallocate(source_known_lon) deallocate(source_truelat1) deallocate(source_truelat2) deallocate(source_stdlon) deallocate(source_fieldname) deallocate(source_path) deallocate(source_interp_string) deallocate(source_tile_x) deallocate(source_tile_y) deallocate(source_tile_z) deallocate(source_tile_z_start) deallocate(source_tile_z_end) deallocate(source_filename_digits) deallocate(source_tile_bdr) deallocate(source_category_min) deallocate(source_category_max) deallocate(source_masked) deallocate(source_output_stagger) deallocate(source_row_order) deallocate(source_dominant_category) deallocate(source_dominant_only) deallocate(source_dfdx) deallocate(source_dfdy) deallocate(source_scale_factor) deallocate(source_z_dim_name) deallocate(source_smooth_option) deallocate(source_smooth_passes) deallocate(source_units) deallocate(source_descr) deallocate(source_res) deallocate(source_missing_value) deallocate(source_fill_missing) do i=1,num_entries call list_destroy(source_res_path(i)) call list_destroy(source_interp_option(i)) call list_destroy(source_landmask_land(i)) call list_destroy(source_landmask_water(i)) end do deallocate(source_res_path) deallocate(source_interp_option) deallocate(source_landmask_land) deallocate(source_landmask_water) deallocate(source_output_flag) deallocate(is_wordsize) deallocate(is_endian) deallocate(is_fieldtype) deallocate(is_dest_fieldtype) deallocate(is_proj) deallocate(is_priority) deallocate(is_dx) deallocate(is_dy) deallocate(is_known_x) deallocate(is_known_y) deallocate(is_known_lat) deallocate(is_known_lon) deallocate(is_truelat1) deallocate(is_truelat2) deallocate(is_stdlon) deallocate(is_fieldname) deallocate(is_path) deallocate(is_tile_x) deallocate(is_tile_y) deallocate(is_tile_z) deallocate(is_tile_z_start) deallocate(is_tile_z_end) deallocate(is_tile_bdr) deallocate(is_category_min) deallocate(is_category_max) deallocate(is_masked) deallocate(is_halt_missing) deallocate(is_output_stagger) deallocate(is_row_order) deallocate(is_dominant_category) deallocate(is_dominant_only) deallocate(is_dfdx) deallocate(is_dfdy) deallocate(is_scale_factor) deallocate(is_z_dim_name) deallocate(is_smooth_option) deallocate(is_smooth_passes) deallocate(is_signed) deallocate(is_units) deallocate(is_descr) deallocate(is_missing_value) deallocate(is_fill_missing) deallocate(is_subgrid) deallocate(is_output_flag) deallocate(is_optional) deallocate(is_not_found) end if call hash_destroy(bad_files) end subroutine datalist_destroy !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: reset_next_field ! ! Purpose: To reset the pointer to the next field in the list of fields ! specified by the user. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine reset_next_field() implicit none next_field = 1 end subroutine reset_next_field !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_next_fieldname ! ! Purpose: Calling this routine results in field_name being set to the name of ! the field currently pointed to. If istatus /= 0 upon return, an error ! occurred, and the value of field_name is undefined. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_next_fieldname(field_name, istatus) implicit none ! Arguments integer, intent(out) :: istatus character (len=128), intent(out) :: field_name istatus = 1 if (next_field <= num_entries) then field_name = source_fieldname(next_field) next_field = next_field + 1 istatus = 0 end if end subroutine get_next_fieldname !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_next_output_fieldname ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine get_next_output_fieldname(nest_num, field_name, ndims, & min_cat, max_cat, istagger, memorder, & dimnames, units, description, sr_x, sr_y, & derived_from, istatus) use gridinfo_module implicit none #include "wrf_io_flags.h" ! Arguments integer, intent(in) :: nest_num integer, intent(out) :: istatus, ndims, istagger, min_cat, max_cat integer, intent(out) :: sr_x, sr_y character (len=128), intent(out) :: memorder, field_name, units, description, derived_from character (len=128), dimension(3), intent(out) :: dimnames ! Local variables integer :: temp_fieldtype integer, dimension(MAX_LANDMASK_CATEGORIES) :: landmask logical :: is_water_mask, is_dom_only character (len=128) :: domcat_name, dfdx_name, dfdy_name character (len=256) :: temphash istatus = 1 if (output_field_state == RETURN_LANDMASK) then call hash_init(duplicate_fnames) call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus) derived_from = '' last_output_fieldname(1:128) = field_name(1:128) if (istatus == 0) then temphash(129:256) = ' ' temphash(1:128) = field_name(1:128) call hash_insert(duplicate_fnames, temphash) call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus) ! We will only save the dominant category if (is_dom_only .and. (istatus == 0)) then output_field_state = RETURN_DOMCAT_LM call get_next_output_fieldname(nest_num, field_name, ndims, & min_cat, max_cat, istagger, & memorder, dimnames, units, description, & sr_x, sr_y, derived_from, istatus) return else ndims = 2 min_cat = 1 max_cat = 1 temp_fieldtype = iget_fieldtype(field_name, istatus) if (istatus == 0) then if (temp_fieldtype == CONTINUOUS) then call get_max_levels(field_name, min_cat, max_cat, istatus) else if (temp_fieldtype == CATEGORICAL) then call get_max_categories(field_name, min_cat, max_cat, istatus) end if if (max_cat - min_cat > 0) ndims = 3 end if call get_output_stagger(field_name, istagger, istatus) if (istagger == M) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' else if (istagger == U) then dimnames(1) = 'west_east_stag' dimnames(2) = 'south_north' else if (istagger == V) then dimnames(1) = 'west_east' dimnames(2) = 'south_north_stag' else if (istagger == HH) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' else if (istagger == VV) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' end if if (ndims == 2) then memorder = 'XY ' dimnames(3) = ' ' else if (ndims == 3) then memorder = 'XYZ' call get_z_dim_name(field_name, dimnames(3), istatus) istatus = 0 else memorder = ' ' dimnames(3) = ' ' end if call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus) call get_source_units(field_name, 1, units, istatus) if (istatus /= 0) units = '-' call get_source_descr(field_name, 1, description, istatus) if (istatus /= 0) description = '-' istatus = 0 output_field_state = RETURN_DOMCAT_LM end if else output_field_state = RETURN_FIELDNAME call get_next_output_fieldname(nest_num, field_name, ndims, & min_cat, max_cat, istagger, & memorder, dimnames, units, description, & sr_x, sr_y, derived_from, istatus) return end if else if (output_field_state == RETURN_FIELDNAME) then call get_next_fieldname(field_name, istatus) derived_from = '' last_output_fieldname(1:128) = field_name(1:128) temphash(129:256) = ' ' temphash(1:128) = field_name(1:128) if (istatus == 0 .and. (.not. hash_search(duplicate_fnames, temphash))) then call hash_insert(duplicate_fnames, temphash) call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus) ! We will only save the dominant category if (is_dom_only .and. (istatus == 0)) then output_field_state = RETURN_DOMCAT call get_next_output_fieldname(nest_num, field_name, ndims, & min_cat, max_cat, istagger, & memorder, dimnames, units, description, & sr_x, sr_y, derived_from, istatus) return ! Return the fractional field else ndims = 2 min_cat = 1 max_cat = 1 temp_fieldtype = iget_fieldtype(field_name, istatus) if (istatus == 0) then if (temp_fieldtype == CONTINUOUS) then call get_max_levels(field_name, min_cat, max_cat, istatus) else if (temp_fieldtype == CATEGORICAL) then call get_max_categories(field_name, min_cat, max_cat, istatus) end if if (max_cat - min_cat > 0) ndims = 3 end if call get_output_stagger(field_name, istagger, istatus) if (istagger == M) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' else if (istagger == U) then dimnames(1) = 'west_east_stag' dimnames(2) = 'south_north' else if (istagger == V) then dimnames(1) = 'west_east' dimnames(2) = 'south_north_stag' else if (istagger == HH) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' else if (istagger == VV) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' end if if (ndims == 2) then memorder = 'XY ' dimnames(3) = ' ' else if (ndims == 3) then memorder = 'XYZ' call get_z_dim_name(field_name, dimnames(3), istatus) istatus = 0 else memorder = ' ' dimnames(3) = ' ' end if call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus) call get_source_units(field_name, 1, units, istatus) if (istatus /= 0) units = '-' call get_source_descr(field_name, 1, description, istatus) if (istatus /= 0) description = '-' istatus = 0 output_field_state = RETURN_DOMCAT end if else if (istatus /= 0) then output_field_state = RETURN_LANDMASK call hash_destroy(duplicate_fnames) return else if (hash_search(duplicate_fnames, temphash)) then call get_next_output_fieldname(nest_num, field_name, ndims, & min_cat, max_cat, istagger, & memorder, dimnames, units, description, & sr_x, sr_y, derived_from, istatus) return end if else if (output_field_state == RETURN_DOMCAT .or. & output_field_state == RETURN_DOMCAT_LM ) then derived_from = last_output_fieldname if (output_field_state == RETURN_DOMCAT) then next_field = next_field - 1 call get_next_fieldname(field_name, istatus) else call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus) end if if (istatus == 0) then call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus) if (istatus == 0) then ndims = 2 min_cat = 1 max_cat = 1 call get_output_stagger(field_name, istagger, istatus) if (istagger == M) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' else if (istagger == U) then dimnames(1) = 'west_east_stag' dimnames(2) = 'south_north' else if (istagger == V) then dimnames(1) = 'west_east' dimnames(2) = 'south_north_stag' else if (istagger == HH) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' else if (istagger == VV) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' end if dimnames(3) = ' ' memorder = 'XY ' call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus) field_name = domcat_name units = 'category' description = 'Dominant category' if (output_field_state == RETURN_DOMCAT) then output_field_state = RETURN_DFDX else output_field_state = RETURN_DFDX_LM end if else if (output_field_state == RETURN_DOMCAT) then output_field_state = RETURN_DFDX else output_field_state = RETURN_DFDX_LM end if call get_next_output_fieldname(nest_num, field_name, ndims, & min_cat, max_cat, istagger, & memorder, dimnames, units, description, & sr_x, sr_y, derived_from, istatus) return end if else call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DOMCAT, '// & 'but no field name is found.') end if else if (output_field_state == RETURN_DFDX .or. & output_field_state == RETURN_DFDX_LM) then derived_from = last_output_fieldname if (output_field_state == RETURN_DFDX) then next_field = next_field - 1 call get_next_fieldname(field_name, istatus) else call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus) end if if (istatus == 0) then call get_dfdx_name(field_name, dfdx_name, istatus) if (istatus == 0) then ndims = 2 min_cat = 1 max_cat = 1 temp_fieldtype = iget_fieldtype(field_name, istatus) if (istatus == 0) then if (temp_fieldtype == CONTINUOUS) then call get_max_levels(field_name, min_cat, max_cat, istatus) else if (temp_fieldtype == CATEGORICAL) then call get_max_categories(field_name, min_cat, max_cat, istatus) end if if (max_cat - min_cat > 0) ndims = 3 end if call get_output_stagger(field_name, istagger, istatus) if (istagger == M) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' else if (istagger == U) then dimnames(1) = 'west_east_stag' dimnames(2) = 'south_north' else if (istagger == V) then dimnames(1) = 'west_east' dimnames(2) = 'south_north_stag' else if (istagger == HH) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' else if (istagger == VV) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' end if if (ndims == 2) then memorder = 'XY ' dimnames(3) = ' ' else if (ndims == 3) then memorder = 'XYZ' call get_z_dim_name(field_name, dimnames(3), istatus) istatus = 0 else memorder = ' ' dimnames(3) = ' ' end if !---------- B. Kosovic 2016-10-28 ---- Changes begin ! The following two lines of code are in the wrong place resulting in ! incorrect size of the dfdx array on the nested domain(s) ! field_name = dfdx_name ! units = '-' call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus) ! Correct location of the two lines of code is below (see also dfdy) field_name = dfdx_name units = '-' !---------- B. Kosovic 2016-10-28 ----- End of changes description = 'df/dx' if (output_field_state == RETURN_DFDX) then output_field_state = RETURN_DFDY else output_field_state = RETURN_DFDY_LM end if else if (output_field_state == RETURN_DFDX) then output_field_state = RETURN_DFDY else output_field_state = RETURN_DFDY_LM end if call get_next_output_fieldname(nest_num, field_name, ndims, & min_cat, max_cat, istagger, & memorder, dimnames, units, description, & sr_x, sr_y, derived_from, istatus) return end if else call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DFDX, '// & 'but no field name is found.') end if else if (output_field_state == RETURN_DFDY .or. & output_field_state == RETURN_DFDY_LM) then derived_from = last_output_fieldname if (output_field_state == RETURN_DFDY) then next_field = next_field - 1 call get_next_fieldname(field_name, istatus) else call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus) end if if (istatus == 0) then call get_dfdy_name(field_name, dfdy_name, istatus) if (istatus == 0) then ndims = 2 min_cat = 1 max_cat = 1 temp_fieldtype = iget_fieldtype(field_name, istatus) if (istatus == 0) then if (temp_fieldtype == CONTINUOUS) then call get_max_levels(field_name, min_cat, max_cat, istatus) else if (temp_fieldtype == CATEGORICAL) then call get_max_categories(field_name, min_cat, max_cat, istatus) end if if (max_cat - min_cat > 0) ndims = 3 end if call get_output_stagger(field_name, istagger, istatus) if (istagger == M) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' else if (istagger == U) then dimnames(1) = 'west_east_stag' dimnames(2) = 'south_north' else if (istagger == V) then dimnames(1) = 'west_east' dimnames(2) = 'south_north_stag' else if (istagger == HH) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' else if (istagger == VV) then dimnames(1) = 'west_east' dimnames(2) = 'south_north' end if if (ndims == 2) then memorder = 'XY ' dimnames(3) = ' ' else if (ndims == 3) then memorder = 'XYZ' call get_z_dim_name(field_name, dimnames(3), istatus) istatus = 0 else memorder = ' ' dimnames(3) = ' ' end if call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus) field_name = dfdy_name units = '-' description = 'df/dy' output_field_state = RETURN_FIELDNAME else output_field_state = RETURN_FIELDNAME call get_next_output_fieldname(nest_num, field_name, ndims, & min_cat, max_cat, istagger, & memorder, dimnames, units, description, & sr_x, sr_y, derived_from, istatus) return end if else call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DFDY, but no '// & 'field name is found.') end if end if end subroutine get_next_output_fieldname !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_landmask_field ! ! Purpose: To return the name of the field from which the landmask is to be ! computed. If no error occurs, is_water_mask is .true. if the landmask ! value specifies the value of water, and .false. if the landmask value ! specifies the value of land. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_landmask_field(res_string, landmask_name, is_water_mask, landmask, istatus) implicit none ! Arguments character (len=128), intent(in) :: res_string integer, dimension(:), intent(out) :: landmask integer, intent(out) :: istatus logical, intent(out) :: is_water_mask character (len=128), intent(out) :: landmask_name ! Local variables integer :: j integer :: ilen integer :: idx integer :: is, ie, sos, eos, comma character (len=128) :: temp_res, mask_cat_string istatus = 1 do idx=1,num_entries if (list_length(source_landmask_land(idx)) > 0) then is = 1 ie = index(res_string(is:128),'+') - 1 if (ie <= 0) ie = 128 temp_res = res_string(is:ie) do while (.not. list_search(source_landmask_land(idx), ckey=temp_res, cvalue=mask_cat_string) & .and. is <= 128) is = ie+2 ie = is + index(res_string(is:128),'+') - 2 if (ie - is <= 0) ie = 128 temp_res = res_string(is:ie) end do if (is > 128) then temp_res = 'default' if (list_search(source_landmask_land(idx), ckey=temp_res, cvalue=mask_cat_string)) then is_water_mask = .false. landmask_name = source_fieldname(idx) istatus = 0 end if else is_water_mask = .false. landmask_name = source_fieldname(idx) istatus = 0 end if end if ! Note: The following cannot be an else-if, since different resolutions of data may ! specify, alternately, a land or a water mask, and in general we need to search ! both lists if (list_length(source_landmask_water(idx)) > 0) then is = 1 ie = index(res_string(is:128),'+') - 1 if (ie <= 0) ie = 128 temp_res = res_string(is:ie) do while (.not. list_search(source_landmask_water(idx), ckey=temp_res, cvalue=mask_cat_string) & .and. is <= 128) is = ie+2 ie = is + index(res_string(is:128),'+') - 2 if (ie - is <= 0) ie = 128 temp_res = res_string(is:ie) end do if (is > 128) then temp_res = 'default' if (list_search(source_landmask_water(idx), ckey=temp_res, cvalue=mask_cat_string)) then is_water_mask = .true. landmask_name = source_fieldname(idx) istatus = 0 end if else is_water_mask = .true. landmask_name = source_fieldname(idx) istatus = 0 end if end if if (istatus == 0) then j = 1 sos = 0 eos = 128 comma = index(mask_cat_string(sos+1:eos-1),',') do while (comma > 0 .and. j < MAX_LANDMASK_CATEGORIES) read(mask_cat_string(sos+1:sos+comma-1),'(i10)') landmask(j) sos = sos + comma comma = index(mask_cat_string(sos+1:eos-1),',') j = j + 1 end do read(mask_cat_string(sos+1:eos-1),'(i10)') landmask(j) j = j + 1 if (j <= MAX_LANDMASK_CATEGORIES) then ! Terminate list with a flag value landmask(j) = INVALID end if exit end if end do end subroutine get_landmask_field !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_missing_value ! ! Pupose: Return the value used in the source data to indicate missing data. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_missing_value(fieldnm, ilevel, rmissing, istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: istatus real, intent(out) :: rmissing character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. & (source_priority(idx) == ilevel)) then if (is_missing_value(idx)) then rmissing = source_missing_value(idx) istatus = 0 exit end if end if end do end subroutine get_missing_value !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_source_units ! ! Pupose: Return a string giving the units of the specified source data. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_source_units(fieldnm, ilevel, cunits, istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: istatus character (len=128), intent(in) :: fieldnm character (len=128), intent(out) :: cunits ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. & (source_priority(idx) == ilevel)) then if (is_units(idx)) then cunits = source_units(idx) istatus = 0 exit end if end if end do end subroutine get_source_units !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_source_descr ! ! Pupose: Return a string giving a description of the specified source data. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_source_descr(fieldnm, ilevel, descr, istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: istatus character (len=128), intent(in) :: fieldnm character (len=128), intent(out) :: descr ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. & (source_priority(idx) == ilevel)) then if (is_units(idx)) then descr = source_descr(idx) istatus = 0 exit end if end if end do end subroutine get_source_descr !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_missing_fill_value ! ! Pupose: Return the value to fill missing points with. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_missing_fill_value(fieldnm, rmissing, istatus) implicit none ! Arguments integer, intent(out) :: istatus real, intent(out) :: rmissing character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) ) then if (is_fill_missing(idx)) then rmissing = source_fill_missing(idx) istatus = 0 exit end if end if end do end subroutine get_missing_fill_value !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_halt_on_missing ! ! Pupose: Returns 1 if the program should halt upon encountering a missing ! value in the final output field, and 0 otherwise. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_halt_on_missing(fieldnm, halt, istatus) implicit none ! Arguments integer, intent(out) :: istatus logical, intent(out) :: halt character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx istatus = 0 halt = .false. do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) ) then if (is_halt_missing(idx)) halt = .true. end if end do end subroutine get_halt_on_missing !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_masked_value ! ! Pupose: If the field is to be masked by the landmask, returns 0 if the field ! is masked over water and 1 if the field is masked over land. If no mask is ! to be applied, -1 is returned. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_masked_value(fieldnm, ilevel, masked, istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: istatus real, intent(out) :: masked character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx istatus = 0 masked = -1. do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. & (source_priority(idx) == ilevel)) then if (is_masked(idx)) then masked = source_masked(idx) exit end if end if end do end subroutine get_masked_value !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_max_levels ! ! Purpose: Returns the number of levels for the field given by fieldnm. ! The number of levels will generally be specified for continuous fields, ! whereas min/max category will generally be specified for categorical ones. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_max_levels(fieldnm, min_level, max_level, istatus) implicit none ! Arguments integer, intent(out) :: min_level, max_level, istatus character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx logical :: have_found_field have_found_field = .false. istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (is_dest_fieldtype(idx) .and. (source_dest_fieldtype(idx) /= CONTINUOUS)) then call mprintf(.true., WARN, 'In GEOGRID.TBL, destination field type for %s is '// & 'not continuous and min/max levels specified.', s1=trim(fieldnm)) end if if (.not. have_found_field) then if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then have_found_field = .true. istatus = 0 min_level = source_tile_z_start(idx) max_level = source_tile_z_end(idx) else if (is_tile_z(idx)) then have_found_field = .true. istatus = 0 min_level = 1 max_level = source_tile_z(idx) end if if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// & 'and tile_z_end specified for entry %i.',i1=idx) end if end if else if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then if (source_tile_z_start(idx) < min_level) min_level = source_tile_z_start(idx) if (source_tile_z_end(idx) > max_level) max_level = source_tile_z_end(idx) else if (is_tile_z(idx)) then if (min_level > 1) min_level = 1 if (source_tile_z(idx) > max_level) max_level = source_tile_z(idx) end if if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// & 'and tile_z_end specified for entry %i.',i1=idx) end if end if end if end if end do end subroutine get_max_levels !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_source_levels ! ! Purpose: Return the min and max z-index for the source data for fieldname ! at a specified priority level (compared with the min/max level over ! all priority levels, as given by get_max_levels). !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_source_levels(fieldnm, ilevel, min_level, max_level, istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: min_level, max_level, istatus character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (ilevel == source_priority(idx)) then if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then istatus = 0 min_level = source_tile_z_start(idx) max_level = source_tile_z_end(idx) else if (is_tile_z(idx)) then istatus = 0 min_level = 1 max_level = source_tile_z(idx) end if if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// & 'and tile_z_end specified for entry %i.',i1=idx) end if end if end if end if end do end subroutine get_source_levels !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_max_categories ! ! Purpose: Returns the minimum category and the maximum category for the field ! given by fieldnm. ! Min/max category will generally be specified for categorical fields, ! whereas the number of levels will generally be specified for continuous ! fields. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_max_categories(fieldnm, min_category, max_category, istatus) implicit none ! Arguments integer, intent(out) :: min_category, max_category, istatus character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx logical :: have_found_field have_found_field = .false. istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (is_dest_fieldtype(idx) .and. (source_dest_fieldtype(idx) /= CATEGORICAL)) then call mprintf(.true., WARN, & 'In GEOGRID.TBL, cannot get min/max categories for continuous '// & 'field %s at entry %i. Perhaps the user has requested to '// & 'perform a strange operation on the field.', s1=trim(fieldnm), i1=idx) end if if (.not. have_found_field) then if (is_category_min(idx) .and. is_category_max(idx)) then have_found_field = .true. istatus = 0 min_category = source_category_min(idx) max_category = source_category_max(idx) else if (is_category_min(idx) .or. is_category_max(idx)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category and '// & 'max_category specified for entry %i.',i1=idx) end if else if (is_category_min(idx) .and. is_category_max(idx)) then if (source_category_min(idx) < min_category) min_category = source_category_min(idx) if (source_category_max(idx) > max_category) max_category = source_category_max(idx) else if (is_category_min(idx) .or. is_category_max(idx)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category and '// & 'max_category specified for entry %i.',i1=idx) end if end if end if end do end subroutine get_max_categories !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_source_categories ! ! Purpose: Return the min and max category for the source data for fieldname ! at a specified priority level (compared with the min/max category over ! all priority levels, as given by get_max_categories). !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_source_categories(fieldnm, ilevel, min_category, max_category, istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: min_category, max_category, istatus character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (ilevel == source_priority(idx)) then if (is_category_min(idx) .and. is_category_max(idx)) then istatus = 0 min_category = source_category_min(idx) max_category = source_category_max(idx) else if (is_category_min(idx) .or. is_category_max(idx)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category '// & 'and max_category specified for entry %i.',i1=idx) end if end if end if end do end subroutine get_source_categories !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_domcategory_name ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_domcategory_name(fieldnm, domcat_name, ldominant_only, istatus) implicit none ! Arguments integer, intent(out) :: istatus logical, intent(out) :: ldominant_only character (len=128), intent(in) :: fieldnm character (len=128), intent(out) :: domcat_name ! Local variables integer :: idx istatus = 1 ldominant_only = .false. do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (is_dominant_category(idx)) then domcat_name = source_dominant_category(idx) istatus = 0 if (is_dominant_only(idx)) then call mprintf(.true., WARN, 'In GEOGRID.TBL, both dominant_category and '// & 'dominant_only are specified in entry %i. Using specification '// & 'for dominant_category.',i1=idx) is_dominant_only(idx) = .false. end if exit else if (is_dominant_only(idx)) then domcat_name = source_dominant_only(idx) ldominant_only = .true. istatus = 0 exit end if end if end do end subroutine get_domcategory_name !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_dfdx_name ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_dfdx_name(fieldnm, dfdx_name, istatus) implicit none ! Arguments integer, intent(out) :: istatus character (len=128), intent(in) :: fieldnm character (len=128), intent(out) :: dfdx_name ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (is_dfdx(idx)) then dfdx_name = source_dfdx(idx) istatus = 0 exit end if end if end do end subroutine get_dfdx_name !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_dfdy_name ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_dfdy_name(fieldnm, dfdy_name, istatus) implicit none ! Arguments integer, intent(out) :: istatus character (len=128), intent(in) :: fieldnm character (len=128), intent(out) :: dfdy_name ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (is_dfdy(idx)) then dfdy_name = source_dfdy(idx) istatus = 0 exit end if end if end do end subroutine get_dfdy_name !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_z_dim_name ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_z_dim_name(fieldnm, z_dim, istatus) implicit none ! Arguments integer, intent(out) :: istatus character (len=128), intent(in) :: fieldnm character (len=128), intent(out) :: z_dim ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (is_z_dim_name(idx)) then z_dim = source_z_dim_name(idx) istatus = 0 exit end if end if end do end subroutine get_z_dim_name !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_field_scale_factor ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_field_scale_factor(fieldnm, ilevel, scale_factor, istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: istatus real, intent(out) :: scale_factor character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. & (ilevel == source_priority(idx))) then if (is_scale_factor(idx)) then scale_factor = source_scale_factor(idx) istatus = 0 end if end if end do end subroutine get_field_scale_factor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_output_stagger ! ! Pupose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_output_stagger(fieldnm, istagger, istatus) use gridinfo_module implicit none ! Arguments integer, intent(out) :: istatus, istagger character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (is_output_stagger(idx)) then istatus = 0 istagger = source_output_stagger(idx) exit else if (gridtype == 'C') then istatus = 0 istagger = M exit else if (gridtype == 'E') then istatus = 0 istagger = HH exit end if end if end if end do end subroutine get_output_stagger !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_subgrid_dim_name ! ! Pupose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_subgrid_dim_name(nest_num, field_name, dimnames, & sub_x, sub_y, istatus) use gridinfo_module implicit none integer, intent(in) :: nest_num integer, intent(out) :: sub_x, sub_y, istatus character(len=128), intent(in) :: field_name character(len=128), dimension(2), intent(inout) :: dimnames integer :: idx, nlen sub_x = 1 sub_y = 1 istatus = 0 do idx=1,num_entries if ((index(source_fieldname(idx),trim(field_name)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(field_name))) then if (is_subgrid(idx)) then istatus = 0 if (is_output_stagger(idx)) then call mprintf(.true.,ERROR,'Cannot use subgrids on variables with staggered grids') end if dimnames(1) = trim(dimnames(1))//"_subgrid" dimnames(2) = trim(dimnames(2))//"_subgrid" sub_x = subgrid_ratio_x(nest_num) sub_y = subgrid_ratio_y(nest_num) end if end if end do end subroutine get_subgrid_dim_name !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_output_flag ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_output_flag(fieldnm, output_flag, istatus) implicit none ! Arguments integer, intent(out) :: istatus character (len=*), intent(in) :: fieldnm character (len=128), intent(out) :: output_flag ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (is_output_flag(idx)) then output_flag = source_output_flag(idx) istatus = 0 exit end if end if end do end subroutine get_output_flag !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_interp_option ! ! Pupose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_interp_option(fieldnm, ilevel, interp_opt, istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: istatus character (len=128), intent(in) :: fieldnm character (len=128), intent(out) :: interp_opt ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (ilevel == source_priority(idx)) then interp_opt = source_interp_string(idx) istatus = 0 exit end if end if end do end subroutine get_interp_option !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_gcel_threshold ! ! Pupose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_gcell_threshold(interp_opt, threshold, istatus) implicit none ! Arguments integer, intent(out) :: istatus real, intent(out) :: threshold character (len=128), intent(in) :: interp_opt ! Local variables integer :: i, p1, p2 istatus = 1 threshold = 1.0 i = index(interp_opt,'average_gcell') if (i /= 0) then ! Move the "average_gcell" option to the beginning ! if (i /= 1) then ! p1 = ! end if ! Check for a threshold p1 = index(interp_opt(i:128),'(') p2 = index(interp_opt(i:128),')') if (p1 /= 0 .and. p2 /= 0) then read(interp_opt(p1+1:p2-1),*,err=1000) threshold else call mprintf(.true., WARN, 'Problem with specified threshold '// & 'for average_gcell interp option. Setting threshold to 0.0.') threshold = 0.0 end if end if istatus = 0 return 1000 call mprintf(.true., ERROR, 'Threshold option to average_gcell interpolator '// & 'must be a real number, enclosed in parentheses immediately '// & 'after keyword "average_gcell"') end subroutine get_gcell_threshold !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_smooth_option ! ! Pupose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_smooth_option(fieldnm, smooth_opt, smooth_passes, istatus) implicit none ! Arguments integer, intent(out) :: istatus, smooth_opt, smooth_passes character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (is_smooth_option(idx)) then istatus = 0 smooth_opt = source_smooth_option(idx) if (is_smooth_passes(idx)) then smooth_passes = source_smooth_passes(idx) else smooth_passes = 1 end if exit end if end if end do end subroutine get_smooth_option !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: iget_fieldtype ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function iget_fieldtype(fieldnm, istatus) implicit none ! Arguments integer, intent(out) :: istatus character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx ! Return value integer :: iget_fieldtype istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (is_dest_fieldtype(idx)) then iget_fieldtype = source_dest_fieldtype(idx) istatus = 0 exit end if end if end do end function iget_fieldtype !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: iget_source_fieldtype ! ! Purpose: Given a resolution, in degrees, and the name of a field, this ! function returns the type (categorical, continuous, etc.) of the source ! data that will be used. This may, in general, depend on the field name ! and the resolution; for example, near 30 second resolution, land use data ! may come from a categorical field, whereas for lower resolutions, it may ! come from arrays of land use fractions for each category. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function iget_source_fieldtype(fieldnm, ilevel, istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: istatus character (len=128), intent(in) :: fieldnm ! Return value integer :: iget_source_fieldtype ! Local variables integer :: idx ! Find information about the source tiles for the specified fieldname istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (ilevel == source_priority(idx)) then istatus = 0 iget_source_fieldtype = source_fieldtype(idx) exit end if end if end do end function iget_source_fieldtype !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_data_tile ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_data_tile(xlat, xlon, ilevel, field_name, & file_name, array, start_x_dim, end_x_dim, start_y_dim, & end_y_dim, start_z_dim, end_z_dim, npts_bdr, & istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: istatus integer, intent(out) :: start_x_dim, end_x_dim, & start_y_dim, end_y_dim, & start_z_dim, end_z_dim, & npts_bdr real, intent(in) :: xlat, xlon ! Location that tile should contain real, pointer, dimension(:,:,:) :: array ! The array to be allocated by this routine character (len=128), intent(in) :: field_name character (len=256), intent(out) :: file_name ! Local variables integer :: j, k integer :: local_wordsize, local_endian, sign_convention, irow_order, strlen integer :: xdim,ydim,zdim real :: scalefac real, allocatable, dimension(:) :: temprow call get_tile_fname(file_name, xlat, xlon, ilevel, field_name, istatus) if (index(file_name, 'OUTSIDE') /= 0) then istatus = 1 return else if (hash_search(bad_files, file_name)) then istatus = 1 return end if call get_tile_dimensions(xlat, xlon, start_x_dim, end_x_dim, start_y_dim, end_y_dim, & start_z_dim, end_z_dim, npts_bdr, local_wordsize, local_endian, & sign_convention, ilevel, field_name, istatus) xdim = (end_x_dim-start_x_dim+1) ydim = (end_y_dim-start_y_dim+1) zdim = (end_z_dim-start_z_dim+1) if (associated(array)) deallocate(array) allocate(array(xdim,ydim,zdim)) call get_row_order(field_name, ilevel, irow_order, istatus) if (istatus /= 0) irow_order = BOTTOM_TOP call s_len(file_name,strlen) scalefac = 1.0 call read_geogrid(file_name, strlen, array, xdim, ydim, zdim, & sign_convention, local_endian, scalefac, local_wordsize, istatus) if (irow_order == TOP_BOTTOM) then allocate(temprow(xdim)) do k=1,zdim do j=1,ydim if (ydim-j+1 <= j) exit temprow(1:xdim) = array(1:xdim,j,k) array(1:xdim,j,k) = array(1:xdim,ydim-j+1,k) array(1:xdim,ydim-j+1,k) = temprow(1:xdim) end do end do deallocate(temprow) end if if (istatus /= 0) then start_x_dim = INVALID start_y_dim = INVALID end_x_dim = INVALID end_y_dim = INVALID call hash_insert(bad_files, file_name) end if end subroutine get_data_tile !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_row_order !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_row_order(fieldnm, ilevel, irow_order, istatus) implicit none ! Arguments integer, intent(in) :: ilevel character (len=128), intent(in) :: fieldnm integer, intent(out) :: irow_order, istatus ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (ilevel == source_priority(idx)) then if (is_row_order(idx)) then irow_order = source_row_order(idx) istatus = 0 exit end if end if end if end do end subroutine get_row_order !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_tile_dimensions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_tile_dimensions(xlat, xlon, start_x_dim, end_x_dim, start_y_dim, end_y_dim, & start_z_dim, end_z_dim, npts_bdr, bytes_per_datum, endianness, & sign_convention, ilevel, fieldnm, istatus) use llxy_module implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: start_x_dim, end_x_dim, & start_y_dim, end_y_dim, & start_z_dim, end_z_dim, & npts_bdr, & bytes_per_datum, endianness, & sign_convention, istatus real, intent(in) :: xlat, xlon character (len=128), intent(in) :: fieldnm ! Local variables integer :: idx, current_domain real :: rx, ry istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (ilevel == source_priority(idx)) then istatus = 0 exit end if end if end do if (istatus /= 0) then start_x_dim = 1 start_y_dim = 1 start_z_dim = 1 end_x_dim = 1 end_y_dim = 1 end_z_dim = 1 bytes_per_datum = 0 return end if current_domain = iget_selected_domain() call select_domain(SOURCE_PROJ) call lltoxy(xlat, xlon, rx, ry, M) call select_domain(current_domain) start_x_dim = source_tile_x(idx) * nint(real(floor((rx-0.5) / real(source_tile_x(idx))))) + 1 end_x_dim = start_x_dim + source_tile_x(idx) - 1 start_y_dim = source_tile_y(idx) * nint(real(floor((ry-0.5) / real(source_tile_y(idx))))) + 1 end_y_dim = start_y_dim + source_tile_y(idx) - 1 if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then start_z_dim = source_tile_z_start(idx) end_z_dim = source_tile_z_end(idx) else if (is_tile_z(idx)) then start_z_dim = 1 end_z_dim = source_tile_z(idx) end if if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start and '// & 'tile_z_end specified for entry %i.',i1=idx) end if end if if (is_tile_bdr(idx)) then npts_bdr = source_tile_bdr(idx) else npts_bdr = 0 end if start_x_dim = start_x_dim - npts_bdr end_x_dim = end_x_dim + npts_bdr start_y_dim = start_y_dim - npts_bdr end_y_dim = end_y_dim + npts_bdr if (is_wordsize(idx)) then bytes_per_datum = source_wordsize(idx) else bytes_per_datum = 1 call mprintf(.true.,ERROR,'In GEOGRID.TBL, no wordsize specified for data in entry %i.',i1=idx) end if if (is_endian(idx)) then endianness = source_endian(idx) else endianness = BIG_ENDIAN end if if (is_signed(idx)) then sign_convention = 1 else sign_convention = 0 end if end subroutine get_tile_dimensions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_tile_fname ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_tile_fname(test_fname, xlat, xlon, ilevel, fieldname, istatus) use llxy_module use gridinfo_module implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: istatus real, intent(in) :: xlat, xlon character (len=*), intent(in) :: fieldname character (len=256), intent(out) :: test_fname ! Local variables integer :: current_domain, idx real :: rx, ry istatus = 1 write(test_fname, '(a)') 'TILE.OUTSIDE.DOMAIN' do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldname)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldname))) then if (ilevel == source_priority(idx)) then istatus = 0 exit end if end if end do if (istatus /= 0) return current_domain = iget_selected_domain() call select_domain(SOURCE_PROJ) call lltoxy(xlat, xlon, rx, ry, M) call select_domain(current_domain) ! rx = real(source_tile_x(idx)) * real(floor((rx-0.5*source_dx(idx))/ real(source_tile_x(idx)))) + 1.0 ! ry = real(source_tile_y(idx)) * real(floor((ry-0.5*source_dy(idx))/ real(source_tile_y(idx)))) + 1.0 rx = real(source_tile_x(idx)) * real(floor((rx-0.5) / real(source_tile_x(idx)))) + 1.0 ry = real(source_tile_y(idx)) * real(floor((ry-0.5) / real(source_tile_y(idx)))) + 1.0 if (rx > 0. .and. ry > 0.) then select case(source_filename_digits(idx)) case (5) write(test_fname, '(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(source_path(idx)), & nint(rx),'-',nint(rx)+source_tile_x(idx)-1,'.',nint(ry),'-',nint(ry)+source_tile_y(idx)-1 case (6) write(test_fname, '(a,i6.6,a1,i6.6,a1,i6.6,a1,i6.6)') trim(source_path(idx)), & nint(rx),'-',nint(rx)+source_tile_x(idx)-1,'.',nint(ry),'-',nint(ry)+source_tile_y(idx)-1 case default call mprintf(.true., ERROR, 'In GEOGRID.TBL, for index file of data at '// & 'entry %i, filename_digits must be either 5 or 6.', i1=idx) istatus = 1 return end select end if end subroutine get_tile_fname !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_source_resolution ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_source_resolution(fieldnm, ilevel, src_dx, src_dy, istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: istatus real, intent(out) :: src_dx, src_dy character (len=*), intent(in) :: fieldnm ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (ilevel == source_priority(idx)) then if (is_dx(idx) .and. is_dy(idx)) then src_dx = source_dx(idx) src_dy = source_dy(idx) if (source_proj(idx) /= PROJ_LATLON) then src_dx = src_dx / 111000. src_dy = src_dy / 111000. end if istatus = 0 exit end if end if end if end do end subroutine get_source_resolution !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: check_priority_level ! ! Purpose: Determines whether there exists the specified priority level for ! the specified field. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine check_priority_level(fieldnm, ilevel, istatus) implicit none ! Arguments character (len=*), intent(in) :: fieldnm integer, intent(in) :: ilevel integer, intent(out) :: istatus ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (ilevel == source_priority(idx)) then istatus = 0 end if end if end do end subroutine check_priority_level !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_data_projection ! ! Purpose: To acquire the parameters necessary in defining the grid on which ! the user-specified data for field 'fieldnm' are given. ! ! NOTES: If the routine successfully acquires values for all necessary ! parameters, istatus is set to 0. In case of an error, ! OR IF THE USER HAS NOT SPECIFIED A TILE OF DATA FOR FIELDNM, ! istatus is set to 1. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_data_projection(fieldnm, iproj, stand_lon, truelat1, truelat2, & dxkm, dykm, known_x, known_y, known_lat, known_lon, ilevel, istatus) implicit none ! Arguments integer, intent(in) :: ilevel integer, intent(out) :: iproj, istatus real, intent(out) :: stand_lon, truelat1, truelat2, dxkm, dykm, & known_x, known_y, known_lat, known_lon character (len=*), intent(in) :: fieldnm ! Local variables integer :: idx istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (ilevel == source_priority(idx)) then istatus = 0 if (is_proj(idx)) then iproj = source_proj(idx) else iproj = 1 call mprintf(.true., ERROR, & 'In GEOGRID.TBL, no specification for projection in entry %i.',i1=idx) end if if (is_known_x(idx)) then known_x = source_known_x(idx) else known_x = 1. call mprintf(.true., ERROR, & 'In GEOGRID.TBL, no specification for known_x in entry %i.',i1=idx) end if if (is_known_y(idx)) then known_y = source_known_y(idx) else known_y = 1. call mprintf(.true., ERROR, & 'In GEOGRID.TBL, no specification for known_y in entry %i.',i1=idx) end if if (is_known_lat(idx)) then known_lat = source_known_lat(idx) else known_lat = 1. call mprintf(.true., ERROR, & 'In GEOGRID.TBL, no specification for known_lat in entry %i.',i1=idx) end if if (is_known_lon(idx)) then known_lon = source_known_lon(idx) else known_lon = 1. call mprintf(.true., ERROR, & 'In GEOGRID.TBL, no specification for known_lon in entry %i.',i1=idx) end if if (is_truelat1(idx)) then truelat1 = source_truelat1(idx) else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then truelat1 = 1. call mprintf(.true., WARN, & 'In GEOGRID.TBL, no specification for truelat1 in entry %i.',i1=idx) end if if (is_truelat2(idx)) then truelat2 = source_truelat2(idx) else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then truelat2 = 1. call mprintf(.true., WARN, & 'In GEOGRID.TBL, no specification for truelat2 in entry %i.',i1=idx) end if if (is_stdlon(idx)) then stand_lon = source_stdlon(idx) else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then stand_lon = 1. call mprintf(.true., WARN, & 'In GEOGRID.TBL, no specification for stdlon in entry %i.',i1=idx) end if if (is_dx(idx)) then dxkm = source_dx(idx) else dxkm = 1. call mprintf(.true., ERROR, & 'In GEOGRID.TBL, no specification for dx in entry %i.',i1=idx) end if if (is_dy(idx)) then dykm = source_dy(idx) else dykm = 1. call mprintf(.true., ERROR, & 'In GEOGRID.TBL, no specification for dy in entry %i.',i1=idx) end if exit end if end if end do end subroutine get_data_projection !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: get_source_opt_status ! ! Purpose: Determines whether a field is optional and can be skipped ! ! If ilevel is specified as 0, the return value, istatus, will be 0 if ! any priority level is available for the field, and 1 otherwise. Otherwise, ! istatus will be set to 0 only if the specified priority level for ! the field is available. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_source_opt_status(fieldnm, ilevel, istatus) implicit none ! Arguments character (len=*), intent(in) :: fieldnm integer, intent(in) :: ilevel integer, intent(out) :: istatus ! Local variables integer :: idx ! Any priority level is available if (ilevel == 0) then istatus = 1 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (.not. is_not_found(idx)) then istatus = 0 exit end if end if end do ! Only the specified level is to be checked else istatus = 0 do idx=1,num_entries if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then if (ilevel == source_priority(idx)) then if (is_not_found(idx)) then istatus = 1 exit end if end if end if end do end if end subroutine get_source_opt_status !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: check_data_specification ! ! Purpose: To check for obvious errors in the user source data specifications. ! Returns .true. if specification passes all checks, and .false. otherwise. ! For failing checks, diagnostic messages are printed. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function check_data_specification( ) implicit none ! Return value logical :: check_data_specification ! Local variables integer :: i, j, istatus integer, pointer, dimension(:) :: priorities real :: rmissing logical :: begin_priority, halt character (len=128) :: cur_name check_data_specification = .false. ! Check that each specification has a name, priority level, and path do i=1,num_entries if (.not. is_fieldname(i)) then call mprintf(.true., ERROR, & 'In GEOGRID.TBL, specification %i does not have a name.',i1=i) end if if (.not. is_priority(i)) then call mprintf(.true., ERROR, & 'In GEOGRID.TBL, specification %i does not have a priority.',i1=i) end if if (list_length(source_res_path(i)) == 0) then call mprintf(.true., ERROR, & 'In GEOGRID.TBL, no path (relative or absolute) is specified '// & 'for entry %i.',i1=i) end if end do ! The fill_missing and halt_on_missing options are mutually exclusive do i=1,num_entries call get_halt_on_missing(source_fieldname(i), halt, istatus) call get_missing_fill_value(source_fieldname(i), rmissing, istatus) if (halt .and. (istatus == 0)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, the halt_on_missing and fill_missing '// & 'options are mutually exclusive, but both are given for field %s', & s1=trim(source_fieldname(i))) end if end do ! Check that the field from which landmask is calculated is not output on a staggering do i=1,num_entries if (list_length(source_landmask_land(i)) > 0 .or. list_length(source_landmask_water(i)) > 0) then if (is_output_stagger(i)) then if (source_output_stagger(i) /= M) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be derived from '// & 'a field that is computed on a staggered grid at entry %i.',i1=i) end if end if end if end do ! Also check that any field that is to be masked by the landmask is not output on a staggering do i=1,num_entries if (is_masked(i) .and. is_output_stagger(i)) then if (source_output_stagger(i) /= M) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be used with '// & 'a field that is computed on a staggered grid at entry %i.',i1=i) end if end if end do allocate(priorities(num_entries)) ! Now check that priorities for each source are unique and in the interval [1,n], n <= num_entries do i=1,num_entries priorities = 0 cur_name = source_fieldname(i) do j=1,num_entries if (source_fieldname(j) == cur_name) then if (source_priority(j) > num_entries .or. source_priority(j) < 1) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, priorities for %s do not '// & 'form a sequence 1,2,...,n.', s1=trim(cur_name)) else if (priorities(source_priority(j)) == 1) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, more than one entry for %s '// & 'has priority %i.', s1=trim(cur_name), i1=source_priority(j)) else priorities(source_priority(j)) = 1 end if end if end if end do begin_priority = .false. do j=num_entries,1,-1 if (.not.begin_priority .and. priorities(j) == 1) then begin_priority = .true. else if (begin_priority .and. priorities(j) == 0) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, no entry for %s has '// & 'priority %i, but an entry has priority %i.', & s1=trim(cur_name), i1=j, i2=j+1) end if end do end do deallocate(priorities) ! Units must match for all priority levels of a field do i=1,num_entries if (source_priority(i) == 1) then do j=1,num_entries if ((source_fieldname(i) == source_fieldname(j)) .and. & (source_units(i) /= source_units(j))) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, units for %s at entry %i '// & 'do not match units at entry %i (%s)', & s1=trim(source_fieldname(i)), i1=j, i2=i, s2=trim(source_units(i))) end if end do end if end do ! Make sure that user has not asked to calculate landmask from a continuous field do i=1,num_entries if (is_dest_fieldtype(i)) then if (source_dest_fieldtype(i) == CONTINUOUS) then if (list_length(source_landmask_water(i)) > 0 .or. list_length(source_landmask_land(i)) > 0) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be '// & 'calculated from a continuous destination field at entry %i.',i1=i) end if end if end if end do ! If either min_category or max_category is specified, then both must be specified do i=1,num_entries if (is_category_min(i) .or. is_category_max(i)) then if (.not. is_category_min(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, for index file of data at '// & 'entry %i, category_max is specified, but category_min is '// & 'not. Both must be specified.',i1=i) else if (.not. is_category_max(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, for index file of data at '// & 'entry %i, category_min is specified, but category_max is '// & 'not. Both must be specified.',i1=i) end if end if end do ! For continuous data, (category_max - category_min + 1) should equal tile_z do i=1,num_entries if (is_fieldtype(i)) then if (source_fieldtype(i) == CONTINUOUS) then if (is_category_max(i) .and. is_category_min(i) .and. is_tile_z(i)) then if (source_tile_z(i) /= (source_category_max(i) - source_category_min(i) + 1)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, tile_z must equal '// & '(category_max - category_min + 1) at entry %i.',i1=i) end if else if (is_category_max(i) .and. is_category_min(i) .and. & is_tile_z_start(i) .and. is_tile_z_end(i)) then if (source_tile_z_end(i) /= source_category_max(i) .or. & source_tile_z_start(i) /= source_category_min(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, tile_z_end must equal '// & 'category_max, and tile_z_start must equal category_min '// & 'at entry %i.',i1=i) end if end if end if end if end do ! Make sure that user has not named a dominant category or computed slope field ! the same as a fractional field do i=1,num_entries if (source_dominant_category(i) == source_fieldname(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category cannot have '// & 'the same name as the field at entry %i.',i1=i) end if do j=1,num_entries if (.not. is_dominant_only(i)) then if (is_dfdx(j)) then if (source_dfdx(j) == source_fieldname(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, field name at entry %i '// & 'cannot have the same name as the slope field df_dx at entry %i.', & i1=i, i2=j) end if end if if (is_dfdy(j)) then if (source_dfdy(j) == source_fieldname(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, field name at entry %i '// & 'cannot have the same name as the slope field df_dy at entry %i.', & i1=i, i2=j) end if end if if (is_dfdx(j) .and. is_dominant_category(i)) then if (source_dfdx(j) == source_dominant_category(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// & 'entry %i cannot have the same name as the slope field df_dx '// & 'at entry %i.',i1=i, i2=j) end if end if if (is_dfdy(j) .and. is_dominant_category(i)) then if (source_dfdy(j) == source_dominant_category(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// & 'entry %i cannot have the same name as the slope field '// & 'df_dy at entry %i.',i1=i, i2=j) end if end if else if (is_dfdx(j)) then if (source_dfdx(j) == source_dominant_only(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// & 'entry %i cannot have the same name as the slope field '// & 'df_dx at entry %i.',i1=i, i2=j) end if end if if (is_dfdy(j)) then if (source_dfdy(j) == source_dominant_only(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// & 'entry %i cannot have the same name as the slope field '// & 'df_dy at entry %i.',i1=i, i2=j) end if end if end if if (i /= j) then if (is_dfdx(i)) then if (is_dfdx(j)) then if (source_dfdx(j) == source_dfdx(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dx at '// & 'entry %i cannot have the same name as the slope '// & 'field df_dx at entry %i.',i1=i, i2=j) end if end if if (is_dfdy(j)) then if (source_dfdy(j) == source_dfdx(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dx at '// & 'entry %i cannot have the same name as the slope field '// & 'df_dy at entry %i.',i1=i, i2=j) end if end if end if if (is_dfdy(i)) then if (is_dfdx(j)) then if (source_dfdx(j) == source_dfdy(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dy at '// & 'entry %i cannot have the same name as the slope field '// & 'df_dx at entry %i.',i1=i, i2=j) end if end if if (is_dfdy(j)) then if (source_dfdy(j) == source_dfdy(i)) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dy at '// & 'entry %i cannot have the same name as the slope field '// & 'df_dy at entry %i.',i1=i, i2=j) end if end if end if if (is_dominant_category(i)) then if (source_dominant_category(i) == source_fieldname(j)) then ! Possible exception if (.not. (is_dominant_only(j) .and. (source_dominant_category(i) /= source_dominant_only(j)))) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at '// & 'entry %i cannot have the same name as the field at '// & 'entry %i.',i1=i, i2=j) end if else if (is_dominant_category(j) .and. & (source_dominant_category(i) == source_dominant_category(j))) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at entry '// & '%i cannot have the same name as dominant category at '// & 'entry %i.',i1=i, i2=j) else if (is_dominant_only(j) .and. & (source_dominant_category(i) == source_dominant_only(j))) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at '// & 'entry %i cannot have the same name as dominant_only '// & 'category at entry %i.',i1=i, i2=j) end if else if (is_dominant_only(i)) then if (source_dominant_only(i) == source_fieldname(j)) then ! Possible exception if (.not. (is_dominant_only(j) .and. (source_dominant_only(i) /= source_dominant_only(j)))) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// & 'at entry %i cannot have the same name as the field at '// & 'entry %i.',i1=i, i2=j) end if else if (is_dominant_category(j) .and. & (source_dominant_only(i) == source_dominant_category(j))) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// & 'at entry %i cannot have the same name as dominant '// & 'category at entry %i.',i1=i, i2=j) else if (is_dominant_only(j) .and. & (source_dominant_only(i) == source_dominant_only(j))) then call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// & 'at entry %i cannot have the same name as dominant_only '// & 'category at entry %i.',i1=i, i2=j) end if end if end if end do end do check_data_specification = .true. end function check_data_specification !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: s_len ! ! Purpose: This routine receives a fortran string, and returns the number of ! characters in the string before the first "space" is encountered. It ! considers ascii characters 33 to 126 to be valid characters, and ascii ! 0 to 32, and 127 to be "space" characters. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine s_len(string, s_length) implicit none ! Arguments character (len=*), intent(in) :: string integer, intent(out) :: s_length ! Local variables integer :: i, len_str, aval logical :: space space = .false. i = 1 len_str = len(string) s_length = len_str do while ((i .le. len_str) .and. (.not. space)) aval = ichar(string(i:i)) if ((aval .lt. 33) .or. (aval .gt. 126)) then s_length = i - 1 space = .true. endif i = i + 1 enddo end subroutine s_len !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: display_optional_field_msgs ! ! Purpose: This routine prints out information regarding any optional fields ! in the GEOGRID.TBL file that were not found at run-time and were ! skipped. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine display_optional_field_msgs() implicit none integer :: idx logical :: do_prints do_prints = .false. do idx=1,num_entries if (is_optional(idx) .and. is_not_found(idx)) then do_prints = .true. exit end if end do if (do_prints) then call mprintf(.true., STDOUT, ' ') call mprintf(.true., STDOUT, ' Optional fields not processed by geogrid:') call mprintf(.true., LOGFILE, 'Optional fields not processed by geogrid:') do idx=1,num_entries if (is_optional(idx) .and. is_not_found(idx)) then call mprintf(.true., STDOUT, ' %s (priority=%i, resolution=''%s'', path=''%s'')', s1=source_fieldname(idx), & i1=source_priority(idx), s2=source_res(idx), s3=source_path(idx)) call mprintf(.true., LOGFILE, ' %s (priority=%i, resolution=''%s'', path=''%s'')', s1=source_fieldname(idx), & i1=source_priority(idx), s2=source_res(idx), s3=source_path(idx)) end if end do call mprintf(.true., STDOUT, ' ') end if end subroutine display_optional_field_msgs end module source_data_module