WPS/ungrib/src/parse_table.F90

   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
 116               exit BLOOP
 117            endif
 118         enddo BLOOP
 119         do while (string(1:1).ne.'-')
 120            read(10,'(A255)', iostat=ierr) string
 121         call mprintf ((ierr /= 0),ERROR,"Read error 3 in PARSE_TABLE.")
 122         enddo
 123         string(1:1) = ' '
 124
 125      elseif (string(1:1).ne.'-') then
 126         ! This is a line of values to interpret and parse.
 127         maxvar = maxvar + 1 ! increment the variable count
 128
 129         ! --- Determine Grib1 or Grib2
 130         ! If there are seven fields this is a Grib1 Vtable,
 131         ! if there are eleven fields this is a Grib2 Vtable.
 132         jstart = 1
 133         jmax=jstart
 134         tot_bars=0
 135
 136         do j = 1, vtable_columns
 137         ! The fields are delimited by '|'
 138            jbar = index(string(jstart:255),'|') + jstart - 2
 139            jstart = jbar + 2
 140            if (jstart.gt.jmax) then
 141              tot_bars=tot_bars+1
 142              jmax=jstart
 143            else
 144              cycle
 145            endif
 146         enddo
 147
 148         call mprintf((tot_bars.eq.7.and.vtable_columns.eq.11),ERROR, &
 149           'Vtable does not contain Grib2 decoding information.'// &
 150           '11 columns of information is expected.'// &
 151           '*** stopping parse_table ***')
 152
 153
 154         istart = 1
 155         ! There are seven fields (Grib1) or eleven fields (Grib2) to each line.
 156   PLOOP : do i = 1, vtable_columns
 157         ! The fields are delimited by '|'
 158
 159            ibar = index(string(istart:255),'|') + istart - 2
 160
 161            if (i.eq.1) then
 162            ! The first field is the Grib1 param code number:
 163
 164               if (string(istart:ibar) == ' ') then
 165                  gcode(maxvar) = blankcode
 166               elseif (scan(string(istart:ibar),'*') /= 0) then
 167                 call mprintf(.true.,ERROR,'Parse_table: Please give a '// &
 168                  'Grib1 parm code rather than $ in the first column of Vtable '// &
 169                  '*** stopping in parse_table ***')
 170               else
 171                  read(string(istart:ibar), * ) gcode(maxvar)
 172               endif
 173
 174            elseif (i.eq.2) then
 175            ! The second field is the Grib1 level type:
 176
 177               if (string(istart:ibar) == ' ') then
 178                  if (lcode(maxvar) /= blankcode) then
 179                   call mprintf(.true.,ERROR,'Parse_table: '// &
 180                    'Please supply a Grib1 level type in the Vtable: %s '// &
 181                    '*** stopping in parse_table ***',s1=string)
 182                  else
 183                     lcode(maxvar) = blankcode
 184                  endif
 185               elseif (scan(string(istart:ibar),'*') /= 0) then
 186                 call mprintf(.true.,ERROR,'Parse_table: '// &
 187                  "Used a * in Grib1 level type...don't do this! "// &
 188                  '*** stopping in parse_table ***')
 189               else
 190                  read(string(istart:ibar), *) lcode(maxvar)
 191               endif
 192
 193            elseif (i.eq.3) then
 194            ! The third field is the Level 1 value, which may be '*':
 195
 196               if (string(istart:ibar) == ' ') then
 197                  level1(maxvar) = blankcode
 198               elseif (scan(string(istart:ibar),'*') == 0) then
 199                  read(string(istart:ibar), *) level1(maxvar)
 200               else
 201                  level1(maxvar) = splatcode
 202               endif
 203
 204            elseif (i.eq.4) then
 205            ! The fourth field is the Level 2 value, which may be blank:
 206
 207               if (string(istart:ibar) == ' ') then
 208                  if ( (lcode(maxvar) == 112) .or.&
 209                       (lcode(maxvar) == 116) ) then
 210                   call mprintf(.true.,ERROR,'Parse_table: '// &
 211                    'Level Code  expects two Level values. '// &
 212                    '*** stopping in parse_table ***')
 213                  else
 214                     level2(maxvar) = blankcode
 215                  endif
 216               elseif (scan(string(istart:ibar),'*') /= 0) then
 217                  call mprintf(.true.,ERROR,'Parse_table: '// &
 218                   'Please give a Level 2 value (or blank), rather * in Vtable column 4 '// &
 219                   '*** stopping in parse_table ***')
 220               else
 221                  read(string(istart:ibar), *) level2(maxvar)
 222               endif
 223
 224            elseif (i.eq.5) then
 225            ! The fifth field is the param name:
 226
 227               if (string(istart:ibar).ne.' ') then
 228                  nstart = 0
 229                  do while (string(istart+nstart:istart+nstart).eq.' ')
 230                     nstart = nstart + 1
 231                  enddo
 232                  namvar(maxvar) = string(istart+nstart:ibar)
 233               else
 234                  call mprintf(.true.,ERROR,'Parse_table: '// &
 235                  'A field name is missing in the Vtable. '// &
 236                  '*** stopping in parse_table ***')
 237               endif
 238
 239            elseif (i.eq.6) then
 240            ! The sixth field is the Units string, which may be blank:
 241
 242               if (string(istart:ibar).ne.' ') then
 243                  nstart = 0
 244                  do while (string(istart+nstart:istart+nstart).eq.' ')
 245                     nstart = nstart + 1
 246                  enddo
 247                  Dunits(maxvar) = string(istart+nstart:ibar)
 248               else
 249                  Dunits(maxvar) = ' '
 250               endif
 251
 252            elseif (i.eq.7) then
 253            ! The seventh field is the description string, which may be blank:
 254
 255               if (string(istart:ibar).ne.' ') then
 256                  nstart = 0
 257                  do while (string(istart+nstart:istart+nstart).eq.' ')
 258                     nstart = nstart + 1
 259                  enddo
 260                  Ddesc(maxvar) = string(istart+nstart:ibar)
 261
 262                  ! If the description string is not blank, this is a
 263                  ! field we want to output.  In that case, copy the
 264                  ! param name to the MAXOUT array:
 265                  maxout = maxout + 1
 266                  nameout(maxout) = namvar(maxvar)
 267                  unitout(maxout) = Dunits(maxvar)
 268                  descout(maxout) = Ddesc(maxvar)
 269
 270               else
 271                  Ddesc(maxvar) = ' '
 272               endif
 273
 274            elseif (i.eq.8) then
 275            ! The eighth field is the Grib2 Product Discipline (see the
 276            ! Product Definition Template, Table 4.2).
 277
 278               !cycle RDLOOP
 279               !read(string(istart:ibar), * ,eor=995) g2code(1,maxvar)
 280
 281               if (string(istart:ibar) == ' ') then
 282                  g2code(1,maxvar) = blankcode
 283               elseif (scan(string(istart:ibar),'*') /= 0) then
 284                  call mprintf(.true.,STDOUT," ERROR reading Grib2 Discipline")
 285                  call mprintf(.true.,STDOUT,  &
 286                     "This Grib2 Vtable line is incorrectly specified:")
 287                  call mprintf(.true.,STDOUT," %s",s1=string)
 288                  call mprintf(.true.,LOGFILE," ERROR reading Grib2 Discipline")
 289                  call mprintf(.true.,LOGFILE,  &
 290                     "This Grib2 Vtable line is incorrectly specified:")
 291                  call mprintf(.true.,LOGFILE," %s",s1=string)
 292                  call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
 293               else
 294                  read(string(istart:ibar), *) g2code(1,maxvar)
 295               endif
 296
 297            elseif (i.eq.9) then
 298            ! The ninth field is the Grib2 Parameter Category per Discipline.
 299
 300               if (string(istart:ibar) == ' ') then
 301                  g2code(2,maxvar) = blankcode
 302               elseif (scan(string(istart:ibar),'*') /= 0) then
 303                  call mprintf(.true.,STDOUT," ERROR reading Grib2 Category")
 304                  call mprintf(.true.,STDOUT,  &
 305                     "This Grib2 Vtable line is incorrectly specified:")
 306                  call mprintf(.true.,STDOUT," %s",s1=string)
 307                  call mprintf(.true.,LOGFILE," ERROR reading Grib2 Category")
 308                  call mprintf(.true.,LOGFILE,  &
 309                     "This Grib2 Vtable line is incorrectly specified:")
 310                  call mprintf(.true.,LOGFILE," %s",s1=string)
 311                  call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
 312               else
 313                  read(string(istart:ibar), * ) g2code(2,maxvar)
 314               endif
 315
 316            elseif (i.eq.10) then
 317            ! The tenth field is the Grib2 Parameter Number per Category.
 318
 319               if (string(istart:ibar) == ' ') then
 320                  g2code(3,maxvar) = blankcode
 321               elseif (scan(string(istart:ibar),'*') /= 0) then
 322                  call mprintf(.true.,STDOUT, &
 323                   " ERROR reading Grib2 Parameter Number ")
 324                  call mprintf(.true.,STDOUT,  &
 325                     "This Grib2 Vtable line is incorrectly specified:")
 326                  call mprintf(.true.,STDOUT," %s",s1=string)
 327                  call mprintf(.true.,LOGFILE, &
 328                   " ERROR reading Grib2 Parameter Number ")
 329                  call mprintf(.true.,LOGFILE,  &
 330                     "This Grib2 Vtable line is incorrectly specified:")
 331                  call mprintf(.true.,LOGFILE," %s",s1=string)
 332                  call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
 333               else
 334                  read(string(istart:ibar), * ) g2code(3,maxvar)
 335               endif
 336
 337            elseif (i.eq.11) then
 338            ! The eleventh field is the Grib2 Level Type (see the Product
 339            ! Definition Template, Table 4.5).
 340
 341               if (string(istart:ibar) == ' ') then
 342                  if (g2code(4,maxvar) /= blankcode) then
 343                    call mprintf(.true.,STDOUT," ERROR reading Grib2 Level Type ")
 344                    call mprintf(.true.,STDOUT,  &
 345                       "This Grib2 Vtable line is incorrectly specified:")
 346                    call mprintf(.true.,STDOUT," %s",s1=string)
 347                    call mprintf(.true.,LOGFILE," ERROR reading Grib2 Level Type ")
 348                    call mprintf(.true.,LOGFILE,  &
 349                       "This Grib2 Vtable line is incorrectly specified:")
 350                    call mprintf(.true.,LOGFILE," %s",s1=string)
 351                    call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
 352                  else
 353                     g2code(4,maxvar) = blankcode
 354                  endif
 355               elseif (scan(string(istart:ibar),'*') /= 0) then
 356                  call mprintf(.true.,STDOUT,"ERROR in Subroutine Parse_table: ")
 357                  call mprintf(.true.,STDOUT, &
 358                   "Used a * in Grib2 level type...don't do this! ")
 359                  call mprintf(.true.,STDOUT," %s ",s1=string)
 360                  call mprintf(.true.,LOGFILE,"ERROR in Subroutine Parse_table: ")
 361                  call mprintf(.true.,LOGFILE, &
 362                   "Used a * in Grib2 level type...don't do this! ")
 363                  call mprintf(.true.,LOGFILE," %s ",s1=string)
 364                  call mprintf(.true.,ERROR," ***** Abort in Subroutine PARSE_TABLE")
 365               else
 366                  read(string(istart:ibar), *) g2code(4,maxvar)
 367               endif
 368
 369            endif
 370
 371            istart = ibar + 2
 372
 373         enddo PLOOP ! 1,vtable_columns
 374      endif
 375 !995  continue
 376   enddo RDLOOP
 377 ! Now we have finished reading the file.
 378   close(10)
 379
 380 ! Now remove duplicates from the NAMEOUT array.  Duplicates may arise
 381 ! when we have the same name referred to by different level or parameter
 382 ! codes in some dataset.
 383
 384   maxtmp = maxout
 385   do i = 1, maxtmp-1
 386      do j = i+1, maxtmp
 387         if ((nameout(i).eq.nameout(j)).and.(nameout(j).ne.' ')) then
 388            call mprintf(.true.,DEBUG,   &
 389              "Duplicate name.  Removing %s from output list.",s1=nameout(j))
 390            nameout(j:maxlines-1) = nameout(j+1:maxlines)
 391            unitout(j:maxlines-1) = unitout(j+1:maxlines)
 392            descout(j:maxlines-1) = descout(j+1:maxlines)
 393            maxout = maxout - 1
 394         endif
 395      enddo
 396   enddo
 397
 398 ! Compute a priority level based on position in the table:
 399 ! This assumes Grib.
 400
 401 ! Priorities are used only for surface fields.  If it is not a
 402 ! surface fields, the priority is assigned a value of 100.
 403
 404 ! For surface fields, priorities are assigned values of 100, 101,
 405 ! 102, etc. in the order the field names appear in the Vtable.
 406
 407   ipcount = 99
 408   do i = 1, maxvar
 409      if (lcode(i).eq.105) then
 410         ipcount = ipcount + 1
 411         iprty(i) = ipcount
 412      elseif (lcode(i).eq.116.and.level1(i).le.50.and.level2(i).eq.0) then
 413         ipcount = ipcount + 1
 414         iprty(i) = ipcount
 415      else
 416         iprty(i) = 100
 417      endif
 418   enddo
 419
 420   if (debug_level .gt. 0) then
 421      write(*,'(//"Read from file ''Vtable'' by subroutine PARSE_TABLE:")')
 422      do i = 1, maxvar
 423         if (vtable_columns.eq.11) then
 424            write(*,'(4I6, 3x,A10, 4I6)')&
 425              gcode(i), lcode(i), level1(i), level2(i), namvar(i), &
 426              g2code(1,i), g2code(2,i), g2code(3,i), g2code(4,i)
 427         else
 428            write(*,'(4I6, 3x,A10)')&
 429              gcode(i), lcode(i), level1(i), level2(i), namvar(i)
 430         endif
 431      enddo
 432      write(*,'(//)')
 433   endif
 434
 435 end subroutine parse_table