C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: W3UNPK77 DECODES SINGLE REPORT FROM BUFR MESSAGES C PRGMMR: KEYSER ORG: NP22 DATE: 2002-03-05 C C ABSTRACT: THIS SUBROUTINE DECODES A SINGLE REPORT FROM BUFR MESSAGES C IN A JBUFR-TYPE DATA FILE. CURRENTLY WIND PROFILER, NEXRAD (VAD) C WIND AND GOES SOUNDING/RADIANCE DATA TYPES ARE VALID. REPORT IS C RETURNED IN QUASI-OFFICE NOTE 29 UNPACKED FORMAT (SEE REMARKS 4.). C C PROGRAM HISTORY LOG: C 1996-12-16 KEYSER -- ORIGINAL AUTHOR (BASED ON W3LIB ROUTINE W3FI77) C 1997-06-02 KEYSER -- ADDED NEXRAD (VAD) WIND DATA TYPE C 1997-06-16 KEYSER -- ADDED GOES SOUNDING/RADIANCE DATA TYPE C 1997-09-18 KEYSER -- ADDED INSTRUMENT DATA USED IN PROCESSING, C SOLAR ZENITH ANGLE, AND SATELLITE ZENITH ANGLE C TO LIST OF PARAMETERS RETURNED FROM GOES C SOUNDING/RADIANCE DATA TYPE C 1998-07-09 KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, HORIZ. C SIGNIFICANCE, VERT. SIGNIFICANCE) TO ACCOUNT C FOR UPDATES TO BUFRTABLE MNEMONICS IN /dcom; C CHANGED CHAR. 6 OF GOES STNID TO BE UNIQUE FOR C TWO DIFFERENT EVEN OR ODD SATELLITE ID'S C (EVERY OTHER EVEN OR ODD SAT. ID NOW GETS SAME C CHAR. 6 TAG) C 1998-08-19 KEYSER -- SUBROUTINE NOW Y2K AND FORTRAN 90 COMPLIANT C 1999-03-16 KEYSER -- INCORPORATED BOB KISTLER'S CHANGES NEEDED C TO PORT THE CODE TO THE IBM SP C 1999-05-17 KEYSER -- MADE CHANGES NECESSARY TO PORT THIS ROUTINE TO C THE IBM SP C 1999-09-26 KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND C PROFILER) BUFR DUMP FILE AFTER 3/2002: CAT. 10 C SURFACE DATA NOW ALL MISSING (MNEMONICS "PMSL", C "WDIR1","WSPD1", "TMDB", "REHU", "REQV" NO C LONGER AVAILABLE); CAT. 11 MNEMONICS "ACAVH", C "ACAVV", "SPP0", AND "NPHL" NO LONGER C AVAILABLE; HEADER MNEMONIC "NPSM" IS NO LONGER C AVAILABLE, HEADER MNEMONIC "TPSE" REPLACES C "TPMI" (AVG. TIME IN MINUTES STILL OUTPUT); C NUMBER OF UPPER-AIR LEVELS INCR. FROM 43 TO UP C TO 64 (SIZE OF OUTPUT "RDATA" ARRAY INCR. FROM C 600 TO 1200 TO ACCOUNT FOR THIS) (WILL STILL C WORK PROPERLY FOR INPUT PROFLR DUMP FILES PRIOR C TO 3/2002) C C C USAGE: CALL W3UNPK77(IDATE,IHE,IHL,LUNIT,RDATA,IRET) C INPUT ARGUMENT LIST: C IDATE - 4-WORD ARRAY HOLDING "CENTRAL" DATE TO PROCESS C - (YYYY, MM, DD, HH) C IHE - NUMBER OF WHOLE HOURS RELATIVE TO "IDATE" FOR DATE OF C - EARLIEST BUFR MESSAGE THAT IS TO BE DECODED; EARLIEST C - DATE IS "IDATE" + "IHE" HOURS (IF "IHE" IS POSITIVE, C - LATEST MESSAGE DATE IS AFTER "IDATE"; IF "IHE" IS C - NEGATIVE LATEST MESSAGE DATE IS PRIOR TO "IDATE") C - EXAMPLE: IF IHE=1, THEN EARLIEST DATE IS 1-HR AFTER C - IDATE; IF IHE=-3, THEN EARLIEST DATE IS 3-HR PRIOR C - TO IDATE C IHL - NUMBER OF WHOLE HOURS RELATIVE TO "IDATE" FOR DATE OF C - LATEST BUFR MESSAGE THAT IS TO BE DECODED; LATEST C - DATE IS "IDATE" + ("IHL" HOURS PLUS 59 MIN) IF "IHL" C - IS POSITIVE (LATEST MESSAGE DATE IS AFTER "IDATE"), C - AND "IDATE" + ("IHL"+1 HOURS MINUS 1 MIN) IF "IHL" C - IS NEGATIVE (LATEST MESSAGE DATE IS PRIOR TO "IDATE") C - EXAMPLE: IF IHL=3, THEN LATEST DATE IS 3-HR 59-MIN C - AFTER IDATE; IF IHL=-2, THEN LATEST DATE IS 1-HR 1-MIN C - PRIOR TO IDATE C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C IRET - CONTROLS DEGREE OF UNIT 6 PRINTOUT (.GE. 0 -LIMITED C - PRINTOUT; = -1 SOME ADDITIONAL DIAGNOSTIC PRINTOUT; C = .LT. -1 -EXTENSIVE PRINTOUT) (SEE REMARKS 3.) C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C RDATA - SINGLE REPORT RETURNED AN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT (SEE REMARKS 4.) (MINIMUM SIZE IS C - 1200 WORDS) C IRET - RETURN CODE AS FOLLOWS: C IRET = 0 ---> REPORT SUCCESSFULLY RETURNED C IRET > 0 ---> NO REPORT RETURNED DUE TO: C = 1 ---> ALL REPORTS READ IN, END C = 2 ---> LAT AND/OR LON DATA MISSING C = 3 ---> RESERVED C = 4 ---> SOME/ALL DATE INFORMATION MISSING C = 5 ---> NO DATA LEVELS PROCESSED (ALL LEVELS ARE MISSING) C = 6 ---> NUMBER OF LEVELS IN REPORT HEADER IS NOT 1 C = 7 ---> NUMBER OF LEVELS IN ANOTHER SINGLE LEVEL SEQUENCE C IS NOT 1 C C INPUT FILES: C UNIT AA - (WHERE AA IS LUNIT ABOVE) FILE HOLDING THE DATA C - IN THE FORM OF BUFR MESSAGES C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C SUBPROGRAMS CALLED: C UNIQUE - UNPK7701 UNPK7702 UNPK7703 UNPK7704 UNPK7705 C - UNPK7706 UNPK7707 UNPK7708 UNPK7709 C LIBRARY: C W3LIB - W3FI04 W3MOVDAT W3DIFDAT ERREXIT C BUFRLIB - DATELEN DUMPBF OPENBF READMG UFBCNT C - READSB UFBINT CLOSBF C C REMARKS: 1) A CONDITION CODE (STOP) OF 15 WILL OCCUR IF THE INPUT C DATES FOR START AND/OR STOP TIME ARE SPECIFIED INCORRECTLY. C 2) A CONDITION CODE (STOP) OF 22 WILL OCCUR IF THE C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII NOR EBCDIC. C 3) THE INPUT ARGUMENT "IRET" SHOULD BE SET PRIOR TO EACH C CALL TO THIS SUBROUTINE. C C *************************************************************** C 4) C BELOW IS THE FORMAT OF AN UNPACKED REPORT IN OUTPUT ARRAY RDATA C (EACH WORD REPRESENTS A FULL-WORD ACCORDING TO THE MACHINE) C N O T E : THIS IS THE SAME FORMAT AS FOR W3LIB ROUTINE W3FI77 C EXCEPT WHERE NOTED C *************************************************************** C CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C FORMAT FOR WIND PROFILER REPORTS CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C HEADER C WORD CONTENT UNIT FORMAT C ---- ---------------------- ------------------- --------- C 1 LATITUDE 0.01 DEGREES REAL C 2 LONGITUDE 0.01 DEGREES WEST REAL C 3 TIME SIGNIFICANCE (BUFR CODE TABLE "0 08 021") INTEGER C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL cvvvvvdak port C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER caaaaadak port C LEFT-JUSTIFIED C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER C 7 STATION ELEVATION METERS REAL C 8 SUBMODE/EDITION NO. (SM X 10) + ED. NO. INTEGER C (ED. NO.=2, CONSTANT; SEE &,~) C 9 REPORT TYPE 71 (CONSTANT) INTEGER C 10 AVERAGING TIME MINUTES INTEGER C (NEGATIVE MEANS PRIOR TO OBS. TIME) C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER C LEFT-JUSTIFIED C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER C LEFT-JUSTIFIED C C 13-34 ZEROED OUT - NOT USED INTEGER C 35 CATEGORY 10, NO. LEVELS COUNT INTEGER C 36 CATEGORY 10, DATA INDEX COUNT INTEGER C 37 CATEGORY 11, NO. LEVELS COUNT INTEGER C 38 CATEGORY 11, DATA INDEX COUNT INTEGER C 39-42 ZEROED OUT - NOT USED INTEGER C C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL C C CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE) C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C(SEE @)1 SEA-LEVEL PRESSURE 0.1 MILLIBARS REAL C(SEE *)2 STATION PRESSURE 0.1 MILLIBARS REAL C(SEE @)3 HORIZ. WIND DIR. DEGREES REAL C(SEE @)4 HORIZ. WIND SPEED 0.1 M/S REAL C(SEE @)5 AIR TEMPERATURE 0.1 DEGREES K REAL C(SEE @)6 RELATIVE HUMIDITY PERCENT REAL C(SEE @)7 RAINFALL RATE 0.0000001 M/S REAL C C CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) C (EACH LEVEL, SEE WORD 37 ABOVE) C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 HEIGHT ABOVE SEA-LVL METERS REAL C 2 HORIZ. WIND DIR. DEGREES REAL C 3 HORIZ. WIND SPEED 0.1 M/S REAL C 4 QUALITY CODE (SEE %) INTEGER C 5 VERT. WIND COMP. (W) 0.01 M/S REAL C(SEE @)6 HORIZ. CONSENSUS NO. (SEE $) INTEGER C(SEE @)7 VERT. CONSENSUS NO. (SEE $) INTEGER C(SEE @)8 SPECTRAL PEAK POWER DB REAL C 9 HORIZ. WIND SPEED 0.1 M/S REAL C STANDARD DEVIATION 0.1 M/S REAL C 10 VERT. WIND COMPONENT 0.1 M/S REAL C STANDARD DEVIATION 0.1 M/S REAL C(SEE @)11 MODE (SEE #) INTEGER C C *- ALWAYS MISSING C &- THIS IS A CHANGE FROM FORMAT IN W3LIB ROUTINE W3FI77 C %- 0 - MEDIAN AND SHEAR CHECKS BOTH PASSED C 2 - MEDIAN AND SHEAR CHECK RESULTS INCONCLUSIVE C 4 - MEDIAN CHECK PASSED; SHEAR CHECK FAILED C 8 - MEDIAN CHECK FAILED; SHEAR CHECK PASSED C 12 - MEDIAN AND SHEAR CHECKS BOTH FAILED C $- NO. OF INDIVIDUAL 6-MINUTE AVERAGE MEASUREMENTS THAT WERE C INCLUDED IN FINAL ESTIMATE OF AVERAGED WIND (RANGE: 0, 2-10) C (BASED ON A ONE-HOUR AVERAGE) C #- 1 - DATA FROM LOW MODE C 2 - DATA FROM HIGH MODE C 3 - MISSING C @- THIS PARAMETER IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET C TO MISSING (99999 FOR INTEGER OR 99999. FOR REAL) C ~- SUBMODE IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET TO 3 C (ITS MISSING VALUE) C CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C FORMAT FOR GOES SOUNDING/RADIANCE REPORTS CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C HEADER C WORD CONTENT UNIT FORMAT C ---- ---------------------- ------------------- --------- C 1 LATITUDE 0.01 DEGREES REAL C 2 LONGITUDE 0.01 DEGREES WEST REAL C 3 FIELD OF VIEW NUMBER NUMERIC INTEGER C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL cvvvvvdak port C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER caaaaadak port C LEFT-JUSTIFIED C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER C 7 STATION ELEVATION METERS REAL C 8 PROCESS. TECHNIQUE (=21-CLEAR; INTEGER C 8 PROCESS. TECHNIQUE =23-CLOUD-CORRECTED) C 9 REPORT TYPE 61 (CONSTANT) INTEGER C 10 QUALITY FLAG (BUFR CODE TABLE "0 33 002") INTEGER C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER C LEFT-JUSTIFIED C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER C LEFT-JUSTIFIED (SEE %) C C 13-26 ZEROED OUT - NOT USED C 27 CATEGORY 08, NO. LEVELS COUNT INTEGER C 28 CATEGORY 08, DATA INDEX COUNT INTEGER C 29-38 ZEROED OUT - NOT USED C 39 CATEGORY 12, NO. LEVELS COUNT INTEGER C 40 CATEGORY 12, DATA INDEX COUNT INTEGER C 41 CATEGORY 13, NO. LEVELS COUNT INTEGER C 42 CATEGORY 13, DATA INDEX COUNT INTEGER C C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL C C CATEGORY 12 - SATELLITE SOUNDING LEVEL DATA (FIRST LEVEL IS SURFACE; C EACH LEVEL, SEE 39 ABOVE) C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 PRESSURE 0.1 MILLIBARS REAL C 2 GEOPOTENTIAL METERS REAL C 3 TEMPERATURE 0.1 DEGREES C REAL C 4 DEWPOINT TEMPERATURE 0.1 DEGREES C REAL C 5 NOT USED SET TO MISSING REAL C 6 NOT USED SET TO MISSING REAL C 7 QUALITY MARKERS 4-CHARACTERS CHARACTER C LEFT-JUSTIFIED (SEE &) C C CATEGORY 13 - SATELLITE RADIANCE "LEVEL" DATA (EACH "LEVEL", SEE C 41 ABOVE) C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 CHANNEL NUMBER NUMERIC INTEGER C 2 BRIGHTNESS TEMP. 0.01 DEG. KELVIN REAL C 3 QUALITY MARKERS 4-CHARACTERS CHARACTER C LEFT-JUSTIFIED (SEE &&) C C CATEGORY 08 - ADDITIONAL (MISCELLANEOUS) DATA (EACH LEVEL, SEE @ C BELOW) C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 VARIABLE SEE @ BELOW REAL C 2 CODE FIGURE SEE @ BELOW REAL C 3 MARKERS 2-CHARACTERS CHARACTER C LEFT-JUSTIFIED (SEE #) C C %- SIXTH CHARACTER OF STATION ID IS A TAGGED AS FOLLOWS: C "I" - GOES-EVEN-1 (252, 256, ...) SAT. , CLEAR COLUMN RETR. C "J" - GOES-EVEN-1 (252, 256, ...) SAT. , CLD-CORRECTED RETR. C "L" - GOES-ODD-1 (253, 257, ...) SAT. , CLEAR COLUMN RETR. C "M" - GOES-ODD-1 (253, 257, ...) SAT. , CLD-CORRECTED RETR. C "O" - GOES-EVEN-2 (254, 258, ...) SAT. , CLEAR COLUMN RETR. C "P" - GOES-EVEN-2 (254, 258, ...) SAT. , CLD-CORRECTED RETR. C "Q" - GOES-ODD-2 (251, 255, ...) SAT. , CLEAR COLUMN RETR. C "R" - GOES-ODD-2 (251, 255, ...) SAT. , CLD-CORRECTED RETR. C "?" - EITHER SATELLITE AND/OR RETRIEVAL TYPE UNKNOWN C &- FIRST CHARACTER IS Q.M. FOR GEOPOTENTIAL C SECOND CHARACTER IS Q.M. FOR TEMPERATURE C THIRD CHARACTER IS Q.M. FOR DEWPOINT TEMPERATURE C FOURTH CHARACTER IS NOT USED C " " - INDICATES DATA NOT SUSPECT C "Q" - INDICATES DATA ARE SUSPECT C "F" - INDICATES DATA ARE BAD C &&- FIRST CHARACTER IS Q.M. FOR BRIGHTNESS TEMPERATURE C SECOND-FOURTH CHARACTERS ARE NOT USED C " " - INDICATES DATA NOT SUSPECT C "Q" - INDICATES DATA ARE SUSPECT C "F" - INDICATES DATA ARE BAD C @- NUMBER OF "LEVELS" FROM WORD 27. MAXIMUM IS 12, AND ARE ORDERED C AS FOLLOWS (IF A DATUM ARE MISSING THAT LEVEL NOT STORED) C 1 - LIFTED INDEX ---------- .01 DEG. KELVIN -- C. FIG. 250. C 2 - TOTAL PRECIP. WATER -- .01 MILLIMETERS -- C. FIG. 251. C 3 - 1. TO .9 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 252. C 4 - .9 TO .7 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 253. C 5 - .7 TO .3 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 254. C 6 - SKIN TEMPERATURE ----- .01 DEG. KELVIN -- C. FIG. 255. C 7 - CLOUD TOP TEMPERATURE- .01 DEG. KELVIN -- C. FIG. 256. C 8 - CLOUD TOP PRESSURE --- .1 MILLIBARS ----- C. FIG. 257. C 9 - CLOUD AMOUNT (BUFR TBL. C.T. 0-20-011) -- C. FIG. 258. C 10 - INSTR. DATA USED IN PROC. C (BUFR TBL. C.T. 0-02-021) -- C. FIG. 259. C 11 - SOLAR ZENITH ANGLE --- .01 DEGREE ------- C. FIG. 260. C 12 - SAT. ZENITH ANGLE ---- .01 DEGREE ------- C. FIG. 261. C #- FIRST CHARACTER IS Q.M. FOR THE DATUM C " " - INDICATES DATA NOT SUSPECT C "Q" - INDICATES DATA ARE SUSPECT C "F" - INDICATES DATA ARE BAD C SECOND CHARACTER IS NOT USED C CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C FORMAT FOR NEXRAD (VAD) WIND REPORTS CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C HEADER C WORD CONTENT UNIT FORMAT C ---- ---------------------- ------------------- --------- C 1 LATITUDE 0.01 DEGREES REAL C 2 LONGITUDE 0.01 DEGREES WEST REAL C 3 ** RESERVED ** SET TO 99999 INTEGER C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL cvvvvvdak port C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER caaaaadak port C LEFT-JUSTIFIED C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER C 7 STATION ELEVATION METERS REAL C 8 ** RESERVED ** SET TO 99999 INTEGER C C 9 REPORT TYPE 72 (CONSTANT) INTEGER C 10 ** RESERVED ** SET TO 99999 INTEGER C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER C LEFT-JUSTIFIED C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER C LEFT-JUSTIFIED C C 13-18 ZEROED OUT - NOT USED INTEGER C 19 CATEGORY 04, NO. LEVELS COUNT INTEGER C 20 CATEGORY 04, DATA INDEX COUNT INTEGER C 21-42 ZEROED OUT - NOT USED INTEGER C C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL C C CATEGORY 04 - UPPER-AIR WINDS-BY-HEIGHT DATA(FIRST LEVEL IS SURFACE) C (EACH LEVEL, SEE WORD 19 ABOVE) C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 HEIGHT ABOVE SEA-LVL METERS REAL C 2 HORIZ. WIND DIR. DEGREES REAL C 3 HORIZ. WIND SPEED 0.1 M/S (SEE *) REAL C 4 QUALITY MARKERS 4-CHARACTERS CHARACTER C LEFT-JUSTIFIED (SEE %) C C *- UNITS HERE DIFFER FROM THOSE IN TRUE UNPACKED OFFICE NOTE 29 C (WHERE UNITS ARE KNOTS) C %- THE FIRST THREE CHARACTERS ARE ALWAYS BLANK, THE FOURTH C CHARACTER IS A "CONFIDENCE LEVEL" WHICH IS RELATED TO THE ROOT- C MEAN-SQUARE VECTOR ERROR FOR THE HORIZONTAL WIND. IT IS C DEFINED AS FOLLOWS: C 'A' = RMS OF 1.9 KNOTS C 'B' = RMS OF 3.9 KNOTS C 'C' = RMS OF 5.8 KNOTS C 'D' = RMS OF 7.8 KNOTS C 'E' = RMS OF 9.7 KNOTS C 'F' = RMS OF 11.7 KNOTS C 'G' = RMS > 13.6 KNOTS CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C C FOR ALL REPORT TYPES, MISSING VALUES ARE: C 99999. FOR REAL C 99999 FOR INTEGER C 9'S FOR CHARACTERS IN WORD 5, 6 OF HEADER C BLANK FOR CHARACTERS IN WORD 11, 12 OF HEADER C AND FOR CHARACTERS IN ANY CATEGORY LEVEL C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP, CRAY, SGI C C$$$ SUBROUTINE W3UNPK77(IDATE,IHE,IHL,LUNIT,RDATA,IRET) CHARACTER*4 CBUFR INTEGER IDATE(4),LSDATE(4),jdate(8),IDATA(1200) dimension rinc(5) REAL RDATA(*),RDATX(1200) COMMON /PK77BB/kdate(8),ldate(8),IPRINT COMMON /PK77CC/INDEX COMMON /PK77DD/LSHE,LSHL,ICDATE(5),IDDATE(5) COMMON /PK77FF/IFOV(3),KNTSAT(250:260) SAVE EQUIVALENCE (RDATX,IDATA) DATA ITM/0/,LUNITL/-99/,KOUNT/0/ IPRINT = 0 IF(IRET.LT.0) IPRINT = IABS(IRET) IRET = 0 IF(ITM.EQ.0) THEN C----------------------------------------------------------------------- C FIRST AND ONLY TIME INTO THIS SUBROUTINE DO A FEW THINGS.... ITM = 1 IFOV = 0 KNTSAT = 0 C DETERMINE MACHINE WORD LENGTH IN BYTES (=8 FOR CRAY) AND TYPE OF C CHARACTER SET {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)} CALL W3FI04(IENDN,ICHTP,LW) PRINT 2213, LW, ICHTP, IENDN 2213 FORMAT(/' ---> W3UNPK77: CALL TO W3FI04 RETURNS: LW = ',I3, $ ', ICHTP = ',I3,', IENDN = ',I3/) IF(ICHTP.GT.1) THEN C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22 PRINT 217 217 FORMAT(' *** W3UNPK77 ERROR: CHARACTERS ON THIS MACHINE ', $ 'ARE NEITHER ASCII NOR EBCDIC - STOP 22'/) CALL ERREXIT(22) END IF C----------------------------------------------------------------------- END IF IF(LUNIT.NE.LUNITL) THEN C----------------------------------------------------------------------- C IF THE INPUT DATA UNIT NUMBER ARGUMENT IS DIFFERENT THAT THE LAST TIME C THIS SUBR. WAS CALLED, PRINT NEW HEADER, SET JRET = 1 LUNITL = LUNIT JRET = 1 PRINT 101, LUNIT 101 FORMAT(//' ---> W3UNPK77: VERSION 03/05/2002: JBUFR DATA SET ', $ 'READ FROM UNIT ',I4/) C----------------------------------------------------------------------- ELSE C FOR SUBSEQUENT TIMES INTO THIS SUBR. W/ SAME LUNIT AS LAST TIME, C TEST INPUT DATE & HR RANGE ARGUMENTS AGAINST THEIR VALUES THE LAST C TIME SUBR. CALLED -- IF THEY ARE DIFFERENT, SET JRET = 1 (ELSE C JRET = 0), WILL TEST JRET SOON JRET = 1 DO I = 4,1,-1 IF(IDATE(I).NE.LSDATE(I)) GO TO 88 ENDDO IF(IHE.NE.LSHE.OR.IHL.NE.LSHL) GO TO 88 JRET = 0 88 CONTINUE C----------------------------------------------------------------------- END IF IF(JRET.EQ.1) THEN PRINT 6680 6680 FORMAT(/' JRET = 1 - REWIND DATA FILE & SET-UP TO DO DATE CHECK'/) C----------------------------------------------------------------------- C COME HERE IF FIRST CALL TO SUBROUTINE OR IF INPUT DATA UNIT NUMBER OR C IF INPUT DATE/TIME OR RANGE IN TIME HAS BEEN CHANGED FROM LAST CALL C CLOSE BUFR DATA SET (IN CASE OPEN FROM PREVIOUS RUN) C REWIND INPUT BUFR DATA SET, GET CENTER TIME AND DUMP TIME, C OPEN BUFR DATA SET C SET-UP TO DETERMINE IF BUFR MESSAGE IS WITHIN REQUESTED DATES C (ALSO SET INDEX=0, FORCES BUFR MSG TO BE READ BEFORE RPTS ARE DECODED) C----------------------------------------------------------------------- CALL CLOSBF(LUNIT) REWIND LUNIT READ(LUNIT,END=9999,ERR=9999) CBUFR IF(CBUFR.NE.'BUFR') GO TO 9999 call datelen(10) CALL DUMPBF(LUNIT,ICDATE,IDDATE) cppppp print *,'CENTER DATE (ICDATE) = ',icdate print *,'DUMP DATE (IDDATE) = ',iddate cppppp if(icdate(1).le.0) then C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE C - RETURN WITH IRET = 1 print *, ' *** W3UNPK77 ERROR: CENTER DATE COULD NOT BE ', $ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit go to 9998 end if if(iddate(1).le.0) then C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE C - RETURN WITH IRET = 1 print *, ' *** W3UNPK77 ERROR: DUMP DATE COULD NOT BE ', $ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit go to 9998 end if IF(ICDATE(1).LT.100) THEN C If 2-digit year returned in ICDATE(1), must use "windowing" technique C to create a 4-digit year C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) PRINT *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ', $ 'HAPPEN!!!!!' PRINT *, '##W3UNPK77 - 2-DIGIT YEAR IN ICDATE(1) ', $ 'RETURNED FROM DUMPBF (ICDATE IS: ',ICDATE,') - USE ', $ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR' IF(ICDATE(1).GT.20) THEN ICDATE(1) = 1900 + ICDATE(1) ELSE ICDATE(1) = 2000 + ICDATE(1) ENDIF PRINT *, '##WW3UNPK77 - CORRECTED ICDATE(1) WITH 4-DIGIT ', $ 'YEAR, ICDATE NOW IS: ',ICDATE ENDIF IF(IDDATE(1).LT.100) THEN C If 2-digit year returned in IDDATE(1), must use "windowing" technique C to create a 4-digit year C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) PRINT *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ', $ 'HAPPEN!!!!!' PRINT *, '##W3UNPK77 - 2-DIGIT YEAR IN IDDATE(1) ', $ 'RETURNED FROM DUMPBF (IDDATE IS: ',IDDATE,') - USE ', $ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR' IF(IDDATE(1).GT.20) THEN IDDATE(1) = 1900 + IDDATE(1) ELSE IDDATE(1) = 2000 + IDDATE(1) ENDIF PRINT *, '##W3UNPK77 - CORRECTED IDDATE(1) WITH 4-DIGIT ', $ 'YEAR, IDDATE NOW IS: ',IDDATE END IF C OPEN BUFR FILE - READ IN DICTIONARY MESSAGES (TABLE A, B, D ENTRIES) CALL OPENBF(LUNIT,'IN',LUNIT) PRINT 100, LUNIT 100 FORMAT(/5X,'===> BUFR DATA SET IN UNIT',I3,' SUCCESSFULLY ', $ 'OPENED FOR INPUT; DCTNY MESSAGES CONTAIN BUFR TABLES A,B,D'/) INDEX = 0 KOUNT = 0 jdate(1:3) = idate(1:3) jdate(4) = 0 jdate(5) = idate(4) jdate(6:8) = 0 PRINT 6681, IDATE 6681 FORMAT(/' %%% REQUESTED "CENTRAL" DATE IS :',I5,3I3,' 0'/) C DETERMINE EARLIEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING call w3movdat((/0.,real(ihe),0.,0.,0./),jdate,kdate) print 6682, (kdate(i),i=1,3),kdate(5),kdate(6) 6682 FORMAT(/' --> EARLIEST DATE FOR ACCEPTING BUFR MSGS IS:',I5,4I3/) C DETERMINE LATEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING if(ihl.ge.0) then xminl = (ihl * 60) + 59 else xminl = ((ihl + 1) * 60) - 1 end if call w3movdat((/0.,0.,xminl,0.,0./),jdate,ldate) print 6683, (ldate(i),i=1,3),ldate(5),ldate(6) 6683 FORMAT(/' --> LATEST DATE FOR ACCEPTING BUFR MSGS IS:',I5,4I3/) call w3difdat(ldate,kdate,3,rinc) IF(rinc(3).LT.0) THEN PRINT 104 104 FORMAT(' *** W3UNPK77 ERROR: DATES SPECIFIED INCORRECTLY -', $ ' STOP 15'/) CALL ERREXIT(15) END IF C----------------------------------------------------------------------- END IF C SUBR. UNPK7701 RETURNS A SINGLE DECODED REPORT FROM BUFR MESSAGE CALL UNPK7701(LUNIT,ITP,IRET) C IRET=1 MEANS ALL DATA HAVE BEEN DECODED FOR SPECIFIED TIME PERIOD C (REWIND DATA FILE AND RETURN W/ IRET=1) C IRET.GE.2 MEANS REPORT NOT RETURNED DUE TO ERROR IN DECODING (RETURN) C (ACTUALLY IRET.GE.2 CURRENTLY CANNOT HAPPEN OUT OF UNPK7701) IF(IRET.GE.1) THEN IF(IRET.EQ.1) THEN REWIND LUNIT IF(ITP.EQ.2) THEN PRINT 8101, IFOV 8101 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED', $ ' BY F-O-V NO. (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/15X, $ '# WITH F-O-V NO. 00 TO 02:',I6,' - GET "BAD" Q.MARK'/15X, $ '# WITH F-O-V NO. 03 TO 09:',I6,' - GET "SUSPECT" Q.MARK'/15X, $ '# WITH F-O-V NO. 10 TO 25:',I6,' - GET "NEUTRAL" Q.MARK'/20X, $ '(NOTE: RADIANCES ALWAYS HAVE NEUTRAL Q.MARK)'/) PRINT 8102 8102 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED', $ ' BY SATELLITE ID (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/) DO IDSAT = 250,259 IF(KNTSAT(IDSAT).GT.0) PRINT 8103, IDSAT,KNTSAT(IDSAT) ENDDO 8103 FORMAT(15X,'NUMBER FROM SAT. ID',I4,4X,':',I6) IF(KNTSAT(260).GT.0) PRINT 8104 8104 FORMAT(15X,'NUMBER FROM UNKNOWN SAT. ID:',I6) PRINT 8105 8105 FORMAT(/) END IF END IF GO TO 99 END IF KOUNT = KOUNT + 1 C INITIALIZE THE OUTPUT ON29 ARRAY CALL UNPK7702(RDATA,ITP) IF(ITP.EQ.1) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO WIND PROFILER REPORTS C----------------------------------------------------------------------- C STORE THE HEADER INFORMATION INTO ON29 FORMAT CALL UNPK7703(LUNIT,RDATA,IRET) C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN) IF(IRET.GE.2) GO TO 99 C STORE THE SURFACE DATA INTO ON29 FORMAT (CATEGORY 10) CALL UNPK7704(LUNIT,RDATA) C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 11) CALL UNPK7705(LUNIT,RDATA) RDATX(1:1200) = RDATA(1:1200) IF(IDATA(35)+IDATA(37).EQ.0) IRET = 5 ELSE IF(ITP.EQ.2) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO GOES SOUNDING/RADIANCE REPORTS C----------------------------------------------------------------------- C STORE THE HEADER INFORMATION INTO ON29 FORMAT CALL UNPK7708(LUNIT,RDATA,KOUNT,IRET) C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN) IF(IRET.GE.2) GO TO 99 C STORE THE UPPER-AIR DATA/RADIANCE INTO ON29 FORMAT (CATEGORY 12, 13) CALL UNPK7709(LUNIT,RDATA,IRET) ELSE IF(ITP.EQ.3) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO NEXRAD (VAD) WIND REPORTS C----------------------------------------------------------------------- C STORE THE HEADER INFORMATION INTO ON29 FORMAT CALL UNPK7706(LUNIT,RDATA,IRET) C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN) IF(IRET.GE.2) GO TO 99 C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 4) CALL UNPK7707(LUNIT,RDATA,IRET) C----------------------------------------------------------------------- END IF 99 CONTINUE C PRIOR TO RETURNING SAVE INPUT DATE & HR RANGE ARGUMENTS FROM THIS CALL lsdate = idate LSHE = IHE LSHL = IHL RETURN C----------------------------------------------------------------------- 9999 CONTINUE C COME HERE IF NULL OR NON-BUFR FILE IS INPUT - RETURN WITH IRET = 1 PRINT *, ' *** W3UNPK77 ERROR: INPUT FILE IN UNIT ',LUNIT,' IS ', $ 'EITHER A NULL OR NON-BUFR FILE' 9998 continue REWIND LUNIT IRET = 1 lsdate = idate LSHE = IHE LSHL = IHL END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: UNPK7701 READS A SINGLE REPORT OUT OF BUFR DATASET C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1996-12-16 C C ABSTRACT: CALLS BUFRLIB ROUTINES TO READ IN A BUFR MESSAGE AND THEN C READ A SINGLE REPORT (SUBSET) OUT OF THE MESSAGE. C C PROGRAM HISTORY LOG: C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR C C USAGE: CALL UNPK7701(LUNIT,ITP,IRET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 - C - WIND PROFILER, =2 - GOES SNDG, =3 - NEXRAD(VAD) WIND} C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK C C INPUT FILES: C UNIT AA - (WHERE AA IS LUNIT ABOVE) FILE HOLDING THE DATA C - IN THE FORM OF BUFR MESSAGES C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPK77. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP, CRAY, SGI C C$$$ SUBROUTINE UNPK7701(LUNIT,ITP,IRET) CHARACTER*8 SUBSET integer mdate(4),ndate(8) dimension rinc(5) COMMON /PK77BB/kdate(8),ldate(8),IPRINT COMMON /PK77CC/INDEX COMMON /PK77DD/LSHE,LSHL,ICDATE(5),IDDATE(5) SAVE DATA IREC/0/ 10 CONTINUE C======================================================================= IF(INDEX.EQ.0) THEN C READ IN NEXT BUFR MESSAGE CALL READMG(LUNIT,SUBSET,IBDATE,JRET) IF(JRET.NE.0) THEN C----------------------------------------------------------------------- PRINT 101 101 FORMAT(' ---> W3UNPK77: ALL BUFR MESSAGES READ IN AND DECODED'/) IRET = 1 RETURN C----------------------------------------------------------------------- END IF if(ibdate.lt.100000000) then c If input BUFR file does not return messages with a 4-digit year, c something is wrong (even non-compliant BUFR messages should c construct a 4-digit year as long as datelen(10) has been called print *, '##W3UNP777/UNPK7701 - A 10-digit Sect. 1 BUFR ', $ 'message date was not returned in unit ',lunit,' - ', $ 'problem with BUFR file - ier = 1' iret = 1 return end if CALL UFBCNT(LUNIT,IREC,ISUB) MDATE(1) = IBDATE/1000000 MDATE(2) = MOD((IBDATE/10000),100) MDATE(3) = MOD((IBDATE/100),100) MDATE(4) = MOD(IBDATE,100) C ALL JBUFR MESSAGES CURRENTLY HAVE "00" FOR MINUTES IN SECTION 1 ndate(1:3) = mdate(1:3) ndate(4) = 0 ndate(5) = mdate(4) ndate(6:8) = 0 IF(IPRINT.GE.1) THEN PRINT *,'HAVE SUCCESSFULLY READ IN A BUFR MESSAGE' PRINT 103 103 FORMAT(' BUFR FOUND BEGINNING AT BYTE 1 OF MESSAGE') PRINT 105, IREC,MDATE,SUBSET 105 FORMAT(8X,'HAVE READ IN A BUFR MESSAGE NO.',I3,', DATE: ', $ I6,3I4,' 0; TABLE A ENTRY = ',A8,' AND EDIT. NO. = 2'/) END IF IF(SUBSET.EQ.'NC002007') THEN IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS WIND ', $ 'PROFILER REPORTS' ITP = 1 ELSE IF(SUBSET.EQ.'NC002008') THEN IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS NEXRAD ', $ '(VAD) WIND REPORTS' ITP = 3 ELSE IF(SUBSET.EQ.'NC003001') THEN IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS GOES ', $ 'SOUNDING/RADIANCE REPORTS' ITP = 2 ELSE PRINT 107, IREC 107 FORMAT(' *** W3UNPK77 WARNING: BUFR MESSAGE NO.',I3,' CONTAINS ', $ 'REPORTS THAT CANNOT BE DECODED BY W3UNPK77, TRY READING NEXT ', $ 'MSG'/) INDEX = 0 GO TO 10 END IF call w3difdat(kdate,ndate,3,rinc) kmin = rinc(3) call w3difdat(ldate,ndate,3,rinc) lmin = rinc(3) C CHECK DATE OF MESSAGE AGAINST SPECIFIED TIME RANGES if((kmin.gt.0.or.lmin.lt.0).AND.IREC.GT.2) then PRINT 106, IREC,MDATE 106 FORMAT(' BUFR MESSAGE NO.',I3,' WITH DATE:',I5,3I3,' 0 NOT W/I', $ ' REQ. TIME RANGE, TRY READING NEXT MSG'/) INDEX = 0 GO TO 10 END IF END IF C======================================================================= C READ NEXT SUBSET (REPORT) IN MESSAGE IF(IPRINT.GT.1) PRINT *,'CALL READSB' CALL READSB(LUNIT,JRET) IF(IPRINT.GT.1) PRINT *,'BACK FROM READSB' IF(JRET.NE.0) THEN IF(INDEX.GT.0) THEN C ALL SUBSETS IN THIS MESSAGE PROCESSED, READ IN NEXT MESSAGE (IF ALL C MESSAGES READ IN NO MORE DATA TO PROCESS) IF(IPRINT.GT.1) PRINT *, 'ALL REPORTS IN THIS MESSAGE ', $ 'DECODED, GO ON TO NEXT MESSAGE' ELSE C THERE WERE NO SUBSETS FOUND IN THIS BUFR MESSAGE, GOOD CHANCE IT IS C ONE OF TWO DUMMY MESSAGES AT TOP OF FILE INDICATING CENTER TIME AND C DATA DUMP TIME ONLY; READ IN NEXT MESSAGE IF(IREC.EQ.1) THEN PRINT 4567, ICDATE 4567 FORMAT(/'===> BUFR MESSAGE NO. 1 IS A DUMMY MESSAGE CONTAINING ', $ 'ONLY CENTER DATE (',I5,4I3,') - NO DATA - GO ON TO NEXT ', $ 'MESSAGE'/) ELSE IF(IREC.EQ.2) THEN PRINT 4568, IDDATE 4568 FORMAT(/'===> BUFR MESSAGE NO. 2 IS A DUMMY MESSAGE CONTAINING ', $ 'ONLY DUMP DATE (',I5,4I3,') - NO DATA - GO ON TO NEXT ', $ 'MESSAGE'/) ELSE PRINT 4569, IREC,MDATE 4569 FORMAT(/'===> BUFR MESSAGE NO.',I3,' (DATE:',I5,3I3,' 0) ', $ 'CONTAINS ZERO REPORTS FOR SOME UNEXPLAINED REASON - GO ON TO ', $ 'NEXT MESSAGE'/) END IF END IF INDEX = 0 GO TO 10 END IF C----------------------------------------------------------------------- IF(IPRINT.GT.1) PRINT *, 'READY TO PROCESS NEW DECODED REPORT' C*********************************************************************** C A SINGLE REPORT HAS BEEN SUCCESSFULLY DECODED C*********************************************************************** INDEX = INDEX + 1 IF(IPRINT.GE.1) PRINT *, 'WORKING WITH SUBSET NUMBER ',INDEX RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: UNPK7702 INITIALIZES THE OUTPUT ARRAY FOR A REPORT C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1996-12-16 C C ABSTRACT: INITIALIZES THE OUTPUT ARRAY WHICH HOLDS A SINGLE REPORT C IN THE QUASI-OFFICE NOTE 29 UNPACKED FORMAT TO ALL MISSING. C C PROGRAM HISTORY LOG: C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR C C USAGE: CALL UNPK7702(RDATA,ITP) C INPUT ARGUMENT LIST: C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 - C - WIND PROFILER, =2 - GOES SNDG, =3 - NEXRAD(VAD) WIND} C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C RDATA - SINGLE REPORT RETURNED AN A QUASI-OFFICE NOTE 29 C UNPACKED FORMAT; ALL DATA ARE MISSING C C REMARKS: CALLED BY SUBROUTINE W3UNPK77. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP, CRAY, SGI C C$$$ SUBROUTINE UNPK7702(RDATA,ITP) REAL RDATA(*),RDATX(1200) INTEGER IDATA(1200),IRTYP(3) CHARACTER*8 COB C SAVE C EQUIVALENCE (RDATX,IDATA),(COB,IOB) DATA XMSG/99999./,IMSG/99999/,IRTYP/71,61,72/ RDATX(1) = XMSG RDATX(2) = XMSG IDATA(3) = IMSG RDATX(4) = XMSG COB = '999999 ' IDATA(5) = IOB COB = '9999 ' IDATA(6) = IOB RDATX(7) = XMSG IDATA(8) = IMSG IDATA(9) = IRTYP(ITP) IDATA(10) = IMSG COB = ' ' IDATA(11) = IOB IDATA(12) = IOB C C ALL TYPES -- LOAD ZEROS INTO THE DEFINING WORD PAIRS C IDATA(13:42) = 0 C C ALL TYPES -- LOAD MISSINGS INTO THE DATA PORTION C RDATX(43:1200) = XMSG IF(ITP.EQ.1) THEN C C PROFILER -- LOAD INTEGER MISSING WHERE APPROPRIATE C (Current limit of 104 Cat. 11 levels) C IDATA(53:1200:11) = IMSG IDATA(55:1200:11) = IMSG IDATA(56:1200:11) = IMSG IDATA(60:1200:11) = IMSG ELSE IF(ITP.EQ.2) THEN C C GOES -- LOAD DEFAULT OF BLANK CHARACTERS INTO CAT. 12 C LEVEL QUALITY MARKERS C (Current limit of 50 Cat. 12 levels) C (could be expanded if need be) C IDATA(49:392:7) = IOB C C GOES -- LOAD DEFAULT OF BLANK CHARACTER INTO FIRST CAT. 08 C LEVEL QUALITY MARKER C (Current limit of 9 Cat. 08 levels) C (could be expanded if need be) C IDATA(395:419:3) = IOB C GOES -- LOAD INTEGER MISSING INTO CAT. 13 LEVEL CHANNEL NUMBER C -- LOAD DEFAULT OF BLANK CHARACTER INTO CAT. 13 LEVEL C QUALITY MARKER C (Current limit of 60 Cat. 13 levels) C (could be expanded if need be) C IDATA(420:599:3) = IMSG IDATA(422:599:3) = IOB ELSE IF(ITP.EQ.3) THEN C C VADWND -- LOAD DEFAULT OF BLANK CHARACTER INTO HGHT CAT. 04 C LEVEL QUALITY MARKER C (Current limit of 70 Cat. 04 levels) C (could be expanded if need be) C IDATA(46:1200:4) = IOB END IF RDATA(1:1200) = RDATX(1:1200) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: UNPK7703 FILLS IN HEADER IN O-PUT ARRAY - PFLR RPT C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05 C C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE C HEADER DATA FOR WIND PROFILER REPORT. HEADER IS THEN FILLED INTO C THE OUTPUT ARRAY WHICH HOLDS A SINGLE WIND PROFILER REPORT IN THE C QUASI-OFFICE NOTE 29 UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND C PROFILER) BUFR DUMP FILE AFTER 3/2002: MNEMONIC C "NPSM" IS NO LONGER AVAILABLE, MNEMONIC "TPSE" C REPLACES "TPMI" (AVG. TIME IN MINUTES STILL C OUTPUT) (WILL STILL WORK PROPERLY FOR INPUT C PROFLR DUMP FILES PRIOR TO 3/2002) C C USAGE: CALL UNPK7703(LUNIT,RDATA,IRET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN C - (ALL OTHER DATA REMAINS MISSING) C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPK77. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP, CRAY, SGI C C$$$ SUBROUTINE UNPK7703(LUNIT,RDATA,IRET) CHARACTER*6 STNID CHARACTER*8 COB CHARACTER*35 HDR1,HDR2 INTEGER IDATA(1200) REAL(8) HDR_8(16) REAL HDR(16),RDATA(*),RDATX(1200) COMMON /PK77BB/kdate(8),ldate(8),IPRINT SAVE EQUIVALENCE (RDATX,IDATA),(COB,IOB) DATA XMSG/99999./,IMSG/99999/ DATA HDR1/'CLAT CLON TSIG SELV NPSM TPSE WMOB '/ DATA HDR2/'WMOS YEAR MNTH DAYS HOUR MINU TPMI '/ RDATX(1:1200) = RDATA(1:1200) HDR_8 = 10.0E10 CALL UFBINT(LUNIT,HDR_8,16,1,NLEV,HDR1//HDR2);HDR=HDR_8 IF(NLEV.NE.1) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- C SET IRET = 6 AND RETURN PRINT 217, NLEV 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/) IRET = 6 RETURN C....................................................................... END IF C LATITUDE (STORED AS REAL) M = 1 IF(IPRINT.GT.1) PRINT 199, HDR(1),M 199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3) IF(HDR(1).LT.XMSG) THEN RDATX(1) = NINT(HDR(1) * 100.) NNNNN = 1 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) 198 FORMAT(5X,'DATA(',I5,') STORED AS: ',F10.2) ELSE IRET = 2 PRINT 102 102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR WIND PROFILER ', $ 'REPORT'/) RETURN END IF C LONGITUDE (STORED AS REAL) M = 2 IF(IPRINT.GT.1) PRINT 199, HDR(2),M IF(HDR(2).LT.XMSG) THEN RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.)) NNNNN = 2 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) ELSE IRET = 2 PRINT 104 104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR WIND PROFILER ', $ 'REPORT'/) RETURN END IF C TIME SIGNIFICANCE (STORED AS INTEGER) M = 3 IF(IPRINT.GT.1) PRINT 199, HDR(3),M IF(HDR(3).LT.XMSG) IDATA(3) = NINT(HDR(3)) NNNNN = 3 IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT) C (STORED AS REAL) M = 4 IF(IPRINT.GT.1) PRINT 199, HDR(4),M IF(HDR(4).LT.XMSG) RDATX(7) = NINT(HDR(4)) NNNNN = 7 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) C SUBMODE INFORMATION C EDITION NUMBER (ALWAYS = 2) C (PACKED AS SUBMODE TIMES 10 PLUS EDITION NUMBER - INTEGER) C {NOTE: After 3/2002, the submode information is no longer C available and is stored as missing (3).} M = 5 IEDTN = 2 IDATA(8) = (3 * 10) + IEDTN IF(IPRINT.GT.1) PRINT 199, HDR(5),M IF(HDR(5).LT.XMSG) IDATA(8) = (NINT(HDR(5)) * 10) + IEDTN NNNNN = 8 IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) C AVERAGING TIME (STORED AS INTEGER) C (NOTE: Prior to 3/2002, this is decoded in minutes, after C 3/2002 this is decoded in seconds - in either case C it is stored in minutes) M = 6 IF(IPRINT.GT.1) PRINT 199, HDR(6),M IF(IPRINT.GT.1) PRINT 199, HDR(14),M IF(HDR(6).LT.XMSG) THEN IDATA(10) = NINT(HDR(6)/60.) ELSE IF(HDR(14).LT.XMSG) THEN IDATA(10) = NINT(HDR(14)) END IF NNNNN = 10 IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) C----------------------------------------------------------------------- C STATION IDENTIFICATION (STORED AS CHARACTER) C (OBTAINED FROM ENCODED WMO BLOCK/STN NUMBERS) STNID = ' ' C WMO BLOCK NUMBER (STORED AS CHARACTER) M = 7 IF(IPRINT.GT.1) PRINT 199, HDR(7),M IF(HDR(7).LT.XMSG) WRITE(STNID(1:2),'(I2.2)') NINT(HDR(7)) C WMO STATION NUMBER (STORED AS CHARACTER) M = 8 IF(IPRINT.GT.1) PRINT 199, HDR(8),M IF(HDR(8).LT.XMSG) WRITE(STNID(3:5),'(I3.3)') NINT(HDR(8)) COB(1:4) = STNID(1:4) IDATA(11) = IOB NNNNN = 11 IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') COB(1:4) = STNID(5:6)//' ' IDATA(12) = IOB NNNNN = 12 IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) cvvvvvdak port C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM) caaaaadak port M = 9 IF(IPRINT.GT.1) PRINT 199, HDR(9),M IYEAR = IMSG IF(HDR(9).LT.XMSG) IYEAR = NINT(HDR(9)) M = 10 IF(IPRINT.GT.1) PRINT 199, HDR(10),M IF(HDR(10).LT.XMSG.AND.IYEAR.LT.IMSG) THEN cvvvvvdak port IYEAR = MOD(IYEAR,100) caaaaadak port IYEAR = NINT(HDR(10)) + (IYEAR * 100) cvvvvvdak port cdak WRITE(COB,'(I6.6,2X)') IYEAR WRITE(COB,'(I4.4,4X)') IYEAR caaaaadak port IDATA(5) = IOB NNNNN = 5 IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6) 9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"') ELSE GO TO 30 END IF C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH) C AND THE OBSERVATION TIME (STORED AS REAL) M = 11 IF(IPRINT.GT.1) PRINT 199, HDR(11),M IDAY = IMSG IF(HDR(11).LT.XMSG) IDAY = NINT(HDR(11)) M = 12 IF(IPRINT.GT.1) PRINT 199, HDR(12),M IF(HDR(12).LT.XMSG.AND.IDAY.LT.IMSG) THEN IHRT = NINT(HDR(12)) M = 13 IF(IPRINT.GT.1) PRINT 199, HDR(13),M IF(HDR(13).GE.XMSG) GO TO 30 RMNT = HDR(13) RDATX(4) = NINT((IHRT * 100.) + (RMNT * 100.)/60.) NNNNN = 4 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) IHRT = IHRT + (IDAY * 100) WRITE(COB(1:4),'(I4.4)') IHRT IDATA(6) = IOB NNNNN = 6 IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) ELSE GO TO 30 END IF RDATA(1:1200) = RDATX(1:1200) RETURN 30 CONTINUE IRET = 4 RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: UNPK7704 FILLS CAT.10 INTO O-PUT ARRAY - PFLR RPT C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05 C C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE C SURFACE DATA FOR WIND PROFILER REPORT. SURFACE DATA ARE THEN C FILLED INTO THE OUTPUT ARRAY AS CATEGORY 10. THE OUPUT ARRAY C HOLDS A SINGLE WIND PROFILER REPORT IN THE QUASI-OFFICE NOTE 29 C UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND C PROFILER) BUFR DUMP FILE AFTER 3/2002: SURFACE C DATA NOW ALL MISSING (MNEMONICS "PMSL", C "WDIR1","WSPD1", "TMDB", "REHU", "REQV" NO C LONGER AVAILABLE) (WILL STILL WORK PROPERLY FOR C INPUT PROFLR DUMP FILES PRIOR TO 3/2002) C C USAGE: CALL UNPK7704(LUNIT,RDATA) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED C - IN (ALL OTHER DATA REMAINS MISSING) C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH SURFACE INFORMATION FILLED IN C - (AS WELL AS THE HEADER; ALL OTHER DATA REMAINS C - MISSING) C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. AFTER 3/2002, THERE IS C NO SURFACE DATA AVAILABLE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP, CRAY, SGI C C$$$ SUBROUTINE UNPK7704(LUNIT,RDATA) CHARACTER*40 SRFC INTEGER IDATA(1200) REAL(8) SFC_8(8) REAL SFC(8),RDATA(*),RDATX(1200) COMMON /PK77BB/kdate(8),ldate(8),IPRINT SAVE EQUIVALENCE (RDATX,IDATA) DATA XMSG/99999./ DATA SRFC/'PMSL WDIR1 WSPD1 TMDB REHU REQV '/ RDATX(1:1200) = RDATA(1:1200) SFC_8 = 10.0E10 CALL UFBINT(LUNIT,SFC_8,8,1,NLEV,SRFC);SFC=SFC_8 IF(NLEV.NE.1) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- PRINT 217, NLEV 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', $ 'IS NOT WHAT IS EXPECTED (1) - NO SFC DATA PROCESSED'/) GO TO 99 C....................................................................... END IF C MSL PRESSURE (STORED AS REAL) M = 1 IF(IPRINT.GT.1) PRINT 199, SFC(1),M 199 FORMAT(5X,'SFC HERE IS: ',F17.4,'; INDEX IS: ',I3) IF((SFC(1)*0.1).LT.XMSG) RDATX(43) = NINT(SFC(1) * 0.1) NNNNN = 43 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43) 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) C SURFACE HORIZONTAL WIND DIRECTION (STORED AS REAL) M = 2 IF(IPRINT.GT.1) PRINT 199, SFC(2),M IF(SFC(2).LT.XMSG) RDATX(43+2) = NINT(SFC(2)) NNNNN = 43 + 2 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+2) C SURFACE HORIZONTAL WIND SPEED (STORED AS REAL) M = 3 IF(IPRINT.GT.1) PRINT 199, SFC(3),M IF(SFC(3).LT.XMSG) RDATX(43+3) = NINT(SFC(3) * 10.) NNNNN = 43 + 3 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+3) C SURFACE TEMPERATURE (STORED AS REAL) M = 4 IF(IPRINT.GT.1) PRINT 199, SFC(4),M IF(SFC(4).LT.XMSG) RDATX(43+4) = NINT(SFC(4) * 10.) NNNNN = 43 + 4 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+4) C RELATIVE HUMIDITY (STORED AS REAL) M = 5 IF(IPRINT.GT.1) PRINT 199, SFC(5),M IF(SFC(5).LT.XMSG) RDATX(43+5) = NINT(SFC(5)) NNNNN = 43 + 5 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+5) C RAINFALL RATE (STORED AS REAL) M = 6 IF(IPRINT.GT.1) PRINT 199, SFC(6),M IF(SFC(6).LT.XMSG) RDATX(43+6) = NINT(SFC(6) * 1.E7) NNNNN = 43 + 6 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+6) C SET CATEGORY COUNTERS FOR SURFACE DATA IDATA(35) = 1 IDATA(36) = 43 99 CONTINUE IF(IPRINT.GT.1) PRINT *, 'IDATA(35)=',IDATA(35),'; IDATA(36)=', $ IDATA(36) RDATA(1:1200) = RDATX(1:1200) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: UNPK7705 FILLS CAT.11 INTO O-PUT ARRAY - PFLR RPT C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05 C C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE C UPPER-AIR DATA FOR WIND PROFILER REPORT. UPPER-AIR DATA ARE THEN C FILLED INTO THE OUTPUT ARRAY AS CATEGORY 11. THE OUPUT ARRAY C HOLDS A SINGLE WIND PROFILER REPORT IN THE QUASI-OFFICE NOTE 29 C UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR C 1998-07-09 KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, HORIZ. C SIGNIFICANCE, VERT. SIGNIFICANCE) PROCESSING C TO ACCOUNT FOR UPDATES TO BUFRTABLE MNEMONICS C IN /dcom C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND C PROFILER) BUFR DUMP FILE AFTER 3/2002: C MNEMONICS "ACAVH", "ACAVV", "SPP0", AND "NPHL" C NO LONGER AVAILABLE; (WILL STILL WORK PROPERLY C FOR INPUT PROFLR DUMP FILES PRIOR TO 3/2002) C C USAGE: CALL UNPK7705(LUNIT,RDATA) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH ONLY HEADER AND SURFACE C - INFORMATION FILLED IN (UPPER-AIR DATA MISSING) C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH UPPER-AIR INFORMATION FILLED C - IN (ALL DATA FOR REPORT NOW FILLED) C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPK77. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP, CRAY, SGI C C$$$ SUBROUTINE UNPK7705(LUNIT,RDATA) CHARACTER*31 UAIR1,UAIR2 CHARACTER*16 UAIR3 INTEGER IDATA(1200) REAL(8) UAIR_8(16,255) REAL UAIR(16,255),RDATA(*),RDATX(1200) COMMON /PK77BB/kdate(8),ldate(8),IPRINT SAVE EQUIVALENCE (RDATX,IDATA) DATA XMSG/99999./ DATA UAIR1/'HEIT WDIR WSPD NPQC WCMP ACAVH '/ DATA UAIR2/'ACAVV SPP0 SDHS SDVS NPHL '/ DATA UAIR3/'HAST ACAV1 ACAV2'/ RDATX(1:1200) = RDATA(1:1200) NSFC = 0 ILVL = 0 ILC = 0 C FIRST UPPER-AIR LEVEL IS THE SURFACE INFORMATION IF(IPRINT.GT.1) PRINT 1078, ILC,ILVL 1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',I5,'; NO. LEVELS ', $ 'PROCESSED TO NOW =',I5) RDATX(50+ILC) = RDATX(7) IF(IPRINT.GT.1) PRINT 198, 50+ILC,RDATX(50+ILC) 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) IF(RDATX(50+ILC).LT.XMSG) NSFC = 1 IF(IDATA(35).GE.1) THEN RDATX(50+ILC+1) = RDATX(IDATA(36)+2) RDATX(50+ILC+2) = RDATX(IDATA(36)+3) END IF IF(IPRINT.GT.1) PRINT 198, 50+ILC+1,RDATX(50+ILC+1) IF(RDATX(50+ILC+1).LT.XMSG) NSFC = 1 IF(IPRINT.GT.1) PRINT 198, 50+ILC+2,RDATX(50+ILC+2) IF(RDATX(50+ILC+2).LT.XMSG) NSFC = 1 ILVL = ILVL + 1 ILC = ILC + 11 IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL,' WITH ', $ 'NSFC=',NSFC,'; GOING INTO NEXT LEVEL WITH ILC=',ILC UAIR_8 = 10.0E10 CALL UFBINT(LUNIT,UAIR_8,16,255,NLEV,UAIR1//UAIR2//UAIR3) UAIR=UAIR_8 IF(NLEV.EQ.0) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- IF(NSFC.EQ.0) THEN C ... NO UPPER AIR DATA PROCESSED PRINT 217 217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS', $ ' REPORT -- NLEV = 0 AND NSFC = 0'/) GO TO 99 ELSE C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED PRINT 218 218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ', $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/) GO TO 98 END IF C....................................................................... END IF IF(IPRINT.GT.1) PRINT 1068, NLEV 1068 FORMAT(' THIS REPORT CONTAINS ',I3,' LEVELS OF DATA (NOT ', $ 'INCLUDING BOTTOM -SURFACE- LEVEL)') DO I = 1,NLEV IF(IPRINT.GT.1) PRINT 1079, ILC,ILVL 1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',I5,'; NO. LEVELS ', $ 'PROCESSED TO NOW =',I5) C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL) C (NOTE: At one time, possibly even now, the height above sea C level was erroneously stored under mnemonic "HAST" C when it should have been stored under mnemonic "HEIT". C ("HAST" is defined as the height above the station.) C Will test first for valid data in "HEIT" - if missing, C then will use data in "HAST" - this will allow this C routine to transition w/o change when the fix is made.) IF(UAIR(1,I).LT.XMSG) THEN M = 1 IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M 199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3) RDATX(50+ILC) = NINT(UAIR(1,I)) ELSE M = 12 IF(IPRINT.GT.1) PRINT 199, UAIR(12,I),M IF(UAIR(12,I).LT.XMSG) RDATX(50+ILC) = NINT(UAIR(12,I)) END IF IF(IPRINT.GT.1) PRINT 198, 50+ILC,RDATX(50+ILC) ILVL = ILVL + 1 C HORIZONTAL WIND DIRECTION (STORED AS REAL) M = 2 IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M IF(UAIR(2,I).LT.XMSG) RDATX(50+ILC+1) = NINT(UAIR(2,I)) IF(IPRINT.GT.1) PRINT 198, 50+ILC+1,RDATX(50+ILC+1) C HORIZONTAL WIND SPEED (STORED AS REAL) M = 3 IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M IF(UAIR(3,I).LT.XMSG) RDATX(50+ILC+2) =NINT(UAIR(3,I) * 10.) IF(IPRINT.GT.1) PRINT 198, 50+ILC+2,RDATX(50+ILC+2) C QUALITY CODE (STORED AS INTEGER) M = 4 IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M IF(UAIR(4,I).LT.XMSG) IDATA(50+ILC+3) = NINT(UAIR(4,I)) IF(IPRINT.GT.1) PRINT 197, 50+ILC+3,IDATA(50+ILC+3) 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) C VERTICAL WIND COMPONENT (W) (STORED AS REAL) M = 5 IF(IPRINT.GT.1) PRINT 199, UAIR(5,I),M IF(UAIR(5,I).LT.XMSG) RDATX(50+ILC+4) = NINT(UAIR(5,I) * 100.) IF(IPRINT.GT.1) PRINT 198, 50+ILC+4,RDATX(50+ILC+4) C HORIZONTAL CONSENSUS NUMBER (STORED AS INTEGER) C (NOTE: Prior to 2/18/1999, the horizonal consensus number was C stored under mnemonic "ACAV1". C From 2/18/1999 through 3/2002, the horizontal consensus C number was stored under mnemonic "ACAVH". C After 3/2002, the horizontal consensus number is no C longer stored. C Will test first for valid data in "ACAVH" - if missing, C then will test for data in "ACAV1" - this will allow C this routine to work properly with historical data.) IF(IPRINT.GT.1) PRINT 199, UAIR(6,I),M IF(IPRINT.GT.1) PRINT 199, UAIR(13,I),M IF(UAIR(6,I).LT.XMSG) THEN M = 6 IDATA(50+ILC+5) = NINT(UAIR(6,I)) ELSE M = 13 IF(UAIR(13,I).LT.XMSG) IDATA(50+ILC+5) = NINT(UAIR(13,I)) END IF IF(IPRINT.GT.1) PRINT 197, 50+ILC+5,IDATA(50+ILC+5) C VERTICAL CONSENSUS NUMBER (STORED AS INTEGER) C (NOTE: Prior to 2/18/1999, the vertical consensus number was C stored under mnemonic "ACAV2". C From 2/18/1999 through 3/2002, the vertical consensus C number was stored under mnemonic "ACAVV". C After 3/2002, the vertical consensus number is no C longer stored. C Will test first for valid data in "ACAVV" - if missing, C then will test for data in "ACAV2" - this will allow C this routine to work properly with historical data.) IF(IPRINT.GT.1) PRINT 199, UAIR(7,I),M IF(IPRINT.GT.1) PRINT 199, UAIR(14,I),M IF(UAIR(7,I).LT.XMSG) THEN M = 7 IDATA(50+ILC+6) = NINT(UAIR(7,I)) ELSE M = 14 IF(UAIR(14,I).LT.XMSG) IDATA(50+ILC+6) = NINT(UAIR(14,I)) END IF IF(IPRINT.GT.1) PRINT 197, 50+ILC+6,IDATA(50+ILC+6) C SPECTRAL PEAK POWER (STORED AS REAL) C (NOTE: After 3/2002, the spectral peak power is no longer C stored.) M = 8 IF(IPRINT.GT.1) PRINT 199, UAIR(8,I),M IF(UAIR(8,I).LT.XMSG) RDATX(50+ILC+7) = NINT(UAIR(8,I)) IF(IPRINT.GT.1) PRINT 198, 50+ILC+7,RDATX(50+ILC+7) C HORIZONTAL WIND SPEED STANDARD DEVIATION (STORED AS REAL) M = 9 IF(IPRINT.GT.1) PRINT 199, UAIR(9,I),M IF(UAIR(9,I).LT.XMSG) RDATX(50+ILC+8)=NINT(UAIR(9,I) * 10.) IF(IPRINT.GT.1) PRINT 198, 50+ILC+8,RDATX(50+ILC+8) C VERTICAL WIND COMPONENT STANDARD DEVIATION (STORED AS REAL) M = 10 IF(IPRINT.GT.1) PRINT 199, UAIR(10,I),M IF(UAIR(10,I).LT.XMSG) RDATX(50+ILC+9) =NINT(UAIR(10,I) * 10.) IF(IPRINT.GT.1) PRINT 198, 50+ILC+9,RDATX(50+ILC+9) C MODE INFORMATION (STORED AS INTEGER) C (NOTE: After 3/2002, the mode information is no longer stored.) M = 11 IF(IPRINT.GT.1) PRINT 199, UAIR(11,I),M IF(UAIR(11,I).LT.XMSG) IDATA(50+ILC+10) = NINT(UAIR(11,I)) IF(IPRINT.GT.1) PRINT 197, 50+ILC+10,IDATA(50+ILC+10) C....................................................................... ILC = ILC + 11 IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL, $ '; GOING INTO NEXT LEVEL WITH ILC=',ILC ENDDO C SET CATEGORY COUNTERS FOR UPPER-AIR DATA 98 CONTINUE IDATA(37) = ILVL IDATA(38) = 50 99 CONTINUE IF(IPRINT.GT.1) PRINT *, 'NSFC=',NSFC,'; IDATA(37)=',IDATA(37), $ '; IDATA(38)=',IDATA(38) RDATA(1:1200) = RDATX(1:1200) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: UNPK7706 FILLS IN HEADER IN O-PUT ARRAY - VADW RPT C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-02 C C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE C HEADER DATA FOR NEXRAD (VAD) WIND REPORT. HEADER IS THEN FILLED C INTO THE OUTPUT ARRAY WHICH HOLDS A SINGLE VAD WIND REPORT IN THE C QUASI-OFFICE NOTE 29 UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 1997-06-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR C C USAGE: CALL UNPK7706(LUNIT,RDATA,IRET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN C - (ALL OTHER DATA REMAINS MISSING) C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPK77. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP, CRAY, SGI C C$$$ SUBROUTINE UNPK7706(LUNIT,RDATA,IRET) CHARACTER*8 STNID,COB CHARACTER*45 HDR1 INTEGER IDATA(1200) REAL(8) HDR_8(9) REAL HDR(9),RDATA(*),RDATX(1200) COMMON /PK77BB/kdate(8),ldate(8),IPRINT SAVE EQUIVALENCE (RDATX,IDATA),(STNID,HDR_8(4)),(COB,IOB) DATA XMSG/99999./,IMSG/99999/ DATA HDR1/'CLAT CLON SELV RPID YEAR MNTH DAYS HOUR MINU '/ RDATX(1:1200) = RDATA(1:1200) HDR_8 = 10.0E10 CALL UFBINT(LUNIT,HDR_8,9,1,NLEV,HDR1);HDR=HDR_8 IF(NLEV.NE.1) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- C SET IRET = 6 AND RETURN PRINT 217, NLEV 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/) IRET = 6 RETURN C....................................................................... END IF C LATITUDE (STORED AS REAL) M = 1 IF(IPRINT.GT.1) PRINT 199, HDR(1),M 199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3) IF(HDR(1).LT.XMSG) THEN RDATX(1) = NINT(HDR(1) * 100.) NNNNN = 1 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) ELSE IRET = 2 PRINT 102 102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR VAD WIND REPORT'/) RETURN END IF C LONGITUDE (STORED AS REAL) M = 2 IF(IPRINT.GT.1) PRINT 199, HDR(2),M IF(HDR(2).LT.XMSG) THEN RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.)) NNNNN = 2 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) ELSE IRET = 2 PRINT 104 104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR VAD WIND REPORT'/) RETURN END IF C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT) C (STORED AS REAL) M = 3 IF(IPRINT.GT.1) PRINT 199, HDR(3),M IF(HDR(3).LT.XMSG) RDATX(7) = NINT(HDR(3)) NNNNN = 7 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) C STATION IDENTIFICATION (STORED AS CHARACTER) C ('99'//LAST 3-CHARACTERS OF PRODUCT SOURCE ID//' ') M = 4 IF(IPRINT.GT.1) PRINT 299, STNID,M 299 FORMAT(5X,'HDR HERE IS: ',9X,A8,'; INDEX IS: ',I3) COB(1:4) = '99'//STNID(2:3) IDATA(11) = IOB NNNNN = 11 IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') COB(1:4) = STNID(4:4)//' ' IDATA(12) = IOB NNNNN = 12 IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) cvvvvvdak port C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM) caaaaadak port M = 5 IF(IPRINT.GT.1) PRINT 199, HDR(5),M IYEAR = IMSG IF(HDR(5).LT.XMSG) IYEAR = NINT(HDR(5)) M = 6 IF(IPRINT.GT.1) PRINT 199, HDR(6),M IF(HDR(6).LT.XMSG.AND.IYEAR.LT.IMSG) THEN cvvvvvdak port IYEAR = MOD(IYEAR,100) caaaaadak port IYEAR = NINT(HDR(6)) + (IYEAR * 100) cvvvvvdak port cdak WRITE(COB,'(I6.6,2X)') IYEAR WRITE(COB,'(I4.4,4X)') IYEAR caaaaadak port IDATA(5) = IOB NNNNN = 5 IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6) 9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"') ELSE GO TO 30 END IF C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH) C AND THE OBSERVATION TIME (STORED AS REAL) M = 7 IF(IPRINT.GT.1) PRINT 199, HDR(7),M IDAY = IMSG IF(HDR(7).LT.XMSG) IDAY = NINT(HDR(7)) M = 8 IF(IPRINT.GT.1) PRINT 199, HDR(8),M IF(HDR(8).LT.XMSG.AND.IDAY.LT.IMSG) THEN IHRT = NINT(HDR(8)) M = 9 IF(IPRINT.GT.1) PRINT 199, HDR(9),M IF(HDR(9).GE.XMSG) GO TO 30 RMNT = HDR(9) RDATX(4) = NINT((IHRT * 100.) + (RMNT * 100.)/60.) NNNNN = 4 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) IHRT = IHRT + (IDAY * 100) WRITE(COB(1:4),'(I4.4)') IHRT IDATA(6) = IOB NNNNN = 6 IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) ELSE GO TO 30 END IF RDATA(1:1200) = RDATX(1:1200) RETURN 30 CONTINUE IRET = 4 RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: UNPK7707 FILLS CAT. 4 INTO O-PUT ARRAY - VADW RPT C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-02 C C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE C UPPER-AIR DATA FOR NEXRAD (VAD) WIND REPORT. UPPER-AIR DATA ARE C THEN FILLED INTO THE OUTPUT ARRAY AS CATEGORY 4. THE OUPUT ARRAY C HOLDS A SINGLE VAD WIND REPORT IN THE QUASI-OFFICE NOTE 29 C UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 1997-06-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR C C USAGE: CALL UNPK7707(LUNIT,RDATA,IRET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED C - IN (CATEGORY 4 DATA MISSING) C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH CATEGORY 4 INFORMATION FILLED IN C - (ALL DATA FOR REPORT NOW FILLED) C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPK77. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP, CRAY, SGI C C$$$ SUBROUTINE UNPK7707(LUNIT,RDATA,IRET) CHARACTER*1 CRMS(0:12) CHARACTER*8 COB CHARACTER*25 UAIR1 INTEGER IDATA(1200) REAL(8) UAIR_8(5,255) REAL UAIR(5,255),RDATA(*),RDATX(1200) COMMON /PK77BB/kdate(8),ldate(8),IPRINT SAVE EQUIVALENCE (RDATX,IDATA),(COB,IOB) DATA XMSG/99999./ DATA UAIR1/'HEIT WDIR WSPD RMSW QMWN '/ DATA CRMS/' ','A',' ','B',' ','C',' ','D',' ','E',' ','F',' '/ RDATX(1:1200) = RDATA(1:1200) NSFC = 0 ILVL = 0 ILC = 0 C FIRST CATEGORY 4 LEVEL UPPER-AIR LEVEL CONTAINS ONLY HEIGHT (ELEV) IF(IPRINT.GT.1) PRINT 1078, ILC,ILVL 1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',I5,'; NO. LEVELS ', $ 'PROCESSED TO NOW =',I5) RDATX(43+ILC) = RDATX(7) IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC) 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) IF(RDATX(43+ILC).LT.XMSG) NSFC = 1 C NOTE: The following was added because of a problem on the sgi-ha C platform related to equivalencing character and non-character C -- for now the addition of these two lines will set the quality C mark for sfc. cat . 4 level to the correct value of " " C rather than to "9999" - Mary McCann notified SGI of this C problem on 08-21-1998 cob = ' ' idata(43+ilc+3) = iob ILVL = ILVL + 1 ILC = ILC + 4 IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL,' WITH ', $ 'NSFC=',NSFC,'; GOING INTO NEXT LEVEL WITH ILC=',ILC UAIR_8 = 10.0E10 CALL UFBINT(LUNIT,UAIR_8,5,255,NLEV,UAIR1);UAIR=UAIR_8 IF(NLEV.EQ.0) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- IF(NSFC.EQ.0) THEN C ... NO UPPER AIR DATA PROCESSED PRINT 217 217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS', $ ' REPORT -- NLEV = 0 AND NSFC = 0'/) GO TO 99 ELSE C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED PRINT 218 218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ', $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/) GO TO 98 END IF C....................................................................... END IF IF(IPRINT.GT.1) PRINT 1068, NLEV 1068 FORMAT(' THIS REPORT CONTAINS ',I3,' LEVELS OF DATA (NOT ', $ 'INCLUDING BOTTOM -SURFACE- LEVEL)') DO I = 1,NLEV IF(IPRINT.GT.1) PRINT 1079, ILC,ILVL 1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',I5,'; NO. LEVELS ', $ 'PROCESSED TO NOW =',I5) C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL) M = 1 IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M 199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3) IF(UAIR(1,I).LT.XMSG) THEN RDATX(43+ILC) = NINT(UAIR(1,I)) C ... WE HAVE A VALID CATEGORY 4 LEVEL -- THERE IS A VALID HEIGHT ILVL = ILVL + 1 ELSE C ... WE DO NOT HAVE A VALID CATEGORY 4 LEVEL -- THERE IS NO VALID C HEIGHT GO ON TO NEXT INPUT LEVEL IF(IPRINT.GT.1) PRINT *, 'HEIGHT MISSING ON INPUT ', $ ' LEVEL ',I,', ALL OTHER DATA SET TO MSG ON THIS LEVEL' GO TO 10 END IF IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC) C HORIZONTAL WIND DIRECTION (STORED AS REAL) M = 2 IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M IF(UAIR(2,I).LT.XMSG) RDATX(43+ILC+1) = NINT(UAIR(2,I)) IF(IPRINT.GT.1) PRINT 198, 43+ILC+1,RDATX(43+ILC+1) C HORIZONTAL WIND SPEED (STORED AS REAL) (OUTPUT STORED C AS METERS/SECOND TIMES TEN, NOT IN KNOTS AS ON29 WOULD C INDICATE FOR CAT. 4 WIND SPEED) M = 3 IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M IF(UAIR(3,I).LT.XMSG) RDATX(43+ILC+2) =NINT(UAIR(3,I) * 10.) IF(IPRINT.GT.1) PRINT 198, 43+ILC+2,RDATX(43+ILC+2) C CONFIDENCE LEVEL (BASED ON RMS VECTOR WIND ERROR) C (NOTE: CONVERTED TO ORIGINAL LETTER INDICATOR AND PACKED C IN BYTE 4 OF CATEGORY 4 QUALITY MARKER LOCATION -- SEE C W3UNPK77 DOCBLOCK REMARKS 5. FOR UNPACKED VAD WIND REPORT C LAYOUT FOR VALUES M = 4 IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M IF(UAIR(4,I).LT.XMSG) THEN C ... CONVERT FROM M/S TO KNOTS CDAKCDAK KRMS = INT(1.93333 * UAIR(4,I)) KRMS = INT(1.9425 * UAIR(4,I)) COB = ' ' IF(KRMS.LT.13) THEN COB(4:4) = CRMS(KRMS) ELSE COB(4:4) = 'G' END IF IDATA(43+ILC+3) = IOB END IF IF(IPRINT.GT.1) PRINT 196, 43+ILC+3,COB(1:4) 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') C ON29 WIND QUALITY MARKER (CURRENTLY NOT STORED) M = 5 IF(IPRINT.GT.1) PRINT 199, UAIR(5,I),M C....................................................................... ILC = ILC + 4 IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL, $ '; GOING INTO NEXT LEVEL WITH ILC=',ILC 10 CONTINUE ENDDO C SET CATEGORY COUNTERS FOR UPPER-AIR DATA 98 CONTINUE IDATA(19) = ILVL 99 CONTINUE IF(IDATA(19).EQ.0) THEN IDATA(20) = 0 IRET = 5 ELSE IDATA(20) = 43 END IF IF(IPRINT.GT.1) PRINT *, 'NSFC=',NSFC,'; IDATA(37)=',IDATA(37), $ '; IDATA(38)=',IDATA(38) RDATA(1:1200) = RDATX(1:1200) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: UNPK7708 FILLS IN HEADER IN O-PUT ARRAY - GOES SND C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-07-09 C C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE C HEADER DATA FOR GOES SOUNDING REPORT. HEADER IS THEN FILLED INTO C THE OUTPUT ARRAY WHICH HOLDS A SINGLE GOES SOUNDING REPORT IN THE C QUASI-OFFICE NOTE 29 UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 1997-06-05 D. A. KEYSER NP22 - ORIGINAL AUTHOR C 1998-07-09 KEYSER -- CHANGED CHAR. 6 OF GOES STNID TO BE UNIQUE FOR C TWO DIFFERENT EVEN OR ODD SATELLITE ID'S C (EVERY OTHER EVEN OR ODD SAT. ID NOW GETS SAME C CHAR. 6 TAG) C C USAGE: CALL UNPK7708(LUNIT,RDATA,KOUNT,IRET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING C KOUNT - NUMBER OF REPORTS PROCESSED INCLUDING THIS ONE C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN C - (ALL OTHER DATA REMAINS MISSING) C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPK77. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP, CRAY, SGI C C$$$ SUBROUTINE UNPK7708(LUNIT,RDATA,KOUNT,IRET) CHARACTER*1 C6TAG(3,0:3) CHARACTER*8 STNID,COB CHARACTER*35 HDR1,HDR2 INTEGER IDATA(1200) REAL(8) HDR_8(12) REAL HDR(12),RDATA(*),RDATX(1200) COMMON /PK77BB/kdate(8),ldate(8),IPRINT COMMON /PK77FF/IFOV(3),KNTSAT(250:260) SAVE EQUIVALENCE (RDATX,IDATA),(COB,IOB) DATA XMSG/99999./,IMSG/99999/ DATA HDR1/'CLAT CLON ACAV GSDP QMRK SAID YEAR '/ DATA HDR2/'MNTH DAYS HOUR MINU SECO '/ C CURRENT LIST OF SATELLITE IDENTIFIERS (BUFR C.F. 0-01-007) C ----------------------------------------------------------- C GOES 6 -- 250 GOES 9 -- 253 GOES 12 -- 256 C GOES 7 -- 251 GOES 10 -- 254 GOES 13 -- 257 C GOES 8 -- 252 GOES 11 -- 255 GOES 14 -- 258 C IDSAT = -- EVEN1 -- --- ODD1 -- -- EVEN2 -- --- ODD2 -- C Sat. No. - 252,256,... 253,257,... 250,254,... 251,255,... C IRTYP = CLR COR UNKN CLR COR UNKN CLR COR UNKN CLR COR UNKN C --- --- ---- --- --- ---- --- --- ---- --- --- ---- DATA C6TAG/'I','J','?', 'L','M','?', 'O','P','?', 'Q','R','?' / RDATX(1:1200) = RDATA(1:1200) HDR_8 = 10.0E10 CALL UFBINT(LUNIT,HDR_8,12,1,NLEV,HDR1//HDR2);HDR=HDR_8 IF(NLEV.NE.1) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- C SET IRET = 6 AND RETURN PRINT 217, NLEV 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/) IRET = 6 RETURN C....................................................................... END IF C LATITUDE (STORED AS REAL) M = 1 IF(IPRINT.GT.1) PRINT 199, HDR(1),M 199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3) IF(HDR(1).LT.XMSG) THEN RDATX(1) = NINT(HDR(1) * 100.) NNNNN = 1 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) ELSE IRET = 2 PRINT 102 102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR GOES SOUNDING'/) RETURN END IF C LONGITUDE (STORED AS REAL) M = 2 IF(IPRINT.GT.1) PRINT 199, HDR(2),M IF(HDR(2).LT.XMSG) THEN RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.)) NNNNN = 2 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) ELSE IRET = 2 PRINT 104 104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR GOES SOUNDING'/) RETURN END IF C NUMBER OF FIELDS OF VIEW - SAMPLE SIZE (STORED AS INTEGER) M = 3 IF(IPRINT.GT.1) PRINT 199, HDR(3),M IF(HDR(3).LT.XMSG) IDATA(3) = NINT(HDR(3)) NNNNN = 3 IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) C STATION ELEVATION (FROM HEIGHT OF FIRST -SURFACE- LEVEL) C (STORED AS REAL) -- STORED IN SUBROUTINE UNPK7709 C RETRIEVAL TYPE (GEOSTATIONARY SATELLITE DATA-PROCESSING C TECHNIQUE USED) (STORED AS INTEGER) M = 4 IF(IPRINT.GT.1) PRINT 199, HDR(4),M IF(HDR(4).LT.XMSG) IDATA(8) = NINT(HDR(4)) IRTYP = 3 IF(IDATA(8).EQ.21) THEN IRTYP = 1 ELSE IF(IDATA(8).EQ.23) THEN IRTYP = 2 END IF NNNNN = 8 IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) C PRODUCT QUALITY BIT FLAGS - QUALITY INFO. (STORED AS INTEGER) M = 5 IF(IPRINT.GT.1) PRINT 199, HDR(5),M IF(HDR(5).LT.XMSG) IDATA(10) = NINT(HDR(5)) NNNNN = 10 IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) C STATION IDENTIFICATION (STORED AS CHARACTER) C (FIRST 5-CHARACTERS OBTAINED FROM 5-DIGIT COUNT NUMBER, C 6'TH CHARACTER OBTAINED FROM SAT. ID/RETRIEVAL TYPE TAG) WRITE(STNID(1:5),'(I5.5)') MIN(KOUNT,99999) C DECODE THE SATELLITE ID M = 6 IDSAT = 2 IF(IPRINT.GT.1) PRINT 199, HDR(6),M IF(HDR(6).LT.XMSG) THEN IDSAT = MOD(NINT(HDR(6)),4) IF(NINT(HDR(6)).GT.249.AND.NINT(HDR(6)).LT.260) THEN KNTSAT(NINT(HDR(6))) = KNTSAT(NINT(HDR(6))) + 1 ELSE KNTSAT(260) = KNTSAT(260) + 1 END IF END IF IF(IPRINT.GT.1) PRINT 2197, IDSAT,IRTYP 2197 FORMAT(5X,'IDSAT IS: ',I10,', IRTYP IS: ',I10) STNID(6:6) = C6TAG(IRTYP,IDSAT) COB(1:4) = STNID(1:4) IDATA(11) = IOB NNNNN = 11 IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') COB(1:4) = STNID(5:6)//' ' IDATA(12) = IOB NNNNN = 12 IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) cvvvvvdak port C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM) caaaaadak port M = 7 IF(IPRINT.GT.1) PRINT 199, HDR(7),M IYEAR = IMSG IF(HDR(7).LT.XMSG) IYEAR = NINT(HDR(7)) M = 8 IF(IPRINT.GT.1) PRINT 199, HDR(8),M IF(HDR(8).LT.XMSG.AND.IYEAR.LT.IMSG) THEN cvvvvvdak port IYEAR = MOD(IYEAR,100) caaaaadak port IYEAR = NINT(HDR(8)) + (IYEAR * 100) cvvvvvdak port cdak WRITE(COB,'(I6.6,2X)') IYEAR WRITE(COB,'(I4.4,4X)') IYEAR caaaaadak port IDATA(5) = IOB NNNNN = 5 IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6) 9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"') ELSE GO TO 30 END IF C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH) C AND THE OBSERVATION TIME (STORED AS REAL) M = 9 IF(IPRINT.GT.1) PRINT 199, HDR(9),M M = 10 IF(IPRINT.GT.1) PRINT 199, HDR(10),M IF(HDR(10).LT.XMSG.AND.HDR(9).LT.IMSG) THEN M = 11 IF(IPRINT.GT.1) PRINT 199, HDR(11),M IF(HDR(11).GE.XMSG) GO TO 30 M = 12 IF(IPRINT.GT.1) PRINT 199, HDR(12),M IF(HDR(12).GE.XMSG) GO TO 30 RDATX(4) = NINT(((HDR(10) + ((HDR(11) * 60.) + HDR(12))/3600.) $ * 100.) + 0.0000000001) NNNNN = 4 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) IDAYHR = NINT(HDR(10)) + (NINT(HDR(9)) * 100) WRITE(COB(1:4),'(I4.4)') IDAYHR IDATA(6) = IOB NNNNN = 6 IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) ELSE GO TO 30 END IF RDATA(1:1200) = RDATX(1:1200) RETURN 30 CONTINUE IRET = 4 RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: UNPK7709 FILLS CAT. 12,8 TO O-PUT ARRAY -GOES SNDG C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-05 C C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE C UPPER-AIR (SOUNDING) AND ADDITIONAL DATA FOR GOES SOUNDING. UPPER- C AIR DATA ARE THEN FILLED INTO THE OUTPUT ARRAY AS CATEGORY 12 C (SATELLITE SOUNDING) AND ADDITIONAL DATA ARE FILLED AS CATEGORY 8. C THE OUPUT ARRAY HOLDS A SINGLE GOES SOUNDING IN THE QUASI-OFFICE C NOTE 29 UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 1997-06-05 D. A. KEYSER NP22 - ORIGINAL AUTHOR C C USAGE: CALL UNPK7709(LUNIT,RDATA,IRET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED C - IN (CATEGORY 12 AND 8 DATA MISSING) C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 C - UNPACKED FORMAT WITH CATEGORY 12 AND 8 INFORMATION C - FILLED IN (ALL DATA FOR REPORT NOW FILLED) C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPK77. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM-SP, CRAY, SGI C C$$$ SUBROUTINE UNPK7709(LUNIT,RDATA,IRET) CHARACTER*1 CQMFLG CHARACTER*8 COB CHARACTER*37 CAT8A,CAT8B CHARACTER*48 UAIR1,RAD1 INTEGER IDATA(1200),ICDFG(12) REAL(8) UAIR_8(4,255),CAT8_8(12),RTCSF_8,RAD_8(2,255) REAL UAIR(4,255),CAT8(12),RDATA(*),RDATX(1200),SC8(12),RAD(2,255) COMMON /PK77BB/kdate(8),ldate(8),IPRINT COMMON /PK77FF/IFOV(3),KNTSAT(250:260) SAVE EQUIVALENCE (RDATX,IDATA),(COB,IOB) DATA XMSG/99999./,YMSG/99999.8/ DATA UAIR1/'PRLC HGHT TMDB TMDP '/ DATA RAD1 /'CHNM TMBR '/ DATA CAT8A/'GLFTI PH2O PH2O19 PH2O97 PH2O73 TMSK '/ DATA CAT8B/'GCDTT CDTP CLAM SIDU SOEL ELEV '/ DATA ICDFG/ 50 , 51 , 52 , 53 , 54 , 55 , 56 ,57 ,58,59, 60 , 61 / DATA SC8/100.,100.,100.,100.,100.,100.,100.,10.,1.,1.,100.,100./ RDATX(1:1200) = RDATA(1:1200) C ALL NON-RADIANCE DATA WILL BE Q.C.'D ACCORDING TO NUMBER OF FIELDS-OF- C VIEW FOR RETRIEVAL: 0-2 --> BAD, 3-9 --> SUSPECT, 10-25 OR MISSING C --> NEUTRAL CQMFLG = ' ' IF(IDATA(3).LT.3) THEN CQMFLG = 'F' IFOV(1) = IFOV(1) + 1 ELSE IF(IDATA(3).LT.10.OR.IDATA(10).EQ.1) THEN CQMFLG = 'Q' IF(IDATA(3).LT.10) IFOV(2) = IFOV(2) + 1 END IF IF(IDATA(3).GT.9) IFOV(3) = IFOV(3) + 1 C*********************************************************************** C FILL CATEGORY 12 PART OF OUTPUT C*********************************************************************** ILVL = 0 ILC = 0 UAIR_8 = 10.0E10 CALL UFBINT(LUNIT,UAIR_8,4,255,NLEV,UAIR1);UAIR=UAIR_8 IF(NLEV.EQ.0) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- PRINT 217 217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ', $ 'FOR THIS REPORT -- NLEV = 0'/) GO TO 98 ELSE IF(NLEV.GT.50) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 50 -- PRINT 218 218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ', $ 'FOR THIS REPORT -- NLEV > 50'/) GO TO 98 C....................................................................... END IF IF(IPRINT.GT.1) PRINT 1068, NLEV 1068 FORMAT(' THIS REPORT CONTAINS',I4,' INPUT LEVELS OF SOUNDING ', $ 'DATA') DO I = 1,NLEV IF(IPRINT.GT.1) PRINT 1079, I,ILC,ILVL 1079 FORMAT(' ATTEMPTING NEW CAT. 12 INPUT LEVEL NUMBER',I4,' WITH ', $ 'ILC =',I5,'; NO. LEVELS PROCESSED TO NOW =',I5) C LEVEL PRESSURE (STORED AS REAL) M = 1 IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M 199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3) IF(I.EQ.1) THEN PSFC = UAIR(1,I) * 0.1 ELSE IF(UAIR(1,I)*0.1.GE.YMSG) THEN C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THERE IS NO VALID PRESSURE C -- GO ON TO NEXT INPUT LEVEL (IF SFC LEVEL MSG, CONTINUE PROCESSING) IF(IPRINT.GT.1) PRINT *, 'PRESSURE MISSING ON INPUT', $ ' LEVEL ',I,', SKIP THE PROCESSING OF THIS LEVEL' GO TO 10 ELSE IF(UAIR(1,I)*0.1.GE.PSFC) THEN C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THE INPUT LEVEL PRESSURE C IS BELOW THE SURFACE PRESSURE -- GO ON TO THE NEXT INPUT LEVEL IF(IPRINT.GT.1) PRINT *,'PRESSURE ON INPUT LEVEL ',I, $ ' IS BELOW GROUND, SKIP THE PROCESSING OF THIS LEVEL' GO TO 10 END IF C WE HAVE A VALID CATEGORY 12 LEVEL -- THERE IS A VALID PRESSURE IF(UAIR(1,I)*0.1.LT.XMSG) RDATX(43+ILC) = NINT(UAIR(1,I)*0.1) ILVL = ILVL + 1 IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC) 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) C GEOPOTENTIAL HEIGHT (STORED AS REAL) M = 2 IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M IF(UAIR(2,I).LT.XMSG) RDATX(43+ILC+1) = NINT(UAIR(2,I)) IF(IPRINT.GT.1) PRINT 198, 43+ILC+1,RDATX(43+ILC+1) IF(I.EQ.1) THEN IF(IPRINT.GT.1) PRINT *, 'THIS IS SURFACE LEVEL, SO ', $ 'STORE HEIGHT ALSO AS ELEVATION IN HEADER' IF(UAIR(2,1).LT.XMSG) RDATX(7) = NINT(UAIR(2,1)) NNNNN = 7 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) END IF C TEMPERATURE (STORED AS REAL) M = 3 IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M ITMP = NINT(UAIR(3,I)*100.) IF(UAIR(3,I).LT.XMSG) $ RDATX(43+ILC+2) = NINT((ITMP - 27315) * 0.1) IF(IPRINT.GT.1) PRINT 198, 43+ILC+2,RDATX(43+ILC+2) C DEWPOINT TEMPERATURE (STORED AS REAL) M = 4 IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M ITMP = NINT(UAIR(4,I)*100.) IF(UAIR(4,I).LT.XMSG) $ RDATX(43+ILC+3) = NINT((ITMP - 27315) * 0.1) IF(IPRINT.GT.1) PRINT 198, 43+ILC+3,RDATX(43+ILC+3) C QUALITY MARKERS (STORED AS CHARACTER) COB = CQMFLG//CQMFLG//CQMFLG//' ' IDATA(43+ILC+6) = IOB IF(IPRINT.GT.1) PRINT 196, 43+ILC+6,COB(1:4) 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') C....................................................................... ILC = ILC + 7 IF(I+1.LE.NLEV.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED ', $ 'LEVEL ',ILVL,'; GOING INTO NEXT LEVEL WITH ILC=',ILC 10 CONTINUE ENDDO C SET CATEGORY COUNTERS FOR CATEGORY 12 (SOUNDING) DATA IDATA(39) = ILVL 98 CONTINUE IF(IPRINT.GT.1) PRINT *, IDATA(39),' CAT. 12 LEVELS PROCESSED' IF(IDATA(39).GT.0) IDATA(40) = 43 C*********************************************************************** C FILL CATEGORY 8 PART OF OUTPUT C WILL ATTEMPT TO FILL 12 "LEVELS" C LVL 1- LIFTED INDEX (DEG. K X 100 - RELATIVE) -------- CODE FIG. 250. C LVL 2- TOTAL COLUMN PRECIPITABLE WATER (MM X 100) ---- CODE FIG. 251. C LVL 3- 1. TO .9 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 252. C LVL 4- .9 TO .7 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 253. C LVL 5- .7 TO .3 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 254. C LVL 6- SKIN TEMPERATURE (DEG. K X 100) --------------- CODE FIG. 255. C LVL 7- CLOUD TOP TEMPERATURE (DEG. K X 100) ---------- CODE FIG. 256. C LVL 8- CLOUD TOP PRESSURE (MB X 10) ------------------ CODE FIG. 257. C LVL 9- CLOUD AMOUNT (C. FIG. BUFR TABLE 0-20-011) ---- CODE FIG. 258. C LVL 10- INSTR. DATA USED IN PROC. C (C. FIG. BUFR TABLE 0-02-021) --- CODE FIG. 259. C LVL 11- SOLAR ZENITH ANGLE (SOLAR ELEV) (DEG. X 100) -- CODE FIG. 260. C LVL 12- SATELLITE ZENITH ANGLE (ELEV) (DEG. X 100) --- CODE FIG. 261. C C IF DATA ONE ANY LEVEL ARE MISSING, THAT LEVEL IS NOT PROCESSED C*********************************************************************** ILVL = 0 ILC = 0 CAT8_8 = 10.0E10 CALL UFBINT(LUNIT,CAT8_8,12,1,NLEV8,CAT8A//CAT8B);CAT8=CAT8_8 IF(NLEV8.NE.1) THEN IF(NLEV8.EQ.0) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- PRINT 318 318 FORMAT(/' ##W3UNPK77: NO ADDITIONAL (CAT. 8) DATA PROCESSED FOR ', $ 'THIS REPORT -- NLEV8 = 0'/) GO TO 99 C....................................................................... ELSE C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- C SET IRET = 7 AND RETURN PRINT 219, NLEV8 219 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 7'/) IRET = 7 RETURN C....................................................................... END IF END IF C THE TEMPERATURE CHANNEL SELECTION FLAG WILL BE USED LATER TO C DETERMINE Q. MARK FOR SKIN TEMPERATURE (IF 0 - OK, OTHERWISE - BAD) RTCSF_8 = 10.0E10 CALL UFBINT(LUNIT,RTCSF_8,1,1,NLEV0,'TCSF');RTCSF=RTCSF_8 ITCSF = 1 M = 1 IF(IPRINT.GT.1) PRINT 299, RTCSF,M 299 FORMAT(5X,'RTCSF HERE IS: ',F17.4,'; INDEX IS: ',I3) IF(RTCSF.LT.XMSG) ITCSF = NINT(RTCSF) IF(IPRINT.GT.1) PRINT 1798, ITCSF 1798 FORMAT(5X,'ITCSF IS: ',I10) C LOOP THROUGH THE 12 POSSIBLE ADDITIONAL DATA DO M = 1,12 IF(IPRINT.GT.1) PRINT 6079, M,ILC,ILVL 6079 FORMAT(' ATTEMPTING MISCEL. INPUT',I5,' WITH ILC =',I5,'; NO. ', $ 'OUTPUT CAT. 8 LVLS PROCESSED TO NOW =',I5) IF(IPRINT.GT.1) PRINT 399, CAT8(M),M 399 FORMAT(5X,'CAT8 HERE IS: ',F17.4,'; INDEX IS: ',I3) IF(CAT8(M).LT.XMSG) THEN C WE HAVE A VALID CATEGORY 8 "LEVEL" ILVL = ILVL + 1 C STORE THE DATUM IN WORD 1 OF THE CAT. 8 LEVEL RDATX(393+ILC) = NINT(CAT8(M) * SC8(M)) IF(IPRINT.GT.1) PRINT 198, 393+ILC,RDATX(393+ILC) C STORE THE CAT. 8 CODE FIGURE IN WORD 2 OF THE CAT. 8 LEVEL RDATX(393+ILC+1) = REAL(200+ICDFG(M)) IF(IPRINT.GT.1) PRINT 198, 393+ILC+1,RDATX(393+ILC+1) C STORE THE QUALITY MARKER IN BYTE 1 OF WORD 3 OF THE CAT. 8 LEVEL COB = CQMFLG//' ' C IF THIS DATUM IS SKIN TEMPERATURE AND THE TEMPERATURE CHANNEL C SELECTION FLAG IS BAD (.NE. 0), SET QUALITY MARKER TO "F" IF(M.EQ.6.AND.ITCSF.NE.0) COB(1:1) = 'F' IDATA(393+ILC+2) = IOB IF(IPRINT.GT.1) PRINT 196, 393+ILC+2,COB(1:4) ILC = ILC + 3 IF(M.LT.12.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED OUTPUT', $ ' LVL',ILVL,'; GOING INTO NEXT INPUT DATUM WITH ILC=',ILC ELSE IF(IPRINT.GT.1) PRINT *, 'DATUM MISSING ON INPUT ',M, $ ', GO ON TO NEXT INPUT DATUM (NO. LVLS PROCESSED SO ', $ 'FAR=',ILVL,'; ILC=',ILC,')' END IF ENDDO C SET CATEGORY COUNTERS FOR CATEGORY 8 (ADDITIONAL) DATA IDATA(27) = ILVL 99 CONTINUE IF(IPRINT.GT.1) PRINT *, IDATA(27),' CAT. 08 LEVELS PROCESSED' IF(IDATA(27).GT.0) IDATA(28) = 393 C*********************************************************************** C FILL CATEGORY 13 PART OF OUTPUT (RADIANCES) C*********************************************************************** ILVL = 0 ILC = 0 RAD_8 = 10.0E10 CALL UFBINT(LUNIT,RAD_8,2,255,NLEV13,RAD1);RAD=RAD_8 IF(NLEV13.EQ.0) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- PRINT 417 417 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ', $ 'REPORT -- NLEV13 = 0'/) GO TO 100 ELSE IF(NLEV13.GT.60) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 60 -- PRINT 418 418 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ', $ 'REPORT -- NLEV13 > 60'/) GO TO 100 C....................................................................... END IF IF(IPRINT.GT.1) PRINT 2068, NLEV13 2068 FORMAT(' THIS REPORT CONTAINS',I4,' INPUT LEVELS (CHANNELS) OF ', $ 'RADIANCE DATA') DO I = 1,NLEV13 IF(IPRINT.GT.1) PRINT 2079, I,ILC,ILVL 2079 FORMAT(' ATTEMPTING NEW CAT. 13 INPUT "LEVEL" NUMBER',I4,' WITH ', $ 'ILC =',I5,'; NO. LEVELS (CHANNELS) PROCESSED TO NOW =',I5) C CHANNEL NUMBER (STORED AS INTEGER) M = 1 IF(IPRINT.GT.1) PRINT 499, RAD(1,I),M 499 FORMAT(5X,'RAD HERE IS: ',F17.4,'; INDEX IS: ',I3) IF(RAD(1,I).GE.YMSG) THEN C WE DO NOT HAVE A VALID CATEGORY 13 LEVEL -- THERE IS NO VALID CHANNEL C NUMBER -- GO ON TO NEXT INPUT LEVEL IF(IPRINT.GT.1) PRINT *, 'CHANNEL NUMBER MISSING ON INPUT', $ ' LEVEL ',I,', SKIP THE PROCESSING OF THIS LEVEL' GO TO 210 END IF C WE HAVE A VALID CATEGORY 13 LEVEL -- THERE IS A VALID CHANNEL NUMBER IDATA(429+ILC) = NINT(RAD(1,I)) ILVL = ILVL + 1 IF(IPRINT.GT.1) PRINT 197, 429+ILC,IDATA(429+ILC) 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) C BRIGHTNESS TEMPERATURE (STORED AS REAL) M = 2 IF(IPRINT.GT.1) PRINT 499, RAD(2,I),M IF(RAD(2,I).LT.XMSG) RDATX(429+ILC+1) = NINT(RAD(2,I) * 100.) IF(IPRINT.GT.1) PRINT 198, 429+ILC+1,RDATX(429+ILC+1) C QUALITY MARKERS (STORED AS CHARACTER) COB = ' ' IDATA(429+ILC+2) = IOB IF(IPRINT.GT.1) PRINT 196, 429+ILC+2,COB(1:4) C....................................................................... ILC = ILC + 3 IF(I+1.LE.NLEV13.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED ', $ 'LEVEL ',ILVL,'; GOING INTO NEXT LEVEL WITH ILC=',ILC 210 CONTINUE ENDDO C SET CATEGORY COUNTERS FOR CATEGORY 13 (RADIANCE) DATA IDATA(41) = ILVL 100 CONTINUE IF(IPRINT.GT.1) PRINT *, IDATA(41),' CAT. 13 LEVELS PROCESSED' IF(IDATA(41).GT.0) IDATA(42) = 429 IF(IDATA(27)+IDATA(39)+IDATA(41).EQ.0) IRET = 5 IF(IPRINT.GT.1) PRINT *,'IDATA(39)=',IDATA(39),'; IDATA(40)=', $ IDATA(40),'; IDATA(27)=',IDATA(27),'; IDATA(28)=',IDATA(28), $ '; IDATA(41)=',IDATA(41),'; IDATA(42)=',IDATA(42) RDATA(1:1200) = RDATX(1:1200) RETURN END