C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: IW3UNP29
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2013-03-20
C
C**********************************************************************
C**********************************************************************
C NOTICE:
C This routine has not been tested reading input data from any dump
C type in ON29/124 format on WCOSS. It likely will not work when
C attempting to read ON29/124 format dumps on WCOSS. It has also
C not been tested reading any dump file other than ADPUPA (BUFR
C input only) on WCOSS. It does work reading BUFR ADPUPA dump files
C on WCOSS. It will hopefully working reading other BUFR (only)
C dump files on WCOSS.
C
C Also, this routine is only known to work correctly when compiled
C using 8 byte machine words (real and integer).
C**********************************************************************
C**********************************************************************
C
C ABSTRACT: READS AND UNPACKS ONE REPORT INTO THE UNPACKED OFFICE NOTE
C 29/124 FORMAT. THE INPUT DATA MAY BE PACKED INTO EITHER BUFR OR
C TRUE ON29/124 FORMAT WITH A Y2K COMPLIANT PSEUDO-ON85 HEADER LABEL.
C (NOTE: AS A TEMPORARY MEASURE, THIS CODE WILL STILL OPERATE ON A
C TRUE ON29/124 FORMAT FILE WITH A NON-Y2K COMPLIANT ON85 HEADER
C LABEL. THE CODE WILL USE THE "WINDOWING" TECHNIQUE TO OBTAIN A
C 4-DIGIT YEAR.) THIS ROUTINE WILL DETERMINE THE FORMAT OF THE
C INPUT DATA AND TAKE THE APPROPRIATE ACTION. IT RETURNS THE
C UNPACKED REPORT TO THE CALLING PROGRAM IN THE ARRAY 'OBS'.
C VARIOUS CONTINGENCIES ARE COVERED BY RETURN VALUE OF THE FUNCTION
C AND PARAMETER 'IER' - FUNCTION AND IER HAVE SAME VALUE. REPEATED
C CALLS OF FUNCTION WILL RETURN A SEQUENCE OF UNPACKED ON29/124
C REPORTS. THE CALLING PROGRAM MAY SWITCH TO A NEW 'NUNIT' AT ANY
C TIME, THAT DATASET WILL THEN BE READ IN SEQUENCE. IF USER
C SWITCHES BACK TO A PREVIOUS 'NUNIT', THAT DATA SET WILL BE READ
C FROM THE BEGINNING, NOT FROM WHERE THE USER LEFT OFF (THIS IS A
C 'SOFTWARE TOOL', NOT AN ENTIRE I/O SYSTEM).
C
C PROGRAM HISTORY LOG:
C 1996-12-13 J. S. WOOLLEN (GSC) -- ORIGINAL AUTHOR - NOTE THIS NEW
C VERSION OF IW3GAD INCORPORATES THE EARLIER VERSION WHICH
C WAS WRITTEN BY J. STACKPOLE AND DEALT ONLY WITH TRUE
C ON29/124 DATA AS INPUT - THIS OPTION IS STILL AVAILABLE
C BUT IS A SMALL PART OF THE NEW ROUTINE WHICH WAS WRITTEN
C FROM SCRATCH TO READ IN BUFR DATA.
C 1997-01-27 D. A. KEYSER -- CHANGES TO MORE CLOSELY DUPLICATE FORMAT
C OBTAINED WHEN READING FROM TRUE ON29/124 DATA SETS.
C 1997-02-04 D. A. KEYSER -- DROPS WITH MISSING STNID GET STNID SET TO
C "DRP88A"; SATWNDS WITH ZERO PRESSURE ARE TOSSED
C 1997-02-12 D. A. KEYSER -- TO GET AROUND THE 3-BIT LIMITATION TO
C THE ON29 PRESSURE Q.M. MNEMONIC "QMPR", AN SDMEDIT/QUIPS
C PURGE OR REJECT FLAG ON PRESSURE IS CHANGED FROM 12 OR 14
C TO 6 IN ORDER TO FIT INTO 3-BITS, SEE FUNCTION E35O29;
C INTERPRETS SDMEDIT AND QUIPS PURGE/KEEP/CHANGE FLAGS
C PROPERLY FOR ALL DATA TYPES; CAN NOW PROCESS CAT. 6 AND
C CAT. 2/3 TYPE FLIGHT-LEVEL RECCOS (BEFORE SKIPPED THESE);
C TESTS FOR MISSING LAT, LON, OBTIME DECODED FROM BUFR AND
C RETAINS MISSING VALUE ON THESE IN UNPACKED ON29/124
C FORMAT (BEFORE NO MISSING CHECK, LED TO POSSIBLE NON-
C MISSING BUT INCORRECT VALUES FOR THESE); THE CHECK FOR
C DROPS WITH MISSING STNID REMOVED SINCE DECODER FIXED FOR
C THIS
C 1997-05-01 D. A. KEYSER -- LOOKS FOR DUPLICATE LEVELS WHEN
C PROCESSING ON29 CAT. 2, 3, AND 4 (IN ALL DATA ON LEVEL)
C AND REMOVES DUPLICATE LEVEL; IN PROCESSING ON29 CAT. 3
C LEVELS, REMOVES ALL LEVELS WHERE WIND IS MISSING; FIXED
C BUG IN AIRCRAFT (AIREP/PIREP/AMDAR) QUALITY MARK
C ASSIGNMENT (WAS NOT ASSIGNING KEEP FLAG TO REPORT IF
C PRESSURE HAD A KEEP Q.M. BUT TEMPERATURE Q.M. WAS
C MISSING)
C 1997-05-30 D. A. KEYSER -- FOR AIRCFT: (ONLY ACARS RIGHT NOW) -
C SECONDS ARE DECODED (IF AVAIL.) AND USED TO OBTAIN
C REPORT TIME; ONLY ASDAR/AMDAR - NEW CAT. 8 CODE FIGS.
C O-PUT 917 (CHAR. 1 & 2 OF ACTUAL STNID), 918 (CHAR. 3 &
C 4 OF ACTUAL STNID), 919 (CHAR. 5 & 6 OF ACTUAL STNID);
C ASDAR/AMDAR AND ACARS - NEW CAT. 8 CODE FIG. O-PUT 920
C (CHAR. 7 & 8 OF ACTUAL STNID); ONLY ACARS - NEW CAT. 8
C CODE FIG. O-PUT 921 (REPORT TIME TO NEAREST 1000'TH OF
C AN HOUR); ONLY SOME ACARS - NEW MNEMONIC "IALT" NOW
C EXISTS AND CAN (IF LINE NOT COMMENTED OUT) BE USED TO
C OBTAIN UNPACKED ON29 CAT. 6
C 1997-07-02 D. A. KEYSER -- REMOVED FILTERING OF AIRCRAFT DATA AS
C FOLLOWS: AIR FRANCE AMDARS NO LONGER FILTERED, AMDAR/
C ASDAR BELOW 7500 FT. NO LONGER FILTERED, AIREP/PIREP
C BELOW 100 METERS NO LONGER FILTERED, ALL AIRCRAFT WITH
C MISSING WIND BUT VALID TEMPERATURE ARE NO LONGER
C FILTERED; REPROCESSES U.S. SATWND STN. IDS TO CONFORM
C WITH PREVIOUS ON29 APPEARANCE EXCEPT NOW 8-CHAR (TAG
C CHAR. 1 & 6 NOT CHANGED FROM BUFR STN. ID) - NEVER ANY
C DUPL. IDS NOW FOR U.S. SATWNDS DECODED FROM A SINGLE
C BUFR FILE; STREAMLINED/ELIMINATED SOME DO LOOPS TO
C SPEED UP A BIT
C 1997-09-18 D. A. KEYSER -- CORRECTED ERRORS IN REFORMATTING SURFACE
C DATA INTO UNPACKED ON124, SPECIFICALLY-HEADER: INST. TYPE
C (SYNOPTIC FMT FLG, AUTO STN. TYPE, CONVERTED HRLY FLG),
C INDICATORS (PRECIP., WIND SPEED, WX/AUTO STN), CAT51:
C P-TEND, HORIZ. VIZ., PRESENT/PAST WX, CLOUD INFO, MAX/
C MIN TEMP, CAT52: PRECIP., SNOW DPTH, WAVE INFO, SHIP
C COURSE/SPEED, CAT8: CODE FIGS. 81-85,98; CORRECTED
C PROBLEM WHICH CODED UPPER-AIR MANDATORY LEVEL WINDS
C AS CAT. 3 INSTEAD OF CAT. 1 WHEN MASS DATA (ONLY) WAS
C REPORTED ON SAME MANDATORY LEVEL IN A SEPARATE REPORTED
C LEVEL IN THE RAW BULLETIN
C 1997-10-06 D. A. KEYSER -- UPDATED LOGIC TO READ AND PROCESS NESDIS
C HI-DENSITY SATELLITE WINDS PROPERLY
C 1997-10-30 D. A. KEYSER -- ADDED GROSS CHECK ON U-AIR PRESSURE, ALL
C LEVELS WITH REPORTED PRESSURE .LE. ZERO NOW TOSSED; SFC
C CAT. 52 SEA-SFC TEMPERATURE NOW READ FROM HIERARCHY OF
C SST IN BUFR {1ST CHOICE - HI-RES SST ('SST2'), 2ND
C CHOICE - LO-RES SST ('SST1'), 3RD CHOICE - SEA TEMP
C ('STMP')}, BEFORE ONLY READ 'SST1'
C 1998-01-26 D. A. KEYSER -- CHANGED PQM PROCESSING FOR ADPUPA TYPES
C SUCH THAT SDMEDIT FLAGS ARE NOW HONORED (BEFORE, PQM
C WAS ALWAYS HARDWIRED TO 2 FOR ADPUPA TYPES); BUMPED
C LIMIT FOR NUMBER OF LEVELS THAT CAN BE PROCESSED FROM
C 100 TO 150 AND ADDED DIAGNOSTIC PRINT WHEN THE LIMIT
C IS EXCEEDED
C 1998-05-19 D. A. KEYSER -- Y2K COMPLIANT VERSION OF IW3GAD ROUTINE
C ACCOMPLISHED BY REDEFINING ORIGINAL 32-CHARACTER ON85
C HEADER LABEL TO BE A 40-CHARACTER LABEL THAT CONTAINS A
C FULL 4-DIGIT YEAR, CAN STILL READ "TRUE" ON29/124 DATA
C SETS PROVIDED THEIR HEADER LABEL IS IN THIS MODIFIED
C FORM
C 1998-07-22 D. A. KEYSER -- MINOR MODIFICATIONS TO ACCOUNT FOR
C CORRECTIONS IN Y2K/F90 BUFRLIB (MAINLY RELATED TO
C BUFRLIB ROUTINE DUMPBF)
C 1998-08-04 D. A. KEYSER -- FIXED A BUG THAT RESULTED IN CODE BEING
C CLOBBERED IN CERTAIN SITUATIONS FOR RECCO REPORTS; MINOR
C MODIFICATIONS TO GIVE SAME ANSWERS ON CRAY AS ON SGI;
C ALLOWED CODE TO READ TRUE ON29/124 FILES WITH NON-Y2K
C COMPLIANT ON85 LABEL (A TEMPORARY MEASURE DURING
C TRANSITION OF MAIN PROGRAMS TO Y2K); ADDED CALL TO "AEA"
C WHICH CONVERTS EBCDIC CHARACTERS TO ASCII FOR INPUT
C TRUE ON29/124 DATA SET PROCESSING OF SGI (WHICH DOES
C NOT SUPPORT "-Cebcdic" IN ASSIGN STATEMENT)
C 1999-02-25 D. A. KEYSER -- ADDED ABILITY TO READ REPROCESSED SSM/I
C BUFR DATA SET (SPSSMI); ADDED ABILITY TO READ MEAN
C SEA-LEVEL PRESSURE BOGUS (PAOBS) DATA SET (SFCBOG)
C 1999-05-14 D. A. KEYSER -- MADE CHANGES NECESSARY TO PORT THIS
C ROUTINE TO THE IBM SP
C 1999-06-18 D. A. KEYSER -- CAN NOW PROCESS WATER VAPOR SATWNDS
C FROM FOREIGN PRODUCERS; STN. ID FOR FOREIGN SATWNDS
C NOW REPROCESSED IN SAME WAY AS FOR NESDIS/GOES SATWNDS,
C CHARACTER 1 OF STN. ID NOW DEFINES EVEN VS. ODD
C SATELLITE WHILE CHARACTER 6 OF STN. ID NOW DEFINES
C IR CLOUD-DRFT VS. VISIBLE CLOUD DRFT VS. WATER VAPOR
C 2002-03-05 D. A. KEYSER -- REMOVED ENTRY "E02O29", NOW PERFORMS
C HEIGHT TO PRESS. CONVERSION DIRECTLY IN CODE FOR CAT. 7;
C TEST FOR MISSING "RPID" CORRECTED FOR ADPUPA DATA (NOW
C CHECKS UFBINT RETURN CODE RATHER THAN VALUE=BMISS);
C ACCOUNTS FOR CHANGES IN INPUT ADPUPA, ADPSFC, AIRCFT
C AND AIRCAR BUFR DUMP FILES AFTER 3/2002: CAT. 7 AND CAT.
C 51 USE MNEMONIC "HBLCS" TO GET HEIGHT OF CLOUD BASE IF
C MNEMONIC "HOCB" NOT AVAILABLE (AND IT WILL NOT BE FOR ALL
C CAT. 7 AND SOME CAT. 51 REPORTS); MNEMONIC "TIWM"
C REPLACES "SUWS" IN HEADER FOR SURFACE DATA; MNEMONIC
C "BORG" REPLACES "ICLI" IN CAT. 8 FOR AIRCRAFT DATA (WILL
C STILL WORK PROPERLY FOR INPUT ADPUPA, ADPSFC, AIRCFT AND
C AIRCAR DUMP FILES PRIOR TO 3/2002)
C 2013-03-20 D. A. KEYSER -- CHANGES TO RUN ON WCOSS: OBTAIN VALUE OF
C BMISS SET IN CALLING PROGRAM VIA CALL TO BUFRLIB ROUTINE
C GETBMISS RATHER THAN HARDWIRING IT TO 10E08 (OR 10E10);
C USE FORMATTED PRINT STATEMENTS WHERE PREVIOUSLY
C UNFORMATTED PRINT WAS USED (WCOSS SPLITS UNFORMATTED
C PRINT AT 80 CHARACTERS)
C
C USAGE: II = IW3UNP29(NUNIT, OBS, IER)
C INPUT ARGUMENT LIST:
C NUNIT - FORTRAN UNIT NUMBER FOR SEQUENTIAL DATA SET CONTAINING
C - PACKED BUFR REPORTS OR PACKED AND BLOCKED OFFICE NOTE
C - 29/124 REPORTS
C
C OUTPUT ARGUMENT LIST:
C OBS - ARRAY CONTAINING ONE REPORT IN UNPACKED OFFICE NOTE
C - 29/124 FORMAT. FORMAT IS MIXED, USER MUST EQUIVALENCE
C - INTEGER AND CHARACTER ARRAYS TO THIS ARRAY (SEE
C - DOCBLOCK FOR W3FI64 IN /nwprod/lib/sorc/w3nco
C - OR WRITEUPS ON W3FI64, ON29, ON124 FOR HELP)
C - THE LENGTH OF THE ARRAY SHOULD BE AT LEAST 1608
C IER - RETURN FLAG (EQUAL TO FUNCTION VALUE) - SEE REMARKS
C
C INPUT FILES:
C UNIT AA - SEQUENTIAL BUFR OR OFFICE NOTE 29/124 DATA SET ("AA"
C - IS UNIT NUMBER SPECIFIED BY INPUT ARGUMENT "NUNIT")
C
C OUTPUT FILES:
C UNIT 06 - PRINTOUT
C
C SUBPROGRAMS CALLED:
C UNIQUE: xxxxxx
C LIBRARY:
C UTILITY - xxxxxx
C W3NCO - xxxxxx
C W3EMC - xxxxxx
C BUFRLIB - xxxxxx
C
C REMARKS:
C IF INPUT DATA SET IS ON29/124, IT SHOULD BE ASSIGNED IN THIS WAY:
C Cray:
C assign -a ADPUPA -Fcos -Cebcdic fort.XX
C SGI:
C assign -a ADPUPA -Fcos fort.XX
C (Note: -Cebcdic is not possible on SGI, so call to W3NCO
C routine "AEA" takes care of the conversion as each
C ON29 record is read in)
C IF INPUT DATA SET IS BUFR, IT SHOULD BE ASSIGNED IN THIS WAY:
C Cray:
C assign -a ADPUPA fort.XX
C SGI:
C assign -a ADPUPA -F cos fort.XX
C
C NOTE: FOR INPUT ON29/124 DATA SETS, A CONTINGENCY HAS BEEN BUILT
C INTO THIS SUBROUTINE TO PERFORM THE CONVERSION FROM EBCDIC TO
C ASCII IN THE EVENT THE assign DOES NOT PERFORM THE CONVERSION
C
C THE RETURN FLAGS IN IER (AND FUNCTION IW3UNP29 ITSELF) ARE:
C = 0 OBSERVATION READ AND UNPACKED INTO LOCATION 'OBS'.
C SEE WRITEUP OF W3FI64 FOR CONTENTS. (ALL CHARACTER
C WORDS ARE LEFT-JUSTIFIED.) NEXT CALL TO IW3UNP29
C WILL RETURN NEXT OBSERVATION IN DATA SET.
C = 1 A 40 BYTE HEADER IN THE FORMAT DESCRIBED HERE
C (Y2K COMPLIANT PSEUDO-OFFICE NOTE 85) IS RETURNED
C IN THE FIRST 10 WORDS OF 'OBS' ON a 4-BYTE MACHINE
C (IBM) AND IN THE FIRST 5 WORDS OF 'OBS' ON AN
C 8-BYTE MACHINE (CRAY). NEXT CALL TO
C IW3UNP29 WILL RETURN FIRST OBS. IN THIS DATA SET.
C (NOTE: IF INPUT DATA SET IS A TRUE ON29/124 FILE
C WITH THE Y2K COMPLIANT PSEUDO-ON85 HEADER RECORD,
C THEN THE PSEUDO-ON85 HEADER RECORD IS ACTUALLY
C READ IN AND RETURNED; IF INPUT DATA SET IS A TRUE
C ON29/124 FILE WITH A NON-Y2K COMPLIANT ON85 HEADER
C RECORD, THEN A Y2K COMPLIANT PSEUDO-ON85 HEADER
C RECORD IS CONSTRUCTED FROM IT USING THE "WINDOWING"
C TECHNIQUE TO OBTAIN A 4-DIGIT YEAR FROM A 2-DIGIT
C YEAR.)
C FORMAT FOR Y2K COMPLIANT PSEUDO-ON85 HEADER RECORD
C RETURNED (40 BYTES IN CHARACTER):
C BYTES 1- 8 -- DATA SET NAME (AS DEFINED IN ON85
C EXCEPT UP TO EIGHT ASCII CHAR.,
C LEFT JUSTIFIED WITH BLANK FILL)
C BYTES 9-10 -- SET TYPE (AS DEFINED IN ON85)
C BYTES 11-20 -- CENTER (ANALYSIS) DATE FOR DATA
C SET (TEN ASCII CHARACTERS IN FORM
C "YYYYMMDDHH")
C BYTES 21-24 -- SET INITIALIZE (DUMP) TIME, AS
C DEDINED IN ON85)
C BYTES 25-34 -- ALWAYS "WASHINGTON" (AS IN ON85)
C BYTES 35-36 -- SOURCE MACHINE (AS DEFINED IN ON85)
C BYTES 37-40 -- BLANK FILL CHARACTERS
C
C = 2 END-OF-FILE (NEVER AN EMPTY OR NULL FILE):
C INPUT ON29/124 DATA SET: THE "ENDOF FILE" RECORD IS
C ENCOUNTERED - NO USEFUL INFORMATION IN 'OBS' ARRAY.
C NEXT CALL TO IW3UNP29 WILL RETURN PHYSICAL END OF
C FILE FOR DATA SET IN 'NUNIT' (SEE IER=3 BELOW).
C INPUT BUFR DATA SET: THE PHYSICAL END OF FILE IS
C ENCOUNTERED.
C = 3 END-OF-FILE:
C PHYSICAL END OF FILE ENCOUNTERED ON DATA SET -
C THIS CAN ONLY HAPPEN FOR AN EMPTY (NULL) DATA SET
C OR FOR A TRUE ON29/124 DATA SET. THERE ARE NO
C MORE REPORTS (OR NEVER WERE ANY IF NULL) ASSOCIATED
C WITH DATA SET IN THIS UNIT NUMBER - NO USEFUL
C INFORMATION IN 'OBS' ARRAY. EITHER ALL DONE (IF
C NO MORE UNIT NUMBERS ARE TO BE READ IN), OR RESET
C 'NUNIT' TO POINT TO A NEW DATA SET (IN WHICH CASE
C NEXT CALL TO IW3UNP29 SHOULD RETURN WITH IER=1).
C = 4 ONLY VALID FOR INPUT ON29/124 DATA SET - I/O ERROR
C READING THE NEXT RECORD OF REPORTS - NO USEFUL
C INFORMATION IN 'OBS' ARRAY. CALLING PROGRAM CAN
C CHOOSE TO STOP OR AGAIN CALL IW3UNP29 WHICH WILL
C ATTEMPT TO UNPACK THE FIRST OBSERVATION IN THE NEXT
C RECORD OF REPORTS.
C = 999 APPLIES ONLY TO NON-EMPTY DATA SETS:
C INPUT ON29/124 DATA SET: FIRST CHOICE Y2K COMPLIANT
C PSEUDO-ON85 FILE HEADER LABEL NOT ENCOUNTERED WHERE
C EXPECTED, AND SECOND CHOICE NON-Y2K COMPLIANT ON85
C FILE HEADER LABEL ALSO NOT ENCOUNTERED.
C INPUT BUFR DATA SET: EITHER HEADER LABEL IN
C FORMAT OF PSEUDO-ON85 COULD NOT BE RETURNED, OR AN
C ABNORMAL ERROR OCCURRED IN THE ATTEMPT TO DECODE AN
C OBSERVATION. FOR EITHER INPUT DATA SET TYPE, NO
C USEFUL INFORMATION IN 'OBS' ARRAY. CALLING PROGRAM
C CAN CHOOSE TO STOP WITH NON-ZERO CONDITION CODE OR
C RESET 'NUNIT' TO POINT TO A NEW DATA SET (IN WHICH
C CASE NEXT CALL TO IW3UNP29 SHOULD RETURN WITH
C IER=1).
C INPUT DATA SET NEITHER ON29/124 NOR BUFR: SPEAKS FOR
C ITSELF.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: NCEP WCOSS
C
C$$$
FUNCTION IW3UNP29(LUNIT,OBS,IER)
COMMON/IO29AA/JWFILE(100),LASTF
COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI
COMMON/IO29CC/SUBSET,IDAT10
COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11)
COMMON/IO29EE/ROBS(255,11)
COMMON/IO29FF/QMS(255,9)
COMMON/IO29GG/SFO(34)
COMMON/IO29HH/SFQ(5)
COMMON/IO29II/PWMIN
COMMON/IO29JJ/ISET,MANLIN(1001)
COMMON/IO29KK/KOUNT(499,18)
COMMON/IO29LL/BMISS
DIMENSION OBS(*)
REAL(8) BMISS,GETBMISS
SAVE
DATA ITIMES/0/
IF(ITIMES.EQ.0) THEN
C THE FIRST TIME IN, INITIALIZE SOME DATA
C (NOTE: FORTRAN 77/90 STANDARD DOES NOT ALLOW COMMON BLOCK VARIABLES
C TO BE INITIALIZED VIA DATA STATEMENTS, AND, FOR SOME REASON,
C THE BLOCK DATA DOES NOT INITIALIZE DATA IN THE W3NCO LIBRARY
C AVOID BLOCK DATA IN W3NCO/W3EMC)
C --------------------------------------------------------------------
ITIMES = 1
JWFILE = 0
LASTF = 0
KNDX = 0
KSKACF = 0
KSKUPA = 0
KSKSFC = 0
KSKSAT = 0
KSKSMI = 0
KOUNT = 0
IKAT(1) = 1
IKAT(2) = 2
IKAT(3) = 3
IKAT(4) = 4
IKAT(5) = 5
IKAT(6) = 6
IKAT(7) = 7
IKAT(8) = 8
IKAT(9) = 51
IKAT(10) = 52
IKAT(11) = 9
MCAT(1) = 6
MCAT(2) = 4
MCAT(3) = 4
MCAT(4) = 4
MCAT(5) = 6
MCAT(6) = 6
MCAT(7) = 3
MCAT(8) = 3
MCAT(9) = 21
MCAT(10) = 15
MCAT(11) = 3
ISET = 0
END IF
C UNIT NUMBER OUT OF RANGE RETURNS A 999
C --------------------------------------
IF(LUNIT.LT.1 .OR. LUNIT.GT.100) THEN
PRINT'(" ##IW3UNP29 - UNIT NUMBER ",I0," OUT OF RANGE -- ",
$ "IER = 999")', LUNIT
GO TO 9999
END IF
IF(LASTF.NE.LUNIT .AND. LASTF.GT.0) THEN
CALL CLOSBF(LASTF)
JWFILE(LASTF) = 0
END IF
LASTF = LUNIT
C THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR
C ------------------------------------------------------------
IF(JWFILE(LUNIT).EQ.0) THEN
PRINT'(" ===> IW3UNP29 - WCOSS VERSION: 03-20-2013")'
BMISS = GETBMISS()
print'(1X)'
print'(" BUFRLIB value for missing passed into IW3UNP29 is: ",
$ G0)', bmiss
print'(1X)'
IF(I03O29(LUNIT,OBS,IER).EQ.1) THEN
PRINT'(" IW3UNP29 - OPENED A TRUE OFFICE NOTE 29 FILE IN ",
$ "UNIT ",I0)', LUNIT
JWFILE(LUNIT) = 1
IER = 1
IW3UNP29 = 1
ELSEIF(I03O29(LUNIT,OBS,IER).EQ.3) THEN
PRINT 107, LUNIT
107 FORMAT(/,' ##IW3UNP29 - FILE IN UNIT',I3,' IS EMPTY OR NULL -- ',
$ 'IER = 3'/)
IER = 3
IW3UNP29 = 3
ELSEIF(I02O29(LUNIT,OBS,IER).EQ.1) THEN
PRINT'(" IW3UNP29 - OPENED A BUFR FILE IN UNIT ",I0)', LUNIT
JWFILE(LUNIT) = 2
KNDX = 0
KSKACF = 0
KSKUPA = 0
KSKSFC = 0
KSKSAT = 0
KSKSMI = 0
IER = 1
IW3UNP29 = 1
ELSEIF(I03O29(LUNIT,OBS,IER).EQ.999) THEN
PRINT'(" IW3UNP29 - OPENED A TRUE OFFICE NOTE 29 FILE IN ",
$ "UNIT ",I0)', LUNIT
PRINT 88
88 FORMAT(/' ##IW3UNP29/I03O29 - NEITHER EXPECTED Y2K COMPLIANT ',
$ 'PSEUDO-ON85 LABEL NOR SECOND CHOICE NON-Y2K COMPLIANT ON85 ',
$ 'LABEL FOUND IN'/21X,'FIRST RECORD OF FILE -- IER = 999'/)
GO TO 9999
ELSE
PRINT 108, LUNIT
108 FORMAT(/,' ##IW3UNP29 - FILE IN UNIT',I3,' IS NEITHER BUFR NOR ',
$ 'TRUE OFFICE NOTE 29 -- IER = 999'/)
GO TO 9999
END IF
ELSEIF(JWFILE(LUNIT).EQ.1) THEN
IF(I03O29(LUNIT,OBS,IER).NE.0) JWFILE(LUNIT) = 0
IF(IER.GT.0) CLOSE (LUNIT)
IW3UNP29 = IER
ELSEIF(JWFILE(LUNIT).EQ.2) THEN
IF(I02O29(LUNIT,OBS,IER).NE.0) JWFILE(LUNIT) = 0
IF(IER.GT.0) CALL CLOSBF(LUNIT)
IF(IER.EQ.2.OR.IER.EQ.3) THEN
IF(KSKACF(1).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT/",
$ "AIRCAR REPORTS TOSSED DUE TO ZERO CAT. 6 LVLS = ",I0)',
$ KSKACF(1)
IF(KSKACF(2).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ",
$ "REPORTS TOSSED DUE TO BEING ""LFPW"" AMDAR = ",I0)',
$ KSKACF(2)
IF(KSKACF(8).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ",
$ "REPORTS TOSSED DUE TO BEING ""PHWR"" AIREP = ",I0)',
$ KSKACF(8)
IF(KSKACF(3).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ",
$ "REPORTS TOSSED DUE TO BEING CARSWELL AMDAR = ",I0)',
$ KSKACF(3)
IF(KSKACF(4).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ",
$ "REPORTS TOSSED DUE TO BEING CARSWELL ACARS = ",I0)',
$ KSKACF(4)
IF(KSKACF(5).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT/",
$ "AIRCAR REPORTS TOSSED DUE TO HAVING MISSING WIND = ",I0)',
$ KSKACF(5)
IF(KSKACF(6).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ",
$ "REPORTS TOSSED DUE TO BEING AMDAR < 2286 M = ",I0)',
$ KSKACF(6)
IF(KSKACF(7).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ",
$ "REPORTS TOSSED DUE TO BEING AIREP < 100 M = ",I0)',
$ KSKACF(7)
IF(KSKACF(1)+KSKACF(2)+KSKACF(3)+KSKACF(4)+KSKACF(5)+
$ KSKACF(6)+KSKACF(7)+KSKACF(8).GT.0)
$ PRINT'(" IW3UNP29 - TOTAL NO. OF AIRCFT/AIRCAR REPORTS ",
$ "TOSSED = ",I0)',
$ KSKACF(1)+KSKACF(2)+KSKACF(3)+KSKACF(4)+
$ KSKACF(5)+KSKACF(6)+KSKACF(7)+KSKACF(8)
IF(KSKUPA.GT.0) PRINT'(" IW3UNP29 - TOTAL NO. OF ADPUPA ",
$ "REPORTS TOSSED = ",I0)', KSKUPA
IF(KSKSFC.GT.0) PRINT'(" IW3UNP29 - TOTAL NO. OF ADPSFC/",
$ "SFCSHP/SFCBOG REPORTS TOSSED = ",I0)', KSKSFC
IF(KSKSAT.GT.0) PRINT'(" IW3UNP29 - TOTAL NO. OF SATWND ",
$ "REPORTS TOSSED = ",I0)', KSKSAT
IF(KSKSMI.GT.0) PRINT'(" IW3UNP29 - TOTAL NO. OF SPSSMI ",
$ "REPORTS TOSSED = ",I0)', KSKSMI
KNDX = 0
KSKACF = 0
KSKUPA = 0
KSKSFC = 0
KSKSAT = 0
KSKSMI = 0
END IF
IW3UNP29 = IER
END IF
RETURN
9999 CONTINUE
IER = 999
IW3UNP29 = 999
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
C-----------------------------------------------------------------------
C I01O29 RETURNS LOOK ALIKE Y2K COMPL. PSEUDO-ON85 HDR FROM A DATA FILE
C-----------------------------------------------------------------------
FUNCTION I01O29(LUNIT,HDR,IER)
C ---> formerly FUNCTION IW3HDR
COMMON/IO29AA/JWFILE(100),LASTF
DIMENSION HDR(*)
SAVE
C UNIT NUMBER OUT OF RANGE RETURNS A 999
C --------------------------------------
IF(LUNIT.LT.1 .OR. LUNIT.GT.100) THEN
PRINT'(" ##IW3UNP29/I01O29 - UNIT NUMBER ",I0," OUT OF RANGE ",
$ "-- IER = 999")', LUNIT
GO TO 9999
END IF
C THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR
C ------------------------------------------------------------
IF(JWFILE(LUNIT).EQ.0) THEN
IF(I03O29(LUNIT,HDR,IER).EQ.1) THEN
I01O29 = I03O29(0,HDR,IER)
I01O29 = 1
RETURN
ELSEIF(I02O29(LUNIT,HDR,IER).EQ.1) THEN
CALL CLOSBF(LUNIT)
I01O29 = 1
RETURN
ELSE
C CAN'T READ FILE HEADER RETURNS A 999
C ------------------------------------
PRINT'(" ##IW3UNP29/I01O29 - CAN""T READ FILE HEADER -- ",
$ "IER = 999")'
GO TO 9999
END IF
ELSE
C FILE ALREADY OPEN RETURNS A 999
C -------------------------------
PRINT'(" ##IW3UNP29/I01O29 - FILE ALREADY OPEN -- IER = 999")'
GO TO 9999
END IF
RETURN
9999 CONTINUE
IER = 999
I01O29 = 999
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION I02O29(LUNIT,OBS,IER)
C ---> formerly FUNCTION JW3O29
COMMON/IO29CC/SUBSET,IDAT10
CHARACTER*40 ON85
CHARACTER*10 CDATE
CHARACTER*8 SUBSET,CBUFR
CHARACTER*6 C01O29
CHARACTER*4 CDUMP
DIMENSION OBS(1608),RON85(16),JDATE(5),JDUMP(5)
EQUIVALENCE (RON85(1),ON85)
SAVE
DATA ON85/' '/
JDATE = -1
JDUMP = -1
C IF FILE IS CLOSED TRY TO OPEN IT AND RETURN A Y2K COMPLIANT
C PSEUDO-ON85 LABEL
C -----------------------------------------------------------
CALL STATUS(LUNIT,LUN,IL,IM)
IF(IL.EQ.0) THEN
IRET = -1
I02O29 = 2
REWIND LUNIT
READ(LUNIT,END=10,ERR=10,FMT='(A8)') CBUFR
IF(CBUFR(1:4).EQ.'BUFR') THEN
PRINT'(" IW3UNP29/I02O29 - INPUT FILE ON UNIT ",I0, " IS",
$ " UNBLOCKED NCEP BUFR"/)', LUNIT
ELSE IF(CBUFR(5:8).EQ.'BUFR') THEN
PRINT'(" IW3UNP29/I02O29 - INPUT FILE ON UNIT ",I0, " IS",
$ " BLOCKED NCEP BUFR"/)', LUNIT
ELSE
REWIND LUNIT
GO TO 10
END IF
call datelen(10)
CALL DUMPBF(LUNIT,JDATE,JDUMP)
cppppp
print'(" CENTER DATE (JDATE) = ",I4,4I3.2/" DUMP DATE (JDUMP)",
$ " (year not used anywhere) = "I4,4I3.2)',jdate,jdump
cppppp
IF(JDATE(1).GT.999) THEN
WRITE(CDATE,'(I4.4,3I2.2)') (JDATE(I),I=1,4)
ELSE IF(JDATE(1).GT.0) THEN
C If 2-digit year returned in JDATE(1), must use "windowing" technique
C 2 create a 4-digit year
PRINT'(" ##IW3UNP29/I02O29 - 2-DIGIT YEAR IN JDATE(1) ",
$ "RETURNED FROM DUMPBF (JDATE IS: ",I4.4,3I2.2,") - USE ",
$ "WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR")', JDATE
IF(JDATE(1).GT.20) THEN
WRITE(CDATE,'("19",4I2.2)') (JDATE(I),I=1,4)
ELSE
WRITE(CDATE,'("20",4I2.2)') (JDATE(I),I=1,4)
ENDIF
PRINT'(" ##IW3UNP29/I02O29 - CORRECTED JDATE(1) WITH ",
$ "4-DIGIT YEAR, JDATE NOW IS: ",I4.4,3I2.2)', JDATE
ELSE
GO TO 10
ENDIF
CALL OPENBF(LUNIT,'IN',LUNIT)
C This next call, I believe, is needed only because SUBSET is not
C returned in DUMPBF ...
call readmg(lunit,subset,idat10,iret)
WRITE(CDUMP,'(2I2.2)') JDUMP(4),100*JDUMP(5)/60
IF(JDUMP(1).LT.0) CDUMP = '9999'
ON85=C01O29(SUBSET)//' C2'//CDATE//CDUMP//'WASHINGTONCR '
OBS(1:16) = RON85
I02O29 = 1
10 CONTINUE
IER = I02O29
RETURN
END IF
C IF THE FILE IS ALREADY OPENED FOR INPUT TRY TO READ THE NEXT SUBSET
C -------------------------------------------------------------------
IF(IL.LT.0) THEN
7822 CONTINUE
CALL READNS(LUNIT,SUBSET,IDAT10,IRET)
IF(IRET.EQ.0) I02O29 = R01O29(SUBSET,LUNIT,OBS)
IF(IRET.NE.0) I02O29 = 2
IF(I02O29.EQ.-9999) GO TO 7822
IER = I02O29
RETURN
END IF
C FILE MUST BE OPEN FOR INPUT!
C ----------------------------
PRINT'(" ##IW3UNP29/I02O29 - FILE ON UNIT ",I0," IS OPENED FOR ",
$ "OUTPUT -- IER = 999")', LUNIT
I02O29 = 999
IER = 999
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: I03O29
C PRGMMR: KEYSER ORG: NP22 DATE: 2013-03-20
C
C ABSTRACT: READS A TRUE (SEE *) ON29/124 DATA SET AND UNPACKS ONE
C REPORT INTO THE UNPACKED OFFICE NOTE 29/124 FORMAT. THE INPUT AND
C OUTPUT ARGUMENTS HERE HAVE THE SAME MEANING AS FOR IW3UNP29.
C REPEATED CALLS OF FUNCTION WILL RETURN A SEQUENCE OF UNPACKED
C ON29/124 REPORTS. * - UNLIKE ORIGINAL "TRUE" ON29/124 DATA SETS,
C THE "EXPECTED" FILE HEADER LABEL IS A Y2K COMPLIANT 40-BYTE
C PSEUDO-ON85 VERSION - IF THIS IS NOT ENCOUNTERED THIS CODE, AS A
C TEMPORARY MEASURE DURING THE Y2K TRANSITION PERIOD, WILL LOOK FOR
C THE ORIGINAL NON-Y2K COMPLIANT 32-BYTE ON85 HEADER LABEL AND USE
C THE "WINDOWING" TECHNIQUE TO CONVERT THE 2-DIGIT YEAR TO A 4-DIGIT
C YEAR IN PREPARATION FOR RETURNING A 40-BYTE PSEUDO-ON85 LABEL IN
C THE FIRST C CALL. (SEE IW3UNP29 DOCBLOCK FOR FORMAT OF 40-BYTE
C PSEUDO-ON85 HEADER LABEL.)
C
C PROGRAM HISTORY LOG:
C 1980-12-01 J.STACKPOLE -- ORIGINAL W3LIB ROUTINE IW3GAD
C 1984-06-26 R.E.JONES -- CONVERT TO VS FORTRAN
C 1991-07-23 D.A.KEYSER -- NOW CALLS W3FI64 (F77); INTERNAL READ ERROR
C NO LONGER CAUSES CALLING PROGRAM TO FAIL BUT WILL MOVE
C TO NEXT RECORD IF CAN'T RECOVER TO NEXT REPORT
C 1993-10-07 D.A.KEYSER -- ADAPTED FOR USE ON CRAY (ADDED SAVE
C STATEMENT, REMOVED IBM-SPECIFIC CODE, ETC.)
C 1993-10-15 R.E.JONES -- ADDED CODE SO IF FILE IS EBCDIC IT CONVERTS
C IT TO ASCII
C 1996-10-04 J.S.WOOLLEN -- CHANGED NAME TO I03GAD AND INCORPORATED
C INTO NEW W3LIB ROUTINE IW3GAD
C 2013-03-20 D. A. KEYSER -- CHANGES TO RUN ON WCOSS
C
C USAGE: II = I03O29(NUNIT, OBS, IER)
C INPUT ARGUMENT LIST:
C NUNIT - FORTRAN UNIT NUMBER FOR SEQUENTIAL DATA SET CONTAINING
C - PACKED AND BLOCKED OFFICE NOTE 29/124 REPORTS
C
C OUTPUT ARGUMENT LIST:
C OBS - ARRAY CONTAINING ONE REPORT IN UNPACKED OFFICE NOTE
C - 29/124 FORMAT. FORMAT IS MIXED, USER MUST EQUIVALENCE
C - INTEGER AND CHARACTER ARRAYS TO THIS ARRAY (SEE
C - DOCBLOCK FOR W3FI64 IN /nwprod/lib/sorc/w3nco
C - OR WRITEUPS ON W3FI64, ON29, ON124 FOR HELP)
C - THE LENGTH OF THE ARRAY SHOULD BE AT LEAST 1608
C IER - RETURN FLAG (EQUAL TO FUNCTION VALUE) - SEE REMARKS
C - IN IW3UNP29 DOCBLOCK
C
C INPUT FILES:
C UNIT AA - SEQUENTIAL OFFICE NOTE 29/124 DATA SET ("AA" IS UNIT
C - NUMBER SPECIFIED BY INPUT ARGUMENT "NUNIT")
C
C OUTPUT FILES:
C UNIT 06 - PRINTOUT
C
C REMARKS: CALLED BY SUBPROGRAM IW3UNP29.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: NCEP WCOSS
C
C$$$
FUNCTION I03O29(NUNIT, OBS, IER)
C ---> formerly FUNCTION KW3O29
CHARACTER*1 CBUFF(6432),CON85L(32)
CHARACTER*2 CBF910
CHARACTER*4 CYR4D
CHARACTER*8 CBUFR
INTEGER IBUFF(5),OBS(*)
EQUIVALENCE (IBUFF,CBUFF)
SAVE
DATA IOLDUN/0/
C TEST FOR NEW (OR PREVIOUSLY USED) NUNIT AND ADJUST 'NEXT'
C (THIS ALLOWS USER TO SWITCH TO NEW NUNIT PRIOR TO READING TO
C THE 'END OF FILE' ON AN OLD UNIT. ANY SWITCH TO A NEW UNIT WILL
C START THE READ AT THE BEGINNING)
C ----------------------------------------------------------------
if(nunit.eq.0) then
if(ioldun.gt.0) rewind ioldun
I03O29 = 0
ioldun = 0
return
end if
IF(NUNIT.NE.IOLDUN) THEN
C THIS IS A NEW UNIT NUMBER, SET 'NEXT' TO 0 AND REWIND THIS UNIT
C ---------------------------------------------------------------
CDAKCDAK PRINT 87, NUNIT NOW REDUNDANT TO PRINT THIS
87 FORMAT(//' IW3UNP29/I03O29 - PREPARING TO READ ON29 DATA SET IN ',
$ 'UNIT ',I3/)
IOLDUN = NUNIT
NEXT = 0
NFILE = 0
REWIND NUNIT
ISWT = 0
END IF
10 CONTINUE
IF(NEXT.NE.0) GO TO 70
C COME HERE TO READ IN A NEW RECORD (EITHER REPORTS, Y2K COMPLIANT 40-
C BYTE PSEUDO-ON85 LBL, NON-Y2K 32-BYTE COMPLIANT ON85 LBL, OR E-O-F)
C --------------------------------------------------------------------
READ(NUNIT,END=9997,ERR=9998,FMT='(A8)') CBUFR
IF(CBUFR(1:4).EQ.'BUFR' .OR. CBUFR(5:8).EQ.'BUFR') THEN
C INPUT DATASET IS BUFR - EXIT IMMEDIATELY
C ----------------------------------------
IOLDUN = 0
NEXT = 0
IER = 999
GO TO 90
END IF
REWIND NUNIT
READ(NUNIT,ERR=9998,END=9997,FMT='(6432A1)') CBUFF
C IF ISWT=1, CHARACTER DATA IN RECORD ARE EBCDIC - CONVERT TO ASCII
C -----------------------------------------------------------------
IF(ISWT.EQ.1) CALL AEA(CBUFF,CBUFF,6432)
IF(NFILE.EQ.0) THEN
C TEST FOR EXPECTED HEADER LABEL
C ------------------------------
NFILE = 1
IF(CBUFF(25)//CBUFF(26)//CBUFF(27)//CBUFF(28).EQ.'WASH') THEN
ELSEIF(CBUFF(21)//CBUFF(22)//CBUFF(23)//CBUFF(24).EQ.'WASH')THEN
ELSE
C QUICK CHECK SHOWS SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO-
C ON85 LBL OR NON-Y2K COMPLIANT ON85 LBL FOUND -- COULD MEAN CHARACTER
C DATA ARE IN EBCDIC, SO SEE IF CONVERSION TO ASCII RECTIFIES THIS
C ---------------------------------------------------------------------
PRINT 78
78 FORMAT(/' ##IW3UNP29 - NEITHER EXPECTED Y2K COMPLIANT PSEUDO-',
$ 'ON85 LABEL NOR SECOND CHOICE NON-Y2K COMPLIANT ON85 LABEL ',
$ 'FOUND IN'/14X,'FIRST RECORD OF FILE -- TRY EBCDIC TO ASCII ',
$ 'CONVERSION'/)
CALL AEA(CBUFF,CBUFF,6432)
ISWT = 1
END IF
IF(CBUFF(25)//CBUFF(26)//CBUFF(27)//CBUFF(28).EQ.'WASH') THEN
C THIS IS Y2K COMPLIANT 40-BYTE PSEUDO-ON85 LBL; RESET 'NEXT', SET
C 'IER', FILL 'OBS(1)-(4)', AND QUIT
C ---------------------------------------------------------------
NEXT = 0
IER = 1
OBS(1:5) = IBUFF(1:5)
GO TO 90
ELSE IF(CBUFF(21)//CBUFF(22)//CBUFF(23)//CBUFF(24).EQ.'WASH')
$ THEN
C THIS IS NON-Y2K COMPLIANT 32-BYTE ON85 LBL; RESET 'NEXT', SET
C 'IER', USE "WINDOWING" TECHNIQUE TO CONTRUCT 4-DIGIT YEAR,
C CONSTRUCT A 40-BYTE PSEUDO-ON85 LABE, FILL 'OBS(1)-(4)', AND QUIT
C ------------------------------------------------------------------
PRINT'(" ==> THIS IS A TRUE OFFICE NOTE 29 FILE!! <==")'
PRINT 88
88 FORMAT(/' ##IW3UNP29/I03O29 - WARNING: ORIGINAL NON-Y2K ',
$ 'COMPLIANT ON85 LABEL FOUND IN FIRST RECORD OF FILE INSTEAD OF ',
$ 'EXPECTED'/30X,'Y2K COMPLIANT PSEUDO-ON85 LABEL -- THIS ',
$ 'ROUTINE IS FORCED TO USE "WINDOWING" TECHNIQUE TO CONTRUCT'/30X,
$'A Y2K COMPLIANT PSEUDO-ON85 LABEL TO RETURN TO CALLING PROGRAM'/)
NEXT = 0
IER = 1
CBF910 = CBUFF(9)//CBUFF(10)
READ(CBF910,'(I2)') IYR2D
PRINT'(" ##IW3UNP29/I03O29 - 2-DIGIT YEAR FOUND IN ON85 ",
$ "LBL (",A,") IS: ",I0/19X," USE WINDOWING TECHNIQUE TO ",
$ "OBTAIN 4-DIGIT YEAR")', CBUFF(1:32),IYR2D
IF(IYR2D.GT.20) THEN
IYR4D = 1900 + IYR2D
ELSE
IYR4D = 2000 + IYR2D
ENDIF
PRINT'(" ##IW3UNP29/I03O29 - 4-DIGIT YEAR OBTAINED VIA ",
$ "WINDOWING TECHNIQUE IS: ",I0/)', IYR4D
CON85L = CBUFF(1:32)
CBUFF(7:40) = ' '
CBUFF(9:10) = CON85L(7:8)
WRITE(CYR4D,'(I4.4)') IYR4D
DO I=1,4
CBUFF(10+I) = CYR4D(I:I)
ENDDO
CBUFF(15:36) = CON85L(11:32)
OBS(1:5) = IBUFF(1:5)
GO TO 90
ELSE
C SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO-ON85 LBL OR
C NON-Y2K COMPLIANT ON85 LBL FOUND; RESET 'NEXT', SET 'IER' AND QUIT
C ------------------------------------------------------------------
CDAKCDAK PRINT 88 CAN'T PRINT THIS ANYMORE
CDA88 FORMAT(/' ##IW3UNP29/I03O29 - EXPECTED ON85 LABEL NOT FOUND IN ',
CDAK $ 'FIRST RECORD OF NEW LOGICAL FILE -- IER = 999'/)
IOLDUN = 0
NEXT = 0
IER = 999
GO TO 90
END IF
END IF
IF(CBUFF(1)//CBUFF(2)//CBUFF(3)//CBUFF(4).EQ.'ENDO') THEN
C LOGICAL "ENDOF FILE" READ; RESET NEXT, SET IER, AND QUIT
C --------------------------------------------------------
NEXT = 0
IER = 2
NFILE = 0
GO TO 90
END IF
GO TO 70
9997 CONTINUE
C PHYSICAL END OF FILE; RESET 'NEXT', SET 'IER' AND QUIT
C ------------------------------------------------------
NEXT = 0
IER = 3
GO TO 90
9998 CONTINUE
C I/O ERROR; RESET 'NEXT', SET 'IER' AND QUIT
C -------------------------------------------
cppppp
print'(" ##IW3UNP29/I03O29 - ERROR READING DATA RECORD")'
cppppp
NEXT = 0
IER = 4
GO TO 90
70 CONTINUE
C WORKING WITHIN ACTUAL DATA REC. READ, CALL W3FI64 TO READ IN NEXT RPT
C ---------------------------------------------------------------------
CALL W3FI64(CBUFF,OBS,NEXT)
IF(NEXT.GE.0) THEN
C REPORT SUCCESSFULLY RETURNED IN ARRAY 'OBS'
C -------------------------------------------
IER = 0
ELSE
C HIT END-OF-RECORD, OR INTERNAL READ ERROR ENCOUNTERED & CAN'T RECOVER
C -- READ IN NEXT RECORD OF REPORTS
C ---------------------------------------------------------------------
NEXT = 0
GO TO 10
END IF
90 CONTINUE
I03O29 = IER
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION C01O29(SUBSET)
C ---> formerly FUNCTION ADP
CHARACTER*(*) SUBSET
CHARACTER*6 C01O29
SAVE
C01O29 = 'NONE'
IF(SUBSET(1:5).EQ.'NC000') C01O29 = 'ADPSFC'
IF(SUBSET(1:5).EQ.'NC001') THEN
IF(SUBSET(6:8).NE.'006') THEN
C01O29 = 'SFCSHP'
ELSE
C01O29 = 'SFCBOG'
END IF
END IF
IF(SUBSET(1:5).EQ.'NC002') C01O29 = 'ADPUPA'
IF(SUBSET(1:5).EQ.'NC004') C01O29 = 'AIRCFT'
IF(SUBSET(1:5).EQ.'NC005') C01O29 = 'SATWND'
IF(SUBSET(1:5).EQ.'NC012') C01O29 = 'SPSSMI'
IF(SUBSET .EQ. 'NC003101') C01O29 = 'SATEMP'
IF(SUBSET .EQ. 'NC004004') C01O29 = 'AIRCAR'
IF(SUBSET .EQ. 'NC004005') C01O29 = 'ADPUPA'
IF(SUBSET .EQ. 'ADPSFC') C01O29 = 'ADPSFC'
IF(SUBSET .EQ. 'SFCSHP') C01O29 = 'SFCSHP'
IF(SUBSET .EQ. 'SFCBOG') C01O29 = 'SFCBOG'
IF(SUBSET .EQ. 'ADPUPA') C01O29 = 'ADPUPA'
IF(SUBSET .EQ. 'AIRCFT') C01O29 = 'AIRCFT'
IF(SUBSET .EQ. 'SATWND') C01O29 = 'SATWND'
IF(SUBSET .EQ. 'SATEMP') C01O29 = 'SATEMP'
IF(SUBSET .EQ. 'AIRCAR') C01O29 = 'AIRCAR'
IF(SUBSET .EQ. 'SPSSMI') C01O29 = 'SPSSMI'
IF(C01O29.EQ.'NONE') PRINT'(" ##IW3UNP29/C01O29 - UNKNOWN SUBSET",
$ " (=",A,") -- CONTINUE~~")', SUBSET
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION R01O29(SUBSET,LUNIT,OBS)
C ---> formerly FUNCTION ADC
CHARACTER*(*) SUBSET
CHARACTER*6 C01O29,ADPSUB
DIMENSION OBS(*)
SAVE
C FIND AN ON29/124 DATA TYPE AND CALL A TRANSLATOR
C ------------------------------------------------
R01O29 = 4
ADPSUB = C01O29(SUBSET)
IF(ADPSUB .EQ. 'ADPSFC') R01O29 = R04O29(LUNIT,OBS)
IF(ADPSUB .EQ. 'SFCSHP') R01O29 = R04O29(LUNIT,OBS)
IF(ADPSUB .EQ. 'SFCBOG') R01O29 = R04O29(LUNIT,OBS)
IF(ADPSUB .EQ. 'ADPUPA') R01O29 = R03O29(LUNIT,OBS)
IF(ADPSUB .EQ. 'AIRCFT') R01O29 = R05O29(LUNIT,OBS)
IF(ADPSUB .EQ. 'AIRCAR') R01O29 = R05O29(LUNIT,OBS)
IF(ADPSUB .EQ. 'SATWND') R01O29 = R06O29(LUNIT,OBS)
IF(ADPSUB .EQ. 'SPSSMI') R01O29 = R07O29(LUNIT,OBS)
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
SUBROUTINE S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP)
C ---> Formerly SUBROUTINE O29HDR
COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11)
COMMON/IO29LL/BMISS
CHARACTER*(*) RSV,RSV2
CHARACTER*8 COB,SID,RCT
DIMENSION IHDR(12),RHDR(12),ICATS(50,150,11)
REAL(8) BMISS
EQUIVALENCE (IHDR(1),RHDR(1)),(COB,IOB),(ICATS,RCATS)
SAVE
DATA OMISS/99999/
C INITIALIZE THE UNPACK ARRAY TO MISSINGS
C ---------------------------------------
NCAT = 0
RCATS = OMISS
COB = ' '
ICATS(6,1:149,1) = IOB
ICATS(4,1:149,2) = IOB
ICATS(4,1:149,3) = IOB
ICATS(4,1:149,4) = IOB
ICATS(6,1:149,5) = IOB
ICATS(6,1:149,6) = IOB
ICATS(3,1:149,7) = IOB
ICATS(3,1:149,8) = IOB
C WRITE THE RECEIPT TIME IN CHARACTERS
C ------------------------------------
RCT = '9999 '
IF(RCH*100.LT.2401.AND.RCH*100.GT.-1)
$ WRITE(RCT,'(I4.4)') NINT(RCH*100.)
C STORE THE ON29 HEADER INFORMATION INTO UNP FORMAT
C -------------------------------------------------
RHDR( 1) = OMISS
IF(YOB.LT.BMISS) RHDR( 1) = NINT(100.*YOB)
cppppp
IF(YOB.GE.BMISS) print'(" ~~IW3UNP29/S01O29: ID ",A," has a ",
$ "missing LATITUDE - on29 hdr, word 1 is set to ",G0)',
$ sid,RHDR(1)
cppppp
RHDR( 2) = OMISS
IF(XOB.LT.BMISS) RHDR( 2) = NINT(100.*MOD(720.-XOB,360.))
cppppp
IF(XOB.GE.BMISS) print'(" ~~IW3UNP29/S01O29: ID ",A," has a ",
$ "missing LONGITUDE - on29 hdr, word 2 is set to ",G0)',
$ sid,RHDR(2)
cppppp
RHDR( 3) = OMISS
RHDR( 4) = OMISS
IF(RHR.LT.BMISS) RHDR( 4) = NINT((100.*RHR)+0.0001)
cppppp
IF(RHR.GE.BMISS) print'(" ~~IW3UNP29/S01O29: ID ",A," has a ",
$ "missing OB TIME - on29 hdr, word 4 is set to ",G0)', sid,RHDR(4)
cppppp
IF(RSV2.EQ.' ') THEN
COB = ' '
COB(1:4) = RCT(3:4)//RSV(1:2)
IHDR(5) = IOB
COB = ' '
COB(1:3) = RCT(1:2)//RSV(3:3)
IHDR(6) = IOB
ELSE
COB = ' '
COB(1:4) = RSV2(3:4)//RSV(1:2)
IHDR(5) = IOB
COB = ' '
COB(1:3) = RSV2(1:2)//RSV(3:3)
IHDR(6) = IOB
END IF
RHDR( 7) = NINT(ELV)
IHDR( 8) = ITP
IHDR( 9) = RTP
RHDR(10) = OMISS
COB = ' '
COB(1:4) = SID(1:4)
IHDR(11) = IOB
COB = ' '
COB(1:4) = SID(5:6)//' '
IHDR(12) = IOB
C STORE THE HEADER INTO A HOLDING ARRAY
C -------------------------------------
HDR = RHDR
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
SUBROUTINE S02O29(ICAT,N,*)
C ---> Formerly SUBROUTINE O29CAT
COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11)
COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255),
$ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255),
$ CF8(255)
COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255),
$ QCP(255),QCA(255),Q81(255),Q82(255)
COMMON/IO29GG/PSL,STP,SDR,SSP,STM,DPD,TMX,TMI,HVZ,PRW,PW1,CCN,CHN,
$ CTL,CTM,CTH,HCB,CPT,APT,PC6,SND,P24,DOP,POW,HOW,SWD,
$ SWP,SWH,SST,SPG,SPD,SHC,SAS,WES
COMMON/IO29HH/PSQ,SPQ,SWQ,STQ,DDQ
COMMON/IO29II/PWMIN
COMMON/IO29LL/BMISS
CHARACTER*8 COB,C11,C12
CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,PSQ,SPQ,SWQ,STQ,
$ DDQ
DIMENSION RCAT(50),JCAT(50)
REAL(8) BMISS
EQUIVALENCE (RCAT(1),JCAT(1)),(C11,HDR(11)),(C12,HDR(12)),
$ (COB,IOB)
LOGICAL SURF
SAVE
cppppp-ID
iprint = 0
c if(C11(1:4)//C12(1:2).eq.'59758 ') iprint = 1
c if(C11(1:4)//C12(1:2).eq.'59362 ') iprint = 1
c if(C11(1:4)//C12(1:2).eq.'57957 ') iprint = 1
c if(C11(1:4)//C12(1:2).eq.'74794 ') iprint = 1
c if(C11(1:4)//C12(1:2).eq.'74389 ') iprint = 1
c if(C11(1:4)//C12(1:2).eq.'96801A') iprint = 1
cppppp-ID
SURF = .FALSE.
GOTO 1
C ENTRY POINT SE01O29 FORCES DATA INTO THE SURFACE (FIRST) LEVEL
C --------------------------------------------------------------
ENTRY SE01O29(ICAT,N)
C ---> formerly ENTRY O29SFC
SURF = .TRUE.
C CHECK THE PARAMETERS COMING IN
C ------------------------------
1 KCAT = 0
DO I = 1,11
IF(ICAT.EQ.IKAT(I)) THEN
KCAT = I
GO TO 991
END IF
ENDDO
991 CONTINUE
C PARAMETER ICAT (ON29 CATEGORY) OUT OF BOUNDS RETURNS A 999
C ----------------------------------------------------------
IF(KCAT.EQ.0) THEN
PRINT'(" ##IW3UNP29/S02O29 - ON29 CATEGORY ",I0," OUT OF ",
$ "BOUNDS -- IER = 999")', ICAT
RETURN 1
END IF
C PARAMETER N (LEVEL INDEX) OUT OF BOUNDS RETURNS A 999
C -----------------------------------------------------
IF(N.GT.255) THEN
PRINT'(" ##IW3UNP29/S02O29 - LEVEL INDEX ",I0," EXCEEDS 255 ",
$ "-- IER = 999")', N
RETURN 1
END IF
C MAKE A MISSING LEVEL AND RETURN WHEN N=0 (NOT ALLOWED FOR CAT 01)
C -----------------------------------------------------------------
IF(N.EQ.0) THEN
IF(KCAT.EQ.1) RETURN
NCAT(KCAT) = MIN(149,NCAT(KCAT)+1)
cppppp
if(iprint.eq.1)
$ print'(" To prepare for sfc. data, write all missings on ",
$ "lvl ",I0," for cat ",I0)', ncat(kcat),kcat
cppppp
RETURN
END IF
C FIGURE OUT WHICH LEVEL TO UPDATE AND RESET THE LEVEL COUNTER
C ------------------------------------------------------------
IF(KCAT.EQ.1) THEN
L = I04O29(POB(N)*.1)
IF(L.EQ.999999) GO TO 9999
C BAD MANDATORY LEVEL RETURNS A 999
C ---------------------------------
IF(L.LE.0) THEN
PRINT'(" ##IW3UNP29/S02O29 - BAD MANDATORY LEVEL (P = ",
$ G0,") -- IER = 999")', POB(N)
RETURN 1
END IF
NCAT(KCAT) = MAX(NCAT(KCAT),L)
cppppp
if(iprint.eq.1)
$ print'(" Will write cat. 1 data on lvl ",I0," for cat ",I0,
$ ", - total no. cat. 1 lvls processed so far = ",I0)',
$ L,kcat,ncat(kcat)
cppppp
ELSEIF(SURF) THEN
L = 1
NCAT(KCAT) = MAX(NCAT(KCAT),1)
cppppp
if(iprint.eq.1)
$ print'(" Will write cat. ",I0," SURFACE data on lvl ",I0,
$ ", - total no. cat. ",I0," lvls processed so far = ",I0)',
$ kcat,L,kcat,ncat(kcat)
cppppp
ELSE
L = MIN(149,NCAT(KCAT)+1)
IF(L.EQ.149) THEN
cppppp
print'(" ~~IW3UNP29/S02O29: ID ",A," - This cat. ",I0,
$ " level cannot be processed because the limit has already",
$ " been reached")', c11(1:4)//c12(1:2),kcat
cppppp
RETURN
END IF
NCAT(KCAT) = L
cppppp
if(iprint.eq.1)
$ print'(" Will write cat. ",I0," NON-SFC data on lvl ",I0,
$ ", - total no. cat. ",I0," lvls processed so far = ",I0)',
$ kcat,L,kcat,ncat(kcat)
cppppp
END IF
C EACH CATEGORY NEEDS A SPECIFIC DATA ARRANGEMENT
C -----------------------------------------------
COB = ' '
IF(ICAT.EQ.1) THEN
RCAT(1) = MIN(NINT(ZOB(N)),NINT(RCATS(1,L,KCAT)))
RCAT(2) = MIN(NINT(TOB(N)),NINT(RCATS(2,L,KCAT)))
RCAT(3) = MIN(NINT(QOB(N)),NINT(RCATS(3,L,KCAT)))
RCAT(4) = MIN(NINT(DOB(N)),NINT(RCATS(4,L,KCAT)))
RCAT(5) = MIN(NINT(SOB(N)),NINT(RCATS(5,L,KCAT)))
COB(1:4) = ZQM(N)//TQM(N)//QQM(N)//WQM(N)
JCAT(6) = IOB
ELSEIF(ICAT.EQ.2) THEN
RCAT(1) = MIN(NINT(POB(N)),99999)
RCAT(2) = MIN(NINT(TOB(N)),99999)
RCAT(3) = MIN(NINT(QOB(N)),99999)
COB(1:3) = PQM(N)//TQM(N)//QQM(N)
JCAT(4) = IOB
ELSEIF(ICAT.EQ.3) THEN
RCAT(1) = MIN(NINT(POB(N)),99999)
RCAT(2) = MIN(NINT(DOB(N)),99999)
RCAT(3) = MIN(NINT(SOB(N)),99999)
C MARK THE TROPOPAUSE LEVEL IN CAT. 3
IF(NINT(VSG(N)).EQ.16) PQM(N) = 'T'
C MARK THE MAXIMUM WIND LEVEL IN CAT. 3
IF(NINT(VSG(N)).EQ. 8) THEN
PQM(N) = 'W'
IF(POB(N).EQ.PWMIN) PQM(N) = 'X'
END IF
COB(1:2) = PQM(N)//WQM(N)
JCAT(4) = IOB
ELSEIF(ICAT.EQ.4) THEN
RCAT(1) = MIN(NINT(ZOB(N)),99999)
RCAT(2) = MIN(NINT(DOB(N)),99999)
RCAT(3) = MIN(NINT(SOB(N)),99999)
COB(1:2) = ZQM(N)//WQM(N)
JCAT(4) = IOB
ELSEIF(ICAT.EQ.5) THEN
RCAT(1) = MIN(NINT(POB(N)),99999)
RCAT(2) = MIN(NINT(TOB(N)),99999)
RCAT(3) = MIN(NINT(QOB(N)),99999)
RCAT(4) = MIN(NINT(DOB(N)),99999)
RCAT(5) = MIN(NINT(SOB(N)),99999)
COB(1:4) = PQM(N)//TQM(N)//QQM(N)//WQM(N)
JCAT(6) = IOB
ELSEIF(ICAT.EQ.6) THEN
RCAT(1) = MIN(NINT(ZOB(N)),99999)
RCAT(2) = MIN(NINT(TOB(N)),99999)
RCAT(3) = MIN(NINT(QOB(N)),99999)
RCAT(4) = MIN(NINT(DOB(N)),99999)
RCAT(5) = MIN(NINT(SOB(N)),99999)
COB(1:4) = ZQM(N)//TQM(N)//QQM(N)//WQM(N)
JCAT(6) = IOB
ELSEIF(ICAT.EQ.7) THEN
RCAT(1) = MIN(NINT(CLP(N)),99999)
RCAT(2) = MIN(NINT(CLA(N)),99999)
COB(1:2) = QCP(N)//QCA(N)
JCAT(3) = IOB
ELSEIF(ICAT.EQ.8) THEN
RCAT(1) = MIN(NINT(OB8(N)),99999)
RCAT(2) = MIN(NINT(CF8(N)),99999)
COB(1:2) = Q81(N)//Q82(N)
JCAT(3) = IOB
ELSEIF(ICAT.EQ.51) THEN
RCAT( 1) = MIN(NINT(PSL),99999)
RCAT( 2) = MIN(NINT(STP),99999)
RCAT( 3) = MIN(NINT(SDR),99999)
RCAT( 4) = MIN(NINT(SSP),99999)
RCAT( 5) = MIN(NINT(STM),99999)
RCAT( 6) = MIN(NINT(DPD),99999)
RCAT( 7) = MIN(NINT(TMX),99999)
RCAT( 8) = MIN(NINT(TMI),99999)
COB(1:4) = PSQ//SPQ//SWQ//STQ
JCAT(9) = IOB
COB = ' '
COB(1:1) = DDQ
JCAT(10) = IOB
JCAT(11) = MIN(NINT(HVZ),99999)
JCAT(12) = MIN(NINT(PRW),99999)
JCAT(13) = MIN(NINT(PW1),99999)
JCAT(14) = MIN(NINT(CCN),99999)
JCAT(15) = MIN(NINT(CHN),99999)
JCAT(16) = MIN(NINT(CTL),99999)
JCAT(17) = MIN(NINT(HCB),99999)
JCAT(18) = MIN(NINT(CTM),99999)
JCAT(19) = MIN(NINT(CTH),99999)
JCAT(20) = MIN(NINT(CPT),99999)
RCAT(21) = MIN(ABS(NINT(APT)),99999)
IF(CPT.GE.BMISS.AND.APT.LT.0.)
$ RCAT(21) = MIN(ABS(NINT(APT))+500,99999)
ELSEIF(ICAT.EQ.52) THEN
JCAT( 1) = MIN(NINT(PC6),99999)
JCAT( 2) = MIN(NINT(SND),99999)
JCAT( 3) = MIN(NINT(P24),99999)
JCAT( 4) = MIN(NINT(DOP),99999)
JCAT( 5) = MIN(NINT(POW),99999)
JCAT( 6) = MIN(NINT(HOW),99999)
JCAT( 7) = MIN(NINT(SWD),99999)
JCAT( 8) = MIN(NINT(SWP),99999)
JCAT( 9) = MIN(NINT(SWH),99999)
JCAT(10) = MIN(NINT(SST),99999)
JCAT(11) = MIN(NINT(SPG),99999)
JCAT(12) = MIN(NINT(SPD),99999)
JCAT(13) = MIN(NINT(SHC),99999)
JCAT(14) = MIN(NINT(SAS),99999)
JCAT(15) = MIN(NINT(WES),99999)
ELSE
C UNSUPPORTED CATEGORY RETURNS A 999
C ----------------------------------
PRINT'(" ##IW3UNP29/S02O29 - CATEGORY ",I0," NOT SUPPORTED ",
$ "-- IER = 999")', ICAT
RETURN 1
END IF
C TRANSFER THE LEVEL DATA INTO THE HOLDING ARRAY AND EXIT
C -------------------------------------------------------
DO I = 1,MCAT(KCAT)
RCATS(I,L,KCAT) = RCAT(I)
ENDDO
RETURN
9999 CONTINUE
RETURN 1
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
SUBROUTINE S03O29(UNP,SUBSET,*,*)
C ---> Formerly SUBROUTINE O29UNP
COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11)
DIMENSION RCAT(50),JCAT(50),UNP(*)
CHARACTER*8 SUBSET
EQUIVALENCE (RCAT(1),JCAT(1))
SAVE
C CALL TO SORT CATEGORIES 02, 03, 04, AND 08 LEVELS
C -------------------------------------------------
CALL S04O29
C TRANSFER DATA FROM ALL CATEGORIES INTO UNP ARRAY & SET POINTERS
C ---------------------------------------------------------------
INDX = 43
JCAT = 0
NLEVTO = 0
NLEVC8 = 0
DO K = 1,11
JCAT(2*K+11) = NCAT(K)
IF(K.NE.7.AND.K.NE.8.AND.K.NE.11) THEN
NLEVTO = NLEVTO + NCAT(K)
ELSE IF(K.EQ.8) THEN
NLEVC8 = NLEVC8 + NCAT(K)
END IF
IF(NCAT(K).GT.0) JCAT(2*K+12) = INDX
IF(NCAT(K).EQ.0) JCAT(2*K+12) = 0
DO J = 1,NCAT(K)
DO I = 1,MCAT(K)
C UNPACKED ON29 REPORT CONTAINS MORE THAN 1608 WORDS - RETURNS A 999
C ------------------------------------------------------------------
IF(INDX.GT.1608) THEN
PRINT'(" ##IW3UNP29/S03O29 - UNPKED ON29 RPT CONTAINS ",
$ I0," WORDS, > LIMIT OF 1608 -- IER = 999")', INDX
RETURN 1
END IF
UNP(INDX) = RCATS(I,J,K)
INDX = INDX+1
ENDDO
ENDDO
ENDDO
C RETURN WITHOUT PROCESSING THIS REPORT IF NO DATA IN CAT. 1-6, 51, 52
C (UNLESS SSM/I REPORT, THEN DO NOT RETURN UNLESS ALSO NO CAT. 8 DATA)
C --------------------------------------------------------------------
IF(NLEVTO.EQ.0) THEN
IF(SUBSET(1:5).NE.'NC012') THEN
RETURN 2
ELSE
IF(NLEVC8.EQ.0) RETURN 2
END IF
END IF
C TRANSFER THE HEADER AND POINTER ARRAYS INTO UNP
C -----------------------------------------------
UNP(1:12) = HDR
UNP(13:42) = RCAT(13:42)
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
SUBROUTINE S04O29
C ---> Formerly SUBROUTINE O29SRT
COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11)
cppppp
character*8 c11,c12,sid
cppppp
DIMENSION RCAT(50,150),IORD(150),IWORK(65536),SCAT(50,150),RCTL(3)
cppppp
EQUIVALENCE (C11,HDR(11)),(C12,HDR(12))
cppppp
SAVE
cppppp
sid = c11(1:4)//c12(1:4)
cppppp
C SORT CATEGORIES 2, 3, AND 4 - LEAVE THE FIRST LEVEL IN EACH INTACT
C ------------------------------------------------------------------
DO K=2,4
IF(NCAT(K).GT.1) THEN
DO J=1,NCAT(K)-1
DO I=1,MCAT(K)
SCAT(I,J) = RCATS(I,J+1,K)
ENDDO
ENDDO
CALL ORDERS(2,IWORK,SCAT(1,1),IORD,NCAT(K)-1,50,8,2)
RCTL = 10E9
DO J=1,NCAT(K)-1
IF(K.LT.4) JJ = IORD((NCAT(K)-1)-J+1)
IF(K.EQ.4) JJ = IORD(J)
DO I=1,MCAT(K)
RCAT(I,J) = SCAT(I,JJ)
ENDDO
IDUP = 0
IF(NINT(RCAT(1,J)).EQ.NINT(RCTL(1))) THEN
IF(NINT(RCAT(2,J)).EQ.NINT(RCTL(2)).AND.
$ NINT(RCAT(3,J)).EQ.NINT(RCTL(3))) THEN
cppppp
if(k.ne.4) then
print'(" ~~@@IW3UNP29/S04O29: ID ",A," has a ",
$ "dupl. cat. ",I0," lvl (all data) at ",G0," mb -- lvl will be ",
$ "excluded from processing")', sid,k,rcat(1,j)*.1
else
print'(" ~~@@IW3UNP29/S04O29: ID ",A," has a ",
$ "dupl. cat. ",I0," lvl (all data) at ",G0," m -- lvl will be ",
$ "excluded from processing")', sid,k,rcat(1,j)
end if
cppppp
IDUP = 1
ELSE
cppppp
if(k.ne.4) then
print'(" ~~@@#IW3UNP29/S04O29: ID ",A," has a ",
$ "dupl. cat. ",I0," press. lvl (data differ) at ",G0," mb -- lvl",
$ " will NOT be excluded")', sid,k,rcat(1,j)*.1
else
print'(" ~~@@#IW3UNP29/S04O29: ID ",A," has a ",
$ "dupl. cat. ",I0," height lvl (data differ) at ",G0," m -- lvl ",
$ "will NOT be excluded")', sid,k,rcat(1,j)
end if
cppppp
END IF
END IF
RCTL = RCAT(1:3,J)
IF(IDUP.EQ.1) RCAT(1,J) = 10E8
ENDDO
JJJ = 1
DO J=2,NCAT(K)
IF(RCAT(1,J-1).GE.10E8) GO TO 887
JJJ = JJJ + 1
DO I=1,MCAT(K)
RCATS(I,JJJ,K) = RCAT(I,J-1)
ENDDO
887 CONTINUE
ENDDO
cppppp
if(jjj.ne.NCAT(K))
$ print'(" ~~@@IW3UNP29/S04O29: ID ",A," has had ",I0,
$ " lvls removed due to their being duplicates")',
$ sid,NCAT(K)-jjj
cppppp
ncat(k) = jjj
end if
IF(NCAT(K).EQ.1) THEN
IF(MIN(RCATS(1,1,K),RCATS(2,1,K),RCATS(3,1,K)).GT.99998.8)
$ NCAT(K) = 0
END IF
ENDDO
C SORT CATEGORY 08 BY CODE FIGURE
C -------------------------------
DO K=8,8
IF(NCAT(K).GT.1) THEN
CALL ORDERS(2,IWORK,RCATS(2,1,K),IORD,NCAT(K),50,8,2)
DO J=1,NCAT(K)
DO I=1,MCAT(K)
RCAT(I,J) = RCATS(I,IORD(J),K)
ENDDO
ENDDO
DO J=1,NCAT(K)
DO I=1,MCAT(K)
RCATS(I,J,K) = RCAT(I,J)
ENDDO
ENDDO
END IF
ENDDO
C NORMAL EXIT
C -----------
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
SUBROUTINE S05O29
C ---> Formerly SUBROUTINE O29INX
COMMON/IO29EE/OBS(255,11)
COMMON/IO29FF/QMS(255,9)
COMMON/IO29GG/SFO(34)
COMMON/IO29HH/SFQ(5)
COMMON/IO29LL/BMISS
CHARACTER*1 QMS,SFQ
REAL(8) BMISS
SAVE
C SET THE INPUT DATA ARRAYS TO MISSING OR BLANK
C ---------------------------------------------
OBS = BMISS
QMS = ' '
SFO = BMISS
SFQ = ' '
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION I04O29(P)
C ---> formerly FUNCTION MANO29
COMMON/IO29JJ/ISET,MANLIN(1001)
SAVE
IF(ISET.EQ.0) THEN
MANLIN = 0
MANLIN(1000) = 1
MANLIN(850) = 2
MANLIN(700) = 3
MANLIN(500) = 4
MANLIN(400) = 5
MANLIN(300) = 6
MANLIN(250) = 7
MANLIN(200) = 8
MANLIN(150) = 9
MANLIN(100) = 10
MANLIN(70) = 11
MANLIN(50) = 12
MANLIN(30) = 13
MANLIN(20) = 14
MANLIN(10) = 15
MANLIN(7) = 16
MANLIN(5) = 17
MANLIN(3) = 18
MANLIN(2) = 19
MANLIN(1) = 20
ISET = 1
END IF
IP = NINT(P*10.)
IF(IP.GT.10000 .OR. IP.LT.10 .OR. MOD(IP,10).NE.0) THEN
I04O29 = 0
ELSE
I04O29 = MANLIN(IP/10)
END IF
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION R02O29()
C ---> formerly FUNCTION ONFUN
COMMON/IO29LL/BMISS
CHARACTER*8 SUBSET,RPID
LOGICAL L02O29,L03O29
INTEGER KKK(0:99),KKKK(49)
REAL(8) BMISS
SAVE
DATA GRAV/9.8/,CM2K/1.94/,TZRO/273.15/
DATA KKK /5*90,16*91,30*92,49*93/
DATA KKKK/94,2*95,6*96,10*97,30*98/
PRS1(Z) = 1013.25 * (((288.15 - (.0065 * Z))/288.15)**5.256)
PRS2(Z) = 226.3 * EXP(1.576106E-4 * (11000. - Z))
PRS3(PMND,TEMP,Z,ZMND)
$ = PMND * (((TEMP - (.0065 * (Z - ZMND)))/TEMP)**5.256)
ES(T) = 6.1078 * EXP((17.269 * (T-273.16))/((T-273.16)+237.3))
QFRMTP(T,PPPP) = (0.622 * ES(T))/(PPPP-(0.378 * ES(T)))
HGTF(P) = (1.-(P/1013.25)**(1./5.256))*(288.15/.0065)
R02O29 = 0
RETURN
ENTRY E01O29(PRS)
C ---> formerly ENTRY ONPRS
IF(PRS.LT.BMISS) E01O29 = NINT(PRS*.1)
IF(PRS.GE.BMISS) E01O29 = BMISS
RETURN
ENTRY E37O29(PMND,TEMP,HGT,ZMND,TQM)
C ---> formerly ENTRY ONPFHT
IF(HGT.GE.BMISS) THEN
E37O29 = BMISS
ELSE
IF(HGT.LE.11000) THEN
P = PRS1(HGT)
ELSE
P = PRS2(HGT)
END IF
IF(MAX(PMND,ZMND).GE.BMISS) THEN
E37O29 = P
RETURN
END IF
IF(TEMP.GE.9999.) TEMP = BMISS
IF(TQM.GE.BMISS) TQM = 2
IF(TEMP.GE.BMISS.OR.TQM.GE.4) CALL W3FA03(P,D1,TEMP,D2)
Q = QFRMTP(TEMP,P)
TVIRT = TEMP * (1.0 + (0.61 * Q))
E37O29 = PRS3(PMND,TVIRT,HGT,ZMND)
END IF
RETURN
ENTRY E03O29(PRS)
C ---> formerly ENTRY ONHFP
IF(PRS.LT.BMISS) E03O29 = HGTF(PRS)
IF(PRS.GE.BMISS) E03O29 = BMISS
RETURN
ENTRY E04O29(WDR,WSP)
C ---> formerly ENTRY ONWDR
E04O29 = WDR
RETURN
ENTRY E05O29(WDR,WSP)
C ---> formerly ENTRY ONWSP
IF(WSP.LT.BMISS) THEN
E05O29 = (WSP*CM2K)
E05O29 = E05O29 + 0.0000001
ELSE
E05O29 = BMISS
END IF
RETURN
ENTRY E06O29(TMP)
C ---> formerly ENTRY ONTMP
ITMP = NINT(TMP*100.)
ITZRO = NINT(TZRO*100.)
IF(TMP.LT.BMISS) E06O29 = NINT((ITMP - ITZRO)*0.1)
IF(TMP.GE.BMISS) E06O29 = BMISS
RETURN
ENTRY E07O29(DPD,TMP)
C ---> formerly ENTRY ONDPD
IF(DPD.LT.BMISS .AND. TMP.LT.BMISS) E07O29 = (TMP-DPD)*10.
IF(DPD.GE.BMISS .OR. TMP.GE.BMISS) E07O29 = BMISS
RETURN
ENTRY E08O29(HGT)
C ---> formerly ENTRY ONHGT
E08O29 = HGT
IF(HGT.LT.BMISS) E08O29 = (HGT/GRAV)
RETURN
ENTRY E09O29(HVZ)
C ---> formerly ENTRY ONHVZ
IF(HVZ.GE.BMISS.OR.HVZ.LT.0.) THEN
E09O29 = BMISS
ELSE IF(NINT(HVZ).LT.6000) THEN
E09O29 = MIN(INT(NINT(HVZ)/100),50)
ELSE IF(NINT(HVZ).LT.30000) THEN
E09O29 = INT(NINT(HVZ)/1000) + 50
ELSE IF(NINT(HVZ).LE.70000) THEN
E09O29 = INT(NINT(HVZ)/5000) + 74
ELSE
E09O29 = 89
END IF
RETURN
ENTRY E10O29(PRW)
C ---> formerly ENTRY ONPRW
E10O29 = BMISS
IF(PRW.LT.BMISS) E10O29 = NINT(MOD(PRW,100.))
RETURN
ENTRY E11O29(PAW)
C ---> formerly ENTRY ONPAW
E11O29 = BMISS
IF(PAW.LT.BMISS) E11O29 = NINT(MOD(PAW,10.))
RETURN
ENTRY E12O29(CCN)
C ---> formerly ENTRY ONCCN
IF(NINT(CCN).EQ.0) THEN
E12O29 = 0
ELSE IF(CCN.LT. 15) THEN
E12O29 = 1
ELSE IF(CCN.LT. 35) THEN
E12O29 = 2
ELSE IF(CCN.LT. 45) THEN
E12O29 = 3
ELSE IF(CCN.LT. 55) THEN
E12O29 = 4
ELSE IF(CCN.LT. 65) THEN
E12O29 = 5
ELSE IF(CCN.LT. 85) THEN
E12O29 = 6
ELSE IF(CCN.LT.100) THEN
E12O29 = 7
ELSE IF(NINT(CCN).EQ.100) THEN
E12O29 = 8
ELSE
E12O29 = BMISS
END IF
RETURN
ENTRY E13O29(CLA)
C ---> formerly ENTRY ONCLA
E13O29 = BMISS
IF(CLA.EQ.0) E13O29 = 0
IF(CLA.EQ.1) E13O29 = 5
IF(CLA.EQ.2) E13O29 = 25
IF(CLA.EQ.3) E13O29 = 40
IF(CLA.EQ.4) E13O29 = 50
IF(CLA.EQ.5) E13O29 = 60
IF(CLA.EQ.6) E13O29 = 75
IF(CLA.EQ.7) E13O29 = 95
IF(CLA.EQ.8) E13O29 = 100
RETURN
ENTRY E14O29(CCL,CCM)
C ---> formerly ENTRY ONCHN
E14O29 = CCL
IF(NINT(E14O29).EQ.0) E14O29 = CCM
IF(NINT(E14O29).LT.10) RETURN
IF(NINT(E14O29).EQ.10) THEN
E14O29 = 9.
ELSE IF(NINT(E14O29).EQ.15) THEN
E14O29 = 10.
ELSE
E14O29 = BMISS
END IF
RETURN
ENTRY E15O29(CTLMH)
C ---> formerly ENTRY ONCTL, ONCTM, ONCTH
E15O29 = CTLMH
RETURN
ENTRY E18O29(CHL,CHM,CHH,CTL,CTM,CTH)
C ---> formerly ENTRY ONHCB
IF(NINT(MAX(CTL,CTM,CTH)).EQ.0) THEN
E18O29 = 9
RETURN
END IF
E18O29 = BMISS
IF(CHH.LT.BMISS) E18O29 = CHH
IF(CHM.LT.BMISS) E18O29 = CHM
IF(CHL.LT.BMISS) E18O29 = CHL
IF(E18O29.GE.BMISS.OR.E18O29.LT.0) RETURN
IF(E18O29.LT. 150) THEN
E18O29 = 0
ELSE IF(E18O29.LT. 350) THEN
E18O29 = 1
ELSE IF(E18O29.LT. 650) THEN
E18O29 = 2
ELSE IF(E18O29.LT. 950) THEN
E18O29 = 3
ELSE IF(E18O29.LT.1950) THEN
E18O29 = 4
ELSE IF(E18O29.LT.3250) THEN
E18O29 = 5
ELSE IF(E18O29.LT.4950) THEN
E18O29 = 6
ELSE IF(E18O29.LT.6750) THEN
E18O29 = 7
ELSE IF(E18O29.LT.8250) THEN
E18O29 = 8
ELSE
E18O29 = 9
END IF
RETURN
ENTRY E19O29(CPT)
C ---> formerly ENTRY ONCPT
E19O29 = BMISS
IF(NINT(CPT).GT.-1.AND.NINT(CPT).LT.9) E19O29 = CPT
RETURN
ENTRY E20O29(PRC)
C ---> formerly ENTRY ONPRC
E20O29 = PRC
IF(PRC.LT.0.) THEN
E20O29 = 9998
ELSE IF(PRC.LT.BMISS) THEN
E20O29 = NINT(PRC*3.937)
END IF
RETURN
ENTRY E21O29(SND)
C ---> formerly ENTRY ONSND
E21O29 = SND
IF(SND.LT.0.) THEN
E21O29 = 998
ELSE IF(SND.LT.BMISS) THEN
E21O29 = NINT(SND*39.37)
END IF
RETURN
ENTRY E22O29(PC6)
C ---> formerly ENTRY ONDOP
E22O29 = BMISS
IF(PC6.LT.BMISS) E22O29 = 1
RETURN
ENTRY E23O29(PER)
C ---> formerly ENTRY ONPOW, ONSWP
E23O29 = NINT(PER)
RETURN
ENTRY E24O29(HGT)
C ---> formerly ENTRY ONHOW, ONSWH
E24O29 = HGT
IF(HGT.LT.BMISS) E24O29 = NINT(2.*HGT)
RETURN
ENTRY E25O29(SWD)
C ---> formerly ENTRY ONSWD
E25O29 = SWD
IF(SWD.EQ.0) THEN
E25O29 = 0
ELSE IF(SWD.LT.5) THEN
E25O29 = 36
ELSE IF(SWD.LT.BMISS) THEN
E25O29 = NINT((SWD+.001)*.1)
END IF
RETURN
ENTRY E28O29(SPG)
C ---> formerly ENTRY ONSPG
E28O29 = SPG
RETURN
ENTRY E29O29(SPD)
C ---> formerly ENTRY ONSPD
E29O29 = SPD
RETURN
ENTRY E30O29(SHC)
C ---> formerly ENTRY ONSHC
E30O29 = BMISS
IF(NINT(SHC).GT.-1.AND.NINT(SHC).LT.9) E30O29 = NINT(SHC)
RETURN
ENTRY E31O29(SAS)
C ---> formerly ENTRY ONSAS
E31O29 = BMISS
IF(NINT(SAS).GT.-1.AND.NINT(SAS).LT.10) E31O29 = NINT(SAS)
RETURN
ENTRY E32O29(WES)
C ---> formerly ENTRY ONWES
E32O29 = WES
RETURN
ENTRY E33O29(SUBSET,RPID)
C ---> formerly ENTRY ONRTP
E33O29 = BMISS
IF(SUBSET(1:5).EQ.'NC000'.AND.L02O29(RPID) ) E33O29 = 511
IF(SUBSET(1:5).EQ.'NC000'.AND.L03O29(RPID) ) E33O29 = 512
IF(SUBSET.EQ.'NC001001'.AND.RPID.NE.'SHIP') E33O29 = 522
IF(SUBSET.EQ.'NC001001'.AND.RPID.EQ.'SHIP') E33O29 = 523
IF(SUBSET.EQ.'NC001002') E33O29 = 562
IF(SUBSET.EQ.'NC001003') E33O29 = 561
IF(SUBSET.EQ.'NC001004') E33O29 = 531
IF(SUBSET.EQ.'NC001006') E33O29 = 551
IF(SUBSET.EQ.'NC002001') THEN
C LAND RADIOSONDE - FIXED
C -----------------------
E33O29 = 011
IF(L03O29(RPID)) E33O29 = 012
IF(RPID(1:4).EQ.'CLAS') E33O29 = 013
END IF
IF(SUBSET.EQ.'NC002002') THEN
C LAND RADIOSONDE - MOBILE
C ------------------------
E33O29 = 013
END IF
IF(SUBSET.EQ.'NC002003') THEN
C SHIP RADIOSONDE
C ---------------
E33O29 = 022
IF(RPID(1:4).EQ.'SHIP') E33O29 = 023
END IF
IF(SUBSET.EQ.'NC002004') THEN
C DROPWINSONDE
C -------------
E33O29 = 031
END IF
IF(SUBSET.EQ.'NC002005') THEN
C PIBAL
C -----
E33O29 = 011
IF(L03O29(RPID)) E33O29 = 012
END IF
IF(SUBSET.EQ.'NC004001') E33O29 = 041
IF(SUBSET.EQ.'NC004002') E33O29 = 041
IF(SUBSET.EQ.'NC004003') E33O29 = 041
IF(SUBSET.EQ.'NC004004') E33O29 = 041
IF(SUBSET.EQ.'NC004005') E33O29 = 031
IF(SUBSET(1:5).EQ.'NC005') E33O29 = 063
RETURN
ENTRY E34O29(HGT,Z100)
C ---> formerly ENTRY ONFIX
C - With Jeff Ator's fix on 1/30/97, don't need this anymore
cdak HGT0 = HGT
cdak IF(MOD(NINT(HGT),300).EQ.0.OR.MOD(NINT(HGT),500).EQ.0)
cdak $ HGT = HGT * 1.016
C ALL WINDS-BY-HEIGHT HEIGHTS ARE TRUNCATED DOWN TO THE NEXT
C 10 METER LEVEL IF PART DD (ABOVE 100 MB LEVEL) (ON29 CONVENTION)
C -----------------------------------------------------------------
IF(HGT.GT.Z100) THEN
IF(MOD(NINT(HGT),10).NE.0) HGT = INT(HGT/10.) * 10
E34O29 = NINT(HGT)
ELSE
C - With Jeff Ator's fix on 1/30/97, don't need this anymore
cdak IF(HGT.NE.HGT0) THEN
cdak IF(MOD(NINT(HGT0),1500).EQ.0) HGT = HGT - 1.0
cdak ELSE
IF(MOD(NINT(HGT/1.016),1500).EQ.0) HGT = NINT(HGT - 1.0)
cdak END IF
E34O29 = INT(HGT)
END IF
RETURN
ENTRY E38O29(HVZ)
IF(HVZ.GE.BMISS.OR.HVZ.LT.0.) THEN
E38O29 = BMISS
ELSE IF(NINT(HVZ).LT.1000) THEN
KK = MIN(INT(NINT(HVZ)/10),99)
E38O29 = KKK(KK)
ELSE IF(NINT(HVZ).LT.50000) THEN
KK = MIN(INT(NINT(HVZ)/1000),49)
E38O29 = KKKK(KK)
ELSE
E38O29 = 99
END IF
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION C02O29()
C ---> formerly FUNCTION ONCHR
CHARACTER*8 C02O29,E35O29,E36O29
CHARACTER*1 CPRT(0:11),CMR29(0:15)
SAVE
C (NOTE: Prior to mid-March 1999, a purge or reject flag on pressure
C was set to 6 (instead of 14 or 12, resp.) to get around the
C 3-bit limit to ON29 pressure q.m. mnemonic "QMPR". The 3-bit
C limit on "QMPR" was changed to 4-bits with a decoder change
C in February 1999. However, the codes that write the q.m.'s
C out (EDTBUFR and QUIPC) were not changed to write out 14 or
C 12 for purge or reject until mid-March 1999. In order to
C allow old runs to work properly, a q.m. of 6 will continue
C to be interpreted as a "P". This would have to change if
C q.m.=6 ever has a defined meaning.)
C Code Table Value: 0 1 2 3 4 5 6 7
DATA CMR29 /'H','A',' ','Q','C','F','P','F',
C Code Table Value: 8 9 10 11 12 13 14 15
. 'F','F','O','B','R','F','P','F'/
DATA CPRT /' ',' ',' ',' ','A','B','C','D','I','J','K','L'/
C02O29 = ' '
RETURN
ENTRY E35O29(QMK)
C ---> formerly ENTRY ONQMK
IF(QMK.GE.0 .AND. QMK.LE.15) E35O29 = CMR29(NINT(QMK))
IF(QMK.LT.0 .OR. QMK.GT.15) E35O29 = ' '
RETURN
ENTRY E36O29(NPRT)
C ---> formerly ENTRY ONPRT
E36O29 = ' '
IF(NPRT.LT.12) E36O29 = CPRT(NPRT)//' '
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION L01O29()
C ---> formerly FUNCTION ONLOG
CHARACTER*8 RPID
LOGICAL L01O29,L02O29,L03O29
SAVE
L01O29 = .TRUE.
RETURN
ENTRY L02O29(RPID)
C ---> formerly ENTRY ONBKS
L02O29 = .FALSE.
READ(RPID,'(I5)',ERR=1) IBKS
L02O29 = .TRUE.
1 RETURN
ENTRY L03O29(RPID)
C ---> formerly ENTRY ONCAL
L03O29 = .TRUE.
READ(RPID,'(I5)',ERR=2) IBKS
L03O29 = .FALSE.
2 RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION R03O29(LUNIT,OBS)
C ---> formerly FUNCTION ADPUPA
COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11)
COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255),
$ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255),
$ CF8(255)
COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255),
$ QCP(255),QCA(255),Q81(255),Q82(255)
COMMON/IO29CC/SUBSET,IDAT10
COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI
COMMON/IO29II/PWMIN
COMMON/IO29LL/BMISS
CHARACTER*80 HDSTR,LVSTR,QMSTR,RCSTR
CHARACTER*8 SUBSET,SID,E35O29,E36O29,RSV,RSV2
CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,PQML
REAL(8) RID_8,HDR_8(12),VSG_8(255)
REAL(8) RCT_8(5,255),ARR_8(10,255)
REAL(8) RAT_8(255),RMORE_8(4),RGP10_8(255),RPMSL_8,RPSAL_8
REAL(8) BMISS
INTEGER IHBLCS(0:9)
DIMENSION OBS(*),RCT(5,255),ARR(10,255)
DIMENSION RAT(255),RMORE(4),RGP10(255)
DIMENSION P2(255),P8(255),P16(255)
EQUIVALENCE (RID_8,SID)
LOGICAL L02O29
SAVE
DATA HDSTR/'NULL CLON CLAT HOUR MINU SELV '/
DATA LVSTR/'PRLC TMDP TMDB GP07 GP10 WDIR WSPD '/
DATA QMSTR/'QMPR QMAT QMDD QMGP QMWN '/
DATA RCSTR/'RCHR RCMI RCTS '/
DATA IHBLCS/25,75,150,250,450,800,1250,1750,2250,2500/
PRS1(Z) = 1013.25 * (((288.15 - (.0065 * Z))/288.15)**5.256)
PRS2(Z) = 226.3 * EXP(1.576106E-4 * (11000. - Z))
C CHECK IF THIS IS A PREPBUFR FILE
C --------------------------------
R03O29 = 99
c#V#V#dak - future
cdak IF(SUBSET.EQ.'ADPUPA') R03O29 = PRPUPA(LUNIT,OBS)
caaaaadak - future
IF(R03O29.NE.99) RETURN
R03O29 = 0
CALL S05O29
C VERTICAL SIGNIFICANCE DESCRIPTOR TO ASSIGN ON29 CATEGORY
C --------------------------------------------------------
C NOTE: MNEMONIC "VSIG" 008001 IS DEFINED AS VERTICAL SOUNDING
C SIGNIFICANCE -- CODE TABLE FOLLOWS:
C 64 Surface
C processed as ON29 category 2 and/or 3 and/or 4
C 32 Standard (mandatory) level
C processed as ON29 category 1
C 16 Tropopause level
C processed as ON29 category 5
C 8 Maximum wind level
C processed as ON29 category 3 or 4
C 4 Significant level, temperature
C processed as ON29 category 2
C 2 Significant level, wind
C processed as ON29 category 3 or 4
C 1 ???????????????????????
C processed as ON29 category 6
C
C anything else - the level is not processed
CALL UFBINT(LUNIT,VSG_8,1,255,NLEV,'VSIG');VSG=VSG_8
C PUT THE HEADER INFORMATION INTO ON29 FORMAT
C -------------------------------------------
CALL UFBINT(LUNIT,HDR_8,12, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:)
IF(HDR(5).GE.BMISS) HDR(5) = 0
CALL UFBINT(LUNIT,RID_8,1,1,IRET,'RPID')
IF(IRET.NE.1) SID = 'MISSING '
cppppp-ID
iprint = 0
c if(sid.eq.'59758 ') iprint = 1
c if(sid.eq.'61094 ') iprint = 1
c if(sid.eq.'62414 ') iprint = 1
c if(sid.eq.'59362 ') iprint = 1
c if(sid.eq.'57957 ') iprint = 1
c if(sid.eq.'74794 ') iprint = 1
c if(sid.eq.'74389 ') iprint = 1
c if(sid.eq.'96801A ') iprint = 1
if(iprint.eq.1)
$ print'(" @@@ START DIAGNOSTIC PRINTOUT FOR ID ",A)', sid
cppppp-ID
IRECCO = 0
CALL UFBINT(LUNIT,RPMSL_8,1, 1,IRET,'PMSL');RPMSL=RPMSL_8
IF(SUBSET.EQ.'NC004005') THEN
CALL UFBINT(LUNIT,RGP10_8,1,255,NLEV,'GP10');RGP10=RGP10_8
CALL UFBINT(LUNIT,RPSAL_8,1,1,IRET,'PSAL');RPSAL=RPSAL_8
IF(NINT(VSG(1)).EQ.32.AND.RPMSL.GE.BMISS.AND.
$ MAX(RGP10(1),RPSAL).LT.BMISS) THEN
cppppp
cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 1 type ",
cdak $ "Flight-level RECCO")', sid
cppppp
IRECCO = 1
ELSE IF(MIN(VSG(1),RPMSL,RGP10(1)).GE.BMISS.AND.RPSAL.LT.
$ BMISS)
$ THEN
cppppp
cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 6 type ",
cdak $ "Flight-level RECCO (but reformatted into cat. 2/3)")', sid
cppppp
IRECCO = 6
ELSE IF(MIN(VSG(1),RGP10(1)).GE.BMISS.AND.MAX(RPMSL,RPSAL)
$ .LT.BMISS) THEN
cppppp
cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 2/3 type ",
cdak $ "Flight-level RECCO with valid PMSL")', sid
cppppp
IRECCO = 23
ELSE
cppppp
print'(" ~~IW3UNP29/R03O29: ID ",A," is currently an ",
$ "unknown type of Flight-level RECCO - VSIG =",G0,
$ "; PMSL =",G0,"; GP10 =",G0," -- SKIP IT for now")',
$ sid,VSG(1),RPMSL,RGP10(1)
R03O29 = -9999
KSKUPA =KSKUPA + 1
RETURN
cppppp
END IF
END IF
XOB = HDR(2)
YOB = HDR(3)
RHR = BMISS
IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60.
RCH = BMISS
RSV = '999 '
ELV = HDR(6)
IF(IRECCO.GT.0) THEN
RPSAL = RPSAL + SIGN(0.0000001,RPSAL)
ELV = RPSAL
END IF
CALL UFBINT(LUNIT,RAT_8, 1,255,NLEV,'RATP');RAT=RAT_8
ITP = MIN(99,NINT(RAT(1)))
RTP = E33O29(SUBSET,SID)
IF(ELV.GE.BMISS) THEN
cppppp
print'(" IW3UNP29/R03O29: ID ",A," has a missing elev, so ",
$ "elevation set to ZERO")', sid
cppppp
IF((RTP.GT.20.AND.RTP.LT.24).OR.SUBSET.EQ.'NC002004') ELV = 0
END IF
cdak if(sid(5:5).eq.' ') print'(A)', sid
IF(L02O29(SID).AND.SID(5:5).EQ.' ') SID = '0'//SID
RSV2 = ' '
CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP)
C PUT THE LEVEL DATA INTO ON29 UNITS
C ----------------------------------
CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8
PWMIN = 999999.
JLV = 2
IF(IRECCO.EQ.6) JLV = 1
IF(IRECCO.GT.0.AND.NLEV.EQ.1) THEN
VSG(JLV) = 4
VSG(JLV+1) = 2
QOB(JLV) = E07O29(ARR(2,1),ARR(3,1))
TOB(JLV) = E06O29(ARR(3,1))
ARR(2,1) = BMISS
ARR(3,1) = BMISS
DOB(JLV+1) = E04O29(ARR(6,1),ARR(7,1))
SOB(JLV+1) = E05O29(ARR(6,1),ARR(7,1))
IF(NINT(DOB(JLV+1)).EQ.0.AND.NINT(SOB(JLV+1)).GT.0)
$ DOB(JLV+1) = 360.
IF(NINT(DOB(JLV+1)).EQ.360.AND.NINT(SOB(JLV+1)).EQ.0)
$ DOB(JLV+1) = 0.
ARR(6,1) = BMISS
ARR(7,1) = BMISS
IF(IRECCO.EQ.23) THEN
VSG(1) = 64
ARR(1,1) = RPMSL
END IF
END IF
IF(IRECCO.EQ.6) GO TO 4523
DO L=1,NLEV
POB(L) = E01O29(ARR(1,L))
IF(NINT(ARR(1,L)).LE.0) THEN
POB(L) = BMISS
cppppp
print'(" ~~@@IW3UNP29/R03O29: ID ",A," has a ZERO or ",
$ "negative reported pressure that is reset to missing")',
$ sid
cppppp
END IF
QOB(L) = E07O29(ARR(2,L),ARR(3,L))
TOB(L) = E06O29(ARR(3,L))
ZOB(L) = MIN(E08O29(ARR(4,L)),E08O29(ARR(5,L)))
cppppp
if(iprint.eq.1) then
if(irecco.gt.0) print'(" At lvl=",I0,"; orig. ZOB = ",G0)',
$ L,zob(L)
end if
cppppp
IF(IRECCO.EQ.1) THEN
IF(MOD(NINT(ZOB(L)),10).NE.0) ZOB(L) = INT(ZOB(L)/10.) * 10
ZOB(L) = NINT(ZOB(L))
ELSEIF(IRECCO.EQ.23) THEN
ZOB(L) = 0
END IF
DOB(L) = E04O29(ARR(6,L),ARR(7,L))
SOB(L) = E05O29(ARR(6,L),ARR(7,L))
IF(NINT(DOB(L)).EQ.0.AND.NINT(SOB(L)).GT.0) DOB(L) = 360.
IF(NINT(DOB(L)).EQ.360.AND.NINT(SOB(L)).EQ.0) DOB(L) = 0.
cppppp
if(iprint.eq.1) then
print'(" At lvl=",I0,"; VSG=",G0,"; POB = ",G0,"; QOB = ",G0,
$ "; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,"; final SOB ",
$ "(kts) = ",G0,"; origl SOB (mps) = ",G0)',
$ L,vsg(L),pob(L),qob(L),tob(L),zob(L),dob(L),sob(L),arr(7,L)
end if
cppppp
IF(IRECCO.EQ.0.AND.MAX(POB(L),DOB(L),SOB(L)).LT.BMISS)
$ PWMIN=MIN(PWMIN,POB(L))
ENDDO
4523 CONTINUE
MLEV = NLEV
CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8
IF(IRECCO.GT.0.AND.MLEV.EQ.1) THEN
POB1 = BMISS
IF(POB(1).LT.BMISS) POB1 = POB(1) * 0.1
TOB1 = BMISS
IF(TOB(JLV).LT.BMISS) TOB1 = (TOB(JLV) * 0.1) + 273.15
RPS1 = RPSAL
ZOB1 = ZOB(1)
TQM1 = ARR(3,1)
POB(JLV)=NINT(E37O29(POB1,TOB1,RPS1,ZOB1,TQM1)) * 10
POB(JLV+1) = POB(JLV)
cppppp
if(iprint.eq.1) then
do L=JLV,JLV+1
print'(" At lvl=",I0,"; VSG=",G0,"; POB = ",G0,"; QOB = ",
$ G0,"; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,"; SOB = ",
$ G0)', L,vsg(L),pob(L),qob(L),tob(L),zob(L),dob(L),sob(L)
enddo
end if
cppppp
END IF
IF(IRECCO.GT.0.AND.NLEV.EQ.1) THEN
PQM(JLV) = 'E'
PQM(JLV+1) = 'E'
TQM(JLV) = E35O29(ARR(2,1))
ARR(2,1) = BMISS
QQM(JLV) = E35O29(ARR(3,1))
ARR(3,1) = BMISS
ARR(4,1) = 3
WQM(JLV+1) = E35O29(ARR(5,1))
ARR(5,1) = BMISS
END IF
IF(IRECCO.EQ.6) GO TO 4524
DO L=1,NLEV
PQM(L) = E35O29(ARR(1,L))
TQM(L) = E35O29(ARR(2,L))
QQM(L) = E35O29(ARR(3,L))
ZQM(L) = E35O29(ARR(4,L))
WQM(L) = E35O29(ARR(5,L))
ENDDO
4524 CONTINUE
IF(IRECCO.GT.0.AND.NLEV.EQ.1) NLEV = JLV + 1
C SURFACE DATA MUST GO FIRST
C --------------------------
CALL S02O29(2,0,*9999)
CALL S02O29(3,0,*9999)
CALL S02O29(4,0,*9999)
INDX2 = 0
INDX8 = 0
INDX16 = 0
P2 = BMISS
P8 = BMISS
P16 = BMISS
DO L=1,NLEV
IF(NINT(VSG(L)).EQ.64) THEN
cppppp
if(iprint.eq.1) then
print'(" Lvl=",L," is a surface level")'
end if
if(iprint.eq.1.and.POB(L).LT.BMISS.AND.(TOB(L).LT.BMISS.OR.IRECCO
$ .EQ.23)) then
print'(" --> valid cat. 2 sfc. lvl ")'
end if
cppppp
IF(POB(L).LT.BMISS.AND.(TOB(L).LT.BMISS.OR.IRECCO.EQ.23))
$ CALL SE01O29(2,L)
cppppp
if(iprint.eq.1.and.POB(L).LT.BMISS.AND.(DOB(L).LT.BMISS.OR.IRECCO
$ .EQ.23)) then
print'(" --> valid cat. 3 sfc. lvl ")'
end if
cppppp
IF(POB(L).LT.BMISS.AND.(DOB(L).LT.BMISS.OR.IRECCO.EQ.23))
$ CALL SE01O29(3,L)
IF(ZOB(L).LT.BMISS.AND.DOB(L).LT.BMISS) THEN
cppppp
if(iprint.eq.1) print'(" --> valid cat. 4 sfc. lvl ")'
cppppp
C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
C -----------------------------------------------------------------
ZQM(L) = ' '
CALL SE01O29(4,L)
END IF
VSG(L) = 0
ELSE IF(NINT(VSG(L)).EQ.2) THEN
P2(L) = POB(L)
INDX2 = L
IF(INDX8.GT.0) THEN
DO II = 1,INDX8
IF(POB(L).EQ.P8(II).AND.POB(L).LT.BMISS) THEN
cppppp
if(iprint.eq.1) then
print'(" ## This cat. 3 level, on lvl ",I0,
$ " will have already been processed as a cat. 3 ",
$ "MAX wind lvl (on lvl ",I0,") - skip this Cat. ",
$ "3 lvl")', L,II
end if
cppppp
IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN
SOB(II) = SOB(L)
DOB(II) = DOB(L)
cppppp
if(iprint.eq.1) then
print'(" ...... also on lvl ",I0," - transfer",
$ " wind data to dupl. MAX wind lvl because its ",
$ "missing there")', L
end if
cppppp
END IF
VSG(L) = 0
GO TO 7732
END IF
ENDDO
END IF
ELSE IF(NINT(VSG(L)).EQ.8) THEN
P8(L) = POB(L)
INDX8 = L
IF(INDX2.GT.0) THEN
DO II = 1,INDX2
IF(POB(L).EQ.P2(II).AND.POB(L).LT.BMISS) THEN
cppppp
if(iprint.eq.1) then
print'(" ## This MAX wind level, on lvl ",I0,
$ " will have already been processed as a cat. 3 ",
$ "lvl (on lvl ",I0,") - skip this MAX wind lvl ",
$ "but set"/6X,"cat. 3 lvl PQM to ""W""")', L,II
end if
cppppp
PQM(II) = 'W'
IF(POB(L).EQ.PWMIN) PQM(II) = 'X'
IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN
SOB(II) = SOB(L)
DOB(II) = DOB(L)
cppppp
if(iprint.eq.1) then
print'(" ...... also on lvl ",I0," - transfer",
$ " wind data to dupl. cat. 3 lvl because its ",
$ "missing there")', L
end if
cppppp
END IF
VSG(L) = 0
GO TO 7732
END IF
ENDDO
END IF
IF(INDX8-1.GT.0) THEN
DO II = 1,INDX8-1
IF(POB(L).EQ.P8(II).AND.POB(L).LT.BMISS) THEN
cppppp
if(iprint.eq.1) then
print'(" ## This cat. 3 MAX wind lvl, on lvl ",I0,
$ " will have already been processed as a cat. 3 ",
$ "MAX wind lvl (on lvl ",I0,") - skip this Cat. ",
$ "3 MAX wind lvl")', L,II
end if
cppppp
IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN
SOB(II) = SOB(L)
DOB(II) = DOB(L)
cppppp
if(iprint.eq.1) then
print'(" ...... also on lvl ",I0," - transfer",
$ " wind data to dupl. MAX wind lvl because its ",
$ "missing there")', L
end if
cppppp
END IF
VSG(L) = 0
GO TO 7732
END IF
ENDDO
END IF
ELSE IF(NINT(VSG(L)).EQ.16) THEN
INDX16 = INDX16 + 1
P16(INDX16) = POB(L)
END IF
7732 CONTINUE
ENDDO
C TAKE CARE OF 925 MB NEXT
C ------------------------
DO L=1,NLEV
IF(NINT(VSG(L)).EQ.32 .AND. NINT(POB(L)).EQ.9250) THEN
CF8(L) = 925
OB8(L) = ZOB(L)
Q81(L) = ' '
Q82(L) = ' '
IF(TOB(L).LT.BMISS) CALL S02O29(2,L,*9999)
IF(DOB(L).LT.BMISS) CALL S02O29(3,L,*9999)
IF(OB8(L).LT.BMISS) CALL S02O29(8,L,*9999)
VSG(L) = 0
END IF
ENDDO
C REST OF THE DATA
C ----------------
Z100 = 16000
DO L=1,NLEV
IF(NINT(VSG(L)).EQ.32) THEN
IF(MIN(DOB(L),ZOB(L),TOB(L)).GE.BMISS) THEN
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG=32 & DOB,ZOB,TOB all ",
$ "missing --> this level not processed")', L
end if
VSG(L) = 0
ELSE IF(MIN(ZOB(L),TOB(L)).LT.BMISS) THEN
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG=32 & one or both of ",
$ "ZOB,TOB non-missing --> valid cat. 1 lvl")', L
end if
cppppp
CALL S02O29(1,L,*9999)
IF(NINT(POB(L)).EQ.1000.AND.ZOB(L).LT.BMISS) Z100 = ZOB(L)
VSG(L) = 0
END IF
END IF
ENDDO
DO L=1,NLEV
IF(NINT(VSG(L)).EQ.32) THEN
IF(DOB(L).LT.BMISS.AND.MIN(ZOB(L),TOB(L)).GE.BMISS) THEN
LL = I04O29(POB(L)*.1)
IF(LL.EQ.999999) THEN
cppppp
print'(" ~~IW3UNP29/R03O29: ID ",A," has VSG=32 for ",
$ "lvl ",I0," but pressure not mand.!! --> this level ",
$ "not processed")', sid,L
cppppp
ELSE IF(MIN(RCATS(1,LL,1),RCATS(2,LL,1)).LT.99999.) THEN
IF(RCATS(4,LL,1).GE.99998.) THEN
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG=32 & ZOB,TOB ",
$ "both missing while DOB non-missing BUT one or ",
$ "both of Z, T non-missing while wind missing ",
$ "in"/7X,"earlier cat. 1 processing of this ",G0,
$ "mb level --> valid cat. 1 lvl")', L,POB(L)*.1
end if
cppppp
CALL S02O29(1,L,*9999)
ELSE
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG=32 & ZOB,TOB ",
$ "both missing while DOB non-missing BUT one or ",
$ "both of Z, T non-missing while wind non-missing",
$ " in"/6X,"earlier cat. 1 processing of this ",G0,
$ "mb level --> valid cat. 3 lvl")', L,POB(L)*.1
end if
cppppp
CALL S02O29(3,L,*9999)
END IF
ELSE
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG=32 & ZOB,TOB both ",
$ "missing while DOB non-missing AND both Z, T ",
$ "missing on"/7X,"this ",G0,"mb level in cat. 1 --> ",
$ "valid cat. 3 lvl")', L,POB(L)*.1
end if
cppppp
CALL S02O29(3,L,*9999)
END IF
ELSE
cppppp
print'(" ~~IW3UNP29/R03O29: ID ",A," has VSG=32 for lvl ",
$ I0," & should never come here!! - by default output",
$ " as cat. 1 lvl")', sid,L
cppppp
CALL S02O29(1,L,*9999)
END IF
VSG(L) = 0
END IF
ENDDO
DO L=1,NLEV
IF(NINT(VSG(L)).EQ. 4) THEN
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG= 4 --> valid cat. 2 ",
$ "lvl")', L
end if
cppppp
IF(INDX16.GT.0) THEN
DO II = 1,INDX16
IF(POB(L).EQ.P16(II).AND.POB(L).LT.BMISS) THEN
cppppp
if(iprint.eq.1) then
print'(" ## This cat. 2 level, on lvl ",I0," is",
$ " also the tropopause level, as its pressure ",
$ "matches that of trop. lvl no. ",I0," - ",
$ "set this cat. 2"/5X,"lvl PQM to ""T""")', L,II
end if
cppppp
PQM(L) = 'T'
GO TO 7738
END IF
ENDDO
END IF
7738 CONTINUE
CALL S02O29(2,L,*9999)
VSG(L) = 0
ELSEIF(NINT(VSG(L)).EQ.16) THEN
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG=16 --> valid cat. 3/5 ",
$ "lvl")', L
end if
cppppp
PQML = PQM(L)
IF(MIN(SOB(L),DOB(L)).LT.BMISS) CALL S02O29(3,L,*9999)
PQM(L) = PQML
CALL S02O29(5,L,*9999)
VSG(L) = 0
ELSEIF(NINT(VSG(L)).EQ. 1) THEN
cppppp
print'(" ~~IW3UNP29/R03O29: HERE IS A VSG =1, SET TO CAT.6, ",
$ "AT ID ",A,"; SHOULD NEVER HAPPEN!!")', SID
cppppp
CALL S02O29(6,L,*9999)
VSG(L) = 0
ELSEIF(NINT(VSG(L)).EQ. 2 .AND. POB(L).LT.BMISS) THEN
IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG= 2 & POB .ne. missing ",
$ "--> valid cat. 3 lvl (expect that ZOB is missing)")', L
end if
cppppp
CALL S02O29(3,L,*9999)
ELSE
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG= 2 & POB .ne. missing ",
$ "--> Cat. 3 level not processed - wind is missing")', L
end if
cppppp
END IF
VSG(L) = 0
ELSEIF(NINT(VSG(L)).EQ. 2 .AND. ZOB(L).LT.BMISS) THEN
IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN
C CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION
C -------------------------------------------------------------
IF(SID(1:2).EQ.'70'.OR.SID(1:2).EQ.'71'.OR.SID(1:2).EQ.'72'
$ .OR.SID(1:2).EQ.'74') ZOB(L) = E34O29(ZOB(L),Z100)
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG= 2 & ZOB .ne. missing ",
$ "--> valid cat. 4 lvl (POB must always be missing)")', L
if(sid(1:2).eq.'70'.or.sid(1:2).eq.'71'.or.sid(1:2).eq.'72'
$ .or.sid(1:2).eq.'74') print'(" .... ZOB at this ",
$ "U.S. site adjusted to ",G0)', zob(L)
end if
cppppp
C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
C -----------------------------------------------------------------
ZQM(L) = ' '
CALL S02O29(4,L,*9999)
ELSE
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG= 2 & ZOB .ne. missing ",
$ "--> Cat. 4 level not processed - wind is missing")', L
end if
cppppp
END IF
VSG(L) = 0
ELSEIF(NINT(VSG(L)).EQ. 8 .AND. POB(L).LT.BMISS) THEN
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG= 8 & POB .ne. missing ",
$ "--> valid cat. 3 lvl (expect that ZOB is missing)")', L
end if
cppppp
CALL S02O29(3,L,*9999)
VSG(L) = 0
ELSEIF(NINT(VSG(L)).EQ. 8 .AND. ZOB(L).LT.BMISS) THEN
IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN
C CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION
C -------------------------------------------------------------
IF(SID(1:2).EQ.'70'.OR.SID(1:2).EQ.'71'.OR.SID(1:2).EQ.'72'
$ .OR.SID(1:2).EQ.'74') ZOB(L) = E34O29(ZOB(L),Z100)
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG= 8 & ZOB .ne. missing ",
$ "--> valid cat. 4 lvl (POB must always be missing)")', L
if(sid(1:2).eq.'70'.or.sid(1:2).eq.'71'.or.sid(1:2).eq.'72'
$ .or.sid(1:2).eq.'74') print'(" .... ZOB at this ",
$ "U.S. site adjusted to ",G0)', zob(L)
end if
cppppp
C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
C -----------------------------------------------------------------
ZQM(L) = ' '
CALL S02O29(4,L,*9999)
ELSE
cppppp
if(iprint.eq.1) then
print'(" ==> For lvl ",I0,"; VSG= 8 & ZOB .ne. missing ",
$ "--> Cat. 4 level not processed - wind is missing")', L
end if
cppppp
END IF
VSG(L) = 0
END IF
ENDDO
C CHECK FOR LEVELS WHICH GOT LEFT OUT
C -----------------------------------
DO L=1,NLEV
IF(NINT(VSG(L)).GT.0) THEN
PRINT 887, L,SID,NINT(VSG(L))
887 FORMAT(' ##IW3UNP29/R03O29 - ~~ON LVL',I4,' OF ID ',A8,', A ',
$ 'VERTICAL SIGNIFICANCE OF',I3,' WAS NOT SUPPORTED - LEAVE ',
$ 'THIS LEVEL OUT OF THE PROCESSING')
print'(" ..... at lvl=",I0,"; POB = ",G0,"; QOB = ",G0,
$ "; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,";"/19X,"SOB = ",
$ G0)', pob(L),qob(L),tob(L),zob(L),dob(L),sob(L)
END IF
ENDDO
C CLOUD DATA GOES INTO CATEGORY 07
C --------------------------------
CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,'HOCB CLAM QMCA HBLCS')
ARR=ARR_8
DO L=1,NLEV
IF(ARR(1,L).LT.BMISS/2.) THEN
! Prior to 3/2002 HBLCS was not available, this will
! always be tested first because it is more precise
! in theory but will now be missing after 3/2002
IF(ELV+ARR(1,L).GE.BMISS/2.) THEN
CLP(L) = BMISS
ELSE IF(ELV+ARR(1,L).LE.11000) THEN
CLP(L) = (PRS1(ELV+ARR(1,L))*10.) + 0.001
ELSE
CLP(L) = (PRS2(ELV+ARR(1,L))*10.) + 0.001
END IF
ELSE
! Effective 3/2002 only this will be available
IF(NINT(ARR(4,L)).GE.10) THEN
CLP(L) = BMISS
ELSE
IF(ELV+IHBLCS(NINT(ARR(4,L))).GE.BMISS/2.) THEN
CLP(L) = BMISS
ELSE IF(ELV+IHBLCS(NINT(ARR(4,L))).LE.11000) THEN
CLP(L) = (PRS1(ELV+IHBLCS(NINT(ARR(4,L))))*10.) +0.001
ELSE
CLP(L) = (PRS2(ELV+IHBLCS(NINT(ARR(4,L))))*10.) +0.001
END IF
END IF
END IF
CLA(L) = E13O29(ARR(2,L))
QCP(L) = ' '
QCA(L) = E35O29(ARR(3,L))
IF(CLP(L).LT.BMISS .OR. CLA(L).LT.BMISS) CALL S02O29(7,L,*9999)
ENDDO
C -----------------------------------------------------
C MISC DATA GOES INTO CATEGORY 08
C -----------------------------------------------------
C CODE FIGURE 104 - RELEASE TIME IN .01*HR
C CODE FIGURE 105 - RECEIPT TIME IN .01*HR
C CODE FIGURE 106 - RADIOSONDE INSTR. TYPE,
C SOLAR/IR CORRECTION INDICATOR,
C TRACKING TECH/STATUS OF SYSTEM USED
C CODE FIGURE 925 - HEIGHT OF 925 LEVEL
C -----------------------------------------------------
CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8
C NOTE: MNEMONIC "RCTS" 008202 IS A LOCAL DESCRIPTOR DEFINED AS
C RECEIPT TIME SIGNIFICANCE -- CODE TABLE FOLLOWS:
C 0 General decoder receipt time
C 1 NCEP receipt time
C 2 OSO receipt time
C 3 ARINC ground station receipt time
C 4 Radiosonde TEMP AA part receipt time
C 5 Radiosonde TEMP BB part receipt time
C 6 Radiosonde TEMP CC part receipt time
C 7 Radiosonde TEMP DD part receipt time
C 8 Radiosonde PILOT AA part receipt time
C 9 Radiosonde PILOT BB part receipt time
C 10 Radiosonde PILOT CC part receipt time
C 11 Radiosonde PILOT DD part receipt time
C 12-62 Reserved for future use
C 63 Missing
DO L=1,NRCT
CF8(L) = 105
OB8(L) = NINT((NINT(RCT(1,L))+NINT(RCT(2,L))/60.) * 100.)
IF(IRECCO.GT.0.AND.NINT(RCT(3,L)).EQ.0) RCT(3,L) = 9
Q81(L) = E36O29(NINT(RCT(3,L)))
Q82(L) = ' '
CALL S02O29(8,L,*9999)
ENDDO
CALL UFBINT(LUNIT,RMORE_8,4,1,NRMORE,'SIRC TTSS UALNHR UALNMN')
RMORE=RMORE_8
IF(MAX(RMORE(3),RMORE(4)).LT.BMISS) THEN
CF8(1) = 104
OB8(1) = NINT((RMORE(3)+RMORE(4)/60.) * 100.)
Q81(1) = ' '
Q82(1) = ' '
CALL S02O29(8,1,*9999)
END IF
IF(NINT(RAT(1)).LT.100) THEN
CF8(1) = 106
ISIR = 9
IF(NINT(RMORE(1)).LT.9) ISIR = NINT(RMORE(1))
ITEC = 99
IF(NINT(RMORE(2)).LT.99) ITEC = NINT(RMORE(2))
OB8(1) = (ISIR * 10000) + (NINT(RAT(1)) * 100) + ITEC
Q81(1) = ' '
Q82(1) = ' '
CALL S02O29(8,1,*9999)
END IF
C PUT THE UNPACKED ON29 REPORT INTO OBS
C -------------------------------------
CALL S03O29(OBS,SUBSET,*9999,*9998)
RETURN
9999 CONTINUE
R03O29 = 999
RETURN
9998 CONTINUE
print'(" IW3UNP29/R03O29: RPT with ID= ",A," TOSSED - ZERO ",
$ "CAT.1-6,51,52 LVLS")', SID
R03O29 = -9999
KSKUPA =KSKUPA + 1
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION R04O29(LUNIT,OBS)
C ---> formerly FUNCTION SURFCE
COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255),
$ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255),
$ CF8(255)
COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255),
$ QCP(255),QCA(255),Q81(255),Q82(255)
COMMON/IO29GG/PSL,STP,SDR,SSP,STM,DPD,TMX,TMI,HVZ,PRW,PW1,CCN,CHN,
$ CTL,CTM,CTH,HCB,CPT,APT,PC6,SND,P24,DOP,POW,HOW,SWD,
$ SWP,SWH,SST,SPG,SPD,SHC,SAS,WES
COMMON/IO29HH/PSQ,SPQ,SWQ,STQ,DDQ
COMMON/IO29CC/SUBSET,IDAT10
COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI
COMMON/IO29LL/BMISS
CHARACTER*80 HDSTR,RCSTR
CHARACTER*8 SUBSET,SID,E35O29,RSV,RSV2
CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,PSQ,SPQ,SWQ,STQ,
$ DDQ
REAL(8) RID_8,UFBINT_8,BMISS
REAL(8) HDR_8(20),RCT_8(5,255),RRSV_8(3),CLDS_8(4,255),
$ TMXMNM_8(4,255)
INTEGER ITIWM(0:15),IHBLCS(0:9)
DIMENSION OBS(*),HDR(20),RCT(5,255),RRSV(3),CLDS(4,255),JTH(0:9),
$ JTL(0:9),LTL(0:9),TMXMNM(4,255)
EQUIVALENCE (RID_8,SID)
SAVE
DATA HDSTR/'RPID CLON CLAT HOUR MINU SELV AUTO '/
DATA RCSTR/'RCHR RCMI RCTS '/
DATA JTH/0,1,2,3,4,5,6,8,7,9/,JTL/0,1,5,8,7,2,3,4,6,9/
DATA LTL/0,1,5,6,7,2,8,4,3,9/
DATA ITIWM/0,3*7,3,3*7,1,3*7,4,3*7/
DATA IHBLCS/25,75,150,250,450,800,1250,1750,2250,2500/
C CHECK IF THIS IS A PREPBUFR FILE
C --------------------------------
R04O29 = 99
c#V#V#dak - future
cdak IF(SUBSET.EQ.'ADPSFC') R04O29 = PRPSFC(LUNIT,OBS)
cdak IF(SUBSET.EQ.'SFCSHP') R04O29 = PRPSFC(LUNIT,OBS)
cdak IF(SUBSET.EQ.'SFCBOG') R04O29 = PRPSFC(LUNIT,OBS)
caaaaadak - future
IF(R04O29.NE.99) RETURN
R04O29 = 0
CALL S05O29
C PUT THE HEADER INFORMATION INTO ON29 FORMAT
C -------------------------------------------
CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:)
CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8
IF(HDR(5).GE.BMISS) HDR(5) = 0
RCTIM = NINT(RCT(1,1))+NINT(RCT(2,1))/60.
RID_8 = HDR_8(1)
XOB = HDR(2)
YOB = HDR(3)
RHR = BMISS
IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60.
RCH = RCTIM
ELV = HDR(6)
C I1 DEFINES SYNOPTIC FORMAT FLAG (SUBSET NC000001, NC000009)
C I1 DEFINES AUTOMATED STATION TYPE (SUBSET NC000003-NC000008,NC000010)
C I2 DEFINES CONVERTED HOURLY FLAG (SUBSET NC000xxx)
C I2 DEFINES SHIP LOCATION FLAG (SUBSET NC001xxx) (WHERE xxx != 006)
I1 = 9
I2 = 9
IF(SUBSET(1:5).EQ.'NC000') THEN
IF(SUBSET(6:8).EQ.'001'.OR.SUBSET(6:8).EQ.'009') THEN
I1 = 1
IF(SUBSET(6:8).EQ.'009') I2 = 1
ELSE IF(SUBSET(6:8).NE.'002') THEN
IF(HDR(7).LT.15) THEN
IF(HDR(7).GT.0.AND.HDR(7).LT.5) THEN
I1 = 2
ELSE IF(HDR(7).EQ.8) THEN
I1 = 3
ELSE
I1 = 4
END IF
END IF
END IF
END IF
ITP = (10 * I1) + I2
RTP = E33O29(SUBSET,SID)
C THE 25'TH (RESERVE) CHARACTER IS INDICATOR FOR PRECIP. (INCL./EXCL.)
C THE 26'TH (RESERVE) CHARACTER IS INDICATOR FOR W SPEED (SOURCE/UNITS)
C '0' - Wind speed estimated in m/s (uncertified instrument)
C '1' - Wind speed obtained from anemometer in m/s (certified
C instrument)
C '3' - Wind speed estimated in knots (uncertified instrument)
C '4' - Wind speed obtained from anemometer in knots (certified
C instrument)
C '7' - Missing
C THE 27'TH (RESERVE) CHARACTER IS INDICATOR FOR STN OPER./PAST WX DATA
CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'INPC');RRSV(1)=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'TIWM');TIWM=UFBINT_8
IF(TIWM.LT.BMISS) THEN ! Effective 3/2002
RRSV(2) = 7
IF(NINT(TIWM).LE.15) RRSV(2) = ITIWM(NINT(TIWM))
ELSE ! Prior to 3/2002
CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'SUWS');RRSV(2)=UFBINT_8
END IF
CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'ITSO');RRSV(3)=UFBINT_8
RSV = '999 '
DO I=1,3
IF(RRSV(I).LT.BMISS) WRITE(RSV(I:I),'(I1)') NINT(RRSV(I))
ENDDO
C READ THE CATEGORY 51 SURFACE DATA FROM BUFR
C -------------------------------------------
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PMSL');PSL=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PRES');STP=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WDIR');SDR=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WSPD');SSP=UFBINT_8
WSPD1 = SSP
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMDB');STM=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMDP');DPD=UFBINT_8
IF(SUBSET.NE.'NC000007') THEN
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'MXTM');TMX=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'MITM');TMI=UFBINT_8
ELSE
TMX = BMISS
TMI = BMISS
END IF
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMPR');QSL=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMPR');QSP=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMWN');QMW=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMAT');QMT=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMDD');QMD=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOVI');HVZ=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PRWE');PRW=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PSW1');PW1=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PSW2');PW2=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOCC');CCN=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CHPT');CPT=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'3HPC');APT=UFBINT_8
IF(MAX(APT,CPT).GE.BMISS) THEN
APT = BMISS
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'24PC');APT24=UFBINT_8
IF(APT24.LT.BMISS) THEN
APT = APT24
CPT = BMISS
END IF
END IF
C READ THE CATEGORY 52 SURFACE DATA FROM BUFR
C -------------------------------------------
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TP06');PC6=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOSD');SND=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TP24');P24=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOPC');PTO=UFBINT_8
IF(PTO.LT.BMISS) THEN
IF(PC6.GE.BMISS.AND.NINT(DOP).EQ. 6) PC6 = PTO
cppppp
IF(PC6.GE.BMISS.AND.NINT(DOP).EQ. 6)
$ print'(" ~~IW3UNP29/R04O29: PTO used for PC6 since latter ",
$ "missing & 6-hr DOP")'
cppppp
IF(P24.GE.BMISS.AND.NINT(DOP).EQ.24) P24 = PTO
cppppp
IF(P24.GE.BMISS.AND.NINT(DOP).EQ.24)
$ print'(" ~~IW3UNP29/R04O29: PTO used for P24 since latter ",
$ "missing & 24-hr DOP")'
cppppp
END IF
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POWW');POW=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOWW');HOW=UFBINT_8
IF(SUBSET(1:5).EQ.'NC001') THEN
IF(SUBSET(6:8).NE.'006') THEN
IF(MIN(POW,HOW).GE.BMISS) THEN
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POWV');POW=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOWV');HOW=UFBINT_8
END IF
ELSE
C PAOBS always have a missing elev, but we know they are at sea level
ELV = 0
END IF
END IF
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'DOSW');SWD=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POSW');SWP=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOSW');SWH=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SST1');SST=UFBINT_8
IF(SST.GE.BMISS) THEN
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'STMP');SST=UFBINT_8
ENDIF
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'????');SPG=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'????');SPD=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TDMP');SHC=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'ASMP');SAS=UFBINT_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'????');WES=UFBINT_8
I52FLG = 0
IF(MIN(SND,P24,POW,HOW,SWD,SWP,SWH,SST,SPG,SPD,SHC,SAS,WES)
$ .GE.BMISS.AND.(PC6.EQ.0..OR.PC6.GE.BMISS)) I52FLG= 1
C SOME CLOUD DATA IS NEEDED FOR LOW, MIDDLE, AND HIGH CLOUDS IN CAT. 51
C ---------------------------------------------------------------------
CALL UFBINT(LUNIT,CLDS_8,4,255,NCLD,'VSSO CLAM CLTP HOCB')
CLDS=CLDS_8
CTH = -9999.
CTM = -9999.
CTL = -9999.
CHH = BMISS
CHM = BMISS
CHL = BMISS
IF(NCLD.EQ.0) THEN
CCM = BMISS
CCL = BMISS
ELSE
CCM = 0.
CCL = 0.
DO L=1,NCLD
VSS = CLDS(1,L)
CAM = CLDS(2,L)
CTP = CLDS(3,L)
CHT = BMISS
IF(CLDS(4,L).LT.BMISS) THEN
! Prior to 3/2002 HBLCS was not available, this will
! always be tested first because it is more precise
! and may still be available for some types after
! 3/2002
CHT = CLDS(4,L)
ELSE
! Effective 3/2002 this will be available and can be
! used for types where HOCB is not available - less
! precise and only available on 1 level
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HBLCS')
HBLCS=UFBINT_8
IF(NINT(HBLCS).LT.10) CHT = IHBLCS(NINT(HBLCS))
END IF
IF(CHT.LT.BMISS) CHT = CHT * 3.2808
IF(NINT(VSS).EQ.0) THEN
IF(NINT(CTP).GT.9.AND.NINT(CTP).LT.20) THEN
ITH = MOD(NINT(CTP),10)
KTH = JTH(ITH)
CTH = MAX(KTH,NINT(CTH))
CHH = MIN(CHT,CHH)
ELSE IF(NINT(CTP).LT.30) THEN
ITM = MOD(NINT(CTP),10)
CTM = MAX(ITM,NINT(CTM))
IF(ITM.EQ.0) CAM = 0.
CCM = MAX(CAM,CCM)
CHM = MIN(CHT,CHM)
ELSE IF(NINT(CTP).LT.40) THEN
ITL = MOD(NINT(CTP),10)
KTL = JTL(ITL)
CTL = MAX(KTL,NINT(CTL))
IF(ITL.EQ.0) CAM = 0.
CCL = MAX(CAM,CCL)
CHL = MIN(CHT,CHL)
ELSE IF(NINT(CTP).EQ.59) THEN
CTH = 10.
CTM = 10.
IF(CCM.EQ.0.) CCM = 15.
CTL = 10.
IF(CCL.EQ.0.) CCL = 15.
ELSE IF(NINT(CTP).EQ.60) THEN
CTH = 10.
ELSE IF(NINT(CTP).EQ.61) THEN
CTM = 10.
IF(CCM.EQ.0.) CCM = 15.
ELSE IF(NINT(CTP).EQ.62) THEN
CTL = 10.
IF(CCL.EQ.0.) CCL = 15.
END IF
END IF
ENDDO
END IF
IF(NINT(CTH).GT.-1.AND.NINT(CTH).LT.10) THEN
CTH = JTH(NINT(CTH))
ELSE IF(NINT(CTH).NE.10) THEN
CTH = BMISS
END IF
IF(NINT(CTM).LT.0.OR.NINT(CTM).GT.10) THEN
CTM = BMISS
CCM = BMISS
END IF
IF(NINT(CTL).GT.-1.AND.NINT(CTL).LT.10) THEN
CTL = LTL(NINT(CTL))
ELSE IF(NINT(CTL).NE.10) THEN
CTL = BMISS
CCL = BMISS
END IF
C CALL FUNCTIONS TO TRANSFORM TO ON29/124 UNITS
C ---------------------------------------------
PSL = E01O29(PSL)
STP = E01O29(STP)
SDR = E04O29(SDR,SSP)
SSP = E05O29(SDR,SSP)
IF(NINT(SDR).EQ.0) SDR = 360.
IF(SDR.GE.BMISS.AND.NINT(SSP).EQ.0) SDR = 360.
DPD = E07O29(DPD,STM)
STM = E06O29(STM)
TMX = E06O29(TMX)
TMI = E06O29(TMI)
PSQ = E35O29(QSL)
SPQ = E35O29(QSP)
SWQ = E35O29(QMW)
STQ = E35O29(QMT)
DDQ = E35O29(QMD)
C ADJUST QUIPS QUALITY MARKERS TO REFLECT UNPACKED ON29 CONVENTION
IF(SUBSET(1:5).EQ.'NC001'.AND.PSQ.EQ.'C') STP = BMISS
IF(PSL.GE.BMISS) PSQ = ' '
IF(STP.GE.BMISS) SPQ = ' '
IF(MAX(SDR,SSP).GE.BMISS) SWQ = ' '
IF(STM.GE.BMISS) STQ = ' '
IF(SUBSET(1:5).EQ.'NC000'.OR.SUBSET.EQ.'NC001004') THEN
HVZ = E09O29(HVZ)
ELSE
HVZ = E38O29(HVZ)
END IF
PRW = E10O29(PRW)
PW1 = E11O29(PW1)
PW2 = E11O29(PW2)
IF(DDQ.NE.'P'.AND.DDQ.NE.'H'.AND.DDQ.NE.'C') THEN
DDQ = ' '
IPW2 = NINT(PW2)
IF(IPW2.GT.-1.AND.IPW2.LT.10) WRITE(DDQ,'(I1)') IPW2
END IF
CCN = E12O29(CCN)
CHN = E14O29(CCL,CCM)
CTL = E15O29(CTL)
CTM = E15O29(CTM)
CTH = E15O29(CTH)
HCB = E18O29(CHL,CHM,CHH,CTL,CTM,CTH)
CPT = E19O29(CPT)
APT = E01O29(APT)
PC6 = E20O29(PC6)
SND = E21O29(SND)
P24 = E20O29(P24)
DOP = E22O29(PC6)
POW = E23O29(POW)
HOW = E24O29(HOW)
SWD = E25O29(SWD)
SWP = E23O29(SWP)
SWH = E24O29(SWH)
SST = E06O29(SST)
SPG = E28O29(SPG)
SPD = E29O29(SPD)
SHC = E30O29(SHC)
SAS = E31O29(SAS)
WES = E32O29(WES)
C MAKE THE UNPACKED ON29/124 REPORT INTO OBS
C ------------------------------------------
RSV2 = ' '
CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP)
CALL S02O29(51,1,*9999)
IF(I52FLG.EQ.0) CALL S02O29(52,1,*9999)
C ------------------------------------------------------------------
C MISC DATA GOES INTO CATEGORY 08
C ------------------------------------------------------------------
C CODE FIGURE 020 - ALTIMETER SETTING IN 0.1*MB
C CODE FIGURE 081 - CALENDAR DAY MAXIMUM TEMPERATURE
C CODE FIGURE 082 - CALENDAR DAY MINIMUM TEMPERATURE
C CODE FIGURE 083 - SIX HOUR MAXIMUM TEMPERATURE
C CODE FIGURE 084 - SIX HOUR MINIMUM TEMPERATURE
C CODE FIGURE 085 - PRECIPITATION OVER PAST HOUR IN 0.01*INCHES
C CODE FIGURE 098 - DURATION OF SUNSHINE FOR CALENDAR DAY IN MINUTES
C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
C ------------------------------------------------------------------
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'ALSE');ALS=UFBINT_8
IF(ALS.LT.BMISS) THEN
OB8(1) = E01O29(ALS)
CF8(1) = 20
Q81(1) = ' '
Q82(1) = ' '
CALL S02O29(8,1,*9999)
END IF
IF(SUBSET.EQ.'NC000007') THEN
CALL UFBINT(LUNIT,TMXMNM_8,4,255,NTXM,
$ '.DTHMXTM MXTM .DTHMITM MITM');TMXMNM=TMXMNM_8
IF(NTXM.GT.0) THEN
DO I = 1,NTXM
DO J = 1,3,2
IF(NINT(TMXMNM(J,I)).EQ.24) THEN
IF(TMXMNM(J+1,I).LT.BMISS) THEN
TMX = E06O29(TMXMNM(J+1,I))
IF(TMX.LT.0) THEN
OB8(1) = 1000 + ABS(NINT(TMX))
ELSE
OB8(1) = NINT(TMX)
END IF
CF8(1) = 81 + INT(J/2)
Q81(1) = ' '
Q82(1) = ' '
CALL S02O29(8,1,*9999)
END IF
ELSE IF(NINT(TMXMNM(J,I)).EQ.6) THEN
IF(TMXMNM(J+1,I).LT.BMISS) THEN
TMX = E06O29(TMXMNM(J+1,I))
IF(TMX.LT.0) THEN
OB8(1) = 1000 + ABS(NINT(TMX))
ELSE
OB8(1) = NINT(TMX)
END IF
CF8(1) = 83 + INT(J/2)
Q81(1) = ' '
Q82(1) = ' '
CALL S02O29(8,1,*9999)
END IF
END IF
ENDDO
ENDDO
END IF
END IF
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TP01');PC1=UFBINT_8
IF(PC1.LT.10000) THEN
OB8(1) = E20O29(PC1)
CF8(1) = 85
Q81(1) = ' '
Q82(1) = ' '
CALL S02O29(8,1,*9999)
END IF
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOSS');DUS=UFBINT_8
IF(NINT(DUS).LT.1000) THEN
OB8(1) = NINT(98000. + DUS)
CF8(1) = 98
Q81(1) = ' '
Q82(1) = ' '
CALL S02O29(8,1,*9999)
END IF
IF(WSPD1.LT.BMISS) THEN
OB8(1) = NINT(WSPD1*10.)
CF8(1) = 924
Q81(1) = ' '
Q82(1) = ' '
CALL S02O29(8,1,*9999)
END IF
CALL S03O29(OBS,SUBSET,*9999,*9998)
RETURN
9999 CONTINUE
R04O29 = 999
RETURN
9998 CONTINUE
print'(" IW3UNP29/R04O29: RPT with ID= ",A," TOSSED - ZERO ",
$ "CAT.1-6,51,52 LVLS")', SID
R04O29 = -9999
KSKSFC =KSKSFC + 1
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION R05O29(LUNIT,OBS)
C ---> formerly FUNCTION AIRCFT
COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255),
$ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255),
$ CF8(255)
COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255),
$ QCP(255),QCA(255),Q81(255),Q82(255)
COMMON/IO29CC/SUBSET,IDAT10
COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI
COMMON/IO29LL/BMISS
CHARACTER*80 HDSTR,LVSTR,QMSTR,RCSTR,CRAWR
CHARACTER*8 SUBSET,SID,SIDO,SIDMOD,E35O29,RSV,RSV2,CCL,CRAW(1,255)
CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,CTURB(0:14)
REAL(8) RID_8,RCL_8,UFBINT_8,RNS_8,BMISS
REAL(8) HDR_8(20),RCT_8(5,255),ARR_8(10,255),RAW_8(1,255)
DIMENSION OBS(*),HDR(20),RCT(5,255),ARR(10,255),RAW(1,255)
EQUIVALENCE (RID_8,SID),(RCL_8,CCL),(RAW_8,CRAW)
SAVE
DATA HDSTR/'RPID CLON CLAT HOUR MINU SECO '/
DATA LVSTR/'PRLC TMDP TMDB WDIR WSPD '/
DATA QMSTR/'QMPR QMAT QMDD QMGP QMWN '/
DATA RCSTR/'RCHR RCMI RCTS '/
DATA CTURB/'0','1','2','3','0','1','2','3','0','1','2',4*'3'/
C CHECK IF THIS IS A PREPBUFR FILE
C --------------------------------
R05O29 = 99
c#V#V#dak - future
cdak IF(SUBSET.EQ.'AIRCFT') R05O29 = PRPCFT(LUNIT,OBS)
cdak IF(SUBSET.EQ.'AIRCAR') R05O29 = PRPCFT(LUNIT,OBS)
caaaaadak - future
IF(R05O29.NE.99) RETURN
R05O29 = 0
CALL S05O29
C PUT THE HEADER INFORMATION INTO ON29 FORMAT
C -------------------------------------------
CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:)
IF(IRET.EQ.0) SID = ' '
CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8
IF(HDR(5).GE.BMISS) HDR(5) = 0
IF(HDR(6).GE.BMISS) HDR(6) = 0
RCTIM = NINT(RCT(1,1))+NINT(RCT(2,1))/60.
RID_8 = HDR_8(1)
XOB = HDR(2)
YOB = HDR(3)
RHR = BMISS
IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4)) + ((NINT(HDR(5)) * 60.) +
$ NINT(HDR(6)))/3600.
RCH = RCTIM
C TRY TO FIND FIND THE FLIGHT LEVEL HEIGHT
C ----------------------------------------
CALL UFBINT(LUNIT,HDR_8,20,1,IRET,'PSAL FLVL IALT HMSL PRLC')
HDR=HDR_8
ELEV = BMISS
IF(HDR(5).LT.BMISS) ELEV = E03O29(HDR(5)*.01)
IF(HDR(4).LT.BMISS) ELEV = HDR(4)
C FOR MDCARS ACARS DATA ONLY:
C UNCOMMENTING NEXT LINE WILL SET P-ALT TO REPORTED "IALT" VALUE --
C IN THIS CASE, PREPDATA WILL LATER GET PRESS. VIA STD. ATMOS. FCN.
C COMMENTING NEXT LINE WILL USE REPORTED PRESSURE "PRLC" TO GET
C P-ALT VIA INVERSE STD. ATMOS. FCN. -- IN THIS CASE, PREPDATA WILL
C LATER RETURN THIS SAME PRESS. VIA STD. ATMOS. FCN.
cdak IF(HDR(3).LT.BMISS) ELEV = HDR(3)
IF(HDR(2).LT.BMISS) ELEV = HDR(2) + SIGN(0.0000001,HDR(2))
IF(HDR(1).LT.BMISS) ELEV = HDR(1) + SIGN(0.0000001,HDR(1))
ELV = ELEV
C ACFT NAVIGATION SYSTEM STORED IN INSTR. TYPE LOCATION (AS WITH ON29)
C --------------------------------------------------------------------
ITP = 99
CALL UFBINT(LUNIT,RNS_8,1,1,IRET,'ACNS');RNS=RNS_8
IF(RNS.LT.BMISS) THEN
IF(NINT(RNS).EQ.0) THEN
ITP = 97
ELSE IF(NINT(RNS).EQ.1) THEN
ITP = 98
END IF
END IF
RTP = E33O29(SUBSET,SID)
CALL UFBINT(LUNIT,RCL_8,1,1,IRET,'BORG') ! Effective 3/2002
IF(IRET.EQ.0) THEN
CCL = ' '
CALL UFBINT(LUNIT,RCL_8,1,1,IRET,'ICLI') ! Prior to 3/2002
IF(IRET.EQ.0) CCL = ' '
END IF
cvvvvv temporary?
IF(CCL(1:4).EQ.'KAWN') THEN
C This will toss all Carswell/Tinker Aircraft reports - until Jack
C fixes the dup-check to properly remove the duplicate Carswell
C reports, we are better off removing them all since they are
C often of less quality than the non-Carswell AIREP reports
C RIGHT NOW WE ARE HAPPY WITH DUP-CHECKER'S HANDLING OF THESE,
C SO COMMENT THIS OUT
cdak R05O29 = -9999
cdak KSKACF(?) = KSKACF(?) + 1
cdak RETURN
END IF
caaaaa temporary?
IF(SUBSET.EQ.'NC004003') THEN
C ------------------------------------
C ASDAR/AMDAR AIRCRAFT TYPE COME HERE
C ------------------------------------
cvvvvv temporary?
C Currently, we throw out any ASDAR/AMDAR reports with header "LFPW" -
C simply because they never appeared in NAS9000 ON29 AIRCFT data set
C (NOTE: These should all have ACID's that begin with "IT")
C (NOTE: These will not be removed from the new decoders, because
C they are apparently unique reports of reasonable
C quality. EMC just needs to test them in a parallel run
C to make sure prepacqc and the analysis handle them okay.)
C NOTE: NO, NO DON'T THROW THEM OUT ANY MORE !!!!!!
C Keyser -- 6/13/97
CDAKCDAK if(ccl(1:4).eq.'LFPW') then
cppppp
cdak print'(" IW3UNP29/R05O29: TOSS ""LFPW"" AMDAR with ID = ",A,
cdak $ "; CCL = ",A)', SID,CCL(1:4)
cppppp
CDAKCDAK R05O29 = -9999
CDAKCDAK kskacf(2) = kskacf(2) + 1
CDAKCDAK return
CDAKCDAK end if
caaaaa temporary?
C MODIFY REPORT ID AS WAS DONE IN OLD ON29 AIRCRAFT PACKER
C --------------------------------------------------------
CALL S06O29(SID,SIDMOD)
SIDO = SID
SID = SIDMOD
C THE 25'TH (RESERVE) CHARACTER INDICATES PHASE OF FLIGHT
C THE 26'TH (RESERVE) CHARACTER INDICATES TEMPERATURE PRECISION
C THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL (NEVER HAPPENS)
C (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH
C "PHWR" AND "EGWR" ARE ALSO APPARENTLY ALSO CARSWELL)
RSV = '71 '
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POAF');POF=UFBINT_8
IF(POF.LT.BMISS) WRITE(RSV(1:1),'(I1)') NINT(POF)
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PCAT');PCT=UFBINT_8
IF(NINT(PCT).GT.1) RSV(2:2) = '0'
IF(CCL(1:4).EQ.'KAWN') RSV(3:3) = 'C'
ELSE IF(SUBSET.EQ.'NC004004') THEN
C ------------------------------
C ACARS AIRCRAFT TYPE COME HERE
C ------------------------------
CALL UFBINT(LUNIT,RID_8,1,1,IRET,'ACRN')
IF(IRET.EQ.0) SID = 'ACARS '
KNDX = KNDX + 1
RSV = '999 '
ELSE IF(SUBSET.EQ.'NC004001'.OR.SUBSET.EQ.'NC004002') THEN
C -----------------------------------------
C AIREP AND PIREP AIRCRAFT TYPES COME HERE
C -----------------------------------------
C MAY POSSIBLY NEED TO MODIFY THE RPID HERE
C -----------------------------------------
IF(SID(6:6).EQ.'Z') SID(6:6) = 'X'
IF(SID.EQ.'A '.OR.SID.EQ.' '.OR.SID(1:3).EQ.'ARP'
$ .OR.SID(1:3).EQ.'ARS') SID = 'AIRCFT '
cvvvvv temporary?
C Determined that Hickum AFB reports are much like Carswell - they have
C problems! They also are usually duplicates of either Carswell or
C non-Carswell reports. Apparently the front-end processing filters
C them out (according to B. Ballish). So, to make things match,
C we will do the same here.
C ACTUALLY, JEFF ATOR HAS REMOVED THESE FROM THE DECODER, SO WE
C SHOULD NEVER EVEN SEE THEM IN THE DATABASE, but it won't hurt
C anything to keep this in here.
C (NOTE: These all have headers of "PHWR")
if(ccl(1:4).eq.'PHWR') then
cppppp
cdak print'(" IW3UNP29/R05O29: TOSS ""PHWR"" AIREP with ID = ",A,
cdak $ "; CCL = ",A)', SID,CCL(1:4)
cppppp
R05O29 = -9999
kskacf(8) = kskacf(8) + 1
return
end if
caaaaa temporary?
cvvvvv temporary?
C 1) Carswell/Tinker AMDARS are processed as AIREP subtypes.
C Nearly all of them are duplicated as true non-Carswell AMDARS in
C the AMDAR subtype. The earlier version of the aircraft dup-
C checker could not remove such duplicates; the new verison now
C in operations can remove these. SO, WE HAVE COMMENTED THIS OUT.
C
C The Carswell AMDARS can be identified by the string " Sxyz" in
C the raw report (beyond byte 40), where y is 0,1, or 2.
C (NOTE: Apparently Carswell here applies to more headers than
C just "KAWN", so report header is not even checked.)
C 2) Carswell/Tinker ACARS are processed as AIREP subtypes.
C These MAY duplicate true non-Carswell ACARS in the ACARS
C subtype. The NAS9000 decoder always excluded this type (no
C dup-checking was done). All of these will be removed here.
C The Carswell ACARS can be identified by the string " Sxyz" in
C the raw report (beyond byte 40), where y is 3 or greater.
C (NOTE: Apparently Carswell here applies to more headers than
C just "KAWN", so report header is not even checked.)
call ufbint(lunit,raw_8,1,255,nlev,'RRSTG');raw=raw_8
if(nlev.gt.5) then
ni = -7
do mm = 6,nlev
ni = ni + 8
crawr(ni:ni+7) = craw(1,mm)
if(ni+8.gt.80) go to 556
enddo
556 continue
do mm = 1,ni+7
if(crawr(mm:mm+1).eq.' S') then
if((crawr(mm+2:mm+2).ge.'0'.and.crawr(mm+2:mm+2).le.
$ '9').or.crawr(mm+2:mm+2).eq.'/') then
if((crawr(mm+3:mm+3).ge.'0'.and.crawr(mm+3:mm+3)
$ .le.'9').or.crawr(mm+3:mm+3).eq.'/') then
if((crawr(mm+4:mm+4).ge.'0'.and.
$ crawr(mm+4:mm+4).le.'9').or.crawr(mm+4:mm+4)
$ .eq.'/') then
cppppp
cdak print'(" IW3UNP29/R05O29: For ",A,", raw_8(",I0,") = ",A)',
cdak $ SID,ni+7,crawr(1:ni+7)
cppppp
if(crawr(mm+3:mm+3).lt.'3') then
C THIS IS A CARSWELL/TINKER AMDAR REPORT --> THROW OUT
C (NOT ANYMORE, DUP-CHECKER IS HANDLING THESE OKAY NOW)
C ----------------------------------------------------
cppppp
cdak print'(" IW3UNP29/R05O29: Found a Carswell AMDAR for ",A,
cdak $ "; CCL = ",A)', SID,CCL(1:4)
cppppp
cdak R05O29 = -9999
cdak KSKACF(3) = KSKACF(3) + 1
cdak RETURN
else
C THIS IS A CARSWELL/TINKER ACARS REPORT --> THROW OUT
C ----------------------------------------------------
cppppp
cdak print'(" IW3UNP29/R05O29: Found a Carswell ACARS for ",A,
cdak $ "; CCL = ",A)', SID,CCL(1:4)
cppppp
R05O29 = -9999
KSKACF(4) = KSKACF(4) + 1
RETURN
end if
end if
end if
end iF
end if
if(mm+5.gt.ni+7) go to 557
enddo
557 continue
END IF
caaaaa temporary?
C THE 25'TH (RESERVE) CHARACTER INDICATES 8'TH CHARACTER OF STATION ID
C THE 26'TH (RESERVE) CHARACTER INDICATES 7'TH CHARACTER OF STATION ID
C THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL
C (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH
C "PHWR" AND "EGWR" ARE ALSO APPARENTLY ALSO CARSWELL)
RSV = SID(8:8)//SID(7:7)//' '
IF(CCL(1:4).EQ.'KAWN') RSV(3:3) = 'C'
END IF
C -----------------------------
C ALL AIRCRAFT TYPES COME HERE
C -----------------------------
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'DGOT');DGT=UFBINT_8
C PUT THE LEVEL DATA INTO ON29 UNITS
C ----------------------------------
CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8
DO L=1,NLEV
Cvvvvv temporary?
C Even though PREPDATA filters out any aircraft reports with a missing
C wind, or AIREP/PIREP and AMDAR reports below 100 and 2286 meters,
C respectively, it will be done here for now in order to help in
C the comparison between counts coming from the Cray dumps and the
C NAS9000 ON29 dumps (the NAS9000 ON29 maker filters these out).
C NO, NO LET'S NOT FILTER HERE ANY MORE - LEAVE IT UP TO PREPDATA
C SINCE WE AREN'T COMPARING NAS9000 AND CRAY COUNTS ANY MORE
C Keyser -- 6/13/97
CDAKCDAK if(arr(4,1).ge.bmiss.or.arr(5,1).ge.bmiss) then
CDAKCDAK R05O29 = -9999
CDAKCDAK kskacf(5) = kskacf(5) + 1
CDAKCDAK return
CDAKCDAK end if
CDAKCDAK if(subset.eq.'NC004003'.and.elev.lt.2286.) then
CDAKCDAK R05O29 = -9999
CDAKCDAK kskacf(6) = kskacf(6) + 1
CDAKCDAK return
CDAKCDAK else if(subset.ne.'NC004004'.and.elev.lt.100.) then
CDAKCDAK R05O29 = -9999
CDAKCDAK kskacf(7) = kskacf(7) + 1
CDAKCDAK return
CDAKCDAK end if
caaaaa temporary?
POB(L) = E01O29(ARR(1,L))
QOB(L) = E07O29(ARR(2,L),ARR(3,L))
TOB(L) = E06O29(ARR(3,L))
ZOB(L) = ELEV
DOB(L) = E04O29(ARR(4,L),ARR(5,L))
SOB(L) = E05O29(ARR(4,L),ARR(5,L))
ENDDO
WSPD1 = ARR(5,1)
CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8
IF(SUBSET.EQ.'NC004004') THEN
C ---------------------------------------------------------
C ACARS AIRCRAFT TYPE COME HERE FOR QUALITY MARK ASSIGNMENT
C ---------------------------------------------------------
DO L=1,NLEV
PQM(L) = E35O29(ARR(1,L))
TQM(L) = E35O29(ARR(2,L))
QQM(L) = E35O29(ARR(3,L))
ZQM(L) = E35O29(ARR(4,L))
WQM(L) = E35O29(ARR(5,L))
ENDDO
C DEFAULT Q.MARK FOR WIND: "A"
C ----------------------------
IF(NLEV.EQ.0.OR.ARR(5,1).GE.BMISS) WQM(1) = 'A'
ELSE
C --------------------------------------------------------------
C ALL OTHER AIRCRAFT TYPES COME HERE FOR QUALITY MARK ASSIGNMENT
C --------------------------------------------------------------
DO L=1,NLEV
ARR(4,L) = 2
C IF KEEP FLAG ON WIND, ENTIRE REPORT GETS KEEP FLAG ('H' IN ZQM)
C -- unless....
C IF PURGE FLAG ON WIND, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM)
C IF PURGE FLAG ON TEMP, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM)
C IF FAIL FLAG ON WIND, ENTIRE REPORT GETS FAIL FLAG ('F' IN ZQM)
C IF FAIL FLAG ON TEMP, ENTIRE REPORT GETS FAIL FLAG ('F' IN ZQM)
C -----------------------------------------------------------------
IF(ARR(5,L).EQ.0.AND.(ARR(2,L).LT.10.OR.ARR(2,L).GT.15))THEN
ARR(4,L) = 0
ELSE IF(ARR(5,L).EQ.14.OR.ARR(2,L).EQ.14) THEN
ARR(4,L) = 14
ELSE IF(ARR(5,L).EQ.13.OR.ARR(2,L).EQ.13) THEN
ARR(4,L) = 13
END IF
PQM(L) = ' '
TQM(L) = ' '
QQM(L) = ' '
ZQM(L) = E35O29(ARR(4,L))
C DEGREE OF TURBULENCE IS STORED IN MOISTURE Q.M. SLOT
C ----------------------------------------------------
IF(NINT(DGT).LT.15) QQM(L) = CTURB(NINT(DGT))
ENDDO
C DEFAULT Q.MARK FOR WIND: "C"
C ----------------------------
WQM(1) = 'C'
END IF
C PUT THE UNPACKED ON29 REPORT INTO OBS
C -------------------------------------
RSV2 = ' '
CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP)
CALL S02O29(6,1,*9999)
C ------------------------------------------------------------------
C MISC DATA GOES INTO CATEGORY 08
C ------------------------------------------------------------------
C CODE FIGURE 021 - REPORT SEQUENCE NUMBER
C CODE FIGURE 917 - CHARACTERS 1 AND 2 OF ACTUAL STATION IDENTIFICATION
C (CURRENTLY ONLY FOR ASDAR/AMDAR)
C CODE FIGURE 918 - CHARACTERS 3 AND 4 OF ACTUAL STATION IDENTIFICATION
C (CURRENTLY ONLY FOR ASDAR/AMDAR)
C CODE FIGURE 919 - CHARACTERS 5 AND 6 OF ACTUAL STATION IDENTIFICATION
C (CURRENTLY ONLY FOR ASDAR/AMDAR)
C CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION
C (CURRENTLY ONLY FOR ASDAR/AMDAR AND ACARS)
C CODE FIGURE 921 - OBSERVATION TIME TO NEAREST 1000'TH OF AN HOUR
C (CURRENTLY ONLY FOR ACARS)
C CODE FIGURE 922 - FIRST TWO CHARACTERS OF BULLETIN BEING MONITORED
C CODE FIGURE 923 - LAST TWO CHARACTERS OF BULLETIN BEING MONITORED
C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
C ------------------------------------------------------------------
IF(SUBSET.EQ.'NC004004') THEN
OB8(1) = KNDX
CF8(1) = 21
Q81(1) = ' '
Q82(1) = ' '
CALL S02O29(8,1,*9999)
OB8(1) = 99999.
Q81(1) = SID(7:7)
Q82(1) = SID(8:8)
CF8(1) = 920
CALL S02O29(8,1,*9999)
IF(RHR.LT.BMISS) THEN
OB8(1) = NINT((RHR*1000.)+0.0000001)
CF8(1) = 921
Q81(1) = ' '
Q82(1) = ' '
CALL S02O29(8,1,*9999)
END IF
ELSE IF(SUBSET.EQ.'NC004003') THEN
DO KKK = 1,4
OB8(KKK) = 99999.
Q81(KKK) = SIDO(2*KKK-1:2*KKK-1)
Q82(KKK) = SIDO(2*KKK:2*KKK)
CF8(KKK) = 916 + KKK
CALL S02O29(8,KKK,*9999)
ENDDO
END IF
IF(CCL.NE.' ') THEN
OB8(2) = 99999.
Q81(2) = CCL(1:1)
Q82(2) = CCL(2:2)
CF8(2) = 922
CALL S02O29(8,2,*9999)
OB8(3) = 99999.
Q81(3) = CCL(3:3)
Q82(3) = CCL(4:4)
CF8(3) = 923
CALL S02O29(8,3,*9999)
END IF
IF(WSPD1.LT.BMISS) THEN
OB8(4) = NINT(WSPD1*10.)
CF8(4) = 924
Q81(4) = ' '
Q82(4) = ' '
CALL S02O29(8,4,*9999)
END IF
CALL S03O29(OBS,SUBSET,*9999,*9998)
RETURN
9999 CONTINUE
R05O29 = 999
RETURN
9998 CONTINUE
print'(" IW3UNP29/R05O29: RPT with ID= ",A," TOSSED - ZERO ",
$ "CAT.1-6,51,52 LVLS")', SID
R05O29 = -9999
KSKACF(1) = KSKACF(1) + 1
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION R06O29(LUNIT,OBS)
C ---> formerly FUNCTION SATWND
COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255),
$ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255),
$ CF8(255)
COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255),
$ QCP(255),QCA(255),Q81(255),Q82(255)
COMMON/IO29CC/SUBSET,IDAT10
COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI
COMMON/IO29KK/KOUNT(499,18)
COMMON/IO29LL/BMISS
CHARACTER*80 HDSTR,LVSTR,QMSTR,RCSTR
CHARACTER*8 SUBSET,SID,E35O29,RSV,RSV2
CHARACTER*3 CINDX3
CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,CSAT(499),
$ CPRD(9),CINDX7,C7(26),CPROD(0:4),CPRDF(3)
INTEGER IPRDF(3)
REAL(8) RID_8,UFBINT_8,BMISS
REAL(8) HDR_8(20),RCT_8(5,255),ARR_8(10,255)
DIMENSION OBS(*),HDR(20),RCT(5,255),ARR(10,255)
EQUIVALENCE (RID_8,SID)
SAVE
DATA HDSTR/'RPID CLON CLAT HOUR MINU SAID '/
DATA LVSTR/'PRLC TMDP TMDB WDIR WSPD '/
DATA QMSTR/'QMPR QMAT QMDD QMGP SWQM '/
DATA RCSTR/'RCHR RCMI RCTS '/
DATA CSAT /'A','B','C','D',45*'?','Z','W','X','Y','Z','W','X',
$ 'Y','Z','W',90*'?','R','O','P','Q','R','O','P','Q','R','O',
$ 339*'?','V'/
DATA CPROD /'C','D','?','?','E'/
DATA CPRDF /'C','B','V'/
DATA IPRDF / 1 , 6 , 4 /
DATA CPRD /'C','V','I','W','P','T','L','Z','G'/
DATA C7 /'A','B','C','D','E','F','G','H','I','J','K','L','M',
$ 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
C CHECK IF THIS IS A PREPBUFR FILE
C --------------------------------
R06O29 = 99
c#V#V#dak - future
cdak IF(SUBSET.EQ.'SATWND') R06O29 = PRPWND(LUNIT,OBS)
caaaaadak - future
IF(R06O29.NE.99) RETURN
R06O29 = 0
CALL S05O29
C TRY TO FIND FIND THE HEIGHT ASSIGNMENT
C --------------------------------------
CALL UFBINT(LUNIT,HDR_8,20,1,IRET,'HGHT PRLC');HDR=HDR_8
ELEV = BMISS
IF(HDR(2).LT.BMISS) ELEV = E03O29(HDR(2)*.01)
IF(HDR(1).LT.BMISS) ELEV = HDR(1)
C PUT THE HEADER INFORMATION INTO ON29 FORMAT
C -------------------------------------------
CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:)
CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8
IF(HDR(5).GE.BMISS) HDR(5) = 0
RCTIM = NINT(RCT(1,1))+NINT(RCT(2,1))/60.
RID_8 = HDR_8(1)
XOB = HDR(2)
YOB = HDR(3)
RHR = BMISS
IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60.
RCH = RCTIM
RSV = '990 '
C THE 25'TH (RESERVE) CHARACTER IS THE CLOUD MASK/DEEP LAYER INDICATOR
C {=2 - CLOUD TOP (NORMAL CLOUD DRIFT), =1 - DEEP LAYER,
C =9 - INDICATOR MISSING, THUS REVERTS TO DEFAULT CLOUD TOP}
C (=9 FOR ALL BUT U.S. HIGH-DENSITY SATWND TYPES)
C --------------------------------------------------------------------
C THE 27'TH (RESERVE) CHARACTER INDICATES THE PRODUCER OF THE SATWND
C ------------------------------------------------------------------
C THE INSTRUMENT TYPE INDICATES THE PRODUCT TYPE
C ----------------------------------------------
ITP = 99
C REPROCESS THE STN. ID
C ---------------------
C REPROCESSED CHAR 1 -----> GOES: BUFR CHAR 1
C -----> METEOSAT: SAT. NO. 52, 56 GET 'X'
C SAT. NO. 53, 57 GET 'Y'
C SAT. NO. 50, 54, 58 GET 'Z'
C SAT. NO. 51, 55, 59 GET 'W'
C -----> GMS(JA): SAT. NO. 152,156 GET 'P'
C SAT. NO. 153,157 GET 'Q'
C SAT. NO. 150,154,158 GET 'R'
C SAT. NO. 151,155,159 GET 'O'
C -----> INSAT: SAT. NO. 499 GET 'V'
C REPROCESSED CHAR 2 -----> GOES: RETURNED VALUE IN BUFR FOR 'SWPR'
C (PRODUCER)
C -----> OTHERS: SAT. PRODUCER -- ESA GET 'C'
C -- GMS GET 'D'
C -- INSAT GET 'E'
C REPROCESSED CHAR 6 -----> GOES: BUFR CHAR 6
C -----> OTHERS -- INFRA-RED CLOUD DRIFT GET 'C'
C -- VISIBLE CLOUD DRIFT GET 'B'
C -- WATER VAPOR GET 'V'
C REPROCESSED CHAR 3-5 ---> SEQUENTIAL SERIAL INDEX (001 - 999)
C (UNIQUE FOR EACH BUFR CHAR 1/6 COMB.)
C REPROCESSED CHAR 7 -----> GROUP NUMBER FOR SERIAL INDEX IN
C REPROCESSED CHAR 3-5 (0 - 9, A - Z)
C REPROCESSED CHAR 8 -----> ALWAYS BLANK (' ') FOR NOW
READ(SUBSET(8:8),'(I1)') INUM
IF(SID(1:1).GE.'A'.AND.SID(1:1).LE.'D') THEN
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWPR');SWPR=UFBINT_8
IF(NINT(SWPR).GT.0.AND.NINT(SWPR).LT.10)
$ WRITE(RSV(3:3),'(I1)') NINT(SWPR)
SID(2:2) = RSV(3:3)
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWTP');SWTP=UFBINT_8
IF(SWTP.LT.BMISS) ITP = NINT(SWTP)
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWDL');SWDL=UFBINT_8
IF(NINT(SWDL).GT.-1.AND.NINT(SWDL).LT.10)
$ WRITE(RSV(1:1),'(I1)') NINT(SWDL)
ELSE
SID = '????????'
IF(NINT(HDR(6)).LT.500) THEN
SID(1:1) = CSAT(NINT(HDR(6)))
SID(2:2) = CPROD(NINT(HDR(6))/100)
RSV(3:3) = SID(2:2)
END IF
IF(INUM.LT.4) THEN
SID(6:6) = CPRDF(INUM)
ITP = IPRDF(INUM)
END IF
END IF
CINDX3 = '???'
CINDX7 = '?'
IF(NINT(HDR(6)).LT.500.AND.ITP.LT.19) THEN
KOUNT(NINT(HDR(6)),ITP) = MIN(KOUNT(NINT(HDR(6)),ITP)+1,35999)
KOUNT3 = MOD(KOUNT(NINT(HDR(6)),ITP),1000)
KOUNT7 = INT(KOUNT(NINT(HDR(6)),ITP)/1000)
WRITE(CINDX3,'(I3.3)') KOUNT3
IF(KOUNT7.LT.10) THEN
WRITE(CINDX7,'(I1.1)') KOUNT7
ELSE
CINDX7 = C7(KOUNT7-9)
END IF
END IF
SID = SID(1:2)//CINDX3//SID(6:6)//CINDX7//' '
ELV = ELEV
RTP = E33O29(SUBSET,SID)
C PUT THE LEVEL DATA INTO ON29 UNITS
C ----------------------------------
CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8
DO L=1,NLEV
POB(L) = E01O29(ARR(1,L))
C GROSS CHECK ON PRESSURE
C -----------------------
IF(NINT(POB(L)).EQ.0) THEN
print'(" ~~IW3UNP29/R06O29: RPT with ID= ",A," TOSSED - ",
$ "PRES. IS ZERO MB")', SID
R06O29 = -9999
KSKSAT = KSKSAT + 1
RETURN
END IF
QOB(L) = E07O29(ARR(2,L),ARR(3,L))
TOB(L) = E06O29(ARR(3,L))
ZOB(L) = ELEV
DOB(L) = E04O29(ARR(4,L),ARR(5,L))
SOB(L) = E05O29(ARR(4,L),ARR(5,L))
ENDDO
WSPD1 = ARR(5,1)
C DETERMINE QUALITY MARKERS
C -------------------------
CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFFL');RFFL=UFBINT_8
IF(RFFL.LT.BMISS.AND.(NINT(ARR(5,1)).EQ.2.OR.NINT(ARR(5,1)).GE.
$ BMISS)) THEN
IF(NINT(RFFL).GT.84) THEN
ARR(5,1) = 1
ELSE IF(NINT(RFFL).GT.55) THEN
ARR(5,1) = 2
ELSE IF(NINT(RFFL).GT.49) THEN
ARR(5,1) = 3
ELSE
ARR(5,1) = 13
END IF
END IF
DO L=1,NLEV
WQM(L) = E35O29(ARR(5,L))
IF(WQM(L).EQ.'R'.OR.WQM(L).EQ.'P'.OR.WQM(L).EQ.'F') THEN
C A REJECT, PURGE, OR FAIL FLAG ON WIND IS TRANSFERRED TO ALL VARIABLES
C ---------------------------------------------------------------------
PQM(L) = WQM(L)
TQM(L) = WQM(L)
QQM(L) = WQM(L)
ZQM(L) = WQM(L)
ELSE
PQM(L) = E35O29(ARR(1,L))
TQM(L) = E35O29(ARR(2,L))
QQM(L) = E35O29(ARR(3,L))
ZQM(L) = E35O29(ARR(4,L))
END IF
ENDDO
C PUT THE UNPACKED ON29 REPORT INTO OBS
C -------------------------------------
RSV2 = ' '
CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP)
CALL S02O29(6,1,*9999)
C ---------------------------------------------------------------------
C MISC DATA GOES INTO CATEGORY 08
C ---------------------------------------------------------------------
C CODE FIGURE 013 - PRESSURE
C CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION
C (CURRENTLY ONLY APPLIES TO U.S. SATWND TYPES)
C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
C ---------------------------------------------------------------------
C ---------------------------------------------------------------------
IF(POB(1).LT.BMISS) THEN
OB8(1) = NINT(POB(1)*0.1)
CF8(1) = 13
Q81(1) = ' '
Q82(1) = ' '
CALL S02O29(8,1,*9999)
END IF
IF(SID(1:1).GE.'A'.AND.SID(1:1).LE.'D') THEN
OB8(1) = 99999.
Q81(1) = SID(7:7)
Q82(1) = SID(8:8)
CF8(1) = 920
CALL S02O29(8,1,*9999)
END IF
IF(WSPD1.LT.BMISS) THEN
OB8(2) = NINT(WSPD1*10.)
CF8(2) = 924
Q81(2) = ' '
Q82(2) = ' '
CALL S02O29(8,2,*9999)
END IF
CALL S03O29(OBS,SUBSET,*9999,*9998)
RETURN
9999 CONTINUE
R06O29 = 999
RETURN
9998 CONTINUE
print'(" IW3UNP29/R06O29: RPT with ID= ",A," TOSSED - ZERO ",
$ "CAT.1-6,51,52 LVLS")', SID
R06O29 = -9999
KSKSAT =KSKSAT + 1
RETURN
END
C***********************************************************************
C***********************************************************************
C***********************************************************************
FUNCTION R07O29(LUNIT,OBS)
C ---> formerly FUNCTION SPSSMI
COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255),
$ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255),
$ CF8(255)
COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255),
$ QCP(255),QCA(255),Q81(255),Q82(255)
COMMON/IO29CC/SUBSET,IDAT10
COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI
COMMON/IO29LL/BMISS
CHARACTER*80 HDSTR
CHARACTER*8 SUBSET,SID,RSV,RSV2
CHARACTER*4 CSTDV
CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,CRF
REAL(8) RID_8,UFBINT_8,HDR_8(20),TMBR_8(7),ADDP_8(5),PROD_8(2,2)
REAL(8) BMISS
DIMENSION OBS(*),HDR(20),ADDP(5),PROD(2,2),TMBR(7)
EQUIVALENCE (RID_8,SID)
SAVE
DATA HDSTR/'RPID CLON CLAT HOUR MINU SECO NMCT SAID '/
C CHECK IF THIS IS A PREPBUFR FILE
C --------------------------------
R07O29 = 99
c#V#V#dak - future
cdak IF(SUBSET.EQ.'SPSSMI') R07O29 = PRPSMI(LUNIT,OBS)
caaaaadak - future
IF(R07O29.NE.99) RETURN
R07O29 = 0
CALL S05O29
C PUT THE HEADER INFORMATION INTO ON29 FORMAT
C -------------------------------------------
CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:)
IF(HDR(5).GE.BMISS) HDR(5) = 0
IF(HDR(6).GE.BMISS) HDR(6) = 0
RID_8 = HDR_8(1)
XOB = HDR(2)
YOB = HDR(3)
RHR = BMISS
IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4)) + ((NINT(HDR(5)) * 60.) +
$ NINT(HDR(6)))/3600.
RCH = 99999.
ELV = 99999.
ITP = 99
RTP = HDR(7)
C CHECK ON VALUE FOR SATELLITE ID TO DETERMINE IF THIS IS A SUPEROB
C (SATELLITE ID IS MISSING FOR SUPEROBS)
C -----------------------------------------------------------------
ISUPOB = 1
IF(HDR(8).LT.BMISS) ISUPOB = 0
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
STDV = BMISS
C PUT THE SSM/I DATA INTO ON29 UNITS (WILL RETURN TO HEADER DATA LATER)
C ALL PROCESSING GOES INTO CATEGORY 08
C ---------------------------------------------------------------------
IF(RTP.EQ.68) THEN
C ---------------------------------------------------------------------
C ** 7-CHANNEL BRIGHTNESS TEMPERATURES -- REPORT TYPE 68 **
C ---------------------------------------------------------------------
C CODE FIGURE 189 - 19 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
C CODE FIGURE 190 - 19 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
C CODE FIGURE 191 - 22 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
C CODE FIGURE 192 - 37 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
C CODE FIGURE 193 - 37 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
C CODE FIGURE 194 - 85 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
C CODE FIGURE 195 - 85 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
C ---------------------------------------------------------------------
NLCAT8 = 7
CALL UFBINT(LUNIT,TMBR_8,1,7,NLEV,'TMBR');TMBR=TMBR_8
DO NCHN = 1,7
OB8(NCHN) = MIN(NINT(TMBR(NCHN)*100.),99999)
CF8(NCHN) = 188 + NCHN
ENDDO
ELSE IF(RTP.EQ.575) THEN
C ---------------------------------------------------------------------
C ** ADDITIONAL PRODUCTS -- REPORT TYPE 575 **
C ---------------------------------------------------------------------
C CODE FIGURE 210 - SURFACE TAG (RANGE: 0,1,3-6)
C CODE FIGURE 211 - ICE CONCENTRATION (PERCENT)
C CODE FIGURE 212 - ICE AGE (RANGE: 0,1)
C CODE FIGURE 213 - ICE EDGE (RANGE: 0,1)
C CODE FIGURE 214 - CALCULATED SURFACE TYPE (RANGE: 1-20)
C ---------------------------------------------------------------------
NLCAT8 = 5
CALL UFBINT(LUNIT,ADDP_8,5,1,IRET,'SFTG ICON ICAG ICED SFTP')
ADDP=ADDP_8
DO NADD = 1,5
IF(ADDP(NADD).LT.BMISS) THEN
OB8(NADD) = NINT(ADDP(NADD))
CF8(NADD) = 209 + NADD
END IF
ENDDO
ELSE IF(RTP.EQ.571) THEN
C ---------------------------------------------------------------------
C ** OCEAN SURFACE WIND SPEED PRODUCT -- REPORT TYPE 571 **
C ---------------------------------------------------------------------
C CODE FIGURE 196 - OCEANIC WIND SPEED (M/S * 10)
C (RAIN FLAG IN Q.M. BYTE 2)
C ---------------------------------------------------------------------
CF8(1) = 196
ELV = 0
NLCAT8 = 1
IF(ISUPOB.EQ.1) THEN
CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST WSOS');PROD=PROD_8
DO JJ = 1,2
IF(PROD(1,JJ).EQ.4) THEN
OB8(1) = NINT(PROD(2,JJ)*10.)
ELSE IF(PROD(1,JJ).EQ.10) THEN
STDV = NINT(PROD(2,JJ)*100.)
END IF
ENDDO
ELSE
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WSOS');PRODN=UFBINT_8
OB8(1) = NINT(PRODN*10.)
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFLG');RFLG=UFBINT_8
IF(RFLG.LT.BMISS) THEN
WRITE(CRF,'(I1.1)') NINT(RFLG)
Q82(1) = CRF
END IF
END IF
ELSE IF(RTP.EQ.65) THEN
C ---------------------------------------------------------------------
C ** OCEAN TOTAL PRECIPITABLE WATER PRODUCT -- REPORT TYPE 65 **
C ---------------------------------------------------------------------
C CODE FIGURE 197 - TOTAL PRECIPITABLE WATER (MM * 10)
C (RAIN FLAG IN Q.M. BYTE 2)
C ---------------------------------------------------------------------
CF8(1) = 197
ELV = 0
NLCAT8 = 1
IF(ISUPOB.EQ.1) THEN
CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST PH2O');PROD=PROD_8
DO JJ = 1,2
IF(PROD(1,JJ).EQ.4) THEN
OB8(1) = NINT(PROD(2,JJ)*10.)
ELSE IF(PROD(1,JJ).EQ.10) THEN
STDV = NINT(PROD(2,JJ)*100.)
END IF
ENDDO
ELSE
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PH2O');PRODN=UFBINT_8
OB8(1) = NINT(PRODN*10.)
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFLG');RFLG=UFBINT_8
IF(RFLG.LT.BMISS) THEN
WRITE(CRF,'(I1)') NINT(RFLG)
Q82(1) = CRF
END IF
END IF
ELSE IF(RTP.EQ.66) THEN
C ---------------------------------------------------------------------
C ** LAND/OCEAN RAINFALL RATE -- REPORT TYPE 66 **
C ---------------------------------------------------------------------
C CODE FIGURE 198 - RAINFALL RATE (MM/HR)
C ---------------------------------------------------------------------
CF8(1) = 198
NLCAT8 = 1
IF(ISUPOB.EQ.1) THEN
CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST REQV');PROD=PROD_8
DO JJ = 1,2
IF(PROD(1,JJ).EQ.4) THEN
OB8(1) = NINT(PROD(2,JJ)*3600.)
ELSE IF(PROD(1,JJ).EQ.10) THEN
STDV = NINT(PROD(2,JJ)*36000.)
END IF
ENDDO
ELSE
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'REQV');PRODN=UFBINT_8
OB8(1) = NINT(PRODN*3600.)
END IF
ELSE IF(RTP.EQ.576) THEN
C ---------------------------------------------------------------------
C ** SURFACE TEMPERATURE -- REPORT TYPE 576 **
C ---------------------------------------------------------------------
C CODE FIGURE 199 - SURFACE TEMPERATURE (DEGREES KELVIN)
C ---------------------------------------------------------------------
CF8(1) = 199
NLCAT8 = 1
IF(ISUPOB.EQ.1) THEN
CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST TMSK');PROD=PROD_8
DO JJ = 1,2
IF(PROD(1,JJ).EQ.4) THEN
OB8(1) = NINT(PROD(2,JJ))
ELSE IF(PROD(1,JJ).EQ.10) THEN
STDV = NINT(PROD(2,JJ)*10.)
END IF
ENDDO
ELSE
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMSK');PRODN=UFBINT_8
OB8(1) = NINT(PRODN)
END IF
ELSE IF(RTP.EQ.69) THEN
C ---------------------------------------------------------------------
C ** OCEAN CLOUD WATER -- REPORT TYPE 69 **
C ---------------------------------------------------------------------
C CODE FIGURE 200 - CLOUD WATER (MM * 100)
C ---------------------------------------------------------------------
CF8(1) = 200
ELV = 0
NLCAT8 = 1
IF(ISUPOB.EQ.1) THEN
CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST CH2O');PROD=PROD_8
DO JJ = 1,2
IF(PROD(1,JJ).EQ.4) THEN
OB8(1) = NINT(PROD(2,JJ)*100.)
ELSE IF(PROD(1,JJ).EQ.10) THEN
STDV = NINT(PROD(2,JJ)*1000.)
END IF
ENDDO
ELSE
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CH2O');PRODN=UFBINT_8
OB8(1) = NINT(PRODN*100.)
END IF
ELSE IF(RTP.EQ.573) THEN
C ---------------------------------------------------------------------
C ** SOIL MOISTURE -- REPORT TYPE 573 **
C ---------------------------------------------------------------------
C CODE FIGURE 201 - SOIL MOISTURE (MM)
C ---------------------------------------------------------------------
CF8(1) = 201
NLCAT8 = 1
IF(ISUPOB.EQ.1) THEN
CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST SMOI');PROD=PROD_8
DO JJ = 1,2
IF(PROD(1,JJ).EQ.4) THEN
OB8(1) = NINT(PROD(2,JJ)*1000.)
ELSE IF(PROD(1,JJ).EQ.10) THEN
STDV = NINT(PROD(2,JJ)*10000.)
END IF
ENDDO
ELSE
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SMOI');PRODN=UFBINT_8
OB8(1) = NINT(PRODN*1000.)
END IF
ELSE IF(RTP.EQ.574) THEN
C ---------------------------------------------------------------------
C ** SNOW DEPTH -- REPORT TYPE 574 **
C ---------------------------------------------------------------------
C CODE FIGURE 202 - SNOW DEPTH (MM)
C ---------------------------------------------------------------------
CF8(1) = 202
NLCAT8 = 1
IF(ISUPOB.EQ.1) THEN
CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST SNDP');PROD=PROD_8
DO JJ = 1,2
IF(PROD(1,JJ).EQ.4) THEN
OB8(1) = NINT(PROD(2,JJ)*1000.)
ELSE IF(PROD(1,JJ).EQ.10) THEN
STDV = NINT(PROD(2,JJ)*10000.)
END IF
ENDDO
ELSE
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SNDP');PRODN=UFBINT_8
OB8(1) = NINT(PRODN*1000.)
END IF
END IF
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C FINISH PUTTING THE HEADER INFORMATION INTO ON29 FORMAT
C ------------------------------------------------------
RSV = '999 '
RSV2 = ' '
IF(STDV.LT.BMISS) THEN
WRITE(CSTDV,'(I4.4)') NINT(STDV)
ELSE
CSTDV = '9999'
END IF
RSV2(3:4) = CSTDV(1:2)
RSV(1:2) = CSTDV(3:4)
CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'ACAV');ACAV=UFBINT_8
IF(ACAV.LT.BMISS) THEN
WRITE(CSTDV(1:2),'(I2.2)') NINT(ACAV)
ELSE
CSTDV = '9999'
END IF
RSV2(1:2) = CSTDV(1:2)
CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP)
DO II = 1,NLCAT8
IF(CF8(II).LT.BMISS) CALL S02O29(8,II,*9999)
ENDDO
C PUT THE UNPACKED ON29 REPORT INTO OBS
C -------------------------------------
CALL S03O29(OBS,SUBSET,*9999,*9998)
RETURN
9999 CONTINUE
R07O29 = 999
RETURN
9998 CONTINUE
print'(" IW3UNP29/R07O29: RPT with ID= ",A," TOSSED - ZERO ",
$ "CAT.1-6,8,51,52 LVLS")', SID
R07O29 = -9999
KSKSMI = KSKSMI + 1
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: S06O29 MODIFIES AIRCRAFT ID
C PRGMMR: RAY CRAYTON ORG: W/NMC411 DATE: 1992-02-16
C
C ABSTRACT: MODIFIES AMDAR REPORTS SO THAT LAST CHARACTER ENDS
C WITH 'Z'.
C
C PROGRAM HISTORY LOG:
C 1992-02-16 RAY CRAYTON
C
C USAGE: CALL S06O29(IDEN,ID)
C INPUT ARGUMENT LIST:
C IDEN - ACFT ID
C
C OUTPUT ARGUMENT LIST:
C ID - MODIFIED AIRCRAFT ID.
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
SUBROUTINE S06O29(IDEN,ID)
C ---> formerly SUBROUTINE IDP
CHARACTER*8 IDEN,ID
CHARACTER*6 ZEROES
CHARACTER*1 JCHAR
SAVE
DATA ZEROES/'000000'/
ID = ' '
L = INDEX(IDEN(1:8),' ')
IF(L.EQ.0) THEN
N = 8
ELSE
N = L - 1
IF(N.LT.1) THEN
ID = 'AMDARZ'
END IF
END IF
IF(N.EQ.8) THEN
IF(IDEN(8:8).EQ.'Z') THEN
C THE ID INDICATES IT IS AN 8-CHARACTER ASDAR REPORT. COMPRESS IT BY
C DELETING THE 6TH AND 7TH CHARACTER
C ------------------------------------------------------------------
ID = IDEN(1:5)//'Z'
GO TO 500
END IF
END IF
L = I05O29(IDEN(1:1),7,JCHAR)
IF(L.EQ.0.OR.L.GT.6.OR.N.GT.6) THEN
C UP THROUGH 6 CHARACTERS ARE LETTERS. CHANGE 6TH CHARACTER TO 'Z'
C ---------------------------------------------------------------
IF(N.GE.5) THEN
ID = IDEN
ID(6:6) = 'Z'
ELSE
C ZERO FILL AND ADD 'Z' TO MAKE 6 CHARAACTERS
C -------------------------------------------
ID = IDEN(1:N)//ZEROES(N+1:5)//'Z'
END IF
ELSE IF(N.EQ.6) THEN
C THE IDEN HAS 6 NUMERIC OR ALPHANUMERIC CHARACTERS
C -------------------------------------------------
IF(IDEN(6:6).EQ.'Z') THEN
ID = IDEN(1:6)
ELSE IF(L.GT.3) THEN
ID = IDEN(1:3)//IDEN(5:6)//'Z'
ELSE IF(L.EQ.1) THEN
ID = IDEN(2:6)//'Z'
ELSE
ID = IDEN(1:L-1)//IDEN(L+1:6)//'Z'
END IF
ELSE IF(N.EQ.5) THEN
C THE IDEN HAS 5 NUMERIC OR ALPHANUMERIC CHARACTERS
C -------------------------------------------------
ID = IDEN(1:5)//'Z'
ELSE
C THE IDEN HAS 1-4 NUMERIC OR ALPHANUMERIC CHARACTERS
C ---------------------------------------------------
IF(L.EQ.1) THEN
ID = ZEROES(1:5-N)//IDEN(1:N)//'Z'
ELSE
IF(N.LT.L) THEN
IDEN(1:6) = 'AMDARZ'
ELSE
ID = IDEN(1:L-1)// ZEROES(1:5-N)//IDEN(L:N)//'Z'
END IF
END IF
END IF
500 CONTINUE
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: I05O29 FINDS LOCATION OF NEXT NUMERIC
C PRGMMR: RAY CRAYTON ORG: W/NMC41 DATE: 1989-07-07
C
C ABSTRACT: FINDS THE LOCATION OF THE NEXT NUMERIC CHARACTER
C IN A STRING OF CHARACTERS.
C
C PROGRAM HISTORY LOG:
C 1989-07-07 RAY CRAYTON
C
C USAGE: LOC=I05O29(STRING,NUM,CHAR)
C INPUT ARGUMENT LIST:
C STRING - CHARACTER ARRAY.
C NUM - NUMBER OF CHARACTERS TO SEARCH IN STRING.
C
C OUTPUT ARGUMENT LIST:
C I05O29 - INTEGER*4 LOCATION OF ALPHANUMERIC CHARACTER.
C = 0 IF NOT FOUND.
C CHAR - CHARACTER FOUND.
C
C REMARKS: NONE
C
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
FUNCTION I05O29(STRING,NUM,CHAR)
C ---> formerly FUNCTION IFIG
CHARACTER*1 STRING(1),CHAR
SAVE
DO I = 1,NUM
IF(STRING(I).GE.'0'.AND.STRING(I).LE.'9') THEN
I05O29 = I
CHAR = STRING(I)
GO TO 200
END IF
ENDDO
I05O29 = 0
CHAR = '?'
200 CONTINUE
RETURN
END