grbindex.f

Go to the documentation of this file.

 
 
      PROGRAM grbindex
      parameter(msk1=32000,msk2=4000)
      CHARACTER cgb*256,cgi*256
      parameter(mbuf=256*1024)
      CHARACTER cbuf(mbuf)
      CHARACTER carg*300
      INTEGER narg,iargc
 
!  GET ARGUMENTS
      narg=iargc()
      IF(narg.NE.2) THEN
        CALL errmsg('grbindex:  Incorrect usage')
        CALL errmsg('Usage: grbindex gribfile indexfile')
        CALL errexit(2)
      ENDIF
      CALL getarg(1,cgb)
      ncgb=len_trim(cgb)
      CALL baopenr(11,cgb(1:ncgb),ios)
      CALL baseto(1,1)
      IF(ios.NE.0) THEN
        lcarg=len('grbindex:  Error accessing file '//cgb(1:ncgb))
        carg(1:lcarg)='grbindex:  Error accessing file '//cgb(1:ncgb)
        CALL errmsg(carg(1:lcarg))
        CALL errexit(8)
      ENDIF
      CALL getarg(2,cgi)
      ncgi=len_trim(cgi)
      CALL baopen(31,cgi(1:ncgi),ios)
      IF(ios.NE.0) THEN
        lcarg=len('grbindex:  Error accessing file '//cgi(1:ncgi))
        carg(1:lcarg)='grbindex:  Error accessing file '//cgi(1:ncgi)
        CALL errmsg(carg(1:lcarg))
        CALL errexit(8)
      ENDIF
 
!  WRITE INDEX FILE
      mnum=0
      CALL getgir(11,msk1,msk2,mnum,mbuf,cbuf,nlen,nnum,irgi)
      IF(irgi.GT.1.OR.nnum.EQ.0) THEN
        CALL errmsg('grbindex:  No GRIB messages detected in file '
     &              //cgb(1:ncgb))
        CALL baclose(11,iret)
        CALL baclose(31,iret)
        CALL errexit(1)
      ENDIF
      mnum=mnum+nnum
      CALL wrgi1h(31,nlen,mnum,cgb(1:ncgb))
      iw=162
      CALL bawrite(31,iw,nlen*nnum,kw,cbuf)
      iw=iw+nlen*nnum
 
!  EXTEND INDEX FILE IF INDEX BUFFER LENGTH GREATER THAN MBUF
      IF(irgi.EQ.1) THEN
        dowhile(irgi.EQ.1.AND.nnum.GT.0)
          CALL getgir(11,msk1,msk2,mnum,mbuf,cbuf,nlen,nnum,irgi)
          IF(irgi.LE.1.AND.nnum.GT.0) THEN
            mnum=mnum+nnum
            CALL bawrite(31,iw,nlen*nnum,kw,cbuf)
            iw=iw+nlen*nnum
          ENDIF
        ENDDO
        CALL wrgi1h(31,nlen,mnum,cgb(1:ncgb))
      ENDIF
      CALL baclose(11,iret)
      CALL baclose(31,iret)
 
      END
 
      SUBROUTINE wrgi1h(LUGI,NLEN,NNUM,CGB)
      CHARACTER CGB*(*)
#ifdef __GFORTRAN__
      CHARACTER CD8*8,CT10*10,HOSTNAME*15
      INTEGER ISTAT
#else
      CHARACTER CD8*8,CT10*10,HOSTNAM*15
#endif
      CHARACTER CHEAD(2)*81
 
!  FILL FIRST 81-BYTE HEADER
      ncgb=len(cgb)
      ncgb1=ncbase(cgb,ncgb)
      ncgb2=ncbase(cgb,ncgb1-2)
      CALL date_and_time(cd8,ct10)
      chead(1)='!GFHDR!'
      chead(1)(9:10)=' 1'
      chead(1)(12:14)='  1'
      WRITE(chead(1)(16:20),'(I5)') 162
      chead(1)(22:31)=cd8(1:4)//'-'//cd8(5:6)//'-'//cd8(7:8)
      chead(1)(33:40)=ct10(1:2)//':'//ct10(3:4)//':'//ct10(5:6)
      chead(1)(42:47)='GB1IX1'
      chead(1)(49:54)=cgb(ncgb2:ncgb1-2)
#ifdef __GFORTRAN__
      istat=hostnm(hostname)
      IF(istat.eq.0) THEN
        chead(1)(56:70)='0000'
      ELSE
        chead(1)(56:70)='0001'
      ENDIF
#else
      chead(1)(56:70)=hostnam(hostname)
#endif
!     print*,' CHEAD(1)(56:70) = ', CHEAD(1)(56:70)
      chead(1)(72:80)='grbindex '
      chead(1)(81:81)=char(10)
 
!  FILL SECOND 81-BYTE HEADER
      chead(2)='IX1FORM:'
      WRITE(chead(2)(9:38),'(3I10)') 162,nlen,nnum
      chead(2)(41:80)=cgb(ncgb1:ncgb)
      chead(2)(81:81)=char(10)
 
!  WRITE HEADERS AT BEGINNING OF INDEX FILE
      CALL bawrite(lugi,0,162,kw,chead)
 
      RETURN
      END
 
      FUNCTION ncbase(C,N)
      CHARACTER c*(*)
 
      k=n
      dowhile(k.GE.1.AND.c(k:k).NE.'/')
        k=k-1
      ENDDO
      ncbase=k+1
 
      RETURN
      END