      PROGRAM SPLITGRIB
C
C     Program to split a gribfile
C
C     Given an input grib file name e.g. mygrib, a directory is created
C     called d_mygrib. (Note that a rm -rf d_mygrib is done first.)
C     After this the grib fields in mygrib are written as individual
C     files called xxx.yy, where xxx and yy are the respective mars grib
C     code and yy the level as determined by isec1(6) and isec1(8).
C
C     Author :- George Mozdzynski, August 1995
C
      PARAMETER (JPGRIB=140000)
      PARAMETER (jpfp=205000)
      DIMENSION IGRIB(jpgrib)
      DIMENSION fpdata(jpfp)
      integer   isec0(2),isec1(512),isec2(22+640),
     s          isec3(2),isec4(42)
      REAL      zsec2(212),zsec3(2)
      CHARACTER*80 cnamein
      CHARACTER*128 cnameout
      CHARACTER*128 cdname
      CHARACTER*7  cparmlev
      INTEGER GETOPT,GETOARG
      CHARACTER*80 CLARG
      CHARACTER CLOPT
C      write(*,'("input gribfile name to be split ->")')
C      read(*,'(a)')cnamein
      IARG=0
      GET_LOOP:DO
        IOPTVAL=GETOPT('i:?',CLARG)
        CLOPT=CHAR(IOPTVAL)
        IF (IOPTVAL.EQ.-1) THEN
          IF(IARG.EQ.0) THEN
            print *,'NO OPTION SUPPLIED ...'
            print *,'USAGE: splitgrib -i input '
            print *,'more help with "inqgrb -\?"'
            GOTO 998
          ELSE
            EXIT GET_LOOP
          ENDIF
        ENDIF
        IF(CLOPT.EQ.'i') THEN
          IARG=IARG+1
          READ(UNIT=CLARG,FMT='(A80)') cnamein
        ENDIF
        IF(CLOPT.EQ.'?') THEN
          print *,
     S     'splitgrib splits input file into separate files ',
     S     'according to the parameters in the input'
          print *,
     S     'input == gribfile '
          print *,
     S     'The splitted files are in the subdirectory d_input'
          print *,'USAGE: splitgrib -i input '
          GOTO 998
        ENDIF
      ENDDO GET_LOOP
      
      call pbopen(iuin,cnamein,'r',ierr)
      if( ierr.ne.0 )then
        write(*,'(" error on pbopen call, ierr=",i5)')ierr
        goto 999
      endif

      inclen=index(cnamein,' ')-1
      cdname='d_'//cnamein(1:inclen)
      inclen=index(cdname,' ')-1
c      call system('rm -rf '//cdname(1:inclen)//' || true')
      call system('mkdir '//cdname(1:inclen)//' || true')

100   continue
      call pbgrib(iuin,igrib,jpgrib*4,ilen,ierr)
      if( ierr.eq.-1 )goto 999
      if( ierr.ne.0 )then
        write(*,'(" error on pbgrib call, ierr=",i5)')ierr
        goto 999
      endif
      call gribex(isec0,isec1,isec2,zsec2,isec3,zsec3,isec4,
     1            fpdata,jpfp,igrib,jpgrib,iword,'I' ,ierr)
      if( ierr.ne.0 )then
        write(*,'(" error on gribex I call, ierr=",i5)')ierr
        goto 999
      endif
c     print *,'isec0---',isec0
c     print *,'isec1---',isec1
      iparm=Isec1(6)
      ilevel=Isec1(8)
C  modify grib headers
      if( (Isec2(1).eq.4).and.(Isec1(7).ne.109) ) then
        ilevel=0
      else
        if( iparm.eq.129 ) then
          call gribex(isec0,isec1,isec2,zsec2,isec3,zsec3,isec4,
     1         fpdata,jpfp,igrib,jpgrib,iword,'D' ,ierr)
          if( ierr.ne.0 )then
            write(*,'(" error on gribex D call, ierr=",i5)')ierr
            goto 999
          endif
          ilevel=1
          Isec1(7)=109
          Isec1(8)=1
          call gribex(isec0,isec1,isec2,zsec2,isec3,zsec3,
     1                isec4,fpdata,jpfp,igrib,jpgrib,iword,
     2                'C' ,ierr)
          ilen=iword*4
          if( ierr.ne.0 )then
            write(*,'(" error on gribex C call, ierr=",i5)')
     1            ierr
            goto 999
          endif
        else
          ilevel=Isec1(8)
        endif
      endif

      write(cparmlev,'("/",i3.3,".",i2.2)')iparm,ilevel
      inclen=index(cnamein,' ')-1
      cdname='d_'//cnamein(1:inclen)
      inclen=index(cdname,' ')-1
      cnameout=cdname(1:inclen)//cparmlev
      write(*,'("writing ",a)')cnameout
      call pbopen(iuout,cnameout,'w',iret)
      call pbwrite(iuout,igrib,ilen,iret)
      CALL pbclose(iuout,iret)
      goto 100

 998  continue
      call setrcd(1)
      call exit(1)

 999  continue
      END

C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      INTEGER FUNCTION getopt(y_optstr, y_optarg)
      CHARACTER*(*)           y_optstr, y_optarg

      CHARACTER*512           y_arg
      CHARACTER*1             y_opt
      LOGICAL                 ll_endopts

      COMMON/gopt_com1/ initial  ,n_args  ,n_arg   ,ndx_arg ,ll_endopts
      COMMON/gopt_com2/ y_arg

C  Initialise on 1st. call
C  -----------------------

      IF (initial .NE. 123456) THEN
         initial    = 123456
         n_args     = iargc()
         n_arg      = 0
         ndx_arg    = 0
         ll_endopts = .FALSE.
      ENDIF

      y_optarg = ' '

C  Get length of "y_optstr"
C  ------------------------

      l_optstr = 0
      DO 10 i = len(y_optstr), 1, -1
      IF (y_optstr(i : i) .NE. ' ') THEN
         l_optstr = i
         GOTO 20
      ENDIF
   10 CONTINUE
   20 CONTINUE

C  If already at end of options, return
C  ------------------------------------

      IF ((n_arg .GT. n_args) .OR. ll_endopts) THEN
         ll_endopts = .TRUE.
         getopt = -1
         RETURN
      ENDIF

C  If we need to get the next argument, do so. Check for end of options
C  --------------------------------------------------------------------

      IF (ndx_arg .EQ. 0) THEN
         n_arg = n_arg + 1

         IF (n_arg .GT. n_args) THEN
            ll_endopts = .TRUE.
            getopt     = -1
            RETURN
         ENDIF

         y_arg   = ' '
         CALL getarg(n_arg, y_arg)
         ndx_arg = 1

         IF (y_arg(1 : 1) .NE. '-') THEN
            ll_endopts = .TRUE.
            getopt     = -1
            RETURN

         ELSE IF (y_arg .EQ. '--') THEN
            ll_endopts = .TRUE.
            n_arg      = n_arg + 1
            y_arg      = ' '
            IF (n_arg .LE. n_args) THEN
               CALL getarg(n_arg, y_arg)
            ENDIF
            getopt     = -1
            RETURN
         ENDIF
         ndx_arg = 2
      ENDIF

C  We have an option, now see if it is valid
C  -----------------------------------------

      y_opt   = y_arg(ndx_arg : ndx_arg)
      ndx_opt = index(y_optstr, y_opt)

      IF (ndx_opt .EQ. 0) THEN
         ndx_arg = ndx_arg + 1
         IF (y_arg(ndx_arg : ) .EQ. ' ') THEN
            ndx_arg = 0
         ENDIF
         getopt = ichar(y_opt)
         RETURN
      ENDIF

C  We have a valid option, see if it should have an argument
C  ---------------------------------------------------------

      ndx_arg = ndx_arg + 1
      IF (y_arg(ndx_arg :) .EQ. ' ') THEN
         ndx_arg = 0
      ENDIF

      IF (ndx_opt .EQ. l_optstr) THEN
         getopt = ichar(y_opt)
         RETURN
      ELSE IF (y_optstr(ndx_opt + 1 : ndx_opt + 1) .NE. ':') THEN
         getopt = ichar(y_opt)
         RETURN
      ENDIF


C  A valid option with an argument
C  -------------------------------

      IF (ndx_arg .EQ. 0) THEN
         IF (n_arg .EQ. n_args) THEN
            ll_endopts = .TRUE.
            getopt     = 0
            RETURN
         ENDIF

         n_arg = n_arg + 1
         y_arg = ' '
         call getarg(n_arg, y_arg)
         ndx_arg = 1
         ll_endopts = n_arg .eq. n_args
      ENDIF

      y_optarg = y_arg(ndx_arg : )
      ndx_arg  = 0
      getopt   = ichar(y_opt)

      RETURN
      END

      INTEGER FUNCTION getoarg(y_argbuf)
      CHARACTER*(*)            y_argbuf

      CHARACTER*512           y_arg
      LOGICAL                 ll_endopts

      COMMON/gopt_com1/ initial  ,n_args  ,n_arg   ,ndx_arg ,ll_endopts
      COMMON/gopt_com2/ y_arg

      y_argbuf = ' '

      IF (initial .NE. 123456) THEN
         getoarg = -1
         RETURN
      ENDIF

      IF (.NOT. ll_endopts) THEN
         getoarg = -1
         RETURN
      ENDIF

      IF (n_arg .GT. n_args) THEN
         getoarg = 0
         RETURN
      ENDIF

      CALL getarg(n_arg, y_arg)

      y_argbuf = y_arg
      n_arg    = n_arg + 1
      getoarg  = 1

      RETURN
      END

C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
