C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM: GRIB           GRIB A GIVEN DATA ARRAY
C   PRGMMR: HAI-TIEN LEE     ORG: W/NMC53    DATE: 94-04-29
C
C ABSTRACT: GRIB A GIVEN DATA ARRAY
C
C PROGRAM HISTORY LOG:
C   1994-04-29  HAI-TIEN LEE
C   2009-03-05 : CRAIG LONG:
C                added IP2 and ITRI to COMGRIB
C                assigned IP2 to ID(19) 
C                assigned ITRI to ID(20) 
C   2022-01-24  HAI-TIEN LEE Mod for 0.25deg grid: nx=1440,ny=721
C
C USAGE:    CALL GRIBER(FLD,KBUF)
C   INPUT ARGUMENT LIST:
C     FLD      - GIVEN DATA ARRAY
C
C   OUTPUT ARGUMENT LIST:
C     KBUF     - GRIB message
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN77
C   MACHINE:  CRAY
C
C$$$
C***********************************************************************
      SUBROUTINE grib(FLD, KBUF)
C***********************************************************************
      PARAMETER (NX=1440,NY=721,NXY=NX*NY)
      PARAMETER (MXBIT=32,LENPDS=28,LENGDS=32)
      PARAMETER (MXSIZE=30+LENPDS+LENGDS+NXY*(MXBIT+1)/8)
C
      REAL FLD(NXY)
C
      INTEGER HEADER(5)
      INTEGER KPDS(LENPDS),KGDS(LENGDS),KPTR(10),KRET
      INTEGER ID(25),IBDSFL(12),IGDS(91)
      INTEGER JERR, NPTS
      integer iyy, imm, idd, ihr, ifcst, idscale,idmodel,idpara
     > idlevel, ITOT, ip1, ip2, itri
C
      LOGICAL*1 KBMS(NXY)
C
      CHARACTER*1 PDS(LENPDS),KBUF(MXSIZE)
C
      COMMON /COMGRIB/IYY,IMM,IDD,IHR,IFCST
     &     ,IDSCALE,IDMODEL,IDPARA,IDLEVEL
     &     ,ITOT,IP2, ITRI
C-------------------------------------------------------------
C
C REMARKS: LAYOUT OF 'ID' ARRAY:
C     ID(1)  = NUMBER OF BYTES IN PRODUCT DEFINITION SECTION (PDS)
C     ID(2)  = PARAMETER TABLE VERSION NUMBER
C     ID(3)  = IDENTIFICATION OF ORIGINATING CENTER
C     ID(4)  = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER)
C     ID(5)  = GRID IDENTIFICATION
C     ID(6)  = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED
C     ID(7)  = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED
C     ID(8)  = INDICATOR OF PARAMETER AND UNITS (TABLE 2)
C     ID(9)  = INDICATOR OF TYPE OF LEVEL       (TABLE 3)
C     ID(10) = VALUE 1 OF LEVEL  (0 FOR 1-100,102,103,105,107
C              109,111,113,115,117,119,125,126,160,200,201,
C              235,237,238
C              LEVEL IS IN ID WORD 11)
C     ID(11) = VALUE 2 OF LEVEL
C     ID(12) = YEAR OF CENTURY
C     ID(13) = MONTH OF YEAR
C     ID(14) = DAY OF MONTH
C     ID(15) = HOUR OF DAY
C     ID(16) = MINUTE OF HOUR   (IN MOST CASES SET TO 0)
C     ID(17) = FCST TIME UNIT
C     ID(18) = P1 PERIOD OF TIME
C     ID(19) = P2 PERIOD OF TIME
C     ID(20) = TIME RANGE INDICATOR
C     ID(21) = NUMBER INCLUDED IN AVERAGE
C     ID(22) = NUMBER MISSING FROM AVERAGES
C     ID(23) = CENTURY  (20, CHANGE TO 21 ON JAN. 1, 2001)
C     ID(24) = SUBCENTER IDENTIFICATION
C     ID(25) = SCALING POWER OF 10
C----------------------------------------------------------

      IMN = 00
      ITYPE = 0
      IFLD = 0
      IBITL = MXBIT
      IGRID = 193
      IPFLAG = 0
      IGFLAG = 0
C     IGDS = 0
      ICOMP = 0
      IBFLAG = 0
      IBMAP = 0
      IBLEN = 0

      IBDSFL(1)=0
      IBDSFL(2)=0
      IBDSFL(3)=ITYPE
      IBDSFL(4)=0
      IBDSFL(5)=0
      IBDSFL(6)=0
      IBDSFL(7)=0
      IBDSFL(8)=0
      IBDSFL(9)=0
      IBDSFL(10)=0
      IBDSFL(11)=0
      IBDSFL(12)=0

      ID( 1)=LENPDS
      ID( 2)=  2
      ID( 3)=  7
      ID( 4)=IDMODEL
      ID( 5)=IGRID
      ID( 6)=  1
      ID( 7)=  0
      ID( 8)=IDPARA
      ID( 9)=IDLEVEL
      ID(10)=  0
      ID(11)=  0
      ID(12)=IYY
      ID(13)=IMM
      ID(14)=IDD
      ID(15)=IHR
      ID(16)=IMN
      ID(17)= 1
      ID(18)=IFCST
      ID(19)=IP2 
      ID(20)=ITRI
      ID(21)= 0
      ID(22)= 0
      ID(23)=21
      ID(24)= 0
      ID(25)=IDSCALE

C...Calculate Bit length for packing data
      GMAX=0
      GMIN=500
      DS=10.**ID(25)
      DO I=1,NXY
         GMAX=MAX(FLD(I),GMAX)
         GMIN=MIN(FLD(I),GMIN)
      ENDDO
      write(6,910) gmax,gmin
  910 format(1x,'GRIB RANGE =', 2f8.2)
      NBIT=LOG((GMAX-GMIN)*DS+0.9)/LOG(2.)+1.
      IBITL=MIN(IBITL,NBIT)
C...FIX IBITL=12 FOR PACKING THE UV (Ranges from -1. to 500. mW/m**2; 
C   0 to 20 UVI 25mW/m**2)
      IBITL=12
      write(6,*) 'IBITL=',IBITL,' NBIT=',NBIT
C...Grib it
      CALL W3FI72(ITYPE,FLD,IFLD,IBITL,IPFLAG,ID,PDS,
     &     IGFLAG,IGRID,IGDS,ICOMP,
     &     IBFLAG,IBMAP,IBLEN,
     &     IBDSFL,
     &     NPTS,KBUF,ITOT,JERR)
      write(6,*) 'ITOT=',itot,' NPTS=',npts,' JERR=',jerr
C
      RETURN
      END