tocgrib2.F90

Go to the documentation of this file.

 
 
PROGRAM tocgrib2
  use grib_mod
  use pdstemplates
  use gridtemplates
  integer, dimension(200) :: ids, gdt, pdt
  integer   ::    dscpl, gdtn, pdtn
  integer   ::    nbul, nrec, mbul, dayofmonth, hourofday
  integer, parameter :: lenhead=21, jrew=0
 
  CHARACTER * 80  desc, wmohead
  CHARACTER * 200  fileb, filei, fileo
  CHARACTER * 6   envvar
  CHARACTER * 1   csep(80)
  CHARACTER * 1   wmohdr(lenhead)
  character(len=1), pointer, dimension(:) :: gribm
 
  logical :: extract=.false.
  integer idxver
  integer (kind = 8) :: itot8
 
  interface
     subroutine getgb2p2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, &
          extract, idxver, k, gribm, leng8, iret)
       integer, intent(in) :: lugb, lugi, j, jdisc
       integer, dimension(:) :: jids(*)
       integer, intent(in) :: jpdtn
       integer, dimension(:) :: jpdt(*)
       integer, intent(in) :: jgdtn
       integer, dimension(:) :: jgdt(*)
       logical, intent(in) :: extract
       integer, intent(inout) :: idxver
       integer, intent(out) :: k
       character(len = 1), pointer, dimension(:) :: gribm
       integer (kind = 8), intent(out) :: leng8
       integer, intent(out) :: iret
     end subroutine getgb2p2
  end interface
  namelist /gribids/dscpl,ids,gdtn,gdt,pdtn,pdt,desc,wmohead,extract
 
  CALL w3tagb('tocgrib2', 2012, 0916, 0083, 'NP11')
 
  lugb=11      ! Input GRIB2 File
  lugi=31      ! Input GRIB2 INdex File
  lugo=51      ! Output transmission file.
 
  !        Read GRIB2 data and index file names from the FORT_nn
  !        environment variables, and open the files.
  envvar='FORT  '
  write(envvar(5:6), fmt='(I2)') lugb
  call getenv(envvar, fileb)
  write(envvar(5:6), fmt='(I2)') lugi
  call getenv(envvar, filei)
 
  call baopenr(lugb, fileb, iret1)
  if (iret1  .ne. 0) then
     write(6, fmt='(" Error opening GRIB file: ", A200)') fileb
     write(6, fmt='(" baopenr error = ", I5)') iret1
     stop 10
  endif
 
  !         Open GRIB2 index file.  If doesn't open, use just the data
  !         file.
  call baopenr(lugi, filei, iret2)
  if (iret2  .ne. 0) then
     lugi=0
  endif
 
  !        Read output GRIB bulletin file name from  FORTnn
  !        environment variable, and open file.
  write(envvar(5:6), fmt='(I2)') lugo
  call getenv(envvar, fileo)
  call baopenw(lugo, fileo, iret1)
  if (iret1  .ne. 0) then
     write(6, fmt='(" Error opening output transmission file: ", &
          A200)') fileo
     write(6, fmt='(" baopenw error = ", I5)') iret1
     stop 20
  endif
 
  !        loop through input control records.
  iret=0
  nbul=0
  nrec = 0
  foreachinputrecord: do
 
     !  Set Namelist defaults
     dscpl=-1     ! Grib2 Discipline number
     ids=-9999    ! GRIB2 Identification Section
     gdtn=-1      ! Grid Definition Template Number
     gdt=-9999    ! Grid Definition Template
     pdtn=-1      ! Product Definition Template Number
     pdt=-9999    ! Product Definition Template
     wmohead='TTAAnn CCCC'
     extract=.false.
 
     READ (*, gribids, iostat=ios, end=999)
     nrec = nrec + 1
     if (ios .ne. 0) then
        write(6, fmt='(" Error reading PDS from input file. iostat = " &
             , i5)') ios
        cycle
     endif
 
     !  Echo input record
     WRITE(6, fmt='(/, ''***********************************'', &
          ''********************************************'')')
     write(6, '(A, I0)') ' Start new record no. =  ', nrec
     write(6, '(73A)') ' DESC=', desc(1:73)
     write(6, '(11A)') ' WMOHEAD=', wmohead(1:11)
     write(6, '(A, I0)') ' GRIB2 DISCIPLINE= ', dscpl
     write(6, '(A, 20(1x, I0))')' Section 1=', &
          (ids(j2), j2=1, 13)
     if (gdtn .ne. -1) then
        write(6, '(A, I0, A, 100(1x, I0))') ' GDT 3. ', gdtn, ' =', &
             (gdt(j2), j2=1, getgdtlen(gdtn))
     endif
     if (pdtn .ne. -1) then
        write(6, '(A, I0, A, 100(1x, I0))') ' PDT 4. ', pdtn, ' =', &
             (pdt(j2), j2=1, getpdtlen(pdtn))
     endif
 
     !        Read and return packed GRIB field
     idxver = 2
     CALL getgb2p2(lugb, lugi, jrew, dscpl, ids, pdtn, pdt, &
          gdtn, gdt, extract, idxver, krew, gribm, itot8, iret)
     itot = int(itot8, kind(4))
     IF (iret.NE.0) THEN
        IF (iret.EQ.96)WRITE(6, '(A)')' GETGB2P: ERROR READING INDEX' &
             //' FILE'
        IF (iret.EQ.97)WRITE(6, '(A)')' GETGB2P: ERROR READING GRIB' &
             //' FILE'
        IF (iret.EQ.99)WRITE(6, '(A)')' GETGB2P: ERROR REQUEST NOT' &
             //' FOUND'
        cycle
     END IF
     WRITE (6, '(A, 1x, I0)')' RECORD NO. OF GRIB RECORD IN INPUT ' &
          //'FILE = ', krew
     !
     WRITE (6, '(A, I0)')' Size of GRIB Field = ', itot
 
     !        MAKE Flag Field Separator block
     iopt=2
     insize=19
     call mkfldsep(csep, iopt, insize, itot+lenhead, lenout)
     !         WRITE(6, '(A, 80A)')'  csep = ', csep
 
     !        MAKE WMO HEADER
     dayofmonth=mova2i(gribm(16+16))
     hourofday=mova2i(gribm(16+17))
     CALL makwmo (wmohead(1:6), dayofmonth, hourofday, &
          wmohead(8:11), wmohdr)
     !         WRITE(6, '(21A)') '  WMOHEADER= ', WMOHDR
 
     !        write out Separator block, Abbreviated WMO Heading, 
     !        and GRIB2 field to output file.
     call wryte(lugo, lenout, csep)
     call wryte(lugo, lenhead, wmohdr)
     call wryte(lugo, itot, gribm)
     nbul=nbul+1
     if (associated(gribm)) then
        deallocate(gribm)
        nullify(gribm)
     endif
     !
  enddo foreachinputrecord
 
  ! CLOSING SECTION
999 if (nbul .EQ. 0) then
     WRITE (6, fmt='('' SOMETHING WRONG WITH DATA CARDS...'', &
          ''NOTHING WAS PROCESSED'')')
     !        CALL W3TAGE('tocgrib2')
     stop 19
  else
     call baclose (lugb, iret)
     call baclose (lugi, iret)
     call baclose (lugo, iret)
     WRITE (6, fmt='(//, '' ******** RECAP OF THIS EXECUTION '', &
          ''********'', /, 5X, ''READ  '', I6, '' INDIVIDUAL IDS'', &
          /, 5X, ''WROTE '', I6, '' BULLETINS OUT FOR TRANSMISSION'', &
          //)') nrec, nbul
  endif
  ! TEST TO SEE IF ANY BULLETINS MISSING
  mbul = nrec - nbul
  IF (mbul .ne. 0) THEN
     WRITE(6, '(A, 1X, I0)')' BULLETINS MISSING = ', mbul
     !        CALL W3TAGE('tocgrib2')
     stop 30
  END IF
 
  !      CALL W3TAGE('tocgrib2')
  stop
END PROGRAM tocgrib2