PROGRAM MKGFSAWPS
C$$$  MAIN PROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C MAIN PROGRAM: MKGFSAWPS
C   PRGMMR: VUONG            ORG: NP11        DATE: 2004-04-21
C
C ABSTRACT: PROGRAM READS GRIB FILE FROM SPECTRAL MODEL WITH 0.5 DEGREE
C           (GRID 4) OR 1 DEGREE (GRID 3) OR 2.5 DEGREE (GRID 2) RECORDS.
C           UNPACKS THEM, AND CAN MAKE AWIPS GRIB GRIDS 201,202, 203, 
C           204, 211, 213 and 225.  THEN, ADD A TOC FLAG FIELD SEPARATOR
C           BLOCK AND WMO HEADER IN FRONT OF EACH GRIB FIELD, AND WRITES
C           THEM OUT TO A NEW FILE.  THE OUTPUT FILE IS IN THE FORMAT
C           REQUIRED FOR TOC'S FTP INPUT SERVICE, WHICH CAN BE USED TO
C           DISSEMINATE THE GRIB BULLETINS.
C
C PROGRAM HISTORY LOG:
C   2004-04-21    VUONG
C   2010-05-27    VUONG   INCREASED SIZE OF ARRAYS
C                       
C USAGE:
C   INPUT FILES:
C      5       - STANDARD FORTRAN INPUT FILE.
C     11       - GRIB FILE FROM SPECTRAL MODEL WITH GRID 2 OR 3.
C     31       - CRAY GRIB INDEX FILE FOR FILE 11
C     PARM     - PASS IN 4 CHARACTERS 'KWBX' WITH PARM FIELD
C
C   OUTPUT FILES:  (INCLUDING SCRATCH FILES)
C      6       - STANDARD FORTRAN PRINT FILE
C     51       - AWIPS GRIB GRID TYPE 201,202,203,211,213 and 225 RECORDS
C                MADE FROM GRIB GRID 2, 3 OR 4 RECORDS.
C
C   SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES)
C     UNIQUE:    - MAKWMO
C     LIBRARY:
C       W3LIB    - W3AS00 IW3PDS W3FP11 W3UTCDAT
C                  W3FI63 W3FI72 W3FI83 W3TAGB GETGB GETGBP
C       BACIO    - BAREAD BAOPENR BAOPENW BACLOSE
C
C   EXIT STATES:
C     COND =   0 - SUCCESSFUL RUN
C             10 - ERROR OPENING INPUT GRIB DATA FILE
C             18 - ERROR READING CONTROL CARD FILE
C             19 - ERROR READING CONTROL CARD FILE
C             20 - ERROR OPENING OUTPUT GRIB FILE
C             30 - BULLETINS ARE MISSING
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
      PARAMETER (MXSIZE=2000000,MXSIZ3=MXSIZE*3)
      PARAMETER (LUGI=31,LUGB=11,LUGO=51)
      PARAMETER (LENHEAD=21)
C
      REAL            FLDI(MXSIZE)
      REAL            FLDV(MXSIZE)
      REAL            FLDO(MXSIZE),FLDVO(MXSIZE)
      REAL            RLAT(MXSIZE),RLON(MXSIZE)
      REAL            CROT(MXSIZE),SROT(MXSIZE)
C
      INTEGER         D(20)
      INTEGER         IFLD(MXSIZE)
      INTEGER         IBDSFL(12)
      INTEGER         IBMAP(MXSIZE)
      INTEGER         IDAWIP(200)
      INTEGER         JGDS(100)
      INTEGER         MPDS(25)
      INTEGER,DIMENSION(8):: ITIME=(/0,0,0,-500,0,0,0,0/)
      INTEGER         KGDS(200),KGDSO(200)
      INTEGER         KPDS(25)
      INTEGER         MAPNUM(20)
      INTEGER         NBITS(20)
      INTEGER         NPARM
      INTEGER         NBUL
      INTEGER         PUNUM
      INTEGER         IPOPT(20)
      INTEGER,DIMENSION(28)::  HEXPDS
C
      CHARACTER * 6   BULHED(20)
      CHARACTER * 100 CPARM
      CHARACTER * 17  DESC
      CHARACTER * 3   EOML
      CHARACTER * 1   GRIB(MXSIZ3)
      CHARACTER * 1   KBUF(MXSIZ3)
      CHARACTER * 4   KWBX
      CHARACTER * 2   NGBFLG
      CHARACTER * 1   PDS(28),GDS(400)
      CHARACTER * 1   PDSL(28)
      CHARACTER * 1   PDSAWIP(28)
      CHARACTER * 132 TITLE
      CHARACTER * 1   WMOHDR(21)
      CHARACTER * 1   WFLAG
      CHARACTER * 6   ENVVAR
      CHARACTER * 80  FIlEB,FILEI,FILEO
      CHARACTER * 1   CSEP(80)
C
      LOGICAL         IW3PDS
      LOGICAL*1       KBMS(MXSIZE),KBMSO(MXSIZE)
C
      SAVE
C
      DATA  IBDSFL/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
      DATA IP/0/,IPOPT/1,19*0/
      DATA HEXPDS /28*0/
      DATA KM/1/
C
      CALL W3TAGB('MKGFSAWIPS',2004,0112,0112,'NP11')                  
C
C     READ GRIB DATA AND INDEX FILE NAMES FROM THE FORT
C     ENVIRONMENT VARIABLES, AND OPEN THE FILES.
C
      ENVVAR='FORT  '
      WRITE(ENVVAR(5:6),FMT='(I2)') LUGB
      CALL GETENV(ENVVAR,FILEB)
      WRITE(ENVVAR(5:6),FMT='(I2)') LUGI
      CALL GETENV(ENVVAR,FILEI)

      CALL BAOPENR(LUGB,FILEB,IRET1)
      IF ( IRET1  .NE. 0 ) THEN
        WRITE(6,FMT='(" ERROR OPENING GRIB FILE: ",A80)') FILEB
        WRITE(6,FMT='(" BAOPENR ERROR = ",I5)') IRET1
        STOP 10
      ENDIF

      CALL BAOPENR(LUGI,FILEI,IRET2)
      IF ( IRET2  .NE. 0 ) THEN
        WRITE(6,FMT='(" ERROR OPENING GRIB FILE: ",A80)') FILEB
        WRITE(6,FMT='(" BAOPENR ERROR = ",I5)') IRET2
        STOP 10
      ENDIF
C
C     READ OUTPUT GRIB BULLETIN FILE NAME FROM FORT
C     ENVIRONMENT VARIABLE, AND OPEN FILE.
C
      ENVVAR='FORT  '
      WRITE(ENVVAR(5:6),FMT='(I2)') LUGO
      CALL GETENV(ENVVAR,FILEO)
      CALL BAOPENW(LUGO,FILEO,IRET3)
      IF ( IRET3  .NE. 0 ) THEN
        WRITE(6,FMT='(" ERROR OPENING OUTPUT GRIB FILE: ",A80)') FILEB
        WRITE(6,FMT='(" BAOPENW ERROR = ",I5)') IRET3
        STOP 20
      ENDIF
C
C     GET PARM FIELD WITH UP TO 100 CHARACTERS
C
      CPARM = '    '
      KWBX  = 'KWBC'
      CALL W3AS00(NPARM,CPARM,IER)
      IF (IER.EQ.0) THEN
        IF (NPARM.EQ.0.OR.CPARM(1:4).EQ.'    ') THEN
          PRINT *,'THERE IS A PARM FIELD BUT IT IS EMPTY'
          PRINT *,'OR BLANK, I WILL USE THE DEFAULT KWBC'
        ELSE
	  KWBX(1:4) = CPARM(1:4)
        END IF
      ELSE IF (IER.EQ.2.OR.IER.EQ.3) THEN
	PRINT *,'W3AS00 ERROR = ',IER
        PRINT *,'THERE IS NO PARM FIELD, I USED DEFAULT KWBC'
      ELSE
	PRINT *,'W3AS00 ERROR = ',IER
      END IF
      PRINT *,'NPARM = ',NPARM
      PRINT *,'CPARM = ',CPARM(1:4)
      PRINT *,'KWBX  = ',KWBX(1:4)
C
      IRET   = 0
      IOPT   = 2
      INSIZE = 19
      NBUL   = 0
      NGBSUM = 0
C
      CALL W3UTCDAT (ITIME)
C
C     LOOP TO READ UNPACKED GRIB DATA
C     28 BYTE PDS AND 65160 FLOATING POINT NUMBERS
C
      NREC = 0
      DO 699 IREAD = 1,1000
        READ (*,66,END=800) (HEXPDS(J),J=1,12),
     &        (HEXPDS(J),J=17,20), PUNUM, NGBFLG, DESC
 66     FORMAT(3(2X,4Z2),3X,4Z2,6X,I3,1X,A2,1X,A17)
C
C     CHARACTERS ON CONTROL CARD NOT 0-9, A-F, OR a-f
C     ALL RECORD EXCEPT V-GRD ARE READ INTO ARRAY C
C
C     EXIT LOOP, IF NO MORE BULLETINS IN INPUT CARDS
C
        PDS=CHAR(HEXPDS)
        IF (MOVA2I(PDS(1)) .EQ. 255) EXIT
        NREC = NREC + 1
        WRITE (6,FMT='(''**************************************'',
     &      ''************************************************'')')
        PRINT *,'START NEW RECORD NO. = ',NREC
        WRITE (6,FMT='('' INPUT PDS, PUNUM, NGBFLG'',
     &        '' & DESC...DESIRED GRIB MAPS LISTED ON FOLLOWING '',
     &        ''LINES...'',/,4X,3(2X,4Z2.2),3X,4Z2.2,6X,I3,1X,A2,
     &        1X,A17)') (HEXPDS(J),J=1,12),
     &        (HEXPDS(J),J=17,20), PUNUM, NGBFLG, DESC
C
C  READ IN GRIDS TO INTERPOLATE TO
C
      NGB   = 0
      DO J = 1,20
        READ (*,END=710,FMT='(4X,I3,2X,I2,2X,A6,1X,I3,24X,A3)')
     &          MAPNUM(J),NBITS(J), BULHED(J), D(J), EOML
        WRITE (6,FMT='(4X,I3,2X,I2,2X,A6,1X,I3,24X,A3)')
     &           MAPNUM(J),NBITS(J), BULHED(J), D(J), EOML
                NGB = J
        IF (EOML .EQ. 'EOM') EXIT
      ENDDO
C
      NGBSUM  = NGBSUM + NGB
      JREW    = 0
      MPDS    = -1
      JGDS    = -1
      MPDS(3) = MOVA2I(PDS(7))
      MPDS(5) = MOVA2I(PDS(9))
      WFLAG   = ' '
      IF (MPDS(5).EQ.33) THEN
        WFLAG = 'U'
      ELSE IF (MPDS(5).EQ.34) THEN
        WFLAG = 'V'
      END IF
      MPDS(6) = MOVA2I(PDS(10))
      MPDS(7) = MOVA2I(PDS(11)) * 256 + MOVA2I(PDS(12))
      IF (MPDS(5).EQ.61.OR.MPDS(5).EQ.62.OR.
     &    MPDS(5).EQ.63) THEN
          MPDS(14) = MOVA2I(PDS(19))
          MPDS(15) = MOVA2I(PDS(20))
      END IF
C
C     PRINT *,'CHECK POINT BEFORE GETGB'
C     IF YOU GET U-GRD, ALSO READ V-GRD INTO ARRAY FLDV
C     ALL RECORD EXCEPT V-GRD ARE READ INTO ARRAY FLDI
C     IF YOU GET V-GRD, READ INTO ARRAY FLDV, READ U-GRD INTO FLDI
C
      IF (WFLAG.EQ.'V') MPDS(5) = 33
      CALL GETGB(LUGB,LUGI,MXSIZE,JREW,MPDS,JGDS,
     &      MI,KREW,KPDS,KGDS,KBMS,FLDI,IRET)
      CALL GETGBP(LUGB,LUGI,MXSIZ3,KREW-1,MPDS,JGDS,
     &      KBYTES,KREW,KPDS,KGDS,GRIB,IRET)
      IF (IRET.NE.0) THEN
        IF (IRET.LT.96) PRINT *,'GETGB-W3FI63: ERROR = ',IRET
        IF (IRET.EQ.96) PRINT *,'GETGB: ERROR READING INDEX FILE'
        IF (IRET.EQ.97) PRINT *,'GETGB: ERROR READING GRIB FILE'
        IF (IRET.EQ.98) THEN
          PRINT *,'GETGB ERROR: NUM. OF DATA POINTS GREATER THAN JF'
        END IF
        IF (IRET.EQ.99) PRINT *,'GETGB ERROR: REQUEST NOT FOUND'
        IF (IRET.GT.99) PRINT *,'GETGB ERROR = ',IRET
        GO TO 699
      END IF
      PDSL(1:28)=GRIB(9:36)
      IBI=MOD(KPDS(4)/64,2)
      IF (WFLAG.EQ.'U') THEN
        CALL W3FP11 (GRIB,PDSL,TITLE,IER)
C
C     COMPARE RECORD (GRIB) TO CONTROL CARD (PDS), THEY SHOULD MATCH
C
        KEY = 2
        IF (.NOT.IW3PDS(PDSL,PDS,KEY)) THEN
          PRINT 2900, IREAD, (MOVA2I(PDSL(J)),J=1,28),
     *                       (MOVA2I(PDS(J)),J=1,28)
          GO TO 699
        END IF
      END IF
C
C     READ V-GRD INTO ARRAY FLDV
C
      IF (WFLAG.EQ.'U'.OR.WFLAG.EQ.'V') THEN
        MPDS(5) = 34
        CALL GETGB(LUGB,LUGI,MXSIZE,JREW,MPDS,JGDS,
     &      MI,KREW,KPDS,KGDS,KBMS,FLDV,JRET)
        CALL GETGBP(LUGB,LUGI,MXSIZ3,KREW-1,MPDS,JGDS,
     &      KBYTES,KREW,KPDS,KGDS,GRIB,JRET)
        IF (JRET.NE.0) THEN
        IF (JRET.LT.96) PRINT *,'GETGB-W3FI63: ERROR = ',JRET
        IF (JRET.EQ.96) PRINT *,'GETGB: ERROR READING INDEX FILE'
        IF (JRET.EQ.97) PRINT *,'GETGB: ERROR READING GRIB FILE'
        IF (JRET.EQ.98) THEN
          PRINT *,'GETGB ERROR: NUM. OF DATA POINTS GREATER THAN JF'
        END IF
        IF (JRET.EQ.99) PRINT *,'GETGB ERROR: REQUEST NOT FOUND'
        IF (JRET.GT.99) PRINT *,'GETGB ERROR = ',JRET
          GO TO 699
        END IF
        IF (WFLAG.EQ.'V') THEN
          CALL W3FP11 (GRIB,PDSL,TITLE,IER)
        END IF
      END IF
      PRINT *,'RECORD NO. OF GRIB RECORD IN INPUT FILE = ',KREW
C
C     COMPARE RECORD (GRIB) TO CONTROL CARD (PDS), THEY SHOULD MATCH
C
      KEY = 2
      IF (WFLAG.EQ.' '.OR.WFLAG.EQ.'V') THEN
        PDSL(1:28)=GRIB(9:36)
        IF (.NOT.IW3PDS(PDSL,PDS,KEY)) THEN
          PRINT 2900, IREAD, (MOVA2I(PDSL(J)),J=1,28),
     *                       (MOVA2I(PDS(J)),J=1,28)
2900      FORMAT ( 1X,I4,' (PDS) IN RECORD DOES NOT MATCH (PDS) IN ',
     &   'CONTROL CARD ',/,7(1X,4Z2.2), /,7(1X,4Z2.2))
          GO TO 699
        END IF
      END IF
C
      PRINT 2, (MOVA2I(PDSL(J)),J=1,28)
 2    FORMAT (' PDS = ',7(4Z2.2,1X))
C
      IF (WFLAG.EQ.' ') THEN
        CALL W3FP11 (GRIB,PDSL,TITLE,IER)
      END IF
      IF (IER.NE.0) PRINT *,'W3FP11 ERROR = ',IER
      PRINT *,TITLE(1:86)
C
C  MASK OUT ZERO PRECIP GRIDPOINTS BEFORE INTERPOLATION
C
      IF (MPDS(5).EQ.61.OR.MPDS(5).EQ.62.OR.
     &    MPDS(5).EQ.63) THEN
        DO J=1,MI
          IF ( FLDI(J).EQ.0.0 ) THEN
           KBMS(J)=.FALSE.
           IBI=1
          ENDIF
        ENDDO
      END IF
C
C  PROCESS EACH GRID
C
      DO 690 I = 1,NGB

        CALL MAKGDS(MAPNUM(I),KGDSO,GDS,LENGDS,IRET)
        IF ( IRET.NE.0) THEN
          PRINT *,' GRID ',MAPNUM(I),' NOT VALID.'
          CYCLE
        ENDIF

        IF (WFLAG.EQ.' ') THEN
          CALL IPOLATES(IP,IPOPT,KGDS,KGDSO,MI,MXSIZE,KM,IBI,KBMS,FLDI,
     *                IGPTS,RLAT,RLON,IBO,KBMSO,FLDO,IRET)
        ELSE
          CALL IPOLATEV(IP,IPOPT,KGDS,KGDSO,MI,MXSIZE,KM,IBI,KBMS,
     *                FLDI,FLDV,IGPTS,RLAT,RLON,CROT,SROT,
     *                IBO,KBMSO,FLDO,FLDVO,IRET)
        ENDIF

        IF (IRET.NE.0) THEN
          PRINT *,' INTERPOLATION TO GRID ',MAPNUM(I),' FAILED.'
          CYCLE
        ENDIF

        IF (WFLAG.EQ.'V') THEN
          FLDO=FLDVO
        ENDIF
C
C       CALL W3FI69 TO UNPACK PDS INTO 25 WORD INTEGER ARRAY
C
        CALL W3FI69(PDSL,IDAWIP)
C
C       CHANGE MODEL NUMBER AND GRID TYPE
C
        IDAWIP(5) = MAPNUM(I)
        IF (WFLAG.EQ.'U') IDAWIP(8) = 33
        IF (WFLAG.EQ.'V') IDAWIP(8) = 34
C
C  ZERO PRECIP GRIDPOINTS WHERE MASK WAS APPLIED BEFORE INTERPOLATION
C
      IF (IDAWIP(8).EQ.61.OR.IDAWIP(8).EQ.62.OR.
     &    IDAWIP(8).EQ.63) THEN
        IF (IBO.EQ.1) THEN
          DO J=1,IGPTS
            IF ( .NOT.KBMSO(J) ) THEN
              KBMSO(J)=.TRUE.
              FLDO(J)=0.0
            ENDIF
          ENDDO
        END IF
      END IF
C
C       TEST RELATIVE HUMIDITY FOR GT THAN 100.0 AND LT 0.0
C       IF SO, RESET TO 0.0 AND 100.0
C
        IF (IDAWIP(8).EQ.52) THEN
          DO J = 1,IGPTS
            IF (FLDO(J).GT.100.0) FLDO(J) = 100.0
            IF (FLDO(J).LT.0.0)   FLDO(J) =   0.0
          END DO
        END IF
C
C       SET ALL NEGATIVE ACUM PCP VALUES TO 0
C
        IF (IDAWIP(8).EQ.61.OR.IDAWIP(8).EQ.62.OR.
     &      IDAWIP(8).EQ.63) THEN
          DO J = 1,IGPTS
            IF (FLDO(J).LT.0.0) FLDO(J) = 0.0
          END DO
        END IF
C
C  COPY OUTPUT BITMAP FROM LOGICAL TO INTEGER ARRAY FOR W3FI72
C
        IF (IBO.EQ.1) THEN
          DO J=1,IGPTS
            IF (KBMSO(J)) THEN
              IBMAP(J)=1
            ELSE
              IBMAP(J)=0
            ENDIF
          ENDDO
        ELSE
          IBMAP=1
        ENDIF
C
C       IF D VALUE EQUAL ZERO, USE D VALUE IN 1 DEGREE INPUT RECORDS,
C       ELSE USE THE D VALUE
C
        IF (D(I).NE.0) THEN
          IDAWIP(25) = D(I)
        END IF
C
C       PRINT *,'W3FT69 = ',IDAWIP
C       PRINT *,'CHECK POINT AFTER W3FI69'
C
        IBITL  = NBITS(I)
        ITYPE  = 0
        IGRID  = MAPNUM(I)
        IPFLAG = 0
        IGFLAG = 0
        IBFLAG = 0
        ICOMP  = 0
        IBLEN  = IGPTS
        JERR   = 0
C
C     GRIB AWIPS GRID 37-44
C
C         PRINT *,'CHECK POINT BEFORE W3FI72'
          CALL W3FI72(ITYPE,FLDO,IFLD,IBITL,
     &                IPFLAG,IDAWIP,PDSAWIP,
     &                IGFLAG,IGRID,KGDSO,ICOMP,
     &                IBFLAG,IBMAP,IBLEN,
     &                IBDSFL,
     &                NPTS,KBUF,ITOT,JERR)
C         PRINT *,'CHECK POINT AFTER W3FI72'
          IF (JERR.NE.0) PRINT *,' W3FI72 ERROR = ',JERR
          PRINT *,'NPTS, ITOT = ',NPTS,ITOT
          PRINT 2, (MOVA2I(PDSAWIP(J)),J=1,28)
C
C       PRINT *,'SIZE OF GRIB FIELD = ',ITOT
C
C       MAKE FLAG FIELD SEPARATOR BLOCK
C
        CALL MKFLDSEP(CSEP,IOPT,INSIZE,ITOT+LENHEAD,LENOUT)
C
C       MAKE WMO HEADER
C
        CALL MAKWMO (BULHED(I),KPDS(10),KPDS(11),KWBX,WMOHDR)
C
C       WRITE OUT SEPARATOR BLOCK, ABBREVIATED WMO HEADING,
C
        CALL WRYTE(LUGO,LENOUT,CSEP)
        CALL WRYTE(LUGO,LENHEAD,WMOHDR)
        CALL WRYTE(LUGO,ITOT,KBUF)
        NBUL    = NBUL + 1
  690 CONTINUE
C
  699 CONTINUE
C--------------------------------------------------------------
C
C     CLOSING SECTION
C
  800 CONTINUE
      IF (NBUL .EQ. 0 .AND. NUMFLD .EQ. 0) THEN
        WRITE (6,FMT='('' SOMETHING WRONG WITH DATA CARDS...'',
     &         ''NOTHING WAS PROCESSED'')')
        CALL W3TAGE('MKGFSAWPS')
        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
C
C         TEST TO SEE IF ANY BULLETINS MISSING
C
        MBUL = 0
        MBUL = NGBSUM - NBUL
        IF (MBUL.NE.0) THEN
          PRINT *,'BULLETINS MISSING = ',MBUL
          CALL W3TAGE('MKGFSAWPS')
          STOP 30
        END IF
C
        CALL W3TAGE('MKGFSAWPS')
        STOP
      ENDIF
C
C     ERROR MESSAGES
C
  710 CONTINUE
      WRITE (6,FMT='(''  ?*?*? CHECK DATA CARDS... READ IN '',
     & ''GRIB PDS AND WAS EXPECTING GRIB MAP CARDS TO FOLLOW.'',/,
     & ''           MAKE SURE NGBFLG = ZZ OR SUPPLY '',
     & ''SOME GRIB MAP DEFINITIONS!'')')
      CALL W3TAGE('MKGFSAWPS')                                           
      STOP 18
C
      END