C********************************************************************
C  Program to remap GASP AOD NAM grid into GRIB1 format
C  Altered by Jian Zeng (Earth Resources Technology, Inc.)
C  Date: 2006-07-26
C********************************************************************
C
      SUBROUTINE  sub_gsmoke_aod_grib_NAM3(AOD,YY,MM,DD,HR,MN,KBUF)
C     integer*2 nx,ny
      integer*4 nx,ny
      integer*4 nlon,nlat
      integer*4 npoint,lenarr,mlon,mlat,maod,mcount,itot,itot1
C      integer*8 npoint,lenarr,mlon,mlat,maod,mcount,itot
      parameter(nx=801,ny=534)
      PARAMETER (LENPDS=28,LENGDS=32)
      parameter(npoint=nx*ny,lenarr=3+npoint*4,mlon=4,
     &  mlat=mlon+npoint,maod=mlat+npoint,mconc=maod+npoint)
      parameter(IBITL=16,IDSCAL=2)
      parameter(INUM=npoint*IBITL+88,NLEFT=MOD(INUM,16))
      parameter(itot1=8+LENPDS+LENGDS+(INUM+16-NLEFT)/8+4)
      CHARACTER*1 KBUF(ITOT1)
      real*4 lon(nx,ny),lat(nx,ny),aod(nx,ny),conc(nx,ny),
     &  arr(lenarr)

C      INTEGER IGRD, IDMODL, IDPARM, IDLVL, IDSCAL, YY, DD, MM, NF
      INTEGER I, J, HR,MN
      
C-----------------------------------------------------------------
C
      NF = 51
C
C     NAM---user defined
      IGRD = 255
C     not from any model
      IDMODL = 255
C     255---AOD,  89-smoke density
C      IDPARM = 255 (changed to 129 on 07/22/08 by t.feroli)
      IDPARM = 129
C     200-the entire atmosphere,  105---between two levels (0-5000m)
      IDLVL  = 200
C     AOD,  11 for smoke concentration
C      IDSCAL = 2
C
C      print *,YY,MM,DD,HR,MN
      CALL GRIBER2(AOD,IGRD,YY,MM,DD,HR,MN,IDMODL,IDPARM,IDLVL,
     > IDSCAL,NF,KBUF)

C      do i=itot-4,itot
C        print *, i, mova2i(KBUF(i))
C      enddo
C
C      CLOSE(51)
C
C      STOP
      END
C*************************************************************************
      SUBROUTINE GRIBER2(FLD,JGRID,IYY,IMM,IDD,IHR,IMN,IDMODL,idparm,
     &                  IDLVL,IDSCAL,NF,KBUF)
C*************************************************************************
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM: GRIBER         GRIB A GIVEN DATA ARRAY
C   PRGMMR: ROGER LIN        ORG: W/NMC53    DATE: 96-03-01
C
C ABSTRACT: GRIB A GIVEN DATA ARRAY
C
C PROGRAM HISTORY LOG:
C   96-03-01  ROGER LIN
C
C USAGE:    CALL GRIBER(FLD,IHEM,IYY,IMM,IDD,IDMODL,idparm,
C    &                  IDLVL,IDSCAL,NF)
C   INPUT ARGUMENT LIST:
C     FLD      - GIVEN DATA ARRAY
C     IHEM     - HEMISPHERIC INDICATOT, NH=1,SH=2
C     IYY      - YEAR(I2)
C     IMM      - MONTH(I2)
C     IDD      - DAY(I2)
C     IDMODL   - MODEL ID
C     idparm   - PARAMETER ID
C     IDLVL    - LEVEL TYPE ID
C     IDSCAL   - SCALING FACTOR
C     NF       - OUTPUT UNIT NUMBER
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     NF       - GRIB MESSAGE OUTPUT TO UNIT NF
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN77
C   MACHINE:  CRAY
C
C*************************************************************************
C      PARAMETER (NX=668,NY=401,NXY=NX*NY) (changed 07/22/08 by t.feroli)
      PARAMETER (NX=801,NY=534,NXY=NX*NY)
      PARAMETER (MXBIT=32,LENPDS=28,LENGDS=32)
      PARAMETER (IBITL=16)
      PARAMETER (MXSIZE=30+LENPDS+LENGDS+NXY*(MXBIT+1)/8)
      INTEGER   JERR
      integer*4 ITOT, NPTS
      parameter(INUM=nxy*IBITL+88,NLEFT=MOD(INUM,16))
C      parameter(itot=8+LENPDS+LENGDS+(INUM+16-NLEFT)/8+4)
      parameter(itot1=8+LENPDS+LENGDS+(INUM+16-NLEFT)/8+4)
      REAL FLD(NXY)
      INTEGER HEADER(5)
      INTEGER KPDS(LENPDS),KGDS(LENGDS),KPTR(10),KRET
      LOGICAL*1 KBMS(NXY)
      INTEGER ID(25),IBDSFL(12),IGDS(91)
      CHARACTER*1 PDS(LENPDS)
      CHARACTER*1 KBUF(ITOT1)
C------------------------------------------------------------------------
      IFCST=0
      ITYPE=0
      IFLD=0
      WRITE(6,*) 'JGRID=',JGRID
      IPFLAG=0

C     1--NAM is user defined grid, AOF_5x--148, NDGD--227
C     or IGFLAG=0 and add GRID255 in w3fi71.f
      IGFLAG=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
C     Parameter Table version
C      ID( 2)=  2
C     Changed to Table 141 on 07/22/08 by t.feroli
      ID( 2)=  141
C     NOAA/NESDIS
      ID( 3)=  160
      ID( 4)=IDMODL
      ID( 5)=JGRID
C     include GDS
      ID( 6)=  1
      ID( 7)=  0
      ID( 8)=IDPARM
      ID( 9)=IDLVL
      ID(10)=  0
      ID(11)=  0
      ID(12)=IYY
      ID(13)=IMM
      ID(14)=IDD
      ID(15)=IHR
      ID(16)=IMN
C     1--hourly
      ID(17)= 0
      ID(18)=IFCST
      ID(19)= 0
      ID(20)= 0
      ID(21)= 0
      ID(22)= 0
C     century
      ID(23)=21
C     NESDIS/ORA
      ID(24)=12
      ID(25)=IDSCAL

C...CALCULATE BIT LENGTH FOR PACKING DATA
      GMAX=-99999
      GMIN=99999
      DS=10.**ID(25)
      DO 400 I=1,NXY
         GMAX=MAX(FLD(I),GMAX)
         GMIN=MIN(FLD(I),GMIN)
C	 write(6,*) FLD(I)
 400  CONTINUE
      WRITE(6,*) 'RANGE:', GMAX,GMIN

C...GRIB IT, create PDS with ID(25) or with user supplied PDS if IPFLAG=1
      IPFLAG=0
      CALL W3FI72n(ITYPE,FLD,IFLD,IBITL,IPFLAG,ID,PDS,
     &     IGFLAG,JGRID,IGDS,ICOMP,
     &     IBFLAG,IBMAP,IBLEN,
     &     IBDSFL,
     &     NPTS,KBUF,ITOT,JERR)


C
      WRITE(6,*) 'JERR =', JERR
C
      WRITE(6,*) 'ITOT=',ITOT,' NPTS=',NPTS,' JERR=',JERR
      WRITE(6,*) 'PDS:'
      WRITE(6,'(8I10/)') (ICHAR(PDS(I)),I=1,LENPDS)

      RETURN
      END
