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