ungrib/src/parse_table.F

   1 !*****************************************************************************!
   2 ! Subroutine PARSE_TABLE                                                      !
   3 !                                                                             !
   4 ! Purpose:                                                                    !
   5 !    Read the Vtable, and fill arrays in the TABLE module with the Vtable     !
   6 !    information.  Broadly, the Vtable file is how the user tells the         !
   7 !    program what fields to extract from the archive files.                   !
   8 !                                                                             !
   9 ! Argument list:                                                              !
  10 !    Input: DEBUG_LEVEL:  0 = no prints, bigger numbers = more prints         !
  11 !
  12 ! Externals:                                                                  !
  13 !    Module TABLE                                                             !
  14 !    Subroutine ABORT                                                         !
  15 !                                                                             !
  16 ! Side Effects:                                                               !
  17 !                                                                             !
  18 !    - File "Vtable" is opened, read, and closed as Fortran unit 10.          !
  19 !                                                                             !
  20 !    - Various prints, especially if DEBUG_PRINT = .TRUE.                     !
  21 !                                                                             !
  22 !    - Abort for some miscellaneous error conditions.                         !
  23 !                                                                             !
  24 !    - Variables in module TABLE are filled., specifically, variables         !
  25 !        MAXVAR                                                               !
  26 !        MAXOUT                                                               !
  27 !                                                                             !
  28 !    - Arrays in module TABLE are filled., specifically, arrays               !
  29 !        NAMVAR                                                               !
  30 !        NAMEOUT                                                              !
  31 !        UNITOUT                                                              !
  32 !        DESCOUT                                                              !
  33 !        GCODE                                                                !
  34 !        LCODE                                                                !
  35 !        LEVEL1                                                               !
  36 !        LEVEL2                                                               !
  37 !        IPRTY                                                                !
  38 !        DUNITS                                                               !
  39 !        DDESC                                                                !
  40 !                                                                             !
  41 ! Author: Kevin W. Manning                                                    !
  42 !         NCAR/MMM                                                            !
  43 !         Summer 1998, and continuing                                         !
  44 !         SDG                                                                 !
  45 !                                                                             !
  46 !*****************************************************************************!
  47
  48 subroutine parse_table(debug_level,vtable_columns)
  49   use Table
  50   use module_debug
  51   use stringutil
  52   implicit none
  53   integer :: debug_level
  54
  55   character(LEN=255) :: string = ' '
  56   integer :: ierr
  57   integer :: istart, ibar, i, j, ipcount
  58   integer :: jstart, jbar, jmax, tot_bars
  59   integer :: vtable_columns
  60   integer :: nstart, maxtmp
  61   logical :: lexist
  62   character(len=9) :: tmp9
  63
  64 ! added for IBM
  65   blankcode = -99
  66   splatcode = -88
  67 ! end added for IBM
  68
  69 ! Open the file called "Vtable"
  70
  71   open(10, file='Vtable', status='old', form='formatted', iostat=ierr)
  72
  73 ! Check to see that the OPEN worked without error.
  74
  75   if (ierr.ne.0) then
  76      inquire(file='Vtable', exist=LEXIST)
  77      call mprintf(.true.,STDOUT," ***** ERROR in Subroutine PARSE_TABLE:")
  78      call mprintf(.true.,LOGFILE," ***** ERROR in Subroutine PARSE_TABLE:")
  79      if (.not.lexist) then
  80        call mprintf(.true.,STDOUT,"Problem opening file Vtable.")
  81        call mprintf(.true.,STDOUT,"File ''Vtable'' does not exist.")
  82        call mprintf(.true.,LOGFILE,"Problem opening file Vtable.")
  83        call mprintf(.true.,LOGFILE,"File ''Vtable'' does not exist.")
  84      else
  85        call mprintf(.true.,STDOUT,"Problem opening file Vtable.")
  86        call mprintf(.true.,STDOUT,"File Vtable exists, but Fortran OPEN statement")
  87        call mprintf(.true.,STDOUT,"failed with error %i",i1=ierr)
  88        call mprintf(.true.,LOGFILE,"Problem opening file Vtable.")
  89        call mprintf(.true.,LOGFILE,"File Vtable exists, but Fortran OPEN statement")
  90        call mprintf(.true.,LOGFILE,"failed with error %i",i1=ierr)
  91      endif
  92      call mprintf(.true.,ERROR," ***** Stopping in Subroutine PARSE_TABLE")
  93   endif
  94
  95 ! First, read past the headers, i.e., skip lines until we hit the first
  96 ! line beginning with '-'
  97   do while (string(1:1).ne.'-')
  98      read(10,'(A255)', iostat=ierr) string
  99      call mprintf ((ierr /= 0),ERROR,"Read error 1 in PARSE_TABLE.")
 100   enddo
 101   string = ' '
 102
 103 ! Now interpret everything from here to the next '-' line:
 104 !
 105   RDLOOP : do while (string(1:1).ne.'-')
 106      read(10,'(A255)', iostat=ierr) string
 107      call mprintf ((ierr /= 0),ERROR,"Read error 2 in PARSE_TABLE.")
 108      if (string(1:1).eq.'#') cycle RDLOOP
 109      if (len_trim(string) == 0) cycle RDLOOP
 110      if (string(1:1).eq.'-') then
 111         ! Skip over internal header lines
 112         BLOOP : do
 113            read(10,'(A255)', iostat=ierr) string
 114            if (ierr /= 0) exit RDLOOP
 115            if (len_trim(string) == 0) then
 116               cycle BLOOP
 117            else if (string(1:1) == '#') then
 118               cycle BLOOP
 119            else
 120               exit BLOOP
 121            endif
 122         enddo BLOOP
 123         do while (string(1:1).ne.'-')
 124            read(10,'(A255)', iostat=ierr) string
 125         call mprintf ((ierr /= 0),ERROR,"Read error 3 in PARSE_TABLE.")
 126         enddo
 127         string(1:1) = ' '
 128
 129      elseif (string(1:1).ne.'-') then
 130         ! This is a line of values to interpret and parse.
 131         maxvar = maxvar + 1 ! increment the variable count
 132
 133         ! --- Determine Grib1 or Grib2
 134         ! If there are seven fields this is a Grib1 Vtable,
 135         ! if there are eleven fields this is a Grib2 Vtable.
 136         jstart = 1
 137         jmax=jstart
 138         tot_bars=0
 139
 140         do j = 1, vtable_columns
 141         ! The fields are delimited by '|'
 142            jbar = index(string(jstart:255),'|') + jstart - 2
 143            jstart = jbar + 2
 144            if (jstart.gt.jmax) then
 145              tot_bars=tot_bars+1
 146              jmax=jstart
 147            else
 148              cycle
 149            endif
 150         enddo
 151
 152         call mprintf((tot_bars.eq.7.and.vtable_columns.ge.11),ERROR, &
 153           'Vtable does not contain Grib2 decoding information.'// &
 154           ' 11 or 12 columns of information is expected.'// &
 155           ' *** stopping parse_table ***')
 156
 157
 158         istart = 1
 159         ! There are seven fields (Grib1) or eleven fields (Grib2) to each line.
 160   PLOOP : do i = 1, vtable_columns
 161         ! The fields are delimited by '|'
 162
 163            ibar = index(string(istart:255),'|') + istart - 2
 164
 165            if (i.eq.1) then
 166            ! The first field is the Grib1 param code number:
 167
 168               if (string(istart:ibar) == ' ') then
 169                  gcode(maxvar) = blankcode
 170               elseif (scan(string(istart:ibar),'*') /= 0) then
 171                 call mprintf(.true.,ERROR,'Parse_table: Please give a '// &
 172                  'Grib1 parm code rather than $ in the first column of Vtable '// &
 173                  '*** stopping in parse_table ***')
 174               else
 175                  read(string(istart:ibar), * ) gcode(maxvar)
 176               endif
 177
 178            elseif (i.eq.2) then
 179            ! The second field is the Grib1 level type:
 180
 181               if (string(istart:ibar) == ' ') then
 182                  if (lcode(maxvar) /= blankcode) then
 183                   call mprintf(.true.,ERROR,'Parse_table: '// &
 184                    'Please supply a Grib1 level type in the Vtable: %s '// &
 185                    '*** stopping in parse_table ***',s1=string)
 186                  else
 187                     lcode(maxvar) = blankcode
 188                  endif
 189               elseif (scan(string(istart:ibar),'*') /= 0) then
 190                 call mprintf(.true.,ERROR,'Parse_table: '// &
 191                  "Used a * in Grib1 level type...don't do this! "// &
 192                  '*** stopping in parse_table ***')
 193               else
 194                  read(string(istart:ibar), *) lcode(maxvar)
 195               endif
 196
 197            elseif (i.eq.3) then
 198            ! The third field is the Level 1 value, which may be '*':
 199
 200               if (string(istart:ibar) == ' ') then
 201                  level1(maxvar) = blankcode
 202               elseif (scan(string(istart:ibar),'*') == 0) then
 203                  read(string(istart:ibar), *) level1(maxvar)
 204               else
 205                  level1(maxvar) = splatcode
 206               endif
 207
 208            elseif (i.eq.4) then
 209            ! The fourth field is the Level 2 value, which may be blank:
 210
 211               if (string(istart:ibar) == ' ') then
 212                  if ( (lcode(maxvar) == 112) .or.&
 213                       (lcode(maxvar) == 116) ) then
 214                   call mprintf(.true.,ERROR,'Parse_table: '// &
 215                    'Level Code  expects two Level values. '// &
 216                    '*** stopping in parse_table ***')
 217                  else
 218                     level2(maxvar) = blankcode
 219                  endif
 220               elseif (scan(string(istart:ibar),'*') /= 0) then
 221                  call mprintf(.true.,ERROR,'Parse_table: '// &
 222                   'Please give a Level 2 value (or blank), rather * in Vtable column 4 '// &
 223                   '*** stopping in parse_table ***')
 224               else
 225                  read(string(istart:ibar), *) level2(maxvar)
 226               endif
 227
 228            elseif (i.eq.5) then
 229            ! The fifth field is the param name:
 230
 231               if (string(istart:ibar).ne.' ') then
 232                  nstart = 0
 233                  do while (string(istart+nstart:istart+nstart).eq.' ')
 234                     nstart = nstart + 1
 235                  enddo
 236                  namvar(maxvar) = string(istart+nstart:ibar)
 237               else
 238                  call mprintf(.true.,ERROR,'Parse_table: '// &
 239                  'A field name is missing in the Vtable. '// &
 240                  '*** stopping in parse_table ***')
 241               endif
 242
 243            elseif (i.eq.6) then
 244            ! The sixth field is the Units string, which may be blank:
 245
 246               if (string(istart:ibar).ne.' ') then
 247                  nstart = 0
 248                  do while (string(istart+nstart:istart+nstart).eq.' ')
 249                     nstart = nstart + 1
 250                  enddo
 251                  Dunits(maxvar) = string(istart+nstart:ibar)
 252               else
 253                  Dunits(maxvar) = ' '
 254               endif
 255
 256            elseif (i.eq.7) then
 257            ! The seventh field is the description string, which may be blank:
 258
 259               if (string(istart:ibar).ne.' ') then
 260                  nstart = 0
 261                  do while (string(istart+nstart:istart+nstart).eq.' ')
 262                     nstart = nstart + 1
 263                  enddo
 264                  Ddesc(maxvar) = string(istart+nstart:ibar)
 265
 266                  ! If the description string is not blank, this is a
 267                  ! field we want to output.  In that case, copy the
 268                  ! param name to the MAXOUT array:
 269                  maxout = maxout + 1
 270                  nameout(maxout) = namvar(maxvar)
 271                  unitout(maxout) = Dunits(maxvar)
 272                  descout(maxout) = Ddesc(maxvar)
 273
 274               else
 275                  Ddesc(maxvar) = ' '
 276               endif
 277
 278            elseif (i.eq.8) then
 279            ! The eighth field is the Grib2 Product Discipline (see the
 280            ! Product Definition Template, Table 4.2).
 281
 282               !cycle RDLOOP
 283               !read(string(istart:ibar), * ,eor=995) g2code(1,maxvar)
 284
 285               if (string(istart:ibar) == ' ') then
 286                  g2code(1,maxvar) = blankcode
 287               elseif (scan(string(istart:ibar),'*') /= 0) then
 288                  call mprintf(.true.,STDOUT," ERROR reading Grib2 Discipline")
 289                  call mprintf(.true.,STDOUT,  &
 290                     "This Grib2 Vtable line is incorrectly specified:")
 291                  call mprintf(.true.,STDOUT," %s",s1=string)
 292                  call mprintf(.true.,LOGFILE," ERROR reading Grib2 Discipline")
 293                  call mprintf(.true.,LOGFILE,  &
 294                     "This Grib2 Vtable line is incorrectly specified:")
 295                  call mprintf(.true.,LOGFILE," %s",s1=string)
 296                  call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
 297               else
 298                  read(string(istart:ibar), *) g2code(1,maxvar)
 299               endif
 300
 301            elseif (i.eq.9) then
 302            ! The ninth field is the Grib2 Parameter Category per Discipline.
 303
 304               if (string(istart:ibar) == ' ') then
 305                  g2code(2,maxvar) = blankcode
 306               elseif (scan(string(istart:ibar),'*') /= 0) then
 307                  call mprintf(.true.,STDOUT," ERROR reading Grib2 Category")
 308                  call mprintf(.true.,STDOUT,  &
 309                     "This Grib2 Vtable line is incorrectly specified:")
 310                  call mprintf(.true.,STDOUT," %s",s1=string)
 311                  call mprintf(.true.,LOGFILE," ERROR reading Grib2 Category")
 312                  call mprintf(.true.,LOGFILE,  &
 313                     "This Grib2 Vtable line is incorrectly specified:")
 314                  call mprintf(.true.,LOGFILE," %s",s1=string)
 315                  call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
 316               else
 317                  read(string(istart:ibar), * ) g2code(2,maxvar)
 318               endif
 319
 320            elseif (i.eq.10) then
 321            ! The tenth field is the Grib2 Parameter Number per Category.
 322
 323               if (string(istart:ibar) == ' ') then
 324                  g2code(3,maxvar) = blankcode
 325               elseif (scan(string(istart:ibar),'*') /= 0) then
 326                  call mprintf(.true.,STDOUT, &
 327                   " ERROR reading Grib2 Parameter Number ")
 328                  call mprintf(.true.,STDOUT,  &
 329                     "This Grib2 Vtable line is incorrectly specified:")
 330                  call mprintf(.true.,STDOUT," %s",s1=string)
 331                  call mprintf(.true.,LOGFILE, &
 332                   " ERROR reading Grib2 Parameter Number ")
 333                  call mprintf(.true.,LOGFILE,  &
 334                     "This Grib2 Vtable line is incorrectly specified:")
 335                  call mprintf(.true.,LOGFILE," %s",s1=string)
 336                  call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
 337               else
 338                  read(string(istart:ibar), * ) g2code(3,maxvar)
 339               endif
 340
 341            elseif (i.eq.11) then
 342            ! The eleventh field is the Grib2 Level Type (see the Product
 343            ! Definition Template, Table 4.5).
 344
 345               if (string(istart:ibar) == ' ') then
 346                  if (g2code(4,maxvar) /= blankcode) then
 347                    call mprintf(.true.,STDOUT," ERROR reading Grib2 Level Type ")
 348                    call mprintf(.true.,STDOUT,  &
 349                       "This Grib2 Vtable line is incorrectly specified:")
 350                    call mprintf(.true.,STDOUT," %s",s1=string)
 351                    call mprintf(.true.,LOGFILE," ERROR reading Grib2 Level Type ")
 352                    call mprintf(.true.,LOGFILE,  &
 353                       "This Grib2 Vtable line is incorrectly specified:")
 354                    call mprintf(.true.,LOGFILE," %s",s1=string)
 355                    call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
 356                  else
 357                     g2code(4,maxvar) = blankcode
 358                  endif
 359               elseif (scan(string(istart:ibar),'*') /= 0) then
 360                  call mprintf(.true.,STDOUT,"ERROR in Subroutine Parse_table: ")
 361                  call mprintf(.true.,STDOUT, &
 362                   "Used a * in Grib2 level type...don't do this! ")
 363                  call mprintf(.true.,STDOUT," %s ",s1=string)
 364                  call mprintf(.true.,LOGFILE,"ERROR in Subroutine Parse_table: ")
 365                  call mprintf(.true.,LOGFILE, &
 366                   "Used a * in Grib2 level type...don't do this! ")
 367                  call mprintf(.true.,LOGFILE," %s ",s1=string)
 368                  call mprintf(.true.,ERROR," ***** Abort in Subroutine PARSE_TABLE")
 369               else
 370                  read(string(istart:ibar), *) g2code(4,maxvar)
 371               endif
 372
 373            elseif (i.eq.12) then
 374            ! The twelfth field is the Grib2 Product Definition Template number
 375            ! Defaults to template 4.0, an instantaneous horizontal field.
 376            ! The only other supported value is 8 - an accumulated or averaged field.
 377
 378             if (istart .lt. ibar) then
 379               if (string(istart:ibar) == ' ') then
 380                  g2code(5,maxvar) = 0
 381               elseif (scan(string(istart:ibar),'*') /= 0) then
 382                  call mprintf(.true.,STDOUT, &
 383                   " ERROR reading Grib2 Parameter Number ")
 384                  call mprintf(.true.,STDOUT,  &
 385                     "This Grib2 Vtable line is incorrectly specified:")
 386                  call mprintf(.true.,STDOUT," %s",s1=string)
 387                  call mprintf(.true.,LOGFILE, &
 388                   " ERROR reading Grib2 Parameter Number ")
 389                  call mprintf(.true.,LOGFILE,  &
 390                     "This Grib2 Vtable line is incorrectly specified:")
 391                  call mprintf(.true.,LOGFILE," %s",s1=string)
 392                  call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
 393               else
 394                  read(string(istart:ibar), * ) g2code(5,maxvar)
 395               endif
 396              else     ! occurs when 11 columns are in the Vtable rather than 12.
 397                g2code(5,maxvar) = 0
 398              endif
 399
 400            endif
 401
 402            istart = ibar + 2
 403
 404         enddo PLOOP ! 1,vtable_columns
 405      endif
 406 !995  continue
 407   enddo RDLOOP
 408 ! Now we have finished reading the file.
 409   close(10)
 410
 411 ! Now remove duplicates from the NAMEOUT array.  Duplicates may arise
 412 ! when we have the same name referred to by different level or parameter
 413 ! codes in some dataset.
 414
 415   maxtmp = maxout
 416   do i = 1, maxtmp-1
 417      do j = i+1, maxtmp
 418         if ((nameout(i).eq.nameout(j)).and.(nameout(j).ne.' ')) then
 419            call mprintf(.true.,DEBUG,   &
 420              "Duplicate name.  Removing %s from output list.",s1=nameout(j))
 421            nameout(j:maxlines-1) = nameout(j+1:maxlines)
 422            unitout(j:maxlines-1) = unitout(j+1:maxlines)
 423            descout(j:maxlines-1) = descout(j+1:maxlines)
 424            maxout = maxout - 1
 425         endif
 426      enddo
 427   enddo
 428
 429 ! Compute a priority level based on position in the table:
 430 ! This assumes Grib.
 431
 432 ! Priorities are used only for surface fields.  If it is not a
 433 ! surface fields, the priority is assigned a value of 100.
 434
 435 ! For surface fields, priorities are assigned values of 100, 101,
 436 ! 102, etc. in the order the field names appear in the Vtable.
 437
 438   ipcount = 99
 439   do i = 1, maxvar
 440      if ((lcode(i).eq.105).or.(lcode(i).eq.118)) then
 441         ipcount = ipcount + 1
 442         iprty(i) = ipcount
 443      elseif (lcode(i).eq.116.and.level1(i).le.50.and.level2(i).eq.0) then
 444         ipcount = ipcount + 1
 445         iprty(i) = ipcount
 446      else
 447         iprty(i) = 100
 448      endif
 449   enddo
 450
 451   if (debug_level .gt. 0) then
 452      write(*,'(//"Read from file ''Vtable'' by subroutine PARSE_TABLE:")')
 453      call mprintf(.true.,DEBUG,   &
 454        "Read from file Vtable by subroutine PARSE_TABLE:")
 455      do i = 1, maxvar
 456         if (vtable_columns.ge.11) then
 457            write(*,'(4I6, 3x,A10, 5I6)')&
 458              gcode(i), lcode(i), level1(i), level2(i), namvar(i), &
 459              g2code(1,i), g2code(2,i), g2code(3,i), g2code(4,i), g2code(5,i)
 460            write(tmp9,'(i9)') gcode(i)
 461            call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.)
 462            write(tmp9,'(i9)') lcode(i)
 463            call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.)
 464            write(tmp9,'(i9)') level1(i)
 465            call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.)
 466            write(tmp9,'(i9)') level2(i)
 467            call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.)
 468            write(tmp9,'(a9)') namvar(i)(1:9)
 469            call right_justify(tmp9,9)
 470            call mprintf(.true.,DEBUG,tmp9,newline=.false.)
 471            do j = 1, 5
 472              write(tmp9,'(i9)') g2code(j,i)
 473              call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.)
 474            enddo
 475            call mprintf(.true.,DEBUG,' ',newline=.true.)
 476         else
 477            write(*,'(4I6, 3x,A10)')&
 478              gcode(i), lcode(i), level1(i), level2(i), namvar(i)
 479         endif
 480      enddo
 481      write(*,'(//)')
 482   endif
 483
 484 end subroutine parse_table