metgrid/src/interp_option_module.F

   1 module interp_option_module
   2
   3    use gridinfo_module
   4    use list_module
   5    use misc_definitions_module
   6    use module_debug
   7    use stringutil
   8
   9    integer, parameter :: BUFSIZE=128
  10
  11    integer :: num_entries
  12    integer, pointer, dimension(:) :: output_stagger
  13    real, pointer, dimension(:) :: masked, fill_missing, missing_value, &
  14                     interp_mask_val, interp_land_mask_val, interp_water_mask_val
  15    logical, pointer, dimension(:) :: output_this_field, is_u_field, is_v_field, is_derived_field, is_mandatory
  16    character (len=128), pointer, dimension(:) :: fieldname, interp_method, v_interp_method, &
  17                     interp_mask, interp_land_mask, interp_water_mask, &
  18                     flag_in_output, output_name, from_input, z_dim_name, level_template, &
  19                     mpas_name
  20    character (len=1), pointer, dimension(:) :: interp_mask_relational, interp_land_mask_relational, interp_water_mask_relational
  21    type (list), pointer, dimension(:) :: fill_lev_list
  22    type (list) :: flag_in_output_list
  23
  24    contains
  25
  26    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  27    ! Name: read_interp_table
  28    !
  29    ! Purpose:
  30    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  31    subroutine read_interp_table()
  32
  33       ! Local variables
  34       integer :: i, p1, p2, idx, eos, ispace, funit, istatus, nparams, s1, s2
  35       logical :: is_used, have_specification
  36       character (len=128) :: lev_string, fill_string, flag_string, flag_val
  37       character (len=BUFSIZE) :: buffer
  38
  39       do funit=10,100
  40          inquire(unit=funit, opened=is_used)
  41          if (.not. is_used) exit
  42       end do
  43
  44       nparams = 0
  45       num_entries = 0
  46
  47       open(funit, file=trim(opt_metgrid_tbl_path)//'METGRID.TBL', form='formatted', status='old', err=1001)
  48       istatus = 0
  49       do while (istatus == 0)
  50          read(funit, '(a)', iostat=istatus) buffer
  51          if (istatus == 0) then
  52             call despace(buffer)
  53
  54             ! Is this line a comment?
  55             if (buffer(1:1) == '#') then
  56
  57             ! Are we beginning a new field specification?
  58             else if (index(buffer,'=====') /= 0) then
  59                if (nparams > 0) num_entries = num_entries + 1
  60                nparams = 0
  61
  62             else
  63                eos = index(buffer,'#')
  64                if (eos /= 0) buffer(eos:BUFSIZE) = ' '
  65
  66                ! Does this line contain at least one parameter specification?
  67                if (index(buffer,'=') /= 0) then
  68                   nparams = nparams + 1
  69                end if
  70             end if
  71
  72          end if
  73       end do
  74
  75       rewind(funit)
  76
  77       ! Allocate one extra array element to act as the default
  78 ! BUG: Maybe this will not be necessary if we move to a module with query routines for
  79 !  parsing the METGRID.TBL
  80       num_entries = num_entries + 1
  81
  82       allocate(fieldname(num_entries))
  83       allocate(mpas_name(num_entries))
  84       allocate(interp_method(num_entries))
  85       allocate(v_interp_method(num_entries))
  86       allocate(masked(num_entries))
  87       allocate(fill_missing(num_entries))
  88       allocate(missing_value(num_entries))
  89       allocate(fill_lev_list(num_entries))
  90       allocate(interp_mask(num_entries))
  91       allocate(interp_land_mask(num_entries))
  92       allocate(interp_water_mask(num_entries))
  93       allocate(interp_mask_val(num_entries))
  94       allocate(interp_land_mask_val(num_entries))
  95       allocate(interp_water_mask_val(num_entries))
  96       allocate(interp_mask_relational(num_entries))
  97       allocate(interp_land_mask_relational(num_entries))
  98       allocate(interp_water_mask_relational(num_entries))
  99       allocate(level_template(num_entries))
 100       allocate(flag_in_output(num_entries))
 101       allocate(output_name(num_entries))
 102       allocate(from_input(num_entries))
 103       allocate(z_dim_name(num_entries))
 104       allocate(output_stagger(num_entries))
 105       allocate(output_this_field(num_entries))
 106       allocate(is_u_field(num_entries))
 107       allocate(is_v_field(num_entries))
 108       allocate(is_derived_field(num_entries))
 109       allocate(is_mandatory(num_entries))
 110
 111       !
 112       ! Set default values
 113       !
 114       do i=1,num_entries
 115          fieldname(i) = ' '
 116          mpas_name(i) = ' '
 117          flag_in_output(i) = ' '
 118          output_name(i) = ' '
 119          from_input(i) = '*'
 120          z_dim_name(i) = 'num_metgrid_levels'
 121          interp_method(i) = 'nearest_neighbor'
 122          v_interp_method(i) = 'linear_log_p'
 123          masked(i) = NOT_MASKED
 124          fill_missing(i) = NAN
 125          missing_value(i) = NAN
 126          call list_init(fill_lev_list(i))
 127          interp_mask(i) = ' '
 128          interp_land_mask(i) = ' '
 129          interp_water_mask(i) = ' '
 130          interp_mask_val(i) = NAN
 131          interp_land_mask_val(i) = NAN
 132          interp_water_mask_val(i) = NAN
 133          interp_mask_relational(i) = ' '
 134          interp_land_mask_relational(i) = ' '
 135          interp_water_mask_relational(i) = ' '
 136          level_template(i) = ' '
 137          if (gridtype == 'C') then
 138             output_stagger(i) = M
 139          else if (gridtype == 'E') then
 140             output_stagger(i) = HH
 141          end if
 142          output_this_field(i) = .true.
 143          is_u_field(i) = .false.
 144          is_v_field(i) = .false.
 145          is_derived_field(i) = .false.
 146          is_mandatory(i) = .false.
 147       end do
 148       call list_init(flag_in_output_list)
 149
 150       i = 1
 151       istatus = 0
 152       nparams = 0
 153
 154       do while (istatus == 0)
 155          buffer = ' '
 156          read(funit, '(a)', iostat=istatus) buffer
 157          if (istatus == 0) then
 158             call despace(buffer)
 159
 160             ! Is this line a comment?
 161             if (buffer(1:1) == '#') then
 162                ! Do nothing.
 163
 164             ! Are we beginning a new field specification?
 165             else if (index(buffer,'=====') /= 0) then   !{
 166                if (nparams > 0) i = i + 1
 167                nparams = 0
 168
 169             else
 170                ! Check whether the current line is a comment
 171                if (buffer(1:1) /= '#') then
 172                  have_specification = .true.
 173                else
 174                  have_specification = .false.
 175                end if
 176
 177                ! If only part of the line is a comment, just turn the comment into spaces
 178                eos = index(buffer,'#')
 179                if (eos /= 0) buffer(eos:BUFSIZE) = ' '
 180
 181                do while (have_specification)   !{
 182
 183                   ! If this line has no semicolon, it may contain a single specification,
 184                   !   so we set have_specification = .false. to prevent the line from being
 185                   !   processed again and "pretend" that the last character was a semicolon
 186                   eos = index(buffer,';')
 187                   if (eos == 0) then
 188                     have_specification = .false.
 189                     eos = BUFSIZE
 190                   end if
 191
 192                   idx = index(buffer(1:eos-1),'=')
 193
 194                   if (idx /= 0) then   !{
 195                      nparams = nparams + 1
 196
 197                      if (index('name',trim(buffer(1:idx-1))) /= 0 .and. &
 198                          len_trim('name') == len_trim(buffer(1:idx-1))) then
 199                         ispace = idx+1
 200                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 201                            ispace = ispace + 1
 202                         end do
 203                         fieldname(i) = ' '
 204                         fieldname(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
 205
 206                      else if (index('mpas_name',trim(buffer(1:idx-1))) /= 0 .and. &
 207                          len_trim('mpas_name') == len_trim(buffer(1:idx-1))) then
 208                         ispace = idx+1
 209                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 210                            ispace = ispace + 1
 211                         end do
 212                         mpas_name(i) = ' '
 213                         mpas_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
 214
 215                      else if (index('from_input',trim(buffer(1:idx-1))) /= 0 .and. &
 216                          len_trim('from_input') == len_trim(buffer(1:idx-1))) then
 217                         ispace = idx+1
 218                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 219                            ispace = ispace + 1
 220                         end do
 221                         from_input(i) = ' '
 222                         from_input(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
 223
 224                      else if (index('z_dim_name',trim(buffer(1:idx-1))) /= 0 .and. &
 225                          len_trim('z_dim_name') == len_trim(buffer(1:idx-1))) then
 226                         ispace = idx+1
 227                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 228                            ispace = ispace + 1
 229                         end do
 230                         z_dim_name(i) = ' '
 231                         z_dim_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
 232
 233                      else if (index('output_stagger',trim(buffer(1:idx-1))) /= 0 .and. &
 234                          len_trim('output_stagger') == len_trim(buffer(1:idx-1))) then
 235                         if (index('M',trim(buffer(idx+1:eos-1))) /= 0) then
 236                            output_stagger(i) = M
 237                         else if (index('U',trim(buffer(idx+1:eos-1))) /= 0) then
 238                            output_stagger(i) = U
 239                         else if (index('V',trim(buffer(idx+1:eos-1))) /= 0) then
 240                            output_stagger(i) = V
 241                         else if (index('HH',trim(buffer(idx+1:eos-1))) /= 0) then
 242                            output_stagger(i) = HH
 243                         else if (index('VV',trim(buffer(idx+1:eos-1))) /= 0) then
 244                            output_stagger(i) = VV
 245                         end if
 246
 247                      else if (index('output',trim(buffer(1:idx-1))) /= 0 .and. &
 248                          len_trim('output') == len_trim(buffer(1:idx-1))) then
 249                         if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
 250                            output_this_field(i) = .true.
 251                         else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
 252                            output_this_field(i) = .false.
 253                         end if
 254
 255                      else if (index('is_u_field',trim(buffer(1:idx-1))) /= 0 .and. &
 256                          len_trim('is_u_field') == len_trim(buffer(1:idx-1))) then
 257                         if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
 258                            is_u_field(i) = .true.
 259                         else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
 260                            is_u_field(i) = .false.
 261                         end if
 262
 263                      else if (index('is_v_field',trim(buffer(1:idx-1))) /= 0 .and. &
 264                          len_trim('is_v_field') == len_trim(buffer(1:idx-1))) then
 265                         if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
 266                            is_v_field(i) = .true.
 267                         else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
 268                            is_v_field(i) = .false.
 269                         end if
 270
 271                      else if (index('derived',trim(buffer(1:idx-1))) /= 0 .and. &
 272                          len_trim('derived') == len_trim(buffer(1:idx-1))) then
 273                         if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
 274                            is_derived_field(i) = .true.
 275                         else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
 276                            is_derived_field(i) = .false.
 277                         end if
 278
 279                      else if (index('mandatory',trim(buffer(1:idx-1))) /= 0 .and. &
 280                          len_trim('mandatory') == len_trim(buffer(1:idx-1))) then
 281                         if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
 282                            is_mandatory(i) = .true.
 283                         else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
 284                            is_mandatory(i) = .false.
 285                         end if
 286
 287                      else if (index('interp_option',trim(buffer(1:idx-1))) /= 0 .and. &
 288                          len_trim('interp_option') == len_trim(buffer(1:idx-1))) then
 289                         ispace = idx+1
 290                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 291                            ispace = ispace + 1
 292                         end do
 293                         interp_method(i) = ' '
 294                         interp_method(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
 295
 296                      else if (index('vertical_interp_option',trim(buffer(1:idx-1))) /= 0 .and. &
 297                          len_trim('vertical_interp_option') == len_trim(buffer(1:idx-1))) then
 298                         ispace = idx+1
 299                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 300                            ispace = ispace + 1
 301                         end do
 302                         v_interp_method(i) = ' '
 303                         v_interp_method(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
 304
 305                      else if (index('level_template',trim(buffer(1:idx-1))) /= 0 .and. &
 306                          len_trim('level_template') == len_trim(buffer(1:idx-1))) then
 307                         ispace = idx+1
 308                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 309                            ispace = ispace + 1
 310                         end do
 311                         level_template(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
 312
 313                      else if (index('interp_mask',trim(buffer(1:idx-1))) /= 0 .and. &
 314                          len_trim('interp_mask') == len_trim(buffer(1:idx-1))) then
 315                         ispace = idx+1
 316                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 317                            ispace = ispace + 1
 318                         end do
 319                         p1 = index(buffer(idx+1:ispace-1),'(')
 320                         p2 = index(buffer(idx+1:ispace-1),')')
 321                         s1 = index(buffer(idx+1:ispace-1),'<')
 322                         s2 = index(buffer(idx+1:ispace-1),'>')
 323                         if (p1 == 0 .or. p2 == 0) then
 324                            call mprintf(.true.,WARN, &
 325                                         'Problem in specifying interp_mask flag. Setting masked flag to 0.')
 326                            interp_mask(i) = ' '
 327                            interp_mask(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
 328                            interp_mask_val(i) = 0
 329                         else
 330                            ! Parenthesis found; additionally, there may be a relational symbol
 331                            if ((s1 /= 0) .OR. (s2 /= 0)) then
 332                               if (s1 > 0) then
 333                                  interp_mask_relational(i) = buffer(idx+s1:idx+s1)
 334                               else if (s2 > 0) then
 335                                  interp_mask_relational(i) = buffer(idx+s2:idx+s2)
 336                               end if
 337                               interp_mask(i) = ' '
 338                               interp_mask(i)(1:p1) = buffer(idx+1:idx+p1-1)
 339                               read(buffer(idx+p1+2:idx+p2-1),*,err=1000) interp_mask_val(i)
 340                            else
 341                               ! No relational symbol
 342                               interp_mask(i) = ' '
 343                               interp_mask(i)(1:p1) = buffer(idx+1:idx+p1-1)
 344                               read(buffer(idx+p1+1:idx+p2-1),*,err=1000) interp_mask_val(i)
 345                            end if
 346                         end if
 347
 348                      else if (index('interp_land_mask',trim(buffer(1:idx-1))) /= 0 .and. &
 349                          len_trim('interp_land_mask') == len_trim(buffer(1:idx-1))) then
 350                         ispace = idx+1
 351                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 352                            ispace = ispace + 1
 353                         end do
 354                         p1 = index(buffer(idx+1:ispace-1),'(')
 355                         p2 = index(buffer(idx+1:ispace-1),')')
 356                         s1 = index(buffer(idx+1:ispace-1),'<')
 357                         s2 = index(buffer(idx+1:ispace-1),'>')
 358                         if (p1 == 0 .or. p2 == 0) then
 359                            call mprintf(.true.,WARN, &
 360                                         'Problem in specifying interp_land_mask flag. Setting masked flag to 0.')
 361                            interp_land_mask(i) = ' '
 362                            interp_land_mask(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
 363                            interp_land_mask_val(i) = 0
 364                         else
 365                            ! Parenthesis found; additionally, there may be a relational symbol
 366                            if ((s1 /= 0) .OR. (s2 /= 0)) then
 367                               if (s1 > 0) then
 368                                  interp_land_mask_relational(i) = buffer(idx+s1:idx+s1)
 369                               else if (s2 > 0) then
 370                                  interp_land_mask_relational(i) = buffer(idx+s2:idx+s2)
 371                               end if
 372                               interp_land_mask(i) = ' '
 373                               interp_land_mask(i)(1:p1) = buffer(idx+1:idx+p1-1)
 374                               read(buffer(idx+p1+2:idx+p2-1),*,err=1000) interp_land_mask_val(i)
 375                            else
 376                               ! No relational symbol
 377                               interp_land_mask(i) = ' '
 378                               interp_land_mask(i)(1:p1) = buffer(idx+1:idx+p1-1)
 379                               read(buffer(idx+p1+1:idx+p2-1),*,err=1000) interp_land_mask_val(i)
 380                            end if
 381                         end if
 382
 383                      else if (index('interp_water_mask',trim(buffer(1:idx-1))) /= 0 .and. &
 384                          len_trim('interp_water_mask') == len_trim(buffer(1:idx-1))) then
 385                         ispace = idx+1
 386                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 387                            ispace = ispace + 1
 388                         end do
 389                         p1 = index(buffer(idx+1:ispace-1),'(')
 390                         p2 = index(buffer(idx+1:ispace-1),')')
 391                         s1 = index(buffer(idx+1:ispace-1),'<')
 392                         s2 = index(buffer(idx+1:ispace-1),'>')
 393                         if (p1 == 0 .or. p2 == 0) then
 394                            call mprintf(.true.,WARN, &
 395                                         'Problem in specifying interp_water_mask flag. Setting masked flag to 0.')
 396                            interp_water_mask(i) = ' '
 397                            interp_water_mask(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
 398                            interp_water_mask_val(i) = 0
 399                         else
 400                            ! Parenthesis found; additionally, there may be a relational symbol
 401                            if ((s1 /= 0) .OR. (s2 /= 0)) then
 402                               if (s1 > 0) then
 403                                  interp_water_mask_relational(i) = buffer(idx+s1:idx+s1)
 404                               else if (s2 > 0) then
 405                                  interp_water_mask_relational(i) = buffer(idx+s2:idx+s2)
 406                               end if
 407                               interp_water_mask(i) = ' '
 408                               interp_water_mask(i)(1:p1) = buffer(idx+1:idx+p1-1)
 409                               read(buffer(idx+p1+2:idx+p2-1),*,err=1000) interp_water_mask_val(i)
 410                            else
 411                               ! No relational symbol
 412                               interp_water_mask(i) = ' '
 413                               interp_water_mask(i)(1:p1) = buffer(idx+1:idx+p1-1)
 414                               read(buffer(idx+p1+1:idx+p2-1),*,err=1000) interp_water_mask_val(i)
 415                            end if
 416                         end if
 417
 418                      else if (index('masked',trim(buffer(1:idx-1))) /= 0 .and. &
 419                          len_trim('masked') == len_trim(buffer(1:idx-1))) then
 420                         if (index('water',trim(buffer(idx+1:eos-1))) /= 0) then
 421                            masked(i) = MASKED_WATER
 422                         else if (index('land',trim(buffer(idx+1:eos-1))) /= 0) then
 423                            masked(i) = MASKED_LAND
 424                         else if (index('both',trim(buffer(idx+1:eos-1))) /= 0) then
 425                            masked(i) = MASKED_BOTH
 426                         end if
 427
 428                      else if (index('flag_in_output',trim(buffer(1:idx-1))) /= 0 .and. &
 429                          len_trim('flag_in_output') == len_trim(buffer(1:idx-1))) then
 430                         flag_string = ' '
 431                         flag_string(1:eos-idx-1) = buffer(idx+1:eos-1)
 432                         if (list_search(flag_in_output_list, ckey=flag_string, cvalue=flag_val)) then
 433                            call mprintf(.true.,WARN, 'In METGRID.TBL, %s is given as a flag more than once.', &
 434                                         s1=flag_string)
 435                            flag_in_output(i)(1:eos-idx-1) = buffer(idx+1:eos-1)
 436                         else
 437                            flag_in_output(i)(1:eos-idx-1) = buffer(idx+1:eos-1)
 438                            write(flag_val,'(i1)') 1
 439                            call list_insert(flag_in_output_list, ckey=flag_string, cvalue=flag_val)
 440                         end if
 441
 442                      else if (index('output_name',trim(buffer(1:idx-1))) /= 0 .and. &
 443                          len_trim('output_name') == len_trim(buffer(1:idx-1))) then
 444                         ispace = idx+1
 445                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 446                            ispace = ispace + 1
 447                         end do
 448                         output_name(i) = ' '
 449                         output_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
 450
 451                      else if (index('fill_missing',trim(buffer(1:idx-1))) /= 0 .and. &
 452                          len_trim('fill_missing') == len_trim(buffer(1:idx-1))) then
 453                         read(buffer(idx+1:eos-1),*) fill_missing(i)
 454
 455                      else if (index('missing_value',trim(buffer(1:idx-1))) /= 0 .and. &
 456                          len_trim('missing_value') == len_trim(buffer(1:idx-1))) then
 457                         read(buffer(idx+1:eos-1),*) missing_value(i)
 458
 459                      else if (index('fill_lev',trim(buffer(1:idx-1))) /= 0 .and. &
 460                          len_trim('fill_lev') == len_trim(buffer(1:idx-1))) then
 461                         ispace = idx+1
 462                         do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
 463                            ispace = ispace + 1
 464                         end do
 465                         fill_string = ' '
 466                         fill_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
 467                         ispace = index(fill_string,':')
 468                         if (ispace /= 0) then
 469                            write(lev_string,'(a)') fill_string(1:ispace-1)
 470                         else
 471                            write(lev_string,'(a)') 'all'
 472                         end if
 473                         write(fill_string,'(a)') trim(fill_string(ispace+1:128))
 474                         fill_string(128-ispace:128) = ' '
 475                         call list_insert(fill_lev_list(i), ckey=lev_string, cvalue=fill_string)
 476
 477                      else
 478                         call mprintf(.true.,WARN, 'In METGRID.TBL, unrecognized option %s in entry %i.', s1=buffer(1:idx-1), i1=idx)
 479                      end if
 480
 481                   end if   !} index(buffer(1:eos-1),'=') /= 0
 482
 483 ! BUG: If buffer has non-whitespace characters but no =, then maybe a wrong specification?
 484
 485                   buffer = buffer(eos+1:BUFSIZE)
 486                end do   ! while eos /= 0 }
 487
 488             end if   !} index(buffer, '=====') /= 0
 489
 490          end if
 491       end do
 492
 493       call check_table_specs()
 494
 495       close(funit)
 496
 497       return
 498
 499    1000 call mprintf(.true.,ERROR,'The mask value of the interp_mask specification must '// &
 500                      'be a real value, enclosed in parentheses immediately after the field name.')
 501
 502    1001 call mprintf(.true.,ERROR,'Could not open file METGRID.TBL')
 503    1002 call mprintf(.true.,ERROR,'Symbol expected < >. Check METGRID.TBL for missing symbol or erroreous entry')
 504
 505    end subroutine read_interp_table
 506
 507
 508    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 509    ! Name: check_table_specs
 510    !
 511    ! Pupose: Perform basic consistency and sanity checks on the METGRID.TBL
 512    !         entries supplied by the user.
 513    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 514    subroutine check_table_specs()
 515
 516       implicit none
 517
 518       ! Local variables
 519       integer :: i
 520
 521       do i=1,num_entries
 522
 523          ! For C grid, U field must be on U staggering, and V field must be on
 524          !   V staggering; for E grid, U and V must be on VV staggering.
 525          if (gridtype == 'C') then
 526             if (is_u_field(i) .and. output_stagger(i) /= U) then
 527                call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind U-component field '// &
 528                             'must be interpolated to the U staggered grid points.',i1=i)
 529             else if (is_v_field(i) .and. output_stagger(i) /= V) then
 530                call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind V-component field '// &
 531                             'must be interpolated to the V staggered grid points.',i1=i)
 532             end if
 533
 534             if (output_stagger(i) == VV) then
 535                call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, VV is not a valid output staggering for ARW.',i1=i)
 536             else if (output_stagger(i) == HH) then
 537                call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, HH is not a valid output staggering for ARW.',i1=i)
 538             end if
 539
 540             if (masked(i) /= NOT_MASKED .and. output_stagger(i) /= M) then
 541                call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, staggered output field '// &
 542                             'cannot use the ''masked'' option.',i1=i)
 543             end if
 544
 545          else if (gridtype == 'E') then
 546             if (is_u_field(i) .and. output_stagger(i) /= VV) then
 547                call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind U-component field '// &
 548                             'must be interpolated to the V staggered grid points.',i1=i)
 549             else if (is_v_field(i) .and. output_stagger(i) /= VV) then
 550                call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind V-component field '// &
 551                             'must be interpolated to the V staggered grid points.',i1=i)
 552             end if
 553
 554             if (output_stagger(i) == M) then
 555                call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, M is not a valid output staggering for NMM.',i1=i)
 556             else if (output_stagger(i) == U) then
 557                call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, U is not a valid output staggering for NMM.',i1=i)
 558             else if (output_stagger(i) == V) then
 559                call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, V is not a valid output staggering for NMM.',i1=i)
 560             end if
 561
 562             if (masked(i) /= NOT_MASKED .and. output_stagger(i) /= HH) then
 563                call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, staggered output field '// &
 564                             'cannot use the ''masked'' option.',i1=i)
 565             end if
 566          end if
 567
 568       end do
 569
 570    end subroutine check_table_specs
 571
 572
 573    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 574    ! Name: get_z_dim_name
 575    !
 576    ! Pupose:
 577    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 578    subroutine get_z_dim_name(fldname, zdim_name)
 579
 580       implicit none
 581
 582       ! Arguments
 583       character (len=*), intent(in) :: fldname
 584       character (len=32), intent(out) :: zdim_name
 585
 586       ! Local variables
 587       integer :: i
 588
 589       zdim_name = z_dim_name(num_entries)(1:32)
 590       do i=1,num_entries
 591          if (trim(fldname) == trim(fieldname(i))) then
 592             zdim_name = z_dim_name(i)(1:32)
 593             exit
 594          end if
 595       end do
 596
 597    end subroutine get_z_dim_name
 598
 599
 600    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 601    ! Name: mpas_name_to_idx
 602    !
 603    ! Pupose:
 604    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 605    function mpas_name_to_idx(mpasname) result(idx)
 606
 607       implicit none
 608
 609       ! Arguments
 610       character (len=*), intent(in) :: mpasname
 611
 612       ! Return value
 613       integer :: idx
 614
 615       ! Local variables
 616       integer :: i
 617
 618       idx = 0
 619       do i=1,num_entries
 620          if (trim(mpasname) == trim(mpas_name(i))) then
 621             idx = i
 622             exit
 623          end if
 624       end do
 625
 626    end function mpas_name_to_idx
 627
 628
 629    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 630    ! Name: mpas_to_intermediate_name
 631    !
 632    ! Pupose:
 633    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 634    function mpas_to_intermediate_name(mpasname) result(intermediate_name)
 635
 636       implicit none
 637
 638       ! Arguments
 639       character (len=*), intent(in) :: mpasname
 640
 641       ! Return value
 642       character (len=128) :: intermediate_name
 643
 644       ! Local variables
 645       integer :: i
 646
 647       intermediate_name = fieldname(num_entries)
 648       do i=1,num_entries
 649          if (trim(mpasname) == trim(mpas_name(i))) then
 650             intermediate_name = fieldname(i)
 651             exit
 652          end if
 653       end do
 654
 655    end function mpas_to_intermediate_name
 656
 657
 658    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 659    ! Name: mpas_output_stagger
 660    !
 661    ! Pupose:
 662    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 663    function mpas_output_stagger(mpasname) result(istagger)
 664
 665       implicit none
 666
 667       ! Arguments
 668       character (len=*), intent(in) :: mpasname
 669
 670       ! Return value
 671       integer :: istagger
 672
 673       ! Local variables
 674       integer :: i
 675
 676       istagger = M
 677       do i=1,num_entries
 678          if (trim(mpasname) == trim(mpas_name(i))) then
 679             istagger = output_stagger(i)
 680             exit
 681          end if
 682       end do
 683
 684    end function mpas_output_stagger
 685
 686
 687    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 688    ! Name: get_gcell_threshold
 689    !
 690    ! Pupose:
 691    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 692    subroutine get_gcell_threshold(interp_opt, threshold, istatus)
 693
 694       implicit none
 695
 696       ! Arguments
 697       integer, intent(out) :: istatus
 698       real, intent(out) :: threshold
 699       character (len=128), intent(in) :: interp_opt
 700
 701       ! Local variables
 702       integer :: i, p1, p2
 703
 704       istatus = 1
 705       threshold = 1.0
 706
 707       i = index(interp_opt,'average_gcell')
 708       if (i /= 0) then
 709
 710          ! Check for a threshold
 711          p1 = index(interp_opt(i:128),'(')
 712          p2 = index(interp_opt(i:128),')')
 713          if (p1 /= 0 .and. p2 /= 0) then
 714             read(interp_opt(p1+1:p2-1),*,err=1000) threshold
 715          else
 716             call mprintf(.true.,WARN, 'Problem in specifying threshold for average_gcell interp option. Setting threshold to 1.0')
 717             threshold = 1.0
 718          end if
 719       end if
 720       istatus = 0
 721
 722       return
 723
 724 1000  call mprintf(.true.,ERROR, &
 725                    'Threshold option to average_gcell interpolator must be a real number, '// &
 726                    'enclosed in parentheses immediately after keyword "average_gcell"')
 727
 728    end subroutine get_gcell_threshold
 729
 730
 731    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 732    ! Name: get_constant_fill_lev
 733    !
 734    ! Pupose:
 735    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 736    subroutine get_constant_fill_lev(fill_opt, fill_const, istatus)
 737
 738       implicit none
 739
 740       ! Arguments
 741       integer, intent(out) :: istatus
 742       real, intent(out) :: fill_const
 743       character (len=128), intent(in) :: fill_opt
 744
 745       ! Local variables
 746       integer :: i, p1, p2
 747
 748       istatus = 1
 749       fill_const = NAN
 750
 751       i = index(fill_opt,'const')
 752       if (i /= 0) then
 753
 754          ! Check for a threshold
 755          p1 = index(fill_opt(i:128),'(')
 756          p2 = index(fill_opt(i:128),')')
 757          if (p1 /= 0 .and. p2 /= 0) then
 758             read(fill_opt(p1+1:p2-1),*,err=1000) fill_const
 759          else
 760             call mprintf(.true.,WARN, 'Problem in specifying fill_lev constant. Setting fill_const to %f', f1=NAN)
 761             fill_const = NAN
 762          end if
 763          istatus = 0
 764       end if
 765
 766       return
 767
 768 1000  call mprintf(.true.,ERROR, &
 769                    'Constant option to fill_lev must be a real number, enclosed in parentheses '// &
 770                    'immediately after keyword "const"')
 771
 772    end subroutine get_constant_fill_lev
 773
 774
 775    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 776    ! Name: get_fill_src_level
 777    !
 778    ! Purpose:
 779    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 780    subroutine get_fill_src_level(fill_opt, fill_src, fill_src_level)
 781
 782       implicit none
 783
 784       ! Arguments
 785       integer, intent(out) :: fill_src_level
 786       character (len=128), intent(in) :: fill_opt
 787       character (len=128), intent(out) :: fill_src
 788
 789       ! Local variables
 790       integer :: p1, p2
 791
 792       ! Check for a level in parentheses
 793       p1 = index(fill_opt,'(')
 794       p2 = index(fill_opt,')')
 795       if (p1 /= 0 .and. p2 /= 0) then
 796          read(fill_opt(p1+1:p2-1),*,err=1000) fill_src_level
 797          fill_src = ' '
 798          write(fill_src,'(a)') fill_opt(1:p1-1)
 799       else
 800          fill_src_level = 1
 801          fill_src = fill_opt
 802       end if
 803
 804       return
 805
 806 1000  call mprintf(.true.,ERROR, &
 807                    'For fill_lev specification, level in source field must be an integer, '// &
 808                    'enclosed in parentheses immediately after the fieldname')
 809
 810    end subroutine get_fill_src_level
 811
 812
 813    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 814    ! Name: interp_option_destroy
 815    !
 816    ! Purpose:
 817    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 818    subroutine interp_option_destroy()
 819
 820       implicit none
 821
 822       ! Local variables
 823       integer :: i
 824
 825       deallocate(fieldname)
 826       deallocate(from_input)
 827       deallocate(z_dim_name)
 828       deallocate(interp_method)
 829       deallocate(v_interp_method)
 830       deallocate(masked)
 831       deallocate(fill_missing)
 832       deallocate(missing_value)
 833       do i=1,num_entries
 834          call list_destroy(fill_lev_list(i))
 835       end do
 836       deallocate(fill_lev_list)
 837       deallocate(interp_mask)
 838       deallocate(interp_land_mask)
 839       deallocate(interp_water_mask)
 840       deallocate(interp_mask_val)
 841       deallocate(interp_land_mask_val)
 842       deallocate(interp_water_mask_val)
 843       deallocate(interp_mask_relational)
 844       deallocate(interp_land_mask_relational)
 845       deallocate(interp_water_mask_relational)
 846       deallocate(level_template)
 847       deallocate(flag_in_output)
 848       deallocate(output_name)
 849       deallocate(output_stagger)
 850       deallocate(output_this_field)
 851       deallocate(is_u_field)
 852       deallocate(is_v_field)
 853       deallocate(is_derived_field)
 854       deallocate(is_mandatory)
 855       call list_destroy(flag_in_output_list)
 856
 857    end subroutine interp_option_destroy
 858
 859 end module interp_option_module