C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: IW3UNP29 UNPACKS A REPORT INTO UNPKED ON29/124 FMT C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05 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 JBUFR 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 JBUFR 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 JBUFR STN. ID) - NEVER ANY C DUPL. IDS NOW FOR U.S. SATWNDS DECODED FROM A SINGLE C JBUFR 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 JBUFR 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 C C USAGE: II = IW3UNP29(NUNIT, OBS, IER) C INPUT ARGUMENT LIST: C NUNIT - FORTRAN UNIT NUMBER FOR SEQUENTIAL DATA SET CONTAINING C - PACKED JBUFR 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/w3libs/w3lib.source 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 JBUFR 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 W3LIB - 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 W3LIB C routine "AEA" takes care of the conversion as each C ON29 record is read in) C IF INPUT DATA SET IS JBUFR, 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 cvvvvvdak port 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 caaaaadak port 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 JBUFR 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 JBUFR 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: IBM-SP, CRAY, SGI 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) DIMENSION OBS(*) 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 W3LIB C A V O I D B L O C K D A T A I N W 3 L I B ) 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 ',LUNIT,' OUT OF RANGE -- ', $ 'IER = 999' 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 - VERSION: 03-05-2002' IF(I03O29(LUNIT,OBS,IER).EQ.1) THEN PRINT *,'IW3UNP29 - OPENED A TRUE OFFICE NOTE 29 FILE IN ', $ 'UNIT ',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 JBUFR FILE IN UNIT ',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 ',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 JBUFR 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 = ',KSKACF(1) IF(KSKACF(2).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', $ 'REPORTS TOSSED DUE TO BEING "LFPW" AMDAR = ',KSKACF(2) IF(KSKACF(8).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', $ 'REPORTS TOSSED DUE TO BEING "PHWR" AIREP = ',KSKACF(8) IF(KSKACF(3).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', $ 'REPORTS TOSSED DUE TO BEING CARSWELL AMDAR = ',KSKACF(3) IF(KSKACF(4).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', $ 'REPORTS TOSSED DUE TO BEING CARSWELL ACARS = ',KSKACF(4) IF(KSKACF(5).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT/', $ 'AIRCAR REPORTS TOSSED DUE TO HAVING MISSING WIND = ', $ KSKACF(5) IF(KSKACF(6).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', $ 'REPORTS TOSSED DUE TO BEING AMDAR < 2286 M = ',KSKACF(6) IF(KSKACF(7).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', $ 'REPORTS TOSSED DUE TO BEING AIREP < 100 M = ',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 = ',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 = ',KSKUPA IF(KSKSFC.GT.0) PRINT *, 'IW3UNP29 - TOTAL NO. OF ADPSFC/', $ 'SFCSHP/SFCBOG REPORTS TOSSED = ',KSKSFC IF(KSKSAT.GT.0) PRINT *, 'IW3UNP29 - TOTAL NO. OF SATWND ', $ 'REPORTS TOSSED = ',KSKSAT IF(KSKSMI.GT.0) PRINT *, 'IW3UNP29 - TOTAL NO. OF SPSSMI ', $ 'REPORTS TOSSED = ',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 ',LUNIT,' OUT OF ', $ 'RANGE -- IER = 999' 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 - CANT 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 CHARACTER*6 C01O29 CHARACTER*4 CDUMP cvvvvvdak port cdak DIMENSION OBS(1608),RON85(8),JDATE(5),JDUMP(5) DIMENSION OBS(1608),RON85(16),JDATE(5),JDUMP(5) caaaaadak port EQUIVALENCE (RON85(1),ON85) SAVE cvvvvvdak port cdak DATA RON85/' '/ DATA ON85/' '/ caaaaadak port 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) ON85 IF(ON85(1:4).NE.'BUFR') GO TO 10 cvvvvvy2k call datelen(10) caaaaay2k CALL DUMPBF(LUNIT,JDATE,JDUMP) cppppp print *, 'CENTER DATE (JDATE) = ',jdate print *, 'DUMP DATE (JDUMP) (year not used anywhere) = ',jdump cppppp Cvvvvvvvvvvvvvvvvvvvvvvvvvvv 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 cvvvvvy2k PRINT *, '##IW3UNP29/I02O29 - 2-DIGIT YEAR IN JDATE(1) ', $ 'RETURNED FROM DUMPBF (JDATE IS: ',JDATE,') - USE ', $ 'WINDWOING TECHNIQUE TO OBTAIN 4-DIGIT YEAR' caaaaay2k IF(JDATE(1).GT.20) THEN WRITE(CDATE,101) (JDATE(I),I=1,4) 101 FORMAT('19',4I2.2) ELSE WRITE(CDATE,102) (JDATE(I),I=1,4) 102 FORMAT('20',4I2.2) ENDIF cvvvvvy2k PRINT *, '##IW3UNP29/I02O29 - CORRECTED JDATE(1) WITH ', $ '4-DIGIT YEAR, JDATE NOW IS: ',JDATE caaaaay2k 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 ' cvvvvvdak port cdak OBS(1:8) = RON85 OBS(1:16) = RON85 caaaaadak port I02O29 = 1 Caaaaaaaaaaaaaaaaaaaaaaaaaaa 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 ',LUNIT,' IS OPENED ', $ 'FOR OUTPUT -- IER = 999' I02O29 = 999 IER = 999 RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: I03O29 UNPACKS REPORT FROM A TRUE ON29/124 DSET C PRGMMR: J. S. WOOLLEN ORG: NP20 DATE: 1996-10-04 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 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/w3libs/w3lib.source 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: IBM-SP, CRAY, SGI C C$$$ FUNCTION I03O29(NUNIT, OBS, IER) C ---> formerly FUNCTION KW3O29 CHARACTER*1 CBUFF(6432),CON85L(32) cvvvvvdak port CHARACTER*2 CBF910 caaaaadak port CHARACTER*4 CYR4D 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,ERR=9998,END=9997) CBUFF IF(CBUFF(1)//CBUFF(2)//CBUFF(3)//CBUFF(4).EQ.'BUFR') THEN C INPUT DATASET IS JBUFR - EXIT IMMEDIATELY C ----------------------------------------- IOLDUN = 0 NEXT = 0 IER = 999 GO TO 90 END IF 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 cvvvvvy2k cdak CALL XMOVEX(OBS,IBUFF,40) 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 cvvvvvdak port cdak READ(CBUFF(9)//CBUFF(10),'(I2)') IYR2D CBF910 = CBUFF(9)//CBUFF(10) READ(CBF910,'(I2)') IYR2D caaaaadak port PRINT *, '##IW3UNP29/I03O29 - 2-DIGIT YEAR FOUND IN ON85 ', $ 'LBL (',CBUFF(1:32),') IS: ',IYR2D PRINT *, ' - USE WINDOWING TECHNIQUE TO ', $ 'OBTAIN 4-DIGIT YEAR' IF(IYR2D.GT.20) THEN IYR4D = 1900 + IYR2D ELSE IYR4D = 2000 + IYR2D ENDIF PRINT *, '##IW3UNP29/I03O29 - 4-DIGIT YEAR OBTAINED VIA ', $ 'WINDOWING TECHNIQUE IS: ',IYR4D PRINT *, ' ' 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 caaaaay2k 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 ', $ '(=',SUBSET,') -- CONTINUE~~' 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) CHARACTER*(*) RSV,RSV2 cvvvvvdak port cdak CHARACTER*8 SID,RCT,CHDR(12) CHARACTER*8 COB,SID,RCT DIMENSION IHDR(12),RHDR(12),ICATS(50,150,11) cdak EQUIVALENCE (CHDR(1),IHDR(1),RHDR(1)) EQUIVALENCE (IHDR(1),RHDR(1)),(COB,IOB),(ICATS,RCATS) caaaaadak port SAVE cvvvvvdak port cdak DATA BLANK/' '/,OMISS/99999/,BMISS/10E10/ DATA OMISS/99999/,BMISS/10E10/ caaaaadak port C INITIALIZE THE UNPACK ARRAY TO MISSINGS C --------------------------------------- NCAT = 0 RCATS = OMISS cvvvvvdak port COB = ' ' cdak RCATS(6,1:149,1) = BLANK cdak RCATS(4,1:149,2) = BLANK cdak RCATS(4,1:149,3) = BLANK cdak RCATS(4,1:149,4) = BLANK cdak RCATS(6,1:149,5) = BLANK cdak RCATS(6,1:149,6) = BLANK cdak RCATS(3,1:149,7) = BLANK cdak RCATS(3,1:149,8) = BLANK 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 caaaaadak port 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 ',sid,' has a ', $ 'missing LATITUDE - on29 hdr, word 1 is set to ',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 ',sid,' has a ', $ 'missing LONGITUDE - on29 hdr, word 2 is set to ',RHDR(2) cppppp RHDR( 3) = OMISS RHDR( 4) = OMISS cvvvvvdak port cdak IF(RHR.LT.BMISS) RHDR( 4) = NINT((100.*RHR)+0.0000001) IF(RHR.LT.BMISS) RHDR( 4) = NINT((100.*RHR)+0.0001) caaaaadak port cppppp IF(RHR.GE.BMISS) print *, '~~IW3UNP29/S01O29: ID ',sid,' has a ', $ 'missing OB TIME - on29 hdr, word 4 is set to ',RHDR(4) cppppp IF(RSV2.EQ.' ') THEN cvvvvvdak port COB = ' ' COB(1:4) = RCT(3:4)//RSV(1:2) IHDR(5) = IOB cdak CHDR( 5) = RCT(3:4)//RSV(1:2) COB = ' ' COB(1:3) = RCT(1:2)//RSV(3:3) IHDR(6) = IOB cdak CHDR( 6) = RCT(1:2)//RSV(3:3) ELSE COB = ' ' COB(1:4) = RSV2(3:4)//RSV(1:2) IHDR(5) = IOB cdak CHDR( 5) = RSV2(3:4)//RSV(1:2) COB = ' ' COB(1:3) = RSV2(1:2)//RSV(3:3) IHDR(6) = IOB cdak CHDR( 6) = RSV2(1:2)//RSV(3:3) caaaaadak port END IF RHDR( 7) = NINT(ELV) IHDR( 8) = ITP IHDR( 9) = RTP RHDR(10) = OMISS cvvvvvdak port COB = ' ' COB(1:4) = SID(1:4) IHDR(11) = IOB cdak CHDR(11) = SID(1:4) COB = ' ' COB(1:4) = SID(5:6)//' ' IHDR(12) = IOB cdak CHDR(12) = SID(5:6)//' ' caaaaadak port 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 cvvvvvdak port cdak CHARACTER*8 CCAT(50),C11,C12 CHARACTER*8 COB,C11,C12 caaaaadak port CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,PSQ,SPQ,SWQ,STQ, $ DDQ DIMENSION RCAT(50),JCAT(50) cvvvvvdak port cdak EQUIVALENCE (RCAT(1),CCAT(1),JCAT(1)),(C11,HDR(11)),(C12,HDR(12)) EQUIVALENCE (RCAT(1),JCAT(1)),(C11,HDR(11)),(C12,HDR(12)), $ (COB,IOB) caaaaadak port LOGICAL SURF SAVE DATA BMISS/10E10/ 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 ',ICAT,' OUT OF ', $ 'BOUNDS -- IER = 999' 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 ',N,' EXCEEDS 255 ', $ '-- IER = 999' 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 ',ncat(kcat),' for cat ',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 = ', $ POB(N),') -- IER = 999' RETURN 1 END IF NCAT(KCAT) = MAX(NCAT(KCAT),L) cppppp if(iprint.eq.1) $ print *, 'Will write cat. 1 data on lvl ',L,' for cat ',kcat, $ ', - total no. cat. 1 lvls processed so far = ',ncat(kcat) cppppp ELSEIF(SURF) THEN L = 1 NCAT(KCAT) = MAX(NCAT(KCAT),1) cppppp if(iprint.eq.1) $ print *, 'Will write cat. ',kcat,' SURFACE data on lvl ',L, $ ', - total no. cat. ',kcat,' lvls processed so far = ', $ ncat(kcat) cppppp ELSE L = MIN(149,NCAT(KCAT)+1) IF(L.EQ.149) THEN cppppp print *, '~~IW3UNP29/S02O29: ID ',c11(1:4)//c12(1:2), $ ' - This cat. ',kcat,', level cannot be processed because ', $ 'the limit has already been reached' cppppp RETURN END IF NCAT(KCAT) = L cppppp if(iprint.eq.1) $ print *, 'Will write cat. ',kcat,' NON-SFC data on lvl ',L, $ ', - total no. cat. ',kcat,' lvls processed so far = ', $ ncat(kcat) cppppp END IF C EACH CATEGORY NEEDS A SPECIFIC DATA ARRANGEMENT C ----------------------------------------------- cvvvvvdak port COB = ' ' caaaaadak port 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))) cvvvvvdak port COB(1:4) = ZQM(N)//TQM(N)//QQM(N)//WQM(N) JCAT(6) = IOB cdak CCAT(6) = ZQM(N)//TQM(N)//QQM(N)//WQM(N) caaaaadak port 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) cvvvvvdak port COB(1:3) = PQM(N)//TQM(N)//QQM(N) JCAT(4) = IOB cdak CCAT(4) = PQM(N)//TQM(N)//QQM(N) caaaaadak port 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 cvvvvvdak port COB(1:2) = PQM(N)//WQM(N) JCAT(4) = IOB cdak CCAT(4) = PQM(N)//WQM(N) caaaaadak port 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) cvvvvvdak port COB(1:2) = ZQM(N)//WQM(N) JCAT(4) = IOB cdak CCAT(4) = ZQM(N)//WQM(N) caaaaadak port 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) cvvvvvdak port COB(1:4) = PQM(N)//TQM(N)//QQM(N)//WQM(N) JCAT(6) = IOB cdak CCAT(6) = PQM(N)//TQM(N)//QQM(N)//WQM(N) caaaaadak port 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) cvvvvvdak port COB(1:4) = ZQM(N)//TQM(N)//QQM(N)//WQM(N) JCAT(6) = IOB cdak CCAT(6) = ZQM(N)//TQM(N)//QQM(N)//WQM(N) caaaaadak port ELSEIF(ICAT.EQ.7) THEN RCAT(1) = MIN(NINT(CLP(N)),99999) RCAT(2) = MIN(NINT(CLA(N)),99999) cvvvvvdak port COB(1:2) = QCP(N)//QCA(N) JCAT(3) = IOB cdak CCAT(3) = QCP(N)//QCA(N) caaaaadak port ELSEIF(ICAT.EQ.8) THEN RCAT(1) = MIN(NINT(OB8(N)),99999) RCAT(2) = MIN(NINT(CF8(N)),99999) cvvvvvdak port COB(1:2) = Q81(N)//Q82(N) JCAT(3) = IOB cdak CCAT(3) = Q81(N)//Q82(N) caaaaadak port 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) cvvvvvdak port COB(1:4) = PSQ//SPQ//SWQ//STQ JCAT(9) = IOB cdak CCAT( 9) = PSQ//SPQ//SWQ//STQ COB = ' ' COB(1:1) = DDQ JCAT(10) = IOB cdak CCAT(10) = DDQ caaaaadak port 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) cvvvvvdak port cdak RCAT(21) = MIN(IABS(NINT(APT)),99999) RCAT(21) = MIN(ABS(NINT(APT)),99999) caaaaadak port IF(CPT.GE.BMISS.AND.APT.LT.0.) cvvvvvdak port cdak $ RCAT(21) = MIN(IABS(NINT(APT))+500,99999) $ RCAT(21) = MIN(ABS(NINT(APT))+500,99999) caaaaadak port 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 ',ICAT,' NOT SUPPORTED', $ ' -- IER = 999' 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 ', $ INDX,' WORDS, > LIMIT OF 1608 -- IER = 999' 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 ----------------------------------------------- cvvvvvy2k cdak CALL XMOVEX(UNP(1), HDR(1), 12*8) UNP(1:12) = HDR cdak CALL XMOVEX(UNP(13),RCAT(13),30*8) UNP(13:42) = RCAT(13:42) caaaaay2k 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 ',sid,' has a', $ ' dupl. cat. ',k,' lvl (all data) at ',rcat(1,j)*.1,' mb -- lvl', $ ' will be excluded from processing' else print *,'~~@@IW3UNP29/S04O29: ID ',sid,' has a', $ ' dupl. cat. ',k,' lvl (all data) at ',rcat(1,j),' m -- lvl', $ ' will be excluded from processing' end if cppppp IDUP = 1 ELSE cppppp if(k.ne.4) then print *,'~~@@#IW3UNP29/S04O29: ID ',sid,' has ', $ 'a dupl. cat. ',k,' press. lvl (data differ) at ',rcat(1,j)*.1, $ ' mb -- lvl will NOT be excluded' else print *,'~~@@#IW3UNP29/S04O29: ID ',sid,' has ', $ 'a dupl. cat. ',k,' height lvl (data differ) at ',rcat(1,j), $ ' m -- lvl will NOT be excluded' end if cppppp END IF END IF cvvvvvy2k cdak CALL XMOVEX(RCTL,RCAT(1,J),3*8) RCTL = RCAT(1:3,J) caaaaay2k 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 ',sid,' has had ', $ NCAT(K)-jjj,' lvls removed due to their being duplicates' cppppp ncat(k) = jjj end if IF(NCAT(K).EQ.1) THEN cvvvvvdak port cdak IF(AMIN1(RCATS(1,1,K),RCATS(2,1,K),RCATS(3,1,K)).GT.99998.8) IF(MIN(RCATS(1,1,K),RCATS(2,1,K),RCATS(3,1,K)).GT.99998.8) caaaaadak port $ 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) CHARACTER*1 QMS,SFQ cvvvvvdak port cdak CHARACTER*1 BLANK CHARACTER*1 CBLANK caaaaadak port SAVE cvvvvvdak port cdak DATA BMISS/10E10/,BLANK/' '/ DATA BMISS/10E10/,CBLANK/' '/ caaaaadak port C SET THE INPUT DATA ARRAYS TO MISSING OR BLANK C --------------------------------------------- OBS = BMISS cvvvvvdak port QMS = CBLANK caaaaadak port SFO = BMISS cvvvvvdak port SFQ = CBLANK caaaaadak port RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION I04O29(P) C ---> formerly FUNCTION MANO29 COMMON/IO29JJ/ISET,MANLIN(1001) SAVE IF(ISET.EQ.0) THEN cvvvvvy2k cdak CALL XSTORE(MANLIN,0,1001) MANLIN = 0 caaaaay2k 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 CHARACTER*8 SUBSET,RPID LOGICAL L02O29,L03O29 INTEGER KKK(0:99),KKKK(49) SAVE DATA GRAV/9.8/,CM2K/1.94/,TZRO/273.15/,BMISS/10E10/ 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 cvvvvvdak port cdak IF(AMAX1(PMND,ZMND).GE.BMISS) THEN IF(MAX(PMND,ZMND).GE.BMISS) THEN caaaaadak port 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 cvvvvvdak port cdak IF(NINT(AMAX1(CTL,CTM,CTH)).EQ.0) THEN IF(NINT(MAX(CTL,CTM,CTH)).EQ.0) THEN caaaaadak port 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 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 cvvvvvdak port 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 caaaaadak port 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/ DATA BMISS/10E10/ 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 ',sid cppppp-ID IRECCO = 0 cvvvvvdak port cdak CALL UFBINT(LUNIT,RPMSL,1, 1,IRET,'PMSL') CALL UFBINT(LUNIT,RPMSL_8,1, 1,IRET,'PMSL');RPMSL=RPMSL_8 caaaaadak port IF(SUBSET.EQ.'NC004005') THEN cdak CALL UFBINT(LUNIT,RGP10,1,255,NLEV,'GP10') cdak CALL UFBINT(LUNIT,RPSAL,1,1,IRET,'PSAL') CALL UFBINT(LUNIT,RGP10_8,1,255,NLEV,'GP10');RGP10=RGP10_8 CALL UFBINT(LUNIT,RPSAL_8,1,1,IRET,'PSAL');RPSAL=RPSAL_8 caaaaadak port IF(NINT(VSG(1)).EQ.32.AND.RPMSL.GE.BMISS.AND. cvvvvvdak port cdak $ AMAX1(RGP10(1),RPSAL).LT.BMISS) THEN $ MAX(RGP10(1),RPSAL).LT.BMISS) THEN caaaaadak port cppppp cdak print *, '~~IW3UNP29/R03O29: ID ',sid,' is a Cat. 1 type ', cdak $ 'Flight-level RECCO' cppppp IRECCO = 1 cvvvvvdak port cdak ELSE IF(AMIN1(VSG(1),RPMSL,RGP10(1)).GE.BMISS.AND.RPSAL.LT. ELSE IF(MIN(VSG(1),RPMSL,RGP10(1)).GE.BMISS.AND.RPSAL.LT. caaaaadak port $ BMISS) $ THEN cppppp cdak print *, '~~IW3UNP29/R03O29: ID ',sid,' is a Cat. 6 type ', cdak $ 'Flight-level RECCO (but reformatted into cat. 2/3)' cppppp IRECCO = 6 cvvvvvdak port cdak ELSE IF(AMIN1(VSG(1),RGP10(1)).GE.BMISS.AND.AMAX1(RPMSL,RPSAL) ELSE IF(MIN(VSG(1),RGP10(1)).GE.BMISS.AND.MAX(RPMSL,RPSAL) caaaaadak port $ .LT.BMISS) THEN cppppp cdak print *, '~~IW3UNP29/R03O29: ID ',sid,' is a Cat. 2/3 type', cdak $ ' Flight-level RECCO with valid PMSL' cppppp IRECCO = 23 ELSE cppppp print *, '~~IW3UNP29/R03O29: ID ',sid,' is currently an ', $ 'unknown type of Flight-level RECCO - VSIG =',VSG(1), $ '; PMSL =',RPMSL,'; GP10 =',RGP10(1),' -- SKIP IT for now' 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 ',sid,' has a missing elev, so ', $ 'elevation set to ZERO' cppppp IF((RTP.GT.20.AND.RTP.LT.24).OR.SUBSET.EQ.'NC002004') ELV = 0 END IF cdak if(sid(5:5).eq.' ') print*,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 ---------------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,LVSTR) CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8 caaaaadak port 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 ',sid,' has a ZERO or ', $ 'negative reported pressure that is reset to missing' 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=',L,'; orig. ZOB = ',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=',L,'; VSG=',vsg(L),'; POB = ',pob(L), $ '; QOB = ',qob(L),'; TOB = ',tob(L),'; ZOB = ',zob(L), $ '; DOB = ',dob(L),'; final SOB (kts) = ',sob(L), $ '; origl SOB (mps) = ',arr(7,L) end if cppppp cvvvvvdak port cdak IF(IRECCO.EQ.0.AND.AMAX1(POB(L),DOB(L),SOB(L)).LT.BMISS) cdak $ PWMIN=AMIN1(PWMIN,POB(L)) IF(IRECCO.EQ.0.AND.MAX(POB(L),DOB(L),SOB(L)).LT.BMISS) $ PWMIN=MIN(PWMIN,POB(L)) caaaaadak port ENDDO 4523 CONTINUE MLEV = NLEV cvvvvvdak port cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,QMSTR) CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8 caaaaadak port 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=',L,'; VSG=',vsg(L),'; POB = ',pob(L), $ '; QOB = ',qob(L),'; TOB = ',tob(L),'; ZOB = ',zob(L), $ '; DOB = ',dob(L),'; SOB = ',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 ',L, $ ' will have already been processed as a cat. 3 ', $ 'MAX wind lvl (on lvl ',II,') - skip this Cat. ', $ '3 lvl' end if cppppp cvvvvvdak port cdak IF(AMAX1(SOB(II),DOB(II)).GE.BMISS) THEN IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN caaaaadak port SOB(II) = SOB(L) DOB(II) = DOB(L) cppppp if(iprint.eq.1) then print *, ' ...... also on lvl ',L,' - transfer', $ ' wind data to dupl. MAX wind lvl because its ', $ 'missing there' 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 ',L, $ ' will have already been processed as a cat. 3 ', $ 'lvl (on lvl ',II,') - skip this MAX wind lvl ', $ 'but set' print *, ' cat. 3 lvl PQM to "W"' end if cppppp PQM(II) = 'W' IF(POB(L).EQ.PWMIN) PQM(II) = 'X' cvvvvvdak port cdak IF(AMAX1(SOB(II),DOB(II)).GE.BMISS) THEN IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN caaaaadak port SOB(II) = SOB(L) DOB(II) = DOB(L) cppppp if(iprint.eq.1) then print *, ' ...... also on lvl ',L,' - transfer', $ ' wind data to dupl. cat. 3 lvl because its ', $ 'missing there' 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 ',L, $ ' will have already been processed as a cat. 3 ', $ 'MAX wind lvl (on lvl ',II,') - skip this Cat. ', $ '3 MAX wind lvl' end if cppppp cvvvvvdak port cdak IF(AMAX1(SOB(II),DOB(II)).GE.BMISS) THEN IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN caaaaadak port SOB(II) = SOB(L) DOB(II) = DOB(L) cppppp if(iprint.eq.1) then print *, ' ...... also on lvl ',L,' - transfer', $ ' wind data to dupl. MAX wind lvl because its ', $ 'missing there' 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 cvvvvvdak port cdak IF(AMIN1(DOB(L),ZOB(L),TOB(L)).GE.BMISS) THEN IF(MIN(DOB(L),ZOB(L),TOB(L)).GE.BMISS) THEN caaaavdak port cppppp if(iprint.eq.1) then print *,' ==> For lvl ',L,'; VSG=32 & DOB,ZOB,TOB all ', $ 'missing --> this level not processed' end if VSG(L) = 0 cvvvvvdak port cdak ELSE IF(AMIN1(ZOB(L),TOB(L)).LT.BMISS) THEN ELSE IF(MIN(ZOB(L),TOB(L)).LT.BMISS) THEN caaaaadak port cppppp if(iprint.eq.1) then print *,' ==> For lvl ',L,'; VSG=32 & one or both of ', $ 'ZOB,TOB non-missing --> valid cat. 1 lvl' 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 cvvvvvdak port cdak IF(DOB(L).LT.BMISS.AND.AMIN1(ZOB(L),TOB(L)).GE.BMISS) THEN IF(DOB(L).LT.BMISS.AND.MIN(ZOB(L),TOB(L)).GE.BMISS) THEN caaaaadak port LL = I04O29(POB(L)*.1) IF(LL.EQ.999999) THEN cppppp print *, '~~IW3UNP29/R03O29: ID ',sid,' has VSG=32 for ', $ 'lvl ',L,' but pressure not mand.!! --> this level ', $ 'not processed' cppppp cvvvvvdak port cdak ELSE IF(AMIN1(RCATS(1,LL,1),RCATS(2,LL,1)).LT.99999.) THEN ELSE IF(MIN(RCATS(1,LL,1),RCATS(2,LL,1)).LT.99999.) THEN caaaaadak port IF(RCATS(4,LL,1).GE.99998.) THEN cppppp if(iprint.eq.1) then print *,' ==> For lvl ',L,'; VSG=32 & ZOB,TOB ', $ 'both missing while DOB non-missing BUT one or ', $ 'both of Z, T non-missing while wind missing in' print *,' earlier cat. 1 processing of this ', $ POB(L)*.1,'mb level --> valid cat. 1 lvl' end if cppppp CALL S02O29(1,L,*9999) ELSE cppppp if(iprint.eq.1) then print *,' ==> For lvl ',L,'; VSG=32 & ZOB,TOB ', $ 'both missing while DOB non-missing BUT one or ', $ 'both of Z, T non-missing while wind non-missing', $ ' in' print *,' earlier cat. 1 processing of this ', $ POB(L)*.1,'mb level --> valid cat. 3 lvl' end if cppppp CALL S02O29(3,L,*9999) END IF ELSE cppppp if(iprint.eq.1) then print *,' ==> For lvl ',L,'; VSG=32 & ZOB,TOB both ', $ 'missing while DOB non-missing AND both Z, T ', $ 'missing on' print *,' this ',POB(L)*.1,'mb level in cat. 1 ', $ ' --> valid cat. 3 lvl' end if cppppp CALL S02O29(3,L,*9999) END IF ELSE cppppp print *, '~~IW3UNP29/R03O29: ID ',sid,' has VSG=32 for ', $ 'lvl ',L,' & should never come here!! - by default output', $ ' as cat. 1 lvl' 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 ',L,'; VSG= 4 --> valid cat. 2 lvl' 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 ',L,' is', $ ' also the tropopause level, as its pressure ', $ 'matches that of trop. lvl no. ',II,' - ', $ 'set this cat. 2' print *, ' lvl PQM to "T"' 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 ',L,'; VSG=16 --> valid cat. 3/5 lvl' end if cppppp PQML = PQM(L) cvvvvvdak port cdak IF(AMIN1(SOB(L),DOB(L)).LT.BMISS) CALL S02O29(3,L,*9999) IF(MIN(SOB(L),DOB(L)).LT.BMISS) CALL S02O29(3,L,*9999) caaaaadak port 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 ',SID,'; SHOULD NEVER HAPPEN!!' cppppp CALL S02O29(6,L,*9999) VSG(L) = 0 ELSEIF(NINT(VSG(L)).EQ. 2 .AND. POB(L).LT.BMISS) THEN cvvvvvdak port cdak IF(AMAX1(SOB(L),DOB(L)).LT.BMISS) THEN IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN caaaaadak port cppppp if(iprint.eq.1) then print *, ' ==> For lvl ',L,'; VSG= 2 & POB .ne. missing ', $ '--> valid cat. 3 lvl (expect that ZOB is missing)' end if cppppp CALL S02O29(3,L,*9999) ELSE cppppp if(iprint.eq.1) then print *, ' ==> For lvl ',L,'; VSG= 2 & POB .ne. missing ', $ '--> Cat. 3 level not processed - wind is missing' end if cppppp END IF VSG(L) = 0 ELSEIF(NINT(VSG(L)).EQ. 2 .AND. ZOB(L).LT.BMISS) THEN cvvvvvdak port cdak IF(AMAX1(SOB(L),DOB(L)).LT.BMISS) THEN IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN caaaaadak port 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 ',L,'; VSG= 2 & ZOB .ne. missing ', $ '--> valid cat. 4 lvl (POB must always be missing)' 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 ',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 ',L,'; VSG= 2 & ZOB .ne. missing ', $ '--> Cat. 4 level not processed - wind is missing' 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 ',L,'; VSG= 8 & POB .ne. missing ', $ '--> valid cat. 3 lvl (expect that ZOB is missing)' end if cppppp CALL S02O29(3,L,*9999) VSG(L) = 0 ELSEIF(NINT(VSG(L)).EQ. 8 .AND. ZOB(L).LT.BMISS) THEN cvvvvvdak port cdak IF(AMAX1(SOB(L),DOB(L)).LT.BMISS) THEN IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN caaaaadak port 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 ',L,'; VSG= 8 & ZOB .ne. missing ', $ '--> valid cat. 4 lvl (POB must always be missing)' 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 ',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 ',L,'; VSG= 8 & ZOB .ne. missing ', $ '--> Cat. 4 level not processed - wind is missing' 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=',L,'; POB = ',pob(L),'; QOB = ', $ qob(L),'; TOB = ',tob(L),'; ZOB = ',zob(L),'; DOB = ',dob(L), $ ';' print *, ' SOB = ',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 ----------------------------------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,RCT, 5,255,NRCT,RCSTR) CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,RMORE,4,1,NRMORE,'SIRC TTSS UALNHR UALNMN') CALL UFBINT(LUNIT,RMORE_8,4,1,NRMORE,'SIRC TTSS UALNHR UALNMN') RMORE=RMORE_8 cdak IF(AMAX1(RMORE(3),RMORE(4)).LT.BMISS) THEN IF(MAX(RMORE(3),RMORE(4)).LT.BMISS) THEN caaaaadak port 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= ',SID,' TOSSED - ZERO ', $ 'CAT.1-6,51,52 LVLS' 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 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 cvvvvvdak port REAL(8) RID_8,UFBINT_8 REAL(8) HDR_8(20),RCT_8(5,255),RRSV_8(3),CLDS_8(4,255), $ TMXMNM_8(4,255) caaaaadak port 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 BMISS /10E10 / 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 ------------------------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,PSL,1,1,IRET,'PMSL') cdak CALL UFBINT(LUNIT,STP,1,1,IRET,'PRES') cdak CALL UFBINT(LUNIT,SDR,1,1,IRET,'WDIR') cdak CALL UFBINT(LUNIT,SSP,1,1,IRET,'WSPD') cdak WSPD1 = SSP cdak CALL UFBINT(LUNIT,STM,1,1,IRET,'TMDB') cdak CALL UFBINT(LUNIT,DPD,1,1,IRET,'TMDP') 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 cdak CALL UFBINT(LUNIT,TMX,1,1,IRET,'MXTM') cdak CALL UFBINT(LUNIT,TMI,1,1,IRET,'MITM') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'MXTM');TMX=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'MITM');TMI=UFBINT_8 caaaaadak port ELSE TMX = BMISS TMI = BMISS END IF cvvvvvdak port cdak CALL UFBINT(LUNIT,QSL,1,1,IRET,'QMPR') cdak CALL UFBINT(LUNIT,QSP,1,1,IRET,'QMPR') cdak CALL UFBINT(LUNIT,QMW,1,1,IRET,'QMWN') cdak CALL UFBINT(LUNIT,QMT,1,1,IRET,'QMAT') cdak CALL UFBINT(LUNIT,QMD,1,1,IRET,'QMDD') cdak CALL UFBINT(LUNIT,HVZ,1,1,IRET,'HOVI') cdak CALL UFBINT(LUNIT,PRW,1,1,IRET,'PRWE') cdak CALL UFBINT(LUNIT,PW1,1,1,IRET,'PSW1') cdak CALL UFBINT(LUNIT,PW2,1,1,IRET,'PSW2') cdak CALL UFBINT(LUNIT,CCN,1,1,IRET,'TOCC') cdak CALL UFBINT(LUNIT,CPT,1,1,IRET,'CHPT') cdak CALL UFBINT(LUNIT,APT,1,1,IRET,'3HPC') 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 cdak IF(AMAX1(APT,CPT).GE.BMISS) THEN IF(MAX(APT,CPT).GE.BMISS) THEN caaaaadak port APT = BMISS cvvvvvdak port cdak CALL UFBINT(LUNIT,APT24,1,1,IRET,'24PC') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'24PC');APT24=UFBINT_8 caaaaadak port IF(APT24.LT.BMISS) THEN APT = APT24 CPT = BMISS END IF END IF C READ THE CATEGORY 52 SURFACE DATA FROM BUFR C ------------------------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,PC6,1,1,IRET,'TP06') cdak CALL UFBINT(LUNIT,SND,1,1,IRET,'TOSD') cdak CALL UFBINT(LUNIT,P24,1,1,IRET,'TP24') cdak CALL UFBINT(LUNIT,PTO,1,1,IRET,'TOPC') cdak CALL UFBINT(LUNIT,DOP,1,1,IRET,'.DTHTOPC') 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 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,POW,1,1,IRET,'POWW') cdak CALL UFBINT(LUNIT,HOW,1,1,IRET,'HOWW') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POWW');POW=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOWW');HOW=UFBINT_8 caaaaadak port IF(SUBSET(1:5).EQ.'NC001') THEN IF(SUBSET(6:8).NE.'006') THEN cvvvvvdak port cdak IF(AMIN1(POW,HOW).GE.BMISS) THEN IF(MIN(POW,HOW).GE.BMISS) THEN cdak CALL UFBINT(LUNIT,POW,1,1,IRET,'POWV') cdak CALL UFBINT(LUNIT,HOW,1,1,IRET,'HOWV') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POWV');POW=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOWV');HOW=UFBINT_8 caaaaadak port END IF ELSE C PAOBS always have a missing elev, but we know they are at sea level ELV = 0 END IF END IF cvvvvvdak port cdak CALL UFBINT(LUNIT,SWD,1,1,IRET,'DOSW') cdak CALL UFBINT(LUNIT,SWP,1,1,IRET,'POSW') cdak CALL UFBINT(LUNIT,SWH,1,1,IRET,'HOSW') cdak CALL UFBINT(LUNIT,SST,1,1,IRET,'SST2') cdak IF(SST.GE.BMISS) THEN cdak CALL UFBINT(LUNIT,SST,1,1,IRET,'SST1') cdak IF(SST.GE.BMISS) CALL UFBINT(LUNIT,SST,1,1,IRET,'STMP') cdak END IF cdak CALL UFBINT(LUNIT,SPG,1,1,IRET,'????') cdak CALL UFBINT(LUNIT,SPD,1,1,IRET,'????') cdak CALL UFBINT(LUNIT,SHC,1,1,IRET,'TDMP') cdak CALL UFBINT(LUNIT,SAS,1,1,IRET,'ASMP') cdak CALL UFBINT(LUNIT,WES,1,1,IRET,'????') 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 caaaaadak port I52FLG = 0 cvvvvvdak port cdak IF(AMIN1(SND,P24,POW,HOW,SWD,SWP,SWH,SST,SPG,SPD,SHC,SAS,WES) IF(MIN(SND,P24,POW,HOW,SWD,SWP,SWH,SST,SPG,SPD,SHC,SAS,WES) caaaaadak port $ .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)) cvvvvvdak port cdak CHH = MIN(NINT(CHT),NINT(CHH)) CHH = MIN(CHT,CHH) caaaaadak port ELSE IF(NINT(CTP).LT.30) THEN ITM = MOD(NINT(CTP),10) CTM = MAX(ITM,NINT(CTM)) IF(ITM.EQ.0) CAM = 0. cvvvvvdak port cdak CCM = MAX(NINT(CAM),NINT(CCM)) CCM = MAX(CAM,CCM) cdak CHM = MIN(NINT(CHT),NINT(CHM)) CHM = MIN(CHT,CHM) caaaaadak port 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. cvvvvvdak port cdak CCL = MAX(NINT(CAM),NINT(CCL)) CCL = MAX(CAM,CCL) cdak CHL = MIN(NINT(CHT),NINT(CHL)) CHL = MIN(CHT,CHL) caaaaadak port 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 = ' ' cvvvvvdak port cdak IF(AMAX1(SDR,SSP).GE.BMISS) SWQ = ' ' IF(MAX(SDR,SSP).GE.BMISS) SWQ = ' ' caaaaadak port 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 ------------------------------------------------------------------ cvvvvvdak port cdak CALL UFBINT(LUNIT,ALS,1,1,IRET,'ALSE') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'ALSE');ALS=UFBINT_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,TMXMNM,4,255,NTXM, cdak $ '.DTHMXTM MXTM .DTHMITM MITM') CALL UFBINT(LUNIT,TMXMNM_8,4,255,NTXM, $ '.DTHMXTM MXTM .DTHMITM MITM');TMXMNM=TMXMNM_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,PC1,1,1,IRET,'TP01') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TP01');PC1=UFBINT_8 caaaaadak port IF(PC1.LT.10000) THEN OB8(1) = E20O29(PC1) CF8(1) = 85 Q81(1) = ' ' Q82(1) = ' ' CALL S02O29(8,1,*9999) END IF cvvvvvdak port cdak CALL UFBINT(LUNIT,DUS,1,1,IRET,'TOSS') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOSS');DUS=UFBINT_8 caaaaadak port 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= ',SID,' TOSSED - ZERO ', $ 'CAT.1-6,51,52 LVLS' 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 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) cvvvvvdak port REAL(8) RID_8,RCL,UFBINT_8,RNS_8 REAL(8) HDR_8(20),RCT_8(5,255),ARR_8(10,255),RAW_8(1,255) caaaaadak port DIMENSION OBS(*),HDR(20),RCT(5,255),ARR(10,255),RAW(1,255) EQUIVALENCE (RID_8,SID),(RCL,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 BMISS /10E10 / 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 ------------------------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,HDR,20, 1,IRET,HDSTR) CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) IF(IRET.EQ.0) SID = ' ' cdak CALL UFBINT(LUNIT,RCT, 5,255,NRCT,RCSTR) CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 caaaaadak port 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 ---------------------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,HDR,20,1,IRET,'PSAL FLVL IALT HMSL PRLC') CALL UFBINT(LUNIT,HDR_8,20,1,IRET,'PSAL FLVL IALT HMSL PRLC') HDR=HDR_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,RNS,1,1,IRET,'ACNS') CALL UFBINT(LUNIT,RNS_8,1,1,IRET,'ACNS');RNS=RNS_8 caaaaadak port 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,1,1,IRET,'BORG') ! Effective 3/2002 IF(IRET.EQ.0) THEN CCL = ' ' CALL UFBINT(LUNIT,RCL,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 = ',SID, cdak $ '; CCL = ',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 ' cvvvvvdak port cdak CALL UFBINT(LUNIT,POF,1,1,IRET,'POAF') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POAF');POF=UFBINT_8 IF(POF.LT.BMISS) WRITE(RSV(1:1),'(I1)') NINT(POF) cdak CALL UFBINT(LUNIT,PCT,1,1,IRET,'PCAT') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PCAT');PCT=UFBINT_8 caaaaadak port 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 = ',SID, cdak $ '; CCL = ',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.) cvvvvvdak port cdak call ufbint(lunit,raw,1,255,nlev,'RRSTG') call ufbint(lunit,raw_8,1,255,nlev,'RRSTG');raw=raw_8 caaaaadak port 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 cvvvvvdak port cppppp cdak print *, 'IW3UNP29/R05O29: For ',SID,', raw_8(',ni+7,') = ', cdak $ crawr(1:ni+7) cppppp caaaaadak port 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 ',SID, cdak $ '; CCL = ',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 ',SID, cdak $ '; CCL = ',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 ----------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,DGT,1,1,IRET,'DGOT') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'DGOT');DGT=UFBINT_8 C PUT THE LEVEL DATA INTO ON29 UNITS C ---------------------------------- cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,LVSTR) CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8 caaaaadak port 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) cvvvvvdak port cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,QMSTR) CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8 caaaaadak port 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= ',SID,' TOSSED - ZERO ', $ 'CAT.1-6,51,52 LVLS' 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) 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) cvvvvvdak port REAL(8) RID_8,UFBINT_8 REAL(8) HDR_8(20),RCT_8(5,255),ARR_8(10,255) caaaaadak port 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 BMISS /10E10 / 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 -------------------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,HDR,20,1,IRET,'HGHT PRLC') CALL UFBINT(LUNIT,HDR_8,20,1,IRET,'HGHT PRLC');HDR=HDR_8 caaaaadak port 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 ------------------------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,HDR,20, 1,IRET,HDSTR) cdak CALL UFBINT(LUNIT,RCT, 5,255,NRCT,RCSTR) 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 caaaaadak port 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: JBUFR 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: JBUFR 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 JBUFR 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,SWPR,1,1,IRET,'SWPR') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWPR');SWPR=UFBINT_8 caaaaadak port IF(NINT(SWPR).GT.0.AND.NINT(SWPR).LT.10) $ WRITE(RSV(3:3),'(I1)') NINT(SWPR) SID(2:2) = RSV(3:3) cvvvvvdak port cdak CALL UFBINT(LUNIT,SWTP,1,1,IRET,'SWTP') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWTP');SWTP=UFBINT_8 caaaaadak port IF(SWTP.LT.BMISS) ITP = NINT(SWTP) cvvvvvdak port cdak CALL UFBINT(LUNIT,SWDL,1,1,IRET,'SWDL') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWDL');SWDL=UFBINT_8 caaaaadak port 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 ---------------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,LVSTR) CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8 caaaaadak port 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= ',SID,' TOSSED - ', $ 'PRES. IS ZERO MB' 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 ------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,QMSTR) cdak CALL UFBINT(LUNIT,RFFL,1,1,IRET,'RFFL') CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFFL');RFFL=UFBINT_8 caaaavdak port 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= ',SID,' TOSSED - ZERO ', $ 'CAT.1-6,51,52 LVLS' 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 CHARACTER*80 HDSTR CHARACTER*8 SUBSET,SID,RSV,RSV2 CHARACTER*4 CSTDV CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,CRF cvvvvvdak port REAL(8) RID_8,UFBINT_8,HDR_8(20),TMBR_8(7),ADDP_8(5),PROD_8(2,2) csaaaadak port 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 '/ DATA BMISS /10E10 / 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 ------------------------------------------- cvvvvvdak port cdak CALL UFBINT(LUNIT,HDR,20, 1,IRET,HDSTR) CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,TMBR,1,7,NLEV,'TMBR') CALL UFBINT(LUNIT,TMBR_8,1,7,NLEV,'TMBR');TMBR=TMBR_8 DO NCHN = 1,7 cdak OB8(NCHN) = MIN0(NINT(TMBR(NCHN)*100.),99999) OB8(NCHN) = MIN(NINT(TMBR(NCHN)*100.),99999) caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,ADDP,5,1,IRET,'SFTG ICON ICAG ICED SFTP') CALL UFBINT(LUNIT,ADDP_8,5,1,IRET,'SFTG ICON ICAG ICED SFTP') ADDP=ADDP_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST WSOS') CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST WSOS');PROD=PROD_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'WSOS') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WSOS');PRODN=UFBINT_8 caaaaadak port OB8(1) = NINT(PRODN*10.) cvvvvvdak port cdak CALL UFBINT(LUNIT,RFLG,1,1,IRET,'RFLG') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFLG');RFLG=UFBINT_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST PH2O') CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST PH2O');PROD=PROD_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'PH2O') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PH2O');PRODN=UFBINT_8 caaaaadak port OB8(1) = NINT(PRODN*10.) cvvvvvdak port cdak CALL UFBINT(LUNIT,RFLG,1,1,IRET,'RFLG') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFLG');RFLG=UFBINT_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST REQV') CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST REQV');PROD=PROD_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'REQV') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'REQV');PRODN=UFBINT_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST TMSK') CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST TMSK');PROD=PROD_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'TMSK') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMSK');PRODN=UFBINT_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST CH2O') CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST CH2O');PROD=PROD_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'CH2O') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CH2O');PRODN=UFBINT_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST SMOI') CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST SMOI');PROD=PROD_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'SMOI') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SMOI');PRODN=UFBINT_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST SNDP') CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST SNDP');PROD=PROD_8 caaaaadak port 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 cvvvvvdak port cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'SNDP') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SNDP');PRODN=UFBINT_8 caaaaadak port 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) cvvvvvdak port cdak CALL UFBINT(LUNIT,ACAV,1,1,IRET,'ACAV') CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'ACAV');ACAV=UFBINT_8 caaaaadak port 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= ',SID,' TOSSED - ZERO ', $ 'CAT.1-6,8,51,52 LVLS' 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