tocgrib2super.F90

Go to the documentation of this file.

 
 
PROGRAM tocgrib2super
  use grib_mod
  use pdstemplates
  use gridtemplates
  !
  integer,dimension(200) :: ids,gdt,pdt
  integer   ::    dscpl,gdtn,pdtn
  integer   ::    nbul,nrec,mbul,dayofmonth,hourofday,minofhour
  integer,parameter :: lenhead=21,jrew=0
  integer    itime(8)
  integer    fsize
  !
  CHARACTER * 16  superwmo
  CHARACTER * 80  desc,wmohead
  CHARACTER * 200 fileb,filei,fileo,filea
  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('tocgrib2super',2010,0900,0246,'NP11')
  lugb=11      ! Input GRIB2 File
  luga=12      ! Input file size
  lugi=31      ! Input GRIB2 INdex File
  lugo=51      ! Output transmission file.
  superwmo = 'SUPER WMO HEADER'
  insize = 19  ! The size of the flag field separator
  !
  !        Read GRIB2 data and index file names from the FORTnn
  !        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)') luga
  call getenv(envvar,filea)
  write(envvar(5:6),fmt='(I2)') lugi
  call getenv(envvar,filei)
  !
  !     Get the file size of the grib file
  !
  !     call baopenr(luga,filea,iret1)
  open(unit=luga,file='filesize',form='formatted',status='old', &
       iostat=iret1)
  if (iret1  .ne. 0) then
     write(6,fmt='(" Error opening GRIB file: ",A200)') filea
     write(6,fmt='(" baopenr error = ",I5)') iret1
     stop 10
  endif
  !
  READ(luga,'(I15)') fsize
  print *,' filesize ', fsize
  !
  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 FORT
  !        environment variable, and open file.
  !
  envvar='FORT  '
  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
  !
  !     NDFD grib file begins with a flag flied separator and size bytes of the file
  !     ****nnnnnnnnn****\lf  where "nnnnnnnn" is the size of the file(minus the separator)
  !     The size of the flag field separator is 19 bytes.
  !
  if (fsize >= insize) then
     fsize = fsize - insize
  else
     fsize=insize
  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.
     iopt=2
 
     READ (*,gribids,iostat=ios,end=999)
     !
     if (desc(1:16) .EQ. superwmo(1:16)) then
        !
        !        MAKE Flag Field Separator block
        !
        call mkfldsep(csep,iopt,insize,fsize,lenout)
        !
        !        MAKE SUPER WMO HEADER
        ! &
        !        GET COMPUTER DATE-TIME  SAVE FOR DATA DATE VERIFICATION
        CALL w3utcdat(itime)
        dayofmonth=itime(3)
        hourofday=itime(5)
        minofhour=itime(6)
        CALL makwmo (wmohead(1:6),dayofmonth,hourofday,minofhour, &
             wmohead(8:11),wmohdr)
        !
        !        write out Separator block, Abbreviated WMO Heading,
        !        and GRIB2 field to output file.
        !
        call wryte(lugo,lenout,csep)
        call wryte(lugo,lenhead,wmohdr)
        !
        write(6,'(16A)') ' DESC=',desc(1:16)
        write(6,'(11A)') ' WMOHEAD=',wmohead(1:11)
        !
        cycle
     endif
 
     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
     !
     call mkfldsep(csep,iopt,insize,itot+lenhead,lenout)
     !         WRITE(6,'(A,80A)')'  csep = ',csep
     !
     !        MAKE WMO HEADER
     !
     CALL makwmo (wmohead(1:6),dayofmonth,hourofday,minofhour, &
          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('tocgrib2super')
     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('tocgrib2super')
     stop 30
  END IF
  !
  !      CALL W3TAGE('tocgrib2super')
  stop
END PROGRAM tocgrib2super