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