SUBROUTINE W3FI78(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX, * MAXR,MAXD,IUNITB,IUNITD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: W3FI78 BUFR MESSAGE DECODER C PRGMMR: CAVANAUGH ORG: NMC421 DATE:93-03-17 C C ABSTRACT: THIS SET OF ROUTINES WILL DECODE A BUFR MESSAGE AND C PLACE INFORMATION EXTRACTED FROM THE BUFR MESSAGE INTO SELECTED C ARRAYS FOR THE USER. THE ARRAY KDATA CAN NOW BE SIZED BY THE USER C BY INDICATING THE MAXIMUM NUMBER OF SUBSTES AND THE MAXIMUM C NUMBER OF DESCRIPTORS THAT ARE EXPECTED IN THE COURSE OF DECODING C SELECTED INPUT DATA. THIS ALLOWS FOR REALISTIC SIZING OF KDATA C AND THE MSTACK ARRAYS. THIS VERSION ALSO ALLOWS FOR THE INCLUSION C OF THE UNIT NUMBERS FOR TABLES B AND D INTO THE C ARGUMENT LIST. THIS ROUTINE DOES NOT INCLUDE IFOD PROCESSING. C C PROGRAM HISTORY LOG: C 88-08-31 CAVANAUGH C 90-12-07 CAVANAUGH NOW UTILIZING GBYTE ROUTINES TO GATHER C AND SEPARATE BIT FIELDS. THIS SHOULD IMPROVE C (DECREASE) THE TIME IT TAKES TO DECODE ANY C BUFR MESSAGE. HAVE ENTERED CODING THAT WILL C PERMIT PROCESSING BUFR EDITIONS 1 AND 2. C IMPROVED AND CORRECTED THE CONVERSION INTO C IFOD FORMAT OF DECODED BUFR MESSAGES. C 91-01-18 CAVANAUGH PROGRAM/ROUTINES MODIFIED TO PROPERLY HANDLE C SERIAL PROFILER DATA. C 91-04-04 CAVANAUGH MODIFIED TO HANDLE TEXT SUPPLIED THRU C DESCRIPTOR 2 05 YYY. C 91-04-17 CAVANAUGH ERRORS IN EXTRACTING AND SCALING DATA C CORRECTED. IMPROVED HANDLING OF NESTED C QUEUE DESCRIPTORS IS ADDED. C 91-05-10 CAVANAUGH - ARRAY 'DATA' HAS BEEN ENLARGED TO REAL*8 C TO BETTER CONTAIN VERY LARGE NUMBERS MORE C ACCURATELY. THE PREIOUS SIZE REAL*4 COULD NOT C CONTAIN SUFFICIENT SIGNIFICANT DIGITS. C - CODING HAS BEEN INTRODUCED TO PROCESS NEW C TABLE C DESCRIPTOR 2 06 YYY WHICH PERMITS IN C LINE PROCESSING OF A LOCAL DESCRIPTOR EVEN IF C THE DESCRIPTOR IS NOT CONTAINED IN THE USERS C TABLE B. C - A SECOND ROUTINE TO PROCESS IFOD MESSAGES C (IFOD0) HAS BEEN REMOVED IN FAVOR OF THE C IMPROVED PROCESSING OF THE ONE C REMAINING (IFOD1). C - NEW CODING HAS BEEN INTRODUCED TO PERMIT C PROCESSING OF BUFR MESSAGES BASED ON BUFR C EDITION UP TO AND INCLUDING EDITION 2. C PLEASE NOTE INCREASED SIZE REQUIREMENTS C FOR ARRAYS IDENT(20) AND IPTR(40). C 91-07-26 CAVANAUGH - ADD ARRAY MTIME TO CALLING SEQUENCE TO C PERMIT INCLUSION OF RECEIPT/TRANSFER TIMES C TO IFOD MESSAGES. C 91-09-25 CAVANAUGH - ALL PROCESSING OF DECODED BUFR DATA INTO C IFOD (A LOCAL USE REFORMAT OF BUFR DATA) C HAS BEEN ISOLATED FROM THIS SET OF ROUTINES. C FOR THOSE INTERESTED IN THE IFOD FORM, C SEE W3FL05 IN THE W3LIB ROUTINES. C PROCESSING OF BUFR MESSAGES CONTAINING C DELAYED REPLICATION HAS BEEN ALTERED SO THAT C SINGLE SUBSETS (REPORTS) AND AND A MATCHING C DESCRIPTOR LIST FOR THAT PARTICULAR SUBSET C WILL BE PASSED TO THE USER WILL BE PASSED TO C THE USER ONE AT A TIME TO ASSURE THAT EACH C SUBSET CAN BE FULLY DEFINED WITH A MINIMUM C OF REPROCESSING. C PROCESSING OF ASSOCIATED FIELDS HAS BEEN C TESTED WITH MESSAGES CONTAINING NON-COMPRESSED C DATA. C IN ORDER TO FACILITATE USER PROCESSING C A MATCHING LIST OF SCALE FACTORS ARE INCLUDED C WITH THE EXPANDED DESCRIPTOR LIST (MSTACK). C 91-11-21 CAVANAUGH - PROCESSING OF DESCRIPTOR 2 03 YYY C HAS CORRECTED TO AGREE WITH FM94 STANDARDS. C 91-12-19 CAVANAUGH - CALLS TO FI7803 AND FI7804 HAVE BEEN C CORRECTED TO AGREE CALLED PROGRAM ARGUMENT C LIST. SOME ADDITIONAL ENTRIES HAVE BEEN C INCLUDED FOR COMMUNICATING WITH DATA ACCESS C ROUTINES. ADDITIONAL ERROR EXIT PROVIDED FOR C THE CASE WHERE TABLE B IS DAMAGED. C 92-01-24 CAVANAUGH - ROUTINES FI7801, FI7803 AND FI7804 C HAVE BEEN MODIFIED TO HANDLE ASSOCIATED FIELDS C ALL DESCRIPTORS ARE SET TO ECHO TO MSTACK(1,N) C 92-05-21 CAVANAUGH - FURTHER EXPANSION OF INFORMATION COLLECTED C FROM WITHIN UPPER AIR SOUNDINGS HAS PRODUCED C THE NECESSITY TO EXPAND SOME OF THE PROCESSING C AND OUTPUT ARRAYS. (SEE REMARKS BELOW) C 92-06-29 CAVANAUGH - CORRECTED DESCRIPTOR DENOTING HEIGHT OF C EACH WIND LEVEL FOR PROFILER CONVERSIONS. C 92-07-23 CAVANAUGH - EXPANSION OF TABLE B REQUIRES ADJUSTMENT C OF ARRAYS TO CONTAIN TABLE B VALUES NEEDED TO C ASSIST IN THE DECODING PROCESS. C ARRAYS CONTAINING DATA FROM TABLE B C KDESC - DESCRIPTOR C ANAME - DESCRIPTOR NAME C AUNITS - UNITS FOR DESCRIPTOR C MSCALE - SCALE FOR VALUE OF DESCRIPTOR C MREF - REFERENCE VALUE FOR DESCRIPTOR C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR C 92-09-09 CAVANAUGH - FIRST ENCOUNTER WITH OPERATOR DESCRIPTOR C 2 05 YYY SHOWED ERROR IN DECODING. THAT ERROR C IS CORRECTED WITH THIS IMPLEMENTATION. FURTHER C TESTING OF UPPER AIR DATA HAS ENCOUNTERED C THE CONDITION OF LARGE (MANY LEVEL) SOUNDINGS C ARRAYS IN THE DECODER HAVE BEEN EXPANDED (AGAIN) C TO ALLOW FOR THIS CONDITION. C 92-10-02 CAVANAUGH - MODIFIED ROUTINE TO REFORMAT PROFILER DATA C (FI7809) TO SHOW DESCRIPTORS, SCALE VALUE AND C DATA IN PROPER ORDER. CORRECTED AN ERROR THAT C PREVENTED USER FROM ASSIGNING THE SECOND DIMENSION C OF KDATA(500,*). C 92-10-20 CAVANAUGH - REMOVED ERROR THAT PREVENTED FULL C IMPLEMENTATION OF PREVIOUS CORRECTIONS AND C MADE CORRECTIONS TO TABLE B TO BRING IT UP TO C DATE. CHANGES INCLUDE PROPER REFORMAT OF PROFILER C DATA AND USER CAPABILITY FOR ASSIGNING SECOND C DIMENSION OF KDATA ARRAY. C 92-12-09 CAVANAUGH - THANKS TO DENNIS KEYSER FOR THE SUGGESTIONS C AND CODING, THIS IMPLEMENTATION WILL ALLOW THE C INCLUSION OF UNIT NUMBERS FOR TABLES B & D, AND C IN ADDITION ALLOWS FOR REALISTIC SIZING OF KDATA C AND MSTACK ARRAYS BY THE USER. AS OF THIS C IMPLEMENTATION, THE UPPER SIZE LIMIT FOR A BUFR C MESSAGE ALLOWS FOR A MESSAGE SIZE GREATER THAN C 10000 BYTES. C 93-01-26 CAVANAUGH - SUBROUTINE FI7810 HAS BEEN ADDED TO PERMIT C REFORMATTING OF PROFILER DATA IN EDITION 2. C C C USAGE: CALL W3FI78(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX, C MAXR,MAXD,IUNITB,IUNITD) C C INPUT ARGUMENT LIST: C MSGA - ARRAY CONTAINING SUPPOSED BUFR MESSAGE C SIZE IS DETERMINED BY USER, CAN BE GREATER C THAN 10000 BYTES. C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE C CONTAINED IN A BUFR MESSAGE C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D C C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM C SOURCE BUFR MESSAGE. C C MSTACK(A,B)-LEVEL B - DESCRIPTOR NUMBER (LIMITED TO VALUE OF C INPUT ARGUMENT MAXD) C C LEVEL A = 1 DESCRIPTOR C = 2 10**N SCALING TO RETURN TO ORIGINAL VALUE C IPTR - UTILITY ARRAY C IPTR( 1)- ERROR RETURN C IPTR( 2)- BYTE COUNT SECTION 1 C IPTR( 3)- POINTER TO START OF SECTION 1 C IPTR( 4)- BYTE COUNT SECTION 2 C IPTR( 5)- POINTER TO START OF SECTION 2 C IPTR( 6)- BYTE COUNT SECTION 3 C IPTR( 7)- POINTER TO START OF SECTION 3 C IPTR( 8)- BYTE COUNT SECTION 4 C IPTR( 9)- POINTER TO START OF SECTION 4 C IPTR(10)- START OF REQUESTED SUBSET, RESERVED FOR DAR C IPTR(11)- CURRENT DESCRIPTOR PTR IN IWORK C IPTR(12)- LAST DESCRIPTOR POS IN IWORK C IPTR(13)- LAST DESCRIPTOR POS IN ISTACK C IPTR(14)- NUMBER OF TABLE B ENTRIES C IPTR(15)- REQUESTED SUBSET POINTER, RESERVED FOR DAR C IPTR(16)- INDICATOR FOR EXISTANCE OF SECTION 2 C IPTR(17)- NUMBER OF REPORTS PROCESSED C IPTR(18)- ASCII/TEXT EVENT C IPTR(19)- POINTER TO START OF BUFR MESSAGE C IPTR(20)- NUMBER OF LINES FROM TABLE D C IPTR(21)- TABLE B SWITCH C IPTR(22)- TABLE D SWITCH C IPTR(23)- CODE/FLAG TABLE SWITCH C IPTR(24)- ADITIONAL WORDS ADDED BY TEXT INFO C IPTR(25)- CURRENT BIT NUMBER C IPTR(26)- DATA WIDTH CHANGE C IPTR(27)- DATA SCALE CHANGE C IPTR(28)- DATA REFERENCE VALUE CHANGE C IPTR(29)- ADD DATA ASSOCIATED FIELD C IPTR(30)- SIGNIFY CHARACTERS C IPTR(31)- NUMBER OF EXPANDED DESCRIPTORS IN MSTACK C IPTR(32)- CURRENT DESCRIPTOR SEGMENT F C IPTR(33)- CURRENT DESCRIPTOR SEGMENT X C IPTR(34)- CURRENT DESCRIPTOR SEGMENT Y C IPTR(35)- UNUSED C IPTR(36)- NEXT DESCRIPTOR MAY BE UNDECIPHERABLE C IPTR(37)- UNUSED C IPTR(38)- UNUSED C IPTR(39)- DELAYED REPLICATION FLAG C 0 - NO DELAYED REPLICATION C 1 - MESSAGE CONTAINS DELAYED REPLICATION C IPTR(40)- NUMBER OF CHARACTERS IN TEXT FOR CURR DESCRIPTOR C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM C BUFR MESSAGE - C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) C IDENT( 4)-OPTIONAL SECTION (BYTE 8, SECTION 1) C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) C 0 = SURFACE (LAND) C 1 = SURFACE (SHIP) C 2 = VERTICAL SOUNDINGS OTHER THAN SATELLITE C 3 = VERTICAL SOUNDINGS (SATELLITE) C 4 = SNGL LVL UPPER-AIR OTHER THAN SATELLITE C 5 = SNGL LVL UPPER-AIR (SATELLITE) C 6 = RADAR C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) C TYPE SBTYP C 2 7 = PROFILER C IDENT( 7)- (BYTES 11-12, SECTION 1) C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) C IDENT(17)-MASTER TABLE NUMBER(BYTE 4, SECTION 1, ED 2 OR GTR) C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. C KDATA(REPORT NUMBER,PARAMETER NUMBER) C C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT C ARGUMENT MAXD) C C ARRAYS CONTAINING DATA FROM TABLE B C ANAME - DESCRIPTOR NAME C AUNITS - UNITS FOR DESCRIPTOR C MSCALE - SCALE FOR VALUE OF DESCRIPTOR C MREF - REFERENCE VALUE FOR DESCRIPTOR C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR C INDEX - POINTER TO AVAILABLE SUBSET C C SUBPROGRAMS CALLED: C LIBRARY: C W3LIB - GBYTE GBYTES C C REMARKS: ERROR RETURNS: C IPTR(1) = 1 'BUFR' NOT FOUND IN FIRST 125 CHARACTERS C = 2 '7777' NOT FOUND IN LOCATION DETERMINED BY C BY USING COUNTS FOUND IN EACH SECTION. ONE OR C MORE SECTIONS HAVE AN ERRONEOUS BYTE COUNT OR C CHARACTERS '7777' ARE NOT IN TEST MESSAGE. C = 3 MESSAGE CONTAINS A DESCRIPTOR WITH F=0 THAT DOES C NOT EXIST IN TABLE B. C = 4 MESSAGE CONTAINS A DESCRIPTOR WITH F=3 THAT DOES C NOT EXIST IN TABLE D. C = 5 MESSAGE CONTAINS A DESCRIPTOR WITH F=2 WITH THE C VALUE OF X OUTSIDE THE RANGE 1-5. C = 6 DESCRIPTOR ELEMENT INDICATED TO HAVE A FLAG VALUE C DOES NOT HAVE AN ENTRY IN THE FLAG TABLE. C (TO BE ACTIVATED) C = 7 DESCRIPTOR INDICATED TO HAVE A CODE VALUE DOES C NOT HAVE AN ENTRY IN THE CODE TABLE. C (TO BE ACTIVATED) C = 8 ERROR READING TABLE D C = 9 ERROR READING TABLE B C = 10 ERROR READING CODE/FLAG TABLE C = 11 DESCRIPTOR 2 04 004 NOT FOLLOWED BY 0 31 021 C = 12 DATA DESCRIPTOR OPERATOR QUALIFIER DOES NOT FOLLOW C DELAYED REPLICATION DESCRIPTOR. C = 13 BIT WIDTH ON ASCII CHARACTERS NOT A MULTIPLE OF 8 C = 14 SUBSETS = 0, NO CONTENT BULLETIN C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS C = 21 EXCEEDED COUNT FOR NON-DELAYED REPLICATION PASS C = 27 NON ZERO LOWEST ON TEXT DATA C = 28 NBINC NOT NR OF CHARACTERS C = 29 TABLE B APPEARS TO BE DAMAGED C = 99 NO MORE SUBSETS (REPORTS) AVAILABLE IN CURRENT C BUFR MESAGE C C = 400 NUMBER OF SUBSETS EXCEEDS THE VALUE OF INPUT C ARGUMENT MAXR; MUST INCREASE MAXR TO VALUE OF C IDENT(14) IN CALLING PROGRAM C C = 401 NUMBER OF PARAMETERS (AND ASSOCIATED FIELDS) C EXCEEDS LIMITS OF THIS PROGRAM. C = 500 VALUE FOR NBINC HAS BEEN FOUND THAT EXCEEDS C STANDARD WIDTH PLUS ANY BIT WIDTH CHANGE. C CHECK ALL BIT WIDTHS UP TO POINT OF ERROR. C = 501 CORRECTED WIDTH FOR DESCRIPTOR IS 0 OR LESS C C ON THE INITIAL CALL TO W3FI78 WITH A BUFR MESSAGE THE ARGUMENT C INDEX MUST BE SET TO ZERO (INDEX = 0). ON THE RETURN FROM W3FI78 C 'INDEX' WILL BE SET TO THE NEXT AVAILABLE SUBSET/REPORT. WHEN C THERE ARE NO MORE SUBSETS AVAILABLE A 99 ERR RETURN WILL OCCUR. C C IF THE ORIGINAL BUFR MESSAGE DOES NOT CONTAIN DELAYED REPLICATION C THE BUFR MESSAGE WILL BE COMPLETELY DECODED AND 'INDEX' WILL POINT C TO THE FIRST DECODED SUBSET. THE USERS WILL THEN HAVE THE OPTION C OF INDEXING THROUGH THE SUBSETS ON THEIR OWN OR BY RECALLING THIS C ROUTINE (WITHOUT RESETTING 'INDEX') TO HAVE THE ROUTINE DO THE C INDEXING. C C IF THE ORIGINAL BUFR MESSAGE DOES CONTAIN DELAYED REPLICATION C ONE SUBSET/REPORT WILL BE DECODED AT A TIME AND PASSED BACK TO C THE USER. THIS IS NOT AN OPTION. C C ============================================= C TO USE THIS ROUTINE C -------------------------------- C 1. READ IN BUFR MESSAGE C 2. SET INDEX = 0 C 3. CALL W3FI78( ) C 4. IF (IPTR(1).EQ.99) THEN C NO MORE SUBSETS C EITHER GO TO 1 C OR TERMINATE IN NO MORE BUFR MESSAGES C END IF C 5. IF (IPTR(1).NE.0) THEN C ERROR CONDITION C EITHER GO TO 1 C OR TERMINATE IN NO MORE BUFR MESSAGES C END IF C 6. THE VALUE OF INDEX INDICATES THE ACTIVE SUBSET SO C IF INTERESTED IN GENERATING AN IFOD MESSAGE C CALL W3FL05 ( ) C ELSE C PROCESS DECODED INFORMATION AS REQUIRED C END IF C 7. GO TO 3 C ============================================= C THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED C AS FOLLOWS: C C KDATA(A,B) IS THE A DATA ENTRY (INTEGER VALUE) C WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS C THAT MAY BE CONTAINED IN THE BUFR MESSAGE (THIS C IS NOW SET TO "MAXR" WHICH IS PASSED AS AN INPUT C ARGUMENT TO W3FI78), AND WHERE B IS THE MAXIMUM C NUMBER OF DESCRIPTOR COMBINATIONS THAT MAY C BE PROCESSED (THIS IS NOW SET TO "MAXD" WHICH C IS ALSO PASSED AS AN INPUT ARGUMENT TO W3FI78; C UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE C A VALUE FOR MAXD OF 1600, BUT FOR MOST OTHER C DATA A VALUE FOR MAXD OF 500 WILL SUFFICE) C MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE C DATA ENTRY (MAX. VALUE FOR B IS NOW "MAXD" C WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI78) C MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO C THE DATA (MAX. VALUE FOR B IS NOW "MAXD" C WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI78) C C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN 77 C MACHINE: CRAY Y-MP8/832 C C$$$ C CHARACTER*40 ANAME(700) CHARACTER*24 AUNITS(700) C C C INTEGER MSGA(*) INTEGER IPTR(*) INTEGER KDATA(MAXR,MAXD) INTEGER MSTACK(2,MAXD) C INTEGER IVALS(1000) INTEGER KNR(MAXR) INTEGER IDENT(*) INTEGER KDESC(2000) INTEGER ISTACK(*) INTEGER IWORK(2000) INTEGER MSCALE(700) INTEGER MREF(700,3) INTEGER MWIDTH(700) INTEGER INDEX C CHARACTER*4 DIRID(2) C LOGICAL SEC2 C SAVE C C PRINT *,' W3FI78 DECODER' C INITIALIZE ERROR RETURN IPTR(1) = 0 IF (INDEX.GT.0) THEN C HAVE RE-ENTRY INDEX = INDEX + 1 C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX IF (INDEX.GT.IDENT(14)) THEN C ALL SUBSETS PROCESSED IPTR(1) = 99 IPTR(39) = 0 ELSE IF (INDEX.LE.IDENT(14)) THEN IF (IPTR(39).NE.0) THEN CALL FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA, C * IVALS,MSTACK, * AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD, * IUNITB,IUNITD) C END IF END IF RETURN ELSE INDEX = 1 C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE' END IF IPTR(39) = 0 C FIND 'BUFR' IN FIRST 125 CHARACTERS DO 1000 KNOFST = 0, 999, 8 INOFST = KNOFST CALL GBYTE (MSGA,IVALS,INOFST,8) IF (IVALS(1).EQ.66) THEN IPTR(19) = INOFST INOFST = INOFST + 8 CALL GBYTE (MSGA,IVALS,INOFST,24) IF (IVALS(1).EQ.5588562) THEN C PRINT *,'FOUND BUFR AT',IPTR(19) INOFST = INOFST + 24 GO TO 1500 END IF END IF 1000 CONTINUE PRINT *,'BUFR - START OF BUFR MESSAGE NOT FOUND' IPTR(1) = 1 RETURN 1500 CONTINUE IDENT(1) = 0 C TEST FOR EDITION NUMBER C ====================== CALL GBYTE (MSGA,IDENT(1),INOFST+24,8) C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE' C IF (IDENT(1).GE.2) THEN C GET TOTAL COUNT CALL GBYTE (MSGA,IVALS,INOFST,24) ITOTAL = IVALS(1) KENDER = ITOTAL * 8 - 32 + IPTR(19) CALL GBYTE (MSGA,ILAST,KENDER,32) C IF (ILAST.EQ.926365495) THEN C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1) C END IF INOFST = INOFST + 32 C GET SECTION 1 COUNT IPTR(3) = INOFST CALL GBYTE (MSGA,IVALS,INOFST,24) C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) INOFST = INOFST + 24 IPTR( 2) = IVALS(1) C GET MASTER TABLE CALL GBYTE (MSGA,IVALS,INOFST,8) INOFST = INOFST + 8 IDENT(17) = IVALS(1) C PRINT *,'BUFR MASTER TABLE NR',IDENT(17) ELSE IPTR(3) = INOFST C GET SECTION 1 COUNT CALL GBYTE (MSGA,IVALS,INOFST,24) C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) INOFST = INOFST + 32 IPTR( 2) = IVALS(1) END IF C ====================== C ORIGINATING CENTER CALL GBYTE (MSGA,IVALS,INOFST,16) INOFST = INOFST + 16 IDENT(2) = IVALS(1) C UPDATE SEQUENCE CALL GBYTE (MSGA,IVALS,INOFST,8) INOFST = INOFST + 8 IDENT(3) = IVALS(1) C OPTIONAL SECTION FLAG CALL GBYTE (MSGA,IVALS,INOFST,1) IDENT(4) = IVALS(1) IF (IDENT(4).GT.0) THEN SEC2 = .TRUE. ELSE C PRINT *,' NO OPTIONAL SECTION 2' SEC2 = .FALSE. END IF INOFST = INOFST + 8 C MESSAGE TYPE CALL GBYTE (MSGA,IVALS,INOFST,8) IDENT(5) = IVALS(1) INOFST = INOFST + 8 C MESSAGE SUB-TYPE CALL GBYTE (MSGA,IVALS,INOFST,8) IDENT(6) = IVALS(1) INOFST = INOFST + 8 C IF BUFR EDITION 0 OR 1 THEN C NEXT 2 BYTES ARE BUFR TABLE VERSION C ELSE C BYTE 11 IS VER NR OF MASTER TABLE C BYTE 12 IS VER NR OF LOCAL TABLE IF (IDENT(1).LT.2) THEN CALL GBYTE (MSGA,IVALS,INOFST,16) IDENT(7) = IVALS(1) INOFST = INOFST + 16 ELSE C BYTE 11 IS VER NR OF MASTER TABLE CALL GBYTE (MSGA,IVALS,INOFST,8) IDENT(18) = IVALS(1) INOFST = INOFST + 8 C BYTE 12 IS VER NR OF LOCAL TABLE CALL GBYTE (MSGA,IVALS,INOFST,8) IDENT(19) = IVALS(1) INOFST = INOFST + 8 END IF C YEAR OF CENTURY CALL GBYTE (MSGA,IVALS,INOFST,8) IDENT(8) = IVALS(1) INOFST = INOFST + 8 C MONTH CALL GBYTE (MSGA,IVALS,INOFST,8) IDENT(9) = IVALS(1) INOFST = INOFST + 8 C DAY C PRINT *,'DAY AT ',INOFST CALL GBYTE (MSGA,IVALS,INOFST,8) IDENT(10) = IVALS(1) INOFST = INOFST + 8 C HOUR CALL GBYTE (MSGA,IVALS,INOFST,8) IDENT(11) = IVALS(1) INOFST = INOFST + 8 C MINUTE CALL GBYTE (MSGA,IVALS,INOFST,8) IDENT(12) = IVALS(1) C RESET POINTER (INOFST) TO START OF C NEXT SECTION C (SECTION 2 OR SECTION 3) INOFST = IPTR(3) + IPTR(2) * 8 IPTR(4) = 0 IPTR(5) = INOFST IF (SEC2) THEN C SECTION 2 COUNT CALL GBYTE (MSGA,IPTR(4),INOFST,24) INOFST = INOFST + 32 C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4) KENTRY = (IPTR(4) - 4) / 14 C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS' IF (IDENT(2).EQ.7) THEN DO 2000 I = 1, KENTRY CALL GBYTE (MSGA,KDSPL ,INOFST,16) INOFST = INOFST + 16 CALL GBYTE (MSGA,LAT ,INOFST,16) INOFST = INOFST + 16 CALL GBYTE (MSGA,LON ,INOFST,16) INOFST = INOFST + 16 CALL GBYTE (MSGA,KDAHR ,INOFST,16) INOFST = INOFST + 16 CALL GBYTE (MSGA,DIRID(1),INOFST,32) INOFST = INOFST + 32 CALL GBYTE (MSGA,DIRID(2),INOFST,16) INOFST = INOFST + 16 C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2) 2000 CONTINUE END IF C RESET POINTER (INOFST) TO START OF C SECTION 3 INOFST = IPTR(5) + IPTR(4) * 8 END IF C BIT OFFSET TO START OF SECTION 3 IPTR( 7) = INOFST C SECTION 3 COUNT CALL GBYTE (MSGA,IPTR(6),INOFST,24) C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6) INOFST = INOFST + 24 C SKIP RESERVED BYTE INOFST = INOFST + 8 C NUMBER OF DATA SUBSETS CALL GBYTE (MSGA,IDENT(14),INOFST,16) C IF (IDENT(14).GT.MAXR) THEN PRINT *,'THE NUMBER OF SUBSETS EXCEEDS THE MAXIMUM OF',MAXR PRINT *,'PASSED INTO W3FI78; MAXR MUST BE INCREASED IN ' PRINT *,'THE CALLING PROGRAM TO AT LEAST THE VALUE OF' PRINT *,IDENT(14),'TO BE ABLE TO PROCESS THIS DATA' C IPTR(1) = 400 RETURN END IF INOFST = INOFST + 16 C OBSERVED DATA FLAG CALL GBYTE (MSGA,IVALS,INOFST,1) IDENT(15) = IVALS(1) INOFST = INOFST + 1 C COMPRESSED DATA FLAG CALL GBYTE (MSGA,IVALS,INOFST,1) IDENT(16) = IVALS(1) INOFST = INOFST + 7 C CALCULATE NUMBER OF DESCRIPTORS NRDESC = (IPTR( 6) - 8) / 2 IPTR(12) = NRDESC IPTR(13) = NRDESC C EXTRACT DESCRIPTORS CALL GBYTES (MSGA,ISTACK,INOFST,16,0,NRDESC) C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS' DO 10 L = 1, NRDESC IWORK(L) = ISTACK(L) C PRINT *,L,ISTACK(L) 10 CONTINUE IPTR(13) = NRDESC C RESET POINTER TO START OF SECTION 4 INOFST = IPTR(7) + IPTR(6) * 8 C BIT OFFSET TO START OF SECTION 4 IPTR( 9) = INOFST C SECTION 4 COUNT CALL GBYTE (MSGA,IVALS,INOFST,24) C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1) IPTR( 8) = IVALS(1) INOFST = INOFST + 32 C SET FOR STARTING BIT OF DATA IPTR(25) = INOFST C FIND OUT IF '7777' TERMINATOR IS THERE INOFST = IPTR(9) + IPTR(8) * 8 CALL GBYTE (MSGA,IVALS,INOFST,32) C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1) IF (IVALS(1).NE.926365495) THEN PRINT *,'BAD SECTION COUNT' IPTR(1) = 2 RETURN ELSE IPTR(1) = 0 END IF C CALL FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,IVALS,MSTACK, * AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD, * IUNITB,IUNITD) C C PRINT *,'HAVE RETURNED FROM FI7801' C IF (IPTR(1).NE.0) THEN C RETURN C END IF C FURTHER PROCESSING REQUIRED FOR PROFILER DATA IF (IDENT(5).EQ.2) THEN IF (IDENT(6).EQ.7) THEN C PRINT *,'BASIC PROFILER DATA' C DO 153 I = 1, KNR(INDEX) C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I) C 153 CONTINUE C PRINT *,'REFORMAT PROFILER DATA' C IF (IDENT(1).LT.2) THEN CALL FI7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) ELSE CALL FI7810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) END IF C DO 151 I = 1, 40 C IF (I.LE.20) THEN C PRINT *,'IPTR(',I,')=',IPTR(I), C * ' IDENT(',I,')= ',IDENT(I) C ELSE C PRINT *,'IPTR(',I,')=',IPTR(I) C END IF C 151 CONTINUE IF (IPTR(1).NE.0) THEN RETURN END IF C C DO 154 I = 1, IPTR(31) C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I) C 154 CONTINUE END IF END IF RETURN END SUBROUTINE FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,IVALS, * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD, * IUNITB,IUNITD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI7801 DATA EXTRACTION C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 C C ABSTRACT: CONTROL THE EXTRACTION OF DATA FROM SECTION 4 BASED ON C DATA DESCRIPTORS. C C PROGRAM HISTORY LOG: C 88-09-01 CAVANAUGH C 91-01-18 CAVANAUGH CORRECTIONS TO PROPERLY HANDLE NON-COMPRESSED C DATA. C 91-09-23 CAVANAUGH CODING ADDED TO HANDLE SINGLE SUBSETS WITH C DELAYED REPLICATION. C 92-01-24 CAVANAUGH MODIFIED TO ECHO DESCRIPTORS TO MSTACK(1,N) C C USAGE: CALL FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA, C * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD, C * IUNITB,IUNITD) C C INPUT ARGUMENT LIST: C IPTR - SEE W3FI78 ROUTINE DOCBLOCK C IDENT - SEE W3FI78 ROUTINE DOCBLOCK C MSGA - ARRAY CONTAINING BUFR MESSAGE C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM C SOURCE BUFR MESSAGE. C MSTACK - WORKING ARRAY OF DESCRIPTORS (EXPANDED)AND SCALING C FACTOR C KDESC - IMAGE OF CURRENT DESCRIPTOR C INDEX - C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE C CONTAINED IN A BUFR MESSAGE C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C IWORK - WORKING DESCRIPTOR LIST C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. C KDATA(REPORT NUMBER,PARAMETER NUMBER) C C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT C ARGUMENT MAXD) C C ISTACK - SEE ABOVE C ARRAYS CONTAINING DATA FROM TABLE B C KDESC - SEE ABOVE C ANAME - DESCRIPTOR NAME C AUNITS - UNITS FOR DESCRIPTOR C MSCALE - SCALE FOR VALUE OF DESCRIPTOR C MREF - REFERENCE VALUE FOR DESCRIPTOR C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR C C SUBPROGRAMS CALLED: C LIBRARY: C W3LIB - FI7802 FI7805 FI7806 FI7807 FI7808 C C REMARKS: ERROR RETURN: C IPTR(1) = 8 ERROR READING TABLE B C = 9 ERROR READING TABLE D C = 11 ERROR OPENING TABLE B C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN 77 C MACHINE: CRAY Y-MP8/832 C C$$$ SAVE C CHARACTER*40 ANAME(*) CHARACTER*24 AUNITS(*) C C INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*) C INTEGER MSCALE(*),KNR(MAXR) INTEGER LX,LY,LL,J INTEGER MREF(700,3) INTEGER MWIDTH(*) INTEGER IHOLD(33) INTEGER ITBLD(500,11) INTEGER IPTR(*) INTEGER IDENT(*) INTEGER KDESC(*) INTEGER ISTACK(*),IWORK(*) C INTEGER MSTACK(2,MAXD),KK C INTEGER JDESC INTEGER INDEX INTEGER ITEST(30) C DATA ITEST /1,3,7,15,31,63,127,255, * 511,1023,2047,4095,8191,16383, * 32767, 65535,131071,262143,524287, * 1048575,2097151,4194303,8388607, * 16777215,33554431,67108863,134217727, * 268435455,536870911,1073741823/ C C PRINT *,' DECOLL FI7801' IF (INDEX.GT.1) THEN GO TO 1000 END IF C --------- DECOLL --------------- IPTR(23) = 0 IPTR(26) = 0 IPTR(27) = 0 IPTR(28) = 0 IPTR(29) = 0 IPTR(30) = 0 IPTR(36) = 0 C INITIALIZE OUTPUT AREA C SET POINTER TO BEGINNING OF DATA C SET BIT IPTR(17) = 1 1000 CONTINUE C IPTR(12) = IPTR(13) LL = 0 IPTR(11) = 1 IF (IPTR(10).EQ.0) THEN C RE-ENTRY POINT FOR MULTIPLE C NON-COMPRESSED REPORTS ELSE INDEX = IPTR(15) IPTR(17) = INDEX IPTR(25) = IPTR(10) IPTR(10) = 0 IPTR(15) = 0 END IF C PRINT *,'FI7801 - RPT',IPTR(17),' STARTS AT',IPTR(25) IPTR(24) = 0 IPTR(31) = 0 C POINTING AT NEXT AVAILABLE DESCRIPTOR MM = 0 IF (IPTR(21).EQ.0) THEN C PRINT *,' READING TABLE B' DO 150 I = 1, 700 IPTR(21) = I C READ(UNIT=IUNITB,FMT=20,ERR=9999,END=175)MF, * MX,MY, * (ANAME(I)(K:K),K=1,40), * (AUNITS(I)(K:K),K=1,24), * MSCALE(I),MREF(I,1),MWIDTH(I) 20 FORMAT(I1,I2,I3,40A1,24A1,I5,I15,1X,I4) IF (MWIDTH(I).EQ.0) THEN IPTR(1) = 29 RETURN END IF MREF(I,2) = 0 IPTR(14) = I KDESC(I) = MF*16384 + MX*256 + MY C PRINT *,I C WRITE(6,21) MF,MX,MY,KDESC(I), C * (ANAME(I)(K:K),K=1,40), C * (AUNITS(I)(K:K),K=1,24), C * MSCALE(I),MREF(I,1),MWIDTH(I) 21 FORMAT(1X,I1,I2,I3,1X,I6,1X,40A1, * 2X,24A1,2X,I5,2X,I15,1X,I4) 150 CONTINUE PRINT *,'HAVE READ LIMIT OF 700 TABLE B DESCRIPTORS' PRINT *,'IF THERE ARE MORE THAT THAT, CORRECT READ LOOP' 175 CONTINUE C C CLOSE(UNIT=IUNITB,STATUS='KEEP') C IPTR(21) = 1 END IF C DO WHILE MM <= MAXD 10 CONTINUE C PROCESS THRU THE FOLLOWING C DEPENDING UPON THE VALUE OF 'F' (LF) MM = MM + 1 12 CONTINUE IF (MM.GT.MAXD) THEN GO TO 200 END IF C END OF CYCLE TEST (SERIAL/SEQUENTIAL) IF (IPTR(11).GT.IPTR(12)) THEN C PRINT *,' HAVE COMPLETED REPORT SEQUENCE' IF (IDENT(16).NE.0) THEN C PRINT *,' PROCESSING COMPRESSED REPORTS' C REFORMAT DATA FROM DESCRIPTOR C FORM TO USER FORM RETURN ELSE C WRITE (6,1) C 1 FORMAT (1H1) C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25) IPTR(17) = IPTR(17) + 1 IF (IPTR(17).GT.IDENT(14)) THEN IPTR(17) = IPTR(17) - 1 GO TO 200 END IF DO 300 I = 1, IPTR(13) IWORK(I) = ISTACK(I) 300 CONTINUE C RESET POINTERS LL = 0 IPTR(1) = 0 IPTR(11) = 1 IPTR(12) = IPTR(13) C IS THIS LAST REPORT ? C PRINT *,'READY',IPTR(39),INDEX IF (IPTR(39).GT.0) THEN IF (INDEX.GT.0) THEN C PRINT *,'HERE IS SUBSET NR',INDEX RETURN END IF END IF GO TO 1000 END IF END IF 14 CONTINUE C GET NEXT DESCRIPTOR CALL FI7808 (IPTR,IWORK,LF,LX,LY,JDESC,MAXD) C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ', C * IPTR(11),IWORK(IPTR(11)),IPTR(31) C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY, C * ' FOR LOC',IPTR(17),IPTR(25) IF (IPTR(11).GT.1600) THEN IPTR(1) = 401 RETURN END IF C KPRM = IPTR(31) + IPTR(24) IF (KPRM.GT.1600) THEN IF (KPRM.GT.KOLD) THEN PRINT *,'EXCEEDED ARRAY SIZE',KPRM,IPTR(31), * IPTR(24) KOLD = KPRM END IF END IF C REPLICATION PROCESSING IF (LF.EQ.1) THEN C ---------- F1 --------- IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) MSTACK(1,KPRM) = JDESC MSTACK(2,KPRM) = 0 KDATA(IPTR(17),KPRM) = 0 C PRINT *,'FI7801-1',KPRM,MSTACK(1,KPRM), C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) CALL FI7805(IPTR,IDENT,MSGA,IWORK,LX,LY, * KDATA,LL,KNR,MSTACK,MAXR,MAXD) IF (IPTR(1).NE.0) THEN RETURN ELSE GO TO 12 END IF C C DATA DESCRIPTION OPERATORS ELSE IF (LF.EQ.2)THEN IF (LX.EQ.5) THEN ELSE IF (LX.EQ.4) THEN IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) MSTACK(1,KPRM) = JDESC MSTACK(2,KPRM) = 0 KDATA(IPTR(17),KPRM) = 0 C PRINT *,'FI7801-2',KPRM,MSTACK(1,KPRM), C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) END IF CALL FI7806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC,MAXR,MAXD) IF (IPTR(1).NE.0) THEN RETURN END IF GO TO 12 C DESCRIPTOR SEQUENCE STRINGS ELSE IF (LF.EQ.3) THEN C PRINT *,'F3 SEQUENCE DESCRIPTOR' IF (IPTR(22).EQ.0) THEN C READ IN TABLE D, BUT JUST ONCE IERR = 0 C PRINT *,' READING TABLE D' DO 50 I = 1, 500 READ(IUNITD,15,ERR=9998,END=75 ) * (IHOLD(J),J=1,33) 15 FORMAT(11(I1,I2,I3,1X),3X) IPTR(20) = I DO 25 JJ = 1, 31, 3 KK = (JJ/3) + 1 ITBLD(I,KK) = IHOLD(JJ)*16384 + * IHOLD(JJ+1)*256 + IHOLD(JJ+2) IF (ITBLD(I,KK).EQ.0) THEN C PRINT 16,(ITBLD(I,L),L=1,11) GO TO 50 END IF 25 CONTINUE C PRINT 16,(ITBLD(I,L),L=1,11) 50 CONTINUE 16 FORMAT(1X,11(I6,1X)) 75 CONTINUE CLOSE(UNIT=IUNITD,STATUS='KEEP') IPTR(22) = 1 ENDIF CALL FI7807(IPTR,IWORK,ITBLD,JDESC,MAXD) IF (IPTR(1).GT.0) THEN RETURN END IF GO TO 14 C C STANDARD DESCRIPTOR PROCESSING ELSE C PRINT *,'ENTRY',IPTR(31),JDESC,' AT',IPTR(25) KPRM = IPTR(31) + IPTR(24) CALL FI7802(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK, * AUNITS,MWIDTH,MREF,MSCALE,JDESC,IVALS,J,MAXR,MAXD) C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR IPTR(36) = 0 IF (IPTR(1).GT.0) THEN RETURN ELSE IF (IDENT(16).EQ.0) THEN KNR(IPTR(17)) = IPTR(31) ELSE DO 310 KJ = 1, MAXR KNR(KJ) = IPTR(31) 310 CONTINUE END IF GO TO 10 END IF END IF C END IF C END DO WHILE 200 CONTINUE IF (IDENT(16).NE.0) THEN C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS' ELSE C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS' END IF RETURN 9998 CONTINUE PRINT *,' ERROR READING TABLE D' IPTR(1) = 8 RETURN 9999 CONTINUE PRINT *,' ERROR READING TABLE B' IPTR(1) = 9 RETURN END C ----------------------------------------------------- SUBROUTINE FI7802(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,AUNITS, * MWIDTH,MREF,MSCALE,JDESC,IVALS,J,MAXR,MAXD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI7802 PROCESS STANDARD DESCRIPTOR C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 C C ABSTRACT: PROCESS A STANDARD DESCRIPTOR (F = 0) AND STORE DATA C IN OUTPUT ARRAY. C C PROGRAM HISTORY LOG: C 88-09-01 CAVANAUGH C 91-04-04 CAVANAUGH CHANGED TO PASS WIDTH OF TEXT FIELDS IN BYTES C C USAGE: CALL FI7802(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,AUNITS, C MWIDTH,MREF,MSCALE,JDESC,IVALS,J,MAXR,MAXD) C INPUT ARGUMENT LIST: C IPTR - SEE W3FI78 ROUTINE DOCBLOCK C IDENT - SEE W3FI78 ROUTINE DOCBLOCK C MSGA - ARRAY CONTAINING BUFR MESSAGE C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. C KDATA(REPORT NUMBER,PARAMETER NUMBER) C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT C ARGUMENT MAXD) C KDESC - IMAGE OF CURRENT DESCRIPTOR C ANAME - LIST OF NAME OF DESCRIPTOR CONTENTS C MSTACK - C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE C CONTAINED IN A BUFR MESSAGE C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C KDATA - SEE ABOVE C KDESC - SEE ABOVE C ARRAYS CONTAINING DATA FROM TABLE B C AUNITS - UNITS FOR DESCRIPTOR C MSCALE - SCALE FOR VALUE OF DESCRIPTOR C MREF - REFERENCE VALUE FOR DESCRIPTOR C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR C C SUBPROGRAMS CALLED: C LIBRARY: C W3LIB - FI7803 FI7804 C C REMARKS: ERROR RETURN: C IPTR(1) = 3 - MESSAGE CONTAINS A DESCRIPTOR WITH F=0 C THAT DOES NOT EXIST IN TABLE B. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN 77 C MACHINE: CRAY Y-MP8/832 C C$$$ SAVE C TABLE B ENTRY CHARACTER*24 ASKEY CHARACTER*24 AUNITS(*) C TABLE B ENTRY INTEGER MSGA(*) INTEGER IPTR(*) INTEGER IDENT(*) INTEGER J INTEGER JDESC INTEGER KDESC(*) INTEGER MWIDTH(*),MSTACK(2,MAXD),MSCALE(*) INTEGER MREF(700,3),KDATA(MAXR,MAXD),IVALS(*) C TABLE B ENTRY C DATA ASKEY /'CCITT IA5 '/ C C PRINT *,' FI7802 - STANDARD DESCRIPTOR PROCESSOR' C GET A MATCH BETWEEN CURRENT C DESCRIPTOR (JDESC) AND C TABLE B ENTRY C IF (KDESC(356).EQ.0) THEN C PRINT *,'FI7802 - KDESC(356) WENT TO ZER0' C IPTR(1) = 600 C RETURN C END IF K = 1 KK = IPTR(14) IF (JDESC.GT.KDESC(KK)) THEN K = KK + 1 END IF 10 CONTINUE IF (K.GT.KK) THEN IF (IPTR(36).NE.0) THEN C HAVE SKIP FLAG IF (IDENT(16).NE.0) THEN C SKIP OVER COMPRESSED DATA C LOWEST IPTR(25) = IPTR(25) + IPTR(36) C NBINC CALL GBYTE (MSGA,IHOLD,IPTR(25),6) IPTR(25) = IPTR(25) + 6 IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) MSTACK(1,KPRM) = JDESC MSTACK(2,KPRM) = 0 DO 50 I = 1, IPTR(14) KDATA(I,KPRM) = 99999 50 CONTINUE C PROCESS DIFFERENCES IF (IHOLD.NE.0) THEN IBITS = IHOLD * IDENT(14) IPTR(25) = IPTR(25) + IBITS END IF ELSE IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) MSTACK(1,KPRM) = JDESC MSTACK(2,KPRM) = 0 KDATA(IPTR(17),KPRM) = 99999 C SKIP OVER NON-COMPRESSED DATA C PRINT *,'SKIP NON-COMPRESSED DATA' IPTR(25) = IPTR(25) + IPTR(36) END IF RETURN ELSE PRINT *,'FI7802 - ERROR = 3' PRINT *,JDESC,K,KK,J,KDESC(J) PRINT *,' ' PRINT *,'TABLE B' C DO 20 LL = 1, IPTR(14) C PRINT *,LL,KDESC(LL) C 20 CONTINUE IPTR(1) = 3 RETURN END IF ELSE J = ((KK - K) / 2) + K END IF IF (JDESC.EQ.KDESC(K)) THEN J = K GO TO 15 ELSE IF (JDESC.EQ.KDESC(KK))THEN J = KK GO TO 15 ELSE IF (JDESC.LT.KDESC(J)) THEN K = K + 1 KK = J - 1 GO TO 10 ELSE IF (JDESC.GT.KDESC(J)) THEN K = J + 1 KK = KK - 1 GO TO 10 END IF 15 CONTINUE C HAVE A MATCH C SET FLAG IF TEXT EVENT IF (ASKEY(1:9).EQ.AUNITS(J)(1:9)) THEN IPTR(18) = 1 IPTR(40) = MWIDTH(J) / 8 ELSE IPTR(18) = 0 END IF IF (IDENT(16).NE.0) THEN C COMPRESSED CALL FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, * MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD) IF (IPTR(1).NE.0) THEN RETURN END IF ELSE C NOT COMPRESSED CALL FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK, * MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD) END IF RETURN END C ----------------------------------------------------- SUBROUTINE FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, * MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI7803 PROCESS COMPRESSED DATA C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 C C ABSTRACT: PROCESS COMPRESSED DATA AND PLACE INDIVIDUAL ELEMENTS C INTO OUTPUT ARRAY. C C PROGRAM HISTORY LOG: C 88-09-01 CAVANAUGH C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE C MODIFIED TO HANLE WIDTH OF FIELDS IN BYTES. C 91-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. C THIS HAS BEEN CORRECTED. C 91-06-21 CAVANAUGH PROCESSING OF TEXT DATA HAS BEEN CHANGED TO C PROVIDE EXACT REPRODUCTION OF ALL CHARACTERS. C C USAGE: CALL FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, C MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD) C INPUT ARGUMENT LIST: C IPTR - SEE W3FI78 ROUTINE DOCBLOCK C IDENT - SEE W3FI78 ROUTINE DOCBLOCK C MSGA - ARRAY CONTAINING BUFR MESSAGE,MSTACK, C IVALS - ARRAY OF SINGLE PARAMETER VALUES C J - C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE C CONTAINED IN A BUFR MESSAGE C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. C KDATA(REPORT NUMBER,PARAMETER NUMBER) C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT C ARGUMENT MAXD) C J - C ARRAYS CONTAINING DATA FROM TABLE B C MSCALE - SCALE FOR VALUE OF DESCRIPTOR C MREF - REFERENCE VALUE FOR DESCRIPTOR C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR C C SUBPROGRAMS CALLED: C LIBRARY: C W3LIB - GBYTE GBYTES C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN 77 C MACHINE: CRAY Y-MP8/832 C C$$$ SAVE C INTEGER MSGA(*),JDESC,MSTACK(2,MAXD) INTEGER IPTR(*),IVALS(*),KDATA(MAXR,MAXD) INTEGER NRVALS,JWIDE,IDATA INTEGER IDENT(*) INTEGER MSCALE(*) INTEGER MREF(700,3) INTEGER J INTEGER MWIDTH(*) INTEGER KLOW(256) C LOGICAL TEXT C INTEGER MSK(28) C C DATA MSK /1,3,7,15,31,63,127, C 1 2 3 4 5 6 7 * 255,511,1023,2047,4095, C 8 9 10 11 12 * 8191,16383,32767,65535, C 13 14 15 16 * 131071,262143,524287, C 17 18 19 * 1048575,2097151,4194303, C 20 21 22 * 8388607,16777215,33554431, C 23 24 25 * 67108863,134217727,268435455/ C 26 27 28 C C PRINT *,' FI7803 COMPR J=',J,' MWIDTH(J) =',MWIDTH(J), C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25) IF (IPTR(18).EQ.0) THEN TEXT = .FALSE. ELSE TEXT = .TRUE. END IF C PRINT *,'DESCRIPTOR',KPRM IF (.NOT.TEXT) THEN IF (IPTR(29).GT.0) THEN C WORKING WITH ASSOCIATED FIELDS HERE IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) C GET LOWEST CALL GBYTE (MSGA,LOWEST,IPTR(25),IPTR(29)) IPTR(25) = IPTR(25) + IPTR(29) C GET NBINC CALL GBYTE (MSGA,NBINC,IPTR(25),6) IPTR(25) = IPTR(25) + 6 C EXTRACT DATA FOR ASSOCIATED FIELD IF (NBINC.GT.0) THEN CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,IPTR(14)) IPTR(25) = IPTR(25) + NBINC * IPTR(14) DO 50 I = 1, IPTR(14) KDATA(I,KPRM) = IVALS(I) + LOWEST IF (KDATA(I,KPRM).GE.MSK(NBINC)) THEN KDATA(I,KPRM) = 999999 END IF 50 CONTINUE ELSE DO 51 I = 1, IPTR(14) IF (LOWEST.GE.MSK(NBINC)) THEN KDATA(I,KPRM) = 999999 ELSE KDATA(I,KPRM) = LOWEST END IF 51 CONTINUE END IF END IF C SET PARAMETER C ISOLATE STANDARD BIT WIDTH JWIDE = MWIDTH(J) + IPTR(26) C SINGLE VALUE FOR LOWEST NRVALS = 1 C LOWEST C PRINT *,'PARAM',KPRM CALL GBYTE (MSGA,LOWEST,IPTR(25),JWIDE) C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25) IPTR(25) = IPTR(25) + JWIDE C ISOLATE COMPRESSED BIT WIDTH CALL GBYTE (MSGA,NBINC,IPTR(25),6) C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25) IF (IPTR(32).EQ.2.AND.IPTR(33).EQ.5) THEN ELSE IF (NBINC.GT.JWIDE) THEN C PRINT *,'FOR DESCRIPTOR',JDESC C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' MWIDTH(J)=', C * MWIDTH(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25) C DO 110 I = 1, KPRM C WRITE (6,111)I,(KDATA(J,I),J=1,6) C 110 CONTINUE 111 FORMAT (1X,5HDATA ,I3,6(2X,I10)) IPTR(1) = 500 C RETURN PRINT *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE', * ' B PLUS WIDTH CHANGES' END IF END IF IPTR(25) = IPTR(25) + 6 C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC C IF TEXT EVENT, PROCESS TEXT C GET COMPRESSED VALUES C PRINT *,'COMPRESSED VALUES - NONTEXT' NRVALS = IDENT(14) IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) IF (NBINC.NE.0) THEN CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,NRVALS) IPTR(25) = IPTR(25) + NBINC * NRVALS C RECALCULATE TO ORIGINAL VALUES DO 100 I = 1, NRVALS C PRINT *,IVALS(I),MSK(NBINC),NBINC IF (IVALS(I).GE.MSK(NBINC)) THEN KDATA(I,KPRM) = 999999 ELSE IF (MREF(J,2).EQ.0) THEN KDATA(I,KPRM) = IVALS(I) + LOWEST + MREF(J,1) ELSE KDATA(I,KPRM) = IVALS(I) + LOWEST + MREF(J,3) END IF END IF 100 CONTINUE C PRINT *,I,JDESC,LOWEST,MREF(J,1),MREF(J,3) ELSE IF (LOWEST.EQ.MSK(MWIDTH(J))) THEN DO 105 I = 1, NRVALS KDATA(I,KPRM) = 999999 105 CONTINUE ELSE IF (MREF(J,2).EQ.0) THEN ICOMB = LOWEST + MREF(J,1) ELSE ICOMB = LOWEST + MREF(J,3) END IF DO 106 I = 1, NRVALS KDATA(I,KPRM) = ICOMB 106 CONTINUE END IF END IF C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25) MSTACK(1,KPRM) = JDESC IF (IPTR(27).NE.0) THEN MSTACK(2,KPRM) = IPTR(27) ELSE MSTACK(2,KPRM) = MSCALE(J) END IF C WRITE (6,80) (DATA(I,KPRM),I=1,10) C 80 FORMAT(2X,10(F10.2,1X)) ELSE IF (TEXT) THEN C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40) C GET LOWEST C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40)) DO 1906 K = 1, IPTR(40) CALL GBYTE (MSGA,KLOW,IPTR(25),8) IPTR(25) = IPTR(25) + 8 IF (KLOW(K).NE.0) THEN IPTR(1) = 27 PRINT *,'NON-ZERO LOWEST ON TEXT DATA' RETURN END IF 1906 CONTINUE C GET NBINC CALL GBYTE (MSGA,NBINC,IPTR(25),6) C PRINT *,'NBINC =',NBINC IPTR(25) = IPTR(25) + 6 IF (NBINC.NE.IPTR(40)) THEN IPTR(1) = 28 PRINT *,'NBINC IS NOT THE NUMBER OF CHARACTERS',NBINC RETURN END IF C FOR NUMBER OF OBSERVATIONS IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) ISTART = KPRM I24 = IPTR(24) DO 1900 N = 1, IDENT(14) KPRM = ISTART IPTR(24) = I24 NBITS = IPTR(40) * 8 1700 CONTINUE C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS IF (NBITS.GT.32) THEN CALL GBYTE (MSGA,IDATA,IPTR(25),32) IPTR(25) = IPTR(25) + 32 NBITS = NBITS - 32 C CONVERTS ASCII TO EBCIDIC C COMMENT OUT IF NOT IBM370 COMPUTER C PRINT *,IDATA C CALL W3AI39 (IDATA,4) MSTACK(1,KPRM) = JDESC MSTACK(2,KPRM) = 0 KDATA(N,KPRM) = IDATA C SET FOR NEXT PART KPRM = KPRM + 1 IPTR(24) = IPTR(24) + 1 C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA 1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,I12) GO TO 1700 ELSE IF (NBITS.GT.0) THEN CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS) IPTR(25) = IPTR(25) + NBITS IBUF = (32 - NBITS) / 8 IF (IBUF.GT.0) THEN DO 1750 MP = 1, IBUF IDATA = IDATA * 256 + 32 1750 CONTINUE END IF C CONVERTS ASCII TO EBCIDIC C COMMENT OUT IF NOT IBM370 COMPUTER C CALL W3AI39 (IDATA,4) MSTACK(1,KPRM) = JDESC MSTACK(2,KPRM) = 0 KDATA(N,KPRM) = IDATA C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS NBITS = 0 END IF C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM) C1800 FORMAT (2X,I4,2X,3A4) 1900 CONTINUE END IF RETURN END C ----------------------------------------------------- SUBROUTINE FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK, * MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI7804 PROCESS SERIAL DATA C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 C C ABSTRACT: PROCESS DATA THAT IS NOT COMPRESSED C C PROGRAM HISTORY LOG: C 88-09-01 CAVANAUGH C 91-01-18 CAVANAUGH MODIFIED TO PROPERLY HANDLE NON-COMPRESSED C DATA. C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE C MODIFIED TO HANDLE FIELD WIDTH IN BYTES. C 91-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. C THIS HAS BEEN CORRECTED. C C USAGE: CALL FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK, C MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD) C INPUT ARGUMENT LIST: C IPTR - SEE W3FI78 ROUTINE DOCBLOCK C MSGA - ARRAY CONTAINING BUFR MESSAGE C IVALS - ARRAY OF SINGLE PARAMETER VALUES C J - C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE C CONTAINED IN A BUFR MESSAGE C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. C KDATA(REPORT NUMBER,PARAMETER NUMBER) C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT C ARGUMENT MAXD) C IVALS - SEE ABOVE C J - SEE ABOVE C ARRAYS CONTAINING DATA FROM TABLE B C MSCALE - SCALE FOR VALUE OF DESCRIPTOR C MREF - REFERENCE VALUE FOR DESCRIPTOR C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR C C SUBPROGRAMS CALLED: C LIBRARY: C W3LIB - GBYTE C C REMARKS: ERROR RETURN: C IPTR(1) = 13 - BIT WIDTH ON ASCII CHARS NOT A MULTIPLE OF 8 C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN 77 C MACHINE: CRAY Y-MP8/832 C C$$$ SAVE C INTEGER MSGA(*) INTEGER IPTR(*),MREF(700,3),MSCALE(*) INTEGER MWIDTH(*),JDESC INTEGER IVALS(*) INTEGER LSTBLK(3) INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD) INTEGER J,LL LOGICAL LKEY C C INTEGER ITEST(30) DATA ITEST /1,3,7,15,31,63,127,255, * 511,1023,2047,4095,8191,16383, * 32767, 65535,131071,262143,524287, * 1048575,2097151,4194303,8388607, * 16777215,33554431,67108863,134217727, * 268435455,536870911,1073741823/ C C PRINT *,' FI7804 NOCMP',J,JDESC,MWIDTH(J),IPTR(26),IPTR(25) IF ((IPTR(26)+MWIDTH(J)).LT.1) THEN IPTR(1) = 501 RETURN END IF C -------- NOCMP -------- C ISOLATE BIT WIDTH JWIDE = MWIDTH(J) + IPTR(26) C IF NOT TEXT EVENT, PROCESS IF (IPTR(18).NE.1) THEN C IF ASSOCIATED FIELD SW ON IF (IPTR(29).GT.0) THEN IF (JDESC.NE.7957.AND.JDESC.NE.7937) THEN IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) MSTACK(1,KPRM) = 33792 + IPTR(29) MSTACK(2,KPRM) = 0 CALL GBYTE (MSGA,IVALS,IPTR(25),IPTR(29)) IPTR(25) = IPTR(25) + IPTR(29) KDATA(IPTR(17),KPRM) = IVALS(1) C PRINT *,'FI7804-A',KPRM,MSTACK(1,KPRM), C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM) END IF END IF IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) MSTACK(1,KPRM) = JDESC IF (IPTR(27).NE.0) THEN MSTACK(2,KPRM) = IPTR(27) ELSE MSTACK(2,KPRM) = MSCALE(J) END IF C GET VALUES C CALL TO GET DATA OF GIVEN BIT WIDTH CALL GBYTE (MSGA,IVALS,IPTR(25),JWIDE) C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25) IPTR(25) = IPTR(25) + JWIDE C RETURN WITH SINGLE VALUE IF (IVALS(1).EQ.ITEST(JWIDE)) THEN KDATA(IPTR(17),KPRM) = 999999 ELSE IF (MREF(J,2).EQ.0) THEN KDATA(IPTR(17),KPRM) = IVALS(1) + MREF(J,1) ELSE KDATA(IPTR(17),KPRM) = IVALS(1) + MREF(J,3) END IF END IF C PRINT *,'FI7804-B',KPRM,MSTACK(1,KPRM), C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM) C IF(JDESC.EQ.2049) THEN C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM) C END IF C PRINT *,'FI7804 ',KPRM,MSTACK(1,KPRM), C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) ELSE C IF TEXT EVENT, PROCESS TEXT C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********' NRCHRS = IPTR(40) NRBITS = NRCHRS * 8 C PRINT *,'CHARS =',NRCHRS,' BITS =',NRBITS IPTR(31) = IPTR(31) + 1 KANY = 0 1800 CONTINUE KANY = KANY + 1 IF (NRBITS.GT.32) THEN CALL GBYTE (MSGA,IDATA,IPTR(25),32) C PRINT 1801,KANY,IDATA,IPTR(17),KPRM C1801 FORMAT (1X,I2,4X,Z8,2(4X,I4)) C CONVERTS ASCII TO EBCIDIC C COMMENT OUT IF NOT IBM370 COMPUTER C CALL W3AI39 (IDATA,4) KPRM = IPTR(31) + IPTR(24) KDATA(IPTR(17),KPRM) = IDATA MSTACK(1,KPRM) = JDESC MSTACK(2,KPRM) = 0 C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM), C * KDATA(IPTR(17),KPRM) IPTR(25) = IPTR(25) + 32 NRBITS = NRBITS - 32 IPTR(24) = IPTR(24) + 1 GO TO 1800 ELSE IF (NRBITS.GT.0) THEN C PRINT *,'LAST TEXT WORD' CALL GBYTE (MSGA,IDATA,IPTR(25),NRBITS) IPTR(25) = IPTR(25) + NRBITS C CONVERTS ASCII TO EBCIDIC C COMMENT OUT IF NOT IBM370 COMPUTER C CALL W3AI39 (IDATA,4) KPRM = IPTR(31) + IPTR(24) KSHFT = 32 - NRBITS IF (KSHFT.GT.0) THEN KTRY = KSHFT / 8 DO 1722 LAK = 1, KTRY IDATA = IDATA * 256 + 64 C PRINT 1723,IDATA 1723 FORMAT (12X,Z8) 1722 CONTINUE END IF KDATA(IPTR(17),KPRM) = IDATA C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM MSTACK(1,KPRM) = JDESC MSTACK(2,KPRM) = 0 C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM), C * KDATA(IPTR(17),KPRM) END IF C TURN OFF TEXT IPTR(18) = 0 END IF RETURN END C ----------------------------------------------------- SUBROUTINE FI7805(IPTR,IDENT,MSGA,IWORK,LX,LY, * KDATA,LL,KNR,MSTACK,MAXR,MAXD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI7805 PROCESS A REPLICATION DESCRIPTOR C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 C C ABSTRACT: PROCESS A REPLICATION DESCRIPTOR, MUST EXTRACT NUMBER C OF REPLICATIONS OF N DESCRIPTORS FROM THE DATA STREAM. C C PROGRAM HISTORY LOG: C 88-09-01 CAVANAUGH C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE C C USAGE: CALL FI7805(IPTR,IDENT,MSGA,IWORK,LX,LY, C * KDATA,LL,KNR,MSTACK,MAXR,MAXD) C INPUT ARGUMENT LIST: C IWORK - WORKING DESCRIPTOR LIST C IPTR - SEE W3FI78 ROUTINE DOCBLOCK C IDENT - SEE W3FI78 ROUTINE DOCBLOCK C LX - X PORTION OF CURRENT DESCRIPTOR C LY - Y PORTION OF CURRENT DESCRIPTOR C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE C CONTAINED IN A BUFR MESSAGE C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. C KDATA(REPORT NUMBER,PARAMETER NUMBER) C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT C ARGUMENT MAXD) C LX - SEE ABOVE C LY - SEE ABOVE C C SUBPROGRAMS CALLED: C LIBRARY: C W3LIB - GBYTES FI7808 C C REMARKS: ERROR RETURN: C IPTR(1) = 12 DATA DESCRIPTOR QUALIFIER DOES NOT FOLLOW C DELAYED REPLICATION DESCRIPTOR C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN 77 C MACHINE: CRAY Y-MP8/832 C C$$$ SAVE C INTEGER IPTR(*) INTEGER KNR(MAXR) INTEGER ITEMP(2000) INTEGER LL INTEGER KTEMP(2000) INTEGER KDATA(MAXR,MAXD) INTEGER LX,MSTACK(2,MAXD) INTEGER LY INTEGER MSGA(*) INTEGER KVALS(1000) INTEGER IWORK(MAXD) INTEGER IDENT(*) C C PRINT *,' REPLICATION FI7805' C DO 100 I = 1, IPTR(13) C PRINT *,I,IWORK(I) C 100 CONTINUE C NUMBER OF DESCRIPTORS NRSET = LX C NUMBER OF REPLICATIONS NRREPS = LY ICURR = IPTR(11) - 1 IPICK = IPTR(11) - 1 C IF (NRREPS.EQ.0) THEN IPTR(39) = 1 C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR C IPTR(31) = IPTR(31) + 1 C KPRM = IPTR(31) + IPTR(24) C MSTACK(1,KPRM) = JDESC C MSTACK(2,KPRM) = 0 C KDATA(IPTR(17),KPRM) = 0 C PRINT *,'FI7805-1',KPRM,MSTACK(1,KPRM), C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) C DELAYED REPLICATION - MUST GET NUMBER OF C REPLICATIONS FROM DATA. C GET NEXT DESCRIPTOR CALL FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD) C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC C MUST BE DATA DESCRIPTION C OPERATION QUALIFIER IF (JDESC.EQ.7937.OR.JDESC.EQ.7947) THEN JWIDE = 8 ELSE IF (JDESC.EQ.7938.OR.JDESC.EQ.7948) THEN JWIDE = 16 ELSE IPTR(1) = 12 RETURN END IF C SET SINGLE VALUE FOR SEQUENTIAL, C MULTIPLE VALUES FOR COMPRESSED IF (IDENT(16).EQ.0) THEN C NON COMPRESSED CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE) C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1) IPTR(25) = IPTR(25) + JWIDE IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) MSTACK(1,KPRM) = JDESC MSTACK(2,KPRM) = 0 KDATA(IPTR(17),KPRM) = KVALS(1) NRREPS = KVALS(1) C PRINT *,'FI7805-2',KPRM,MSTACK(1,KPRM), C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) ELSE NRVALS = IDENT(14) CALL GBYTES (MSGA,KVALS,IPTR(25),JWIDE,0,NRVALS) IPTR(25) = IPTR(25) + JWIDE * NRVALS IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) MSTACK(1,KPRM) = JDESC MSTACK(2,KPRM) = 0 KDATA(IPTR(17),KPRM) = KVALS(1) DO 100 I = 1, NRVALS KDATA(I,KPRM) = KVALS(I) 100 CONTINUE NRREPS = KVALS(1) END IF ELSE C PRINT *,'NOT DELAYED REPLICATION' END IF C RESTRUCTURE WORKING STACK W/REPLICATIONS C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS' C PICK UP DESCRIPTORS TO BE REPLICATED DO 1000 I = 1, NRSET CALL FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD) ITEMP(I) = JDESC C PRINT *,'REPLICATION ',I,ITEMP(I) 1000 CONTINUE C MOVE TRAILING DESCRIPTORS TO HOLD AREA LAX = IPTR(12) - IPTR(11) + 1 C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12) DO 2000 I = 1, LAX CALL FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD) KTEMP(I) = JDESC C PRINT *,' ',I,KTEMP(I) 2000 CONTINUE C REPLICATIONS INTO ISTACK C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES' C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR DO 4000 I = 1, NRREPS DO 3000 J = 1, NRSET IWORK(ICURR) = ITEMP(J) C PRINT *,'FI7805 A',ICURR,IWORK(ICURR) ICURR = ICURR + 1 3000 CONTINUE 4000 CONTINUE C PRINT *,' TO LOC',ICURR-1 C RESTORE TRAILING DESCRIPTORS C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR DO 5000 I = 1, LAX IWORK(ICURR) = KTEMP(I) C PRINT *,'FI7805 B',ICURR,IWORK(ICURR) ICURR = ICURR + 1 5000 CONTINUE IPTR(12) = ICURR - 1 IPTR(11) = IPICK RETURN END SUBROUTINE FI7806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC,MAXR,MAXD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI7806 PROCESS OPERATOR DESCRIPTORS C PRGMMR: CAVANAUGH ORG: W/NMCX42 DATE: 88-09-01 C C ABSTRACT: EXTRACT AND SAVE INDICATED CHANGE VALUES FOR USE C UNTIL CHANGES ARE RESCINDED, OR EXTRACT TEXT STRINGS INDICATED C THROUGH 2 05 YYY. C C PROGRAM HISTORY LOG: C 88-09-01 CAVANAUGH C 91-04-04 CAVANAUGH MODIFIED TO HANDLE DESCRIPTOR 2 05 YYY C 91-05-10 CAVANAUGH CODING HAS BEEN ADDED TO PROCESS PROPOSED C TABLE C DESCRIPTOR 2 06 YYY. C 91-11-21 CAVANAUGH CODING HAS BEEN ADDED TO PROPERLY PROCESS C TABLE C DESCRIPTOR 2 03 YYY, THE CHANGE C TO NEW REFERENCE VALUE FOR SELECTED C DESCRIPTORS. C C USAGE: CALL FI7806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, C * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC,MAXR,MAXD) C INPUT ARGUMENT LIST: C IPTR - SEE W3FI78 ROUTINE DOCBLOCK C LX - X PORTION OF CURRENT DESCRIPTOR C LY - Y PORTION OF CURRENT DESCRIPTOR C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE C CONTAINED IN A BUFR MESSAGE C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE C C OUTPUT ARGUMENT LIST: C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. C KDATA(REPORT NUMBER,PARAMETER NUMBER) C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT C ARGUMENT MAXD) C ARRAYS CONTAINING DATA FROM TABLE B C MSCALE - SCALE FOR VALUE OF DESCRIPTOR C MREF - REFERENCE VALUE FOR DESCRIPTOR C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR C C REMARKS: ERROR RETURN: C IPTR(1) = 5 - ERRONEOUS X VALUE IN DATA DESCRIPTOR OPERATOR C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN 77 C MACHINE: CRAY Y-MP8/832 C C$$$ SAVE INTEGER IPTR(*),KDATA(MAXR,MAXD),IVALS(*) INTEGER IDENT(*),IWORK(*) INTEGER MSGA(*),MSTACK(2,MAXD) INTEGER MREF(700,3),KDESC(*) INTEGER MSCALE(*),MWIDTH(*) INTEGER J,JDESC INTEGER LL INTEGER LX INTEGER LY C C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR' IF (LX.EQ.1) THEN C CHANGE BIT WIDTH IF (LY.EQ.0) THEN C PRINT *,' RETURN TO NORMAL WIDTH' IPTR(26) = 0 ELSE C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS' IPTR(26) = LY - 128 END IF ELSE IF (LX.EQ.2) THEN C CHANGE SCALE IF (LY.EQ.0) THEN C RESET TO STANDARD SCALE IPTR(27) = 0 ELSE C SET NEW SCALE IPTR(27) = LY - 128 END IF ELSE IF (LX.EQ.3) THEN C CHANGE REFERENCE VALUE C FOR EACH OF THOSE DESCRIPTORS BETWEEN C 2 03 YYY WHERE Y LT 255 AND C 2 03 255, EXTRACT THE NEW REFERENCE C VALUE (BIT WIDTH YYY) AND PLACE C IN TERTIARY TABLE B REF VAL POSITION, C SET FLAG IN SECONDARY REFVAL POSITION C THOSE DESCRIPTORS DO NOT HAVE DATA C ASSOCIATED WITH THEM, BUT ONLY C IDENTIFY THE TABLE B ENTRIES THAT C ARE GETTING NEW REFERENCE VALUES. KYYY = LY IF (KYYY.GT.0.AND.KYYY.LT.255) THEN C START CYCLING THRU DESCRIPTORS UNTIL C TERMINATE NEW REF VALS IS FOUND 300 CONTINUE CALL FI7808 (IPTR,IWORK,LF,LX,LY,JDESC,MAXD) IF (JDESC.EQ.33791) THEN C IF 2 03 255 THEN RETURN RETURN ELSE C FIND MATCHING TABLE B ENTRY DO 500 LJ = 1, IPTR(14) IF (JDESC.EQ.KDESC(LJ)) THEN C TURN ON NEW REF VAL FLAG MREF(LJ,2) = 1 C INSERT NEW REF VAL CALL GBYTE (MSGA,MREF(LJ,3),IPTR(25),KYYY) C GO GET NEXT DESCRIPTOR GO TO 300 END IF 500 CONTINUE C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR PRINT *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND' STOP 203 END IF ELSE IF (KYYY.EQ.0) THEN C MUST TURN OFF ALL NEW C REFERENCE VALUES DO 400 I = 1, IPTR(14) MREF(I,2) = 0 400 CONTINUE END IF C LX = 3 C MUST BE CONCLUDED WITH Y=255 ELSE IF (LX.EQ.4) THEN C ASSOCIATED VALUES IF (LY.EQ.0) THEN IPTR(29) = 0 C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29) ELSE IPTR(29) = LY IF (IWORK(IPTR(11)).NE.7957) THEN PRINT *,'2 04 YYY NOT FOLLOWED BY 0 31 021' IPTR(1) = 11 END IF C PRINT *,'SET ASSOCIATED VALUES',IPTR(29) END IF ELSE IF (LX.EQ.5) THEN C PROCESS TEXT DATA IPTR(40) = LY IPTR(18) = 1 IF (IDENT(16).EQ.0) THEN C PRINT *,'2 05 YYY - TEXT - NONCOMPRESSED MODE' CALL FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK, * MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD) ELSE C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE' CALL FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, * MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD) IF (IPTR(1).NE.0) THEN RETURN END IF ENDIF IPTR(18) = 0 ELSE IF (LX.EQ.6) THEN C SKIP NEXT DESCRIPTOR C SET TO PASS OVER DESCRIPTOR AND DATA C IF DESCRIPTOR NOT IN TABLE B IPTR(36) = LY C PRINT *,'SET TO SKIP',LY,' BIT FIELD' IPTR(31) = IPTR(31) + 1 KPRM = IPTR(31) + IPTR(24) MSTACK(1,KPRM) = 34304 + LY MSTACK(2,KPRM) = 0 ELSE IPTR(1) = 5 ENDIF RETURN END SUBROUTINE FI7807(IPTR,IWORK,ITBLD,JDESC,MAXD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI7807 PROCESS QUEUE DESCRIPTOR C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 C C ABSTRACT: SUBSTITUTE DESCRIPTOR QUEUE FOR QUEUE DESCRIPTOR C C PROGRAM HISTORY LOG: C 88-09-01 CAVANAUGH C 91-04-17 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS C 91-05-28 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS C BASED ON TESTS WITH LIVE DATA. C C USAGE: CALL FI7807(IPTR,IWORK,ITBLD,JDESC,MAXD) C INPUT ARGUMENT LIST: C IWORK - WORKING DESCRIPTOR LIST C IPTR - SEE W3FI78 ROUTINE DOCBLOCK C LAST - INDEX TO LAST DESCRIPTOR C ITBLD - ARRAY CONTAINING DESCRIPTOR QUEUES C JDESC - QUEUE DESCRIPTOR TO BE EXPANDED C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C ISTACK - SEE ABOVE C C SUBPROGRAMS CALLED: C LIBRARY: C W3LIB - NONE C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN 77 C MACHINE: CRAY Y-MP8/832 C C$$$ SAVE C INTEGER IPTR(*),JDESC INTEGER IWORK(*),IHOLD(2000) INTEGER ITBLD(500,11) C C PRINT *,' FI7807 F3 ENTRY',IPTR(11),IPTR(12) C SET FOR BINARY SEARCH IN TABLE D C DO 2020 I = 1, IPTR(12) C PRINT *,'ENTRY IWORK',I,IWORK(I) C2020 CONTINUE JLO = 1 JHI = IPTR(20) C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC 10 CONTINUE JMID = (JLO + JHI) / 2 C PRINT *,JLO,ITBLD(JLO,1),JMID,ITBLD(JMID,1),JHI,ITBLD(JHI,1) C IF (JDESC.LT.ITBLD(JMID,1)) THEN IF (JDESC.EQ.ITBLD(JLO,1)) THEN JMID = JLO GO TO 100 ELSE JLO = JLO + 1 JHI = JMID - 1 IF (JLO.GT.JMID) THEN IPTR(1) = 4 RETURN END IF GO TO 10 END IF ELSE IF (JDESC.GT.ITBLD(JMID,1)) THEN IF (JDESC.EQ.ITBLD(JHI,1)) THEN JMID = JHI GO TO 100 ELSE JLO = JMID + 1 JHI = JHI - 1 IF (JLO.GT.JHI) THEN IPTR(1) = 4 RETURN END IF GO TO 10 END IF END IF 100 CONTINUE C HAVE TABLE D MATCH C PRINT *,'D ',(ITBLD(JMID,LL),LL=1,11) C PRINT *,'TABLE D TO IHOLD' IK = 0 JK = 0 DO 200 KI = 2, 11 IF (ITBLD(JMID,KI).NE.0) THEN IK = IK + 1 IHOLD(IK) = ITBLD(JMID,KI) C PRINT *,IK,IHOLD(IK) ELSE GO TO 300 END IF 200 CONTINUE 300 CONTINUE KK = IPTR(11) IF (KK.GT.IPTR(12)) THEN C NOTHING MORE TO APPEND C PRINT *,'NOTHING MORE TO APPEND' ELSE C APPEND TRAILING IWORK TO IHOLD C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12) DO 500 I = KK, IPTR(12) IK = IK + 1 IHOLD(IK) = IWORK(I) 500 CONTINUE END IF C RESET IHOLD TO IWORK C PRINT *,' RESET IWORK STACK' KK = IPTR(11) - 2 DO 1000 I = 1, IK KK = KK + 1 IWORK(KK) = IHOLD(I) 1000 CONTINUE IPTR(12) = KK C PRINT *,' FI7807 F3 EXIT ',IPTR(11),IPTR(12) C DO 2000 I = 1, IPTR(12) C PRINT *,'EXIT IWORK',I,IWORK(I) C2000 CONTINUE C RESET POINTERS IPTR(11) = IPTR(11) - 1 RETURN END C ----------------------------------------------------- SUBROUTINE FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI7808 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 89-01-17 C C ABSTRACT: C C PROGRAM HISTORY LOG: C 88-09-01 CAVANAUGH C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE C C USAGE: CALL FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD) C INPUT ARGUMENT LIST: C IPTR - SEE W3FI78 ROUTINE DOCBLOCK C IWORK - WORKING DESCRIPTOR LIST C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C IPTR - SEE ABOVE C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN 77 C MACHINE: CRAY Y-MP8/832 C C$$$ SAVE INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC C C PRINT *,' FI7808 NEW DESCRIPTOR PICKUP' JDESC = IWORK(IPTR(11)) LY = MOD(JDESC,256) IPTR(34) = LY LX = MOD((JDESC/256),64) IPTR(33) = LX LF = JDESC / 16384 IPTR(32) = LF C PRINT *,' CURRENT DESCRIPTOR BEING TESTED IS',LF,LX,LY IPTR(11) = IPTR(11) + 1 RETURN END SUBROUTINE FI7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI7809 REFORMAT PROFILER W HGT INCREMENTS C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 90-02-14 C C ABSTRACT: REFORMAT DECODED PROFILER DATA TO SHOW HEIGHTS INSTEAD OF C HEIGHT INCREMENTS. C C PROGRAM HISTORY LOG: C 90-02-14 CAVANAUGH C C USAGE: CALL FI7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) C INPUT ARGUMENT LIST: C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM C BUFR MESSAGE - C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) C IDENT( 4)- (BYTE 8, SECTION 1) C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) C IDENT( 7)- (BYTES 11-12, SECTION 1) C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. C KDATA(REPORT NUMBER,PARAMETER NUMBER) C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT C ARGUMENT MAXD) C KSET2 - INTERIM DATA ARRAY C KPROFL - INTERIM DESCRIPTOR ARRAY C IPTR - SEE W3FI78 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE C CONTAINED IN A BUFR MESSAGE C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE C C OUTPUT FILES: C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN 77 C MACHINE: CRAY Y-MP8/832 C C$$$ SAVE C ---------------------------------------------------------------- C INTEGER ISW INTEGER IDENT(*),KDATA(MAXR,MAXD) INTEGER MSTACK(2,MAXD),IPTR(*) INTEGER KPROFL(1600) INTEGER KPROF2(1600) INTEGER KSET2(1600) C C ---------------------------------------------------------- C PRINT *,'FI7809' C LOOP FOR NUMBER OF SUBSETS/REPORTS DO 3000 I = 1, IDENT(14) C INIT FOR DATA INPUT ARRAY MK = 1 C INIT FOR DESC OUTPUT ARRAY JK = 0 C LOCATION ISW = 0 DO 200 J = 1, 3 C LATITUDE IF (MSTACK(1,MK).EQ.1282) THEN ISW = ISW + 1 GO TO 100 C LONGITUDE ELSE IF (MSTACK(1,MK).EQ.1538) THEN ISW = ISW + 2 GO TO 100 C HEIGHT ABOVE SEA LEVEL ELSE IF (MSTACK(1,MK).EQ.1793) THEN IHGT = KDATA(I,MK) ISW = ISW + 4 GO TO 100 END IF GO TO 200 100 CONTINUE JK = JK + 1 C SAVE DESCRIPTOR KPROFL(JK) = MSTACK(1,MK) C SAVE SCALE KPROF2(JK) = MSTACK(2,MK) C SAVE DATA KSET2(JK) = KDATA(I,MK) MK = MK + 1 200 CONTINUE IF (ISW.NE.7) THEN PRINT *,'LOCATION ERROR PROCESSING PROFILER' IPTR(1) = 200 RETURN END IF C TIME ISW = 0 DO 400 J = 1, 7 C YEAR IF (MSTACK(1,MK).EQ.1025) THEN ISW = ISW + 1 GO TO 300 C MONTH ELSE IF (MSTACK(1,MK).EQ.1026) THEN ISW = ISW + 2 GO TO 300 C DAY ELSE IF (MSTACK(1,MK).EQ.1027) THEN ISW = ISW + 4 GO TO 300 C HOUR ELSE IF (MSTACK(1,MK).EQ.1028) THEN ISW = ISW + 8 GO TO 300 C MINUTE ELSE IF (MSTACK(1,MK).EQ.1029) THEN ISW = ISW + 16 GO TO 300 C TIME SIGNIFICANCE ELSE IF (MSTACK(1,MK).EQ.2069) THEN ISW = ISW + 32 GO TO 300 ELSE IF (MSTACK(1,MK).EQ.1049) THEN ISW = ISW + 64 GO TO 300 END IF GO TO 400 300 CONTINUE JK = JK + 1 C SAVE DESCRIPTOR KPROFL(JK) = MSTACK(1,MK) C SAVE SCALE KPROF2(JK) = MSTACK(2,MK) C SAVE DATA KSET2(JK) = KDATA(I,MK) MK = MK + 1 400 CONTINUE IF (ISW.NE.127) THEN PRINT *,'TIME ERROR PROCESSING PROFILER',ISW IPTR(1) = 201 RETURN END IF C SURFACE DATA KRG = 0 ISW = 0 DO 600 J = 1, 10 C WIND SPEED IF (MSTACK(1,MK).EQ.2818) THEN ISW = ISW + 1 GO TO 500 C WIND DIRECTION ELSE IF (MSTACK(1,MK).EQ.2817) THEN ISW = ISW + 2 GO TO 500 C PRESS REDUCED TO MSL ELSE IF (MSTACK(1,MK).EQ.2611) THEN ISW = ISW + 4 GO TO 500 C TEMPERATURE ELSE IF (MSTACK(1,MK).EQ.3073) THEN ISW = ISW + 8 GO TO 500 C RAINFALL RATE ELSE IF (MSTACK(1,MK).EQ.3342) THEN ISW = ISW + 16 GO TO 500 C RELATIVE HUMIDITY ELSE IF (MSTACK(1,MK).EQ.3331) THEN ISW = ISW + 32 GO TO 500 C 1ST RANGE GATE OFFSET ELSE IF (MSTACK(1,MK).EQ.1982.OR. * MSTACK(1,MK).EQ.1983) THEN C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE C VALUE FOR LATER USE IF (MSTACK(1,MK).EQ.1983) THEN IHGT = KDATA(I,MK) MK = MK + 1 KRG = 1 ELSE IF (KRG.EQ.0) THEN INCRHT = KDATA(I,MK) MK = MK + 1 KRG = 1 C PRINT *,'INITIAL INCR =',INCRHT ELSE LHGT = 500 + IHGT - KDATA(I,MK) ISW = ISW + 64 C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT END IF END IF C MODE #1 ELSE IF (MSTACK(1,MK).EQ.8128) THEN ISW = ISW + 128 GO TO 500 C MODE #2 ELSE IF (MSTACK(1,MK).EQ.8129) THEN ISW = ISW + 256 GO TO 500 END IF GO TO 600 500 CONTINUE C SAVE DESCRIPTOR JK = JK + 1 KPROFL(JK) = MSTACK(1,MK) C SAVE SCALE KPROF2(JK) = MSTACK(2,MK) C SAVE DATA KSET2(JK) = KDATA(I,MK) C IF (I.EQ.1) THEN C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) C END IF MK = MK + 1 600 CONTINUE 650 CONTINUE IF (ISW.NE.511) THEN PRINT *,'SURFACE ERROR PROCESSING PROFILER',ISW IPTR(1) = 202 RETURN END IF C 43 LEVELS DO 2000 L = 1, 43 2020 CONTINUE ISW = 0 C HEIGHT INCREMENT IF (MSTACK(1,MK).EQ.1982) THEN C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK) INCRHT = KDATA(I,MK) MK = MK + 1 IF (LHGT.LT.(9250+IHGT)) THEN LHGT = IHGT + 500 - INCRHT ELSE LHGT = IHGT + 9250 - INCRHT END IF END IF C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE LHGT = LHGT + INCRHT C PRINT *,'LEVEL ',L,LHGT IF (L.EQ.37) THEN LHGT = LHGT + INCRHT END IF JK = JK + 1 C SAVE DESCRIPTOR KPROFL(JK) = 1798 C SAVE SCALE KPROF2(JK) = 0 C SAVE DATA KSET2(JK) = LHGT C IF (I.EQ.10) THEN C PRINT *,' ' C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK) C END IF ISW = 0 DO 800 J = 1, 9 750 CONTINUE IF (MSTACK(1,MK).EQ.1982) THEN GO TO 2020 C U VECTOR VALUE ELSE IF (MSTACK(1,MK).EQ.3008) THEN ISW = ISW + 1 IF (KDATA(I,MK).GE.2047) THEN VECTU = 32767 ELSE VECTU = KDATA(I,MK) END IF MK = MK + 1 GO TO 800 C V VECTOR VALUE ELSE IF (MSTACK(1,MK).EQ.3009) THEN ISW = ISW + 2 IF (KDATA(I,MK).GE.2047) THEN VECTV = 32767 ELSE VECTV = KDATA(I,MK) END IF MK = MK + 1 C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF C DESCRIPTORS AND DATA IF (IAND(ISW,1).NE.0) THEN IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN C SAVE DD DESCRIPTOR JK = JK + 1 KPROFL(JK) = 2817 C SAVE SCALE KPROF2(JK) = 0 C SAVE DD DATA KSET2(JK) = 32767 C SAVE FFF DESCRIPTOR JK = JK + 1 KPROFL(JK) = 2818 C SAVE SCALE KPROF2(JK) = 1 C SAVE FFF DATA KSET2(JK) = 32767 ELSE C GENERATE DDFFF CALL W3FC05 (VECTU,VECTV,DIR,SPD) NDIR = DIR SPD = SPD NSPD = SPD C PRINT *,' ',NDIR,NSPD C SAVE DD DESCRIPTOR JK = JK + 1 KPROFL(JK) = 2817 C SAVE SCALE KPROF2(JK) = 0 C SAVE DD DATA KSET2(JK) = DIR C IF (I.EQ.1) THEN C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) C END IF C SAVE FFF DESCRIPTOR JK = JK + 1 KPROFL(JK) = 2818 C SAVE SCALE KPROF2(JK) = 1 C SAVE FFF DATA KSET2(JK) = SPD C IF (I.EQ.1) THEN C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) C END IF END IF END IF GO TO 800 C W VECTOR VALUE ELSE IF (MSTACK(1,MK).EQ.3010) THEN ISW = ISW + 4 GO TO 700 C Q/C TEST RESULTS ELSE IF (MSTACK(1,MK).EQ.8130) THEN ISW = ISW + 8 GO TO 700 C U,V QUALITY IND ELSE IF(IAND(ISW,16).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN ISW = ISW + 16 GO TO 700 C W QUALITY IND ELSE IF(IAND(ISW,32).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN ISW = ISW + 32 GO TO 700 C SPECTRAL PEAK POWER ELSE IF (MSTACK(1,MK).EQ.5568) THEN ISW = ISW + 64 GO TO 700 C U,V VARIABILITY ELSE IF (MSTACK(1,MK).EQ.3011) THEN ISW = ISW + 128 GO TO 700 C W VARIABILITY ELSE IF (MSTACK(1,MK).EQ.3013) THEN ISW = ISW + 256 GO TO 700 ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN MK = MK + 1 GO TO 750 END IF GO TO 800 700 CONTINUE JK = JK + 1 C SAVE DESCRIPTOR KPROFL(JK) = MSTACK(1,MK) C SAVE SCALE KPROF2(JK) = MSTACK(2,MK) C SAVE DATA KSET2(JK) = KDATA(I,MK) MK = MK + 1 C IF (I.EQ.1) THEN C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) C END IF 800 CONTINUE 850 CONTINUE IF (ISW.NE.511) THEN PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW IPTR(1) = 203 RETURN END IF 2000 CONTINUE C MOVE DATA BACK INTO KDATA ARRAY DO 4000 LL = 1, JK KDATA(I,LL) = KSET2(LL) 4000 CONTINUE 3000 CONTINUE C PRINT *,'REBUILT ARRAY' DO 5000 LL = 1, JK C DESCRIPTOR MSTACK(1,LL) = KPROFL(LL) C SCALE MSTACK(2,LL) = KPROF2(LL) C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7) 5000 CONTINUE C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY IPTR(31) = JK RETURN END SUBROUTINE FI7810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI7810 REFORMAT PROFILER EDITION 2 DATA C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-01-21 C C ABSTRACT: REFORMAT PROFILER DATA IN EDITION 2 C C PROGRAM HISTORY LOG: C 93-01-27 CAVANAUGH C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE C C USAGE: CALL FI7810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) C INPUT ARGUMENT LIST: C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM C BUFR MESSAGE - C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) C IDENT( 4)- (BYTE 8, SECTION 1) C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) C IDENT( 7)- (BYTES 11-12, SECTION 1) C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. C KDATA(REPORT NUMBER,PARAMETER NUMBER) C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT C ARGUMENT MAXD) C KSET2 - INTERIM DATA ARRAY C KPROFL - INTERIM DESCRIPTOR ARRAY C IPTR - SEE W3FI78 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE C CONTAINED IN A BUFR MESSAGE C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE C C OUTPUT FILES: C C REMARKS: C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN 77 C MACHINE: CRAY Y-MP8/832 C C$$$ INTEGER ISW INTEGER IDENT(*),KDATA(MAXR,MAXD) INTEGER MSTACK(2,MAXD),IPTR(*) INTEGER KPROFL(1600) INTEGER KPROF2(1600) INTEGER KSET2(1600) C LOOP FOR NUMBER OF SUBSETS DO 3000 I = 1, IDENT(14) MK = 1 JK = 0 ISW = 0 C PRINT *,'IDENTIFICATION' DO 200 J = 1, 5 IF (MSTACK(1,MK).EQ.257) THEN C BLOCK NUMBER ISW = ISW + 1 ELSE IF (MSTACK(1,MK).EQ.258) THEN C STATION NUMBER ISW = ISW + 2 ELSE IF (MSTACK(1,MK).EQ.1282) THEN C LATITUDE ISW = ISW + 4 ELSE IF (MSTACK(1,MK).EQ.1538) THEN C LONGITUDE ISW = ISW + 8 ELSE IF (MSTACK(1,MK).EQ.1793) THEN C HEIGHT OF STATION ISW = ISW + 16 IHGT = KDATA(I,MK) ELSE MK = MK + 1 GO TO 200 END IF JK = JK + 1 KPROFL(JK) = MSTACK(1,MK) KPROF2(JK) = MSTACK(2,MK) KSET2(JK) = KDATA(I,MK) C PRINT *,JK,KPROFL(JK),KSET2(JK) MK = MK + 1 200 CONTINUE C PRINT *,'LOCATION ',ISW IF (ISW.NE.31) THEN PRINT *,'LOCATION ERROR PROCESSING PROFILER' IPTR(10) = 200 RETURN END IF C PROCESS TIME ELEMENTS ISW = 0 DO 400 J = 1, 7 IF (MSTACK(1,MK).EQ.1025) THEN C YEAR ISW = ISW + 1 ELSE IF (MSTACK(1,MK).EQ.1026) THEN C MONTH ISW = ISW + 2 ELSE IF (MSTACK(1,MK).EQ.1027) THEN C DAY ISW = ISW + 4 ELSE IF (MSTACK(1,MK).EQ.1028) THEN C HOUR ISW = ISW + 8 ELSE IF (MSTACK(1,MK).EQ.1029) THEN C MINUTE ISW = ISW + 16 ELSE IF (MSTACK(1,MK).EQ.2069) THEN C TIME SIGNIFICANCE ISW = ISW + 32 ELSE IF (MSTACK(1,MK).EQ.1049) THEN C TIME DISPLACEMENT ISW = ISW + 64 ELSE MK = MK + 1 GO TO 400 END IF JK = JK + 1 KPROFL(JK) = MSTACK(1,MK) KPROF2(JK) = MSTACK(2,MK) KSET2(JK) = KDATA(I,MK) C PRINT *,JK,KPROFL(JK),KSET2(JK) MK = MK + 1 400 CONTINUE C PRINT *,'TIME ',ISW IF (ISW.NE.127) THEN PRINT *,'TIME ERROR PROCESSING PROFILER' IPTR(1) = 201 RETURN END IF C SURFACE DATA ISW = 0 C PRINT *,'SURFACE' DO 600 K = 1, 8 C PRINT *,MK,MSTACK(1,MK),JK,ISW IF (MSTACK(1,MK).EQ.2817) THEN ISW = ISW + 1 ELSE IF (MSTACK(1,MK).EQ.2818) THEN ISW = ISW + 2 ELSE IF (MSTACK(1,MK).EQ.2611) THEN ISW = ISW + 4 ELSE IF (MSTACK(1,MK).EQ.3073) THEN ISW = ISW + 8 ELSE IF (MSTACK(1,MK).EQ.3342) THEN ISW = ISW + 16 ELSE IF (MSTACK(1,MK).EQ.3331) THEN ISW = ISW + 32 ELSE IF (MSTACK(1,MK).EQ.1797) THEN INCRHT = KDATA(I,MK) ISW = ISW + 64 C PRINT *,'INITIAL INCREMENT = ',INCRHT MK = MK + 1 C PRINT *,JK,KPROFL(JK),KSET2(JK),' ISW=',ISW GO TO 600 ELSE IF (MSTACK(1,MK).EQ.6433) THEN ISW = ISW + 128 END IF JK = JK + 1 KPROFL(JK) = MSTACK(1,MK) KPROF2(JK) = MSTACK(2,MK) KSET2(JK) = KDATA(I,MK) C PRINT *,JK,KPROFL(JK),KSET2(JK),'ISW=',ISW MK = MK + 1 600 CONTINUE IF (ISW.NE.255) THEN PRINT *,'ERROR PROCESSING PROFILER',ISW IPTR(1) = 204 RETURN END IF IF (MSTACK(1,MK).NE.1797) THEN PRINT *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER' IPTR(1) = 205 RETURN END IF C MUST SAVE THIS HEIGHT VALUE LHGT = 500 + IHGT - KDATA(I,MK) C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT MK = MK + 1 IF (MSTACK(1,MK).GE.16384) THEN MK = MK + 1 END IF C PROCESS LEVEL DATA C PRINT *,'LEVEL DATA' DO 2000 L = 1, 43 2020 CONTINUE C PRINT *,'DESC',MK,MSTACK(1,MK),JK ISW = 0 C HEIGHT INCREMENT IF (MSTACK(1,MK).EQ.1797) THEN INCRHT = KDATA(I,MK) C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT MK = MK + 1 IF (LHGT.LT.(9250+IHGT)) THEN LHGT = IHGT + 500 - INCRHT ELSE LHGT = IHGT + 9250 -INCRHT END IF END IF C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA C AT THIS POINT LHGT = LHGT + INCRHT C PRINT *,'LEVEL ',L,LHGT IF (L.EQ.37) THEN LHGT = LHGT + INCRHT END IF JK = JK + 1 C SAVE DESCRIPTOR KPROFL(JK) = 1798 C SAVE SCALE KPROF2(JK) = 0 C SAVE DATA KSET2(JK) = LHGT C PRINT *,KPROFL(JK),KSET2(JK),JK ISW = 0 ICON = 1 DO 800 J = 1, 10 750 CONTINUE IF (MSTACK(1,MK).EQ.1797) THEN GO TO 2020 ELSE IF (MSTACK(1,MK).EQ.6432) THEN C HI/LO MODE ISW = ISW + 1 ELSE IF (MSTACK(1,MK).EQ.6434) THEN C Q/C TEST ISW = ISW + 2 ELSE IF (MSTACK(1,MK).EQ.2070) THEN IF (ICON.EQ.1) THEN C FIRST PASS - U,V CONSENSUS ISW = ISW + 4 ICON = ICON + 1 ELSE C SECOND PASS - W CONSENSUS ISW = ISW + 64 END IF ELSE IF (MSTACK(1,MK).EQ.2819) THEN C U VECTOR VALUE ISW = ISW + 8 IF (KDATA(I,MK).GE.2047) THEN VECTU = 32767 ELSE VECTU = KDATA(I,MK) END IF MK = MK + 1 GO TO 800 ELSE IF (MSTACK(1,MK).EQ.2820) THEN C V VECTOR VALUE ISW = ISW + 16 IF (KDATA(I,MK).GE.2047) THEN VECTV = 32767 ELSE VECTV = KDATA(I,MK) END IF IF (IAND(ISW,1).NE.0) THEN IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN C SAVE DD DESCRIPTOR JK = JK + 1 KPROFL(JK) = 2817 KPROF2(JK) = 0 KSET2(JK) = 32767 C SAVE FFF DESCRIPTOR JK = JK + 1 KPROFL(JK) = 2818 KPROF2(JK) = 1 KSET2(JK) = 32767 ELSE CALL W3FC05 (VECTU,VECTV,DIR,SPD) NDIR = DIR SPD = SPD NSPD = SPD C PRINT *,' ',NDIR,NSPD C SAVE DD DESCRIPTOR JK = JK + 1 KPROFL(JK) = 2817 KPROF2(JK) = 0 KSET2(JK) = NDIR C IF (I.EQ.1) THEN C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) C ENDIF C SAVE FFF DESCRIPTOR JK = JK + 1 KPROFL(JK) = 2818 KPROF2(JK) = 1 KSET2(JK) = NSPD C IF (I.EQ.1) THEN C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) C ENDIF END IF MK = MK + 1 GO TO 800 END IF ELSE IF (MSTACK(1,MK).EQ.2866) THEN C SPEED STD DEVIATION ISW = ISW + 32 C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568 ELSE IF (MSTACK(1,MK).EQ.5568) THEN C SIGNAL POWER ISW = ISW + 128 ELSE IF (MSTACK(1,MK).EQ.2822) THEN C W COMPONENT ISW = ISW + 256 ELSE IF (MSTACK(1,MK).EQ.2867) THEN C VERT STD DEVIATION ISW = ISW + 512 ELSE MK = MK + 1 GO TO 750 END IF JK = JK + 1 C SAVE DESCRIPTOR KPROFL(JK) = MSTACK(1,MK) C SAVE SCALE KPROF2(JK) = MSTACK(2,MK) C SAVE DATA KSET2(JK) = KDATA(I,MK) MK = MK + 1 C PRINT *,L,'TEST ',JK,KPROFL(JK),KSET2(JK) 800 CONTINUE 850 CONTINUE IF (ISW.NE.1023) THEN PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW IPTR(1) = 202 RETURN END IF 2000 CONTINUE C MOVE DATA BACK INTO KDATA ARRAY DO 5000 LL = 1, JK C DATA KDATA(I,LL) = KSET2(LL) 5000 CONTINUE 3000 CONTINUE DO 5005 LL = 1, JK C DESCRIPTOR MSTACK(1,LL) = KPROFL(LL) C SCALE MSTACK(2,LL) = KPROF2(LL) C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4) 5005 CONTINUE IPTR(31) = JK RETURN END