WPS/ungrib/src/g1print.F90

   1 ! Print information about a grib file.
   2 !  Usage: "gribscan [-v] [-V] filename"
   3 !  as of now, the filename cannot be a full path name
   4 !
   5 program gribscan
   6   use module_grib
   7   interface
   8      subroutine parse_args(err, a1, h1, i1, l1, a2, h2, i2, l2,&
   9           a3, h3, i3, l3, hlast)
  10        integer :: err
  11        character(len=*) , optional :: a1, a2, a3
  12        character(len=*), optional :: h1, h2, h3
  13        integer , optional :: i1, i2, i3
  14        logical, optional :: l1, l2, l3
  15        character(len=*), optional :: hlast
  16      end subroutine parse_args
  17   end interface
  18
  19   character(len=120) :: flnm
  20   character(len=30) :: hopt
  21   real, allocatable, dimension(:) :: datarray
  22   integer :: ierr, igherr
  23   integer :: cc
  24   character(len=100) :: fmt = '(I4,1X, &
  25        & I3,1x, A5,1x, &
  26        & I4, &
  27        & 2(1x,I4),2x,I4.4,2("-",I2.2),"_",I2.2,":",&
  28        & I2.2, 1x, "+", i2.2)'
  29   logical :: ivb = .FALSE.
  30   logical :: idb = .FALSE.
  31   integer :: year
  32   character(len=5) :: gc(255)
  33   data gc /'PRES','PRMSL','PTEND','PVORT','ICAHT','GP','HGT','DIST',&
  34        'HSTDV','TOZNE','TMP','VTMP','POT','EPOT','T MAX','T MIN','DPT',&
  35        'DEPR','LAPR','VIS','RDSP1','RDSP2','RDSP3','PLI','TMP A','PRESA',&
  36        'GP A','WVSP1','WVSP2','WVSP3','WDIR','WIND','U GRD','V GRD','STRM',&
  37        'V POT','MNTSF','SGCVV','V VEL','DZDT','ABS V','ABD D','REL V','REL D',&
  38        'VUCSH','VVCSG','DIR C','SP C','UOGRD','VOGRD','SPF H','R H','MIXR',&
  39        'P WAT','VAPP','SAT D','EVP','C ICE','PRATE','TSTM','A PCP','NCPCP',&
  40        'ACPCP','SRWEQ','WEASD','SNO D','MIXHT','TTHDP','MTHD','MTH A','T CDC',&
  41        'CDCON','L CDC','M CDC','H CDC','C WAT','BLI','SNO C','SNO L','WTMP',&
  42        'LAND','DSL M','SFC R','ALBDO','TSOIL','SOILM','VEG','SALTY','DEN',&
  43        'WATR','ICE C','ICETK','DICED','SICED','U ICE','V ICE','ICE G','ICE D',&
  44        'SNO M','HTSGW','WVDIR','WVHGT','WVPER','SWDIR','SWELL','SWPER','DIRPW',&
  45        'PERPW','DIRSW','PERSW','NSWRS','NLWRS','NSWRT','NLWRT','LWAVR','SWAVR',&
  46        'GRAD','BRTMP','LWRAD','SWRAD','LHTFL','SHTFL','BLYDP','U FLX','V FLX',&
  47        'WMIXE','IMG D',&
  48 ! 128-254 for use by originating center. NWS/NCEP usage is coded here.
  49        'MSLSA','MSLMA','MSLET','LFT X','4LFTX','K X','S X','MCONV','VW SH',&
  50        'TSLSA','BVF 2','PV MW','CRAIN','CFRZR','CICEP','CSNOW','SOILW',&
  51        'PEVPR','CWORK','U-GWD','V-GWD','PV','COVMZ','COVTZ','COVTM','CLWMR',&
  52        'O3MR','GFLUX','CIN','CAPE','TKE','CONDP','CSUSF','CSDSF','CSULF',&
  53        'CSDLF','CFNSF','CFNLF','VBDSF','VDDSF','NBDSF','NDDSF','RWMR',&
  54        'SNMR','M FLX','LMH','LMV','MLYNO','NLAT','ELON','ICMR','GRMR','GUST',&
  55        'LPS X','LPS Y','HGT X','HGT Y','TPFI','TIPD','LTNG','RDRIP','VPTMP','HLCY',&
  56        'PROB','PROBN','POP','CPOFP','CPOZP','USTM','VSTM','NCIP','EVBS','EVCW',&
  57        'ICWAT','CWDI','VAFTD','DSWRF','DLWRF','UVI','MSTAV','SFEXC','MIXLY','TRANS',&
  58        'USWRF','ULWRF','CDLYR','CPRAT','TTDIA','TTRAD','TTPHY','PREIX','TSD1D',&
  59        'NLGSP','HPBL','5WAVH','CNWAT','SOTYP','VGTYP','BMIXL','AMIXL','PEVAP',&
  60        'SNOHF','5WAVA','MFLUX','DTRF','UTRF','BGRUN','SSRUN','SIPD','O3TOT',&
  61        'SNOWC','SNOT','COVTW','LRGHR','CNVHR','CNVMR','SHAHR','SHAMR','VDFHR',&
  62        'VDFUA','VDFVA','VDFMR','SWHR','LWHR','CD','FRICV','RI','  '/
  63
  64   flnm = ' '
  65   call parse_args(ierr, a1='v', l1=ivb, a2='V', l2=idb, hlast=flnm)
  66   if (ierr.ne.0) then
  67      call getarg(0, hopt)
  68      write(*,'(//,"Usage: ", A, " [-v] [-V] file",/)') trim(hopt)
  69      write(*,'("     -v   : Print more information about the GRIB records")')
  70      write(*,'("     -V   : Print way too much information about the GRIB&
  71           & records")')
  72      write(*,'("     file : GRIB file to read"//)')
  73       stop
  74 !    stop
  75   endif
  76
  77   if (idb) ivb = .TRUE.
  78
  79   call c_open(idum, munit, flnm, 1, ierr, 1)
  80
  81   if (.not. ivb) then
  82      write(*,'(52("-"))')
  83      write(*,'(" rec GRIB GRIB  Lvl  Lvl  Lvl         Time      Fcst")')
  84      write(*,'(" Num Code name  Code one  two                   hour")')
  85      write(*,'(52("-"))')
  86   endif
  87
  88   irec = 0
  89   call gribget(munit, ierr)
  90   do while (ierr.eq.0)
  91      irec = irec + 1
  92      call gribheader(0,igherr)
  93      if (igherr /= 0) then
  94         call deallogrib
  95         call gribget(munit, ierr)
  96         cycle
  97      endif
  98
  99      if ( sec1(3) .ne. 7 ) then  ! gc defined only for NCEP
 100        do cc = 128, 254
 101          gc(cc) = '     '
 102        enddo
 103      if ( sec1(3) .eq. 57 ) then  ! AFWA
 104        gc(144) = 'DNWLR'
 105        gc(145) = 'INSWR'
 106        gc(155) = 'GDHFX'
 107        gc(157) = 'XTRAJ'
 108        gc(158) = 'YTRAJ'
 109        gc(159) = 'PTRAJ'
 110        gc(160) = 'TERID'
 111        gc(161) = 'MDLTN'
 112        gc(174) = 'SNOWD'
 113        gc(175) = 'SNOAG'
 114        gc(176) = 'SNOCL'
 115        gc(177) = 'VSBLY'
 116        gc(178) = 'CURWX'
 117        gc(179) = 'CLAMT'
 118        gc(180) = 'CLBAS'
 119        gc(181) = 'CLTOP'
 120        gc(182) = 'CLTYP'
 121        gc(183) = 'UTIME'
 122        gc(184) = 'SRCDT'
 123        gc(196) = 'EPCDF'
 124        gc(197) = 'EPALL'
 125        gc(198) = 'EPGEO'
 126        gc(199) = 'EPVAL'
 127        gc(200) = 'SOILR'
 128        gc(201) = 'SOILW'
 129        gc(205) = 'TYPSL'
 130        gc(206) = 'VLASH'
 131        gc(207) = 'CANWT'
 132        gc(208) = 'PEVAP'
 133        gc(209) = 'WNDRN'
 134        gc(210) = 'RHTMN'
 135        gc(211) = 'SOILL'
 136        gc(212) = 'VEGTP'
 137        gc(213) = 'GREEN'
 138        gc(234) = 'BGRUN'
 139        gc(235) = 'SSRUN'
 140      endif
 141      endif
 142
 143      if (ivb) then
 144         call gribprint(0)
 145         call gribprint(1)
 146         call gribprint(2)
 147         call gribprint(3)
 148         call gribprint(4)
 149            if (sec2(4).eq.50) then
 150               ndat = (infogrid(1)+1)*(infogrid(2)+1)
 151            else
 152               ndat = (infogrid(1)*infogrid(2))
 153            endif
 154            allocate(datarray(ndat))
 155            call gribdata(datarray, ndat)
 156            fldmax = datarray(1)
 157            fldmin = datarray(1)
 158            do j = 1, ndat
 159              if (datarray(j).gt.fldmax) fldmax=datarray(j)
 160              if (datarray(j).lt.fldmin) fldmin=datarray(j)
 161            enddo
 162         write(*,*) "  "
 163         write(*,*) "  ",gc(sec1(7))," : "
 164         write(*,'(5x,"Minimum Data Value ",t45,":",g14.5)') fldmin
 165         write(*,'(5x,"Maximum Data Value ",t45,":",g14.5)') fldmax
 166         write(*,'(//,70("*"))')
 167         if (idb) then
 168            print*, 'Datarray = ', Datarray
 169         endif
 170            deallocate(datarray)
 171      else
 172         CC = sec1(22)
 173         year = (cc-1)*100 + sec1(11)
 174         write(*,FMT) irec, sec1(7), gc(sec1(7)), sec1(8:10), year,sec1(12:15),sec1(17)
 175      endif
 176
 177      call deallogrib
 178
 179      call gribget(munit, ierr)
 180   enddo
 181   if (ierr.eq.1) write(*,'(/,"***** End-Of-File on C unit ", I3,/)') munit
 182   call c_close( munit, 0, ierr)
 183
 184 end program gribscan
 185
 186 subroutine parse_args(err, a1, h1, i1, l1, a2, h2, i2, l2, a3, h3, i3, l3, &
 187      hlast)
 188   integer :: err
 189   character(len=*) , optional :: a1, a2, a3
 190   character(len=*), optional :: h1, h2, h3
 191   integer , optional :: i1, i2, i3
 192   logical, optional :: l1, l2, l3
 193   character(len=*), optional :: hlast
 194
 195   character(len=100) :: hold
 196   integer :: ioff = 0
 197
 198   if (present(hlast)) then
 199      ioff = -1
 200   endif
 201
 202   err = 0
 203
 204   narg = iargc()
 205   numarg = narg + ioff
 206
 207   i = 1
 208   LOOP : do while ( i <= numarg)
 209
 210      ierr = 1
 211      if (present(i1)) then
 212         call checkiarg(i, a1, i1, ierr)
 213      elseif (present(h1)) then
 214         call checkharg(i, a1, h1, ierr)
 215      elseif (present(l1)) then
 216         call checklarg(i, a1, l1, ierr)
 217      endif
 218      if (ierr.eq.0) cycle LOOP
 219
 220      if (present(i2)) then
 221         call checkiarg(i, a2, i2, ierr)
 222      elseif (present(h2)) then
 223         call checkharg(i, a2, h2, ierr)
 224      elseif (present(l2)) then
 225         call checklarg(i, a2, l2, ierr)
 226      endif
 227      if (ierr.eq.0) cycle LOOP
 228
 229      if (present(i3)) then
 230         call checkiarg(i, a3, i3, ierr)
 231      elseif (present(h3)) then
 232         call checkharg(i, a3, h3, ierr)
 233      elseif (present(l3)) then
 234         call checklarg(i, a3, l3, ierr)
 235      endif
 236      if (ierr.eq.0) cycle LOOP
 237
 238      err = 1
 239      call getarg(1, hold)
 240      write(*, '("arg = ", A)') trim(hold)
 241
 242      exit LOOP
 243
 244   enddo LOOP
 245
 246   if (present(hlast)) then
 247      if (narg.eq.0) then
 248         err = 1
 249      else
 250         call getarg(narg, hlast)
 251      endif
 252   endif
 253
 254 contains
 255   subroutine checkiarg(c, a, i, ierr)
 256     integer :: c
 257     character(len=*) :: a
 258     integer :: i
 259
 260     character(len=100) :: hold
 261     ierr = 1
 262
 263     call getarg(c, hold)
 264
 265     if ('-'//a.eq.trim(hold)) then
 266        c = c + 1
 267        call getarg(c, hold)
 268        read(hold, *) i
 269        c = c + 1
 270        ierr = 0
 271     elseif ('-'//a .eq. hold(1:len_trim(a)+1)) then
 272        hold = hold(len_trim(a)+2: len(hold))
 273        read(hold, *) i
 274        c = c + 1
 275        ierr = 0
 276     endif
 277
 278   end subroutine checkiarg
 279   subroutine checkharg(c, a, h, ierr)
 280     integer :: c
 281     character(len=*) :: a
 282     character(len=*) :: h
 283
 284     character(len=100) :: hold
 285     ierr = 1
 286
 287     call getarg(c, hold)
 288
 289     if ('-'//a.eq.trim(hold)) then
 290        c = c + 1
 291        call getarg(c, hold)
 292        h = trim(hold)
 293        c = c + 1
 294        ierr = 0
 295     elseif ('-'//a .eq. hold(1:len_trim(a)+1)) then
 296        hold = hold(len_trim(a)+2: len(hold))
 297        h = trim(hold)
 298        c = c + 1
 299        ierr = 0
 300     endif
 301
 302   end subroutine checkharg
 303
 304   subroutine checklarg(c, a, l, ierr)
 305     integer :: c
 306     character(len=*) :: a
 307     logical :: l
 308
 309     character(len=100) :: hold
 310     ierr = 1
 311
 312     call getarg(c, hold)
 313     if ('-'//a.eq.trim(hold)) then
 314        l = .TRUE.
 315        c = c + 1
 316        ierr = 0
 317     endif
 318
 319   end subroutine checklarg
 320
 321 end subroutine parse_args
 322
 323