C$$$  MAIN PROGRAM DOCUMENTATION BLOCK
C
C MAIN PROGRAM: BUFR_QUIPC
C   PRGMMR: KEYSER           ORG: NP22        DATE: 2007-03-23
C
C ABSTRACT: APPLIES REAL-TIME INTERACTIVE QUALITY CONTROL AND DUPLICATE
C   FLAGS AND CORRECTIONS GENERATED BY NCEP/OPC (USING "CREWSS"
C   SOFTWARE) TO SURFACE MARINE SHIP, BUOY, C-MAN PLATFORM OR TIDE
C   GAUGE DATA (BUFR MESSAGE TYPE 001, SUBTYPES 001-005) AS IT IS BEING
C   DUMPED FROM THE /dcom BUFR DATABASE IN THE VARIOUS NCEP NETWORKS.
C   ALSO CHECKS FOR REPORTS IN THE GREAT LAKES SINCE THIS CAN AFFECT
C   THE CORRECTIONS.  THE DATA TIME WINDOW AND THE BUFR INPUT FILE
C   NAMES TO CHECK ARE READ FROM STANDARD INPUT.  ALL BUFR FILE
C   CONNECTIONS (EXCEPT STANDARD INPUT WHICH IS PRE-CONNECTED) ARE MADE
C   THROUGH THE FORTRAN OPEN STATEMENT.
C
C PROGRAM HISTORY LOG:
C 1997-02-01  J. WOOLLEN  -- ORIGINAL AUTHOR
C 1997-02-27  J. WOOLLEN  -- FIXED COPY TO PROCESS DATE MESSAGES
C       CORRECTLY
C 1998-07-13  J. WOOLLEN  -- CORRECTED AIR TEMPERATURE CONVERSION ERROR
C       IN SUBR. APPLY
C 1998-07-14  C. CARUSO   -- REMOVED CALLS TO W3LOG (OBSOLETE)
C 1998-07-15  C. CARUSO   -- CORRECTED SST CONVERSION ERROR IN SUBR.
C       APPLY
C 1998-11-12  C. CARUSO   -- FIXED HOW WIND CORRECTIONS ARE READ IN,
C       PREVIOUSLY, WIND DIR. WAS FIRST 3 COLUMNS AFTER 'QW' AND WIND
C       SPD WAS NEXT 2 COLUMNS, NOW WIND DIR IS FIRST 2 COLUMNS AFTER
C       'QW' (IT'S ACTUALLY WIND DIR./10) AND WIND SPD IS NEXT 3
C       COLUMNS,  DONE TO ENSURE THAT 3 DIGIT WINDS DON'T CAUSE AN
C       ERROR IN THIS CODE WHEN READING OCCURS
C 1998-11-30  C. CARUSO   -- CHANGING CODE TO READ, BUT NOT USE, 4
C       DIGIT YEAR IN QC FLAGS FILE;  WHEN NEW BUFRLIB GOES IN (THAT
C       USES 4 DIGIT YEAR THROUGHOUT CODE), WILL HAVE THIS CODE USE
C       FIRST 2 DIGITS OF YEAR AS WELL (CURRENTLY, BUFRLIB CAN ACCEPT 4
C       DIGIT YEAR, BUT IT CUTS IT DOWN TO 2 DIGIT YEAR FOR INTERNAL
C       USE)
C 1998-12-03  C. CARUSO   -- CHANGING CODE TO USE FULL 4 DIGIT YEAR;
C       THIS CODE WILL GO INTO PRODUCTION SIMULTANEOUSLY WITH NEW
C       BUFRLIB THAT IS F90 & Y2K-COMPLIANT AND USES 4 DIGIT YEAR
C       THROUGHOUT THE SCRIPT
C 1999-06-03  D. KEYSER   -- PURGED PRESS. Q.M. NOW ENCODED AS 14 (LIKE
C       ALL OTHERS) NOW THAT QMPR IS STORED IN 4 BITS; MODIFIED TO PORT
C       TO IBM SP AND RUN IN 4 OR 8 BYTE STORAGE
C 1999-12-03 CARUSO MAGEE -- ADD CODE TO FIX STATION ELEVATION FOR
C       SHIPS THAT WERE MOVED INTO OR OUT OF GREAT LAKES; ADD CODE TO
C       CHECK PLATFORM LOCATION BEFORE COPYING CORRECTED SLP INTO
C       STATION PRESSURE (DON'T DO THIS FOR PLATFORMS IN THE G. LAKES)
C 1999-12-07 CARUSO MAGEE -- ADD DOCBLOCKS & REMOVE FCN ONRTP (NOT
C       USED)
C 2001-09-04 CARUSO MAGEE -- CHANGING ARRAY SIZE FOR MXTB FROM 10000 TO
C       15000 SO A WHOLE DAY OF DRIFTING BUOY DATA MAY BE DUMPED IN A
C       SINGLE DUMPJB EXECUTION
C 2003-07-29 CARUSO MAGEE -- CHANGING ARRAY SIZE FOR MXTB FROM 15000 TO
C       25000 SO A WHOLE DAY OF DRIFTING BUOY DATA MAY BE DUMPED IN A
C       SINGLE DUMPJB EXECUTION
C 2003-09-08 D. KEYSER    -- CRISIS CHANGE TO CORRECT ERROR IN REPORT
C       TIME WRITTEN INTO MARINE DATA DUMP FILES BECAUSE REPORT TIMES
C       NEVER MATCHED TIMES IN FLAG FILE (WHICH WERE CORRECTLY
C       CALCULATED EVEN AFTER CCS CONVERSION)
C 2004-02-02  D. KEYSER   -- ADDED FLEXIBILITY IN READING AND CHECKING
C       INPUT FILE NAMES; REPLACED CALLS TO "BORT" WITH CALLS TO
C       "ERREXIT"; STREAMLINED CODE; IMPROVED DOCBLOCKS AND COMMENTS;
C       ADDED MORE DESCRIPTIVE STANDARD OUTPUT PRINT; FIXED A FEW MINOR
C       BUGS; ADDED STATUS FILE IN UNIT 60 THAT IS WRITTEN TO ONLY WHEN
C       THIS PROGRAM COMPLETES SUCCESSFULLY (TRANSF. TO DUMPJB SCRIPT);
C       CORRECTED ERROR IN CALCULATING DATE TOLERANCE WHEN .GT. 0.00
C       HOURS; NOW ATTEMPTS TO READ MOISTURE Q.M. FROM COLUMN 45 AND
C       WAVE HEIGHT Q.M. FROM COLUMN 54 OF QUIPS FLAG FILE ENTRIES
C       (THESE WERE BOTH SPARE, BLANKS, BEFORE) AND PROCESS THESE INTO
C       DUMP FILE UNDER MNEMONICS "QMDD" AND "QMWH", RESP. (NOTE:
C       NEITHER IS YET BEING WRITTEN INTO QUIPS FLAG FILE, AND "QMWH"
C       IS NOT YET PRESENT IN BUFR TABLE)
C 2004-05-17  D. KEYSER   -- NOW CHECKS FOR VALID "NUMBERS" IN THE
C       LAT, LON, REPORT TYPE, DATE AND CORRECTED VALUES (LAT, LON,
C       PMSL, AIR TEMP, WIND DIRECTION, WIND SPEED AND SST) FOR EACH
C       FLAG FILE ENTRY - IF ANY VALUES (EXCEPT THOSE IN THE CORRECTED
C       VALUE LOCATIONS) ARE NON-NUMERIC THE CODE WILL SKIP THE ENTRY,
C       IF ANY CORRECTED VALUES ARE NON-NUMERIC THE CODE WILL NOT
C       APPLY ANY CORRECTIONS - IN EITHER CASE THE CODE WILL SEND A
C       MESSAGE TO THE PRODUCTION JOBLOG FILE TO ALERT THAT THERE IS A
C       CORRUPT ENTRY IN THE QUIPS FLAG FILE, AND THEN CONTINUE
C       PROCESSING THE NEXT RECORD (ENTRY) IN THE FLAG FILE; IN THE
C       EVENT THE PROGRAM TERMINATES ABNORMALLY, A MESSAGE IS NOW
C       POSTED TO THE PRODUCTION JOBLOG FILE
C 2005-02-07  D. KEYSER   -- INCREASE THE SIZE FOR MXTB FROM 25000 TO
C       50000 SO 24-HOURS OF DRIFTING BUOY DATA MAY BE DUMPED IN A
C       SINGLE DUMPJB EXECUTION (DUE TO AN INCREASE IN THE NUMBER OF
C       DRIFTING BUOY REPORTS IN THE BUFR TANKS); INCREASE THE
C       TOLERANCE FOR LAT/LON CHECKS FROM 0.001 TO 0.01 DEGREES BECAUSE
C       THE UPSTREAM CREWSS PROCESSING SOMETIMES ROUNDS LAT/LON
C       DIFFERENTLY THAN WHAT IS STORED IN BUFR
C 2005-11-21  D. KEYSER   -- INCREASE THE SIZE FOR MXTB FROM 50000 TO
C       80000 TO ALLOW PRODUCTION JOBS THAT DUMP DRIFTING BUOY DATA
C       OVER A 36-HOUR TIME WINDOW TO CHECK ALL DATA HERE
C 2007-03-23  D. KEYSER   INTRODUCED ALLOCATABLE ARRAYS TO AVOID ARRAY
C     OVERFLOW PROBLEMS, DETERMINES SIZE OF ARRAYS BY CALLING UFBTAB
C     WITH NEGATIVE UNIT NUMBER TO SIMPLY COUNT SUBSETS
C
C USAGE:
C   INPUT FILES:
C     UNIT 05  - STANDARD INPUT - FIRST RECORD CONTAINS TIME-WINDOWING
C                SPECIFICATIONS (THE YYYYMMDDHH<.HH> DATE OF THE
C                EARLIEST TIME TO DUMP AND THE YYYYMMDDHH<.HH> DATE OF
C                THE LATEST TIME TO DUMP), SECOND THROUGH N'TH RECORDS
C                CONTAIN THE WORKING INPUT FILE NAMES FOR ALL DUMP
C                TYPES BEING COMBINED INTO A SINGLE DUMP FILE
C     UNIT 20  - QUIPS FLAG TEXT FILE (SEE REMARKS)
C     UNIT 21  - BUFR FILE(S) PRIOR TO QUALITY CONTROL AND/OR
C                CORRECTING
C
C   OUTPUT FILES:
C     UNIT 06  - STANDARD OUTPUT PRINT
C     UNIT 21  - BUFR FILE(S) AFTER QUALITY CONTROL AND/OR CORRECTING
C     UNIT 50  - WORKSPACE (SCRATCH) FILE(S)
C     UNIT 60  - STATUS FILE WHOSE PRESENCE INDICATES THIS PROGRAM
C                COMPLETED SUCCESSFULLY
C   WORK FILES:
C     UNIT 91  - SCRATCH FILE CONTAINING CONTENTS OF FLAG FILE ENTRY
C                FOR CASES OF A CORRUPT ENTRY WHERE MESSAGE IS POSTED
C                TO THE PRODUCTION JOBLOG FILE VIA POSTMSG
C
C   SUBPROGRAMS CALLED:
C     UNIQUE     - APPLY    PARCOR   IQMF     GLCHECK
C     SYSTEM     - SYSTEM
C     LIBRARY:
C       W3LIB    - W3TAGB   W3TAGE   ERREXIT  W3DIFDAT
C       BUFRLIB  - DATELEN  OPENBF   COPYMG   UFBTAB   OPENMB
C                  COPYBF   COPYSB   CLOSMG   CLOSBF   IREADMG
C                  IREADSB  UFBCPY   WRITSB   UFBINT   MESGBC
C                  STATUS   NEMTAB   NMSUB
C
C   EXIT STATES:
C     COND =   0 - SUCCESSFUL RUN
C            > 0 - ABNORMAL RUN
C
C REMARKS:
C     Contents of each "record" (line entry) in QUIPS flag text file
C        Column        Description
C        ------        -----------
C        01-08         Reported call sign or WMO id  (left justified,
C                      blank right fill)
C          09          Spare (blank)
C        10-14         Reported latitude (x 100 degrees, right
C                      justified, blank left fill - if "-" precedes
C                      latitude it is in Southern Hemisphere)
C          15          Spare (blank)
C        16-20         Reported longitude (x 100 degrees West, 0-36000)
C                      (right justified, blank left fill)
C          21          Spare (blank)
C        22-29         Report date in format YYYYMMDD
C          30          Spare (blank)
C        31-34         Report time in format HHMM (UTC)
C        35-36         Spares (blanks)
C        37-39         Report type (all BUFR message type 001)
C                         "522" - Ship with name (BUFR msg subtype 001)
C                         "523" - Ship without name (id set to "SHIP")
C                             "  (BUFR msg subtype 001)
C                         "531" - C-MAN platform (BUFR msg subtype 004)
C                         "532" - Tide gauge (BUFR msg subtype 005)
C                         "561" - Moored buoy (BUFR msg subtype 003)
C                         "562" - Drifting buoy (BUFR msg subtype 002)
C          40          Duplicate report indicator
C                         "L"   - Duplicate report
C                         blank - Not entered (non-duplicate report)
C          41          Quality marker on mean sea-level pressure (see *)
C          42          Quality marker on wind (see *)
C          43          Quality marker on air temperature (see *)
C          44          Quality marker on sea-surface temperature (see *)
C          45          Quality marker on moisture (here dewpoint
C                      temperature) (currently not utilized) (not used
C                      by tide gauge reports) (see *) 
C        46-53         Corrected call sign or WMO id
C                         blanks - not entered (no correction)
C          54          Quality marker on wave height (currently not
C                      utilized) (not used by tide gauge reports)
C                      (see *) 
C          55          Spare (blank)
C        56-132        Quips correction data in groups of 7 or 14
C                       characters (no spaces between groups)
C                         QLaaaaa -> aaaaa = Corrected latitude
C                                            (x 100 deg, N+,S-)
C                         QGooooo -> ooooo=  Corrected longitude
C                                            (x 100 deg West, 0-36000)
C                         OPxxxxxQPppppp
C                            -> xxxxx = Reported sea-level pressure
C                                       (x 10 mb)
C                            -> ppppp = Corrected sea-level pressure
C                                       (x 10 mb)
C                         OTxxxxxQTttttt
C                            -> xxxxx = Reported air temperature   
C                                       (x 10 deg. C)
C                            -> ttttt = Corrected air temperature
C                                       (x 10 deg. C)
C                         OWxxyyyQWddsss
C                            -> xx    = Reported wind direction
C                                       (/ 10 deg.)
C                            -> yyy   = Reported wind speed
C                                       (knots)
C                            -> dd    = Corrected wind direction
C                                       (/ 10 deg.)
C                            -> sss   = Corrected wind speed
C                                       (knots)
C                         OSxxxxxQSttttt
C                            -> xxxxx = Reported sea-surface temp   
C                                       (x 10 deg. C)
C                            -> ttttt = Corrected sea-surface temp
C                                       (x 10 deg. C)
C
C                         blanks - not entered (no corrections)
C
C        * - "H"   - Hold (keep) flag
C            "P"   - Purge flag
C            blank - Quality marker not entered
C
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM SP
C
C$$$
      PROGRAM BUFR_QUIPSC

      PARAMETER (MEDT=1000)         ! Allows up to 1000 time-relevant
                                    !  entries in QUIPS flag file
      PARAMETER (MXTS=8)
 
      REAL(8),ALLOCATABLE :: TAB_8(:,:)
      LOGICAL,ALLOCATABLE :: EDIT(:)

      CHARACTER*132 CARD,CARDS(MEDT)
      CHARACTER*80  BFRFIL,TSTR,OSTR_orig,QSTR_orig
      CHARACTER*29  CTYPE(5),CTYPE1
      CHARACTER*8   SUBSET,STNID

      DIMENSION     ELAT(MEDT),ELON(MEDT),ETYP(MEDT)
      DIMENSION     LYEAR(MEDT),LMNTH(MEDT),LDAYS(MEDT),LHOUR(MEDT),
     .              LMINU(MEDT)
      DIMENSION     JDAT(8),IDAT(8),RINC(5)

      LOGICAL       DUPE,SKIPIT(MEDT)

      REAL(8)       ADATE,BDATE,EDATE,UFBTAB_8,RSTNID_8
      REAL(8)       OBS_8,QMS_8

      INTEGER(4)    JRET,KRET

      EQUIVALENCE   (STNID,RSTNID_8)
 
      COMMON /ORIG/   OBS_8(8),QMS_8(6)
      COMMON /COUNTS/ ICOR(9),IPQM(0:14),IWQM(0:14),ITQM(0:14),
     .                ISQM(0:14),IMQM(0:14),IHQM(0:14)

      DATA TSTR   /'RPID CLON CLAT YEAR MNTH DAYS HOUR MINU '/

      DATA OSTR_orig /'PMSL PRES WDIR WSPD TMDB SST1 SST2 SELV'/
      DATA QSTR_orig /'QMPR QMWN QMAT QMST QMDD QMWH'/

      DATA LUEDT  /20/
      DATA LUBFI  /21/
      DATA LUBFJ  /50/
      DATA DEXY   /.01/
      DATA DTIM   /.001/

      DATA CTYPE /'SURFACE MARINE SHIP          ', ! 001.001
     .            'SURFACE MARINE DRIFTING BUOY ', ! 001.002
     .            'SURFACE MARINE FIXED BUOY    ', ! 001.003
     .            'SURFACE MARINE C-MAN PLATFORM', ! 001.004
     .            'SURFACE TIDE GAUGE STATION   '/ ! 001.005
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      CALL W3TAGB('BUFR_QUIPC',2007,0082,0062,'NP22')

      print *
      print * ,'---> Welcome to BUFR_QUIPC - Version 03-23-2007'
      print *
 
C     HARDWIRED PARAMETERS:
C     DEXY  = 0.01  TOLERANCE FOR LAT/LON CHECKS IN DEGREES
C     DTIM  = 0.001  TOLERANCE FOR TIME CHECK IN HOURS
C  ------------------------------------------------------------------

      NREP = 0
      MREP = 0
      IDUP = 0
      ICOR = 0
      IPQM = 0
      IWQM = 0
      ITQM = 0
      ISQM = 0
      IMQM = 0
      IHQM = 0

      IFIL_CHK  = 0
      IFIL_READ = 0

      CALL DATELEN(10)

ccccc CALL OPENBF(0,'QUIET',2) ! Uncomment for extra print from bufrlib

C  READ IN DATA DATE RANGE (TIME WINDOW)
C  -------------------------------------
 
      READ(5,*,END=900,ERR=900) ADATE,BDATE

      PRINT 200, DEXY,DEXY,DTIM,ADATE,BDATE
200   FORMAT(/3X,'ALL REPORTS IN DUMP FILE(S) ARE READ AND COMPARED ',
     . 'TO REPORT ENTRIES IN QUIPS FLAG FILE.'/3X,'IF STATION ID ',
     . 'MATCHES AN ENTRY IN SDMEDIT FLAG FILE, REPORT WILL BE ',
     . 'CONSIDERED FOR Q.C. EDITING AND'/3X,'CORRECTING IF ALL OF THE ',
     . 'FOLLOWING CONDITIONS ARE MET:'/7X,'1) REPORT LAT  IS WITHIN',
     . F6.3,' DEGREES OF LAT IN FLAG FILE ENTRY'/7X,'2) REPORT LON  IS',
     . ' WITHIN',F6.3,' DEGREES OF LON IN FLAG FILE ENTRY'/7X,'3) ',
     . 'REPORT DATE IS WITHIN',F6.3,' HOURS OF DATE IN FLAG FILE ENTRY'/
     . //'TIME WINDOW FOR CHECKING REPORTS AGAINST QUIPS FLAG FILE ',
     . 'ENTRIES IS: ',F13.2,'  to  ',F13.2,'  UTC')

      LOOP1: DO IERR_COUNT=0,5

C  READ RECORDS FROM QUIPS FLAG FILE, ONLY STORE THOSE W/I TIME WINDOW
C  -------------------------------------------------------------------
 
         REWIND LUEDT
         NREC = 0
         NEDT = 0
         LOOP1n1: DO
            READ(LUEDT,'(A132)',END=4,ERR=3) CARD
            NREC = NREC+1
            IF(CARD(1:6).EQ.'QCSHIP') CYCLE LOOP1n1 !Skip poss. hdr rec.
            READ(CARD(22:34),'(F8.0,1X,2F2.0)',ERR=801) EDATE,EHR,EMI
            EDATE = EDATE*100. + EHR + EMI/60. ! Construct date-time
            IF(EDATE.GE.ADATE .AND. EDATE.LE.BDATE) THEN
               IF(NEDT+1.LE.MEDT) THEN
                  NEDT = NEDT+1
                  CARDS(NEDT) = CARD ! Store record if in time window
               ELSE
                  PRINT'(/"#####THE NUMBER OF RECORDS IN THE QUIPS ",
     .             "FLAG FILE IN UNIT",I3," THAT ARE WITHIN THE TIME ",
     .             "WINDOW EXCEEDS THE"/5X,"LIMIT OF",I6," - ALL ",
     .             "REMAINING RECORDS ARE IGNORED"/)', LUEDT,MEDT
                  EXIT LOOP1
               ENDIF
            ENDIF

            CYCLE LOOP1n1

  801       CONTINUE

C  COME HERE IF THE "YYYYMMDD HHMM" DATE IN THE FLAG FILE ENTRY IS
C   FOUND TO NOT BE VALID -- THIS ENTRY WILL BE SKIPPED OVER WHEN
C   EDITING IS PERFORMED
C  ---------------------------------------------------------------

            PRINT'(/"#####QUIPS FILE CONTAINS CORRUPTED RECORD '//
     .       '(OVERALL NUMBER",I4,"): ",A/5X,"- IGNORE AND SKIP TO '//
     .       'NEXT RECORD"/)', NREC,CARD
            REWIND(91)
            WRITE(91,'(A)') CARD
            REWIND(91)
            CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg'//
     .       ' "$jlogfile" "***WARNING: CORRUPT RECORD IN SDMEDIT '//
     .       'FILE: `cat ./fort.91`"')

         ENDDO LOOP1n1

3        CONTINUE

C  Error reading a card, start over (unless hit limit of 5 re-tries)
C  -----------------------------------------------------------------

         IF(IERR_COUNT.EQ.5) THEN
            PRINT'(/"#####ERRORS READING THE QUIPS FLAG FILE IN UNIT",
     .       I3," - QUIPS Q.C. FLAGS NOT APPLIED TO DUMP FILE(S)"/)',
     .       LUEDT
            GOTO 700
         ENDIF
         PRINT'(/"ERRORS READING THE QUIPS FLAG FILE IN UNIT",I3,
     .    " - REWIND FILE AND TRY READING AGAIN"/)', LUEDT
      ENDDO LOOP1

4     CONTINUE

      IF(NREC.EQ.0) THEN

C  Non-existent or empty flag file - all done
C  ------------------------------------------

         PRINT'(/"#####THE QUIPS FLAG FILE IN UNIT",I3," EITHER ",
     .    "DOESN''T EXIST OR IS EMPTY - QUIPS Q.C. FLAGS NOT APPLIED ",
     .    "TO"/5X,"DUMP FILE(S)"/)', LUEDT
         GOTO 700
      ELSEIF(NEDT.EQ.0) THEN

C  Flag file doesn't contain any time-relevant rec. entries - all done
C  -------------------------------------------------------------------

         PRINT'(/"#####THE QUIPS FLAG FILE IN UNIT",I3," DOESN''T ",
     .    "CONTAIN ANY TIME-RELEVANT RECORD ENTRIES - QUIPS Q.C. FLAGS"/
     .    5X,"NOT APPLIED TO DUMP FILE(S)"/)', LUEDT
         CALL SYSTEM('[ -n "$NET" ]',JRET)
         IF(JRET.EQ.0)  THEN
            CALL SYSTEM('[ $NET = gfs -o $NET = gdas ]',KRET)
            IF(KRET.EQ.0)  THEN
               CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg'//
     .          ' "$jlogfile" "***WARNING: QUIPS FLAG FILE DOESN''T '//
     .          'CONTAIN ANY TIME-RELEVANT RECORD ENTRIES"')
            ENDIF
         ENDIF
         GOTO 700
      ELSE
         PRINT'(/"READ IN",I5," RECORDS FROM QUIPS FLAG FILE IN UNIT",
     .    I3,", A TOTAL OF ",I5," ARE WITHIN REQUESTED TIME WINDOW "/
     .    "AND READ INTO MEMORY"/)', NREC,LUEDT,NEDT
      ENDIF

C  ALL TIME-RELEVANT RECORDS FROM QUIPS FLAG FILE READ INTO MEMORY -
C  CONVERT IDS, LOCATIONS, TYPES AND TIMES INTO ARRAYS FOR LATER
C  CROSS CHECKING OF REPORTS IN BUFR DUMP FILE(S)
C  -----------------------------------------------------------------
 
      ELAT  = 0
      ELON  = 0
      ETYP  = 0
      LYEAR = 0
      LMNTH = 0
      LDAYS = 0
      LHOUR = 0
      LMINU = 0

      DO M=1,NEDT
         SKIPIT(M) = .FALSE.
         READ(CARDS(M)(10:14),'(F5.2)',ERR=800) ELAT(M)
         READ(CARDS(M)(16:20),'(F5.2)',ERR=800) ELON(M)
         ELON(M)  = MOD(720.-ELON(M),360.)
         READ(CARDS(M)(37:40),'(F3.0)',ERR=800) ETYP(M)
         READ(CARDS(M)(22:25),'(I4)',ERR=800)   LYEAR(M)
         READ(CARDS(M)(26:27),'(I2)',ERR=800)   LMNTH(M)
         READ(CARDS(M)(28:29),'(I2)',ERR=800)   LDAYS(M)
         READ(CARDS(M)(31:32),'(I2)',ERR=800)   LHOUR(M)
         READ(CARDS(M)(33:34),'(I2)',ERR=800)   LMINU(M)
         CYCLE

  800    CONTINUE

C  COME HERE IF ANY OF THE FOLLOWING VALUES IN THE FLAG FILE ENTRY ARE
C   FOUND TO NOT BE VALID: LATITUDE, LONGITUDE, REPORT TYPE, YEAR,
C   MONTH, DAY, HOUR, MINUTE -- THIS ENTRY WILL BE SKIPPED OVER WHEN
C   EDITING IS PERFORMED
C  -------------------------------------------------------------------

         LYEAR(M) = 0  ! This is added in case year was ok, will
                       !  prevent date manipulations below
         PRINT'(/"#####QUIPS FILE CONTAINS CORRUPTED RECORD (NUMBER",'//
     .    'I4,"): ",A/5X,"- IGNORE AND SKIP TO NEXT RECORD"/)',
     .    M,CARDS(M)
         REWIND(91)
         WRITE(91,'(A)') CARDS(M)
         REWIND(91)
         CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg'//
     .    ' "$jlogfile" "***WARNING: CORRUPT RECORD IN QUIPS FILE: '//
     .    '`cat ./fort.91`"')
         SKIPIT(M) = .TRUE.

      ENDDO
 
C  LOOP OVER LIST OF BUFR DUMP FILES TO CONSIDER FOR Q.C MARKING & CORR.
C  ---------------------------------------------------------------------

      LOOP2: DO
         READ(5,'(A80)',END=100,ERR=901) BFRFIL  ! Read in filename
         IFIL_READ = IFIL_READ + 1
         LOOP2n1: DO I=4,10 ! Find BUFR msg type/subtype in file name
            IF(BFRFIL(I:I).EQ.'.') THEN
               READ(BFRFIL(I-3:I+3),'(I3,1X,I3)',ERR=902) ITYP,JTYP
               EXIT LOOP2n1
            ENDIF
         ENDDO LOOP2n1
         CTYPE1 = ' '
         IF(ITYP.EQ.001 .AND. (JTYP.GT.000 .AND. JTYP.LT.006))
     .    CTYPE1 = CTYPE(JTYP)
         PRINT'(//"===> NEXT BUFR FILE TO CHECK HAS TYPE=",I4.3,
     .    ", SUBTYPE=",I4.3,5X,A)', ITYP,JTYP,CTYPE1
         IF(ITYP.NE.001) THEN
            PRINT'(16X,"- SKIP THIS FILE SINCE IT IS NOT A SURFACE ",
     .       "MARINE TYPE (BUFR MESSAGE TYPE .NE. 001)"/)'
            CYCLE LOOP2
         ELSEIF(JTYP.GT.005) THEN
            PRINT'(16X,"- SKIP THIS FILE SINCE IT IS NOT ONE OF THE ",
     .       "SURFACE MARINE TYPES CONSIDERED (BUFR MESSAGE"/18X,
     .       " SUBTYPE .GT. 005)"/)'
            CYCLE LOOP2
         ENDIF
   
         IFIL_CHK = IFIL_CHK + 1

         OPEN(LUBFI,FILE=BFRFIL,FORM='UNFORMATTED')

         CALL MESGBC(LUBFI,MSGT,ICOMP)
         IF(ICOMP.EQ.1) THEN
            PRINT'(5X,"INPUT AND OUTPUT BUFR FILE MESSAGES   ",
     .       "C O M P R E S S E D")'
            PRINT *, '#####BUFR_QUIPC (UFBTAB) CANNOT PROCESS ',
     .               'COMPRESSED BUFR MESSAGES -- FATAL ERROR'
            CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg'//
     .       ' "$jlogfile" "**ERROR IN PROGRAM BUFR_QUIPC - '//
     .       'ABNORMAL EXIT"')
            CALL W3TAGE('BUFR_QUIPC')
            CALL ERREXIT(99)
         ELSE  IF(ICOMP.EQ.0) THEN
            PRINT'(5X,"INPUT AND OUTPUT BUFR FILE MESSAGES   ",
     .       "U N C O M P R E S S E D")'
         ELSE IF(ICOMP.EQ.-1) THEN
            PRINT'(5X,"ERROR READING INPUT BUFR FILE - MESSAGE ",
     .       "COMPRESSION UNKNOWN")'
         ELSE  IF(ICOMP.EQ.-3) THEN
            PRINT'(5X,"INPUT BUFR FILE DOES NOT EXIST")'
         ELSE  IF(ICOMP.EQ.-2) THEN
            PRINT'(5X,"INPUT BUFR FILE HAS NO DATA MESSAGES")'
            CYCLE LOOP2
         ENDIF

         PRINT'(16X,"- BEGIN CHECKING REPORTS IN THIS FILE"/)'

C  COUNT THE NUMBER OF SUBSETS IN THE FILE TO ALLOCATE SPACE
C  ---------------------------------------------------------

         OPEN(LUBFI,FILE=BFRFIL,FORM='UNFORMATTED')
         CALL UFBTAB(-LUBFI,UFBTAB_8,1,1,MXTB,' ')

         ALLOCATE(TAB_8(MXTS,MXTB),STAT=I);IF(I.NE.0) GOTO 904
         ALLOCATE(EDIT(MXTB),STAT=I);      IF(I.NE.0) GOTO 904

C  MAKE A TABLE OF STN ID, LAT, LON AND TIME (TO MINUTE) FROM THE BUFR
C  REPORT DATA
C  -------------------------------------------------------------------
 
         OPEN(LUBFI,FILE=BFRFIL,FORM='UNFORMATTED')
         CALL UFBTAB(LUBFI,TAB_8,MXTS,MXTB,NTAB,TSTR)
 
C  LOOP THROUGH THE SAVED (TIME-RELEVANT) QUIPS FLAG FILE ENTRIES,
C  COMPARING EACH LAT, LON & TIME TO THOSE IN THE BUFR REPORT TABLE -
C  MARK ALL MATCHES
C  ------------------------------------------------------------------
 
         EDIT = .FALSE.
         DO M=1,NEDT     ! Loop thru the saved quips flag file entries
            JDAT    = 0
            IF(LYEAR(M).GT.0) THEN
               JDAT(1) = LYEAR(M)   ! Flag file entry year
               JDAT(2) = LMNTH(M)   ! Flag file entry month
               JDAT(3) = LDAYS(M)   ! Flag file entry day
               JDAT(5) = LHOUR(M)   ! Flag file entry hour
               JDAT(6) = LMINU(M)   ! Flag file entry minute
            ENDIF
            DO N=1,NTAB  ! Loop thru the BUFR report table values
               TAB2    = TAB_8(2,N) ! Report longitude
               TAB2    = MOD(360.+TAB2,360.)
               TAB3    = TAB_8(3,N) ! Report latitude
               IDAT    = 0
               IF(LYEAR(M).GT.0) THEN
                  IDAT(1) = TAB_8(4,N) ! Report year
                  IDAT(2) = TAB_8(5,N) ! Report month
                  IDAT(3) = TAB_8(6,N) ! Report day
                  IDAT(5) = TAB_8(7,N) ! Report hour
                  IDAT(6) = TAB_8(8,N) ! Report minute
                  IT = 2
                  CALL W3DIFDAT(JDAT,IDAT,IT,RINC)
                  RSTNID_8 = TAB_8(1,N)
                  EDIT(N) = (STNID.EQ.CARDS(M)(1:8)          .AND.
     .                      ABS(TAB2-ELON(M)).LE.DEXY        .AND.
     .                      ABS(TAB3-ELAT(M)).LE.DEXY        .AND.
     .                      ABS(RINC(2)).LE.DTIM)            .OR.
     .                      EDIT(N) !If true, there is a match - mark it
               ENDIF
            ENDDO
         ENDDO
 
C  READ AND COPY THE ORIGINAL FILE, APPLYING Q.C. MARKS AND/OR
C  CORRECTIONS TO MARKED REPORTS
C  -----------------------------------------------------------
 
         OPEN(LUBFI,FILE=  BFRFIL,FORM='UNFORMATTED')
         OPEN(LUBFJ,FILE='.QPTMP',FORM='UNFORMATTED')
         CALL OPENBF(LUBFI,'IN ',LUBFI)
         CALL OPENBF(LUBFJ,'OUT',LUBFI)
         ISUB = 0
 
         DO WHILE(IREADMG(LUBFI,SUBSET,IDATE).EQ.0)
            NSUBS = NMSUB(LUBFI)
            IF(NSUBS.GT.0) THEN
               CALL OPENMB(LUBFJ,SUBSET,IDATE)
               DO N=ISUB+1,ISUB+NSUBS ! Loop thru all subsets in message
                  IF(EDIT(N)) THEN
                     DUPE = .FALSE.   ! Report marked, must unpack it
                     IF(IREADSB(LUBFI).NE.0) GOTO 903
                     CALL UFBINT(LUBFI,OBS_8,8,1,IRET,OSTR_orig)
                     CALL UFBINT(LUBFI,QMS_8,6,1,IRET,QSTR_orig)
                     CALL UFBCPY(LUBFI,LUBFJ) ! Copy unpacked subset in
                                              ! preparation for updating
                     TAB2    = TAB_8(2,N) ! Report longitude
                     TAB2    = MOD(360.+TAB2,360.)
                     TAB3    = TAB_8(3,N) ! Report latitude
                     IDAT    = 0
                     IDAT(1) = TAB_8(4,N) ! Report year
                     IDAT(2) = TAB_8(5,N) ! Report month
                     IDAT(3) = TAB_8(6,N) ! Report day
                     IDAT(5) = TAB_8(7,N) ! Report hour
                     IDAT(6) = TAB_8(8,N) ! Report minute
                     DO M=1,NEDT ! Loop thru saved quips file entries

C  Do not edit any potential matches with a corrupted flag file entry
C  ------------------------------------------------------------------
                        IF(SKIPIT(M))  CYCLE
                        JDAT    = 0
                        IF(LYEAR(M).GT.0) THEN
                           JDAT(1) = LYEAR(M)   ! Flag file entry year
                           JDAT(2) = LMNTH(M)   ! Flag file entry month
                           JDAT(3) = LDAYS(M)   ! Flag file entry day
                           JDAT(5) = LHOUR(M)   ! Flag file entry hour
                           JDAT(6) = LMINU(M)   ! Flag file entry minute
                           IT = 2
                        CALL W3DIFDAT(JDAT,IDAT,IT,RINC)
                        ENDIF
                        ! If a match is found, apply q.c. and/or corrs.
                        RSTNID_8 = TAB_8(1,N)
                        IF(STNID.EQ.CARDS(M)(1:8)         .AND.
     .                     ABS(RINC(2)).LE.DTIM           .AND.
     .                     ABS(TAB2-ELON(M)).LE.DEXY      .AND.
     .                     ABS(TAB3-ELAT(M)).LE.DEXY) THEN
        ! Found the match, check for dup then apply q.c. or corrections
                           DUPE = CARDS(M)(40:40).EQ.'L' .OR. DUPE
                           CALL APPLY(LUBFI,LUBFJ,CARDS(M),M)
                        ENDIF
                     ENDDO
                     IF(.NOT.DUPE) THEN
                        CALL WRITSB(LUBFJ)
                        MREP = MREP + 1
                     ELSE
                        print'("    ... report is a duplicate, toss")'
                        IDUP = IDUP + 1
                     ENDIF
                  ELSE
                     CALL COPYSB(LUBFI,LUBFJ,IRET) ! Rpt unmarked, just
                                                   ! copy packed subset
                     MREP = MREP + 1
                  ENDIF
               ENDDO
            ELSE
               CALL CLOSMG(LUBFJ)      ! No subsets in msg, close prev.
               CALL COPYMG(LUBFI,LUBFJ)! output msg & just copy this one
            ENDIF
            ISUB = ISUB + NSUBS
            NREP = NREP + NSUBS
         ENDDO
 
         CALL CLOSBF(LUBFI)
         CALL CLOSBF(LUBFJ)
         OPEN(LUBFI,FILE=  BFRFIL,FORM='UNFORMATTED')
         OPEN(LUBFJ,FILE='.QPTMP',FORM='UNFORMATTED')
         CALL COPYBF(LUBFJ,LUBFI) ! Copy entire updated BUFR file back
                                  ! to original input unit number

         DEALLOCATE(TAB_8,STAT=I);  IF(I.NE.0) GOTO 905
         DEALLOCATE(EDIT,STAT=I);   IF(I.NE.0) GOTO 905
      ENDDO LOOP2
      CALL SYSTEM('[ -f ./fort.91 ] && rm ./fort.91')

C  EXITS
C  -----
 
100   CONTINUE
      IF(IFIL_READ.EQ.0) THEN
         PRINT'(/"#####THERE ARE NO DUMP FILES IN UNIT 05, ALL DUMPS ",
     .    "IN THIS GROUP ARE EMPTY"/)'
         GOTO 700
      ENDIF
      IF(IFIL_CHK.EQ.0) GOTO 700

      PRINT 101, NREP,IDUP,IPQM(0),IPQM(4),IPQM(14),IWQM(0),
     . IWQM(4),IWQM(14),ITQM(0),ITQM(4),ITQM(14),ISQM(0),ISQM(4),
     . ISQM(14),IMQM(0),IMQM(14),IHQM(0),IHQM(14),ICOR(6),ICOR(1),
     . ICOR(2),ICOR(3),ICOR(8),ICOR(4),ICOR(5),ICOR(7),ICOR(9),MREP
101   FORMAT(/101('=')/'SUMMARY:'/3X,'TOTAL NUMBER OF REPORTS READ ',
     . 'FROM ALL DUMPS CHECKED IN THIS GROUP ',27('.'),I5/3X,'Number ',
     . 'of reports skipped due to matching a quips flag file duplicate',
     . ' report entry ..',I5/3X,'Number of reports with a q.m. change ',
     . 'due to matching a quips flag file q.m. change entry:'/
     . /18X,'Pressure changed to  0 (keep) ...',I5
     . /18X,'Pressure changed to  4 (corr) ...',I5
     . /18X,'Pressure changed to 14 (purge) ..',I5/18X,41('-')
     . /18X,'Wind     changed to  0 (keep) ...',I5
     . /18X,'Wind     changed to  4 (corr) ...',I5
     . /18X,'Wind     changed to 14 (purge) ..',I5/18X,41('-')
     . /18X,'Air temp changed to  0 (keep) ...',I5
     . /18X,'Air temp changed to  4 (corr) ...',I5
     . /18X,'Air temp changed to 14 (purge) ..',I5/18X,41('-')
     . /18X,'SSTemp   changed to  0 (keep) ...',I5
     . /18X,'SSTemp   changed to  4 (corr) ...',I5
     . /18X,'SSTemp   changed to 14 (purge) ..',I5/18X,41('-')
     . /18X,'Moisture changed to  0 (keep) ...',I5
     . /18X,'Moisture changed to 14 (purge) ..',I5/18X,41('-')
     . /18X,'Wave hgt changed to  0 (keep) ...',I5
     . /18X,'Wave hgt changed to 14 (purge) ..',I5/18X,41('-')/
     . /3X,'Number of reports with a data correction due to matching a',
     . ' quips flag file data correction entry:'/
     . /18X,'Station id ......................',I5
     . /18X,'Latitude ........................',I5
     . /18X,'Longitude .......................',I5
     . /18X,'Mean sea-lvl pressure ...........',I5
     . /18X,'Station pressure ................',I5
     . /18X,'Air temperature .................',I5
     . /18X,'Wind direction/speed ............',I5
     . /18X,'Sea-sfc temperature .............',I5
     . /18X,'Station elevation ...............',I5/
     . /3X,'TOTAL NUMBER OF REPORTS WRITTEN BACK TO ALL DUMPS CHECKED ',
     . 'IN THIS GROUP ',21('.'),I5/101('=')/)

700   CONTINUE
      write(60,'("ALL DONE")')
      CALL W3TAGE('BUFR_QUIPC')
      STOP

900   CONTINUE
      PRINT *, '#####E-O-F OR ERROR READING TIME WINDOW FROM STANDARD ',
     . 'INPUT - STOP 99'
      CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg "$jlogfile" '//
     . '"**ERROR IN PROGRAM BUFR_QUIPC - ABNORMAL EXIT"')
      CALL W3TAGE('BUFR_QUIPC')
      CALL ERREXIT(99)
901   CONTINUE
      PRINT *, '#####ERROR READING WORKING INPUT DUMP FILE NAME FROM ',
     . 'STANDARD INPUT - STOP 99'
      CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg "$jlogfile" '//
     . '"**ERROR IN PROGRAM BUFR_QUIPC - ABNORMAL EXIT"')
      CALL W3TAGE('BUFR_QUIPC')
      CALL ERREXIT(99)
902   CONTINUE
      PRINT *, '#####ERROR READING BUFR MESSAGE TYPE/SUBTYPE ',
     . '(INTERNAL) FROM INPUT DUMP FILE NAME - STOP 99'
      CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg "$jlogfile" '//
     . '"**ERROR IN PROGRAM BUFR_QUIPC - ABNORMAL EXIT"')
      CALL W3TAGE('BUFR_QUIPC')
      CALL ERREXIT(99)
903   CONTINUE
      PRINT *, '#####POSITION ERROR READING A SUBSET FROM A BUFR ',
     . 'MESSAGE - STOP 99'
      CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg "$jlogfile" '//
     . '"**ERROR IN PROGRAM BUFR_QUIPC - ABNORMAL EXIT"')
      CALL W3TAGE('BUFR_QUIPC')
      CALL ERREXIT(99)
904   CONTINUE
      PRINT *, '#####UNABLE TO ALLOCATE ARRAYS - STOP 99'
      CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg "$jlogfile" '//
     . '"**UNABLE TO ALLOCATE ARRAYS - ABNORMAL EXIT"')
      CALL W3TAGE('BUFR_QUIPC')
      CALL ERREXIT(99)
905   CONTINUE
      PRINT *, '#####UNABLE TO DEALLOCATE ARRAYS - STOP 99'
      CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg "$jlogfile" '//
     . '"**UNABLE TO DEALLOCATE ARRAYS - ABNORMAL EXIT"')
      CALL W3TAGE('BUFR_QUIPC')
      CALL ERREXIT(99)

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    APPLY
C   PRGMMR: KEYSER           ORG: NP22       DATE: 2004-05-17
C
C ABSTRACT: ENCODES QUIPS Q.C. FLAGS (KEEP OR PURGE) AND DATA
C   CORRECTIONS INTO SURFACE MARINE BUFR REPORTS.  THE FOLLOWING DATA
C   TYPES CAN ENCODE Q.C. FLAGS (WHICH REPLACE MISSING VALUES):
C   PRESSURE (SEA-LEVEL AND STATION), WIND, AIR TEMPERATURE, SEA-
C   SURFACE TEMPERATURE, MOISTURE (DEWPOINT TEMPERATURE) AND WAVE
C   HEIGHT .  THE FOLLOWING DATA TYPES CAN ENCODE CORRECTED VALUES
C   (WHICH REPLACE ORGINAL REPORTED VALUES): STATION ID, LATITUDE,
C   LONGITUDE, SEA-LEVEL PRESSURE, AIR TEMPERATURE, WIND DIRECTION/
C   SPEED AND SEA-SURFACE TEMPERATURE.  FOR THE LATTER FOUR TYPES, A
C   CORRECTED VALUE ALSO ENCODES AN UPDATED Q.C. FLAG, HARDWIRED TO
C   FOUR (BUT ONLY IF THE FLAG IS MISSING, I.E., HAS NOT ALREADY BEEN
C   ENCODED AS KEEP OR PURGE BY THIS SUBROUTINE).  FINALLY, THIS
C   SUBROUTINE CHECKS ALL REPORTS TO SEE IF THEY ARE LOCATED IN THE
C   GREAT LAKES.  ALL SHIPS WITH A CORRECTED LAT OR LON ENCODE AN
C   UPDATED ELEVATION INTO THE BUFR REPORT SINCE THE REPORT MAY HAVE
C   MOVED INTO OR MOVED OUT OF THE GREAT LAKES (UNLESS THE ELEVATION
C   HAS NOT CHANGED FROM THE ORIGINAL VALUE).  ALL REPORTS (EXCEPT TIDE
C   GAUGE ) WITH A CORRECTED SEA-LEVEL PRESSURE ENCODE THIS SAME
C   CORRECTED VALUE INTO STATION PRESSURE (PROVIDED THE STATION
C   PRESSURE WAS PRESENT ORIGINALLY), UNLESS THE REPORTS IS IN THE
C   GREAT LAKES.
C
C PROGRAM HISTORY LOG:
C 1997-02-01  J. WOOLLEN   -- ORIGINAL AUTHOR
C 1999-12-07  CARUSO MAGEE -- ADDED DOCBLOCK
C 2004-02-02  D. KEYSER    -- STREAMLINED CODE; IMPROVED DOCBLOCK AND
C       COMMENTS; ADDED MORE DESCRIPTIVE STANDARD OUTPUT PRINT; FIXED A
C       FEW MINOR BUGS
C 2004-05-17  D. KEYSER    -- NOW CHECKS FOR VALID "NUMBERS" IN THE
C       LAT AND LON FOR EACH FLAG FILE ENTRY AND IF EITHER ARE NON-
C       NUMERIC SETS THEM TO MISSING AND SENDS A MESSAGE TO THE
C       PRODUCTION JOBLOG FILE TO ALERT THAT THERE IS A CORRUPT ENTRY
C       IN THE QUIPS FLAG FILE; ADDED NEW INPUT ARGUMENT "M" (RECORD
C       NUMBER FOR PARTICULAR ENTRY IN QUIPS FLAG FILE BEING PROCESSED
C       IN THIS CALL) (USED IN PRINT MESSAGE IF THIS ENTRY IS CORRUPT)
C
C USAGE:    CALL APPLY (LUBFI, LUBFJ, CARD, M)
C   INPUT ARGUMENT LIST:
C     LUBFI    - INTEGER, UNIT NUMBER OF INPUT  BUFR FILE
C     LUBFJ    - INTEGER, UNIT NUMBER OF OUTPUT BUFR FILE
C     CARD     - CHARACTER*132, STRING CONTAINING ONE ENTIRE LINE
C                (RECORD) AS READ IN FROM THE QUIPS FLAG FILE
C     M        - INTEGER, INDEX IN MEMORY POINTING TO THE RECORD NUMBER
C
C   INPUT FILES:
C     UNIT LUBFI - BUFR FILE(S) PRIOR TO QUALITY CONTROL AND/OR
C                  CORRECTING
C
C   OUTPUT FILES:
C     UNIT 06  - STANDARD OUTPUT PRINT
C     UNIT LUBFJ - BUFR FILE AFTER QUALITY CONTROL AND/OR CORRECTING
C                COMPLETED SUCCESSFULLY
C   WORK FILES:
C     UNIT 91  - SCRATCH FILE CONTAINING CONTENTS OF FLAG FILE ENTRY
C                FOR CASES OF A CORRUPT ENTRY WHERE MESSAGE IS POSTED
C                TO THE PRODUCTION JOBLOG FILE VIA POSTMSG
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM
C
C$$$
      SUBROUTINE APPLY(LUBFI,LUBFJ,CARD,M)
 
      CHARACTER*132 CARD
      CHARACTER*8   CNID

      DIMENSION     RDATA(7)

      LOGICAL       LOCATION_COR, PMSL_COR

      REAL(8)       UFBINT_8,OBS_8,QMS_8,RNID_8
 
      EQUIVALENCE   (RNID_8,CNID)

      COMMON /ORIG/   OBS_8(8),QMS_8(6)
      COMMON /COUNTS/ ICOR(9),IPQM(0:14),IWQM(0:14),ITQM(0:14),
     .                ISQM(0:14),IMQM(0:14),IHQM(0:14)

      DATA BMISS /10E10/,IFIRST/0/
      DATA CM2K  /1.94 /
 
C  PRINT QUIPS FLAG FILE RECORD USED TO APPLY Q.C. & CORR. FOR THIS RPT
C  --------------------------------------------------------------------

      IF(IFIRST.EQ.0) THEN
         PRINT'(/"THE FOLLOWING REPORTS ARE MODIFIED AS INDICATED HERE",
     .    " BY THIS PROGRAM (SEE DOCBLOCK FOR DOCUMENTATION ON"/
     .    "FORMAT BELOW):"/39X,"D   S CORRECT-"/39X,"U   S ED    ID"/
     .    39X,"P   T         W"/"RPTED ID N-LAT W-LON YYYYMMDD HHMM  ",
     .    "TYP PWT M",8X,"Z CORRECTIONS ---->"/8("-"),1X,2(5("-"),1X),
     .    8("-")," ----  ",18("-"),1X,19("-"))'
         IFIRST = 1
      ENDIF
 
      PRINT'(/A132)',CARD
 
      IF(CARD(40:40).EQ.'L')  RETURN  ! Return immediately if duplicate

C  PARSE THE SDMEDIT QUALITY FLAGS FOR THIS ENTRY
C  ----------------------------------------------

      IQMPR = IQMF(CARD(41:41))  ! Quality mark on pressure (stn & msl)
      IQMWN = IQMF(CARD(42:42))  ! Quality mark on wind
      IQMAT = IQMF(CARD(43:43))  ! Quality mark on air temperature
      IQMST = IQMF(CARD(44:44))  ! Quality mark on sea-sfc temperature
      IQMDD = IQMF(CARD(45:45))  ! Quality mark on moisture (dewpoint)
      IQMWH = IQMF(CARD(54:54))  ! Quality mark on wave height

C  ENCODE QUALITY FLAGS INTO THIS BUFR REPORT
C  ------------------------------------------
 
      IF(IQMPR.GE.0) THEN
         IF(qms_8(1).ge.bmiss .or. IQMPR.GT.qms_8(1)) THEN
            UFBINT_8 = IQMPR
            CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'QMPR')
            IF(qms_8(1).lt.bmiss) THEN
               print'("    ... QMPR changed from ",F7.0," to ",F3.0)',
     .          qms_8(1),ufbint_8
            ELSE
               print'("    ... QMPR changed from MISSING to ",F3.0)',
     .          ufbint_8
            ENDIF
            IPQM(IQMPR) = IPQM(IQMPR) + 1
         ELSEIF (IQMPR.LE.qms_8(1)) then
            print'("    ... since QMPR already ",F3.0," it is not ",
     .       "changed to ",F3.0)', qms_8(1),real(IQMPR)
         ENDIF
      ENDIF
      IF(IQMWN.GE.0) THEN
         IF(qms_8(2).ge.bmiss .or. IQMWN.GT.qms_8(2)) THEN
            UFBINT_8 = IQMWN
            CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'QMWN')
            IF(qms_8(2).lt.bmiss) THEN
               print'("    ... QMWN changed from ",F7.0," to ",F3.0)',
     .          qms_8(2),ufbint_8
            ELSE
               print'("    ... QMWN changed from MISSING to ",F3.0)',
     .          ufbint_8
            ENDIF
            IWQM(IQMWN) = IWQM(IQMWN) + 1
         ELSEIF (IQMWN.LE.qms_8(2)) then
            print'("    ... since QMWN already ",F3.0," it is not ",
     .       "changed to ",F3.0)', qms_8(2),real(IQMWN)
         ENDIF
      ENDIF
      IF(IQMAT.GE.0) THEN
         IF(qms_8(3).ge.bmiss .or. IQMAT.GT.qms_8(3)) THEN
            UFBINT_8 = IQMAT
            CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'QMAT')
            IF(qms_8(3).lt.bmiss) THEN
               print'("    ... QMAT changed from ",F7.0," to ",F3.0)',
     .          qms_8(3),ufbint_8
            ELSE
               print'("    ... QMAT changed from MISSING to ",F3.0)',
     .          ufbint_8
            ENDIF
            ITQM(IQMAT) = ITQM(IQMAT) + 1
         ELSEIF (IQMAT.LE.qms_8(3)) then
            print'("    ... since QMAT already ",F3.0," it is not ",
     .       "changed to ",F3.0)', qms_8(3),real(IQMAT)
         ENDIF
      ENDIF
      IF(IQMST.GE.0) THEN
         IF(qms_8(4).ge.bmiss .or. IQMST.GT.qms_8(4)) THEN
            UFBINT_8 = IQMST
            CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'QMST')
            IF(qms_8(4).lt.bmiss) THEN
               print'("    ... QMST changed from ",F7.0," to ",F3.0)',
     .          qms_8(4),ufbint_8
            ELSE
               print'("    ... QMST changed from MISSING to ",F3.0)',
     .          ufbint_8
            ENDIF
            ISQM(IQMST) = ISQM(IQMST) + 1
         ELSEIF (IQMST.LE.qms_8(4)) then
            print'("    ... since QMST already ",F3.0," it is not ",
     .       "changed to ",F3.0)', qms_8(4),real(IQMST)
         ENDIF
      ENDIF
      IF(IQMDD.GE.0) THEN
         IF(CARD(37:39).NE.'532') THEN
            IF(qms_8(5).ge.bmiss .or. IQMDD.GT.qms_8(5)) THEN
               UFBINT_8 = IQMDD
               CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'QMDD')
               IF(qms_8(5).lt.bmiss) THEN
                  print'("    ... QMDD changed from ",F7.0," to ",F3.0)'
     .             ,qms_8(5),ufbint_8
               ELSE
                  print'("    ... QMDD changed from MISSING to ",F3.0)',
     .             ufbint_8
               ENDIF
               IMQM(IQMDD) = IMQM(IQMDD) + 1
            ELSEIF (IQMDD.LE.qms_8(5)) then
               print'("    ... since QMDD already ",F3.0," it is not ",
     .          "changed to ",F3.0)', qms_8(5),real(IQMDD)
            ENDIF
         ELSE
C Tide gauge reports do not encode moisture q.m.
            print'("    ... QMDD (=",I2,") is NOT encoded into tide ",
     .       "gauge reports")', IQMDD
         ENDIF
      ENDIF
      IF(IQMWH.GE.0) THEN
         IF(CARD(37:39).NE.'532') THEN
            IF(qms_8(6).ge.bmiss .or. IQMWH.GT.qms_8(6)) THEN
               UFBINT_8 = IQMWH
               CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'QMWH')
               IF(IRET.GT.0) THEN  ! Add this test since QMWH is not
                                   !  yet in the BUFR table
                  IF(qms_8(6).lt.bmiss) THEN
                     print'("    ... QMWH changed from ",F7.0," to ",
     .                F3.0)', qms_8(6),ufbint_8
                  ELSE
                     print'("    ... QMWH changed from MISSING to ",
     .                F3.0)', ufbint_8
                  ENDIF
                  IHQM(IQMWH) = IHQM(IQMWH) + 1
               ELSE
                  print'("    ... QMWH (=",I2,") is NOT encoded ",
     .             "because it is not in BUFR table")', IQMWH
               ENDIF
            ELSEIF (IQMWH.LE.qms_8(6)) then
               print'("    ... since QMWH already ",F3.0," it is not ",
     .          "changed to ",F3.0)', qms_8(6),real(IQMWH)
            ENDIF
         ELSE
C Tide gauge reports do not encode wave height q.m.
            print'("    ... QMWH (=",I2,") is NOT encoded into tide ",
     .       "gauge reports")', IQMWH
         ENDIF
      ENDIF
 
C  IF ID CORRECTED, ENCODE INTO BUFR REPORT IN PLACE OF REPORTED ID
C  ----------------------------------------------------------------
 
      CNID = CARD(46:53)
      IF(CNID.NE.' ') THEN
         CALL UFBINT(LUBFJ,RNID_8,1,1,IRET,'RPID')
         print'("    ... RPID corrected to ",A8)', cnid
         ICOR(6) = ICOR(6) + 1
      ENDIF
 
C  XLAT AND XLON DEFAULT TO ORIGINAL REPORTED LATITUDE AND LONGITUDE
C  (AND WILL BE SET TO MISSING IS THERE IS A PROBLEM READING ORIG.
C  REPORTED VALUES); ONE OR THE OTHER COULD BE MODIFIED IF A CORRECTED
C  VALUE IS FOUND (THESE WILL LATER BE USED FOR GREAT LAKES CHECK FOR
C  SHIPS)
C  ------------------------------------------------------------------

      READ(CARD(10:14),'(F5.2)',ERR=800) XLAT
      READ(CARD(16:20),'(F5.2)',ERR=800) XLON
      XLON = MOD(720.-XLON,360.)
      GOTO 850

  800 CONTINUE

      XLAT = BMISS
      XLON = BMISS
      PRINT'(/"#####QUIPS FILE CONTAINS CORRUPTED RECORD (NUMBER",'//
     . 'I4,"): ",A/5X,"- SET ORIG. LAT/LON TO MISSING IN GREAT LAKES'//
     . ' TEST"/)', M,CARD
      REWIND(91)
      WRITE(91,'(A)') CARD
      REWIND(91)
      CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg "$jlogfile" '//
     . '"***WARNING: CORRUPT RECORD IN QUIPS FILE: cat ./fort.91`"')

  850 CONTINUE

C  PARSE THE QUIPS CORRECTION DATA & ENCODE CORRECTIONS IN BUFR REPORT
C  -------------------------------------------------------------------
 
      CALL PARCOR(CARD,RDATA)
 
      LOCATION_COR = .FALSE.
      PMSL_COR     = .FALSE.

      IF(RDATA(1).LT.BMISS) THEN             ! Latitude (deg. N+, S-)
         UFBINT_8 = RDATA(1)
         CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'CLAT')
         print'("    ... CLAT corrected to ",F6.2," deg. N+,S-")',
     .    ufbint_8
         XLAT     = RDATA(1)  ! Modify XLAT for later Great Lakes check
         LOCATION_COR = .TRUE.
         ICOR(1) = ICOR(1) + 1
      ENDIF
      IF(RDATA(2).LT.BMISS) THEN             ! Longitude (convert from
         RDATA(2) = MOD(720.-RDATA(2),360.)  ! deg. W to deg. E)
         UFBINT_8 = RDATA(2)
         CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'CLON')
         print'("    ... CLON corrected to ",F6.2," deg. E")', ufbint_8
         XLON     = RDATA(2)  ! Modify XLON for later Great Lakes check
         LOCATION_COR = .TRUE.
         ICOR(2) = ICOR(2) + 1
      ENDIF
      IF(RDATA(3).LT.BMISS) THEN             ! Mean sea-level pressure
         RDATA(3) = RDATA(3) * 100.          ! (convert from mb to Pa)
         UFBINT_8 = RDATA(3)
         CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'PMSL')
         print'("    ... PMSL corrected from ",F6.1," to ",F6.1," mb")',
     .    obs_8(1)*0.01,ufbint_8*0.01
         IF(IQMPR.LT.0) THEN
            UFBINT_8 = 4      ! Update quality marker to 4
            CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'QMPR')
            print'("    ... since this report has a corrected PMSL, ",
     .       "QMPR changed from ",F3.0," to ",F3.0)', qms_8(1),ufbint_8
            IPQM(4) = IPQM(4) + 1
         ELSE
            print *, '   ... report has a corrected PMSL, but since ',
     .       'its QMPR has already been set to ',IQMPR,' it is not '
            print *, '       changed to 4 here'
         ENDIF
         PMSL_COR = .TRUE.
         ICOR(3) = ICOR(3) + 1
      ENDIF
      IF(RDATA(4).LT.BMISS) THEN             ! Air temperature (K)
         UFBINT_8 = RDATA(4)
         CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'TMDB')
         print'("    ... TMDB corrected from ",F6.2," to ",F6.2," K")',
     .    obs_8(5),ufbint_8
         IF(IQMAT.LT.0) THEN
            UFBINT_8 = 4      ! Update quality marker to 4
            CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'QMAT')
            print'("    ... since this report has a corrected TMDB, ",
     .       "QMAT changed from ",F3.0," to ",F3.0)', qms_8(3),ufbint_8
            ITQM(4) = ITQM(4) + 1
         ELSE
            print *, '   ... report has a corrected TMDB, but since ',
     .       'its QMAT has already been set to ',IQMAT,' it is not ',
     .       'changed to 4 here'
         ENDIF
         ICOR(4) = ICOR(4) + 1
      ENDIF
      IF(MAX(RDATA(5),RDATA(6)).LT.BMISS) THEN
         UFBINT_8 = RDATA(5)                 ! Wind dir. (deg. from N)
         CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'WDIR')
         print'("    ... WDIR corrected from ",F4.0," to ",F4.0,
     .    " deg. from N")', obs_8(3),ufbint_8
         RDATA(6) = RDATA(6)/CM2K            ! Wind speed (convert from
         UFBINT_8 = RDATA(6)                 ! knots to m/s)
         CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'WSPD')
         print'("    ... WSPD corrected from ",F5.1," to ",F5.1,
     .    " m/s")', obs_8(4),ufbint_8
         IF(IQMWN.LT.0) THEN
            UFBINT_8 = 4      ! Update quality marker to 4
            CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'QMWN')
            IWQM(4) = IWQM(4) + 1
            print'("    ... since this report has a corrected WDIR ",
     .       "and WSPD, QMWN changed from ",F3.0," to ",F3.0)',
     .       qms_8(2),ufbint_8
            ITQM(4) = ITQM(4) + 1
         ELSE
            print *, '   ... report has a corrected WDIR and WSPD, ',
     .       'but since its QMWN has already been set to ',IQMWN,' it ',
     .       'is not'
            print *, '       changed to 4 here'
         ENDIF
         ICOR(5) = ICOR(5) + 1
      ENDIF
      IF(RDATA(7).LT.BMISS) THEN
         UFBINT_8 = RDATA(7)                 ! Sea-sfc temperature (K)

C  Check to see if the BUFR mnemonic table contains SST1 or SST2
C   {the current (9/9/03) table does not contain SST2}
C  -------------------------------------------------------------

         CALL STATUS(LUBFI,LUN,IDUMMY1,IDUMMY2)
         CALL NEMTAB(LUN,'SST1',IDUMMY1,CDUMMY,IRET1)
         CALL NEMTAB(LUN,'SST2',IDUMMY1,CDUMMY,IRET2)
         IF(IRET1.GT.0) THEN
            CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'SST1')
            print'("    ... SST1 corrected from ",F6.2," to ",F6.2,
     .       " K")', obs_8(6),ufbint_8
         ENDIF
         IF(IRET2.GT.0) THEN
            CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'SST2')
            print'("    ... SST2 corrected from ",F6.2," to ",F6.2,
     .       " K")', obs_8(7),ufbint_8
         ENDIF
         IF(IQMST.LT.0) THEN
            UFBINT_8 = 4      ! Update quality marker to 4
            CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'QMST')
            ISQM(4) = ISQM(4) + 1
            print'("    ... since this report has a corrected SST1 ",
     .       "and/or SST2, QMST changed from ",F3.0," to ",F3.0)',
     .       qms_8(4),ufbint_8
         ELSE
            print *, '   ... report has a corrected SST1 and/or SST2,',
     .       ' but since its QMST has already been set to ',IQMST,' it',
     .       ' is not'
            print *, '       changed to 4 here'
         ENDIF
         ICOR(7) = ICOR(7) + 1
      ENDIF
 
C  CHECK TO SEE IF REPORT IS IN GREAT LAKES, THE LAT/LON USED HERE
C  WILL INCLUDE THE CORRECTED VALUE IF ONE IS PRESENT (OTHERWISE THE
C  ORIGINAL VALUE IS USED) - IF IN GREAT LAKES, ELEVATION IS SET TO
C  THAT OF THE LAKE, OTHERWISE ELEVATION IS SET TO ZERO (SEA-LEVEL)
C  -----------------------------------------------------------------

      CALL GLCHECK(XLAT,XLON,ELEV)

      IF(ELEV.GT.0) THEN
         print'("    ... this report is in a Great Lake - the lake has",
     .    " an elevation of ",F4.0," meters")', elev
         if(nint(obs_8(8)).lt.nint(elev))  print'("  ---> This ",
     .    "report''s elev (=",F4.0,") is LESS THAN that of the ",
     .    "lake!!!")', obs_8(8)
      ENDIF

C  SINCE SHIPS WITH A CORRECTED LOCATION MAY HAVE MOVED EITHER INTO OR
C  OUT OF GREAT LAKES, ENCODE ELEV COMING FROM GLCHECK INTO THIS SHIP
C  BUFR REPORT IF IT IS DIFFERENT THAN ORIGINAL REPORTED ELEVATION
C  (Note: Since the elev for fixed buoys & C-MANs is set by the
C         decoders, which match their stn ids to the stn elev tbl;
C         and since the decoders hardwire elev to ZERO for drifting
C         buoys (there are no drifters in the Great Lakes YET); these
C         reports are not checked here.) 
C  --------------------------------------------------------------------

      IF((CARD(37:39).EQ.'522'.OR.CARD(37:39).EQ.'523') .AND.
     .  LOCATION_COR) THEN
         IF(nint(obs_8(8)).ne.nint(elev)) then
            UFBINT_8 = ELEV
            CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'SELV')
            print'("    ... since this is a ship report with a ",
     .       "corrected lat and/or lon, SELV corrected from ",F4.0,
     .       " to ",F4.0," meters")', obs_8(8),ufbint_8
            obs_8(8) = ufbint_8
            ICOR(9) = ICOR(9) + 1
         ENDIF
      ENDIF

C  ALL REPORTS (EXCEPT TIDE GAUGE) WITH REPORTED ELEVATION ZERO
C  (I.E., OUTSIDE THE GREAT LAKES) WITH A CORRECTED SEA-LEVEL PRESSURE
C  ENCODE THIS SAME VALUE FOR STATION PRESSURE INTO THE BUFR REPORT
C  (REPLACING THE ORIGINAL STATION PRESSURE VALUE IF IT IS NON-MISSING)
C  SINCE STATION PRESSURE AND SEA-LEVEL PRESSURE ARE ASSUMED TO BE THE
C  SAME (TIDE GAUGE REPORTS DO NOT ENCODE STATION PRESSURE)
C  --------------------------------------------------------------------

      IF(CARD(37:39).NE.'532') THEN  ! Exclude tide gauge reports
         IF(PMSL_COR .AND. OBS_8(2).LT.BMISS) THEN
            IF(nint(obs_8(8)).EQ.0) THEN
               UFBINT_8 = RDATA(3)
               CALL UFBINT(LUBFJ,UFBINT_8,1,1,IRET,'PRES')
               print'("    ... since this report''s PMSL corrected, ",
     .          "PRES corrected from ",F6.1," to ",F6.1," mb, ",
     .          "report''s SELV is ",F4.0," meters")',
     .          obs_8(2)*0.01,ufbint_8*0.01,obs_8(8)
               ICOR(8) = ICOR(8) + 1
            ELSE
               print *, '   ... although PMSL corrected, DO NOT ',
     .          'correct this report''s PRES since it is in the Great ',
     .          'Lakes -- this'
               print *, '       may cause problems esp. since qm is ',
     .          'set to 4!!!'
            ENDIF
         ENDIF
      ENDIF

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    PARCOR
C   PRGMMR: KEYSER           ORG: NP22       DATE: 2004-05-17
C
C ABSTRACT: PARSES CORRECTED DATA VALUES FOR A SINGLE REPORT FROM
C   COLUMNS 56-132 OF A RECORD (LINE) FROM THE QUIPS FLAG FILE.
C
C PROGRAM HISTORY LOG:
C 1997-02-01  J. WOOLLEN   -- ORIGINAL AUTHOR
C 1999-12-07  CARUSO MAGEE -- ADDED DOCBLOCK
C 2004-02-02  D. KEYSER    -- STREAMLINED CODE; IMPROVED DOCBLOCK AND
C       COMMENTS; ADDED MORE DESCRIPTIVE STANDARD OUTPUT PRINT; FIXED A
C       FEW MINOR BUGS
C 2004-05-17  D. KEYSER    -- NOW CHECKS FOR VALID "NUMBERS" IN THE
C       CORRECTED LAT, LON, PMSL, AIR TEMPERATURE, WIND DIRECTION, WIND
C       SPEED AND SST VALUES FOR THE FLAG FILE ENTRY BEING PROCESSED
C       AND IF ANY VALUES ARE NON-NUMERIC THIS SUBROUTINE WILL SET ALL
C       CORRECTION VALUES TO MISSING, SEND A MESSAGE TO THE PRODUCTION
C       JOBLOG FILE TO ALERT THAT THERE IS A CORRUPT ENTRY IN THE QUIPS
C       FLAG FILE, AND THEN RETURN TO THE CALLING ROUTINE; FIRST INPUT
C       ARGUMENT NOW CONTAINS COMPLETE RECORD (ENTRY) FROM QUIPS FLAG
C       FILE RATHER THAN JUST COLUMNS 56-132 (WHICH CONTAIN ONLY THE
C       CORRECTED VALUES) (USED IN PRINT MESSAGE IF THIS ENTRY IS
C       CORRUPT)
C
C USAGE:    CALL PARCOR (CARD, RDATA)
C   INPUT ARGUMENT LIST:
C     CARD     - CHARACTER*132, STRING CONTAINING ONE ENTIRE LINE
C                (RECORD) AS READ IN FROM THE QUIPS FLAG FILE (ONLY
C                COLUMNS 56-132, CONTAINING CORRECTIONS, ARE EXAMINED)
C
C   OUTPUT ARGUMENT LIST:
C     RDATA    - REAL, 7-WORD ARRAY CONTAINING CORRECTED DATA IN THE
C                FOLLOWING FORMAT:
C                  Word 1 - Corrected latitude (deg. N+,S-)
C                  Word 2 - Corrected longitude (deg. W, 0-36000)
C                  Word 3 - Corrected sea-level pressure (mb)     
C                  Word 4 - Corrected air temperature (K)
C                  Word 5 - Corrected wind direction (deg. from north)
C                  Word 6 - Corrected wind speed (knots)
C                  Word 7 - Corrected sea-surface temperature (K)
C                If no corrected data are found, RDATA(n) is set to
C                10E10 (missing).
C
C   OUTPUT FILES:
C     UNIT 06  - STANDARD OUTPUT PRINT
C                COMPLETED SUCCESSFULLY
C   WORK FILES:
C     UNIT 91  - SCRATCH FILE CONTAINING CONTENTS OF FLAG FILE ENTRY
C                FOR CASES OF A CORRUPT ENTRY WHERE MESSAGE IS POSTED
C                TO THE PRODUCTION JOBLOG FILE VIA POSTMSG
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM
C
C$$$
      SUBROUTINE PARCOR(CARD,RDATA)
 
      CHARACTER*132 CARD
 
      REAL          RDATA(7)

      DATA BMISS  /10E10/

      I = 56

      RDATA = BMISS
 
C  PARSE CORRECTION DATA FROM QUIPS FLAG FILE RECORD COLUMNS 56-132
C  ----------------------------------------------------------------
 
      DO WHILE(I.LT.133 .AND. CARD(I:132).NE.' ')
         IF(CARD(I:I).EQ.' ') THEN
            I = I+1
            CYCLE
         ELSE
            IF(CARD(I:I+1).EQ.'QL') THEN
               READ(CARD(I+2:I+6),'(F5.2)',  ERR=800)  RDATA(1) ! LAT
               I = I+7
            ELSEIF(CARD(I:I+1).EQ.'QG') THEN
               READ(CARD(I+2:I+6),'(F5.2)',  ERR=800)  RDATA(2) ! LON
               I = I+7
            ELSEIF(CARD(I+7:I+8).EQ.'QP') THEN
               READ(CARD(I+9:I+13),'(F5.1)', ERR=800)  RDATA(3) ! PMSL
               I = I+14
            ELSEIF(CARD(I+7:I+8).EQ.'QT') THEN
               READ(CARD(I+9:I+13),'(F5.1)', ERR=800)  RDATA(4) ! ATMP
               RDATA(4) = RDATA(4) + 273.15
               I = I+14
            ELSEIF(CARD(I+7:I+8).EQ.'QW') THEN
               READ(CARD(I+9:I+10),'(F2.0)', ERR=800)  RDATA(5) ! WDIR
               RDATA(5) = RDATA(5) * 10.
               READ(CARD(I+11:I+13),'(F3.0)',ERR=800)  RDATA(6) ! WSPD
               I = I+14
            ELSEIF(CARD(I+7:I+8).EQ.'QS') THEN
               READ(CARD(I+9:I+13),'(F5.1)', ERR=800)  RDATA(7) ! SST
               RDATA(7) = RDATA(7) + 273.15
               I = I+14
            ELSE
               PRINT'(/"PARCOR: UNRECOGNIZED CORRECTION TYPE (=''",A2,
     .          "'' OR ''",A2,"''), DO NOT ATTEMPT TO PROCESS ANY ",
     .          "CORRECTION FIELDS"/8X,"FOR THIS REPORT"/)',
     .          CARD(I:I+1),CARD(I+7:I+8)
               RDATA = BMISS
               RETURN
            ENDIF
            CYCLE

  800       CONTINUE
            PRINT'(/"PARCOR: CORRUPTED CORRECTION VALUES IN QUIPS '//
     .       'FLAG FILE ENTRY, DO NOT ATTEMPT TO PROCESS ANY '//
     .       'CORRECTION FIELDS"/8X,"FOR THIS REPORT"/8X,"CARD: ",A)',
     .       CARD
            REWIND(91)
            WRITE(91,'(A)') CARD
            REWIND(91)
            CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg '//
     .       '"$jlogfile" "***WARNING: CORRUPT RECORD IN QUIPS FILE:'//
     .       ' `cat ./fort.91`"')
            RDATA = BMISS
            RETURN

         ENDIF
      ENDDO
 
C  NORMAL EXIT
C  -----------
 
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    IQMF
C   PRGMMR: KEYSER           ORG: NP22       DATE: 2004-02-02
C
C ABSTRACT: THIS FUNCTION CONVERTS A QUALITY MARK FROM CHARACTER FORM
C   TO NUMERIC FORM.
C
C PROGRAM HISTORY LOG:
C 1997-02-01  J. WOOLLEN   -- ORIGINAL AUTHOR
C 1999-12-07  CARUSO MAGEE -- ADDED DOCBLOCK
C 2004-02-02  D. KEYSER    -- CHANGED TO AN INTEGER FUNCTION (WAS QMF);
C       MISSING QUALITY MARK IN CHARACTER FORM (I.E., " ") RETURNS -99
C
C USAGE:    IQMF (FLAG)
C   INPUT ARGUMENT LIST:
C     FLAG     - CHARACTER*1, QUALITY MARK IN CHARACTER FORM
C                   'H' - FOR HOLD (KEEP)
C                   'P' - PURGE (REJECT)
C
C   OUTPUT ARGUMENT LIST:
C     IQMF     - INTEGER, QUALITY MARK IN NUMERIC FORM
C                    0  - FOR HOLD (KEEP)
C                   14  - PURGE (REJECT)
C                  -99  - NEITHER HOLD NOR PURGE
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM
C
C$$$
      FUNCTION IQMF(FLAG)

      CHARACTER*1 FLAG

      IQMF = -99
      IF(FLAG.EQ.'H') THEN
         IQMF = 0
      ELSEIF(FLAG.EQ.'P') THEN
         IQMF = 14
      ENDIF

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    GLCHECK
C   PRGMMR: KEYSER           ORG: NP22       DATE: 2004-05-17
C
C ABSTRACT:  CHECKS A REPORT'S LATITUDE AND LONGITUDE TO SEE IF IT IS
C   LOCATED IN ONE OF THE GREAT LAKES.  IF SO, SETS THE REPORT'S
C   STATION ELEVATION TO THE ELEVATION OF THE LAKE THE REPORT LIES
C   IN.  IF THE REPORT IS NOT IN ONE OF THE GREAT LAKES, THIS
C   SUBROUTINE SETS ITS ELEVATION TO ZERO.
C
C PROGRAM HISTORY LOG:
C 1999-12-03  CARUSO MAGEE -- ORIGINAL AUTHOR
C 2004-02-02  D. KEYSER    -- STREAMLINED CODE
C 2004-05-17  D. KEYSER    -- NOW CHECKS TO SEE IF INPUT LAT AND/OR LON
C    IS MISSING, IF SO THIS SUBROUTINE RETURNS WITH ELEVATION ZERO
C    (I.E., ASSUMES REPORT IS NOT IN THE GREAT LAKES)
C
C USAGE:    CALL GLCHECK (ALAT, ALON, ELEV)
C   INPUT ARGUMENT LIST:
C     ALAT     - REAL, LATITUDE -90.00 TO 90.00 (SOUTH TO NORTH)
C     ALON     - REAL, LONGITUDE 0.00 TO 360.00 EASTBOUND (WESTERN 
C                HEMISPHERE HAS VALUES FROM 180.00 TO 360.00)
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     ELEV     - REAL, STATION ELEVATION IN METERS (HARDWIRED TO ZERO
C                IF REPORT IS NOT IN GREAT LAKES, OTHERWISE HARDWIRED
C                TO ELEVATION OF GREAT LAKE IN WHICH REPORT LIES)
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM
C
C$$$
      SUBROUTINE GLCHECK(ALAT,ALON,ELEV)

      REAL    ALAT,ALON,ELEV

      DATA BMISS  /10E10/

      ELEV = 0.

C  IF EITHER LATITUDE OR LONGITUDE IS MISSING, RETURN IMMEDIATELY
C   (ASSUME NOT LOCATED IN GREAT LAKES - ELEVATION SET TO ZERO)
C  ---------------------------------------------------------------

      IF(ALAT .GE. BMISS  .OR. ALON .GT.BMISS) RETURN

C  CONVERT LONGITUDE FROM 0 TO 360 EASTBOUND INTO -180 TO +180
C  -----------------------------------------------------------

      IF(ALON.GT.180.00) ALON = ALON - 360.0


C  REPORT IS NOT LOCATED IN GREAT LAKES - RETURN
C  -----------------------------------------------

      IF((ALON .LT. -92.50 .OR. ALON .GT. -76.00) .OR.
     .   (ALAT .LT.  41.00 .OR. ALAT .GT.  49.00)) RETURN


      IF((ALON .GE. -92.50 .AND. ALON .LE. -84.52) .AND.
     .   (ALAT .GE.  46.48 .AND. ALAT .LE.  49.00)) THEN

C  REPORT IS LOCATED IN LAKE SUPERIOR
C  ------------------------------------

         ELEV = 183.0

      ELSEIF((ALON .GE. -88.10 .AND. ALON .LE. -84.80) .AND.
     .       (ALAT .GE.  41.20 .AND. ALAT .LE.  46.20)) THEN

C  REPORT IS LOCATED IN LAKE MICHIGAN
C  ------------------------------------

         ELEV = 176.0

      ELSEIF((ALON .GE. -84.80 .AND. ALON .LE. -79.79) .AND.
     .       (ALAT .GE.  43.00 .AND. ALAT .LE.  46.48)) THEN

C  REPORT IS LOCATED IN LAKE HURON OR GEORGIAN BAY
C  -------------------------------------------------

         ELEV = 176.0

      ELSEIF((ALON .GE. -84.00 .AND. ALON .LE. -78.00) .AND.
     .       (ALAT .GE.  41.00 .AND. ALAT .LE.  42.90)) THEN

C  REPORT IS LOCATED IN LAKE ERIE
C  --------------------------------

         ELEV = 174.0

      ELSEIF((ALON .GE. -80.00 .AND. ALON .LE. -76.00) .AND.
     .       (ALAT .GE.  43.10 .AND. ALAT .LE.  44.23)) THEN

C  REPORT IS LOCATED IN LAKE ONTARIO
C  -----------------------------------

         ELEV = 74.0

      ENDIF

      RETURN
      END
