text:
C$$$  MAIN PROGRAM DOCUMENTATION BLOCK
C
C MAIN PROGRAM: PREPOBS_ACARSQC
C   PRGMMR: KEYSER           ORG: NP22        DATE: 2011-03-30
C
C ABSTRACT: READS IN PREPBUFR FILE CONTAINING ALL PREPROCESSED DATA
C   TYPES. {ONLY BUFR TABLE A ENTRY MESSAGES "AIRCAR  " ARE OPERATED
C   ON.}  PERFORMS CERTAIN RUDIMENTARY QUALITY CHECKS ON THE DATA
C   (E.G., GROSS CHECKS AND SANITY CHECK).  SORTS BY STATION ID, DOES
C   TRACK CHECKING (NOT YET), AND AGGRAGATES OBS BY POSITION (CALLED
C   A 'STACK').  DOES QUALITY CONTROL BY MAKING TRACK CHECKS ON
C   FLIGHTS (NOT YET), REMOVING DUPLICATES (NOT YET) AND COMPARING
C   COLOCATED OBSERVATIONS, (NOT YET).  A SERIES OF NEW PREPBUFR
C   QUALITY MARKS ARE ATTACHED TO EACH OBSERVATION (SEE REMARKS).
C   FINALLY: WRITES STACKED EVENTS (CONSISTING OF THE UPDATED PREPBUFR
C   QUALITY MARKS) ONTO THE EXISTING PREPBUFR DATA.  IN ALL CASES, THE
C   NEW FILE CONTAINS ALL OF THE ORIGINAL OBSERVATIONAL DATA (P-ALT,
C   TEMP, SPECIFIC HUMIDITY, WIND) MINUS THE DUPLICATES (IF ANY) AND
C   THOSE OUTSIDE THE DESIRED TIME WINDOW.  FUTURE Q.C. MAY INVOLVE
C   CHECKS OVER CONUS VS. OUTSIDE CONUS.
C
C PROGRAM HISTORY LOG:
C 2002-05-07  D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM EXISITNG
C             PROGRAM "PREPOBS_PREPACQC")
C 2008-09-25  D. A. KEYSER -- IN RESPONSE TO CHANGE FROM SINGLE LEVEL
C             TO DELAYED REPLICATION FOR "AIRCAR" REPORT LEVEL DATA NOW
C             IN PREPBUFR FILE (IN PREPARATION FOR NRL AIRCRAFT QC
C             PROGRAM WHICH WILL REPLACE THIS PROGRAM AND CAN GENERATE
C             AIRCRAFT "PROFILES"), RECEIPT TIME (RCT) (WHICH IS NOW
C             PART OF LEVEL DATA) IS NO LONGER RETRIEVED IN SAME CALL
C             TO UFBINT AS REMAINING SINGLE-LEVEL HEADER DATA (TO AVOID
C             BUFRLIB ERROR) (ALL LEVEL DATA HERE STILL HAS JUST ONE
C             REPLICATION AT THIS POINT)
C 2009-08-03  D. A. KEYSER -- WILL NO LONGER TRY TO PULL OUT RECEIPT
C             TIME (RCT) FROM PRE-DECEMBER 2008 VERSIONS OF PREPBUFR
C             FILE WHICH DO YET INCLUDE IT IN ACARS REPORT HEADER (DONE
C             SO THAT CFSRR RUNS WILL NOT FAIL)
C 2011-03-30  D. A. KEYSER -- INCREASED THE SIZE OF PARAMETERS "IRMX"
C             FROM 60000 TO 90000, "ISMX" FROM 2000 TO 4000, "ISUP"
C             FROM 1000 TO 2000, AND "ITMX" FROM 2000 TO 4000 - ALL TO
C             ACCOUNT FOR INCREASED NUMBER OF REPORTS NOW BEING DECODED
C             DUE TO THE NEW INCLUSION OF ALASKAN ACARS REPORTS; IF
C             "IRMX" IS EXCEEDED, CODE NO LONGER FAILS BUT RATHER
C             PROCESSES FIRST "IRMX" REPORTS AND POSTS A WARNING
C             MESSAGE TO THE PRODUCTION JOBLOG FILE
C 2012-12-07  M. SIENKIEWICZ -- INCREASED "IRMX" TO 120000 TO HANDLE
C             INCREASE IN ACARS REPORTS IN NOV 2012
C 2015-11-10  M. SIENKIEWICZ -- INCREASED "IRMX" TO 200000 TO HANDLE
C             INCREASE IN ACARS REPORTS SINCE 2012
C 2019-12-10  M. SIENKIEWICZ -- INCREASED "IRMX" TO 250000 TO HANDLE
C             INCREASE IN ACARS REPORTS SINCE 2015
C
C   INPUT FILES:
C     UNIT 05  - NAMELIST INPUT
C     UNIT 14  - PREPBUFR FILE CONTAINING ALL DATA
C     UNIT 15  - SEQUENTIAL FILE HOLDING FIXED FIELDS: N.H. 1 DEG.
C                LAT/LON GRID LAND/SEA INDICATOR; S.H. 2.5 DEG.
C                LAT/LON GRID LAND/SEA INDICATOR; N.H. CONUS 1 DEG
C                LAT/LON YES/NO INDICATOR (NOT YET USED IN ANY
C                CHECKS, BUT PROVIDED FOR FUTURE NEEDS)
C
C   OUTPUT FILES:
C     UNIT 06  - PRINTOUT
C     UNIT 52  - TEXT FILE FOR SDM PERUSAL (LIST OF REPORTS
C              - THAT ARE FLAGGED FOR NON-USE BY THIS PROGRAM AS WELL
C              - AS THOSE WITH LARGE INCREMENTS)
C     UNIT 61  - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACARS QC)
C
C   SUBPROGRAMS CALLED:
C     UNIQUE:    - RPACKR   INDEXF   INDEXC   TRKCHK ACCOUNT
C                - IDSORT   FORSDM   DBUFR    IBUFR  OBUFR
C                - CMDDFF
C     LIBRARY:
C       SYSTEM   - SYSTEM
C       W3LIB :  - W3FI04   ERREXIT
C       BURLIB:  - DATELEN  OPENBF   READMG   READSB   UFBINT
C                - CLOSBF   OPENMB   UFBCPY   WRITSB   UFBCNT
C                - COPYMG   UFBQCD   CLOSMG   STATUS   NEMTAB
C
C   EXIT STATES:
C     COND =   0 - SUCCESSFUL RUN
C     COND =  04 - NO REPORTS WERE PROCESSED (NO "AIRCAR" TABLE A
C                  MESSAGES FOUND)
C     COND =  22 - CHARACTERS ON THIS MACHINE ARE NEITHER ASCII NOR
C                - EBCDIC
C     COND =  70 - THE NUMBER OF LEVELS IN A DECODED REPORT'S HEADER
C                - AND/OR OBS. AND/OR FCST LVL IS NOT 1
C
C REMARKS: SEE COMMENT CARDS FOLLOWING DOCBLOCK.
C     THE FOLLOWING DESCRIBE THE COMMON BLOCKS IN THIS PROGRAM:
C       /ALLDAT/ -- CONTAINS ARRAYS FOR ALL ACARS OBSERVATIONS
C       /SUMDAT/ -- CONTAINS ARRAYS FOR ONLY GROUP OF STACKED OBS.
C
C     THE POSSIBLE OUTPUT QUALITY MARKERS ARE DEFINED AS FOLLOWS:
C       (WHERE: 'T' IS TEMPERATURE, 'Q' IS SPECIFIC HUMIDITY AND
C        'W' IS WIND)
C
C                                                      PREPBUFR
C    ORIGINAL SDM KEEP FLAG MAINTAINED (T/Q/W).........      0
C    CHECKED BY THIS PROGRAM AND GOOD (T/Q/W)..........      1
C    ORIGINAL DATA NOT CHECKED BY THIS PROGRAM (T/Q/W).      2
C    ORIGINAL DATA MISSING (T/Q/W).....................     15
C    CHECKED BY THIS PROGRAM AND SUSPECT (T/Q/W).......      3
C    CHECKED BY THIS PROGRAM AND BAD/FAILED (T/Q/W)....     13
C    ORIGINAL SDM PURGE FLAG MAINTAINED (T/Q/W)........     14
C
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$
CC
C   ***** VARIABLES IN NAMELIST INPUT READ IN MAIN PROGRAM *****
CC
C    WINDOW - TIME WINDOW FOR REPORTS TO BE OUTPUT BY THIS PROGRAM (IF
C             WINDOW=X, TIME WINDOW IS +/- X HOURS OF CYCLE TIME)
C                                    (DEFAULT=3.00, 6-HOUR TOTAL WINDOW)
C         {NOTE: THE MAXIMUM VALUE FOR WINDOW IS 5.75 (5-HOURS,
C                45-MINUTES; ANYTHING LARGER WILL RESULT IN ERROR!}
C         (NOTE: FOR INPUT, THE TIME WINDOW IS SET TO THE LARGER OF
C                3-HOURS 15-MINUTES OR "WINDOW" PLUS 15-MINUTES.
C                THIS ALLOWS THE TRACK CHECKING TO BE DONE PROPERLY.
C                ON OUTPUT, THE VALUE OF "WINDOW" IS USED - ALL
C                REPORTS OUTSIDE WINDOW ARE OMITTED FROM OUTPUT)
C    RCPTST - SWITCH TO PERFORM THE RECEIPT-TIME TEST
C              RCPTST=.TRUE. ---> PERFORM THE TEST             (DEFAULT)
C              RCPTST=.FALSE. --> DO NOT PERFORM THE TEST
C         (NOTE: THE RECEIPT TIME TEST CHECKS FOR REPORTS WITH A
C                STRANGE RECEIPT TIME COMPARED TO THE REPORT TIME -
C                MAY BE YESTERDAY'S REPORT PROCESSED TODAY --
C                IF THE RECEIPT TIME IS OUTSIDE THE RANGE OF REPORT
C                TIME MINUS 1-HOUR TO REPORT TIME PLUS 11.99 HOURS, THE
C                REPORT IS SKIPPED SINCE ITS VALIDITY IS IN QUESTION)
CC
C  N O T E -- THE FOLLOWING 6-WORD ARRAYS REFER TO SIX LATITUDE
C              BANDS: -90 TO -70, -70 TO -20, -20 TO 0, 0 TO 20,
C                      20 TO  70,  70 TO  90 DEGREES (N +)
CC
C    JAMASS - PROCESS ACARS MASS REPORTS ON OUTPUT?
C              JAMASS = 0    ---> YES, PROCESS MASS REPORTS
C              JAMASS = 9999 ---> NO, DO NOT PROCESS MASS REPORTS
C                                             (DEFAULT = JAMASS(6)/6*0/)
C    JAWIND - PROCESS ACARS WIND REPORTS ON OUTPUT?
C              JAWIND = 0    ---> YES, PROCESS WIND REPORTS
C              JAWIND = 9999 ---> NO, DO NOT PROCESS WIND REPORTS
C                                             (DEFAULT = JAWIND(6)/6*0/)
CC
C    FWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF FINAL LISTING
C             OF ORIGINAL REPORTS IN AIRCAR FILE WITH NEW Q. MARKS
C              FWRITE=.TRUE. ---> PRODUCE PRINTOUT
C              FWRITE=.FALSE. --> NO PRINTOUT                  (DEFAULT)
C    IWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF INPUT LISTING
C             OF ORIGINAL REPORTS IN AIRCAR FILE BEFORE IDSORT, AFTER
C             IDSORT, AND AFTER TRACK CHECK
C              IWRITE=.TRUE. ---> PRODUCE PRINTOUT
C              IWRITE=.FALSE. --> NO PRINTOUT                  (DEFAULT)
C    EWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF "EVENTS"
C             (WHEN A BUFR EVENT OCCURS, I.E. CHANGING A QUALITY MARK)
C             {NOTE: DOES NOT APPLY TO EVENT # 7 (SEE EWRITE_7)}
C              EWRITE=.TRUE. ---> PRODUCE PRINTOUT
C              EWRITE=.FALSE. --> NO PRINTOUT                  (DEFAULT)
C    EWRITE_7 - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF EVENT # 7
C             (REPORT WITH A TEMP, SPEC. HUMIDITY AND/OR WIND THAT
C              HAS PASSED ALL CHECKS AND IS CONSIDERED TO BE GOOD)
C             {NOTE: DOES NOT APPLY TO OTHER EVENT NUMBERS
C                    (SEE EWRITE)}
C              EWRITE_7=.TRUE. ---> PRODUCE PRINTOUT
C              EWRITE_7=.FALSE. --> NO PRINTOUT                (DEFAULT)
CCCCC
      PROGRAM PREPOBS_ACARSQC
C
C PARAMETER NAME "IRMX" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM
C  NUMBER OF ACARS RPTS THAN CAN BE UNPACKED FROM THE INPUT FILE CHOSEN
C PARAMETER NAME "ISMX" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM
C  NUMBER OF ACARS RPTS THAT CAN BE TREATED IN A STACK
      PARAMETER (IRMX= 250000, ISMX= 4000)
C PARAMETER NAME "ISUP" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM
C  NUMBER OF SUPEROBED REPORTS THAT CAN BE PROCESSED
      PARAMETER (ISUP= 2000)
C PARAMETER NAME "ISIZE" THROUGHOUT THIS PROGRAM SETS THE NUMBER OF
C  VARIABLES THAT ARE AFFECTED BY THE SORTS ID IDSORT AND TRKCHK
C  (EXCLUDING STATION ID AND THE TAGS WHICH ARE IN SEPARATE ARRAYS)
      PARAMETER (ISIZE= 18)

      LOGICAL  FWRITE,IWRITE,EWRITE,EWRITE_7,RCPTST

      CHARACTER*1  CF,INACMK(11),PF,CINCR
      CHARACTER*4  SPEC5,SPEC6,SSMARK
      CHARACTER*6  CIRMX
      CHARACTER*8  ACID,SAID,IDENT,AAID(IRMX)
      CHARACTER*16  TAG,CTAG(IRMX),STAG(IRMX)

      INTEGER  IDATA(1608),NNIN(11),IDSTR(400,2)

      REAL  RDATA(1608)

      COMMON/OUTPUT/KNTOUT(2)
      COMMON/SUMDAT/SAID(ISMX),SLAT(ISMX),SLON(ISMX),SHGT(ISMX),
     $ STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX),SSPH(ISMX),
     $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX)
      COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX),
     $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX),
     $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX),
     $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX),
     $ IQEVNT(IRMX)
      COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX)
      COMMON/ACCONT/KISO(11)
      COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST
      COMMON/STWRIT/EWRITE,EWRITE_7,IWRITE
      COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91)
      COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG
      COMMON/CBUFR/IDENT,IRCTME,RDATA,KIX,CINCR,CF,PF
      COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP),
     $ SSTMP(ISUP),SSSPH(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP),
     $ SSTMPF(ISUP),SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP)
      COMMON/STDATE/IDATE(5)
      COMMON/WORD/ICHTP
      COMMON/QUALITY/ITQM,IQQM,IWQM
      COMMON/NEWTABLE/IPRSLEVLA

      NAMELIST/INPUT/WINDOW,FWRITE,IWRITE,EWRITE,EWRITE_7,JAMASS,JAWIND,
     $               RCPTST

      EQUIVALENCE  (RDATA,IDATA)

      DATA  XMSG/99999./,INACMK/'Q','R','S','T','U','V','W','X','Y','Z',
     $ 'N'/

      CALL W3TAGB('PREPOBS_ACARSQC',2011,0089,0087,'NP22')

      PRINT 2111
 2111 FORMAT(//11X,'*****  WELCOME TO THE ACARS QUALITY CONTROL ',
     $'PROGRAM ACARSQM -- VERSION CREATED 30 MAR 2011  *****'/)

C CALL W3FI04 TO DETERMINE MACHINE WORD LENGTH (BYTES)
C  AND TO TEST FOR ASCII(ICHTP=0) OR EBCDIC(ICHTP=1) CHARACTERS
      CALL W3FI04(IENDN,ICHTP,LW)
      PRINT 2213, LW, ICHTP, IENDN
 2213 FORMAT(/' ---> CALL TO W3FI04 RETURNS: LW = ',I3,', ICHTP = ',I3,
     $ ', IENDN = ',I3/)
      IF(ICHTP.GT.1)  THEN
C-----------------------------------------------------------------------
C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22
         PRINT 217
  217    FORMAT(/5X,'++ CHARACTERS ON THIS MACHINE ARE NEITHER ASCII',
     $    ' NOR EBCDIC - STOP 22'/)
         CALL W3TAGE('PREPOBS_ACARSQC')
         CALL ERREXIT(22)
C-----------------------------------------------------------------------
      END IF

C INITIALIZE CONSTANTS FOR ACCOUNTING
      KDUP   = 0
      ICNT1  = 0
      KISO   = 0
      NNIN   = 0

C READ IN NAMELIST, FIRST SET-UP ANY DEFAULTS
      WINDOW   = 3.00
      RCPTST   = .TRUE.
      FWRITE   = .FALSE.
      IWRITE   = .FALSE.
      EWRITE   = .FALSE.
      EWRITE_7 = .FALSE.
      JAMASS   = 0
      JAWIND   = 0
      READ(5,INPUT,END=9222)

 9222 CONTINUE

C GET DATE OF PREPBUFR FILE
      CALL DBUFR(IDATEP)
      IDATE(1) = IDATEP/1000000
      IDATE(2) = MOD((IDATEP/10000),100)
      IDATE(3) = MOD((IDATEP/100),100)
      IDATE(4) = MOD(IDATEP,100)
      IDATE(5) = 0
      KOUNT    = 0
      KNTIN    = 0
      KNTOUT   = 0
      TBASE = REAL(IDATE(4) * 100.)
      IF(NINT(TBASE).LT.600)  TBASE = TBASE + 2400.
C THE TIME WINDOW UPON INPUT IS SET TO THE LARGER OF 3-HRS 15-MIN OR
C  "WINDOW" PLUS 15-MINUTES.  REMOVE ALL REPORTS OUTSIDE THIS TIME
C  WINDOW.  (THE LARGER INPUT TIME WINDOW ALLOWS THE TRACK CHECKING TO
C  BE DONE PROPERLY (FUTURE).)
      TWNDOW = AMAX1(((WINDOW*100.)+25.0),325.)
      TMAX = TBASE + TWNDOW
      TMIN = TBASE - TWNDOW
      TMAXO = TBASE + (WINDOW * 100.)
      TMINO = TBASE - (WINDOW * 100.)
      PRINT 1111, IDATE,TBASE,TMIN,TMAX,TMINO,TMAXO
 1111 FORMAT(39X,'===> OPERATIONAL AIRCAR FILE HAS DATE: ',I6,4I4/
     $ 41X,'===> TIME BASE IS ',F8.0/
     $ 41X,'===> INPUT  TIME WINDOW IS ',F8.0,' TO ',F8.0/
     $ 41X,'===> OUTPUT TIME WINDOW IS ',F8.0,' TO ',F8.0//)
      WRITE(6,INPUT)

C READ IN N.H. CONUS MASK (1 DEG GRID); IF MASK > 0 THEN GRID LOCATED
C  HERE -- THIS IS NEEDED LATER IN PROGRAM (FUTURE)
      PRINT 101
  101 FORMAT(/1X,'**** OPEN UNIT 15 TO GET CONUS GRID FOR POSSIBLE ',
     $ 'LOCATION CHECKS ****'/)
      READ(15,ERR=8814)  GDNH
      READ(15,ERR=8814)  GDSH
      READ(15,ERR=8814)  GDUS
      GO TO 8812
C-----------------------------------------------------------------------
 8814 CONTINUE
C PROBLEM W/ READ; INIT. GDUS ARRAY TO 0 - (HAVE TO ASSUME ALL N.H. OBS.
C  ARE OUTSIDE OF CONUS REGION)
      GDUS = 0.0
      PRINT 102
  102 FORMAT(/'  +++> TROUBLE READING U.S. MASK FILE; ASSUME ALL N.H. ',
     $ 'DATA OUTSIDE CONUS REGION IN ANY CONUS TEST'/)
C-----------------------------------------------------------------------

 8812 CONTINUE
       IF(IWRITE)  PRINT 6176
 6176 FORMAT(/' LISTING OF ORIGINAL DATA BEFORE IDSORT----'/9X,'ACID',
     $ 7X,'LAT   WLON   UTC  ALT   TEMP  SHUM DIR  SPD  -QM  ----TAGS',
     $ '-----  ITP RPTIME KNTINI  GALT GTEMP GDIR GSPD'/)

    5 CONTINUE

      ALTF = XMSG
      DIRF = XMSG
      SPDF = XMSG
      TMPF = XMSG
C***********************************************************************
C                       READ IN NEXT ACARS REPORT
C***********************************************************************
      IY = 43
      SPEC5 = '----'
      SPEC6 = '----'
      CALL IBUFR(ALTF,DIRF,SPDF,TMPF,*2)
      SPEC5(3:3) = PF
      SPEC6(3:3) = CF
      IF(KOUNT+1.GT.IRMX)  THEN
C.......................................................................
C THERE ARE MORE RPTS IN INPUT FILE THAN "IRMX" -- DO NOT PROCESS ANY
C  MORE REPORTS
         PRINT 53, IRMX,IRMX
   53 FORMAT(/' #####> WARNING: THERE ARE MORE THAN ',I7,' ACARS ',
     $ 'REPORTS IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER NAME',
     $ ' "IRMX" - WILL, CONTINUE ON PROCESSING ONLY ',I7,' REPORTS'/)
         WRITE(CIRMX,'(I6)') IRMX
!        CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg'//
!    $    ' "$jlogfile" "***WARNING:'//CIRMX//' ACARS REPORT LIMIT '//
!    $    'EXCEEDED IN PREPOBS_ACARSQC, ONLY '//CIRMX//' RPTS '//
!    $    'PROCESSED"')
         CALL CLOSBF(14)
         PRINT 301
  301 FORMAT(/5X,'===> PREPBUFR DATA SET IN UNIT 14 SUCCESSFULLY',
     $ ' CLOSED FROM INITIAL READ OF ACARS OBS.')
         go to 2
ccccc    CALL W3TAGE('PREPOBS_ACARSQC')
ccccc    CALL ERREXIT(20)
C.......................................................................
      END IF
      KOUNT = KOUNT + 1
      KNTIN = KNTIN + 1
      KNTINI(KOUNT) = KNTIN
      TAG(KOUNT)(12:12) = '-'
      ALAT(KOUNT) = RDATA(1)
      ALON(KOUNT) = RDATA(2)
      INTP(KOUNT) = IDATA(8)

      IF(NINT(ALON(KOUNT)*100.).EQ.36000)  ALON(KOUNT) = 0.0
C IF MISSING OR UNREASONABLE LAT/LON (SET LATTER TO MISSING), SET POS.
C  12 OF TAG TO '@' TO MARK THEM (AT END OF SORT)
      IF(NINT(ALAT(KOUNT)*100.).GT.9000.OR.NINT(ALAT(KOUNT)*100.).LT.
     $ -9000)  THEN
CVVVVV%%%%%
      PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE LAT - SET TO MSG!!'
CAAAAA%%%%%
         ALAT(KOUNT) = XMSG
         TAG(KOUNT)(12:12) = '@'
      END IF
      IF(NINT(ALON(KOUNT)*100.).GT.36000.OR.NINT(ALON(KOUNT)*100.).LT.
     $ 0)  THEN
CVVVVV%%%%%
      PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE LON - SET TO MSG!!'
CAAAAA%%%%%
         ALON(KOUNT) = XMSG
         TAG(KOUNT)(12:12) = '@'
      END IF

      ACID(KOUNT) = IDENT
      TIME(KOUNT) = RDATA(4)
CVVVVV%%%%%
      IF(NINT(TIME(KOUNT)).GT.2400.OR.NINT(TIME(KOUNT)).LT.0)
     $ PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE TIME, TOSSED?'
CAAAAA%%%%%
      IRTM(KOUNT) = IRCTME

C DO A TIME CHECK ON REPORT -- IF OUTSIDE EXPANDED INPUT WINDOW TOSS IT
      ITIME = NINT(TIME(KOUNT))
      IF(NINT(TBASE).GT.2300.AND.NINT(TIME(KOUNT)).LE.
     $ (IDATE(4)*100)+600)  TIME(KOUNT) = TIME(KOUNT) + 2400.
      IF(TIME(KOUNT).LT.TMIN.OR.TIME(KOUNT).GT.TMAX)  THEN
C SKIP REPORTS OUTSIDE REQUESTED TIME WINDOW
CCCCCC  PRINT 9002,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),TIME(KOUNT)
C9002 FORMAT(/' ##########: MAIN; REPORTS OUTSIDE TIME WINDOW SKIPPED.',
CCCCC$ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F4.0)
         KOUNT = KOUNT - 1
         GO TO 5
      END IF

      IF(RCPTST.AND.IRCTME.LE.2400)  THEN
C CHECK FOR DATA WITH STRANGE RECEIPT TIME COMPARED TO REPORT TIME -
C  MAY BE YESTERDAY'S REPORT PROCESSED TODAY -- IF THE RECEIPT TIME
C  IS OUTSIDE THE RANGE OF REPORT TIME MINUS 1-HOUR TO REPORT TIME
C  PLUS 11.99 HOURS, SKIP THE REPORT AS WE CAN'T DETERMINE ITS VALIDITY
         IF(ITIME.LT.100)  ITIME = ITIME + 2400
         IETIME = ITIME -  100
         ILTIME = ITIME + 1199
         IF(IRCTME.LT.IETIME.OR.IRCTME.GT.ILTIME)  THEN
C RECEIPT TIME IS OUTSIDE EXPECTED RANGE, BUT MAY BE AROUND 00Z SO ADD
C  2400 TO RECEIPT TIME AND TEST AGAIN
            IRCTMN = IRCTME + 2400
            IF(IRCTMN.LT.IETIME.OR.IRCTMN.GT.ILTIME)  THEN
C RECEIPT TIME IS STILL OUTSIDE EXPECTED RANGE, SKIP REPORT
CVVVVV%%%%%
           PRINT *,'~~~~~ THE STRANGE RECEIPT TIME DIFF. HAS OCCURRED!!'
CAAAAA%%%%%
               PRINT 9393, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $          TIME(KOUNT),IRCTME,SPEC6(3:3)
 9393 FORMAT(/' ##########: SKIP RPTS WHERE OBS. & RCPT. TIME ARE INCON'
     $,'SISTENT  ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F4.0,'; REC. TIME ',I4,
     $ '; CAFB? ',A1)
               KOUNT = KOUNT - 1
               GO TO 5
            END IF
         END IF
      END IF

      AALT(KOUNT) = RDATA(IY)
      ADIR(KOUNT) = RDATA(IY+3)
      ASPD(KOUNT) = RDATA(IY+4)
      ATMP(KOUNT) = RDATA(IY+1)
      ASPH(KOUNT) = RDATA(IY+2)
C FILL IN FORECAST VALUES FOR ALTITUDE, WIND DIR., WIND SPEED & TEMP.
      AALTF(KOUNT) = ALTF
      ADIRF(KOUNT) = DIRF
      ASPDF(KOUNT) = SPDF
      ATMPF(KOUNT) = TMPF
      ITEVNT(KOUNT) = 0
      IQEVNT(KOUNT) = 0
      IWEVNT(KOUNT) = 0
C***********************************************************************
C***********************************************************************
C  INPUT AIRCAR TABLE A ENTRY MESSAGE QUALITY MARKER SITUATION -
C   (P-ALTITUDE, TEMPERATURE. SPECIFIC HUMIDITY AND WIND)
C
C     WILL CONTAIN VALUE OF 14 IF SDM HAS PURGED
C     ELSE WILL CONTAIN VALUE OF 0 IF SDM KEEPS
C     ELSE WILL CONTAIN DEFAULT VALUE OF 2
C     ELSE WILL CONTAIN A VALUE OF 15 IF DATA ARE MISSING
C
C  OTHER INPUT REPORT INFORMATION AS INDICATED:
C
C    +++ CONTAINS PROPER ACARS FLIGHT NUMBER (UP TO EIGHT CHARACTERS)
C    +++ CONTAINS SCALED VECTOR WIND INCREMENT (USES ASSIMILATING
C        FORECAST DIRECTLY, ASSUMING FCST U AND V ARE IN BUFR DATA)
C    +++ CONTAINS RECEIPT TIME (HOURS)
C    +++ CONTAINS INSTRUMENT TYPE
C
C
C  OUTPUT QUALITY MARKER SITUATION - SEE DOCBLOCK REMARKS
C   (P-ALTITUDE, TEMPERATURE. SPECIFIC HUMIDITY AND WIND)
C
C
C  EVENTS WRITTEN BY THIS PROGRAM INTO OUTPUT PREPBUFR FILE:
C    NOTE: AN EVENT CAN ONLY CHANGE A VARIABLE'S QUALITY MARKER,
C          THE OBSERVED VARIABLE ITSELF IS NEVER CHANGED.
C          IF THE OBSERVED VARIABLE IS MISSING, THE EVENT IS
C          NOT ACTIVE.
C                                                              VARIABLE
C EVENT SUBR.    MEANING                                      QUAL. MARK
C ----- ------   -------------------------------------------- ----------
C    1  MAIN     REPORT WITH AN ALTITUDE > 16,500 METERS       TEMP = 13
C                (~95 MB).  PROBABLY A MISCODED REPORT.        SHUM = 13
C                TEMPERATURE, SPECIFIC HUMIDITY AND/OR         WIND = 13
C                WIND CONSIDERED BAD IF PRESENT.
C
C    2  MAIN     REPORT WITH A LATITUDE OF 0 DEGREES.  COULD   TEMP = 13
C                BE A MISCODED REPORT.  TEMPERATURE,           WIND = 13
C                SPECIFIC HUMIDITY AND/OR WIND CONSIDERED      SHUM = 13
C                BAD IF PRESENT.
C
C    3  MAIN     REPORT WITH A LONGITUDE OF 0 DEGREES.         TEMP = 13
C                COULD BE A MISCODED REPORT.  TEMPERATURE,     WIND = 13
C                SPECIFIC HUMIDITY AND/OR WIND CONSIDERED      SHUM = 13
C                BAD IF PRESENT.
C
C    4  MAIN     REPORT WITH CALM WIND.  WIND CONSIDERED BAD   WIND = 13
C                IF PRESENT.
C
C    5  MAIN     REPORT WITH ALTITUDE BETWEEN 2000 & 5000 FT.  TEMP = 13
C                WITH TEMPERATURE THAT DIFFERS FROM GUESS      SHUM = 13
C                BY > 25 DEG. C {PROBABLY DUE TO "0" DIGIT     WIND = 13
C                DROPPED FROM REPORTED ALTITUDE (TRUE
C                ALTITUDE BETWEEN 20,000 & 50,000 FT.)}
C                TEMPERATURE, SPECIFIC HUMIDITY AND/OR WIND
C                CONSIDERED BAD IF PRESENT.
C
C    6  RPACKR   REPORT WITH A MISSING PHASE OF FLIGHT         TEMP =  3
C                INDICATOR (PROBABLY BANKING).  TEMPERATURE,   SHUM =  3
C                SPECIFIC HUMIDITY AND/OR WIND CONSIDERED      WIND =  3
C                SUSPECT IF PRESENT.
C
C    7  RPACKR   REPORT WITH A TEMPERATURE, SPECIFIC HUMIDITY  TEMP =  1
C                AND/OR WIND THAT HAS PASSED ALL CHECKS.       SHUM =  1
C                TEMPERATURE, SPECIFIC HUMIDITY AND/OR WIND    WIND =  1
C                CONSIDERED GOOD IF PRESENT.
C
C    8  RPACKR   REPORT WITH A TEMPERATURE THAT HAS FAILED     SHUM = 13
C                ONE OR MORE CHECKS AND IS CONSIDERED BAD.
C                SPECIFIC HUMIDITY CONSIDERED BAD.
C
C
C***********************************************************************
C
C  EACH REPORT CARRIES WITH IT IN THIS PROGRAM THE FOLLOWING 'TAG' INFO:
C
C    BYTE  1 : +++ TEMPERATURE QUALITY MARKER
C               "H" - Manual (SDM) Keep
C               "A" - Good
C               "-" - Neutral
C               "Q" - Suspect
C               "F" - Failed
C               "P" - Manual (SDM) Purge
C    BYTE  2 : +++ SPECIFIC HUMIDITY QUALITY MARKER
C               "H" - Manual (SDM) Keep
C               "A" - Good
C               "-" - Neutral
C               "Q" - Suspect
C               "F" - Failed
C               "P" - Manual (SDM) Purge
C    BYTE  3 : +++ WIND QUALITY MARKER
C               "H" - Manual (SDM) Keep
C               "A" - Good
C               "-" - Neutral
C               "Q" - Suspect
C               "F" - Failed
C               "P" - Manual (SDM) Purge
C    BYTE  4 : WILL CONTAIN 'D' IF THIS REPORT IS A DUPLICATE
C            : ELSE WILL BE '-' IF THIS REPORT IS NOT A DUPLICATE
C    BYTE  5 : +++ SCALED VECTOR INCREMENT VALUE : WILL CONTAIN
C               'Q' - 'Z' IF INCREMENT COULD BE PRODUCED
C            : ELSE  WILL CONTAIN 'N' IF NOT CALCULATED
C    BYTE  6 : +++ TEMPERATURE PRECISION
C            : WILL CONTAIN '0' IF LOW PRECISION
C            : WILL CONTAIN '1' IF HIGH PRECISION
C            : ELSE WILL BE '-' IF TEMPERATURE PRECISION NOT
C               REPORTED
C    BYTE  7 : +++ CURRENTLY NOT USED AND SET TO '-'
C    BYTE  8 : +++ TURBULENCE INDICATOR
C            : WILL CONTAIN '0' IF NO TURBULENCE
C            : WILL CONTAIN '1' IF LIGHT TURBULENCE
C            : WILL CONTAIN '2' IF MODERATE TURBULENCE
C            : WILL CONTAIN '3' IF SEVERE TURBULENCE
C            : ELSE WILL BE '-' IF NONE OF ABOVE
C    BYTE  9 : +++ CURRENTLY NOT USED AND SET TO '-'
C    BYTE 10 : +++ PHASE OF FLIGHT INDICATOR
C            : WILL CONTAIN '0' - '2' IF RESERVED
C            : WILL CONTAIN '3' IF LVL FLIGHT, ROUTINE OBSERVATION
C            : WILL CONTAIN '4' IF LVL FLIGHT, HIGHEST WIND ENCOUNTERED
C            : WILL CONTAIN '5' IF ASCENDING
C            : WILL CONTAIN '6' IF DESCENDING
C            : WILL CONTAIN '7' IF MISSING (PROBABLY BANKING)
C    BYTE 11 : +++ CURRENTLY NOT USED AND SET TO '-'
C    BYTE 12 : +++ INDICATOR FOR "BAD" REPORTS EXCLUDED FROM CHECKS
C            : WILL CONTAIN '@' IF A "BAD"/EXCLUDED REPORT
C            : ELSE WILL BE '-'
C    BYTE 13 : +++ NUMERICAL VALUE FOR TEMPERATURE QUALITY MARKER
C            : LOWER NUMBER ALWAYS SUPERCEDES HIGHER NUMBER (SEE && )
C    BYTE 14 : +++ NUMERICAL VALUE FOR WIND QUALITY MARKER
C            : LOWER NUMBER ALWAYS SUPERCEDES HIGHER NUMBER (SEE && )
C    BYTE 15 : +++ NUMERICAL VALUE FOR SPECIFIC HUMIDITY QUALITY MARKER
C            : LOWER NUMBER ALWAYS SUPERCEDES HIGHER NUMBER (SEE && )
C    BYTE 16 : +++ TRACK CHECK INDICATOR
C            : WILL CONTAIN 'E' IF SUSPECTED TRACK CHECK ERROR
C            : ELSE WILL BE '-'
C
C   &&  -  '0' -- DUPLICATE ('D') ('D' IS ONLY STORED IN POS. 1 OF TAG)
C          '1' -- PURGE     ('P')   -- OR --
C                 KEEP      ('H')
C          '2' -- DATA ARE MISSING
C          '3' -- BAD       ('F')
C          '4' -- RESERVED FOR FUTURE USE
C          '5' -- SUSPECT   ('Q')
C          '6' -- GOOD      ('A')
C          '7' -- CANNOT BE CHECKED/UNTREATABLE OR NOT CHECKED (' ' OR
C                   '-')
C          '8' -- INITIAL VALUE
C
C

      TAG(KOUNT)(1:4) = '----'
      TAG(KOUNT)(5:5) = CINCR
      TAG(KOUNT)(6:9) = '----'
      TAG(KOUNT)(10:10) = SPEC5(3:3)
      TAG(KOUNT)(11:11) = '-'
      TAG(KOUNT)(13:15) = '888'
      TAG(KOUNT)(16:16) = '-'

      IF(MAX(ASPD(KOUNT),ADIR(KOUNT)).GE.XMSG) THEN
C IF WIND IS MISSING, QUALITY MARKER IS SET TO 'x'
         TAG(KOUNT)(3:3) = 'x'
         TAG(KOUNT)(15:15) ='2'
      ELSE  IF(IWQM.EQ.14)  THEN
C IF SDM PURGE FLAG ON WIND, WIND Q.M. IS SET TO 'P'
         PRINT 9029, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $    TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9029 FORMAT(/' P-P-P-P-P-:  SDM   PURGE FLAG ON WIND, WIND Q.M. IS ',
     $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
         TAG(KOUNT)(3:3) = 'P'
         TAG(KOUNT)(15:15) = '1'
      ELSE  IF(IWQM.EQ.0)  THEN
C IF SDM KEEP FLAG ON WIND, WIND Q.M. IS SET TO 'H'
         PRINT 8029, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $    TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 8029 FORMAT(/' H-H-H-H-H-:  SDM   KEEP  FLAG ON WIND, WIND Q.M. IS ',
     $ 'SET TO "H"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
         TAG(KOUNT)(3:3) = 'H'
         TAG(KOUNT)(15:15) = '1'
      ELSE IF(IWQM.GT.3.AND.IWQM.LT.16)  THEN
C IF EXISTING BAD Q.M. ON WIND, WIND Q.M. IS SET TO 'F'
         PRINT 9629, IWQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $    TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9629 FORMAT(/' F-F-F-F-F-:  EXISTING BAD QM ON WIND (=',I2,'), WIND ',
     $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,
     $ A13/)
         TAG(KOUNT)(3:3) = 'F'
         TAG(KOUNT)(15:15) = '3'
      END IF

      IF(ATMP(KOUNT).GE.XMSG) THEN
C IF TEMPERATURE IS MISSING, QUALITY MARKER IS SET TO 'x'
         TAG(KOUNT)(1:1) = 'x'
         TAG(KOUNT)(13:13) = '2'
      ELSE  IF(ITQM.EQ.14)  THEN
C IF SDM PURGE FLAG ON TEMPERATURE, TEMPERATURE Q.M. IS SET TO 'P'
         PRINT 9039, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $    TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9039 FORMAT(/' P-P-P-P-P-:  SDM   PURGE FLAG ON TEMP, TEMP Q.M. IS ',
     $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
         TAG(KOUNT)(1:1) = 'P'
         TAG(KOUNT)(13:13) = '1'
         IF(ASPH(KOUNT).LT.XMSG) THEN
C IF SDM PURGE FLAG ON TEMPERATURE, SPECIFIC HUMIDITY Q.M. IS SET TO 'P'
C  (UNLESS SPECIFIC HUMIDITY IS MISSING)
            PRINT 9049, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $       TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9049 FORMAT(/' P-P-P-P-P-:  SDM   PURGE FLAG ON TEMP, SHUM Q.M. IS ',
     $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
            TAG(KOUNT)(2:2) = 'P'
            TAG(KOUNT)(14:14) = '1'
         END IF
      ELSE  IF(ITQM.EQ.0)  THEN
C IF SDM KEEP FLAG ON TEMPERATURE, TEMPERATURE Q.M. IS SET TO 'H'
         PRINT 8039, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $    TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 8039 FORMAT(/' H-H-H-H-H-:  SDM   KEEP  FLAG ON TEMP, TEMP Q.M. IS ',
     $ 'SET TO "H"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
         TAG(KOUNT)(1:1) = 'H'
         TAG(KOUNT)(13:13) = '1'
      ELSE IF(ITQM.GT.3.AND.ITQM.LT.16)  THEN
C IF EXISTING BAD Q.M. ON TEMP, TEMP Q.M. IS SET TO 'F'
         PRINT 9639, ITQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $    TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9639 FORMAT(/' F-F-F-F-F-:  EXISTING BAD QM ON TEMP (=',I2,'), TEMP ',
     $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,
     $ A13/)
         TAG(KOUNT)(1:1) = 'F'
         TAG(KOUNT)(13:13) = '3'
         IF(ASPH(KOUNT).LT.XMSG) THEN
C IF EXISTING BAD Q.M. ON TEMPERATURE, SPECIFIC HUMIDITY Q.M. IS SET TO
C  'P' (UNLESS SPECIFIC HUMIDITY IS MISSING)
            PRINT 9099, ITQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $       TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9099 FORMAT(/' F-F-F-F-F-:  EXISTING BAD QM ON TEMP (=',I2,'), SHUM ',
     $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,
     $ A13/)
            TAG(KOUNT)(2:2) = 'F'
            TAG(KOUNT)(14:14) = '3'
         END IF
      END IF

      IF(TAG(KOUNT)(14:14).GT.'3') THEN
         IF(ASPH(KOUNT).GE.XMSG) THEN
C IF SPECIFIC HUMIDITY IS MISSING, QUALITY MARKER IS SET TO 'x'
            TAG(KOUNT)(2:2) = 'x'
            TAG(KOUNT)(14:14) ='2'
         ELSE  IF(IQQM.EQ.14)  THEN
C IF SDM PURGE FLAG ON SPECIFIC HUMIDITY, SPECIFIC HUMIDITY Q.M. IS SET
C  TO 'P'
            PRINT 9059, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $       TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9059 FORMAT(/' P-P-P-P-P-:  SDM   PURGE FLAG ON SHUM, SHUM Q.M. IS ',
     $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
            TAG(KOUNT)(2:2) = 'P'
            TAG(KOUNT)(14:14) = '1'
         ELSE  IF(IQQM.EQ.0)  THEN
C IF SDM KEEP FLAG ON SPECIFIC HUMIDITY, SPECIFIC HUMIDITY Q.M. IS SET
C  TO 'H'
            PRINT 8059, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $       TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 8059 FORMAT(/' H-H-H-H-H-:  SDM   KEEP  FLAG ON SHUM, SHUM Q.M. IS ',
     $ 'SET TO "H"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13,/)
            TAG(KOUNT)(2:2) = 'H'
            TAG(KOUNT)(14:14) = '1'
         ELSE IF(IQQM.GT.3.AND.IQQM.LT.16)  THEN
C IF EXISTING BAD Q.M. ON SHUM, SHUM Q.M. IS SET TO 'F'
            PRINT 9649, IQQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $       TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9649 FORMAT(/' F-F-F-F-F-:  EXISTING BAD QM ON SHUM (=',I2,'), SHUM ',
     $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,
     $ A13/)
            TAG(KOUNT)(2:2) = 'F'
            TAG(KOUNT)(14:14) = '3'
         END IF
      END IF

C SET POS. 12 OF TAG TO '@' TO MARK PURGE FLAG OR MISSING DATA ON BOTH
C  WIND AND TEMPERATURE (THESE REPORTS WILL BE EXCLUDED FROM MOST
C  FURTHER PROCESSING)
      IF((TAG(KOUNT)(1:1).EQ.'P'.OR.TAG(KOUNT)(1:1).EQ.'x') .AND.
     $   (TAG(KOUNT)(3:3).EQ.'P'.OR.TAG(KOUNT)(3:3).EQ.'x'))
     $ TAG(KOUNT)(12:12) = '@'

      IF(AALT(KOUNT).GT.16500) THEN
         TAG(KOUNT)(12:12) = '@'
CVVVVV%%%%%
ccc      PRINT *,'~~~~~ HERE IS A RPT WITH ALT > 16,500 METERS'
CAAAAA%%%%%
         IF(TAG(KOUNT)(13:13).GT.'3')  THEN
            IF(EWRITE)  PRINT 9108, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $       ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9108 FORMAT(/' #EVENT 1: ALTITUDE IS > 16,500 M (~95 MB), TEMP QM ',
     $ '"F" ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
            TAG(KOUNT)(1:1) = 'F'
            TAG(KOUNT)(13:13) = '3'
            ITEVNT(KOUNT) = 1
         END IF
         IF(TAG(KOUNT)(14:14).GT.'3')  THEN
            IF(EWRITE)  PRINT 7108, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $       ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 7108 FORMAT(/' #EVENT 1: ALTITUDE IS > 16,500 M (~95 MB), SHUM QM ',
     $ '"F" ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
            TAG(KOUNT)(2:2) = 'F'
            TAG(KOUNT)(14:14) = '3'
            IQEVNT(KOUNT) = 1
         END IF
         IF(TAG(KOUNT)(15:15).GT.'3')  THEN
            IF(EWRITE)  PRINT 7908, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $       ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 7908 FORMAT(/' #EVENT 1: ALTITUDE IS > 16,500 M (~95 MB), WIND QM ',
     $ '"F" ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
            TAG(KOUNT)(3:3) = 'F'
            TAG(KOUNT)(15:15) = '3'
            IWEVNT(KOUNT) = 1
         END IF
      END IF

      IF(NINT(ALAT(KOUNT)*100.).EQ.0) THEN
         TAG(KOUNT)(12:12) = '@'
CVVVVV%%%%%
ccc      PRINT *,'~~~~~ HERE IS A RPT WITH LATITUDE OF 0 DEGREES'
CAAAAA%%%%%
         IF(TAG(KOUNT)(13:13).GT.'3')  THEN
            IF(EWRITE)  PRINT 9908, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $       ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9908 FORMAT(/' #EVENT 2: LATITUDE IS 0 DEGREES, TEMP QM "F" ',I5,2X,
     $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
            TAG(KOUNT)(1:1) = 'F'
            TAG(KOUNT)(13:13) = '3'
            ITEVNT(KOUNT) = 2
         END IF
         IF(TAG(KOUNT)(14:14).GT.'3')  THEN
            IF(EWRITE)  PRINT 2908, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $       ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 2908 FORMAT(/' #EVENT 2: LATITUDE IS 0 DEGREES, SHUM QM "F" ',I5,2X,
     $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
            TAG(KOUNT)(2:2) = 'F'
            TAG(KOUNT)(14:14) = '3'
            IQEVNT(KOUNT) = 2
         END IF
         IF(TAG(KOUNT)(15:15).GT.'3')  THEN
            IF(EWRITE)  PRINT 8908, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $       ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 8908 FORMAT(/' #EVENT 2: LATITUDE IS 0 DEGREES, WIND QM "F" ',I5,2X,
     $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
            TAG(KOUNT)(3:3) = 'F'
            TAG(KOUNT)(15:15) = '3'
            IWEVNT(KOUNT) = 2
         END IF
      END IF

      IF(NINT(ALON(KOUNT)*100.).EQ.0) THEN
         TAG(KOUNT)(12:12) = '@'
CVVVVV%%%%%
ccc      PRINT *,'~~~~~ HERE IS A RPT WITH LONGITUDE OF 0 DEGREES'
CAAAAA%%%%%
         IF(TAG(KOUNT)(13:13).GT.'3')  THEN
            IF(EWRITE)  PRINT 5908, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $       ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 5908 FORMAT(/' #EVENT 3: LONGITUDE IS 0 DEGREES, TEMP QM "F" ',I5,2X,
     $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
            TAG(KOUNT)(1:1) = 'F'
            TAG(KOUNT)(13:13) = '3'
            ITEVNT(KOUNT) = 3
         END IF
         IF(TAG(KOUNT)(14:14).GT.'3')  THEN
            IF(EWRITE)  PRINT 5909, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $       ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 5909 FORMAT(/' #EVENT 3: LONGITUDE IS 0 DEGREES, SHUM QM "F" ',I5,2X,
     $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
            TAG(KOUNT)(2:2) = 'F'
            TAG(KOUNT)(14:14) = '3'
            IQEVNT(KOUNT) = 3
         END IF
         IF(TAG(KOUNT)(15:15).GT.'3')  THEN
            IF(EWRITE)  PRINT 5910, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $       ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 5910 FORMAT(/' #EVENT 3: LONGITUDE IS 0 DEGREES, WIND QM "F" ',I5,2X,
     $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
            TAG(KOUNT)(3:3) = 'F'
            TAG(KOUNT)(15:15) = '3'
            IWEVNT(KOUNT) = 3
         END IF
      END IF

      IF(TAG(KOUNT)(15:15).GT.'3'.AND.NINT(ASPD(KOUNT)*10.).EQ.0.)  THEN
C FLAG ALL CALM WINDS
         IF(EWRITE)  PRINT 9005, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $    ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9005 FORMAT(/' #EVENT 4: CALM WIND, WIND Q.M. SET "F".',
     $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
         TAG(KOUNT)(3:3) = 'F'
         TAG(KOUNT)(15:15) = '3'
         IWEVNT(KOUNT) = 4
      END IF

      IF(TAG(KOUNT)(13:13).GT.'2'.AND.ATMPF(KOUNT).LT.XMSG)  THEN
C IF GUESS TEMPERATURE AVAILABLE, CHECK TEMPERATURE OF REPORTS WITH
C  ALTITUDE BETWEEN 2000 AND 5000 FEET - IF NOT WITHIN 25 DEG. C OF
C  GUESS TEMPERATURE FLAG THE REPORT; SET POS. 12 OF TAG TO '@' TO MARK
C  THEM
C  (NOTE: DONE TO FLAG RPTS THAT ARE ACTUALLY AT AN ALT. BETWEEN 20,000
C         AND 50,000 FT. BUT ARE REPORTED WITH A '0' DIGIT DROPPED)
         IF((AALT(KOUNT).GT.609..AND.AALT(KOUNT).LT.1524.).AND.
     $    (ABS(ATMP(KOUNT)-ATMPF(KOUNT)).GT.25.))  THEN
            TAG(KOUNT)(12:12) = '@'
CVVVVV%%%%%
            PRINT *,'~~~~~ HERE IS A RPT WITH INCORRECT? ALTITUDE!!'
CAAAAA%%%%%
            IF(TAG(KOUNT)(13:13).GT.'3')  THEN
               IF(EWRITE)  PRINT 9902, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $          ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 9902 FORMAT(/' #EVENT 5: "0" DIGIT DROPPED FROM ALT.?, TEMP QM "F" ',
     $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
               TAG(KOUNT)(1:1) = 'F'
               TAG(KOUNT)(13:13) = '3'
               ITEVNT(KOUNT) = 5
            END IF
            IF(TAG(KOUNT)(14:14).GT.'3')  THEN
               IF(EWRITE)  PRINT 7902, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $          ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 7902 FORMAT(/' #EVENT 5: "0" DIGIT DROPPED FROM ALT.?, SHUM QM "F" ',
     $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
               TAG(KOUNT)(2:2) = 'F'
               TAG(KOUNT)(14:14) = '3'
               IQEVNT(KOUNT) = 5
            END IF
            IF(TAG(KOUNT)(15:15).GT.'3')  THEN
               IF(EWRITE)  PRINT 8902, KOUNT,ACID(KOUNT),ALAT(KOUNT),
     $          ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16)
 8902 FORMAT(/' #EVENT 5: "0" DIGIT DROPPED FROM ALT.?, WIND QM "F" ',
     $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/)
               TAG(KOUNT)(3:3) = 'F'
               TAG(KOUNT)(15:15) = '3'
               IWEVNT(KOUNT) = 5
            END IF
         END IF
      END IF

      IF(IWRITE)  THEN
         PRINT 6177, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),
     $    NINT(TIME(KOUNT)),NINT(AALT(KOUNT)),ATMP(KOUNT),ASPH(KOUNT),
     $    NINT(ADIR(KOUNT)),ASPD(KOUNT),TAG(KOUNT)(1:3),
     $    TAG(KOUNT)(4:16),INTP(KOUNT),IRTM(KOUNT),KNTINI(KOUNT),
     $    NINT(AALTF(KOUNT)),ATMPF(KOUNT),NINT(ADIRF(KOUNT)),
     $    ASPDF(KOUNT)
 6177     FORMAT(' ',I5,2X,A8,1X,2(1X,F6.2),1X,I4,1X,I5,2(1X,F5.1),1X,
     $     I3,1X,F4.1,2X,A3,2X,A13,3X,I2,3X,I4,2X,I5,1X,I5,1X,F5.1,2X,
     $     I3,1X,F4.1)
      END IF

C NOW GO BACK AND READ IN NEXT REPORT
      GO TO 5

C***********************************************************************

    2 CONTINUE

C ALL MESSAGES READ IN -- FINISHED READING IN REPORTS
      PRINT 812, KOUNT
  812 FORMAT(/' ALL MESSAGES READ IN PREPBUFR FILE -- TOTAL NUMBER OF ',
     $ 'REPORTS READ=',I6)
      NFILE = KOUNT

      IF(KOUNT.EQ.0)  GO TO 6000

C***********************************************************************
C             SORT BY ACARS STATION ID (FOR TRACK CHECKING)
C***********************************************************************
      CALL IDSORT(NFILE,NEXCLUDE)
      IF(IWRITE)  THEN
         PRINT 2177
 2177 FORMAT(/' LISTING OF ORIGINAL DATA AFTER IDSORT----'/9X,'ACID',
     $ 7X,'LAT   WLON   UTC  ALT   TEMP  SHUM DIR  SPD  -QM  ----TAGS',
     $ '-----  ITP RPTIME KNTINI  GALT GTEMP GDIR GSPD'/)
         DO K = 1,KOUNT
      PRINT 6177, K,ACID(K),ALAT(K),ALON(K),NINT(TIME(K)),NINT(AALT(K)),
     $ ATMP(K),ASPH(K),NINT(ADIR(K)),ASPD(K),TAG(K)(1:3),TAG(K)(4:16),
     $ INTP(K),IRTM(K),KNTINI(K),NINT(AALTF(K)),ATMPF(K),NINT(ADIRF(K)),
     $ ASPDF(K)
         ENDDO
      END IF
      PRINT 6122, KOUNT,NEXCLUDE
 6122 FORMAT(/' AFTER ID SORT: INPUT FILE COUNT=',I7,', NUMBER OF ',
     $ 'EXCLUDED REPORTS=',I5/)

C***********************************************************************
C                         TRACK CHECK
C***********************************************************************
C CALL TRACK CHECK WITH NEXCLUDE (GOOD REPORTS ARE FIRST IN SORTED
C  ARRAY, REPORTS EXCLUDED FROM ALL CHECKS ARE LAST IN SORTED ARRAY)
C CALL TRACK CHECK WITH NFILE=KOUNT, RETURNS NEW KOUNT (NO DUPS)
      CALL TRKCHK(KOUNT,NEXCLUDE)   ! Not much happens in here yet!
C***********************************************************************
C HERE, TAG(KOUNT)(16:16) NOW CONTAINS '-' OR 'E' FOR SUSPECTED TRKCHK
C  ERROR - DO CENSUS ON INCREMENTS
      DO K = 1,KOUNT
         IF(TIME(K).GE.TMINO.AND.TIME(K).LE.TMAXO)  THEN
            DO M = 1,11
               IF(TAG(K)(5:5).EQ.INACMK(M))  THEN
                  NNIN(M) = NNIN(M) + 1
                  EXIT
               END IF
            ENDDO
         END IF
      ENDDO
C INITIALIZE SDM LOOKAT FILE FOR FLAGGED REPORTS -- UNIT 52
      WRITE(52,15) (IDATE(I),I=1,4)
   15 FORMAT(/'SDM ACARS QC CHECK FILE FOR ',I6,3I4.2)
      WRITE(52,16)
   16 FORMAT('REPORTS TOSSED (WIND AND/OR TEMP QM=F), OR WITH LARGE ',
     $ 'WIND INCREMENTS (.GE. 50 )'/
     $ ' (SUSPECT QM=Q, GOOD QM=A)'/
     $ '(NOTE1: ACARS ARE NEVER FLAGGED AS BAD DUE ONLY TO LARGE ',
     $ 'INCREMENTS)'/
     $ '(NOTE2: DOES NOT INCLUDE REPORTS MARKED FOR EXCLUSION BY ',
     $ 'THIS PROGRAM - THESE'/9X,'ARE NOT CONSIDERED CANDIDATES FOR ',
     $ 'RETENTION)'//
     $ 'SDMEDIT CAN BE USED TO MARK THESE FOR RETENTION (KEEP FLAG) ',
     $ 'IN LATER RUNS'/' OR FLAG (PURGE) THOSE WITH LARGE WIND ',
     $ 'INCREMENTS'//)

      WRITE(52,17)
   17 FORMAT(/' AC',9X,'LAT    LON     UTC   ALT  TEMP  SHUM  WDIR  ',
     $ 'WSPD  INCR  WND TMP'/'IDENT',27X,'(MB)  (C)  (G/KG)',7X,
     $ '(M/S) (KTS)  QM  QM'/'--------  ------ -------  ----  ----',
     $ ' -----  ----- ----  ----- ----- --- ---'/)

      KDUP = NFILE - KOUNT
C ARRANGE STACK - INDX RUNS FROM 1 TO KOUNT
      JARRAY = 0
      CTAG = '----------------'
      AAID = '        '
      DO INDX = 1,KOUNT
         SLAT(1) = ALAT(INDX)
         SLON(1) = ALON(INDX)
         SAID(1) = ACID(INDX)
         SHGT(1) = AALT(INDX)
         STIM(1) = TIME(INDX)
         SDIR(1) = ADIR(INDX)
         SSPD(1) = ASPD(INDX)
         STMP(1) = ATMP(INDX)
         SSPH(1) = ASPH(INDX)
         SHGTF(1) = AALTF(INDX)
         SDIRF(1) = ADIRF(INDX)
         SSPDF(1) = ASPDF(INDX)
         STMPF(1) = ATMPF(INDX)

C CALL RPACKR
         CALL RPACKR(INDX)

C CALL FORSDM TO ALERT SDM TO FLAGGED REPORTS OR REPORTS WITH LARGE
C  INCREMENTS (SKIP EXCLUDED REPORTS AT END OF THE LIST)
         IF(INDX.LE.KOUNT-NEXCLUDE)  CALL FORSDM(INDX)

         ICNT1 = ICNT1 + 1
      ENDDO

 6000 CONTINUE

C-----------------------------------------------------------------------
C             PACK Q.C'ED OBSERVATIONS INTO PREPBUFR FILE
C-----------------------------------------------------------------------
      CALL OBUFR(KOUNT)

C-----------------------------------------------------------------------
C           ALL REPORTS HAVE BEEN PROCESSED -- WE ARE DONE
C-----------------------------------------------------------------------
      PRINT 8926, KNTOUT
 8926 FORMAT(/5X,'@@@@@  ALL REPORTS PROCESSED: NUMBER OF ORIGINAL ',
     $ '"AIRCAR" MASS REPORTS COPIED TO OUTPUT FILE =',I6/35X,'NUMBER ',
     $ 'OF ORIGINAL "AIRCAR" WIND REPORTS COPIED TO OUTPUT FILE =',I6)
      IF(FWRITE)  THEN
         PRINT 8923
 8923 FORMAT(//26X,'>>>>>  ORIGINAL LISTING OF ACARS REPORTS NOW WITH ',
     $ 'NEW QUALITY MARKS  <<<<<'//'     K   STNID    TIME   LAT    LON ',
     $ '   ALT  TEMP  SHUM  DIR  SPD   -QM  ----TAGS-----  ITP  ',
     $ 'KINI TEV QEV WEV  GALT GTEMP GDIR GSPD'/16X,'UTC',10X,'WEST',5X,
     $ 'M    C    G/KG  DEG  M/S',8X,13('-'),27X,'M    C    DEG  M/S'/)
         KNT = 0
         DO K = 1,KOUNT
            IF(TAG(K)(4:4).EQ.'D')  GO TO 200
            KNT = KNT + 1
      PRINT 6111, KNT,ACID(K),NINT(TIME(K)),ALAT(K),ALON(K),
     $ NINT(AALT(K)),ATMP(K),ASPH(K),NINT(ADIR(K)),ASPD(K),TAG(K)(1:3),
     $ TAG(K)(4:16),INTP(K),KNTINI(K),ITEVNT(K),IQEVNT(K),IWEVNT(K),
     $ NINT(AALTF(K)),ATMPF(K),NINT(ADIRF(K)),ASPDF(K)
 6111 FORMAT(' ',I7,1X,A8,1X,I4,2(1X,F6.2),1X,I5,2(1X,F5.1),2X,I3,2X,
     $ F4.1,2X,A3,2X,A13,3X,I2,1X,I5,3(1X,I3),1X,I5,1X,F5.1,2X,I3,1X,
     $ F4.1)
  200       CONTINUE
         ENDDO
      END IF

      PRINT 5001, NFILE,ICNT1,KDUP
 5001 FORMAT(//' ORIGINAL DATA (WITHIN EXPANDED INPUT TIME WINDOW)'/
     $ ' INPUT FILE COUNT=',I6,'; NUMBER OF NON-DUPLICATES WRITTEN ',
     $ 'OUT=',I6,'; NUMBER OF DUPLICATES NOT WRITTEN OUT=',I5)
      PRINT 5014, INACMK
 5014 FORMAT(//' ORIGINAL DATA (WITHIN OUTPUT TIME WINDOW)'/49X,
     $ 11(5X,A1)/)
      PRINT 5331, NNIN
 5331 FORMAT(' NUMBER ACCORDING TO OBS-GUESS INCREMENT (INPUT)  ',11I6)
      PRINT 5337, KISO
 5337 FORMAT(' NUMBER ACCORDING TO OBS-GUESS INCREMENT (OUTPUT) ',11I6)

      END FILE 52

      REWIND 52

      PRINT 5015
 5015 FORMAT(/49X,'************PROGRAM COMPLETED *********')

      CALL W3TAGE('PREPOBS_ACARSQC')

      STOP
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    TRKCHK      COMPLETE TRACK CHECK FOR ALL FLIGHTS
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2002-05-07
C
C ABSTRACT: PERFORMS COMPLETE TRACK CHECK FOR ALL ACARS FLIGHTS WITH
C   TWO OR MORE REPORTS.  USING REPORTS ALREADY SORTED BY STATION
C   ID (TAIL NUMBER), CALCULATES GROUND SPEED AND OTHER LOGICAL
C   QUANTITIES TO ENTER DECISION MAKING ALGORITHM FOR CHOOSING BAD
C   REPORTS. THESE OBSERVATIONS ARE FLAGGED.  DUPLICATE REPORTS ARE
C   ELIMINATED.  NOTE:  THIS IS NOT YET RUNNING, ALL THIS SUBROUTINE
C   DOES NOW IS RESORT REPORTS ACCORDING TO REPORTED LATITUDE.
C
C PROGRAM HISTORY LOG:
C 2002-05-07  D. A. KEYSER -- ORIGINAL AUTHOR (NO TRACK CHECKING
C             LOGIC YET IN PLACE)
C
C USAGE:    CALL TRKCHK(NFILE,NEXCLUDE)
C   INPUT ARGUMENT LIST:
C     NFILE    - NUMBER OF OBSERVATIONS TO BE TREATED
C     NEXCLUDE - NUMBER OF EXCLUDED REPORTS AT END OF SORT
C
C   OUTPUT ARGUMENT LIST:
C     NFILE    - NUMBER OF OBSERVATIONS AFTER DUPLICATES REMOVED
C
C   OUTPUT FILES:
C     UNIT 06  - PRINTOUT
C
C REMARKS: CALLED BY MAIN PROGRAM.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$
      SUBROUTINE TRKCHK(NFILE,NEXCLUDE)

      PARAMETER (IRMX= 250000, ISMX= 4000)
      PARAMETER (ISIZE= 18)
C PARAMETER NAME "ITMX" IN THIS SUBROUTINE (ONLY) SETS THE MAXIMUM
C  NUMBER OF ACARS RPTS THAT CAN BE CHECKED IN A SINGLE TRACK
      PARAMETER (ITMX= 4000)
      PARAMETER (ITRKL= 20)

      LOGICAL  LOGLAT,LOGTME,LOGLT1,LOGWND,DUP,LOGTRK,LOGALT,NEW,LOGLON,
     $ LOGLO,LOGTMP,LOGGT3,LOGHI,LPOS25,TRACE,LUTCEQ,LLATEQ,LLONEQ,
     $ LVAREQ,EWRITE,EWRITE_7,IWRITE

      CHARACTER*1  TOSLIM,CTG
      CHARACTER*8  ACID,SAAID(IRMX),AAID(IRMX),TYPE(ITRKL)
      CHARACTER*16  TAG,CTAG(IRMX),STAG(IRMX)
      CHARACTER*32  CARRAY(IRMX)

      INTEGER  IPTNAD(ITRKL),JPTNAD(ITRKL),IPTADJ(ITRKL),IPTTRK(5),
     $ DTKNT,IARRAY(ISMX),INDR(IRMX)

      REAL  AVESPD(ITMX),DELPOS(ITMX),DELLAT(ITMX),DELLON(ITMX)

      COMMON/STWRIT/EWRITE,EWRITE_7,IWRITE
      COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG
      COMMON/ACCONT/KISO(11)
      COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX),
     $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX),
     $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX),
     $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX),
     $ IQEVNT(IRMX)

      DATA XMSG/99999./,IMSG/99999/

      KOUNT = NFILE
      TRACE = .TRUE.
      TRACE = .FALSE.
      DG2RAD = (4.0 * ATAN(1.0))/180.

C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING
C  (ORIGINAL DATA HAS BEEN SORTED BY TAIL NUMBER ID, WITH BAD REPORTS
C   LAST)
      AAID(1:NFILE)           = ACID(1:NFILE)
      SAAID(1:NFILE)          = AAID(1:NFILE)
      JARRAY(1:NFILE,1)       = NINT(ALAT(1:NFILE)*100.)
      JARRAY(1:NFILE,2)       = NINT(ALON(1:NFILE)*100.)
      JARRAY(1:NFILE,3)       = NINT(AALT(1:NFILE))
      JARRAY(1:NFILE,4)       = NINT(TIME(1:NFILE))
      JARRAY(1:NFILE,5)       = NINT(ATMP(1:NFILE)*10.)
      JARRAY(1:NFILE,6)       = NINT(ADIR(1:NFILE))
      JARRAY(1:NFILE,7)       = NINT(ASPD(1:NFILE)*10.)
      JARRAY(1:NFILE,8)       = INTP(1:NFILE)
      JARRAY(1:NFILE,9)       = IRTM(1:NFILE)
      JARRAY(1:NFILE,10)      = KNTINI(1:NFILE)
      JARRAY(1:NFILE,11)      = ITEVNT(1:NFILE)
      JARRAY(1:NFILE,12)      = IWEVNT(1:NFILE)
      JARRAY(1:NFILE,13)      = NINT(AALTF(1:NFILE))
      JARRAY(1:NFILE,14)      = NINT(ADIRF(1:NFILE))
      JARRAY(1:NFILE,15)      = NINT(ASPDF(1:NFILE)*10.)
      JARRAY(1:NFILE,16)      = NINT(ATMPF(1:NFILE)*10.)
      JARRAY(1:NFILE,17)      = NINT(ASPH(1:NFILE)*10.)
      JARRAY(1:NFILE,18)      = IQEVNT(1:NFILE)
      KARRAY(1:NFILE,:)       = JARRAY(1:NFILE,:)
      CTAG(1:NFILE)           = TAG(1:NFILE)
      STAG(1:NFILE)           = CTAG(1:NFILE)
      NACARS = NFILE - NEXCLUDE
      PRINT 501, KOUNT,NACARS,NEXCLUDE
  501 FORMAT(1X,128('*')/43X,'ACARS TRACK CHECK SORT - NCEP ',
     $ 'WASHINGTON'/128('*')//' INPUT FILE COUNT=',I6,', NUMBER OF ',
     $ 'NON-EXCLUDED REPORTS=',I6,', NUMBER OF EXCLUDED REPORTS=',I6)
CCCCC PRINT 502
CC502 FORMAT(' LISTING OF DATA, SORTED BY ID, ENTERING TRKCHK----'/9X,
CCCCC$ 'ACID',7X,'LAT   WLON   UTC  ALT   TEMP  SHUM DIR  SPD  ',
CCCCC$ '-QM ----TAGS-----   ITP RPTIME KNTINI  GALT GTEMP GDIR GSPD'/)
CCCCC DO J = 1,KOUNT
CCCCC    SARRY1 = XMSG
CCCCC    IF(JARRAY(J, 1).LT.IMSG)  SARRY1  = JARRAY(J, 1) * 0.01
CCCCC    SARRY2 = XMSG
CCCCC    IF(JARRAY(J, 2).LT.IMSG)  SARRY2  = JARRAY(J, 2) * 0.01
CCCCC    SARRY5 = XMSG
CCCCC    IF(JARRAY(J, 5).LT.IMSG)  SARRY5  = JARRAY(J, 5) * 0.1
CCCCC    SARRY7 = XMSG
CCCCC    IF(JARRAY(J, 7).LT.IMSG)  SARRY7  = JARRAY(J, 7) * 0.1
CCCCC    SARRY15 = XMSG
CCCCC    IF(JARRAY(J,15).LT.IMSG)  SARRY15 = JARRAY(J,15) * 0.1
CCCCC    SARRY16 = XMSG
CCCCC    IF(JARRAY(J,16).LT.IMSG)  SARRY16 = JARRAY(J,16) * 0.1
CCCCC    SARRY17 = XMSG
CCCCC    IF(JARRAY(J,17).LT.IMSG)  SARRY17 = JARRAY(J,17) * 0.1
CCCCC    PRINT 331, J,AAID(J),SARRY1,SARRY2,JARRAY(J,4),JARRAY(J,3),
CCCCC$    SARRAY5,SARRAY17,JARRAY(J,6),SARRAY7,CTAG(J)(1:3),
CCCCC$    CTAG(J)(4:16),JARRAY(J,8),JARRAY(J,9),JARRAY(J,10),
CCCCC$    JARRAY(J,13),SARRY16,JARRAY(J,14),SARRY15
CCCCC ENDDO
      PRINT 574
  574 FORMAT(/' ----------------------------------')
      NTRK = 0
      ITRK = NACARS + 1
   65 CONTINUE
      PRINT 574

C***********************************************************************
C        DETERMINE TRACK FOR EACH NON-EXCLUDED ACARS FLIGHT ID
C***********************************************************************
      PRINT 574
      NTRK = 0
      ITRK = 1
      PRINT 574

C   Future Track checking logic will go here

C RESORT FOR SUBSEQUENT Q.C. CHECKING:
C    1ST ORDER - LATITUDE (SOUTH TO NORTH)
C    2ND ORDER - LONGITUDE (WEST, INCREASING)
C    3RD ORDER - TIME (INCREASING)
C    4TH ORDER - ALITITUDE (INCREASING)
C SORT BY CONCATENATING THESE QUANITIIES INTO CHARACTER ARRAY
      DO J = 1,NACARS
         WRITE(CARRAY(J)(1:5),'(I5.5)') JARRAY(J,1) + 9000
         WRITE(CARRAY(J)(6:10),'(I5.5)') JARRAY(J,2)
         WRITE(CARRAY(J)(11:14),'(I4.4)') JARRAY(J,4)
         WRITE(CARRAY(J)(15:20),'(I6.6)') JARRAY(J,3)
         CARRAY(J)(21:32) = '000000000000'
CCCCC    PRINT 788, J,AAID(J),CARRAY(J)
CC788    FORMAT(' DBG J ',I6,2X,'; ID=',A8,'; CARRAY=',A32)
      ENDDO
C  CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE
      IF(NACARS.GT.0)  CALL INDEXC(NACARS,CARRAY,INDR)
C WRITE SORTED REPORTS INTO SAAID, KARRAY, AND STAG ARRAYS (REMAINING
C  EXCLUDED REPORTS ALREADY IN THESE ARRAYS IN PROPER POSITION FROM
C  STORE MADE AT BEGINNING OF SUBROUTINE)
      DO I = 1,NACARS
         J = INDR(I)
         SAAID(I) = AAID(J)
         STAG(I) = CTAG(J)
         KARRAY(I,:) = JARRAY(J,:)
      ENDDO
CCCCC PRINT 562
CC562 FORMAT(' LAT/LON  ACID ',6X,' LAT     LON ',4X,'UTC    ALT  ',
CCCCC$'   TEMP    SHUM    WDIR     WSPD ')
CCCCC DO J = 1,KOUNT
CCCCC    KARRY1  = MIN(KARRAY(J, 1),IMSG)
CCCCC    KARRY2  = MIN(KARRAY(J, 2),IMSG)
CCCCC    KARRY5  = MIN(KARRAY(J, 5),IMSG)
CCCCC    KARRY17 = MIN(KARRAY(J,17),IMSG)
CCCCC    KARRY7  = MIN(KARRAY(J, 7),IMSG)
CCCCC    PRINT 711, J,SAAID(J),KARRY1*.01,KARRY2*.01,KARRAY(J,4),
CCCCC$   KARRAY(J,3),KARRAY5*.1,KARRAY17*.1,KARRAY(J,6),KARRAY7*.1,
CCCCC$   STAG(J)(1:3),STAG(J)(4:16)
CC711    FORMAT(' ',I5,2X,A8,2(2X,F6.2),4X,I4,3X,I5,2(3X,F5.1),5X,I3,4X,
CCCCC$   F4.1,A3,1X,A13)
CCCCC ENDDO
C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS AND ELIMINATE DUPS
      IF(IWRITE)  PRINT 557
  557 FORMAT(/' FINAL LISTING OF DATA, SORTED BY ID AND LATITUDE, ',
     $ ' LEAVING TRKCHK----'/9X,'ACID',7X,'LAT   WLON   UTC  ALT   ',
     $ 'TEMP  SHUM DIR  SPD  -QM  ----TAGS-----  ITP RPTIME KNTINI  ',
     $ 'GALT GTEMP GDIR GSPD'/)
      M = 0
      DO I = 1,KOUNT
         IF(STAG(I)(4:4).EQ.'D')  THEN
            PRINT 9022, I,SAAID(I),REAL(KARRAY(I,1))*.01,
     $       REAL(KARRAY(I,2))*.01,REAL(KARRAY(I,4)),STAG(I)(1:3),
     $       STAG(I)(4:16)
 9022 FORMAT(/' ##########: TRKCHK; DUPLICATE REMOVED AT END OF SUBR..',
     $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/)
            CYCLE
         END IF
         M = M + 1
         ACID(M)   = SAAID(I)
         ALAT(M)   = KARRAY(I,1) * .01
         ALON(M)   = KARRAY(I,2) * .01
         AALT(M)   = KARRAY(I,3)
         TIME(M)   = KARRAY(I,4)
         ATMP(M)   = KARRAY(I,5) * .1
         ADIR(M)   = KARRAY(I,6)
         ASPD(M)   = KARRAY(I,7) * .1
         INTP(M)   = KARRAY(I,8)
         IRTM(M)   = KARRAY(I,9)
         KNTINI(M) = KARRAY(I,10)
         ITEVNT(M) = KARRAY(I,11)
         IWEVNT(M) = KARRAY(I,12)
         AALTF(M)  = KARRAY(I,13)
         ADIRF(M)  = KARRAY(I,14)
         ASPDF(M)  = KARRAY(I,15) * .1
         ATMPF(M)  = KARRAY(I,16) * .1
         ASPH(M)   = KARRAY(I,17) * .1
         IQEVNT(M) = KARRAY(I,18)
         TAG(M)    = STAG(I)
         IF(IWRITE)  PRINT 331, M,ACID(M),ALAT(M),ALON(M),NINT(TIME(M)),
     $    NINT(AALT(M)),ATMP(M),ASPH(M),NINT(ADIR(M)),ASPD(M),
     $    TAG(M)(1:3),TAG(M)(4:16),INTP(M),IRTM(M),KNTINI(M),
     $    NINT(AALTF(M)),ATMPF(M),NINT(ADIRF(M)),ASPDF(M)
  331     FORMAT(' ',I5,2X,A8,1X,2(1X,F6.2),1X,I4,1X,I5,2(1X,F5.1),1X,
     $     I3,1X,F4.1,2X,A3,2X,A13,3X,I2,3X,I4,2X,I5,1X,I5,1X,F5.1,2X,
     $     I3,1X,F4.1)
      ENDDO
      NFILE = M
      PRINT 681, NFILE
  681 FORMAT(//1X,128('*')/25X,'OUT OF TRACK CHECK - NUMBER OF NON-',
     $ 'DUPLICATE REPORTS (INCL. PREVIOUSLY EXCLUDED) =',I7/1X,128('*')
     $ ///)

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FORSDM      WRITES FLAGGED OR LARGE INCREMENT REPORTS
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2002-05-07
C
C ABSTRACT: WRITES ALL REPORTS CONTAINING A TEMPERATURE AND/OR WIND
C   WHICH HAS BEEN FLAGGED FOR NON-USE TO A TEXT FILE WHICH THE SDM
C   CAN EXAMINE.  ALSO WRITES ALL REPORTS WITH LARGE WIND INCREMENTS,
C   REGARDLESS OF QUALITY MARKER.  THIS ALLOWS THE SDM TO USE SDMEDIT
C   TO 'KEEP' ANY OF THESE REPORTS IN THE NEXT NETWORK RUN.
C
C PROGRAM HISTORY LOG:
C 2002-05-07  D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE
C                             IN EXISTING PROGRAM "PREPOBS_PREPACQC")
C
C USAGE:    CALL FORSDM(INDX)
C   INPUT ARGUMENT LIST:
C     INDX     - POINTER TO POSITION IN ORIGINAL ACARS ARRAY
C
C   OUTPUT FILES:
C     UNIT 52  - TEXT FILE FOR SDM PERUSAL (LIST OF REPORTS THAT ARE
C              - FLAGGED FOR NON-USE BY THIS PROGRAM AS WELL AS THOSE
C              - WITH LARGE INCREMENTS)
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$
      SUBROUTINE FORSDM(INDX)

      PARAMETER (IRMX= 250000)

      CHARACTER*1  CTG,CLON,TAGX(3),CH1(9)
      CHARACTER*8  ACID
      CHARACTER*16  TAG

      INTEGER  ICH1(9)

      COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST
      COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91)
      COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX),
     $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX),
     $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX),
     $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX),
     $ IQEVNT(IRMX)

      DATA XMSG/99999./
      DATA CH1  /'Q','R','S','T','U','V','W','X','Y'/
      DATA ICH1 /10, 20, 30, 40, 50, 60, 70, 80, 90 /

      IF((TAG(INDX)(5:5).GE.'U'.AND.TAG(INDX)(5:5).LE.'Z').OR.
     $ TAG(INDX)(1:1).EQ.'F'.OR.TAG(INDX)(3:3).EQ.'F')  THEN
C SKIP WRITING OF ANY FLAGGED REPORTS OUTSIDE REQUESTED TIME WINDOW
         IF(TIME(INDX).LT.TMINO.OR.TIME(INDX).GT.TMAXO)  RETURN
C WRITE SDM WINDS W/ VECTOR INCR. U-Z OR WINDS AND/OR TEMPS FLAGGED BY
C  THIS PROGRAM; SCALE BASED ON VALUE OF SCALED INCREMENT CHARACTER Q-Z,
C  IF INCREMENT NOT AVAIL. SCALE SET TO MSG
         SCALE = XMSG
         IF(TAG(INDX)(5:5).GE.'Q'.AND.TAG(INDX)(5:5).LE.'Z')  THEN
            CTG = TAG(INDX)(5:5)
            SCALE = 100.0
            DO I=1,9
               IF(CTG.EQ.CH1(I)) THEN
                  SCALE = ICH1(I)
                  EXIT
               END IF
            ENDDO
         END IF

         IF(AALT(INDX).LE.11000.)  THEN
            PRALT = 1013.25 *
     $       (((288.15 - (.0065*AALT(INDX)))/288.15)**5.256)
         ELSE
             PRALT = 226.3 * EXP(1.576106E-4*(11000.-AALT(INDX)))
         END IF

         QTIME = MOD(TIME(INDX),2400.)
         QLON = ALON(INDX)
         CLON = 'W'
         IF(NINT(QLON).GT.180)  THEN
            QLON = (360. - QLON)
            CLON = 'E'
         END IF
         DO M = 1,3,1
            TAGX(M) = TAG(INDX)(M:M)
            IF(TAG(INDX)(M:M).EQ.'-'.OR.TAG(INDX)(M:M).EQ.'x')
     $       TAGX(M) = ' '
         END DO
         WRITE(52,25) ACID(INDX),ALAT(INDX),QLON,CLON,NINT(QTIME),
     $    NINT(PRALT),ATMP(INDX),ASPH(INDX),NINT(ADIR(INDX)),ASPD(INDX),
     $    NINT(SCALE),TAGX(3),TAGX(1)
   25 FORMAT(A8,2X,F6.2,1X,F6.2,A1,2(2X,I4),2(1X,F5.1),3X,I3,1X,F5.1,2X,
     $ I3,2X,2(3X,A1))
      END IF

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    RPACKR      PREPARES OBS. FOR PACKING
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2002-05-07
C
C ABSTRACT: PREPARES OBSERVATIONS FOR FINAL PACKING TO OUTPUT FILE.
C   FINAL CHECK TO REMOVE DUPLICATES, FINAL ASSIGNMENT OF TEMPERATURE,
C   SPECIFIC HUMIDITY AND WIND QUALITY MARKERS (IF APPLICABLE) AND
C   ACCUMULATION OF NEW SUPEROBS IN HOLDING ARRAYS (IF APPLICABLE).
C
C PROGRAM HISTORY LOG:
C 2002-05-07  D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE
C                             IN EXISTING PROGRAM "PREPOBS_PREPACQC")
C
C USAGE:    CALL RPACKR(INDX)
C   INPUT ARGUMENT LIST:
C     INDX     - POINTER TO POSITION IN ORIGINAL ACARS ARRAY
C
C   OUTPUT FILES:
C     UNIT 06  - PRINTOUT
C
C REMARKS: CALLED BY MAIN PROGRAM.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$

      SUBROUTINE RPACKR(INDX)

      PARAMETER (IRMX= 250000, ISMX= 4000)
      PARAMETER (ISUP= 2000)

      LOGICAL  EWRITE,EWRITE_7

      CHARACTER*4  SSMARK
      CHARACTER*8  ACID,SAID
      CHARACTER*16  TAG

      INTEGER  IDATA(1608)

      REAL  ORIGTM(10),RDATA(1608)

      COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST
      COMMON/OUTPUT/KNTOUT(2)
      COMMON/STWRIT/EWRITE,EWRITE_7,IWRITE
      COMMON/SUMDAT/SAID(ISMX),SLAT(ISMX),SLON(ISMX),SHGT(ISMX),
     $ STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX),SSPH(ISMX),
     $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX)
      COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX),
     $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX),
     $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX),
     $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX),
     $ IQEVNT(IRMX)
      COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP),
     $ SSTMP(ISUP),SSSPH(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP),
     $ SSTMPF(ISUP),SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP)

      EQUIVALENCE  (IDATA,RDATA)

      DATA  IMSG/99999/

C INVENTORY INCREMENTS
      CALL ACCOUNT(INDX)
      IF(TAG(INDX)(4:4).EQ.'D')  THEN
C SKIP REPACKING OF ORIGINAL REPORT IF IT IS INDEED A DUPLICATE REPORT
         PRINT 9026, INDX,ACID(INDX),ALAT(INDX),ALON(INDX),
     $    TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16)
 9026 FORMAT(/' ##########: RPACKR; DUPLICATE REMOVED AT BEG OF SUBR..',
     $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/)
         KNTINI(INDX) = IMSG
         GO TO 1
      END IF
C SKIP REPACKING OF ORIGINAL REPORT IF IT IS OUTSIDE REQ. TIME WINDOW
      IF(TIME(INDX).LT.TMINO.OR.TIME(INDX).GT.TMAXO)  THEN
C SET POS.1 OF TAG TO 'D' TO REMOVE FROM FINAL LISTING OF ORIG. REPORTS
         TAG(INDX)(4:4) = 'D'
CCCCC    PRINT 9002, INDX,ACID(INDX),ALAT(INDX),ALON(INDX),
CCCCC$    TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16)
C9002 FORMAT(/' ##########: RPACKR; RPTS OUTSIDE TIME WINDOW SKIPPED..',
CCCCC$ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/)
         KNTINI(INDX) = IMSG
         GO TO 1
      END IF
C NOW, MAKE FINAL ASSIGNMENT OF TEMPERATURE, SPECIFIC HUMIDITY AND WIND
C  Q. MARKS (IF APPL.)
      IF(TAG(INDX)(13:13).GT.'5')  THEN
         IF(TAG(INDX)(10:10).EQ.'7')  THEN
            IF(EWRITE)  PRINT 9095, INDX,ACID(INDX),ALAT(INDX),
     $       ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16)
 9095 FORMAT(/' #EVENT 6: RPACKR; ACARS BANKING?, TEMP QM. Q',
     $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/)
            TAG(INDX)(1:1) = 'Q'
            TAG(INDX)(13:13) = '5'
            ITEVNT(INDX) = 6
         ELSE  IF(TAG(INDX)(13:13).GT.'6')  THEN
C IF "GOOD" REPORT, TEMP Q.M. IS 'A'
            IF(EWRITE_7)  PRINT 9090, INDX,ACID(INDX),ALAT(INDX),
     $       ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16)
 9090 FORMAT(' #EVENT 7: RPACKR; "GOOD" ACARS, TEMP Q.M. A',
     $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13)
            TAG(INDX)(1:1) = 'A'
            TAG(INDX)(13:13) = '6'
            ITEVNT(INDX) = 7
         END IF
      END IF
      IF(TAG(INDX)(14:14).GT.'5')  THEN
         IF(TAG(INDX)(10:10).EQ.'7')  THEN
            IF(EWRITE)  PRINT 7095, INDX,ACID(INDX),ALAT(INDX),
     $       ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16)
 7095 FORMAT(/' #EVENT 6: RPACKR; ACARS BANKING?, SHUM QM. Q',
     $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/)
            TAG(INDX)(2:2) = 'Q'
            TAG(INDX)(14:14) = '5'
            IQEVNT(INDX) = 6
         ELSE  IF(TAG(INDX)(14:14).GT.'6')  THEN
C IF "GOOD" REPORT, SPECIFIC HUMIDITY Q.M. IS 'A'
            IF(EWRITE_7)  PRINT 7090, INDX,ACID(INDX),ALAT(INDX),
     $       ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16)
 7090 FORMAT(' #EVENT 7: RPACKR; "GOOD" ACARS, SHUM Q.M. A',
     $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13)
            TAG(INDX)(2:2) = 'A'
            TAG(INDX)(14:14) = '6'
            IQEVNT(INDX) = 7
         END IF
      END IF
      IF(TAG(INDX)(15:15).GT.'5')  THEN
         IF(TAG(INDX)(10:10).EQ.'7')  THEN
            IF(EWRITE)  PRINT 8095, INDX,ACID(INDX),ALAT(INDX),
     $       ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16)
 8095 FORMAT(/' #EVENT 6: RPACKR; ACARS BANKING?, WIND QM. Q',
     $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/)
            TAG(INDX)(3:3) = 'Q'
            TAG(INDX)(15:15) = '5'
            IWEVNT(INDX) = 6
         ELSE  IF(TAG(INDX)(15:15).GT.'6')  THEN
C IF "GOOD" ACARS REPORT, WIND Q.M. IS 'A'
            IF(EWRITE_7)  PRINT 9091, INDX,ACID(INDX),ALAT(INDX),
     $       ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16)
 9091 FORMAT(' #EVENT 7: RPACKR; "GOOD" ACARS, WIND Q.M. A',
     $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13)
            TAG(INDX)(3:3) = 'A'
            TAG(INDX)(15:15) = '6'
            IWEVNT(INDX) = 7
         END IF
      END IF
      IF(TAG(INDX)(1:1).EQ.'F'.AND.TAG(INDX)(14:14).GT.'3')  THEN
C IF TEMPERATURE IS FLAGGED, THEN SPECIFIC HUMIDITY IS ALWAYS
C  ALSO FLAGGED
         IF(EWRITE)  PRINT 7033, INDX,ACID(INDX),ALAT(INDX),
     $    ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16)
 7033 FORMAT(/' #EVENT 8: RPACKR; BAD TEMP, SHUM Q.M. SET TO "F"....',
     $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/)
         TAG(INDX)(2:2) = 'F'
         TAG(INDX)(14:14) = '3'
         IQEVNT(INDX) = 8
      END IF

    1 CONTINUE

      NPT = 1

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ACCOUNT     DOES SIMPLE ACCOUNTING OF REPORTS
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2002-05-07
C
C ABSTRACT: DOES SIMPLE ACCOUNTING BY LOGGING NUMBER OF REPORTS BY
C   SCALED VECTOR INCREMENT.  IN ADDITION, LOGS THE NUMBER OF
C   SDM KEEPS AND SDM PURGES.  THE NUMBER OF BAD TEMPERATURES
C   IS ALSO ACCOUNTED FOR HERE.
C
C PROGRAM HISTORY LOG:
C 2002-05-07  D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE
C                             IN EXISTING PROGRAM "PREPOBS_PREPACQC")
C
C USAGE:    CALL ACCOUNT(INDX)
C   INPUT ARGUMENT LIST:
C     INDX     - POINTER TO POSITION IN ORIGINAL ACARS ARRAY
C
C REMARKS: CALLED BY SUBROUTINE 'RPACKR'.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$

      SUBROUTINE ACCOUNT(INDX)

      PARAMETER (IRMX= 250000)

      CHARACTER*1  INACMK(11)
      CHARACTER*8  ACID
      CHARACTER*16  TAG

      COMMON/ACCONT/KISO(11)
      COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX),
     $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX),
     $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX),
     $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX),
     $ IQEVNT(IRMX)
      COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST

      DATA  INACMK/'Q','R','S','T','U','V','W','X','Y','Z','N'/

      IF(TIME(INDX).GE.TMINO.AND.TIME(INDX).LE.TMAXO)  THEN
         DO  M = 1,11
            IF(TAG(INDX)(5:5).EQ.INACMK(M))  THEN
               KISO(M) = KISO(M) + 1
               EXIT
            END IF
         ENDDO
      END IF

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    IDSORT      SORTS INPUT AIRCAR REPORTS BY STATION ID
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2002-05-07
C
C ABSTRACT: USES LOCAL SORT ROUTINE TO SORT ENTIRE ACARS FILE
C   BY THE 8-CHARACTER STATION (FLIGHT) IDENTIFICATION.
C
C PROGRAM HISTORY LOG:
C 2002-05-07  D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE
C                             IN EXISTING PROGRAM "PREPOBS_PREPACQC")
C
C USAGE:    CALL IDSORT(NFILE,NEXCLUDE)
C   INPUT ARGUMENT LIST:
C     NFILE    - NUMBER OF OBSERVATIONS TO SORT
C
C   OUTPUT ARGUMENT LIST:
C     NEXCLUDE - NUMBER OF EXCLUDED REPORTS AT END OF SORT
C
C   OUTPUT FILES:
C     UNIT 06  - PRINTOUT
C
C REMARKS: CALLED BY MAIN PROGRAM.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$

      SUBROUTINE IDSORT(NFILE,NEXCLUDE)

      PARAMETER (IRMX= 250000)
      PARAMETER (ISIZE= 18)

      CHARACTER*8  ACID,AAID(IRMX)
      CHARACTER*16  TAG,STAG(IRMX)
      CHARACTER*32  CARRAY(IRMX)

      REAL  SARRAY(IRMX,ISIZE)

      INTEGER  INDR(IRMX)

      COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX),
     $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX),
     $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX),
     $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX),
     $ IQEVNT(IRMX)
      COMMON/WORD/ICHTP

      DATA  IMSG/99999/

      NEXCLUDE = 0
C FILL IN CARRAY FOR SORT ROUTINE
      DO J = 1,NFILE
         IF(TAG(J)(12:12).EQ.'@')  THEN
C EXCLUDED RPTS ARE COUNTED AND WILL BE AT VERY END OF SORT
C  (DO THIS BY CHANGING CHARACTER STRING TO:
C     '99999' IF CHARACTERS ARE EBCDIC,
C     '~~~~~' IF CHARACTERS ARE ASCII)
C    1ST ORDER - "99999" or "~~~~~"//STATION ID
C    2ND ORDER - TIME (INCREASING)
C    3RD ORDER - LONGITUDE (WEST, INCREASING)
C    4TH ORDER - LATITUDE (SOUTH TO NORTH)
C    5TH ORDER - ALTITUDE (INCREASING)
            NEXCLUDE = NEXCLUDE + 1
            CARRAY(J)(1:5) = '99999'
            IF(ICHTP.EQ.0)  CARRAY(J)(1:5) = '~~~~~'
            CARRAY(J)( 6:12) = ACID(J)(1:7)
            WRITE(CARRAY(J)(13:16),'(I4.4)')  NINT(TIME(J))
            WRITE(CARRAY(J)(17:21),'(I5.5)')  NINT(ALON(J)*100.)
            WRITE(CARRAY(J)(22:26),'(I5.5)')  NINT(ALAT(J)*100.) + 9000
            WRITE(CARRAY(J)(27:32),'(I6.6)')  NINT(AALT(J))
         ELSE
C GOOD REPORTS WILL BE AT BEGINNING OF SORT
C    1ST ORDER - STATION ID
C    2ND ORDER - LONGITUDE (WEST, INCREASING)
C    3RD ORDER - TIME (INCREASING)
C    4TH ORDER - LATITUDE (SOUTH TO NORTH)
C    5TH ORDER - ALTITUDE (INCREASING)
            CARRAY(J)(1:7) = ACID(J)(1:7)
            WRITE(CARRAY(J)(8:12),'(I5.5)')  NINT(ALON(J)*100.)
            WRITE(CARRAY(J)(13:16),'(I4.4)')  NINT(TIME(J))
            WRITE(CARRAY(J)(17:21),'(I5.5)')  NINT(ALAT(J)*100.) + 9000
            WRITE(CARRAY(J)(22:27),'(I6.6)')  NINT(AALT(J))
            CARRAY(J)(28:32) = '00000'
         END IF
C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING
         AAID(J) = ACID(J)
         SARRAY(J,1)  = ALAT(J)
         SARRAY(J,2)  = ALON(J)
         SARRAY(J,3)  = AALT(J)
         SARRAY(J,4)  = TIME(J)
         SARRAY(J,5)  = ATMP(J)
         SARRAY(J,6)  = ADIR(J)
         SARRAY(J,7)  = ASPD(J)
         SARRAY(J,8)  = REAL(INTP(J))
         SARRAY(J,9)  = REAL(IRTM(J))
         SARRAY(J,10) = REAL(KNTINI(J))
         SARRAY(J,11) = REAL(ITEVNT(J))
         SARRAY(J,12) = REAL(IWEVNT(J))
         SARRAY(J,13) = AALTF(J)
         SARRAY(J,14) = ADIRF(J)
         SARRAY(J,15) = ASPDF(J)
         SARRAY(J,16) = ATMPF(J)
         SARRAY(J,17) = ASPH(J)
         SARRAY(J,18) = REAL(IQEVNT(J))
         STAG(J)      = TAG(J)
CCCCC    LON = IMSG
CCCCC    PRINT 1927, AAID(J),NINT(TIME(J)),ALON(J),CARRAY(J)
C1927    FORMAT(' ',A8,6X,I4,3X,F6.2,A32)
CCCCC    PRINT 100, J,AAID(J),SARRAY(J,1),SARRAY(J,2),SARRAY(J,4),
CCCCC$    SARRAY(J,3),SARRAY(J,5),SARRAY(J,17),SARRAY(J,6),SARRAY(J,7),
CCCCC$    STAG(J)(1:3)
CC100    FORMAT(' ', I7,2X,A8,2X,2(3X,F6.2),4X,F5.0,3X,F6.0,2(4X,F5.1),
CCCCC$    5X,F4.0,5X,F4.1,1X,A3)
      ENDDO
C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE
      IF(NFILE.GT.0)  CALL INDEXC(NFILE,CARRAY,INDR)
      DO I = 1,NFILE
         J = INDR(I)
C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS
         ACID(I)   = AAID(J)
         ALAT(I)   = SARRAY(J,1)
         ALON(I)   = SARRAY(J,2)
         AALT(I)   = SARRAY(J,3)
         TIME(I)   = SARRAY(J,4)
         ATMP(I)   = SARRAY(J,5)
         ADIR(I)   = SARRAY(J,6)
         ASPD(I)   = SARRAY(J,7)
         INTP(I)   = NINT(SARRAY(J,8))
         IRTM(I)   = NINT(SARRAY(J,9))
         KNTINI(I) = NINT(SARRAY(J,10))
         ITEVNT(I) = NINT(SARRAY(J,11))
         IWEVNT(I) = NINT(SARRAY(J,12))
         AALTF(I) = SARRAY(J,13)
         ADIRF(I) = SARRAY(J,14)
         ASPDF(I) = SARRAY(J,15)
         ATMPF(I) = SARRAY(J,16)
         ASPH(I)  = SARRAY(J,17)
         IQEVNT(I) = NINT(SARRAY(J,18))
         TAG(I)   = STAG(J)
      ENDDO

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    INDEXC      GENERAL SORT ROUTINE FOR CHARACTER ARRAY
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 1999-08-23
C
C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST
C   FOR A 32-CHARACTER ARRAY.  DOES NOT REARRANGE THE FILE.
C
C PROGRAM HISTORY LOG:
C 1993-06-05  R  KISTLER --- FORTRAN VERSION OF C-PROGRAM
C 1993-07-15  P. JULIAN ---- MODIFIED TO SORT 12-CHARACTER ARRAY
C 1994-08-25  D. A. KEYSER - MODIFIED TO SORT 16-CHARACTER ARRAY
C 1995-05-30  D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST,
C             IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY)
C 1999-08-23  D. A. KEYSER - EXPANDED CHARACTER ARRAY FROM 16 TO 32
C             BYTES (ALLOWS HIGHER ORDERS TO BE INCLUDED IN SORT)
C
C USAGE:    CALL INDEXC(N,CARRIN,INDX)
C   INPUT ARGUMENT LIST:
C     N        - SIZE OF ARRAY TO BE SORTED
C     CARRIN   - 32-CHARACTER ARRAY TO BE SORTED
C
C   OUTPUT ARGUMENT LIST:
C     INDX     - ARRAY OF POINTERS GIVING SORT ORDER OF CARRIN IN
C              - ASCENDING ORDER {E.G., CARRIN(INDX(I)) IS SORTED IN
C              - ASCENDING ORDER FOR ORIGINAL I = 1, ... ,N}
C
C REMARKS: CALLED BY SUBROUTINES 'TRKCHK' AND 'IDSORT'.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$

      SUBROUTINE INDEXC(N,CARRIN,INDX)

      CHARACTER*32  CARRIN(N),CC

      INTEGER  INDX(N)

      DO J = 1,N
         INDX(J) = J
      ENDDO

C MUST BE > 1 ELEMENT IN SORT LIST, ELSE RETURN
      IF(N.LE.1)  RETURN

      L = N/2 + 1
      IR = N

   33 CONTINUE

      IF(L.GT.1)  THEN
         L = L - 1
         INDXT = INDX(L)
         CC = CARRIN(INDXT)
      ELSE
         INDXT = INDX(IR)
         CC = CARRIN(INDXT)
         INDX(IR) = INDX(1)
         IR = IR - 1
         IF(IR.EQ.1)  THEN
            INDX(1) = INDXT
            RETURN
         END IF
      END IF
      I = L
      J = L * 2

   30 CONTINUE

      IF(J.LE.IR)  THEN
         IF(J.LT.IR)  THEN
            IF(CARRIN(INDX(J)).LT.CARRIN(INDX(J+1)))  J = J + 1
         END IF
         IF(CC.LT.CARRIN(INDX(J)))  THEN
            INDX(I) = INDX(J)
            I = J
            J = J + I
         ELSE
            J = IR + 1
         ENDIF
      END IF
      IF(J.LE.IR)  GO TO 30
      INDX(I) = INDXT
      GO TO 33

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    INDEXF      GENERAL SORT ROUTINE FOR INTEGER ARRAY
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 1995-05-30
C
C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST
C   FOR AN INTEGER ARRAY.  DOES NOT REARRANGE THE FILE.
C
C PROGRAM HISTORY LOG:
C 1993-06-05  R  KISTLER -- FORTRAN VERSION OF C-PROGRAM
C 1995-05-30  D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST,
C             IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY)
C
C USAGE:    CALL INDEXF(N,IARRIN,INDX)
C   INPUT ARGUMENT LIST:
C     N        - SIZE OF ARRAY TO BE SORTED
C     IARRIN   - INTEGER ARRAY TO BE SORTED
C
C   OUTPUT ARGUMENT LIST:
C     INDX     - ARRAY OF POINTERS GIVING SORT ORDER OF IARRIN IN
C              - ASCENDING ORDER {E.G., IARRIN(INDX(I)) IS SORTED IN
C              - ASCENDING ORDER FOR ORIGINAL I = 1, ... ,N}
C
C REMARKS: CALLED BY SUBROUTINES 'TRKCHK' AND 'OBUFR'.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$

      SUBROUTINE INDEXF(N,IARRIN,INDX)

      INTEGER  INDX(N),IARRIN(N)

      DO J = 1,N
         INDX(J) = J
      ENDDO

C MUST BE > 1 ELEMENT IN SORT LIST, ELSE RETURN
      IF(N.LE.1)  RETURN
      L = N/2 + 1
      IR = N

   33 CONTINUE

      IF(L.GT.1)  THEN
         L = L - 1
         INDXT = INDX(L)
         II = IARRIN(INDXT)
      ELSE
         INDXT = INDX(IR)
         II = IARRIN(INDXT)
         INDX(IR) = INDX(1)
         IR = IR - 1
         IF(IR.EQ.1)  THEN
            INDX(1) = INDXT
            RETURN
         END IF
      END IF
      I = L
      J = L * 2

   30 CONTINUE

      IF(J.LE.IR)  THEN
         IF(J.LT.IR)  THEN
            IF(IARRIN(INDX(J)).LT.IARRIN(INDX(J+1)))  J = J + 1
         END IF
         IF(II.LT.IARRIN(INDX(J)))  THEN
            INDX(I) = INDX(J)
            I = J
            J = J + I
         ELSE
            J = IR + 1
         END IF
      END IF
      IF(J.LE.IR)  GO TO 30
      INDX(I) = INDXT
      GO TO 33

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    DBUFR       GETS THE DATE FROM A PREPBUFR FILE
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2009-08-03
C
C ABSTRACT: READS THRU SUCCESSIVE BUFR MESSAGES UNTIL THE BUFR TABLE
C   A ENTRY "AIRCAR" (ACARS AIRCRAFT REPORTS) IS FOUND IN A PREPBUFR
C   FILE.  RETURNS THE DATE OF THIS MESSAGE TO THE CALLING PROGRAM.
C
C PROGRAM HISTORY LOG:
C 2002-05-07  D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE
C                             IN EXISTING PROGRAM "PREPOBS_PREPACQC")
C 2009-08-03  D. A. KEYSER -- WILL NO LONGER TRY TO PULL OUT RECEIPT
C             TIME (RCT) FROM PRE-DECEMBER 2008 VERSIONS OF PREPBUFR
C             FILE WHICH DO YET INCLUDE IT IN ACARS REPORT HEADER (DONE
C             SO THAT CFSRR RUNS WILL NOT FAIL)
C
C USAGE:    CALL DBUFR(IDATEP)
C   OUTPUT ARGUMENT LIST:
C     IDATEP   - DATE FROM FIRST TABLE A "AIRCAR" MESSAGE (YYYYMMDDHH)
C
C   INPUT FILES:
C     UNIT 14  - PREPBUFR FILE CONTAINING ALL DATA
C
C   OUTPUT FILES:
C     UNIT06   - PRINTOUT
C
C REMARKS: CALLED BY MAIN PROGRAM.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$

      SUBROUTINE DBUFR(IDATEP)

      CHARACTER*8   SUBSET
      CHARACTER*1   CTAB

      COMMON/NEWTABLE/IPRSLEVLA

      CALL DATELEN(10)

      CALL OPENBF(14,'IN',14)

C  Check to see if the post 12/2008 version of the PREPBUFR mnemonic
C   table which includes Table D mnemonic "PRSLEVLA" is being used here
C  --------------------------------------------------------------------

      CALL STATUS(14,LUN,IDUMMY1,IDUMMY2)
      CALL NEMTAB(LUN,'PRSLEVLA',IDUMMY1,CTAB,IRET)
      IPRSLEVLA = 0
      IF(IRET.GT.0.AND.CTAB.EQ.'D') IPRSLEVLA = 1

   10 CONTINUE

      CALL READMG(14,SUBSET,IDATEP,IRET)
      IF(IRET.NE.0)   GO TO 999
      IF(SUBSET.NE.'AIRCAR  ')  GO TO 10
cppppp
      print * ,' '
      print *, 'First AIRCAR message found ... '
      print *,'PREPBUFR File Sec. 1 message date (IDATEP) = ',IDATEP
cppppp
      IF(IDATEP.LT.1000000000)  THEN

C If 2-digit year returned in IDATEP, must use "windowing" technique
C  to create a 4-digit year

C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
C            CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
C            Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)

         PRINT *, '##ACARSQC - THE FOLLOWING SHOULD NEVER HAPPEN!!!!!'
         PRINT *, '##ACARSQC - 2-DIGIT YEAR IN IDATEP RETURNED FROM ',
     $    'READMG (IDATEP IS: ',IDATEP,') - USE WINDOWING TECHNIQUE ',
     $    'TO OBTAIN 4-DIGIT YEAR'
         IF(IDATEP/1000000.GT.20)  THEN
            IDATEP = 1900000000 + IDATEP
         ELSE
            IDATEP = 2000000000 + IDATEP
         ENDIF
         PRINT *, '##ACARSQC - CORRECTED IDATEP WITH 4-DIGIT YEAR, ',
     $    'IDATEP NOW IS: ',IDATEP
      ENDIF

      RETURN

C-----------------------------------------------------------------------
  999 CONTINUE
C PREPBUFR DATA SET CONTAINS NO "AIRCAR" TABLE A MSGS -- STOP 4  !!!
      PRINT 14
   14 FORMAT(/' PREPBUFR DATA SET CONTAINS NO "AIRCAR" TABLE A ',
     $ 'MESSAGES - STOP 4'/)
      CALL CLOSBF(14)
      CALL W3TAGE('PREPOBS_ACARSQC')
      CALL ERREXIT(4)
C-----------------------------------------------------------------------

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    IBUFR       DECODES ACARS OBS. FROM PREPBUFR FILE
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2009-08-03
C
C ABSTRACT: DECODES AN ACARS AIRCRAFT OBSERVATION FROM A TABLE A
C   ENTRY "AIRCAR" MESSAGE IN A PREPBUFR FILE FOR EACH CALL.  IF ALL
C   SUBSETS HAVE BEEN DECODED IN A MESSAGE THE NEXT TABLE A ENTRY
C   "AIRCAR" MESSAGE IN READ IN AND DECODED.  A RETURN 1 OCCURS WHEN
C   ALL TABLE A ENTRY "AIRCAR" MESSAGES HAVE BEEN PROCESSED.  SPECIAL
C   LOGIC COMBINES THE SEPARATE WIND AND MASS REPORT "PIECES" INTO A
C   SINGLE OBSERVATION PRIOR TO RETURN TO CALLING PROGRAM.
C
C PROGRAM HISTORY LOG:
C 2002-05-07  D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE
C             IN EXISTING PROGRAM "PREPOBS_PREPACQC")
C 2008-09-25  D. A. KEYSER -- IN RESPONSE TO CHANGE FROM SINGLE LEVEL
C             TO DELAYED REPLICATION FOR "AIRCAR" REPORT LEVEL DATA NOW
C             IN PREPBUFR FILE (IN PREPARATION FOR NRL AIRCRAFT QC
C             PROGRAM WHICH WILL REPLACE THIS PROGRAM AND CAN GENERATE
C             AIRCRAFT "PROFILES"), RECEIPT TIME (RCT) (WHICH IS NOW
C             PART OF LEVEL DATA) IS NO LONGER RETRIEVED IN SAME CALL
C             TO UFBINT AS REMAINING SINGLE-LEVEL HEADER DATA (TO AVOID
C             BUFRLIB ERROR) (ALL LEVEL DATA HERE STILL HAS JUST ONE
C             REPLICATION AT THIS POINT)
C 2009-08-03  D. A. KEYSER -- WILL NO LONGER TRY TO PULL OUT RECEIPT
C             TIME (RCT) FROM PRE-DECEMBER 2008 VERSIONS OF PREPBUFR
C             FILE WHICH DO YET INCLUDE IT IN ACARS REPORT HEADER (DONE
C             SO THAT CFSRR RUNS WILL NOT FAIL)
C
C USAGE:    CALL IBUFR(ALTF,DIRF,SPDF,TMPF,*)
C   INPUT ARGUMENT LIST:
C     ALTF     - INITIAL FORECAST VALUE FOR PRESSURE ALTITUDE, MISSING
C     DIRF     - INITIAL FORECAST VALUE FOR WIND DIRECTION, MISSING
C     SPDF     - INITIAL FORECAST VALUE FOR WIND SPEED, MISSING
C     TMPF     - INITIAL FORECAST VALUE FOR TEMPERATURE, MISSING
C
C   OUTPUT ARGUMENT LIST:
C     ALTF     - FORECAST VALUE FOR PRESSURE ALTITUDE (METERS)
C     DIRF     - FORECAST VALUE FOR WIND DIRECTION (DEGREES)
C     SPDF     - FORECAST VALUE FOR WIND SPEED (M/S)
C     TMPF     - FORECAST VALUE FOR TEMPERATURE (DEG. C)
C
C   INPUT FILES:
C     UNIT 14  - PREPBUFR FILE CONTAINING ALL DATA
C
C   OUTPUT FILES:
C     UNIT 06  - PRINTOUT
C
C REMARKS: CALLED BY MAIN PROGRAM.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$

      SUBROUTINE IBUFR(ALTF,DIRF,SPDF,TMPF,*)

      CHARACTER*1   CIQMMK(10),CF,PF,CINCR
      CHARACTER*8   SUBSET,IDENT
      CHARACTER*40  HEADR,OBLVL,FCLVL

      REAL(8)  HDR6_8,OBS_8(10),HDR_8(9),FST_8(4),RCT_8
      REAL     ACAT(9)

      COMMON/QUALITY/ITQM,IQQM,IWQM
      COMMON/CBUFR/IDENT,IRCTME,RDATA(1608),KIX,CINCR,CF,PF
      COMMON/STDATE/IDATE(5)
      COMMON/NEWTABLE/IPRSLEVLA

      EQUIVALENCE  (IDENT,HDR6_8),(IRPTYP,RDATA(8))

      DATA  CIQMMK/'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/
      DATA   ACAT/10.5,20.5,30.5,40.5,50.5,60.5,70.5,80.5,90.5/
      DATA  HEADR/'YOB XOB NUL DHR TSB SID ITP TYP SQN     '/
      DATA  OBLVL/'ZOB TOB DDO FFO TQM WQM UOB VOB QOB QQM '/
      DATA  FCLVL/'UFC VFC TFC ZFC                         '/
      DATA  XMSG/99999./,IMSG/99999/,IFLAG/0/,ILOOP/1/,KI/0/,SQNL/0/
      DATA  BMISS /10E10/

C ON INPUT: IFLAG =0 - 1ST "PIECE" OF NEXT OBS. HAS NOT YET BEEN DECODED
C           IFLAG =1 - 1ST "PIECE" OF NEXT OBS. DECODED IN PREVIOUS CALL
      IF(IFLAG.EQ.1)  GO TO 45
      RDATA = XMSG

   30 CONTINUE

      CALL READSB(14,IRET)
      IF(IRET.NE.0)  THEN
   20    CONTINUE
         CALL READMG(14,SUBSET,IDATEP,IRET)
         IF(IRET.NE.0)  THEN
C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ
C  FILE WILL BE CLOSED
            PRINT 101
  101 FORMAT(/5X,'===> PREPBUFR DATA SET IN UNIT 14 SUCCESSFULLY',
     $ ' CLOSED FROM INITIAL READ OF ACARS OBS.')
            CALL CLOSBF(14)
            RETURN 1
         END IF
         IF(SUBSET.NE.'AIRCAR  ')  GO TO 20
         GO TO 30
      END IF

      CALL UFBINT(14,HDR_8, 9,1,N1LEV,HEADR)
      CALL UFBINT(14,OBS_8,10,1,NLEV ,OBLVL)
      CALL UFBINT(14,FST_8, 4,1,NLEV2,FCLVL)
      IF(IPRSLEVLA.EQ.1) THEN

C  If the post 12/2008 version of the PREPBUFR mnemonic table which
C   includes Table D mnemonic "PRSLEVLA" is being used here, then 'RCT'
C   is present in the ACARS report header
C  --------------------------------------------------------------------

         CALL UFBINT(14,RCT_8, 1,1,N3LEV,'RCT')
      ELSE

C  .... otherwise, 'RCT' is not present in the ACARS report header
C       ----------------------------------------------------------

         RCT_8 = BMISS
         N3LEV = 1 ! set so that if test below will not be satisfied
      END IF
      IF(N1LEV.NE.NLEV.OR.NLEV2.NE.NLEV.OR.NLEV.NE.1.OR.N3LEV.NE.NLEV)
     $ GO TO 999
      KI = NINT(HDR_8(8))/100
      IF(ILOOP.EQ.2)  THEN
C COMPARE RPT SEQ. NUMBERS IN HEADERS OF TWO "PIECES" DECODED IN THIS
C  CALL - IF THEY AGREE THEN BOTH ARE PART OF SAME OBS., OTHERWISE THIS
C  OBS. CONSISTS OF ONLY ONE "PIECE" AND IT IS RETURNED TO CALLING PGM
C  (IFLAG=1 ON RETURN INDICATES NEXT OBS. 1ST "PIECE" HAS BEEN DECODED)
         IF(HDR_8(9).EQ.SQNL)  GO TO 40
         ILOOP = 1
         IFLAG = 1
         RETURN
      END IF

   45 CONTINUE

C CONSTRUCT OBSERVATION HEADER(ONLY DONE FOR 1ST DECODED REPORT "PIECE")
      CF     = '-'
      PF     = '-'
      CINCR = 'N'
      RDATA(1) = MIN(99999._8,HDR_8(1))
      RDATA(2) = MIN(99999._8,(360._8-HDR_8(2)))
C     IRCTME  = MIN(IMSG,NINT(HDR_8(3)*100.))
      IRCTME  = NINT(MIN(9999._8,HDR_8(3)*100.))
C     NDT = MIN(IMSG,NINT(HDR_8(4)*100.))
      NDT = NINT(MIN(9999._8,HDR_8(4)*100.))
      RDATA(4) = NDT + (IDATE(4) * 100)
      RDATA(4) = MOD(NINT(RDATA(4)),2400)
      IF(NINT(RDATA(4)).LT.0)  RDATA(4) = NINT(2400. + RDATA(4))
      if (hdr_8(5) .lt. xmsg) then
         IF(NINT(HDR_8(5)).EQ.1)  CF = 'C'
         IF(NINT(HDR_8(5)).EQ.2)  PF = '7'
      endif
C     IRPTYP   = MIN(99,NINT(HDR_8(7)))
      IRPTYP   = NINT(MIN(99._8,HDR_8(7)))
      HDR6_8 = HDR_8(6)
      KIX = HDR_8(8)

   40 CONTINUE

      IF(KI.EQ.2)  THEN
C CONSTRUCT WIND PART OF OBSERVATION FROM DECODED WIND REPORT "PIECE"

C CINCR HOLDS SCALED VECTOR WIND INCREMENT MARKER (IF APPLICABLE)
C  OBTAINED FROM THE CALCULATED VECTOR INCREMENT (NOTE: IF REPORT TIME
C  IS > 3.33-HOURS FROM CYCLE TIME THE DEFAULT SCALE = 'N' IS STORED)
         IF(MAX(FST_8(1),FST_8(2)).LT.XMSG)  THEN
            IF(MAX(OBS_8(7),OBS_8(8)).LT.XMSG.AND.(ABS(RDATA(4)-
     $       REAL(IDATE(4)*100.)).LE.333..OR.(RDATA(4)-
     $       REAL(IDATE(4)*100.)).GE.2067.))  THEN
               VDIF = SQRT((FST_8(1)-OBS_8(7))**2
     $                    +(FST_8(2)-OBS_8(8))**2)*1.9425
               CINCR = 'Z'
               DO J = 1,9
                  IF(VDIF.LT.ACAT(J))  THEN
                     CINCR = CIQMMK(J)
                     EXIT
                  END IF
               ENDDO
            END IF
C CONSTRUCT FCST WIND DIR. (DEG) & SPD (M/S) FROM FCST WIND COMPONENTS
            ISUNIT = 2
            UFC = FST_8(1)
            VFC = FST_8(2)
            CALL CMDDFF(ISUNIT,UFC,VFC,DIRF,SPDF)
            DIRF = NINT(DIRF)
         END IF
C RDATA(43) HOLDS PRESSURE ALTITUDE (METERS)
         RDATA(43) = MIN(99999._8,OBS_8(1))
C ALTF HOLDS FORECAST PRESSURE ALTITUDE (METERS)
         IF(FST_8(4).LT.XMSG)  ALTF = NINT(FST_8(4))
C RDATA(46) HOLDS WIND DIRECTION (DEGREES)
         RDATA(46) = MIN(99999._8,OBS_8(3))
C RDATA(46) HOLDS WIND SPEED (M/S)
         SPEED = XMSG
         IF(MAX(OBS_8(7),OBS_8(8)).LT.XMSG)
     $    SPEED = SQRT(OBS_8(7)**2 + OBS_8(8)**2)
         RDATA(47) = MIN(XMSG,SPEED)
C IWQM HOLDS WIND QUALITY MARKER (NUMERIC)
         IWQM = MIN(99._8,OBS_8(6))
      ELSE
C CONSTRUCT MASS PART OF OBSERVATION FROM DECODED MASS REPORT "PIECE"

C RDATA(43) HOLDS PRESSURE ALTITUDE (METERS)
         RDATA(43) = MIN(99999._8,OBS_8(1))
C ALTF HOLDS FORECAST PRESSURE ALTITUDE (METERS)
         IF(FST_8(4).LT.XMSG)  ALTF = NINT(FST_8(4))
C RDATA(44) HOLDS TEMPERATURE (DEGREES CELSIUS)
         RDATA(44) = MIN(99999._8,OBS_8(2))
C TMPF HOLDS FORECAST TEMPERATURE (DEGREES CELSIUS X 10)
         IF(FST_8(3).LT.XMSG)  TMPF = FST_8(3)
C ITQM HOLDS TEMPERATURE QUALITY MARKER (NUMERIC)
         ITQM = MIN(99._8,OBS_8(5))
C RDATA(45) HOLDS SPECIFIC HUMIDITY (G/KG)
         RDATA(45) = MIN(99999._8,OBS_8(9)*.001)
C IQQM HOLDS SPECIFIC HUMIDITY QUALITY MARKER (NUMERIC)
         IQQM = MIN(99._8,OBS_8(10))
      END IF

      IF(ILOOP.EQ.1)  THEN
C IF ONLY ONE "PIECE" HAS BEEN DECODED IN THIS CALL, DECODE NEXT "PIECE"
C  TO DETERMINE IF IT IS THE SECOND "PIECE" OF THE ACARS OBSERVATION
C  (SAVE RPT SEQ. # OF 1ST "PIECE" FOR LATER COMPARISON AGAINST SECOND)
         SQNL = HDR_8(9)
         ILOOP = 2
         GO TO 30
      END IF

C IF TWO "PIECES" HAVE BEEN DECODED IN THIS CALL, READY TO RETURN
C  COMPLETE ACARS OBSERVATION TO CALLING PROGRAM
      ILOOP = 1
      IFLAG = 0

      RETURN

C-----------------------------------------------------------------------
  999 CONTINUE
C THE NUMBER OF DECODED LEVELS IS NOT 1!! -- STOP 70
      PRINT 217
  217 FORMAT(/' THE NUMBER OF DECODED LEVELS FOR A REPORT IS NOT 1 -- ',
     $ 'STOP 70'/)
      CALL W3TAGE('PREPOBS_ACARSQC')
      CALL ERREXIT(70)
C-----------------------------------------------------------------------

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    OBUFR       WRITES ACARS RPTS TO PREPBUFR FILE
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2002-05-07
C
C ABSTRACT: RESORTS ALL OBS. IN HOLDING ARRAYS BACK TO ORIGINAL ORDER,
C   THEN FOR ALL TABLE A ENTRY MESSAGES EXCEPT "AIRCAR" DOES A
C   STRAIGHT COPY OF EACH SUBSET (REPORT) FROM THE INPUT PREPBUFR
C   FILE TO THE OUTPUT PREPBUFR FILE.  FOR TABLE A ENTRY "AIRCAR"
C   MESSAGES, ALSO COPIES ALL SUBSETS (RPTS) THAT ARE NOT DUPLICATES
C   OR NOT OUTSIDE USER-SPECIFIED TIME WINDOW.  HOWEVER, FROM RESORTED
C   OBS. HOLDING ARRAYS, DETERMINES IF AN "EVENT" HAS OCCURRED (I.E.,
C   A CHANGED TEMPERATURE, SPECIFIC HUMIDITY OR WIND QUALITY MARKER).
C   IF SO, PUSHES DOWN TEMPERATURE, SPECIFIC HUMIDITY OR WIND STACKED
C   EVENTS AND RECORDS THIS EVENT (REASON CODE) ALONG WITH THE NEW
C   QUALITY MARKER PRIOR TO WRITING THE SUBSET TO THE OUTPUT PREPBUFR
C   FILE.  WILL ALSO UPDATE LAT/LON IF IT WAS CHANGED DUE TO A WAYPOINT
C   ERROR (THIS IS NOT A STACKED EVENT, HOWEVER).
C
C PROGRAM HISTORY LOG:
C 2002-05-07  D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE
C                             IN EXISTING PROGRAM "PREPOBS_PREPACQC")
C
C USAGE:    CALL OBUFR(KOUNT)
C   INPUT ARGUMENT LIST:
C     KOUNT    - THE NUMBER OF ACARS OBSERVATIONS IN HOLDING ARRAYS
C
C   INPUT FILES:
C     UNIT 14  - PREPBUFR FILE CONTAINING ALL DATA
C
C   OUTPUT FILES:
C     UNIT 06  - PRINTOUT
C     UNIT 61  - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACARS QC)
C
C REMARKS: CALLED BY MAIN PROGRAM.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$

      SUBROUTINE OBUFR(KOUNT)

      PARAMETER (IRMX= 250000)
      PARAMETER (ISIZE= 18)

      CHARACTER*1   CHRQM(6)
      CHARACTER*8   LAST,ACID,AAID(IRMX),SUBSET,POSITN,HEADR
      CHARACTER*16  TAG,STAG(IRMX)
      CHARACTER*20  QM1LVL,QM2LVL,QM3LVL

      REAL(8) HDR_8(2),QMS1_8(4),QMS2_8(5),QMS3_8(4)
      REAL RQM(6),SARRAY(IRMX,ISIZE),PHIACF(7)

      INTEGER  INDR(IRMX),IARRAY(IRMX),MFLAG(2)

      COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX),
     $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX),
     $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX),
     $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX),
     $ IQEVNT(IRMX)
      COMMON/OUTPUT/KNTOUT(2)
      COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST
      COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91)

      DATA  QM1LVL/'TOB TQM TPC TRC     '/
      DATA  QM2LVL/'UOB WQM WPC WRC VOB '/
      DATA  QM3LVL/'QOB QQM QPC QRC     '/
      DATA  HEADR/'TYP SQN '/
      DATA  POSITN/'YOB XOB '/
      DATA  KNTBFR/0/,KKK/0/,IFLAG/0/,SQNL/0/
      DATA  RQM  / 0., 1., 3.,13.,10.,14./
      DATA  CHRQM/'H','A','Q','F','O','P'/
      DATA  LAST/'XXXXXXXX'/,ISUBO/0/,ISUBOT/0/,IRECOL/0/,IRECO/0/
      DATA  PHIACF/-90.,-70.,-20.,0.,20.,70.,90./
      DATA  MFLAG/2*0/

      PRINT 199
  199 FORMAT(/5X,'===> ALL REPORTS Q.C.ED AND READY FOR REPACKING'/)
C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING

      DO J = 1,KOUNT
         AAID(J) = ACID(J)
         SARRAY(J,1)  = ALAT(J)
         SARRAY(J,2)  = ALON(J)
         SARRAY(J,3)  = AALT(J)
         SARRAY(J,4)  = TIME(J)
         SARRAY(J,5)  = ATMP(J)
         SARRAY(J,6)  = ADIR(J)
         SARRAY(J,7)  = ASPD(J)
         SARRAY(J,8)  = REAL(INTP(J))
         SARRAY(J,9)  = REAL(IRTM(J))
         SARRAY(J,10) = REAL(KNTINI(J))
         SARRAY(J,11) = REAL(ITEVNT(J))
         SARRAY(J,12) = REAL(IWEVNT(J))
         SARRAY(J,13) = AALTF(J)
         SARRAY(J,14) = ADIRF(J)
         SARRAY(J,15) = ASPDF(J)
         SARRAY(J,16) = ATMPF(J)
         SARRAY(J,17) = ASPH(J)
         SARRAY(J,18) = REAL(IQEVNT(J))
         STAG(J)      = TAG(J)
         IARRAY(J) = KNTINI(J)
      ENDDO

C NEED TO RESORT OBS. ACCORDING TO ORIGINAL ORDER THAT WAS READ IN
C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE
      IF(KOUNT.GT.0)  CALL INDEXF(KOUNT,IARRAY,INDR)
C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS
      DO I = 1,KOUNT
         J = INDR(I)
         ACID(I)   = AAID(J)
         ALAT(I)   = SARRAY(J,1)
         ALON(I)   = SARRAY(J,2)
         AALT(I)   = SARRAY(J,3)
         TIME(I)   = SARRAY(J,4)
         ATMP(I)   = SARRAY(J,5)
         ADIR(I)   = SARRAY(J,6)
         ASPD(I)   = SARRAY(J,7)
         INTP(I)   = NINT(SARRAY(J,8))
         IRTM(I)   = NINT(SARRAY(J,9))
         KNTINI(I) = NINT(SARRAY(J,10))
         ITEVNT(I) = NINT(SARRAY(J,11))
         IWEVNT(I) = NINT(SARRAY(J,12))
         AALTF(I)  = SARRAY(J,13)
         ADIRF(I)  = SARRAY(J,14)
         ASPDF(I)  = SARRAY(J,15)
         ATMPF(I)  = SARRAY(J,16)
         ASPH(I)   = SARRAY(J,17)
         IQEVNT(I) = NINT(SARRAY(J,18))
         TAG(I)    = STAG(J)
      ENDDO

      CALL DATELEN(10)
      CALL OPENBF(14,'IN',14)
      PRINT 200
  200 FORMAT(/5X,'+++> PREPBUFR DATA SET IN UNIT 14 SUCCESSFULLY',
     $ ' OPENED FOR INPUT; FIRST MESSAGE CONTAINS BUFR TABLES A,B,D'/)
      CALL OPENBF(61,'OUT',14)
      PRINT 100
  100 FORMAT(/5X,'+++> PREPBUFR DATA SET IN UNIT 61 SUCCESSFULLY',
     $ ' OPENED FOR OUTPUT; CUSTOMIZED BUFR TABLES A,B,D IN UNIT 14'/
     $ 12X,'READ IN AND ENCODED INTO MESSAGE NO. 1 OF OUTPUT DATA SET'/)

C GET THE "PROGRAM CODE" CORRESPONDING TO "ACARSQC"
      CALL UFBQCD1(14,'ACARSQC',PCODE)

   10 CONTINUE

C READ IN NEXT BUFR MESSAGE FROM INPUT FILE
      CALL READMG(14,SUBSET,IDATEP,IRET)
      IF(IRET.NE.0)  THEN
C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ
C  CLOSE INPUT DATA SET
         IF(LAST.EQ.'AIRCAR  ')  THEN
            CALL UFBCNT(61,IRECO,ISUBO)
            ISUBOT = ISUBOT + ISUBO
            PRINT 1254, IRECO,LAST,ISUBO,ISUBOT
 1254 FORMAT(/' --- WROTE BUFR DATA MSG NO. ',I10,' -- TABLE A ENTRY "',
     $A8,'" - CONTAINS',I6,' REPORTS (TOTAL NO. RPTS WRITTEN =',I7,')'/)
         END IF
         PRINT 9101, IRECO,ISUBOT
 9101 FORMAT(/' --- ALL TOTAL OF',I11,' BUFR MESSAGES WRITTEN OUT -- TO'
     $,'TAL NUMBER OF REPORTS WRITTEN =',I7//5X,'===> PREPBUFR DATA '
     $,'SET IN UNIT 14 SUCCESSFULLY CLOSED FROM FINAL READ OF ALL OBS')
         CALL CLOSBF(61)
         PRINT 9102
 9102 FORMAT(/5X,'===> PREPBUFR DATA SET IN UNIT 61 SUCCESSFULLY ',
     $ 'CLOSED AFTER WRITING OF ALL OBS'/25X,' *** ALL DONE ***'/)
         RETURN
      END IF
      CALL UFBCNT(14,IRECI,ISUBI)
CCCCC PRINT 1364, IRECI,SUBSET
      IF(SUBSET.EQ.'AIRCAR  ')  PRINT 1364, IRECI,SUBSET
 1364 FORMAT(' --- READ IN BUFR DATA MESSAGE NUMBER',I6,' WITH TABLE ',
     $ 'A ENTRY "',A8,'"')
      IF(LAST.NE.SUBSET)  THEN
         IF(LAST.EQ.'AIRCAR  ')  THEN
            CALL UFBCNT(61,IRECO,ISUBO)
            ISUBOT = ISUBOT + ISUBO
            PRINT 1254, IRECO,LAST,ISUBO,ISUBOT
C MUST CLOSE THE LAST "AIRCAR" TABLE A ENTRY MESSAGE
            CALL CLOSMG(61)
         END IF
         PRINT 105, SUBSET,IDATEP
  105 FORMAT(/' ===> NEXT MESSAGE IN OUTPUT PREPBUFR DATA SET IN ',
     $ 'UNIT 61 HAS NEW TABLE A ENTRY OF "',A6,'" -- DATE IS',I11)
         CALL UFBCNT(61,IRECOL,ISUBO)
         IRECOL = IRECOL + 1
      END IF
      LAST = SUBSET
      IF(SUBSET.NE.'AIRCAR  ')  THEN
C ALL TABLE A ENTRY BUFR MESSAGES THAT ARE NOT "AIRCAR" ARE SIMPLY
C  COPIED FROM INPUT FILE TO OUTPUT FILE AS IS (NO DECODING OF SUBSETS)
         CALL COPYMG(14,61)
         CALL UFBCNT(61,IRECO,ISUBO)
         ISUBOT = ISUBOT + ISUBO
CCCCC    PRINT 1254, IRECO,SUBSET,ISUBO,ISUBOT
         GO TO 10
      END IF
C TABLE A ENTRY "AIRCAR" MESSAGES COME HERE TO DECODE/ENCODE EACH SUBSET
      CALL OPENMB(61,SUBSET,IDATEP)

    2 CONTINUE

C READ IN NEXT SUBSET (REPORT) FROM THIS BUFR MESSAGE
      CALL READSB(14,IRET)
C NON-ZERO IRET IN READSB MEANS ALL SUBSETS IN BUFR MSG HAVE BEEN READ
C GO ON TO READ NEXT BUFR MESSAGE
      IF(IRET.NE.0)  GO TO 10
C OTHERWISE, MUST LOOK AT RPT SEQ. NUMBER TO SEE IF THIS IS PIECE 1 OF A
C  1- OR 2-PIECE(MASS/WIND) OBS. (KNEW=1) OR IF THIS IS PIECE 2 (KNEW=0)
      CALL UFBINT(14,HDR_8,2,1,N1LEV,HEADR)
      IF(N1LEV.NE.1)  GO TO 999
      KNEW = 0
      IF(HDR_8(2).NE.SQNL)  THEN
         KNEW  = 1
         IF(IFLAG.EQ.0)  THEN
C TEST BELOW SATISFIED WHEN BOTH JAMASS & JAWIND ARE 9999 FOR LAT BAND
C  (SET POS. 1 OF TAG TO 'D' TO REMOVE FROM FINAL PRINTOUT LISTING)
            IF(MIN(MFLAG(1),MFLAG(2)).EQ.1)  TAG(KKK)(4:4) = 'D'
            KKK = KKK + 1
            MFLAG(1) = 1
            MFLAG(2) = 1
         END IF
         IFLAG = 0
         KNTBFR = KNTBFR + 1
      END IF
      SQNL = HDR_8(2)
C DETERMINE IF THIS "AIRCAR" OBS SHOULD INDEED BE WRITTEN TO OUTPUT FILE
      IF(KNTBFR.NE.KNTINI(KKK))  THEN
C  -- COME HERE IF NOT AND SET IFLAG=1 IN CASE NEXT PIECE READ IN IS
C      PART OF THIS SAME OBS.
         IFLAG = 1
         GO TO 2
      END IF
C DETERMINE LATITUDE BAND INDEX (IBNDA)
      DO IBNDA = 1,5
         IF(ALAT(KKK).LT.(PHIACF(IBNDA+1)-0.005))  GO TO 6701
      ENDDO
      IBNDA = 6
 6701 CONTINUE
      KI = NINT(HDR_8(1))/100
      IF((JAMASS(IBNDA).NE.0.AND.KI.EQ.1).OR.(JAWIND(IBNDA).NE.0.AND.
     $ KI.EQ.2)) GO TO 3
      MFLAG(KI) = 0
C ALL SUBSETS THAT ARE TO BE RETAINED ARE FIRST COPIED FROM INPUT BUFFER
C  TO OUTPUT BUFFER AS IS
      CALL UFBCPY(14,61)
      IF(KI.EQ.1)  THEN
         IF(ITEVNT(KKK).GT.0)  THEN
C --> COME HERE IF THERE IS A TEMPERATURE EVENT (NEW Q. MARKER)
C      STACK NEW Q.MARK, PGM CODE, REASON CODE (EVENT) AND TEMP. OB
            CALL UFBINT(14,QMS1_8,4,1,N1LEV,QM1LVL)
            IF(N1LEV.NE.1)  GO TO 999
            QMS1_8(2) = 2.
            QMS1_8(3) = PCODE
            QMS1_8(4) = ITEVNT(KKK)
            DO I = 1,6
               IF(TAG(KKK)(1:1).EQ.CHRQM(I))  THEN
                  QMS1_8(2) = RQM(I)
                  EXIT
               END IF
            ENDDO
            CALL UFBINT(61,QMS1_8,4,1,IRET,QM1LVL)
         END IF
         IF(IQEVNT(KKK).GT.0)  THEN
C --> COME HERE IF THERE IS A SPECIFIC HUMIDITY EVENT (NEW Q. MARKER)
C      STACK NEW Q.MARK, PGM CODE, REASON CODE (EVENT) AND SHUM OB
            CALL UFBINT(14,QMS3_8,4,1,N1LEV,QM3LVL)
            IF(N1LEV.NE.1)  GO TO 999
            QMS3_8(2) = 2.
            QMS3_8(3) = PCODE
            QMS3_8(4) = IQEVNT(KKK)
            DO I = 1,6
               IF(TAG(KKK)(2:2).EQ.CHRQM(I))  THEN
                  QMS3_8(2) = RQM(I)
                  EXIT
               END IF
            ENDDO
            CALL UFBINT(61,QMS3_8,4,1,IRET,QM3LVL)
         END IF
      ELSE  IF(KI.EQ.2.AND.IWEVNT(KKK).GT.0)  THEN
C --> COME HERE IF THERE IS A WIND EVENT (NEW Q. MARKER)
C      STACK NEW Q.MARK, PGM CODE, REASON CODE (EVENT) AND WIND OB
         CALL UFBINT(14,QMS2_8,5,1,N1LEV,QM2LVL)
         IF(N1LEV.NE.1)  GO TO 999
         QMS2_8(2) = 2.
         QMS2_8(3) = PCODE
         QMS2_8(4) = IWEVNT(KKK)
         DO I = 1,6
            IF(TAG(KKK)(3:3).EQ.CHRQM(I))  THEN
               QMS2_8(2) = RQM(I)
               EXIT
            END IF
         ENDDO
         CALL UFBINT(61,QMS2_8,5,1,IRET,QM2LVL)
      END IF
      IF(KI.EQ.1)  THEN
         KNTOUT(1) = KNTOUT(1) + 1
      ELSE
         KNTOUT(2) = KNTOUT(2) + 1
      END IF
C FINALLY, WRITE SUBSET (REPORT) WITH ANY ADDED EVENTS (IF APPL.) TO
C  OUTPUT FILE
      CALL WRITSB(61)
      CALL UFBCNT(61,IRECO,ISUBON)
      IF(IRECO.GT.IRECOL)  THEN
         IRECOL = IRECO
         ISUBOT = ISUBOT + ISUBO
         PRINT 1264, IRECO-1,ISUBO,ISUBOT
 1264 FORMAT(/' --- THIS REPORT OPENS NEW MSG (SAME TABLE A): LAST ',
     $ 'DATA MSG WAS NO.',I5,' WITH',I5,' REPORTS (TOTAL NO. REPORTS ',
     $ 'WRITTEN =',I7,')'/)
      END IF
      ISUBO = ISUBON

    3 CONTINUE

CCCCC IF(KNEW.EQ.1)  THEN
CCCCC    PRINT 6111, KKK,ACID(KKK),TIME(KKK),ALAT(KKK),ALON(KKK),
CCCCC$   AALT(KKK),ATMP(KKK),ASPH(KKK),ADIR(KKK),ASPD(KKK),
CCCCC$   TAG(KKK)(1:3),TAG(KKK)(4:16),INTP(KKK),KNTINI(KKK),ITEVNT(KKK),
CCCCC$   IQEVNT(KKK),IWEVNT(KKK)
C6111    FORMAT(' ',I5,2X,A8,3X,F5.0,2(3X,F6.2),1X,F6.0,2(4X,F5.1),2X,
CCCCC$    F4.0,3X,F4.1,4X,A3,3X,A13,I6,I8,3I6)
CCCCC END IF
      GO TO 2

C-----------------------------------------------------------------------
  999 CONTINUE
C THE NUMBER OF DECODED HEADER AND/OR OBS. LEVELS IS NOT 1!! -- STOP 70
      PRINT 217
  217 FORMAT(/' THE NUMBER OF DECODED HEADER AND/OR OBS. LEVELS FOR',
     $ ' A REPORT IS NOT 1 -- STOP 70'/)
      CALL W3TAGE('PREPOBS_ACARSQC')
      CALL ERREXIT(70)
C-----------------------------------------------------------------------

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    CMDDFF      CONVERTS WIND U/V COMPONENTS TO DIR/SPD
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 1995-03-27
C
C ABSTRACT: CONVERTS GRID U AND V COMPONENTS OF VELOCITY (M/S) TO WIND
C   DIRECTION AND SPEED.  SEE ARGUMENT 'ISUNIT' FOR OUTPUT SPEED UNITS.
C
C PROGRAM HISTORY LOG:
C   UNKNOWN
C 1995-03-27  D. A. KEYSER -- ORIGINAL AUTHOR
C
C USAGE:    CALL CMDDFF(ISUNIT,U,V,DD,FF)
C   INPUT ARGUMENT LIST:
C     ISUNIT   - OUTPUT SPEED UNIT INDICATOR (=1 - KNOTS, =2 - M/S)
C     U        - U-COMPONENT OF WIND VELOCITY (M/S)
C     V        - V-COMPONENT OF WIND VELOCITY (M/S)
C
C   OUTPUT ARGUMENT LIST:
C     DD       - DIRECTION OF WIND (DEGREES)
C     FF       - SPEED OF WIND (SEE 'ISUNIT' FOR UNITS)
C
C REMARKS: CALLED BY SUBROUTINE IBUFR.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$

      SUBROUTINE CMDDFF(ISUNIT,U,V,DD,FF)

      REAL  FACTOR(2)

      DATA  FACTOR/0.5148,1.0/,CONV2R/0.017453293/

      IF(U.EQ.0.0)  THEN
         DD = 0.
         IF(V.GT.0.0)  DD = 180.
      ELSE
         IF(V.EQ.0.0)  THEN
            DD =  90.
            IF(U.GT.0.0)  DD = 270.
         ELSE
            DD = (ATAN2(U,V)/CONV2R) + 180.
            DD = AMOD(DD,360.)
         END IF
      END IF
      FF = SQRT(U**2 + V**2)/FACTOR(ISUNIT)

      RETURN

      END

      SUBROUTINE UFBQCD1(LUNIT,NEMO,QCD)

      CHARACTER*(*) NEMO
      CHARACTER*6  FXY,ADN30
      CHARACTER*1  TAB

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

      CALL STATUS(LUNIT,LUN,IL,IM)
      IF(IL.EQ.0) GOTO 900

      CALL NEMTAB(LUN,NEMO,IDN,TAB,IRET)
      IF(TAB.NE.'D') then
        QCD = 14                ! hardwire when missing
        return
      endif

      FXY = ADN30(IDN,6)
      IF(FXY(2:3).NE.'63') GOTO 902
      READ(FXY(4:6),'(F3.0)',ERR=903) QCD

      RETURN
900   CALL BORT('UFBQCD - FILE IS CLOSED                       ')
901   CALL BORT('UFBQCD - MISSING OR INVALID TABLE D QC CODE   ')
902   CALL BORT('UFBQCD - TABLE D QC CODE DESCRIPTOR NOT 363YYY')
903   CALL BORT('UFBQCD - ERROR READING YYY FROM QC CODE DESCRP')
      END

max_stars_repo_name: GEOS-ESM/GEOSadas

max_issues_repo_name: GEOS-ESM/GEOSadas

max_forks_repo_name: GEOS-ESM/GEOSadas