SUBROUTINE BF_PARS(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX, 00471*78 * LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD) 00472148 C 00473*99 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 00474*99 C . . . . 00475*99 C SUBPROGRAM: BF_PARS BUFR MESSAGE DECODER 00476*78 C PRGMMR: CAVANAUGH ORG: NMC421 DATE:92-11-04 00477*99 C 00478*99 C ABSTRACT: THIS SET OF ROUTINES WILL DECODE A BUFR MESSAGE AND 00479*99 C PLACE INFORMATION EXTRACTED FROM THE BUFR MESSAGE INTO SELECTED 00480*99 C ARRAYS FOR THE USER. THE ARRAY KDATA CAN NOW BE SIZED BY THE USER 00481*99 C BY INDICATING THE MAXIMUM NUMBER OF SUBSETS AND THE MAXIMUM 00482*99 C NUMBER OF DESCRIPTORS THAT ARE EXPECTED IN THE COURSE OF DECODING 00483*99 C SELECTED INPUT DATA. THIS ALLOWS FOR REALISTIC SIZING OF KDATA 00484*99 C AND THE MSTACK ARRAYS. THIS VERSION ALSO ALLOWS FOR THE INCLUSION 00485*99 C OF THE UNIT NUMBERS FOR TABLES B AND D INTO THE 00486*99 C ARGUMENT LIST. THIS ROUTINE DOES NOT INCLUDE IFOD PROCESSING. 00487*99 C 00488*99 C PROGRAM HISTORY LOG: 00489*99 C 88-08-31 CAVANAUGH 00490*99 C 90-12-07 CAVANAUGH NOW UTILIZING GBYTE ROUTINES TO GATHER 00491*99 C AND SEPARATE BIT FIELDS. THIS SHOULD IMPROVE 00492*99 C (DECREASE) THE TIME IT TAKES TO DECODE ANY 00493*99 C BUFR MESSAGE. HAVE ENTERED CODING THAT WILL 00494*99 C PERMIT PROCESSING BUFR EDITIONS 1 AND 2. 00495*99 C IMPROVED AND CORRECTED THE CONVERSION INTO 00496*99 C IFOD FORMAT OF DECODED BUFR MESSAGES. 00497*99 C 91-01-18 CAVANAUGH PROGRAM/ROUTINES MODIFIED TO PROPERLY HANDLE 00498*99 C SERIAL PROFILER DATA. 00499*99 C 91-04-04 CAVANAUGH MODIFIED TO HANDLE TEXT SUPPLIED THRU 00500*99 C DESCRIPTOR 2 05 YYY. 00501*99 C 91-04-17 CAVANAUGH ERRORS IN EXTRACTING AND SCALING DATA 00502*99 C CORRECTED. IMPROVED HANDLING OF NESTED 00503*99 C QUEUE DESCRIPTORS IS ADDED. 00504*99 C 91-05-10 CAVANAUGH - ARRAY 'DATA' HAS BEEN ENLARGED TO REAL*8 00505*99 C TO BETTER CONTAIN VERY LARGE NUMBERS MORE 00506*99 C ACCURATELY. THE PREIOUS SIZE REAL*4 COULD NOT 00507*99 C CONTAIN SUFFICIENT SIGNIFICANT DIGITS. 00508*99 C - CODING HAS BEEN INTRODUCED TO PROCESS NEW 00509*99 C TABLE C DESCRIPTOR 2 06 YYY WHICH PERMITS IN 00510*99 C LINE PROCESSING OF A LOCAL DESCRIPTOR EVEN IF 00511*99 C THE DESCRIPTOR IS NOT CONTAINED IN THE USERS 00512*99 C TABLE B. 00513*99 C - A SECOND ROUTINE TO PROCESS IFOD MESSAGES 00514*99 C (IFOD0) HAS BEEN REMOVED IN FAVOR OF THE 00515*99 C IMPROVED PROCESSING OF THE ONE 00516*99 C REMAINING (IFOD1). 00517*99 C - NEW CODING HAS BEEN INTRODUCED TO PERMIT 00518*99 C PROCESSING OF BUFR MESSAGES BASED ON BUFR 00519*99 C EDITION UP TO AND INCLUDING EDITION 2. 00520*99 C PLEASE NOTE INCREASED SIZE REQUIREMENTS 00521*99 C FOR ARRAYS IDENT(20) AND IPTR(40). 00522*99 C 91-07-26 CAVANAUGH - ADD ARRAY MTIME TO CALLING SEQUENCE TO 00523*99 C PERMIT INCLUSION OF RECEIPT/TRANSFER TIMES 00524*99 C TO IFOD MESSAGES. 00525*99 C 91-09-25 CAVANAUGH - ALL PROCESSING OF DECODED BUFR DATA INTO 00526*99 C IFOD (A LOCAL USE REFORMAT OF BUFR DATA) 00527*99 C HAS BEEN ISOLATED FROM THIS SET OF ROUTINES. 00528*99 C FOR THOSE INTERESTED IN THE IFOD FORM, 00529*99 C SEE W3FL05 IN THE W3LIB ROUTINES. 00530*99 C PROCESSING OF BUFR MESSAGES CONTAINING 00531*99 C DELAYED REPLICATION HAS BEEN ALTERED SO THAT 00532*99 C SINGLE SUBSETS (REPORTS) AND AND A MATCHING 00533*99 C DESCRIPTOR LIST FOR THAT PARTICULAR SUBSET 00534*99 C WILL BE PASSED TO THE USER WILL BE PASSED TO 00535*99 C THE USER ONE AT A TIME TO ASSURE THAT EACH 00536*99 C SUBSET CAN BE FULLY DEFINED WITH A MINIMUM 00537*99 C OF REPROCESSING. 00538*99 C PROCESSING OF ASSOCIATED FIELDS HAS BEEN 00539*99 C TESTED WITH MESSAGES CONTAINING NON-COMPRESSED00540*99 C DATA. 00541*99 C IN ORDER TO FACILITATE USER PROCESSING 00542*99 C A MATCHING LIST OF SCALE FACTORS ARE INCLUDED 00543*99 C WITH THE EXPANDED DESCRIPTOR LIST (MSTACK). 00544*99 C 91-11-21 CAVANAUGH - PROCESSING OF DESCRIPTOR 2 03 YYY 00545*99 C HAS CORRECTED TO AGREE WITH FM94 STANDARDS. 00546*99 C 91-12-19 CAVANAUGH - CALLS TO FI8803 AND FI8804 HAVE BEEN 00547*78 C CORRECTED TO AGREE CALLED PROGRAM ARGUMENT 00548*99 C LIST. SOME ADDITIONAL ENTRIES HAVE BEEN 00549*99 C INCLUDED FOR COMMUNICATING WITH DATA ACCESS 00550*99 C ROUTINES. ADDITIONAL ERROR EXIT PROVIDED FOR 00551*99 C THE CASE WHERE TABLE B IS DAMAGED. 00552*99 C 92-01-24 CAVANAUGH - ROUTINES FI8801, FI8803 AND FI8804 00553*78 C HAVE BEEN MODIFIED TO HANDLE ASSOCIATED FIELDS00554*99 C ALL DESCRIPTORS ARE SET TO ECHO TO MSTACK(1,N)00555*99 C 92-05-21 CAVANAUGH - FURTHER EXPANSION OF INFORMATION COLLECTED 00556*99 C FROM WITHIN UPPER AIR SOUNDINGS HAS PRODUCED 00557*99 C THE NECESSITY TO EXPAND SOME OF THE PROCESSING00558*99 C AND OUTPUT ARRAYS. (SEE REMARKS BELOW) 00559*99 C 92-06-29 CAVANAUGH - CORRECTED DESCRIPTOR DENOTING HEIGHT OF 00560*99 C EACH WIND LEVEL FOR PROFILER CONVERSIONS. 00561*99 C 92-07-23 CAVANAUGH - EXPANSION OF TABLE B REQUIRES ADJUSTMENT 00562*99 C OF ARRAYS TO CONTAIN TABLE B VALUES NEEDED TO 00563*99 C ASSIST IN THE DECODING PROCESS. 00564*99 C ARRAYS CONTAINING DATA FROM TABLE B 00565*99 C KFXY1 - DESCRIPTOR 00566149 C ANAME1 - DESCRIPTOR NAME 00567149 C AUNIT1 - UNITS FOR DESCRIPTOR 00568149 C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR 00569149 C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR 00570149 C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR 00571149 C 92-09-09 CAVANAUGH - FIRST ENCOUNTER WITH OPERATOR DESCRIPTOR 00572*99 C 2 05 YYY SHOWED ERROR IN DECODING. THAT ERROR 00573*99 C IS CORRECTED WITH THIS IMPLEMENTATION. FURTHER 00574*99 C TESTING OF UPPER AIR DATA HAS ENCOUNTERED 00575*99 C THE CONDITION OF LARGE (MANY LEVEL) SOUNDINGS 00576*99 C ARRAYS IN THE DECODER HAVE BEEN EXPANDED (AGAIN) 00577*99 C TO ALLOW FOR THIS CONDITION. 00578*99 C 92-10-02 CAVANAUGH - MODIFIED ROUTINE TO REFORMAT PROFILER DATA 00579*99 C (FI8809) TO SHOW DESCRIPTORS, SCALE VALUE AND 00580*78 C DATA IN PROPER ORDER. CORRECTED AN ERROR THAT 00581*99 C PREVENTED USER FROM ASSIGNING THE SECOND DIMENSION00582*99 C OF KDATA(500,*). 00583*99 C 92-10-20 CAVANAUGH - REMOVED ERROR THAT PREVENTED FULL 00584*99 C IMPLEMENTATION OF PREVIOUS CORRECTIONS AND 00585*99 C MADE CORRECTIONS TO TABLE B TO BRING IT UP TO 00586*99 C DATE. CHANGES INCLUDE PROPER REFORMAT OF PROFILER 00587*99 C DATA AND USER CAPABILITY FOR ASSIGNING SECOND 00588*99 C DIMENSION OF KDATA ARRAY. 00589*99 C 92-12-09 CAVANAUGH - THANKS TO DENNIS KEYSER FOR THE SUGGESTIONS 00590*99 C AND CODING, THIS IMPLEMENTATION WILL ALLOW THE 00591*99 C INCLUSION OF UNIT NUMBERS FOR TABLES B & D, AND 00592*99 C IN ADDITION ALLOWS FOR REALISTIC SIZING OF KDATA 00593*99 C AND MSTACK ARRAYS BY THE USER. AS OF THIS 00594*99 C IMPLEMENTATION, THE UPPER SIZE LIMIT FOR A BUFR 00595*99 C MESSAGE ALLOWS FOR A MESSAGE SIZE GREATER THAN 00596*99 C 10000 BYTES. 00597*99 C 93-01-26 CAVANAUGH - ROUTINE FI8810 HAS BEEN ADDED TO PERMIT 00598*78 C REFORMATTING OF PROFILER DATA IN EDITION 2. 00599*99 C 93-05-13 CAVANAUGH - ROUTINE FI8811 HAS BEEN ADDED TO PERMIT 00600*78 C PROCESSING OF RUN-LINE ENCODING. THIS PROVIDES FOR00601*99 C THE HANDLING OF DATA FOR GRAPHICS PRODUCTS. 00602*99 C PLEASE NOTE THE ADDITION OF TWO ARGUMENTS IN THE 00603*99 C CALLING SEQUENCE. 00604*99 C 93-12-01 CAVANAUGH - ROUTINE FI8803 TO CORRECT HANDLING OF 00605*78 C ASSOCIATED FIELDS AND ARRAYS ASSOCIATED WITH 00606*99 C TABLE B ENTRIES ENLARGED TO HANDLE LARGER TABLE B 00607*99 C 94-04-28 CAVANAUGH - ROUTINES HAVE BEEN MODIFIED TO CONSTRUCT A 00608*78 C MODIFIED TABLE B I.E., IT IS TAILORED TO CONTAIN O00609*78 C THOSE DESCRIPTORS THAT WILL BE USED TO DECODE 00610*78 C DATA IN CURRENT AND SUBSEQUENT BUFR MESSAGES. 00611*78 C TABLE B AND TABLE D DESCRIPTORS WILL BE ISOLATED 00612*78 C AND MERGED WITH THE MAIN TABLES FOR USE WITH 00613*78 C FOLLOWING BUFR MESSAGES. 00614*78 C THE DESCRIPTORS INDICATING THE REPLICATION OF 00615*78 C DESCRIPTORS AND DATA ARE ACTIVATED WITH THIS 00616*78 C IMPLEMENTATION. 00617*78 C 00618*99 C USAGE: CALL BF_PARS(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX, 00619*78 C LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD) 00620*99 C 00621*99 C INPUT ARGUMENT LIST: 00622*99 C MSGA - ARRAY CONTAINING SUPPOSED BUFR MESSAGE 00623*99 C SIZE IS DETERMINED BY USER, CAN BE GREATER 00624*99 C THAN 10000 BYTES. 00625*99 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE 00626*99 C CONTAINED IN A BUFR MESSAGE 00627*99 C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT 00628*99 C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE 00629*99 C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST 00630*99 C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE 00631*99 C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B 00632*99 C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D 00633*99 C 00634*99 C 00635*99 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 00636*99 C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM 00637*99 C SOURCE BUFR MESSAGE. 00638*99 C 00639*99 C MSTACK(A,B)-LEVEL B - DESCRIPTOR NUMBER (LIMITED TO VALUE OF 00640*99 C INPUT ARGUMENT MAXD) 00641*99 C 00642*99 C LEVEL A = 1 DESCRIPTOR 900643*99 C = 2 10**N SCALING TO RETURN TO ORIGINAL VALUE 00644*99 C IPTR - UTILITY ARRAY (SHOULD HAVE AT LAST 42 ENTRIES) 00645124 C IPTR( 1)- ERROR RETURN 00646*99 C IPTR( 2)- BYTE COUNT SECTION 1 00647*99 C IPTR( 3)- POINTER TO START OF SECTION 1 00648*99 C IPTR( 4)- BYTE COUNT SECTION 2 00649*99 C IPTR( 5)- POINTER TO START OF SECTION 2 00650*99 C IPTR( 6)- BYTE COUNT SECTION 3 00651*99 C IPTR( 7)- POINTER TO START OF SECTION 3 00652*99 C IPTR( 8)- BYTE COUNT SECTION 4 00653*99 C IPTR( 9)- POINTER TO START OF SECTION 4 00654*99 C IPTR(10)- START OF REQUESTED SUBSET, RESERVED FOR DAR 00655*99 C IPTR(11)- CURRENT DESCRIPTOR PTR IN IWORK 00656*99 C IPTR(12)- LAST DESCRIPTOR POS IN IWORK 00657*99 C IPTR(13)- LAST DESCRIPTOR POS IN ISTACK 00658*99 C IPTR(14)- RESERVED 00659**2 C IPTR(15)- REQUESTED SUBSET POINTER, RESERVED FOR DAR 00660*99 C IPTR(16)- INDICATOR FOR EXISTANCE OF SECTION 2 00661*99 C IPTR(17)- NUMBER OF REPORTS PROCESSED 00662*99 C IPTR(18)- ASCII/TEXT EVENT 00663*99 C IPTR(19)- POINTER TO START OF BUFR MESSAGE 00664*99 C IPTR(20)- NUMBER OF ENTRIES FROM TABLE D 00665**3 C IPTR(21)- NR TABLE B ENTRIES 00666**3 C IPTR(22)- NR TABLE B ENTRIES FROM CURRENT MESSAGE 00667**2 C IPTR(23)- CODE/FLAG TABLE SWITCH 00668*99 C IPTR(24)- ADITIONAL WORDS ADDED BY TEXT INFO 00669*99 C IPTR(25)- CURRENT BIT NUMBER 00670*99 C IPTR(26)- DATA WIDTH CHANGE - ADD TO TABLE B WIDTH 00671*99 C IPTR(27)- DATA SCALE CHANGE - NEW SCALE VALUE 00672*99 C IPTR(28)- DATA REFERENCE VALUE CHANGE - ????????? 00673*99 C IPTR(29)- ADD DATA ASSOCIATED FIELD 00674*99 C IPTR(30)- SIGNIFY CHARACTERS 00675*99 C IPTR(31)- NUMBER OF EXPANDED DESCRIPTORS IN MSTACK 00676*99 C IPTR(32)- CURRENT DESCRIPTOR SEGMENT F 00677*99 C IPTR(33)- CURRENT DESCRIPTOR SEGMENT X 00678*99 C IPTR(34)- CURRENT DESCRIPTOR SEGMENT Y 00679*99 C IPTR(35)- DATA/DESCRIPTOR REPLICATION IN PROGRESS 00680*99 C 0 = NO 00681*99 C 1 = YES 00682*99 C IPTR(36)- NEXT DESCRIPTOR MAY BE UNDECIPHERABLE 00683*99 C IPTR(37)- UNUSED 00684*99 C IPTR(38)- DATA/DESCRIPTOR REPLICATION FLAG 00685*99 C 0 - DOES NOT EXIST IN CURRENT MESSAGE 00686*99 C 1 - EXISTS IN CURRENT MESSAGE 00687*99 C IPTR(39)- DELAYED REPLICATION FLAG 00688*99 C 0 - NO DELAYED REPLICATION 00689*99 C 1 - MESSAGE CONTAINS DELAYED REPLICATION 00690*99 C IPTR(40)- NUMBER OF CHARACTERS IN TEXT FOR CURR DESCRIPTOR 00691*99 C IPTR(41)- NUMBER OF ANCILLARY TABLE B ENTRIES 00692172 C IPTR(42)- NUMBER OF ANCILLARY TABLE D ENTRIES 00693172 C IPTR(43)- NUMBER OF ADDED TABLE B ENTRIES ENCOUNTERED WHILE 00694172 C PROCESSING A BUFR MESSAGE. THESE ENTRIES ONLY 00695172 C EXIST DURNG PROCESSING OF CURRENT BUFR MESSAGE 00696172 C IPTR(44)- UNUSED 00697172 C IPTR(45)- UNUSED 00698173 C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM 00699173 C BUFR MESSAGE - 00700*99 C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) 00701*99 C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) 00702*99 C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) 00703*99 C IDENT( 4)-OPTIONAL SECTION (BYTE 8, SECTION 1) 00704*99 C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) 00705*99 C 0 = SURFACE (LAND) 00706*99 C 1 = SURFACE (SHIP) 00707*99 C 2 = VERTICAL SOUNDINGS OTHER THAN SATELLITE 00708*99 C 3 = VERTICAL SOUNDINGS (SATELLITE) 00709*99 C 4 = SNGL LVL UPPER-AIR OTHER THAN SATELLITE 00710*99 C 5 = SNGL LVL UPPER-AIR (SATELLITE) 00711*99 C 6 = RADAR 00712*99 C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) 00713*99 C TYPE SBTYP 00714*99 C 2 7 = PROFILER 00715*99 C IDENT( 7)- (BYTES 11-12, SECTION 1) 00716*99 C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) 00717*99 C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) 00718*99 C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) 00719*99 C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) 00720*99 C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) 00721*99 C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) 00722*99 C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) 00723*99 C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) 00724*99 C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) 00725*99 C IDENT(17)-MASTER TABLE NUMBER(BYTE 4, SECTION 1, ED 2 OR GTR) 00726*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 00727*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 00728*99 C 00729*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 00730*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 00731*99 C ARGUMENT MAXD) 00732*99 C INDEX - POINTER TO AVAILABLE SUBSET 00733*78 C 00734*99 C =========================================================== 00735148 C ARRAYS CONTAINING DATA FROM TABLE B 00736*99 C NEW - BASE ARRAYS CONTAINING DATA FROM TABLE B 00737148 C KFXY1 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES 00738148 C ANAME1 - DESCRIPTOR NAME 00739148 C AUNIT1 - UNITS FOR DESCRIPTOR 00740148 C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR 00741148 C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR 00742148 C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR 00743148 C =========================================================== 00744148 C NEW - ANCILLARY ARRAYS CONTAINING DATA FROM TABLE B 00745148 C CONTAINING TABLE B ENTRIES EXTRACTED 00746148 C FROM TYPE 11 BUFR MESSAGES 00747148 C KFXY2 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES 00748148 C ANAME2 - DESCRIPTOR NAME 00749148 C AUNIT2 - UNITS FOR DESCRIPTOR 00750148 C ISCAL2 - SCALE FOR VALUE OF DESCRIPTOR 00751148 C IRFVL2 - REFERENCE VALUE FOR DESCRIPTOR 00752148 C IWIDE2 - BIT WIDTH FOR VALUE OF DESCRIPTOR 00753148 C =========================================================== 00754148 C NEW - ADDED ARRAYS CONTAINING DATA FROM TABLE B 00755148 C CONTAINING TABLE B ENTRIES EXTRACTED 00756148 C FROM NON-TYPE 11 BUFR MESSAGES 00757148 C THESE EXIST FOR THE LIFE OF CURRENT BUFR MESSAGE 00758148 C KFXY3 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES 00759148 C ANAME3 - DESCRIPTOR NAME 00760148 C AUNIT3 - UNITS FOR DESCRIPTOR 00761148 C ISCAL3 - SCALE FOR VALUE OF DESCRIPTOR 00762148 C IRFVL3 - REFERENCE VALUE FOR DESCRIPTOR 00763148 C IWIDE3 - BIT WIDTH FOR VALUE OF DESCRIPTOR 00764148 C =========================================================== 00765148 C 00766*99 C SUBPROGRAMS CALLED: 00767*99 C LIBRARY: 00768*99 C UNIQUE - FI8801 FI8802 FI8803 FI8804 FI8805 FI8806 00769*78 C FI8807 FI8808 FI8809 FI8810 FI8811 FI8812 00770*78 C FI8813 FI8814 FI8815 FI8820 00771*78 C W3LIB - W3AI39 W3FC05 GBYTE GBYTES 00772198 C 00773*99 C REMARKS: ERROR RETURNS: 00774*99 C IPTR(1) = 1 'BUFR' NOT FOUND IN FIRST 125 CHARACTERS 00775*99 C = 2 '7777' NOT FOUND IN LOCATION DETERMINED BY 00776*99 C BY USING COUNTS FOUND IN EACH SECTION. ONE OR 00777*99 C MORE SECTIONS HAVE AN ERRONEOUS BYTE COUNT OR 00778*99 C CHARACTERS '7777' ARE NOT IN TEST MESSAGE. 00779*99 C = 3 MESSAGE CONTAINS A DESCRIPTOR WITH F=0 THAT DOES 00780*99 C NOT EXIST IN TABLE B. 00781*99 C = 4 MESSAGE CONTAINS A DESCRIPTOR WITH F=3 THAT DOES 00782*99 C NOT EXIST IN TABLE D. 00783*99 C = 5 MESSAGE CONTAINS A DESCRIPTOR WITH F=2 WITH THE 00784*99 C VALUE OF X OUTSIDE THE RANGE 1-5. 00785*99 C = 6 DESCRIPTOR ELEMENT INDICATED TO HAVE A FLAG VALUE 00786*99 C DOES NOT HAVE AN ENTRY IN THE FLAG TABLE. 00787*99 C (TO BE ACTIVATED) 00788*99 C = 7 DESCRIPTOR INDICATED TO HAVE A CODE VALUE DOES 00789*99 C NOT HAVE AN ENTRY IN THE CODE TABLE. 00790*99 C (TO BE ACTIVATED) 00791*99 C = 8 ERROR READING TABLE D 00792*99 C = 9 ERROR READING TABLE B 00793*99 C = 10 ERROR READING CODE/FLAG TABLE 00794*99 C = 11 DESCRIPTOR 2 04 004 NOT FOLLOWED BY 0 31 021 00795*99 C = 12 DATA DESCRIPTOR OPERATOR QUALIFIER DOES NOT FOLLOW 00796*99 C DELAYED REPLICATION DESCRIPTOR. 00797*99 C = 13 BIT WIDTH ON ASCII CHARACTERS NOT A MULTIPLE OF 8 00798*99 C = 14 SUBSETS = 0, NO CONTENT BULLETIN 00799*99 C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS 00800*99 C = 21 EXCEEDED COUNT FOR NON-DELAYED REPLICATION PASS 00801*99 C = 22 EXCEEDED COMBINED BIT WIDTH, BIT WIDTH > 32 00802*87 C = 27 NON ZERO LOWEST ON TEXT DATA 00803*99 C = 28 NBINC NOT NR OF CHARACTERS 00804*99 C = 29 TABLE B APPEARS TO BE DAMAGED 00805*99 C = 99 NO MORE SUBSETS (REPORTS) AVAILABLE IN CURRENT 00806*99 C BUFR MESAGE 00807*99 C 00808*99 C = 400 NUMBER OF SUBSETS EXCEEDS THE VALUE OF INPUT 00809*99 C ARGUMENT MAXR; MUST INCREASE MAXR TO VALUE OF 00810*99 C IDENT(14) IN CALLING PROGRAM 00811*99 C 00812*99 C = 401 NUMBER OF PARAMETERS (AND ASSOCIATED FIELDS) 00813*99 C EXCEEDS LIMITS OF THIS PROGRAM. 00814*99 C = 500 VALUE FOR NBINC HAS BEEN FOUND THAT EXCEEDS 00815*99 C STANDARD WIDTH PLUS ANY BIT WIDTH CHANGE. 00816*99 C CHECK ALL BIT WIDTHS UP TO POINT OF ERROR. 00817*99 C = 501 CORRECTED WIDTH FOR DESCRIPTOR IS 0 OR LESS 00818*99 C = 888 NON-NUMERIC CHARACTER IN CONVERSION REQUEST 00819109 C = 890 CLASS 0 ELEMENT DESCRIPTOR W/WIDTH OF 0 00820113 C 00821*99 C ON THE INITIAL CALL TO BF_PARS WITH A BUFR MESSAGE THE ARGUMENT00822*78 C INDEX MUST BE SET TO ZERO (INDEX = 0). ON THE RETURN FROM BF_PARS 00823*78 C 'INDEX' WILL BE SET TO THE NEXT AVAILABLE SUBSET/REPORT. WHEN 00824*99 C THERE ARE NO MORE SUBSETS AVAILABLE A 99 ERR RETURN WILL OCCUR. 00825*99 C 00826*99 C IF THE ORIGINAL BUFR MESSAGE DOES NOT CONTAIN DELAYED REPLICATION 00827*99 C THE BUFR MESSAGE WILL BE COMPLETELY DECODED AND 'INDEX' WILL POINT 00828*99 C TO THE FIRST DECODED SUBSET. THE USERS WILL THEN HAVE THE OPTION 00829*99 C OF INDEXING THROUGH THE SUBSETS ON THEIR OWN OR BY RECALLING THIS 00830*99 C ROUTINE (WITHOUT RESETTING 'INDEX') TO HAVE THE ROUTINE DO THE 00831*99 C INDEXING. 00832*99 C 00833*99 C IF THE ORIGINAL BUFR MESSAGE DOES CONTAIN DELAYED REPLICATION 00834*99 C ONE SUBSET/REPORT WILL BE DECODED AT A TIME AND PASSED BACK TO 00835*99 C THE USER. THIS IS NOT AN OPTION. 00836*99 C 00837*99 C ============================================= 00838*99 C TO USE THIS ROUTINE 00839*99 C ============================================= 00840*99 C THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED 00841*99 C AS FOLLOWS: 00842*99 C 00843*99 C KDATA(A,B) IS THE A DATA ENTRY (INTEGER VALUE) 00844*99 C WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS00845*99 C THAT MAY BE CONTAINED IN THE BUFR MESSAGE (THIS 00846*99 C IS NOW SET TO "MAXR" WHICH IS PASSED AS AN INPUT00847*99 C ARGUMENT TO BF_PARS), AND WHERE B IS THE MAXIMUM00848*78 C NUMBER OF DESCRIPTOR COMBINATIONS THAT MAY 00849*99 C BE PROCESSED (THIS IS NOW SET TO "MAXD" WHICH 00850*99 C IS ALSO PASSED AS AN INPUT ARGUMENT TO BF_PARS; 00851*78 C UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE 00852*99 C A VALUE FOR MAXD OF 1700, BUT FOR MOST OTHER 00853*99 C DATA A VALUE FOR MAXD OF 500 WILL SUFFICE) 00854*99 C MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE 00855*99 C DATA ENTRY (MAX. VALUE FOR B IS NOW "MAXD" 00856*99 C WHICH IS PASSED AS AN INPUT ARGUMENT TO BF_PARS)00857*78 C MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO 00858*99 C THE DATA (MAX. VALUE FOR B IS NOW "MAXD" 00859*99 C WHICH IS PASSED AS AN INPUT ARGUMENT TO BF_PARS)00860*78 C 00861*99 C 00862*99 C ATTRIBUTES: 00863*99 C LANGUAGE: FORTRAN 77 00864*99 C MACHINE: NAS 00865*99 C 00866*99 C$$$ 00867*99 C 00868*99 C 00869*78 C THE MEMORY REQUIREMENTS FOR LSTACK AND LDATA ARE USED WITH 00870*99 C RUN-LINE CODING PROVIDING FOR THE HANDLING OF DATA FOR 00871*99 C GRAPHICS. I.E., RADAR DISPLAYS. IF THE DECODING PROCESS WILL 00872*99 C NOT BE USED TO PROCESS THOSE TYPE OF MESSAGES, THEN THE 00873*99 C VARIABLE SIZES FOR THE ARRAYS CAN BE MINIMIZED. 00874*99 C IF THE DECODING PROCESS WILL BE USED TO DECODE THOSE MESSAGE 00875*99 C TYPES, THEN MAXD MUST REFLECT THE MAXIMUM NUMBER OF 00876*99 C DESCRIPTORS (FULLY EXPANDED LIST) TO BE EXPECTED IN THE 00877*99 C MESSAGE. 00878*99 C 00879*99 INTEGER LDATA(MAXD) 00880*99 INTEGER LSTACK(2,MAXD) 00881*99 C 00882*99 INTEGER MSGA(*) 00883*99 INTEGER IPTR(*) 00884*99 INTEGER KDATA(MAXR,MAXD) 00885*99 INTEGER MSTACK(2,MAXD) 00886*99 C 00887*99 INTEGER IVALS(1000) 00888*99 INTEGER KNR(MAXR) 00889*99 INTEGER IDENT(*) 00890*99 INTEGER ISTACK(*),IOLD11 00891125 INTEGER IWORK(7500) 00892*75 INTEGER INDEX 00893*99 C 00894*99 CHARACTER*4 DIRID(2) 00895*99 C 00896*99 LOGICAL SEC2 00897*99 C .................................................. 00898148 C 00899148 C NEW BASE TABLE B 00900148 C MAY BE A COMBINATION OF MASTER TABLE B 00901198 C AND ANCILLARY TABLE B 00902198 C 00903148 INTEGER KFXY1(200),ISCAL1(200),IRFVL1(3,200),IWIDE1(200) 00904*44 CHARACTER*40 ANAME1(200) 00905148 CHARACTER*24 AUNIT1(200) 00906148 C .................................................. 00907198 C 00908148 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE 00909198 C 00910139 INTEGER KFXY2(200),ISCAL2(200),IRFVL2(200),IWIDE2(200) 00911148 CHARACTER*64 ANAME2(200) 00912148 CHARACTER*24 AUNIT2(200) 00913148 C .................................................. 00914198 C 00915139 C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE 00916198 C 00917148 C INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200) 00918198 C CHARACTER*64 ANAME3(200) 00919198 C CHARACTER*24 AUNIT3(200) 00920198 C .................................................. 00921148 C 00922148 C NEW BASE TABLE D 00923148 C 00924148 INTEGER ITBLD(14,400) 00925*76 C .................................................. 00926148 C 00927148 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE 00928198 C 00929139 INTEGER ITBLD2(14,50) 00930*76 C .................................................. 00931148 C 00932139 SAVE 00933*99 C 00934*99 C PRINT *,' W3FI88 DECODER' 00935*78 C INITIALIZE ERROR RETURN 00936*99 IPTR(1) = 0 00937*99 IF (INDEX.GT.0) THEN 00938*99 C HAVE RE-ENTRY 00939*99 INDEX = INDEX + 1 00940*99 C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX 00941*99 IF (INDEX.GT.IDENT(14)) THEN 00942*99 C ALL SUBSETS PROCESSED 00943*99 IPTR(1) = 99 00944*99 IPTR(38) = 0 00945*99 IPTR(39) = 0 00946*99 ELSE IF (INDEX.LE.IDENT(14)) THEN 00947*99 IF (IPTR(39).NE.0) THEN 00948*99 CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, 00949*78 * MSTACK,KNR,INDEX,MAXR,MAXD, 00950192 * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,00951192 * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, 00952192 * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, 00953192 * IUNITB,IUNITD,ITBLD) 00954192 C 00955*99 END IF 00956*99 END IF 00957*99 RETURN 00958*99 ELSE 00959*99 INDEX = 1 00960*99 C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE' 00961*99 END IF 00962*99 IPTR(39) = 0 00963*99 C FIND 'BUFR' IN FIRST 125 CHARACTERS 00964*99 DO 1000 KNOFST = 0, 999, 8 00965*99 INOFST = KNOFST 00966*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 00967*99 IF (IVALS(1).EQ.66) THEN 00968*99 IPTR(19) = INOFST 00969*99 INOFST = INOFST + 8 00970*99 CALL GBYTE (MSGA,IVALS,INOFST,24) 00971*99 IF (IVALS(1).EQ.5588562) THEN 00972*99 C PRINT *,'FOUND BUFR AT',IPTR(19) 00973*99 INOFST = INOFST + 24 00974*99 GO TO 1500 00975*99 END IF 00976*99 END IF 00977*99 1000 CONTINUE 00978*99 PRINT *,'BUFR - START OF BUFR MESSAGE NOT FOUND' 00979*99 IPTR(1) = 1 00980*99 RETURN 00981*99 1500 CONTINUE 00982*99 IDENT(1) = 0 00983*99 C TEST FOR EDITION NUMBER 00984*99 C ====================== 00985*99 CALL GBYTE (MSGA,IDENT(1),INOFST+24,8) 00986*99 C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE' 00987*99 C 00988*99 IF (IDENT(1).GE.2) THEN 00989*99 C GET TOTAL COUNT 00990*99 CALL GBYTE (MSGA,IVALS,INOFST,24) 00991*99 ITOTAL = IVALS(1) 00992*99 KENDER = ITOTAL * 8 - 32 + IPTR(19) 00993*99 CALL GBYTE (MSGA,ILAST,KENDER,32) 00994*99 C IF (ILAST.EQ.926365495) THEN 00995*99 C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1) 00996*99 C END IF 00997*99 INOFST = INOFST + 32 00998*99 C GET SECTION 1 COUNT 00999*99 IPTR(3) = INOFST 01000*99 CALL GBYTE (MSGA,IVALS,INOFST,24) 01001*99 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) 01002*99 INOFST = INOFST + 24 01003*99 IPTR( 2) = IVALS(1) 01004*99 C GET MASTER TABLE 01005*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 01006*99 INOFST = INOFST + 8 01007*99 IDENT(17) = IVALS(1) 01008*99 C PRINT *,'BUFR MASTER TABLE NR',IDENT(17) 01009*99 ELSE 01010*99 IPTR(3) = INOFST 01011*99 C GET SECTION 1 COUNT 01012*99 CALL GBYTE (MSGA,IVALS,INOFST,24) 01013*99 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) 01014*99 INOFST = INOFST + 32 01015*99 IPTR( 2) = IVALS(1) 01016*99 END IF 01017*99 C ====================== 01018*99 C ORIGINATING CENTER 01019*99 CALL GBYTE (MSGA,IVALS,INOFST,16) 01020*99 INOFST = INOFST + 16 01021*99 IDENT(2) = IVALS(1) 01022*99 C UPDATE SEQUENCE 01023*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 01024*99 INOFST = INOFST + 8 01025*99 IDENT(3) = IVALS(1) 01026*99 C OPTIONAL SECTION FLAG 01027*99 CALL GBYTE (MSGA,IVALS,INOFST,1) 01028*99 IDENT(4) = IVALS(1) 01029*99 IF (IDENT(4).GT.0) THEN 01030*99 SEC2 = .TRUE. 01031*99 ELSE 01032*99 C PRINT *,' NO OPTIONAL SECTION 2' 01033*99 SEC2 = .FALSE. 01034*99 END IF 01035*99 INOFST = INOFST + 8 01036*99 C MESSAGE TYPE 01037*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 01038*99 IDENT(5) = IVALS(1) 01039*99 INOFST = INOFST + 8 01040*99 C IF HAVE CHANGE IN DATA TYPE , RESET TABLE B01041125 IF (IOLD11.EQ.11) THEN 01042*10 C JUST CONTINUE PROCESSING 01043*10 ELSE IF (IOLD11.NE.IDENT(5)) THEN 01044*10 IOLD11 = IDENT(5) 01045125 IPTR(21) = 0 01046125 END IF 01047125 C MESSAGE SUB-TYPE 01048*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 01049*99 IDENT(6) = IVALS(1) 01050*99 INOFST = INOFST + 8 01051*99 C IF BUFR EDITION 0 OR 1 THEN 01052*99 C NEXT 2 BYTES ARE BUFR TABLE VERSION 01053*99 C ELSE 01054*99 C BYTE 11 IS VER NR OF MASTER TABLE 01055*99 C BYTE 12 IS VER NR OF LOCAL TABLE 01056*99 IF (IDENT(1).LT.2) THEN 01057*99 CALL GBYTE (MSGA,IVALS,INOFST,16) 01058*99 IDENT(7) = IVALS(1) 01059*99 INOFST = INOFST + 16 01060*99 ELSE 01061*99 C BYTE 11 IS VER NR OF MASTER TABLE 01062*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 01063*99 IDENT(18) = IVALS(1) 01064*99 INOFST = INOFST + 8 01065*99 C BYTE 12 IS VER NR OF LOCAL TABLE 01066*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 01067*99 IDENT(19) = IVALS(1) 01068*99 INOFST = INOFST + 8 01069*99 01070*99 END IF 01071*99 C YEAR OF CENTURY 01072*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 01073*99 IDENT(8) = IVALS(1) 01074*99 INOFST = INOFST + 8 01075*99 C MONTH 01076*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 01077*99 IDENT(9) = IVALS(1) 01078*99 INOFST = INOFST + 8 01079*99 C DAY 01080*99 C PRINT *,'DAY AT ',INOFST 01081*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 01082*99 IDENT(10) = IVALS(1) 01083*99 INOFST = INOFST + 8 01084*99 C HOUR 01085*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 01086*99 IDENT(11) = IVALS(1) 01087*99 INOFST = INOFST + 8 01088*99 C MINUTE 01089*99 CALL GBYTE (MSGA,IVALS,INOFST,8) 01090*99 IDENT(12) = IVALS(1) 01091*99 C RESET POINTER (INOFST) TO START OF 01092*99 C NEXT SECTION 01093*99 C (SECTION 2 OR SECTION 3) 01094*99 INOFST = IPTR(3) + IPTR(2) * 8 01095*99 IPTR(4) = 0 01096*99 IPTR(5) = INOFST 01097*99 IF (SEC2) THEN 01098*99 C SECTION 2 COUNT 01099*99 CALL GBYTE (MSGA,IPTR(4),INOFST,24) 01100*99 INOFST = INOFST + 32 01101*99 C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4) 01102*99 KENTRY = (IPTR(4) - 4) / 14 01103*99 C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS' 01104*99 IF (IDENT(2).EQ.7) THEN 01105*99 DO 2000 I = 1, KENTRY 01106*99 CALL GBYTE (MSGA,KDSPL ,INOFST,16) 01107*99 INOFST = INOFST + 16 01108*99 CALL GBYTE (MSGA,LAT ,INOFST,16) 01109*99 INOFST = INOFST + 16 01110*99 CALL GBYTE (MSGA,LON ,INOFST,16) 01111*99 INOFST = INOFST + 16 01112*99 CALL GBYTE (MSGA,KDAHR ,INOFST,16) 01113*99 INOFST = INOFST + 16 01114*99 CALL GBYTE (MSGA,DIRID(1),INOFST,32) 01115*99 INOFST = INOFST + 32 01116*99 CALL GBYTE (MSGA,DIRID(2),INOFST,16) 01117*99 INOFST = INOFST + 16 01118*99 C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2) 01119*99 2000 CONTINUE 01120*99 END IF 01121*99 C RESET POINTER (INOFST) TO START OF 01122*99 C SECTION 3 01123*99 INOFST = IPTR(5) + IPTR(4) * 8 01124*99 END IF 01125*99 C BIT OFFSET TO START OF SECTION 3 01126*99 IPTR( 7) = INOFST 01127*99 C SECTION 3 COUNT 01128*99 CALL GBYTE (MSGA,IPTR(6),INOFST,24) 01129*99 C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6) 01130*99 INOFST = INOFST + 24 01131*99 C SKIP RESERVED BYTE 01132*99 INOFST = INOFST + 8 01133*99 C NUMBER OF DATA SUBSETS 01134*99 CALL GBYTE (MSGA,IDENT(14),INOFST,16) 01135*99 C 01136*99 IF (IDENT(14).GT.MAXR) THEN 01137*99 PRINT *,'THE NUMBER OF SUBSETS EXCEEDS THE MAXIMUM OF',MAXR 01138*99 PRINT *,'PASSED INTO W3FI88; MAXR MUST BE INCREASED IN ' 01139*78 PRINT *,'THE CALLING PROGRAM TO AT LEAST THE VALUE OF' 01140*99 PRINT *,IDENT(14),'TO BE ABLE TO PROCESS THIS DATA' 01141*99 C 01142*99 IPTR(1) = 400 01143*99 RETURN 01144*99 END IF 01145*99 INOFST = INOFST + 16 01146*99 C OBSERVED DATA FLAG 01147*99 CALL GBYTE (MSGA,IVALS,INOFST,1) 01148*99 IDENT(15) = IVALS(1) 01149*99 INOFST = INOFST + 1 01150*99 C COMPRESSED DATA FLAG 01151*99 CALL GBYTE (MSGA,IVALS,INOFST,1) 01152*99 IDENT(16) = IVALS(1) 01153*99 INOFST = INOFST + 7 01154*99 C CALCULATE NUMBER OF DESCRIPTORS 01155*99 NRDESC = (IPTR( 6) - 8) / 2 01156*99 IPTR(12) = NRDESC 01157*99 IPTR(13) = NRDESC 01158*99 C EXTRACT DESCRIPTORS 01159*99 CALL GBYTES (MSGA,ISTACK,INOFST,16,0,NRDESC) 01160*99 C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS' 01161*99 DO 10 L = 1, NRDESC 01162*99 IWORK(L) = ISTACK(L) 01163*99 C PRINT *,L,ISTACK(L) 01164*78 10 CONTINUE 01165*99 IPTR(13) = NRDESC 01166*99 C =============================================================== 01167*99 C 01168*99 C CONSTRUCT A TABLE B TO MATCH THE 01169*99 C LIST OF DESCRIPTORS FOR THIS MESSAGE 01170*99 C 01171*99 IF (IPTR(21).EQ.0) THEN 01172*99 C PRINT *,'W3FI88- TABLE B NOT YET ENTERED' 01173*78 CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC, 01174*78 * IRF1SW,NEWREF,ITBLD,ITBLD2, 01175192 * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, 01176192 * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) 01177192 ELSE 01178203 C PRINT *,'W3FI88- TABLE B ALL READY IN PLACE' 01179*78 IF (IPTR(41).NE.0) THEN 01180**2 C PRINT *,'MERGE',IPTR(41),' ENTRIES INTO TABLE B' 01181*78 CALL FI8818(IPTR,KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,01182*78 * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)01183**2 END IF 01184**2 END IF 01185*99 C ================================================================ 01186*99 C RESET POINTER TO START OF SECTION 4 01187*99 INOFST = IPTR(7) + IPTR(6) * 8 01188*99 C BIT OFFSET TO START OF SECTION 4 01189*99 IPTR( 9) = INOFST 01190*99 C SECTION 4 COUNT 01191*99 CALL GBYTE (MSGA,IVALS,INOFST,24) 01192*99 C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1) 01193*99 IPTR( 8) = IVALS(1) 01194*99 INOFST = INOFST + 32 01195*99 C SET FOR STARTING BIT OF DATA 01196*99 IPTR(25) = INOFST 01197*99 C FIND OUT IF '7777' TERMINATOR IS THERE 01198*99 INOFST = IPTR(9) + IPTR(8) * 8 01199*99 CALL GBYTE (MSGA,IVALS,INOFST,32) 01200*99 C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1) 01201*99 IF (IVALS(1).NE.926365495) THEN 01202*99 PRINT *,'BAD SECTION COUNT' 01203*99 IPTR(1) = 2 01204*99 RETURN 01205*99 ELSE 01206*99 IPTR(1) = 0 01207*99 END IF 01208*99 C 01209*99 CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, 01210*78 * MSTACK,KNR,INDEX,MAXR,MAXD, 01211192 * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,01212192 * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, 01213192 * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, 01214192 * IUNITB,IUNITD,ITBLD,ITBLD2) 01215219 C 01216*99 C PRINT *,'HAVE RETURNED FROM FI8801' 01217*78 C IF (IPTR(1).NE.0) THEN 01218*99 C RETURN 01219*99 C END IF 01220*99 C FURTHER PROCESSING REQUIRED FOR PROFILER DATA 01221*99 IF (IDENT(5).EQ.2) THEN 01222*99 IF (IDENT(6).EQ.7) THEN 01223*99 C PRINT *,'REFORMAT PROFILER DATA' 01224*99 C 01225*99 IF (IDENT(1).LT.2) THEN 01226*99 CALL FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) 01227*78 ELSE 01228*99 CALL FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) 01229*78 END IF 01230*99 C DO 151 I = 1, 40 01231*99 C IF (I.LE.20) THEN 01232*99 C PRINT *,'IPTR(',I,')=',IPTR(I), 01233*99 C * ' IDENT(',I,')= ',IDENT(I) 01234*99 C ELSE 01235*99 C PRINT *,'IPTR(',I,')=',IPTR(I) 01236*99 C END IF 01237*99 C 151 CONTINUE 01238*99 IF (IPTR(1).NE.0) THEN 01239*99 RETURN 01240*99 END IF 01241*99 C 01242*99 C DO 154 I = 1, IPTR(31) 01243*99 C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)01244*99 C 154 CONTINUE 01245*99 END IF 01246*99 END IF 01247*99 C IF DATA/DESCRIPTOR REPLICATION FLAG IS ON, 01248*99 C MUST COMPLETE EXPANSION OF DATA AND 01249*99 C DESCRIPTORS. 01250*99 IF (IPTR(38).EQ.1) THEN 01251*99 CALL FI8811(IPTR,IDENT,MSTACK,KDATA,KNR, 01252*78 * LDATA,LSTACK,MAXD,MAXR) 01253*99 END IF 01254*99 C 01255126 C IF HAVE A LIST OF TABLE ENTRIES FROM 01256126 C A BUFR MESSAGE TYPE 11 01257126 C PRINT OUT THE ENTRIES 01258126 C 01259126 IF (IDENT(5).EQ.11) THEN 01260126 C DO 100 I = 1, IPTR(31)+IPTR(24) 01261*60 C PRINT *,I,MSTACK(1,I),(KDATA(J,I),J=1,4) 01262*60 C 100 CONTINUE 01263*60 CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT, 01264*78 * ITBLD2,ANAME2,AUNIT2,KFXY2,ISCAL2,IRFVL2,IWIDE2) 01265219 END IF 01266126 RETURN 01267*99 END 01268*99 SUBROUTINE FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, 01269*78 * MSTACK,KNR,INDEX,MAXR,MAXD, 01270192 * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL, 01271202 * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, 01272192 * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, 01273192 * IUNITB,IUNITD,ITBLD,ITBLD2) 01274219 C 01275*99 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 01276*99 C . . . . 01277*99 C SUBPROGRAM: FI8801 DATA EXTRACTION 01278*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 01279*99 C 01280*99 C ABSTRACT: CONTROL THE EXTRACTION OF DATA FROM SECTION 4 BASED ON 01281*99 C DATA DESCRIPTORS. 01282*99 C 01283*99 C PROGRAM HISTORY LOG: 01284*99 C 88-09-01 CAVANAUGH 01285*99 C 91-01-18 CAVANAUGH CORRECTIONS TO PROPERLY HANDLE NON-COMPRESSED 01286*99 C DATA. 01287*99 C 91-09-23 CAVANAUGH CODING ADDED TO HANDLE SINGLE SUBSETS WITH 01288*99 C DELAYED REPLICATION. 01289*99 C 92-01-24 CAVANAUGH MODIFIED TO ECHO DESCRIPTORS TO MSTACK(1,N) 01290*99 C 01291*99 C USAGE: CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, 01292*78 C * MSTACK,KNR,INDEX,MAXR,MAXD, 01293192 C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL, 01294192 C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, 01295192 C * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, 01296192 C * IUNITB,IUNITD,ITBLD,ITBLD2) 01297219 C 01298*99 C INPUT ARGUMENT LIST: 01299*99 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK 01300*78 C IDENT - SEE W3FI88 ROUTINE DOCBLOCK 01301*78 C MSGA - ARRAY CONTAINING BUFR MESSAGE 01302*99 C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM 01303*99 C SOURCE BUFR MESSAGE. 01304*99 C MSTACK - WORKING ARRAY OF DESCRIPTORS (EXPANDED)AND SCALING 01305*99 C FACTOR 01306*99 C KFXY1 - IMAGE OF CURRENT DESCRIPTOR 01307149 C INDEX - 01308*99 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE 01309*99 C CONTAINED IN A BUFR MESSAGE 01310*99 C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT 01311*99 C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE 01312*99 C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST 01313*99 C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE 01314*99 C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B 01315*99 C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D 01316*99 C 01317*99 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 01318*99 C IWORK - WORKING DESCRIPTOR LIST 01319*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 01320*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 01321*99 C 01322*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 01323*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 01324*99 C ARGUMENT MAXD) 01325*99 C 01326*99 C ISTACK - SEE ABOVE 01327*99 C ARRAYS CONTAINING DATA FROM TABLE B 01328*99 C KFXY1 - SEE ABOVE 01329149 C ANAME1 - DESCRIPTOR NAME 01330149 C AUNIT1 - UNITS FOR DESCRIPTOR 01331149 C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR 01332149 C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR 01333149 C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR 01334149 C 01335*99 C SUBPROGRAMS CALLED: 01336*99 C LIBRARY: 01337*99 C W3LIB - FI8802 FI8805 FI8806 FI8807 FI8808 01338*78 C 01339*99 C REMARKS: ERROR RETURN: 01340*99 C IPTR(1) = 8 ERROR READING TABLE B 01341*99 C = 9 ERROR READING TABLE D 01342*99 C = 11 ERROR OPENING TABLE B 01343*99 C 01344*99 C ATTRIBUTES: 01345*99 C LANGUAGE: FORTRAN 77 01346*99 C MACHINE: NAS 01347*99 C 01348*99 C$$$ 01349*99 SAVE 01350*99 C .................................................. 01351*43 C 01352*43 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE 01353*43 C 01354*43 INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*) 01355*43 CHARACTER*64 ANAME2(*) 01356*43 CHARACTER*24 AUNIT2(*) 01357*43 C .................................................. 01358*43 C 01359198 C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE 01360198 C 01361198 INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200) 01362198 CHARACTER*64 ANAME3(200) 01363198 CHARACTER*24 AUNIT3(200) 01364198 C .................................................. 01365198 C 01366*41 C NEW BASE TABLE B 01367*41 C MAY BE A COMBINATION OF MASTER TABLE B 01368*41 C AND ANCILLARY TABLE B 01369*41 C 01370*41 INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) 01371*44 CHARACTER*40 ANAME1(*) 01372*41 CHARACTER*24 AUNIT1(*) 01373*41 C .................................................. 01374*41 C 01375*41 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE 01376*41 C 01377*41 INTEGER ITBLD2(14,*) 01378*76 C .................................................. 01379*42 C 01380*42 C NEW BASE TABLE D 01381*42 C 01382*42 INTEGER ITBLD(14,*) 01383*76 C .................................................. 01384*42 C 01385*99 C 01386*99 INTEGER MAXD, MAXR 01387*41 C 01388*99 INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*) 01389*99 C 01390*99 INTEGER KNR(MAXR) 01391*41 INTEGER LX,LY,LL,J 01392*99 C INTEGER IHOLD(33) 01393198 INTEGER IPTR(*) 01394*99 INTEGER IDENT(*) 01395*99 INTEGER ISTACK(*),IWORK(*) 01396*99 C 01397*99 INTEGER MSTACK(2,MAXD) 01398198 C 01399*99 INTEGER JDESC 01400*99 INTEGER INDEX 01401*99 C 01402*99 C PRINT *,' DECOLL FI8801' 01403*78 IF (INDEX.GT.1) THEN 01404*99 GO TO 1000 01405*99 END IF 01406*99 C --------- DECOLL --------------- 01407*99 IPTR(23) = 0 01408*99 IPTR(26) = 0 01409*99 IPTR(27) = 0 01410*99 IPTR(28) = 0 01411*99 IPTR(29) = 0 01412*99 IPTR(30) = 0 01413*99 IPTR(36) = 0 01414*99 C INITIALIZE OUTPUT AREA 01415*99 C SET POINTER TO BEGINNING OF DATA 01416*99 C SET BIT 01417*99 IPTR(17) = 1 01418*99 1000 CONTINUE 01419*99 C IPTR(12) = IPTR(13) 01420*99 LL = 0 01421*99 IPTR(11) = 1 01422*99 IF (IPTR(10).EQ.0) THEN 01423*99 C RE-ENTRY POINT FOR MULTIPLE 01424*99 C NON-COMPRESSED REPORTS 01425*99 ELSE 01426*99 INDEX = IPTR(15) 01427*99 IPTR(17) = INDEX 01428*99 IPTR(25) = IPTR(10) 01429*99 IPTR(10) = 0 01430*99 IPTR(15) = 0 01431*99 END IF 01432*99 C PRINT *,'FI8801 - RPT',IPTR(17),' STARTS AT',IPTR(25) 01433*78 IPTR(24) = 0 01434*99 IPTR(31) = 0 01435*99 C POINTING AT NEXT AVAILABLE DESCRIPTOR 01436*99 MM = 0 01437*99 IF (IPTR(21).EQ.0) THEN 01438200 CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC, 01439*78 * IRF1SW,NEWREF,ITBLD,ITBLD2, 01440200 * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, 01441200 * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) 01442200 END IF 01443200 10 CONTINUE 01444*99 C PROCESS THRU THE FOLLOWING 01445*99 C DEPENDING UPON THE VALUE OF 'F' (LF) 01446*99 MM = MM + 1 01447*99 12 CONTINUE 01448*99 IF (MM.GT.MAXD) THEN 01449*99 GO TO 200 01450*99 END IF 01451*99 C END OF CYCLE TEST (SERIAL/SEQUENTIAL) 01452*99 IF (IPTR(11).GT.IPTR(12)) THEN 01453*99 C PRINT *,' HAVE COMPLETED REPORT SEQUENCE' 01454*99 IF (IDENT(16).NE.0) THEN 01455*99 C PRINT *,' PROCESSING COMPRESSED REPORTS' 01456*99 C REFORMAT DATA FROM DESCRIPTOR 01457*99 C FORM TO USER FORM 01458*99 RETURN 01459*99 ELSE 01460*99 C WRITE (6,1) 01461*99 C 1 FORMAT (1H1) 01462*99 C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25) 01463*99 IPTR(17) = IPTR(17) + 1 01464*99 IF (IPTR(17).GT.IDENT(14)) THEN 01465*99 IPTR(17) = IPTR(17) - 1 01466*99 GO TO 200 01467*99 END IF 01468*99 DO 300 I = 1, IPTR(13) 01469*99 IWORK(I) = ISTACK(I) 01470*99 300 CONTINUE 01471*99 C RESET POINTERS 01472*99 LL = 0 01473*99 IPTR(1) = 0 01474*99 IPTR(11) = 1 01475*99 IPTR(12) = IPTR(13) 01476*99 C IS THIS LAST REPORT ? 01477*99 C PRINT *,'READY',IPTR(39),INDEX 01478*99 IF (IPTR(39).GT.0) THEN 01479*99 IF (INDEX.GT.0) THEN 01480*99 C PRINT *,'HERE IS SUBSET NR',INDEX 01481*99 RETURN 01482*99 END IF 01483*99 END IF 01484*99 GO TO 1000 01485*99 END IF 01486*99 END IF 01487*99 14 CONTINUE 01488*99 C GET NEXT DESCRIPTOR 01489*99 CALL FI8808 (IPTR,IWORK,LF,LX,LY,JDESC) 01490*78 C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ', 01491*20 C * IPTR(11),IWORK(IPTR(11)),IPTR(31) 01492*20 C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY, 01493*99 C * ' FOR LOC',IPTR(17),IPTR(25) 01494*99 IF (IPTR(11).GT.MAXD) THEN 01495*24 IPTR(1) = 401 01496*99 RETURN 01497*99 END IF 01498*99 C 01499*99 KPRM = IPTR(31) + IPTR(24) 01500*99 IF (KPRM.GT.MAXD) THEN 01501*52 IF (KPRM.GT.KOLD) THEN 01502*99 PRINT *,'EXCEEDED ARRAY SIZE',KPRM,IPTR(31), 01503*99 * IPTR(24) 01504*99 KOLD = KPRM 01505*99 END IF 01506*99 END IF 01507*99 C REPLICATION PROCESSING 01508*99 IF (LF.EQ.1) THEN 01509*99 C ---------- F1 --------- 01510*99 IPTR(31) = IPTR(31) + 1 01511*99 KPRM = IPTR(31) + IPTR(24) 01512*99 MSTACK(1,KPRM) = JDESC 01513*99 MSTACK(2,KPRM) = 0 01514*99 KDATA(IPTR(17),KPRM) = 0 01515*99 C PRINT *,'FI8801-1',KPRM,MSTACK(1,KPRM), 01516*78 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) 01517*23 CALL FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY, 01518*78 * KDATA,LL,KNR,MSTACK,MAXR,MAXD) 01519*99 C * KDATA,LL,KNR,MSTACK,MAXR,MAXD) 01520*99 IF (IPTR(1).NE.0) THEN 01521*99 RETURN 01522*99 ELSE 01523*99 GO TO 12 01524*99 END IF 01525*99 C 01526*99 C DATA DESCRIPTION OPERATORS 01527*99 ELSE IF (LF.EQ.2)THEN 01528*99 IF (LX.EQ.5) THEN 01529*99 ELSE IF (LX.EQ.4) THEN 01530*99 IPTR(31) = IPTR(31) + 1 01531*99 KPRM = IPTR(31) + IPTR(24) 01532*99 MSTACK(1,KPRM) = JDESC 01533*99 MSTACK(2,KPRM) = 0 01534*99 KDATA(IPTR(17),KPRM) = 0 01535*99 C PRINT *,'FI8801-2',KPRM,MSTACK(1,KPRM), 01536*78 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) 01537*78 END IF 01538*99 CALL FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, 01539*78 * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD) 01540149 IF (IPTR(1).NE.0) THEN 01541*99 RETURN 01542*99 END IF 01543*99 GO TO 12 01544*99 C DESCRIPTOR SEQUENCE STRINGS 01545*99 ELSE IF (LF.EQ.3) THEN 01546*99 C PRINT *,'F3 SEQUENCE DESCRIPTOR' 01547*23 C READ IN TABLE D, BUT JUST ONCE 01548*13 IF (IPTR(20).EQ.0) THEN 01549219 CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2) 01550*78 IF (IPTR(1).GT.0) THEN 01551*99 RETURN 01552*99 END IF 01553*99 ELSE 01554**3 IF (IPTR(42).NE.0) THEN 01555**3 C PRINT *,'MERGE',IPTR(42),' ENTRIES INTO TABLE D' 01556*78 CALL FI8819(IPTR,ITBLD,ITBLD2) 01557*78 END IF 01558**3 END IF 01559*99 CALL FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC) 01560*78 IF (IPTR(1).GT.0) THEN 01561*99 RETURN 01562*99 END IF 01563*99 GO TO 14 01564*99 C 01565*99 C ELEMENT DESCRIPTOR PROCESSING 01566179 C 01567179 ELSE 01568*99 KPRM = IPTR(31) + IPTR(24) 01569*99 CALL FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK, 01570*78 * AUNIT1,IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD) 01571149 C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR 01572*99 IPTR(36) = 0 01573*99 IF (IPTR(1).GT.0) THEN 01574*99 RETURN 01575*99 ELSE 01576*99 C 01577179 C IF ENCOUNTER CLASS 0 DESCRIPTOR 01578179 C NOT CONTAINED WITHIN A BUFR 01579179 C MESSAGE OF TYPE 11, THEN COLLECT 01580179 C ALL TABLE B ENTRIES FOR USE ON 01581179 C CURRENT BUFR MESSAGE 01582179 C 01583179 IF (JDESC.LE.20.AND.JDESC.GE.10) THEN 01584179 IF (IDENT(5).NE.11) THEN 01585179 C COLLECT TABLE B ENTRIES 01586179 CALL FI8815(IPTR,IDENT,JDESC,KDATA, 01587*78 * KFXY3,MAXR,MAXD,ANAME3,AUNIT3, 01588181 * ISCAL3,IRFVL3,IWIDE3, 01589187 * KEYSET,IBFLAG,IERR) 01590188 IF (IERR.NE.0) THEN 01591179 END IF 01592179 IF (IAND(IBFLAG,16).NE.0) THEN 01593188 IF (IAND(IBFLAG,8).NE.0) THEN 01594188 IF (IAND(IBFLAG,4).NE.0) THEN 01595188 IF (IAND(IBFLAG,2).NE.0) THEN 01596188 IF (IAND(IBFLAG,1).NE.0) THEN 01597188 C HAVE A COMPLETE TABLE B ENTRY01598186 IPTR(43) = IPTR(43) + IDENT(14) 01599186 KEYSET = 0 01600186 IBFLAG = 0 01601186 GO TO 1000 01602186 END IF 01603186 END IF 01604186 END IF 01605186 END IF 01606188 END IF 01607188 END IF 01608188 END IF 01609179 IF (IDENT(16).EQ.0) THEN 01610*99 KNR(IPTR(17)) = IPTR(31) 01611*99 ELSE 01612*99 DO 310 KJ = 1, MAXR 01613*99 KNR(KJ) = IPTR(31) 01614*99 310 CONTINUE 01615*99 END IF 01616*99 GO TO 10 01617*99 END IF 01618*99 END IF 01619*99 C END IF 01620*99 C END DO WHILE 01621*99 200 CONTINUE 01622*99 IF (IDENT(16).NE.0) THEN 01623*99 C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS' 01624*99 ELSE 01625*99 C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS' 01626*99 END IF 01627*99 RETURN 01628*99 END 01629*99 SUBROUTINE FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1, 01630*78 * IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD) 01631149 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 01632*99 C . . . . 01633*99 C SUBPROGRAM: FI8802 PROCESS ELEMENT DESCRIPTOR 01634*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 01635*99 C 01636*99 C ABSTRACT: PROCESS AN ELEMENT DESCRIPTOR (F = 0) AND STORE DATA 01637149 C IN OUTPUT ARRAY. 01638*99 C 01639*99 C PROGRAM HISTORY LOG: 01640*99 C 88-09-01 CAVANAUGH 01641*99 C 91-04-04 CAVANAUGH CHANGED TO PASS WIDTH OF TEXT FIELDS IN BYTES 01642*99 C 01643*99 C USAGE: CALL FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1, 01644*78 C IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD) 01645149 C INPUT ARGUMENT LIST: 01646*99 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK 01647*78 C IDENT - SEE W3FI88 ROUTINE DOCBLOCK 01648*78 C MSGA - ARRAY CONTAINING BUFR MESSAGE 01649*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 01650*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 01651*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 01652*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 01653*99 C ARGUMENT MAXD) 01654*99 C KFXY1 - IMAGE OF CURRENT DESCRIPTOR 01655149 C ANAME1 - LIST OF NAME OF DESCRIPTOR CONTENTS 01656149 C MSTACK - 01657*99 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE 01658*99 C CONTAINED IN A BUFR MESSAGE 01659*99 C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT 01660*99 C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE 01661*99 C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST 01662*99 C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE 01663*99 C 01664*99 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 01665*99 C KDATA - SEE ABOVE 01666*99 C KFXY1 - SEE ABOVE 01667149 C ARRAYS CONTAINING DATA FROM TABLE B 01668*99 C AUNIT1 - UNITS FOR DESCRIPTOR 01669149 C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR 01670149 C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR 01671149 C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR 01672149 C 01673*99 C SUBPROGRAMS CALLED: 01674*99 C LIBRARY: 01675*99 C W3LIB - FI8803 FI8804 01676*78 C 01677*99 C REMARKS: ERROR RETURN: 01678*99 C IPTR(1) = 3 - MESSAGE CONTAINS A DESCRIPTOR WITH F=0 01679*99 C THAT DOES NOT EXIST IN TABLE B. 01680*99 C 01681*99 C ATTRIBUTES: 01682*99 C LANGUAGE: FORTRAN 77 01683*99 C MACHINE: NAS 01684*99 C 01685*99 C$$$ 01686*99 SAVE 01687*99 C TABLE B ENTRY 01688*99 CHARACTER*24 ASKEY 01689*99 INTEGER MSGA(*) 01690*99 INTEGER IPTR(*) 01691*99 INTEGER IDENT(*) 01692*99 INTEGER J 01693*99 INTEGER JDESC 01694*99 INTEGER MSTACK(2,MAXD) 01695*41 INTEGER KDATA(MAXR,MAXD),IVALS(*) 01696*41 C .................................................. 01697*41 C 01698*41 C NEW BASE TABLE B 01699*41 C MAY BE A COMBINATION OF MASTER TABLE B 01700*41 C AND ANCILLARY TABLE B 01701*41 C 01702*41 INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) 01703*44 C CHARACTER*40 ANAME1(*) 01704*47 CHARACTER*24 AUNIT1(*) 01705*41 C .................................................. 01706*41 C 01707*99 DATA ASKEY /'CCITT IA5 '/ 01708*99 C 01709*99 C PRINT *,' FI8802 - ELEMENT DESCRIPTOR PROCESSOR' 01710*78 C GET A MATCH BETWEEN CURRENT 01711*99 C DESCRIPTOR (JDESC) AND 01712*99 C TABLE B ENTRY 01713*99 C IF (KFXY1(356).EQ.0) THEN 01714149 C PRINT *,'FI8802 - KFXY1(356) WENT TO ZER0' 01715*78 C IPTR(1) = 600 01716*99 C RETURN 01717*99 C END IF 01718*99 KLOW = 1 01719*16 KHIGH = IPTR(21) 01720**2 10 CONTINUE 01721*99 IF (KLOW.GT.KHIGH) THEN 01722*18 IPTR(1) = 3 01723*18 RETURN 01724*18 END IF 01725*18 C 01726*16 J = (KLOW + KHIGH) / 2 01727*16 IF (JDESC.EQ.KFXY1(J)) THEN 01728*16 GO TO 15 01729*16 ELSE IF(JDESC.EQ.KFXY1(KLOW)) THEN 01730*16 J = KLOW 01731*16 GO TO 15 01732*99 ELSE IF (JDESC.EQ.KFXY1(KHIGH)) THEN 01733*16 J = KHIGH 01734*17 GO TO 15 01735*16 ELSE IF (JDESC.LT.KFXY1(J)) THEN 01736*16 KLOW = KLOW + 1 01737*16 KHIGH = J - 1 01738*16 GO TO 10 01739*16 ELSE 01740*16 KLOW = J 01741*16 KHIGH = KHIGH - 1 01742*16 GO TO 10 01743*16 END IF 01744*99 15 CONTINUE 01745*99 C HAVE A MATCH 01746*99 C SET FLAG IF TEXT EVENT 01747*99 C PRINT *,'ASKEY=',ASKEY,'AUNIT1(',J,')=',AUNIT1(J) 01748*30 IF (ASKEY(1:9).EQ.AUNIT1(J)(1:9)) THEN 01749149 IPTR(18) = 1 01750*99 IPTR(40) = IWIDE1(J) / 8 01751149 ELSE 01752*99 IPTR(18) = 0 01753*99 END IF 01754*99 C PRINT *,'FI8802 - BIT WIDTH =',IWIDE1(J),IPTR(18),' FOR',JDESC 01755*78 IF (IDENT(16).NE.0) THEN 01756*99 C COMPRESSED 01757*99 CALL FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, 01758*78 * IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD) 01759149 C IF (IPTR(1).NE.0) THEN 01760*22 C RETURN 01761*22 C END IF 01762*22 ELSE 01763*99 C NOT COMPRESSED 01764*99 CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, 01765*78 * IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) 01766149 C IF (IPTR(1).NE.0) THEN 01767*22 C RETURN 01768*22 C END IF 01769*22 END IF 01770*99 RETURN 01771*99 END 01772*99 C ----------------------------------------------------- 01773*99 SUBROUTINE FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, 01774*78 * IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD) 01775149 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 01776*99 C . . . . 01777*99 C SUBPROGRAM: FI8803 PROCESS COMPRESSED DATA 01778*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 01779*99 C 01780*99 C ABSTRACT: PROCESS COMPRESSED DATA AND PLACE INDIVIDUAL ELEMENTS 01781*99 C INTO OUTPUT ARRAY. 01782*99 C 01783*99 C PROGRAM HISTORY LOG: 01784*99 C 88-09-01 CAVANAUGH 01785*99 C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE 01786*99 C MODIFIED TO HANLE WIDTH OF FIELDS IN BYTES. 01787*99 C 91-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED 01788*99 C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. 01789*99 C THIS HAS BEEN CORRECTED. 01790*99 C 91-06-21 CAVANAUGH PROCESSING OF TEXT DATA HAS BEEN CHANGED TO 01791*99 C PROVIDE EXACT REPRODUCTION OF ALL CHARACTERS. 01792*99 C 94-04-11 CAVANAUGH CORRECTED PROCESSING OF DATA WHEN ALL VALUES 01793*27 C THE SAME (NBINC = 0). CORRECTED TEST OF LOWEST 01794*27 C VALUE AGAINST PROPER BIT MASK. 01795*27 C 01796*99 C USAGE: CALL FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, 01797*78 C IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD) 01798149 C INPUT ARGUMENT LIST: 01799*99 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK 01800*78 C IDENT - SEE W3FI88 ROUTINE DOCBLOCK 01801*78 C MSGA - ARRAY CONTAINING BUFR MESSAGE,MSTACK, 01802*99 C IVALS - ARRAY OF SINGLE PARAMETER VALUES 01803*99 C J - 01804*99 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE 01805*99 C CONTAINED IN A BUFR MESSAGE 01806*99 C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT 01807*99 C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE 01808*99 C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST 01809*99 C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE 01810*99 C 01811*99 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 01812*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 01813*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 01814*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 01815*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 01816*99 C ARGUMENT MAXD) 01817*99 C J - 01818*99 C ARRAYS CONTAINING DATA FROM TABLE B 01819*99 C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR 01820149 C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR 01821149 C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR 01822149 C 01823*99 C SUBPROGRAMS CALLED: 01824*99 C LIBRARY: 01825*99 C W3LIB - GBYTE GBYTES W3AI39 01826*99 C 01827*99 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION 01828*99 C 01829*99 C ATTRIBUTES: 01830*99 C LANGUAGE: FORTRAN 77 01831*99 C MACHINE: NAS 01832*99 C 01833*99 C$$$ 01834*99 SAVE 01835*99 C 01836*99 C .................................................. 01837*41 C 01838*41 C NEW BASE TABLE B 01839*41 C MAY BE A COMBINATION OF MASTER TABLE B 01840*41 C AND ANCILLARY TABLE B 01841*41 C 01842*41 C INTEGER KFXY1(*) 01843*47 INTEGER ISCAL1(*) 01844*47 INTEGER IRFVL1(3,*) 01845*47 INTEGER IWIDE1(*) 01846*47 C CHARACTER*40 ANAME1(*) 01847*47 C CHARACTER*24 AUNIT1(*) 01848*47 C .................................................. 01849*41 INTEGER MAXD,MAXR 01850*41 INTEGER MSGA(*),JDESC,MSTACK(2,MAXD) 01851*99 INTEGER IPTR(*),IVALS(*),KDATA(MAXR,MAXD) 01852*99 INTEGER NRVALS,JWIDE,IDATA 01853*99 INTEGER IDENT(*) 01854*99 INTEGER J 01855*99 INTEGER KLOW(256) 01856*99 C 01857*99 LOGICAL TEXT 01858*99 C 01859*99 INTEGER MSK(32) 01860*79 C 01861*99 C 01862*99 DATA MSK /1, 3, 7, 15, 31, 63, 127, 01863*83 C 1 2 3 4 5 6 7 01864*99 * 255, 511, 1023, 2047, 4095, 01865*83 C 8 9 10 11 12 01866*99 * 8191, 16383, 32767, 65535, 01867*83 C 13 14 15 16 01868*99 * 131071, 262143, 524287, 01869*83 C 17 18 19 01870*99 * 1048575, 2097151, 4194303, 01871*83 C 20 21 22 01872*99 * 8388607, 16777215, 33554431, 01873*83 C 23 24 25 01874*99 * 67108863, 134217727, 268435455, 01875*83 C 26 27 28 01876*99 * 536870911, 1073741823, 2147483647,-1 / 01877*83 C 29 30 31 32 01878*83 CALL W3FI01(LW) 01879*92 IF (LW.EQ.8) THEN 01880*92 I = 2147483647 01881*98 MSK(32) = I + I + 1 01882*97 END IF 01883*92 C 01884*99 C PRINT *,' FI8803 COMPR J=',J,' IWIDE1(J) =',IWIDE1(J), 01885*78 C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25) 01886*99 IF (IPTR(18).EQ.0) THEN 01887*99 TEXT = .FALSE. 01888*99 ELSE 01889*99 TEXT = .TRUE. 01890*99 END IF 01891*99 C PRINT *,'DESCRIPTOR',KPRM 01892*99 IF (.NOT.TEXT) THEN 01893*99 IF (IPTR(29).GT.0.AND.JDESC.NE.7957) THEN 01894*99 C PRINT *,'ASSOCIATED FIELD AT',IPTR(25) 01895*99 C WORKING WITH ASSOCIATED FIELDS HERE 01896*99 IPTR(31) = IPTR(31) + 1 01897*99 KPRM = IPTR(31) + IPTR(24) 01898*99 C GET LOWEST 01899*99 CALL GBYTE (MSGA,LOWEST,IPTR(25),IPTR(29)) 01900*99 IPTR(25) = IPTR(25) + IPTR(29) 01901*99 C GET NBINC 01902*99 CALL GBYTE (MSGA,NBINC,IPTR(25),6) 01903*99 IPTR(25) = IPTR(25) + 6 01904*99 C PRINT *,'LOWEST=',LOWEST,' NBINC=',NBINC 01905*99 IF (NBINC.GT.32) THEN 01906*92 IPTR(1) = 22 01907*92 RETURN 01908*92 END IF 01909*92 C EXTRACT DATA FOR ASSOCIATED FIELD 01910*99 IF (NBINC.GT.0) THEN 01911*99 CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,IPTR(21)) 01912*87 IPTR(25) = IPTR(25) + NBINC * IPTR(21) 01913*87 DO 50 I = 1, IDENT(14) 01914*87 KDATA(I,KPRM) = IVALS(I) + LOWEST 01915*87 IF (NBINC.EQ.32) THEN 01916*92 IF (KDATA(I,KPRM).EQ.MSK(NBINC)) THEN 01917105 KDATA(I,KPRM) = 999999 01918*92 END IF 01919*92 ELSE IF (KDATA(I,KPRM).GE.MSK(NBINC)) THEN 01920*92 KDATA(I,KPRM) = 999999 01921*87 END IF 01922*87 50 CONTINUE 01923*87 ELSE 01924*99 DO 51 I = 1, IDENT(14) 01925*87 KDATA(I,KPRM) = LOWEST 01926*92 IF (NBINC.EQ.32) THEN 01927*92 IF (LOWEST.EQ.MSK(32)) THEN 01928*92 KDATA(I,KPRM) = 999999 01929*92 END IF 01930*92 ELSE IF(LOWEST.GE.MSK(NBINC)) THEN 01931*92 KDATA(I,KPRM) = 999999 01932*92 END IF 01933*87 51 CONTINUE 01934*87 END IF 01935*99 END IF 01936*99 C SET PARAMETER 01937*99 C ISOLATE COMBINED BIT WIDTH 01938*87 JWIDE = IWIDE1(J) + IPTR(26) 01939149 C 01940*87 IF (JWIDE.GT.32) THEN 01941*87 C TOO MANY BITS IN COMBINED 01942*87 C BIT WIDTH 01943*87 PRINT *,'ERR 22 - HAVE EXCEEDED COMBINED BIT WIDTH' 01944*87 IPTR(1) = 22 01945*87 RETURN 01946*87 END IF 01947*87 C SINGLE VALUE FOR LOWEST 01948*99 NRVALS = 1 01949*99 C LOWEST 01950*99 C PRINT *,'PARAM',KPRM 01951*99 CALL GBYTE (MSGA,LOWEST,IPTR(25),JWIDE) 01952*99 C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25) 01953*99 IPTR(25) = IPTR(25) + JWIDE 01954*99 C ISOLATE COMPRESSED BIT WIDTH 01955*99 CALL GBYTE (MSGA,NBINC,IPTR(25),6) 01956*99 C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25) 01957*99 IF (NBINC.GT.32) THEN 01958*92 C NBINC TOO LARGE 01959*92 IPTR(1) = 22 01960*92 RETURN 01961*92 END IF 01962*92 IF (IPTR(32).EQ.2.AND.IPTR(33).EQ.5) THEN 01963*99 ELSE 01964*99 IF (NBINC.GT.JWIDE) THEN 01965*99 C PRINT *,'FOR DESCRIPTOR',JDESC 01966*99 C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' IWIDE1(J)=',01967149 C * IWIDE1(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25) 01968149 C DO 110 I = 1, KPRM 01969*99 C WRITE (6,111)I,(KDATA(J,I),J=1,6) 01970*99 C 110 CONTINUE 01971*99 C 111 FORMAT (1X,5HDATA ,I3,6(2X,I10)) 01972198 IPTR(1) = 500 01973*99 C RETURN 01974*99 PRINT *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE',01975*99 * ' B PLUS WIDTH CHANGES' 01976*99 END IF 01977*99 END IF 01978*99 IPTR(25) = IPTR(25) + 6 01979*99 C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC 01980*99 C IF TEXT EVENT, PROCESS TEXT 01981*99 C GET COMPRESSED VALUES 01982*99 C PRINT *,'COMPRESSED VALUES - NONTEXT' 01983*99 NRVALS = IDENT(14) 01984*99 IPTR(31) = IPTR(31) + 1 01985*99 KPRM = IPTR(31) + IPTR(24) 01986*99 IF (NBINC.NE.0) THEN 01987*99 CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,NRVALS) 01988*99 IPTR(25) = IPTR(25) + NBINC * NRVALS 01989*99 C RECALCULATE TO ORIGINAL VALUES 01990*99 DO 100 I = 1, NRVALS 01991*99 C PRINT *,IVALS(I),MSK(NBINC),NBINC 01992*99 IF (IVALS(I).GE.MSK(NBINC)) THEN 01993*92 KDATA(I,KPRM) = 999999 01994*99 ELSE 01995*99 IF (IRFVL1(2,J).EQ.0) THEN 01996*44 KDATA(I,KPRM) = IVALS(I) + LOWEST + IRFVL1(1,J)01997*44 ELSE 01998*99 KDATA(I,KPRM) = IVALS(I) + LOWEST + IRFVL1(3,J)01999*44 END IF 02000*99 END IF 02001*99 100 CONTINUE 02002*99 C PRINT *,I,JDESC,LOWEST,IRFVL1(1,J),IRFVL1(3,J) 02003*44 ELSE 02004*99 IF (LOWEST.EQ.MSK(JWIDE)) THEN 02005*26 DO 105 I = 1, NRVALS 02006*99 KDATA(I,KPRM) = 999999 02007*99 105 CONTINUE 02008*99 ELSE 02009*99 IF (IRFVL1(2,J).EQ.0) THEN 02010*44 ICOMB = LOWEST + IRFVL1(1,J) 02011*44 ELSE 02012*99 ICOMB = LOWEST + IRFVL1(3,J) 02013*44 END IF 02014*99 DO 106 I = 1, NRVALS 02015*99 KDATA(I,KPRM) = ICOMB 02016*99 106 CONTINUE 02017*99 END IF 02018*99 END IF 02019*99 C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25) 02020*99 MSTACK(1,KPRM) = JDESC 02021*99 IF (IPTR(27).NE.0) THEN 02022*99 MSTACK(2,KPRM) = IPTR(27) 02023*99 ELSE 02024*99 MSTACK(2,KPRM) = ISCAL1(J) 02025149 END IF 02026*99 C WRITE (6,80) (DATA(I,KPRM),I=1,10) 02027*99 C 80 FORMAT(2X,10(F10.2,1X)) 02028*99 ELSE IF (TEXT) THEN 02029*99 C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40) 02030*99 C GET LOWEST 02031*99 C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40)) 02032*99 DO 1906 K = 1, IPTR(40) 02033*99 CALL GBYTE (MSGA,KLOW,IPTR(25),8) 02034*99 IPTR(25) = IPTR(25) + 8 02035*99 IF (KLOW(K).NE.0) THEN 02036*99 IPTR(1) = 27 02037*99 PRINT *,'NON-ZERO LOWEST ON TEXT DATA' 02038*99 RETURN 02039*99 END IF 02040*99 1906 CONTINUE 02041*99 C GET NBINC 02042*99 CALL GBYTE (MSGA,NBINC,IPTR(25),6) 02043*99 C PRINT *,'NBINC =',NBINC 02044*99 IPTR(25) = IPTR(25) + 6 02045*99 IF (NBINC.NE.IPTR(40)) THEN 02046*99 IPTR(1) = 28 02047*99 PRINT *,'NBINC IS NOT THE NUMBER OF CHARACTERS',NBINC 02048*99 RETURN 02049*99 END IF 02050*99 C FOR NUMBER OF OBSERVATIONS 02051*99 IPTR(31) = IPTR(31) + 1 02052*99 KPRM = IPTR(31) + IPTR(24) 02053*99 ISTART = KPRM 02054*99 I24 = IPTR(24) 02055*99 DO 1900 N = 1, IDENT(14) 02056*99 KPRM = ISTART 02057*99 IPTR(24) = I24 02058*99 NBITS = IPTR(40) * 8 02059*99 1700 CONTINUE 02060*99 C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS 02061*99 IF (NBITS.GT.32) THEN 02062*99 CALL GBYTE (MSGA,IDATA,IPTR(25),32) 02063*99 IPTR(25) = IPTR(25) + 32 02064*99 NBITS = NBITS - 32 02065*99 C CONVERTS ASCII TO EBCIDIC 02066*99 C COMMENT OUT IF NOT IBM370 COMPUTER 02067*99 C PRINT *,IDATA 02068*99 C CALL W3AI39 (IDATA,4) 02069**2 MSTACK(1,KPRM) = JDESC 02070*99 MSTACK(2,KPRM) = 0 02071*99 KDATA(N,KPRM) = IDATA 02072*99 C SET FOR NEXT PART 02073*99 KPRM = KPRM + 1 02074*99 IPTR(24) = IPTR(24) + 1 02075*99 C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA 02076*99 C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,I12)02077198 GO TO 1700 02078*99 ELSE IF (NBITS.GT.0) THEN 02079*99 CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS) 02080*99 IPTR(25) = IPTR(25) + NBITS 02081*99 IBUF = (32 - NBITS) / 8 02082*99 IF (IBUF.GT.0) THEN 02083*99 DO 1750 MP = 1, IBUF 02084*99 IDATA = IDATA * 256 + 32 02085*99 1750 CONTINUE 02086*99 END IF 02087*99 C CONVERTS ASCII TO EBCIDIC 02088*99 C COMMENT OUT IF NOT IBM370 COMPUTER 02089*99 C CALL W3AI39 (IDATA,4) 02090**2 MSTACK(1,KPRM) = JDESC 02091*99 MSTACK(2,KPRM) = 0 02092*99 KDATA(N,KPRM) = IDATA 02093*99 C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS 02094*99 NBITS = 0 02095*99 END IF 02096*99 C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM) 02097*99 C1800 FORMAT (2X,I4,2X,3A4) 02098*99 1900 CONTINUE 02099*99 END IF 02100*99 RETURN 02101*99 END 02102*99 C ----------------------------------------------------- 02103*99 SUBROUTINE FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, 02104*78 * IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) 02105149 C$$$ S PROGRAM DOCUMENTATION BLOCK 02106*99 C . . . . 02107*99 C SUBPROGRAM: FI8804 PROCESS SERIAL DATA 02108*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 02109*99 C 02110*99 C ABSTRACT: PROCESS DATA THAT IS NOT COMPRESSED 02111*99 C 02112*99 C PROGRAM HISTORY LOG: 02113*99 C 88-09-01 CAVANAUGH 02114*99 C 91-01-18 CAVANAUGH MODIFIED TO PROPERLY HANDLE NON-COMPRESSED 02115*99 C DATA. 02116*99 C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE 02117*99 C MODIFIED TO HANDLE FIELD WIDTH IN BYTES. 02118*99 C 91-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED 02119*99 C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. 02120*99 C THIS HAS BEEN CORRECTED. 02121*99 C 02122*99 C USAGE: CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, 02123*78 C IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) 02124149 C INPUT ARGUMENT LIST: 02125*99 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK 02126*78 C MSGA - ARRAY CONTAINING BUFR MESSAGE 02127*99 C IVALS - ARRAY OF SINGLE PARAMETER VALUES 02128*99 C J - 02129*99 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE 02130*99 C CONTAINED IN A BUFR MESSAGE 02131*99 C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT 02132*99 C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE 02133*99 C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST 02134*99 C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE 02135*99 C 02136*99 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 02137*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 02138*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 02139*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 02140*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 02141*99 C ARGUMENT MAXD) 02142*99 C IVALS - SEE ABOVE 02143*99 C J - SEE ABOVE 02144*99 C ARRAYS CONTAINING DATA FROM TABLE B 02145*99 C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR 02146149 C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR 02147149 C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR 02148149 C 02149*99 C SUBPROGRAMS CALLED: 02150*99 C LIBRARY: 02151*99 C W3LIB - GBYTE 02152*99 C 02153*99 C REMARKS: ERROR RETURN: 02154*99 C IPTR(1) = 13 - BIT WIDTH ON ASCII CHARS NOT A MULTIPLE OF 8 02155*99 C 02156*99 C ATTRIBUTES: 02157*99 C LANGUAGE: FORTRAN 77 02158*99 C MACHINE: NAS 02159*99 C 02160*99 C$$$ 02161*99 SAVE 02162*99 C .................................................. 02163*41 C 02164*41 C NEW BASE TABLE B 02165*41 C MAY BE A COMBINATION OF MASTER TABLE B 02166*41 C AND ANCILLARY TABLE B 02167*41 C 02168*41 C INTEGER KFXY1(*) 02169*47 INTEGER ISCAL1(*) 02170*47 INTEGER IRFVL1(3,*) 02171*47 INTEGER IWIDE1(*) 02172*47 C CHARACTER*40 ANAME1(*) 02173*47 C CHARACTER*24 AUNIT1(*) 02174*47 C .................................................. 02175*41 C 02176*99 INTEGER MSGA(*),MAXD,MAXR 02177*41 INTEGER IPTR(*) 02178*41 INTEGER JDESC 02179*41 INTEGER IVALS(*) 02180*99 C INTEGER LSTBLK(3) 02181198 INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD) 02182*99 INTEGER J,LL 02183*99 C LOGICAL LKEY 02184198 C 02185*99 C 02186*99 INTEGER ITEST(32) 02187*94 DATA ITEST /1,3,7,15,31,63,127,255, 02188*99 * 511,1023,2047,4095,8191,16383, 02189*99 * 32767, 65535,131071,262143,524287, 02190*99 * 1048575,2097151,4194303,8388607, 02191*99 * 16777215,33554431,67108863,134217727, 02192*99 * 268435455,536870911,1073741823, 02193105 * 2147483647,-1/ 02194*94 C 02195*99 CALL W3FI01(LW) 02196105 IF (LW.NE.4) THEN 02197105 I = 2147483647 02198*99 ITEST(32) = I + I + 1 02199*99 END IF 02200*94 C 02201*94 C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25) 02202*78 C -------- NOCMP -------- 02203*99 C IF NOT TEXT EVENT, PROCESS 02204*99 IF (IPTR(18).EQ.0) THEN 02205*19 C PRINT *,' NOT TEXT' 02206*24 IF ((IPTR(26)+IWIDE1(J)).LT.1) THEN 02207*68 PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25)02208105 IPTR(1) = 501 02209*68 RETURN 02210*68 END IF 02211*68 C ISOLATE BIT WIDTH 02212131 JWIDE = IWIDE1(J) + IPTR(26) 02213131 C IF ASSOCIATED FIELD SW ON 02214*99 IF (IPTR(29).GT.0) THEN 02215*99 IF (JDESC.NE.7957.AND.JDESC.NE.7937) THEN 02216*99 IPTR(31) = IPTR(31) + 1 02217*99 KPRM = IPTR(31) + IPTR(24) 02218*99 MSTACK(1,KPRM) = 33792 + IPTR(29) 02219*99 MSTACK(2,KPRM) = 0 02220*99 CALL GBYTE (MSGA,IVALS,IPTR(25),IPTR(29)) 02221*99 IPTR(25) = IPTR(25) + IPTR(29) 02222*99 KDATA(IPTR(17),KPRM) = IVALS(1) 02223*99 C PRINT *,'FI8804-A',KPRM,MSTACK(1,KPRM), 02224*78 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)02225*99 END IF 02226*99 END IF 02227*99 IPTR(31) = IPTR(31) + 1 02228*99 KPRM = IPTR(31) + IPTR(24) 02229*99 MSTACK(1,KPRM) = JDESC 02230*99 IF (IPTR(27).NE.0) THEN 02231*99 MSTACK(2,KPRM) = IPTR(27) 02232*99 ELSE 02233*99 MSTACK(2,KPRM) = ISCAL1(J) 02234149 END IF 02235*99 C GET VALUES 02236*99 C CALL TO GET DATA OF GIVEN BIT WIDTH 02237*99 CALL GBYTE (MSGA,IVALS,IPTR(25),JWIDE) 02238*99 C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25) 02239*99 IPTR(25) = IPTR(25) + JWIDE 02240*99 C RETURN WITH SINGLE VALUE 02241*99 IF (JWIDE.EQ.32) THEN 02242*94 IF (IVALS(1).EQ.ITEST(JWIDE)) THEN 02243*94 KDATA(IPTR(17),KPRM) = 999999 02244*94 ELSE 02245*94 IF (IRFVL1(2,J).EQ.0) THEN 02246*94 KDATA(IPTR(17),KPRM) = IVALS(1) + IRFVL1(1,J) 02247*94 ELSE 02248*94 KDATA(IPTR(17),KPRM) = IVALS(1) + IRFVL1(3,J) 02249*94 END IF 02250*94 END IF 02251*94 ELSE IF (IVALS(1).GE.ITEST(JWIDE)) THEN 02252*94 KDATA(IPTR(17),KPRM) = 999999 02253*94 ELSE 02254*99 IF (IRFVL1(2,J).EQ.0) THEN 02255*44 KDATA(IPTR(17),KPRM) = IVALS(1) + IRFVL1(1,J) 02256*44 ELSE 02257*99 KDATA(IPTR(17),KPRM) = IVALS(1) + IRFVL1(3,J) 02258*44 END IF 02259*99 END IF 02260*99 C PRINT *,'FI8804-B',KPRM,MSTACK(1,KPRM), 02261*78 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM) 02262*99 C IF(JDESC.EQ.2049) THEN 02263*99 C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM) 02264*99 C END IF 02265*99 C PRINT *,'FI8804 ',KPRM,MSTACK(1,KPRM), 02266*78 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) 02267*99 ELSE 02268*99 C PRINT *,' TEXT' 02269*28 C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********' 02270*23 JWIDE = IPTR(40) * 8 02271131 C PRINT *,' WIDTH =',JWIDE,IPTR(40)02272*28 NRCHRS = IPTR(40) 02273*13 NRBITS = JWIDE 02274*13 C PRINT *,' CHARS =',NRCHRS,' BITS =',NRBITS 02275*23 IPTR(31) = IPTR(31) + 1 02276*99 KANY = 0 02277*99 1800 CONTINUE 02278*99 KANY = KANY + 1 02279*99 C PRINT *,' NR BITS THIS PASS',NRBITS 02280*30 IF (NRBITS.GT.32) THEN 02281*99 CALL GBYTE (MSGA,IDATA,IPTR(25),32) 02282*99 C PRINT 1801,KANY,IDATA,IPTR(17),KPRM,NRBITS 02283*28 1801 FORMAT (1X,I2,4X,Z8,2(4X,I4)) 02284*22 C CONVERTS ASCII TO EBCIDIC 02285*99 C COMMENT OUT IF NOT IBM370 COMPUTER 02286*99 C CALL W3AI39 (IDATA,4) 02287**2 KPRM = IPTR(31) + IPTR(24) 02288*99 KDATA(IPTR(17),KPRM) = IDATA 02289*99 MSTACK(1,KPRM) = JDESC 02290*99 MSTACK(2,KPRM) = 0 02291*99 C PRINT *,'BODY ',KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM), 02292*22 C * KDATA(IPTR(17),KPRM) 02293*22 IPTR(25) = IPTR(25) + 32 02294*99 NRBITS = NRBITS - 32 02295*99 IPTR(24) = IPTR(24) + 1 02296*99 GO TO 1800 02297*99 ELSE IF (NRBITS.GT.0) THEN 02298*99 CALL GBYTE (MSGA,IDATA,IPTR(25),NRBITS) 02299*99 IPTR(25) = IPTR(25) + NRBITS 02300*99 C CONVERTS ASCII TO EBCIDIC 02301*99 C COMMENT OUT IF NOT IBM370 COMPUTER 02302*99 C CALL W3AI39 (IDATA,4) 02303**2 KPRM = IPTR(31) + IPTR(24) 02304*99 KSHFT = 32 - NRBITS 02305*99 IF (KSHFT.GT.0) THEN 02306*99 KTRY = KSHFT / 8 02307*99 DO 1722 LAK = 1, KTRY 02308*99 IDATA = IDATA * 256 + 64 02309*99 C PRINT 1723,IDATA 02310*99 C1723 FORMAT (12X,Z8) 02311198 1722 CONTINUE 02312*99 END IF 02313*99 KDATA(IPTR(17),KPRM) = IDATA 02314*99 C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM 02315*28 MSTACK(1,KPRM) = JDESC 02316*99 MSTACK(2,KPRM) = 0 02317*99 C PRINT *,'TAIL ',KPRM,MSTACK(1,KPRM), 02318*22 C * KDATA(IPTR(17),KPRM) 02319*22 END IF 02320*99 END IF 02321*99 RETURN 02322*99 END 02323*99 C ----------------------------------------------------- 02324*99 SUBROUTINE FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY, 02325*78 * KDATA,LL,KNR,MSTACK,MAXR,MAXD) 02326*99 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 02327*99 C . . . . 02328*99 C SUBPROGRAM: FI8805 PROCESS A REPLICATION DESCRIPTOR 02329*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 02330*99 C 02331*99 C ABSTRACT: PROCESS A REPLICATION DESCRIPTOR, MUST EXTRACT NUMBER 02332*99 C OF REPLICATIONS OF N DESCRIPTORS FROM THE DATA STREAM. 02333*99 C 02334*99 C PROGRAM HISTORY LOG: 02335*99 C 88-09-01 CAVANAUGH 02336*99 C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE 02337*99 C 02338*99 C USAGE: CALL FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY, 02339*78 C * KDATA,LL,KNR,MSTACK,MAXR,MAXD) 02340*99 C INPUT ARGUMENT LIST: 02341*99 C IWORK - WORKING DESCRIPTOR LIST 02342*99 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK 02343*78 C IDENT - SEE W3FI88 ROUTINE DOCBLOCK 02344*78 C LX - X PORTION OF CURRENT DESCRIPTOR 02345*99 C LY - Y PORTION OF CURRENT DESCRIPTOR 02346*99 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE 02347*99 C CONTAINED IN A BUFR MESSAGE 02348*99 C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT 02349*99 C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE 02350*99 C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST 02351*99 C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE 02352*99 C 02353*99 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 02354*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 02355*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 02356*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 02357*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 02358*99 C ARGUMENT MAXD) 02359*99 C LX - SEE ABOVE 02360*99 C LY - SEE ABOVE 02361*99 C 02362*99 C SUBPROGRAMS CALLED: 02363*99 C LIBRARY: 02364*99 C W3LIB - GBYTES FI8808 02365*78 C 02366*99 C REMARKS: ERROR RETURN: 02367*99 C IPTR(1) = 12 DATA DESCRIPTOR QUALIFIER DOES NOT FOLLOW 02368*99 C DELAYED REPLICATION DESCRIPTOR 02369*99 C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS 02370*99 C 02371*99 C ATTRIBUTES: 02372*99 C LANGUAGE: FORTRAN 77 02373*99 C MACHINE: NAS 02374*99 C 02375*99 C$$$ 02376*99 SAVE 02377*99 C 02378*99 INTEGER IPTR(*) 02379*99 INTEGER KNR(MAXR) 02380*99 INTEGER ITEMP(2000) 02381*99 INTEGER LL 02382*99 INTEGER KTEMP(2000) 02383*99 INTEGER KDATA(MAXR,MAXD) 02384*99 INTEGER LX,MSTACK(2,MAXD) 02385*99 INTEGER LY 02386*99 INTEGER MSGA(*) 02387*99 INTEGER KVALS(1000) 02388*99 INTEGER IWORK(MAXD) 02389*99 INTEGER IDENT(*) 02390*99 C 02391*99 C PRINT *,' REPLICATION FI8805' 02392*78 C DO 100 I = 1, IPTR(13) 02393*99 C PRINT *,I,IWORK(I) 02394*99 C 100 CONTINUE 02395*99 C NUMBER OF DESCRIPTORS 02396*99 NRSET = LX 02397*99 C NUMBER OF REPLICATIONS 02398*99 NRREPS = LY 02399*99 ICURR = IPTR(11) - 1 02400*99 IPICK = IPTR(11) - 1 02401*99 C 02402*99 IF (NRREPS.EQ.0) THEN 02403*99 IPTR(39) = 1 02404*99 C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR 02405*99 C IPTR(31) = IPTR(31) + 1 02406*99 C KPRM = IPTR(31) + IPTR(24) 02407*99 C MSTACK(1,KPRM) = JDESC 02408*99 C MSTACK(2,KPRM) = 0 02409*99 C KDATA(IPTR(17),KPRM) = 0 02410*99 C PRINT *,'FI8805-1',KPRM,MSTACK(1,KPRM), 02411*78 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) 02412*99 C DELAYED REPLICATION - MUST GET NUMBER OF 02413*99 C REPLICATIONS FROM DATA. 02414*99 C GET NEXT DESCRIPTOR 02415*99 CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) 02416*78 C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC 02417*99 C MUST BE DATA DESCRIPTION 02418*99 C OPERATION QUALIFIER 02419*99 IF (JDESC.EQ.7937.OR.JDESC.EQ.7947) THEN 02420*99 JWIDE = 8 02421*99 ELSE IF (JDESC.EQ.7938.OR.JDESC.EQ.7948) THEN 02422*99 JWIDE = 16 02423*99 ELSE 02424*99 IPTR(1) = 12 02425*99 RETURN 02426*99 END IF 02427*99 C THIS IF BLOCK IS SET TO HANDLE 02428*99 C DATA/DESCRIPTOR REPLICATION 02429*99 IF (JDESC.EQ.7947.OR.JDESC.EQ.7948) THEN 02430*99 C SET DATA/DESCRIPTOR REPLICATION FLAG = ON 02431*99 IPTR(38) = 1 02432*99 C SAVE AS NEXT ENTRY IN KDATA, MSTACK 02433*99 IPTR(31) = IPTR(31) + 1 02434*99 KPRM = IPTR(31) + IPTR(24) 02435*99 MSTACK(1,KPRM) = JDESC 02436*99 MSTACK(2,KPRM) = 0 02437*99 CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE) 02438*99 IPTR(25) = IPTR(25) + JWIDE 02439*99 KDATA(IPTR(17),KPRM) = KVALS(1) 02440*99 RETURN 02441*99 END IF 02442*99 02443*99 C SET SINGLE VALUE FOR SEQUENTIAL, 02444*99 C MULTIPLE VALUES FOR COMPRESSED 02445*99 IF (IDENT(16).EQ.0) THEN 02446*99 02447*99 C NON COMPRESSED 02448*99 CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE) 02449*99 C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1) 02450250 IPTR(25) = IPTR(25) + JWIDE 02451*99 IPTR(31) = IPTR(31) + 1 02452*99 KPRM = IPTR(31) + IPTR(24) 02453*99 MSTACK(1,KPRM) = JDESC 02454*99 MSTACK(2,KPRM) = 0 02455*99 KDATA(IPTR(17),KPRM) = KVALS(1) 02456*99 NRREPS = KVALS(1) 02457*99 C PRINT *,'FI8805-2',KPRM,MSTACK(1,KPRM), 02458*78 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) 02459*99 ELSE 02460*99 NRVALS = IDENT(14) 02461*99 CALL GBYTES (MSGA,KVALS,IPTR(25),JWIDE,0,NRVALS) 02462*99 IPTR(25) = IPTR(25) + JWIDE * NRVALS 02463*99 IPTR(31) = IPTR(31) + 1 02464*99 KPRM = IPTR(31) + IPTR(24) 02465*99 MSTACK(1,KPRM) = JDESC 02466*99 MSTACK(2,KPRM) = 0 02467*99 KDATA(IPTR(17),KPRM) = KVALS(1) 02468*99 DO 100 I = 1, NRVALS 02469*99 KDATA(I,KPRM) = KVALS(I) 02470*99 100 CONTINUE 02471*99 NRREPS = KVALS(1) 02472*99 END IF 02473*99 ELSE 02474*99 C PRINT *,'NOT DELAYED REPLICATION' 02475*99 END IF 02476*99 C RESTRUCTURE WORKING STACK W/REPLICATIONS 02477*99 IF (NRREPS.EQ.0) THEN 02478237 C PRINT *,'RESTRUCTURING - NO REPLICATION' 02479246 IPTR(11) = IPICK + NRSET + 2 02480244 GO TO 9999 02481231 END IF C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS' 02483*99 C PICK UP DESCRIPTORS TO BE REPLICATED 02484*99 DO 1000 I = 1, NRSET 02485*99 CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) 02486*78 ITEMP(I) = JDESC 02487*99 C PRINT *,'REPLICATION ',I,ITEMP(I) 02488*99 1000 CONTINUE 02489*99 C MOVE TRAILING DESCRIPTORS TO HOLD AREA 02490*99 LAX = IPTR(12) - IPTR(11) + 1 02491*99 C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12)02492*99 DO 2000 I = 1, LAX 02493*99 CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) 02494*78 KTEMP(I) = JDESC 02495*99 C PRINT *,' ',I,KTEMP(I) 02496*99 2000 CONTINUE 02497*99 C REPLICATIONS INTO ISTACK 02498*99 C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES' 02499*99 C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR 02500*99 DO 4000 I = 1, NRREPS 02501*99 DO 3000 J = 1, NRSET 02502*99 IWORK(ICURR) = ITEMP(J) 02503*99 C PRINT *,'FI8805 A',ICURR,IWORK(ICURR) 02504*78 ICURR = ICURR + 1 02505*99 3000 CONTINUE 02506*99 4000 CONTINUE 02507*99 C PRINT *,' TO LOC',ICURR-1 02508*99 C RESTORE TRAILING DESCRIPTORS 02509*99 C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR 02510*99 DO 5000 I = 1, LAX 02511232 IWORK(ICURR) = KTEMP(I) 02512232 C PRINT *,'FI8805 B',ICURR,IWORK(ICURR) 02513*78 ICURR = ICURR + 1 02514232 5000 CONTINUE 02515232 IPTR(12) = ICURR - 1 02516*99 IPTR(11) = IPICK 02517*99 9999 CONTINUE 02518231 C DO 5500 I = 1, IPTR(12) 02519246 C PRINT *,'FI8805 B',I,IWORK(I),IPTR(11) 02520*78 C5500 CONTINUE 02521246 RETURN 02522*99 END 02523*99 SUBROUTINE FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, 02524*78 * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD) 02525161 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 02526*99 C . . . . 02527*99 C SUBPROGRAM: FI8806 PROCESS OPERATOR DESCRIPTORS 02528*78 C PRGMMR: CAVANAUGH ORG: W/NMCX42 DATE: 88-09-01 02529*99 C 02530*99 C ABSTRACT: EXTRACT AND SAVE INDICATED CHANGE VALUES FOR USE 02531*99 C UNTIL CHANGES ARE RESCINDED, OR EXTRACT TEXT STRINGS INDICATED 02532*99 C THROUGH 2 05 YYY. 02533*99 C 02534*99 C PROGRAM HISTORY LOG: 02535*99 C 88-09-01 CAVANAUGH 02536*99 C 91-04-04 CAVANAUGH MODIFIED TO HANDLE DESCRIPTOR 2 05 YYY 02537*99 C 91-05-10 CAVANAUGH CODING HAS BEEN ADDED TO PROCESS PROPERLY 02538164 C TABLE C DESCRIPTOR 2 06 YYY. 02539*99 C 91-11-21 CAVANAUGH CODING HAS BEEN ADDED TO PROPERLY PROCESS 02540*99 C TABLE C DESCRIPTOR 2 03 YYY, THE CHANGE 02541*99 C TO NEW REFERENCE VALUE FOR SELECTED 02542*99 C DESCRIPTORS. 02543*99 C 02544*99 C USAGE: CALL FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, 02545*78 C * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD) 02546149 C INPUT ARGUMENT LIST: 02547*99 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK 02548*78 C LX - X PORTION OF CURRENT DESCRIPTOR 02549*99 C LY - Y PORTION OF CURRENT DESCRIPTOR 02550*99 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE 02551*99 C CONTAINED IN A BUFR MESSAGE 02552*99 C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT 02553*99 C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE 02554*99 C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST 02555*99 C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE 02556*99 C 02557*99 C OUTPUT ARGUMENT LIST: 02558*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 02559*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 02560*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 02561*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 02562*99 C ARGUMENT MAXD) 02563*99 C ARRAYS CONTAINING DATA FROM TABLE B 02564*99 C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR 02565149 C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR 02566149 C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR 02567149 C 02568*99 C REMARKS: ERROR RETURN: 02569*99 C IPTR(1) = 5 - ERRONEOUS X VALUE IN DATA DESCRIPTOR OPERATOR 02570*99 C 02571*99 C ATTRIBUTES: 02572*99 C LANGUAGE: FORTRAN 77 02573*99 C MACHINE: NAS 02574*99 C 02575*99 C$$$ 02576*99 SAVE 02577*99 C .................................................. 02578*41 C 02579*41 C NEW BASE TABLE B 02580*41 C MAY BE A COMBINATION OF MASTER TABLE B 02581*41 C AND ANCILLARY TABLE B 02582*41 C 02583*41 INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) 02584*44 C CHARACTER*40 ANAME1(*) 02585*47 C CHARACTER*24 AUNIT1(*) 02586*47 C .................................................. 02587*41 INTEGER IPTR(*),KDATA(MAXR,MAXD),IVALS(*) 02588*99 INTEGER IDENT(*),IWORK(*) 02589*99 INTEGER MSGA(*),MSTACK(2,MAXD) 02590*99 INTEGER J,JDESC 02591*99 INTEGER LL 02592*99 INTEGER LX 02593*99 INTEGER LY 02594*99 C 02595*99 C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR' 02596*99 IF (LX.EQ.1) THEN 02597*99 C CHANGE BIT WIDTH 02598*99 IF (LY.EQ.0) THEN 02599*99 C PRINT *,' RETURN TO NORMAL WIDTH' 02600*99 IPTR(26) = 0 02601*99 ELSE 02602*99 C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS' 02603*99 IPTR(26) = LY - 128 02604*99 END IF 02605*99 ELSE IF (LX.EQ.2) THEN 02606*99 C CHANGE SCALE 02607*99 IF (LY.EQ.0) THEN 02608*99 C RESET TO STANDARD SCALE 02609*99 IPTR(27) = 0 02610*99 ELSE 02611*99 C SET NEW SCALE 02612*99 IPTR(27) = LY - 128 02613*99 END IF 02614*99 ELSE IF (LX.EQ.3) THEN 02615*99 C CHANGE REFERENCE VALUE 02616*99 C FOR EACH OF THOSE DESCRIPTORS BETWEEN 02617*99 C 2 03 YYY WHERE Y LT 255 AND 02618*99 C 2 03 255, EXTRACT THE NEW REFERENCE 02619*99 C VALUE (BIT WIDTH YYY) AND PLACE 02620*99 C IN TERTIARY TABLE B REF VAL POSITION, 02621*99 C SET FLAG IN SECONDARY REFVAL POSITION 02622*99 C THOSE DESCRIPTORS DO NOT HAVE DATA 02623*99 C ASSOCIATED WITH THEM, BUT ONLY 02624*99 C IDENTIFY THE TABLE B ENTRIES THAT 02625*99 C ARE GETTING NEW REFERENCE VALUES. 02626*99 KYYY = LY 02627*99 IF (KYYY.GT.0.AND.KYYY.LT.255) THEN 02628*99 C START CYCLING THRU DESCRIPTORS UNTIL 02629*99 C TERMINATE NEW REF VALS IS FOUND 02630*99 300 CONTINUE 02631*99 CALL FI8808 (IPTR,IWORK,LF,LX,LY,JDESC) 02632*78 IF (JDESC.EQ.33791) THEN 02633*99 C IF 2 03 255 THEN RETURN 02634*99 RETURN 02635*99 ELSE 02636*99 C FIND MATCHING TABLE B ENTRY 02637*99 DO 500 LJ = 1, IPTR(21) 02638**2 IF (JDESC.EQ.KFXY1(LJ)) THEN 02639149 C TURN ON NEW REF VAL FLAG 02640*99 IRFVL1(2,LJ) = 1 02641*44 C INSERT NEW REF VAL 02642*99 CALL GBYTE (MSGA,IRFVL1(3,LJ),IPTR(25),KYYY) 02643*44 C GO GET NEXT DESCRIPTOR 02644*99 GO TO 300 02645*99 END IF 02646*99 500 CONTINUE 02647*99 C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR 02648*99 PRINT *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND' 02649*99 STOP 203 02650*99 END IF 02651*99 ELSE IF (KYYY.EQ.0) THEN 02652*99 C MUST TURN OFF ALL NEW 02653*99 C REFERENCE VALUES 02654*99 DO 400 I = 1, IPTR(21) 02655**2 IRFVL1(2,I) = 0 02656*44 400 CONTINUE 02657*99 END IF 02658*99 C LX = 3 02659*99 C MUST BE CONCLUDED WITH Y=255 02660*99 ELSE IF (LX.EQ.4) THEN 02661*99 C ASSOCIATED VALUES 02662*99 IF (LY.EQ.0) THEN 02663*99 IPTR(29) = 0 02664*99 C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29) 02665*99 ELSE 02666*99 IPTR(29) = LY 02667*99 IF (IWORK(IPTR(11)).NE.7957) THEN 02668*99 PRINT *,'2 04 YYY NOT FOLLOWED BY 0 31 021' 02669*99 IPTR(1) = 11 02670*99 END IF 02671*99 C PRINT *,'SET ASSOCIATED VALUES',IPTR(29) 02672*99 END IF 02673*99 ELSE IF (LX.EQ.5) THEN 02674*99 C PROCESS TEXT DATA 02675*99 IPTR(40) = LY 02676*99 IPTR(18) = 1 02677*99 IF (IDENT(16).EQ.0) THEN 02678*99 C PRINT *,'2 05 YYY - TEXT - NONCOMPRESSED MODE' 02679*99 CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, 02680*78 * IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) 02681149 ELSE 02682*99 C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE' 02683*99 CALL FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, 02684*78 * IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD) 02685149 IF (IPTR(1).NE.0) THEN 02686*99 RETURN 02687*99 END IF 02688*99 ENDIF 02689*99 IPTR(18) = 0 02690*99 ELSE IF (LX.EQ.6) THEN 02691*99 C SKIP NEXT DESCRIPTOR 02692*99 C SET TO PASS OVER DESCRIPTOR AND DATA 02693*99 C IF DESCRIPTOR NOT IN TABLE B 02694*99 IPTR(36) = LY 02695*99 C PRINT *,'SET TO SKIP',LY,' BIT FIELD' 02696*99 IPTR(31) = IPTR(31) + 1 02697*99 KPRM = IPTR(31) + IPTR(24) 02698*99 MSTACK(1,KPRM) = 34304 + LY 02699*99 MSTACK(2,KPRM) = 0 02700*99 ELSE 02701*99 IPTR(1) = 5 02702*99 ENDIF 02703*99 RETURN 02704*99 END 02705*99 SUBROUTINE FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC) 02706*78 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 02707*99 C . . . . 02708*99 C SUBPROGRAM: FI8807 PROCESS QUEUE DESCRIPTOR 02709*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 02710*99 C 02711*99 C ABSTRACT: SUBSTITUTE DESCRIPTOR QUEUE FOR QUEUE DESCRIPTOR 02712*99 C 02713*99 C PROGRAM HISTORY LOG: 02714*99 C 88-09-01 CAVANAUGH 02715*99 C 91-04-17 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS 02716*99 C 91-05-28 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS 02717*99 C BASED ON TESTS WITH LIVE DATA. 02718*99 C 02719*99 C USAGE: CALL FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC) 02720*78 C INPUT ARGUMENT LIST: 02721*99 C IWORK - WORKING DESCRIPTOR LIST 02722*99 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK 02723*78 C LAST - INDEX TO LAST DESCRIPTOR 02724*99 C ITBLD - ARRAY CONTAINING DESCRIPTOR QUEUES 02725*99 C JDESC - QUEUE DESCRIPTOR TO BE EXPANDED 02726*99 C 02727*99 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 02728*99 C ISTACK - SEE ABOVE 02729*99 C 02730*99 C SUBPROGRAMS CALLED: 02731*99 C LIBRARY: 02732*99 C W3LIB - NONE 02733*99 C 02734*99 C ATTRIBUTES: 02735*99 C LANGUAGE: FORTRAN 77 02736*99 C MACHINE: NAS 02737*99 C 02738*99 C$$$ 02739*99 SAVE 02740*99 C .................................................. 02741*41 C 02742*41 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE 02743*41 C 02744*41 INTEGER ITBLD2(14,*) 02745*76 C .................................................. 02746*42 C 02747*42 C NEW BASE TABLE D 02748*42 C 02749*42 INTEGER ITBLD(14,*) 02750*76 C .................................................. 02751*42 C 02752*99 INTEGER IPTR(*),JDESC 02753*99 INTEGER IWORK(*),IHOLD(3000) 02754*39 C 02755*99 C PRINT *,' FI8807 F3 ENTRY',IPTR(11),IPTR(12) 02756*78 C SET FOR BINARY SEARCH IN TABLE D 02757*99 JLO = 1 02758*99 JHI = IPTR(20) 02759*99 C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC,IPTR(11),IPTR(12) 02760*59 10 CONTINUE 02761*99 JMID = (JLO + JHI) / 2 02762*99 C PRINT *,JLO,ITBLD(1,JLO),JMID,ITBLD(1,JMID),JHI,ITBLD(1,JHI) 02763*57 C 02764*99 IF (JDESC.LT.ITBLD(1,JMID)) THEN 02765*48 IF (JDESC.EQ.ITBLD(1,JLO)) THEN 02766*48 JMID = JLO 02767*99 GO TO 100 02768*99 ELSE 02769*99 JLO = JLO + 1 02770*99 JHI = JMID - 1 02771*99 IF (JLO.GT.JMID) THEN 02772*99 C PRINT *,'FI8807-1 > IPTR(1)=4' 02773*78 IPTR(1) = 4 02774*99 RETURN 02775*99 END IF 02776*99 GO TO 10 02777*99 END IF 02778*99 ELSE IF (JDESC.GT.ITBLD(1,JMID)) THEN 02779*48 IF (JDESC.EQ.ITBLD(1,JHI)) THEN 02780*48 JMID = JHI 02781*99 GO TO 100 02782*99 ELSE 02783*99 JLO = JMID + 1 02784*99 JHI = JHI - 1 02785*99 IF (JLO.GT.JHI) THEN 02786*99 C PRINT *,'FI8807-2 > IPTR(1)=4' 02787*78 IPTR(1) = 4 02788*99 RETURN 02789*99 END IF 02790*99 GO TO 10 02791*99 END IF 02792*99 END IF 02793*99 100 CONTINUE 02794*99 C HAVE TABLE D MATCH 02795*99 C PRINT *,'D ',(ITBLD(LL,JMID),LL=1,14) 02796*76 C PRINT *,'TABLE D TO IHOLD' 02797*99 IK = 0 02798*99 JK = 0 02799*99 DO 200 KI = 2, 14 02800*76 IF (ITBLD(KI,JMID).NE.0) THEN 02801*48 IK = IK + 1 02802*99 IHOLD(IK) = ITBLD(KI,JMID) 02803*48 C PRINT *,IK,IHOLD(IK) 02804*99 ELSE 02805*99 GO TO 300 02806*99 END IF 02807*99 200 CONTINUE 02808*99 300 CONTINUE 02809*99 KK = IPTR(11) 02810*99 IF (KK.GT.IPTR(12)) THEN 02811*99 C NOTHING MORE TO APPEND 02812*99 C PRINT *,'NOTHING MORE TO APPEND' 02813*99 ELSE 02814*99 C APPEND TRAILING IWORK TO IHOLD 02815*99 C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12) 02816*99 DO 500 I = KK, IPTR(12) 02817*99 IK = IK + 1 02818*99 IHOLD(IK) = IWORK(I) 02819*99 500 CONTINUE 02820*99 END IF 02821*99 C RESET IHOLD TO IWORK 02822*99 C PRINT *,' RESET IWORK STACK' 02823*99 KK = IPTR(11) - 2 02824*99 DO 1000 I = 1, IK 02825*99 KK = KK + 1 02826*99 IWORK(KK) = IHOLD(I) 02827*99 1000 CONTINUE 02828*99 IPTR(12) = KK 02829*99 C PRINT *,' FI8807 F3 EXIT ',IPTR(11),IPTR(12) 02830*78 C DO 2000 I = 1, IPTR(12) 02831*99 C PRINT *,'EXIT IWORK',I,IWORK(I) 02832*99 C2000 CONTINUE 02833*99 C RESET POINTERS 02834*99 IPTR(11) = IPTR(11) - 1 02835*99 RETURN 02836*99 END 02837*99 C ----------------------------------------------------- 02838*99 SUBROUTINE FI8808(IPTR,IWORK,LF,LX,LY,JDESC) 02839*78 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 02840*99 C . . . . 02841*99 C SUBPROGRAM: FI8808 02842*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 89-01-17 02843*99 C 02844*99 C ABSTRACT: 02845*99 C 02846*99 C PROGRAM HISTORY LOG: 02847*99 C 88-09-01 CAVANAUGH 02848*99 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE 02849*99 C 02850*99 C USAGE: CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) 02851*78 C INPUT ARGUMENT LIST: 02852*99 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK 02853*78 C IWORK - WORKING DESCRIPTOR LIST 02854*99 C 02855*99 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 02856*99 C IPTR - SEE ABOVE 02857*99 C 02858*99 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION 02859*99 C 02860*99 C ATTRIBUTES: 02861*99 C LANGUAGE: FORTRAN 77 02862*99 C MACHINE: NAS 02863*99 C 02864*99 C$$$ 02865*99 SAVE 02866*99 INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC 02867*99 C 02868*99 C PRINT *,' FI8808 NEW DESCRIPTOR PICKUP' 02869*78 JDESC = IWORK(IPTR(11)) 02870*99 LY = MOD(JDESC,256) 02871*99 IPTR(34) = LY 02872*99 LX = MOD((JDESC/256),64) 02873*99 IPTR(33) = LX 02874*99 LF = JDESC / 16384 02875*99 IPTR(32) = LF 02876*99 C PRINT *,' TEST DESCRIPTOR',LF,LX,LY,' AT',IPTR(11) 02877246 IPTR(11) = IPTR(11) + 1 02878*99 RETURN 02879*99 END 02880*99 SUBROUTINE FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) 02881*78 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 02882*99 C . . . . 02883*99 C SUBPROGRAM: FI8809 REFORMAT PROFILER W HGT INCREMENTS 02884*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 90-02-14 02885*99 C 02886*99 C ABSTRACT: REFORMAT DECODED PROFILER DATA TO SHOW HEIGHTS INSTEAD OF 02887*99 C HEIGHT INCREMENTS. 02888*99 C 02889*99 C PROGRAM HISTORY LOG: 02890*99 C 90-02-14 CAVANAUGH 02891*99 C 02892*99 C USAGE: CALL FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) 02893*78 C INPUT ARGUMENT LIST: 02894*99 C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM 02895*99 C BUFR MESSAGE - 02896*99 C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) 02897*99 C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) 02898*99 C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) 02899*99 C IDENT( 4)- (BYTE 8, SECTION 1) 02900*99 C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) 02901*99 C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) 02902*99 C IDENT( 7)- (BYTES 11-12, SECTION 1) 02903*99 C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) 02904*99 C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) 02905*99 C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) 02906*99 C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) 02907*99 C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) 02908*99 C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) 02909*99 C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) 02910*99 C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) 02911*99 C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) 02912*99 C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR 02913*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 02914*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 02915*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 02916*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 02917*99 C ARGUMENT MAXD) 02918*99 C KSET2 - INTERIM DATA ARRAY 02919*99 C KPROFL - INTERIM DESCRIPTOR ARRAY 02920*99 C IPTR - SEE W3FI88 02921*78 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE 02922*99 C CONTAINED IN A BUFR MESSAGE 02923*99 C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT 02924*99 C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE 02925*99 C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST 02926*99 C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE 02927*99 C 02928*99 C OUTPUT FILES: 02929*99 C 02930*99 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION 02931*99 C 02932*99 C ATTRIBUTES: 02933*99 C LANGUAGE: FORTRAN 77 02934*99 C MACHINE: NAS 02935*99 C 02936*99 C$$$ 02937*99 SAVE 02938*99 C ---------------------------------------------------------------- 02939*99 C 02940*99 INTEGER ISW 02941*99 INTEGER IDENT(*),KDATA(MAXR,MAXD) 02942*99 INTEGER MSTACK(2,MAXD),IPTR(*) 02943*99 INTEGER KPROFL(1700) 02944*99 INTEGER KPROF2(1700) 02945*99 INTEGER KSET2(1700) 02946*99 C 02947*99 C ---------------------------------------------------------- 02948*99 C PRINT *,'FI8809' 02949*78 C LOOP FOR NUMBER OF SUBSETS/REPORTS 02950*99 DO 3000 I = 1, IDENT(14) 02951*99 C INIT FOR DATA INPUT ARRAY 02952*99 MK = 1 02953*99 C INIT FOR DESC OUTPUT ARRAY 02954*99 JK = 0 02955*99 C LOCATION 02956*99 ISW = 0 02957*99 DO 200 J = 1, 3 02958*99 C LATITUDE 02959*99 IF (MSTACK(1,MK).EQ.1282) THEN 02960*99 ISW = ISW + 1 02961*99 GO TO 100 02962*99 C LONGITUDE 02963*99 ELSE IF (MSTACK(1,MK).EQ.1538) THEN 02964*99 ISW = ISW + 2 02965*99 GO TO 100 02966*99 C HEIGHT ABOVE SEA LEVEL 02967*99 ELSE IF (MSTACK(1,MK).EQ.1793) THEN 02968*99 IHGT = KDATA(I,MK) 02969*99 ISW = ISW + 4 02970*99 GO TO 100 02971*99 END IF 02972*99 GO TO 200 02973*99 100 CONTINUE 02974*99 JK = JK + 1 02975*99 C SAVE DESCRIPTOR 02976*99 KPROFL(JK) = MSTACK(1,MK) 02977*99 C SAVE SCALE 02978*99 KPROF2(JK) = MSTACK(2,MK) 02979*99 C SAVE DATA 02980*99 KSET2(JK) = KDATA(I,MK) 02981*99 MK = MK + 1 02982*99 200 CONTINUE 02983*99 IF (ISW.NE.7) THEN 02984*99 PRINT *,'LOCATION ERROR PROCESSING PROFILER' 02985*99 IPTR(1) = 200 02986*99 RETURN 02987*99 END IF 02988*99 C TIME 02989*99 ISW = 0 02990*99 DO 400 J = 1, 7 02991*99 C YEAR 02992*99 IF (MSTACK(1,MK).EQ.1025) THEN 02993*99 ISW = ISW + 1 02994*99 GO TO 300 02995*99 C MONTH 02996*99 ELSE IF (MSTACK(1,MK).EQ.1026) THEN 02997*99 ISW = ISW + 2 02998*99 GO TO 300 02999*99 C DAY 03000*99 ELSE IF (MSTACK(1,MK).EQ.1027) THEN 03001*99 ISW = ISW + 4 03002*99 GO TO 300 03003*99 C HOUR 03004*99 ELSE IF (MSTACK(1,MK).EQ.1028) THEN 03005*99 ISW = ISW + 8 03006*99 GO TO 300 03007*99 C MINUTE 03008*99 ELSE IF (MSTACK(1,MK).EQ.1029) THEN 03009*99 ISW = ISW + 16 03010*99 GO TO 300 03011*99 C TIME SIGNIFICANCE 03012*99 ELSE IF (MSTACK(1,MK).EQ.2069) THEN 03013*99 ISW = ISW + 32 03014*99 GO TO 300 03015*99 ELSE IF (MSTACK(1,MK).EQ.1049) THEN 03016*99 ISW = ISW + 64 03017*99 GO TO 300 03018*99 END IF 03019*99 GO TO 400 03020*99 300 CONTINUE 03021*99 JK = JK + 1 03022*99 C SAVE DESCRIPTOR 03023*99 KPROFL(JK) = MSTACK(1,MK) 03024*99 C SAVE SCALE 03025*99 KPROF2(JK) = MSTACK(2,MK) 03026*99 C SAVE DATA 03027*99 KSET2(JK) = KDATA(I,MK) 03028*99 MK = MK + 1 03029*99 400 CONTINUE 03030*99 IF (ISW.NE.127) THEN 03031*99 PRINT *,'TIME ERROR PROCESSING PROFILER',ISW 03032*99 IPTR(1) = 201 03033*99 RETURN 03034*99 END IF 03035*99 C SURFACE DATA 03036*99 KRG = 0 03037*99 ISW = 0 03038*99 DO 600 J = 1, 10 03039*99 C WIND SPEED 03040*99 IF (MSTACK(1,MK).EQ.2818) THEN 03041*99 ISW = ISW + 1 03042*99 GO TO 500 03043*99 C WIND DIRECTION 03044*99 ELSE IF (MSTACK(1,MK).EQ.2817) THEN 03045*99 ISW = ISW + 2 03046*99 GO TO 500 03047*99 C PRESS REDUCED TO MSL 03048*99 ELSE IF (MSTACK(1,MK).EQ.2611) THEN 03049*99 ISW = ISW + 4 03050*99 GO TO 500 03051*99 C TEMPERATURE 03052*99 ELSE IF (MSTACK(1,MK).EQ.3073) THEN 03053*99 ISW = ISW + 8 03054*99 GO TO 500 03055*99 C RAINFALL RATE 03056*99 ELSE IF (MSTACK(1,MK).EQ.3342) THEN 03057*99 ISW = ISW + 16 03058*99 GO TO 500 03059*99 C RELATIVE HUMIDITY 03060*99 ELSE IF (MSTACK(1,MK).EQ.3331) THEN 03061*99 ISW = ISW + 32 03062*99 GO TO 500 03063*99 C 1ST RANGE GATE OFFSET 03064*99 ELSE IF (MSTACK(1,MK).EQ.1982.OR. 03065*99 * MSTACK(1,MK).EQ.1983) THEN 03066*99 C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE 03067*99 C VALUE FOR LATER USE 03068*99 IF (MSTACK(1,MK).EQ.1983) THEN 03069*99 IHGT = KDATA(I,MK) 03070*99 MK = MK + 1 03071*99 KRG = 1 03072*99 ELSE 03073*99 IF (KRG.EQ.0) THEN 03074*99 INCRHT = KDATA(I,MK) 03075*99 MK = MK + 1 03076*99 KRG = 1 03077*99 C PRINT *,'INITIAL INCR =',INCRHT 03078*99 ELSE 03079*99 LHGT = 500 + IHGT - KDATA(I,MK) 03080*99 ISW = ISW + 64 03081*99 C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT 03082*99 END IF 03083*99 END IF 03084*99 C MODE #1 03085*99 ELSE IF (MSTACK(1,MK).EQ.8128) THEN 03086*99 ISW = ISW + 128 03087*99 GO TO 500 03088*99 C MODE #2 03089*99 ELSE IF (MSTACK(1,MK).EQ.8129) THEN 03090*99 ISW = ISW + 256 03091*99 GO TO 500 03092*99 END IF 03093*99 GO TO 600 03094*99 500 CONTINUE 03095*99 C SAVE DESCRIPTOR 03096*99 JK = JK + 1 03097*99 KPROFL(JK) = MSTACK(1,MK) 03098*99 C SAVE SCALE 03099*99 KPROF2(JK) = MSTACK(2,MK) 03100*99 C SAVE DATA 03101*99 KSET2(JK) = KDATA(I,MK) 03102*99 C IF (I.EQ.1) THEN 03103*99 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) 03104*99 C END IF 03105*99 MK = MK + 1 03106*99 600 CONTINUE 03107*99 IF (ISW.NE.511) THEN 03108*99 PRINT *,'SURFACE ERROR PROCESSING PROFILER',ISW 03109*99 IPTR(1) = 202 03110*99 RETURN 03111*99 END IF 03112*99 C 43 LEVELS 03113*99 DO 2000 L = 1, 43 03114*99 2020 CONTINUE 03115*99 ISW = 0 03116*99 C HEIGHT INCREMENT 03117*99 IF (MSTACK(1,MK).EQ.1982) THEN 03118*99 C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK) 03119*99 INCRHT = KDATA(I,MK) 03120*99 MK = MK + 1 03121*99 IF (LHGT.LT.(9250+IHGT)) THEN 03122*99 LHGT = IHGT + 500 - INCRHT 03123*99 ELSE 03124*99 LHGT = IHGT + 9250 - INCRHT 03125*99 END IF 03126*99 END IF 03127*99 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA 03128*99 C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE 03129*99 LHGT = LHGT + INCRHT 03130*99 C PRINT *,'LEVEL ',L,LHGT 03131*99 IF (L.EQ.37) THEN 03132*99 LHGT = LHGT + INCRHT 03133*99 END IF 03134*99 JK = JK + 1 03135*99 C SAVE DESCRIPTOR 03136*99 KPROFL(JK) = 1798 03137*99 C SAVE SCALE 03138*99 KPROF2(JK) = 0 03139*99 C SAVE DATA 03140*99 KSET2(JK) = LHGT 03141*99 C IF (I.EQ.10) THEN 03142*99 C PRINT *,' ' 03143*99 C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK) 03144*99 C END IF 03145*99 ISW = 0 03146*99 DO 800 J = 1, 9 03147*99 750 CONTINUE 03148*99 IF (MSTACK(1,MK).EQ.1982) THEN 03149*99 GO TO 2020 03150*99 C U VECTOR VALUE 03151*99 ELSE IF (MSTACK(1,MK).EQ.3008) THEN 03152*99 ISW = ISW + 1 03153*99 IF (KDATA(I,MK).GE.2047) THEN 03154*99 VECTU = 32767 03155*99 ELSE 03156*99 VECTU = KDATA(I,MK) 03157*99 END IF 03158*99 MK = MK + 1 03159*99 GO TO 800 03160*99 C V VECTOR VALUE 03161*99 ELSE IF (MSTACK(1,MK).EQ.3009) THEN 03162*99 ISW = ISW + 2 03163*99 IF (KDATA(I,MK).GE.2047) THEN 03164*99 VECTV = 32767 03165*99 ELSE 03166*99 VECTV = KDATA(I,MK) 03167*99 END IF 03168*99 MK = MK + 1 03169*99 C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF 03170*99 C DESCRIPTORS AND DATA 03171*99 IF (IAND(ISW,1).NE.0) THEN 03172*99 IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN 03173*99 C SAVE DD DESCRIPTOR 03174*99 JK = JK + 1 03175*99 KPROFL(JK) = 2817 03176*99 C SAVE SCALE 03177*99 KPROF2(JK) = 0 03178*99 C SAVE DD DATA 03179*99 KSET2(JK) = 32767 03180*99 C SAVE FFF DESCRIPTOR 03181*99 JK = JK + 1 03182*99 KPROFL(JK) = 2818 03183*99 C SAVE SCALE 03184*99 KPROF2(JK) = 1 03185*99 C SAVE FFF DATA 03186*99 KSET2(JK) = 32767 03187*99 ELSE 03188*99 C GENERATE DDFFF 03189*99 CALL W3FC05 (VECTU,VECTV,DIR,SPD) 03190*99 NDIR = DIR 03191*99 SPD = SPD 03192*99 NSPD = SPD 03193*99 C PRINT *,' ',NDIR,NSPD 03194*99 C SAVE DD DESCRIPTOR 03195*99 JK = JK + 1 03196*99 KPROFL(JK) = 2817 03197*99 C SAVE SCALE 03198*99 KPROF2(JK) = 0 03199*99 C SAVE DD DATA 03200*99 KSET2(JK) = DIR 03201*99 C IF (I.EQ.1) THEN 03202*99 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) 03203*99 C END IF 03204*99 C SAVE FFF DESCRIPTOR 03205*99 JK = JK + 1 03206*99 KPROFL(JK) = 2818 03207*99 C SAVE SCALE 03208*99 KPROF2(JK) = 1 03209*99 C SAVE FFF DATA 03210*99 KSET2(JK) = SPD 03211*99 C IF (I.EQ.1) THEN 03212*99 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) 03213*99 C END IF 03214*99 END IF 03215*99 END IF 03216*99 GO TO 800 03217*99 C W VECTOR VALUE 03218*99 ELSE IF (MSTACK(1,MK).EQ.3010) THEN 03219*99 ISW = ISW + 4 03220*99 GO TO 700 03221*99 C Q/C TEST RESULTS 03222*99 ELSE IF (MSTACK(1,MK).EQ.8130) THEN 03223*99 ISW = ISW + 8 03224*99 GO TO 700 03225*99 C U,V QUALITY IND 03226*99 ELSE IF(IAND(ISW,16).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN03227*99 ISW = ISW + 16 03228*99 GO TO 700 03229*99 C W QUALITY IND 03230*99 ELSE IF(IAND(ISW,32).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN03231*99 ISW = ISW + 32 03232*99 GO TO 700 03233*99 C SPECTRAL PEAK POWER 03234*99 ELSE IF (MSTACK(1,MK).EQ.5568) THEN 03235*99 ISW = ISW + 64 03236*99 GO TO 700 03237*99 C U,V VARIABILITY 03238*99 ELSE IF (MSTACK(1,MK).EQ.3011) THEN 03239*99 ISW = ISW + 128 03240*99 GO TO 700 03241*99 C W VARIABILITY 03242*99 ELSE IF (MSTACK(1,MK).EQ.3013) THEN 03243*99 ISW = ISW + 256 03244*99 GO TO 700 03245*99 ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN 03246*99 MK = MK + 1 03247*99 GO TO 750 03248*99 END IF 03249*99 GO TO 800 03250*99 700 CONTINUE 03251*99 JK = JK + 1 03252*99 C SAVE DESCRIPTOR 03253*99 KPROFL(JK) = MSTACK(1,MK) 03254*99 C SAVE SCALE 03255*99 KPROF2(JK) = MSTACK(2,MK) 03256*99 C SAVE DATA 03257*99 KSET2(JK) = KDATA(I,MK) 03258*99 MK = MK + 1 03259*99 C IF (I.EQ.1) THEN 03260*99 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) 03261*99 C END IF 03262*99 800 CONTINUE 03263*99 IF (ISW.NE.511) THEN 03264*99 PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW 03265*99 IPTR(1) = 203 03266*99 RETURN 03267*99 END IF 03268*99 2000 CONTINUE 03269*99 C MOVE DATA BACK INTO KDATA ARRAY 03270*99 DO 4000 LL = 1, JK 03271*99 KDATA(I,LL) = KSET2(LL) 03272*99 4000 CONTINUE 03273*99 3000 CONTINUE 03274*99 C PRINT *,'REBUILT ARRAY' 03275*99 DO 5000 LL = 1, JK 03276*99 C DESCRIPTOR 03277*99 MSTACK(1,LL) = KPROFL(LL) 03278*99 C SCALE 03279*99 MSTACK(2,LL) = KPROF2(LL) 03280*99 C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7) 03281*99 5000 CONTINUE 03282*99 C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY 03283*99 IPTR(31) = JK 03284*99 RETURN 03285*99 END 03286*99 SUBROUTINE FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) 03287*78 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 03288*99 C . . . . 03289*99 C SUBPROGRAM: FI8810 REFORMAT PROFILER EDITION 2 DATA 03290*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-01-21 03291*99 C 03292*99 C ABSTRACT: REFORMAT PROFILER DATA IN EDITION 2 03293*99 C 03294*99 C PROGRAM HISTORY LOG: 03295*99 C 93-01-27 CAVANAUGH 03296*99 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE 03297*99 C 03298*99 C USAGE: CALL FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) 03299*78 C INPUT ARGUMENT LIST: 03300*99 C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM 03301*99 C BUFR MESSAGE - 03302*99 C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) 03303*99 C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) 03304*99 C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) 03305*99 C IDENT( 4)- (BYTE 8, SECTION 1) 03306*99 C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) 03307*99 C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) 03308*99 C IDENT( 7)- (BYTES 11-12, SECTION 1) 03309*99 C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) 03310*99 C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) 03311*99 C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) 03312*99 C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) 03313*99 C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) 03314*99 C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) 03315*99 C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) 03316*99 C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) 03317*99 C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) 03318*99 C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR 03319*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 03320*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 03321*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 03322*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 03323*99 C ARGUMENT MAXD) 03324*99 C KSET2 - INTERIM DATA ARRAY 03325*99 C KPROFL - INTERIM DESCRIPTOR ARRAY 03326*99 C IPTR - SEE W3FI88 03327*78 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE 03328*99 C CONTAINED IN A BUFR MESSAGE 03329*99 C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT 03330*99 C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE 03331*99 C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST 03332*99 C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE 03333*99 C 03334*99 C OUTPUT FILES: 03335*99 C 03336*99 C REMARKS: 03337*99p 03338*99 C ATTRIBUTES: 03339*99 C LANGUAGE: FORTRAN 77 03340*99 C MACHINE: NAS 03341*99 C 03342*99 C$$$ 03343*99 INTEGER ISW 03344*99 INTEGER IDENT(*),KDATA(MAXR,MAXD) 03345*99 INTEGER MSTACK(2,MAXD),IPTR(*) 03346*99 INTEGER KPROFL(1700) 03347*99 INTEGER KPROF2(1700) 03348*99 INTEGER KSET2(1700) 03349*99 C LOOP FOR NUMBER OF SUBSETS 03350*99 DO 3000 I = 1, IDENT(14) 03351*99 MK = 1 03352*99 JK = 0 03353*99 ISW = 0 03354*99 C PRINT *,'IDENTIFICATION' 03355*99 DO 200 J = 1, 5 03356*99 IF (MSTACK(1,MK).EQ.257) THEN 03357*99 C BLOCK NUMBER 03358*99 ISW = ISW + 1 03359*99 ELSE IF (MSTACK(1,MK).EQ.258) THEN 03360*99 C STATION NUMBER 03361*99 ISW = ISW + 2 03362*99 ELSE IF (MSTACK(1,MK).EQ.1282) THEN 03363*99 C LATITUDE 03364*99 ISW = ISW + 4 03365*99 ELSE IF (MSTACK(1,MK).EQ.1538) THEN 03366*99 C LONGITUDE 03367*99 ISW = ISW + 8 03368*99 ELSE IF (MSTACK(1,MK).EQ.1793) THEN 03369*99 C HEIGHT OF STATION 03370*99 ISW = ISW + 16 03371*99 IHGT = KDATA(I,MK) 03372*99 ELSE 03373*99 MK = MK + 1 03374*99 GO TO 200 03375*99 END IF 03376*99 JK = JK + 1 03377*99 KPROFL(JK) = MSTACK(1,MK) 03378*99 KPROF2(JK) = MSTACK(2,MK) 03379*99 KSET2(JK) = KDATA(I,MK) 03380*99 C PRINT *,JK,KPROFL(JK),KSET2(JK) 03381*99 MK = MK + 1 03382*99 200 CONTINUE 03383*99 C PRINT *,'LOCATION ',ISW 03384*99 IF (ISW.NE.31) THEN 03385*99 PRINT *,'LOCATION ERROR PROCESSING PROFILER' 03386*99 IPTR(10) = 200 03387*99 RETURN 03388*99 END IF 03389*99 C PROCESS TIME ELEMENTS 03390*99 ISW = 0 03391*99 DO 400 J = 1, 7 03392*99 IF (MSTACK(1,MK).EQ.1025) THEN 03393*99 C YEAR 03394*99 ISW = ISW + 1 03395*99 ELSE IF (MSTACK(1,MK).EQ.1026) THEN 03396*99 C MONTH 03397*99 ISW = ISW + 2 03398*99 ELSE IF (MSTACK(1,MK).EQ.1027) THEN 03399*99 C DAY 03400*99 ISW = ISW + 4 03401*99 ELSE IF (MSTACK(1,MK).EQ.1028) THEN 03402*99 C HOUR 03403*99 ISW = ISW + 8 03404*99 ELSE IF (MSTACK(1,MK).EQ.1029) THEN 03405*99 C MINUTE 03406*99 ISW = ISW + 16 03407*99 ELSE IF (MSTACK(1,MK).EQ.2069) THEN 03408*99 C TIME SIGNIFICANCE 03409*99 ISW = ISW + 32 03410*99 ELSE IF (MSTACK(1,MK).EQ.1049) THEN 03411*99 C TIME DISPLACEMENT 03412*99 ISW = ISW + 64 03413*99 ELSE 03414*99 MK = MK + 1 03415*99 GO TO 400 03416*99 END IF 03417*99 JK = JK + 1 03418*99 KPROFL(JK) = MSTACK(1,MK) 03419*99 KPROF2(JK) = MSTACK(2,MK) 03420*99 KSET2(JK) = KDATA(I,MK) 03421*99 C PRINT *,JK,KPROFL(JK),KSET2(JK) 03422*99 MK = MK + 1 03423*99 400 CONTINUE 03424*99 C PRINT *,'TIME ',ISW 03425*99 IF (ISW.NE.127) THEN 03426*99 PRINT *,'TIME ERROR PROCESSING PROFILER' 03427*99 IPTR(1) = 201 03428*99 RETURN 03429*99 END IF 03430*99 C SURFACE DATA 03431*99 ISW = 0 03432*99 C PRINT *,'SURFACE' 03433*99 DO 600 K = 1, 8 03434*99 C PRINT *,MK,MSTACK(1,MK),JK,ISW 03435*99 IF (MSTACK(1,MK).EQ.2817) THEN 03436*99 ISW = ISW + 1 03437*99 ELSE IF (MSTACK(1,MK).EQ.2818) THEN 03438*99 ISW = ISW + 2 03439*99 ELSE IF (MSTACK(1,MK).EQ.2611) THEN 03440*99 ISW = ISW + 4 03441*99 ELSE IF (MSTACK(1,MK).EQ.3073) THEN 03442*99 ISW = ISW + 8 03443*99 ELSE IF (MSTACK(1,MK).EQ.3342) THEN 03444*99 ISW = ISW + 16 03445*99 ELSE IF (MSTACK(1,MK).EQ.3331) THEN 03446*99 ISW = ISW + 32 03447*99 ELSE IF (MSTACK(1,MK).EQ.1797) THEN 03448*99 INCRHT = KDATA(I,MK) 03449*99 ISW = ISW + 64 03450*99 C PRINT *,'INITIAL INCREMENT = ',INCRHT 03451*99 MK = MK + 1 03452*99 C PRINT *,JK,KPROFL(JK),KSET2(JK),' ISW=',ISW 03453*99 GO TO 600 03454*99 ELSE IF (MSTACK(1,MK).EQ.6433) THEN 03455*99 ISW = ISW + 128 03456*99 END IF 03457*99 JK = JK + 1 03458*99 KPROFL(JK) = MSTACK(1,MK) 03459*99 KPROF2(JK) = MSTACK(2,MK) 03460*99 KSET2(JK) = KDATA(I,MK) 03461*99 C PRINT *,JK,KPROFL(JK),KSET2(JK),'ISW=',ISW 03462*99 MK = MK + 1 03463*99 600 CONTINUE 03464*99 IF (ISW.NE.255) THEN 03465*99 PRINT *,'ERROR PROCESSING PROFILER',ISW 03466*99 IPTR(1) = 204 03467*99 RETURN 03468*99 END IF 03469*99 IF (MSTACK(1,MK).NE.1797) THEN 03470*99 PRINT *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER' 03471*99 IPTR(1) = 205 03472*99 RETURN 03473*99 END IF 03474*99 C MUST SAVE THIS HEIGHT VALUE 03475*99 LHGT = 500 + IHGT - KDATA(I,MK) 03476*99 C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT 03477*99 MK = MK + 1 03478*99 IF (MSTACK(1,MK).GE.16384) THEN 03479*99 MK = MK + 1 03480*99 END IF 03481*99 C PROCESS LEVEL DATA 03482*99 C PRINT *,'LEVEL DATA' 03483*99 DO 2000 L = 1, 43 03484*99 2020 CONTINUE 03485*99 C PRINT *,'DESC',MK,MSTACK(1,MK),JK 03486*99 ISW = 0 03487*99 C HEIGHT INCREMENT 03488*99 IF (MSTACK(1,MK).EQ.1797) THEN 03489*99 INCRHT = KDATA(I,MK) 03490*99 C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT 03491*99 MK = MK + 1 03492*99 C IF (LHGT.LT.(9250+IHGT)) THEN 0349 99 C LHGT = IHGT + 500 - INCRHT 03494*99 C ELSE 03495*99 C LHGT = IHGT + 9250 -INCRHT 03496*99 C END IF 03497*99 END IF 03498*99 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA03499*99 C AT THIS POINT 03500*99 LHGT = LHGT + INCRHT 03501*99 C PRINT *,'LEVEL ',L,LHGT 03502*99 C IF (L.EQ.37) THEN 03503*99 C LHGT = LHGT + INCRHT 03504*99 C END IF 03505*99 JK = JK + 1 03506*99 C SAVE DESCRIPTOR 03507*99 KPROFL(JK) = 1798 03508*99 C SAVE SCALE 03509*99 KPROF2(JK) = 0 03510*99 C SAVE DATA 03511*99 KSET2(JK) = LHGT 03512*99 C PRINT *,KPROFL(JK),KSET2(JK),JK 03513*99 ISW = 0 03514*99 ICON = 1 03515*99 DO 800 J = 1, 10 03516*99 750 CONTINUE 03517*99 IF (MSTACK(1,MK).EQ.1797) THEN 03518*99 GO TO 2020 03519*99 ELSE IF (MSTACK(1,MK).EQ.6432) THEN 03520*99 C HI/LO MODE 03521*99 ISW = ISW + 1 03522*99 ELSE IF (MSTACK(1,MK).EQ.6434) THEN 03523*99 C Q/C TEST 03524*99 ISW = ISW + 2 03525*99 ELSE IF (MSTACK(1,MK).EQ.2070) THEN 03526*99 IF (ICON.EQ.1) THEN 03527*99 C FIRST PASS - U,V CONSENSUS 03528*99 ISW = ISW + 4 03529*99 ICON = ICON + 1 03530*99 ELSE 03531*99 C SECOND PASS - W CONSENSUS 03532*99 ISW = ISW + 64 03533*99 END IF 03534*99 ELSE IF (MSTACK(1,MK).EQ.2819) THEN 03535*99 C U VECTOR VALUE 03536*99 ISW = ISW + 8 03537*99 IF (KDATA(I,MK).GE.2047) THEN 03538*99 VECTU = 32767 03539*99 ELSE 03540*99 VECTU = KDATA(I,MK) 03541*99 END IF 03542*99 MK = MK + 1 03543*99 GO TO 800 03544*99 ELSE IF (MSTACK(1,MK).EQ.2820) THEN 03545*99 C V VECTOR VALUE 03546*99 ISW = ISW + 16 03547*99 IF (KDATA(I,MK).GE.2047) THEN 03548*99 VECTV = 32767 03549*99 ELSE 03550*99 VECTV = KDATA(I,MK) 03551*99 END IF 03552*99 IF (IAND(ISW,1).NE.0) THEN 03553*99 IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN 03554*99 C SAVE DD DESCRIPTOR 03555*99 JK = JK + 1 03556*99 KPROFL(JK) = 2817 03557*99 KPROF2(JK) = 0 03558*99 KSET2(JK) = 32767 03559*99 C SAVE FFF DESCRIPTOR 03560*99 JK = JK + 1 03561*99 KPROFL(JK) = 2818 03562*99 KPROF2(JK) = 1 03563*99 KSET2(JK) = 32767 03564*99 ELSE 03565*99 CALL W3FC05 (VECTU,VECTV,DIR,SPD) 03566*99 NDIR = DIR 03567*99 SPD = SPD 03568*99 NSPD = SPD 03569*99 C PRINT *,' ',NDIR,NSPD 03570*99 C SAVE DD DESCRIPTOR 03571*99 JK = JK + 1 03572*99 KPROFL(JK) = 2817 03573*99 KPROF2(JK) = 0 03574*99 KSET2(JK) = NDIR 03575*99 C IF (I.EQ.1) THEN 03576*99 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) 03577*99 C ENDIF 03578*99 C SAVE FFF DESCRIPTOR 03579*99 JK = JK + 1 03580*99 KPROFL(JK) = 2818 03581*99 KPROF2(JK) = 1 03582*99 KSET2(JK) = NSPD 03583*99 C IF (I.EQ.1) THEN 03584*99 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) 03585*99 C ENDIF 03586*99 END IF 03587*99 MK = MK + 1 03588*99 GO TO 800 03589*99 END IF 03590*99 ELSE IF (MSTACK(1,MK).EQ.2866) THEN 03591*99 C SPEED STD DEVIATION 03592*99 ISW = ISW + 32 03593*99 C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568 03594*99 ELSE IF (MSTACK(1,MK).EQ.5568) THEN 03595*99 C SIGNAL POWER 03596*99 ISW = ISW + 128 03597*99 ELSE IF (MSTACK(1,MK).EQ.2822) THEN 03598*99 C W COMPONENT 03599*99 ISW = ISW + 256 03600*99 ELSE IF (MSTACK(1,MK).EQ.2867) THEN 03601*99 C VERT STD DEVIATION 03602*99 ISW = ISW + 512 03603*99 ELSE 03604*99 MK = MK + 1 03605*99 GO TO 750 03606*99 END IF 03607*99 JK = JK + 1 03608*99 C SAVE DESCRIPTOR 03609*99 KPROFL(JK) = MSTACK(1,MK) 03610*99 C SAVE SCALE 03611*99 KPROF2(JK) = MSTACK(2,MK) 03612*99 C SAVE DATA 03613*99 KSET2(JK) = KDATA(I,MK) 03614*99 MK = MK + 1 03615*99 C PRINT *,L,'TEST ',JK,KPROFL(JK),KSET2(JK) 03616*99 800 CONTINUE 03617*99 IF (ISW.NE.1023) THEN 03618*99 PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW 03619*99 IPTR(1) = 202 03620*99 RETURN 03621*99 END IF 03622*99 2000 CONTINUE 03623*99 C MOVE DATA BACK INTO KDATA ARRAY 03624*99 DO 5000 LL = 1, JK 03625*99 C DATA 03626*99 KDATA(I,LL) = KSET2(LL) 03627*99 5000 CONTINUE 03628*99 3000 CONTINUE 03629*99 DO 5005 LL = 1, JK 03630*99 C DESCRIPTOR 03631*99 MSTACK(1,LL) = KPROFL(LL) 03632*99 C SCALE 03633*99 MSTACK(2,LL) = KPROF2(LL) 03634*99 C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP03635*99 C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4) 03636*99 5005 CONTINUE 03637*99 IPTR(31) = JK 03638*99 RETURN 03639*99 END 03640*99 SUBROUTINE FI8811(IPTR,IDENT,MSTACK,KDATA,KNR, 03641*78 * LDATA,LSTACK,MAXD,MAXR) 03642*99 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 03643*99 C . . . . 03644*99 C SUBPROGRAM: FI8811 EXPAND DATA/DESCRIPTOR REPLICATION 03645*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-05-12 03646*99 C 03647*99 C ABSTRACT: EXPAND DATA AND DESCRIPTOR STRINGS 03648*99 C 03649*99 C PROGRAM HISTORY LOG: 03650*99 C 93-05-12 CAVANAUGH 03651*99 C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE 03652*99 C 03653*99 C USAGE: CALL FI8811(IPTR,IDENT,MSTACK,KDATA,KNR, 03654*78 C * LDATA,LSTACK,MAXD,MAXR) 03655*99 C INPUT ARGUMENT LIST: 03656*99 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK 03657*78 C IDENT - SEE W3FI88 ROUTINE DOCBLOCK 03658*78 C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE 03659*99 C CONTAINED IN A BUFR MESSAGE 03660*99 C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT 03661*99 C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE 03662*99 C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST 03663*99 C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE 03664*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 03665*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 03666*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 03667*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 03668*99 C ARGUMENT MAXD) 03669*99 C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES 03670*99 C 03671*99 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 03672*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 03673*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 03674*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 03675*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 03676*99 C ARGUMENT MAXD) 03677*99 C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES 03678*99 C 03679*99 C SUBPROGRAMS CALLED: 03680*99 C LIBRARY: 03681*99 C W3LIB - 03682*99 C 03683*99 C REMARKS: ERROR RETURN: 03684*99 C IPTR(1) = 03685*99 C 03686*99 C ATTRIBUTES: 03687*99 C LANGUAGE: FORTRAN 77 03688*99 C MACHINE: NAS 03689*99 C 03690*99 C$$$ 03691*99 SAVE 03692*99 C 03693*99 INTEGER IPTR(*) 03694*99 INTEGER KNR(MAXR) 03695*99 INTEGER KDATA(MAXR,MAXD),LDATA(MAXD) 03696*99 INTEGER MSTACK(2,MAXD),LSTACK(2,MAXD) 03697*99 INTEGER IDENT(*) 03698*99 C 03699*99 C PRINT *,' DATA/DESCRIPTOR REPLICATION ' 03700*99 DO 1000 I = 1, KNR(1) 03701*99 C IF NOT REPLICATION DESCRIPTOR 03702*99 IF ((MSTACK(1,I)/16384).NE.1) THEN 03703*99 GO TO 1000 03704*99 END IF 03705*99 C IF DELAYED REPLICATION DESCRIPTOR 03706*99 IF (MOD(MSTACK(1,I),256).EQ.0) THEN 03707*99 C SAVE KX VALUE (NR DESC'S TO REPLICATE) 03708*99 KX = MOD((MSTACK(1,I)/256),64) 03709*99 C IF NEXT DESC IS NOT 7947 OR 7948 03710*99 C (I.E., 0 31 011 OR 0 31 012) 03711*99 IF (MSTACK(1,I+1).NE.7947.AND.MSTACK(1,I+1).NE.7948) THEN 03712*99 C SKIP IT 03713*99 GO TO 1000 03714*99 END IF 03715*99 C GET NR REPS FROM KDATA 03716*99 NRREPS = KDATA(1,I+1) 03717*99 LAST = I + 1 + KX 03718*99 C SAVE OFF TRAILING DESCS AND DATA 03719*99 KTRAIL = KNR(1) - I - 1 - KX 03720*99 DO 100 L = 1, KTRAIL 03721*99 NX = I + L + KX + 1 03722*99 LDATA(L) = KDATA(1,NX) 03723*99 LSTACK(1,L) = MSTACK(1,NX) 03724*99 LSTACK(2,L) = MSTACK(2,NX) 03725*99 100 CONTINUE 03726*99 C INSERT FX DESCS/DATA NR REPS TIMES 03727*99 LAST = I + 1 03728*99 DO 400 J = 1, NRREPS 03729*99 NX = I + 2 03730*99 DO 300 K = 1, KX 03731*99 LAST = LAST + 1 03732*99 KDATA(1,LAST) = KDATA(1,NX) 03733*99 MSTACK(1,LAST) = MSTACK(1,NX) 03734*99 MSTACK(2,LAST) = MSTACK(2,NX) 03735*99 NX = NX + 1 03736*99 300 CONTINUE 03737*99 03738*99 400 CONTINUE 03739*99 C RESTORE TRAILING DATA/DESCS 03740*99 DO 500 L = 1, KTRAIL 03741*99 LAST = LAST + 1 03742*99 KDATA(1,LAST) = LDATA(L) 03743*99 MSTACK(1,LAST) = LSTACK(1,L) 03744*99 MSTACK(2,LAST) = LSTACK(2,L) 03745*99 500 CONTINUE 03746*99 C RESET KNR(1) 03747*99 KNR(1) = LAST 03748*99 END IF 03749*99 1000 CONTINUE 03750*99 RETURN 03751*99 END 03752*99 SUBROUTINE FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC, 03753*78 * IRF1SW,NEWREF,ITBLD,ITBLD2, 03754192 * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, 03755192 * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) 03756192 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 03757*99 C . . . . 03758*99 C SUBPROGRAM: FI8812 BUILD TABLE B SUBSET BASED ON BUFR SEC 3 03759*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-23 03760*99 C 03761*99 C ABSTRACT: BUILD A SUBSET OF TABLE B ENTRIES THAT CORRESPOND TO 03762*99 C THE DESCRIPTORS NEEDED FOR THIS MESSAGE 03763*99 C 03764*99 C PROGRAM HISTORY LOG: 03765*99 C 93-05-12 CAVANAUGH 03766*99 C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE 03767*99 C 03768*99 C USAGE: CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC, 03769*78 C * IRF1SW,NEWREF,ITBLD,ITBLD2, 03770175 C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, 03771175 C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) 03772175 C INPUT ARGUMENT LIST: 03773*99 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK 03774*78 C IDENT - SEE W3FI88 ROUTINE DOCBLOCK 03775*78 C ISTACK - LIST OF DESCRIPTORS AND SCALE VALUES 03776*99 C IUNITB - 03777191 C IUNITD - 03778191 C ISTACK - 03779191 C NRDESC - 03780191 C KFXY2 - 03781191 C ANAME2 - 03782191 C AUNIT2 - 03783191 C ISCAL2 - 03784191 C IRFVL2 - 03785191 C IWIDE2 - 03786191 C IRF1SW - 03787191 C NEWREF - 03788191 C ITBLD2 - 03789191 C 03790*99 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 03791*99 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. 03792*99 C KDATA(REPORT NUMBER,PARAMETER NUMBER) 03793*99 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT 03794*99 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT 03795*99 C ARGUMENT MAXD) 03796*99 C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES 03797*99 C KFXY1 - 03798191 C ANAME1 - 03799191 C AUNIT1 - 03800191 C ISCAL1 - 03801191 C IRFVL1 - 03802191 C IWIDE1 - 03803191 C ITBLD - 03804191 C 03805*99 C SUBPROGRAMS CALLED: 03806*99 C LIBRARY: 03807*99 C W3LIB - 03808*99 C 03809*99 C REMARKS: ERROR RETURN: 03810*99 C IPTR(1) = 03811*99 C 03812*99 C ATTRIBUTES: 03813*99 C LANGUAGE: FORTRAN 77 03814*99 C MACHINE: NAS 03815*99 C 03816*99 C$$$ 03817*99 SAVE 03818*99 C 03819*99 C .................................................. 03820*41 C 03821*41 C NEW BASE TABLE B 03822*41 C MAY BE A COMBINATION OF MASTER TABLE B 03823*41 C AND ANCILLARY TABLE B 03824*41 C 03825*41 INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) 03826*44 CHARACTER*40 ANAME1(*) 03827*41 CHARACTER*24 AUNIT1(*) 03828*41 C .................................................. 03829*43 C 03830*43 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE 03831*43 C 03832*43 INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*) 03833*43 CHARACTER*64 ANAME2(*) 03834*43 CHARACTER*24 AUNIT2(*) 03835*43 C .................................................. 03836*43 C 03837*41 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE 03838*41 C 03839*41 INTEGER ITBLD2(14,*) 03840*76 C .................................................. 03841*42 C 03842*42 C NEW BASE TABLE D 03843*42 C 03844*42 INTEGER ITBLD(14,*) 03845*76 C .................................................. 03846*42 INTEGER IPTR(*),ISTACK(*),NRDESC,NWLIST(200) 03847192 INTEGER NEWREF(*) 03848*41 INTEGER IUNITB,IUNITD,ICOPY(1600),NRCOPY,IELEM,IPOS 03849*99 CHARACTER*64 AHLD64 03850*43 CHARACTER*24 AHLD24 03851*43 C 03852*99 C SCAN AND DISCARD REPLICATION AND OPERATOR DESCRIPTORS 03853*99 C REPLACING SEQUENCE DESCRIPTORS WITH THEIR CORRESPONDING 03854*99 C SET OF DESCRIPTORS ALSO ELIMINATING DUPLICATES. 03855*99 C 03856*99 C----------------------------------------------------------- 03857*99 C PRINT *,'ENTER FI8812' 03858*78 C 03859*99 C GET A COPY OF ISTACK 03860*99 C 03861*99 C PRINT *,'ISTACK COPY' 03862**2 DO 100 I = 1, NRDESC 03863**2 ICOPY(I) = ISTACK(I) 03864**2 C PRINT *,I,ICOPY(I) 03865**2 100 CONTINUE 03866**2 C 03867*99 C REPLACE ALL SEQUENCE DESCRIPTORS 03868*99 NRCOPY = NRDESC 03869*99 IPOS = 1 03870*99 200 CONTINUE 03871*99 IF (IPOS.GE.NRCOPY) THEN 03872*99 GO TO 450 03873*99 END IF 03874*99 IF (ICOPY(IPOS).GE.49152) THEN 03875*99 C READ TABLE D IF NEEDED 03876*99 IF (IPTR(20).EQ.0) THEN 03877219 C PRINT *,'MUST READ IN TABLE D' 03878192 C READ IN TABLE D 03879*99 CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2) 03880*78 ELSE 03881**3 IF (IPTR(42).NE.0) THEN 03882**3 C PRINT *,'MERGE',IPTR(42),' ENTRIES INTO TABLE D' 03883*78 CALL FI8819(IPTR,ITBLD,ITBLD2) 03884*78 END IF 03885**3 END IF 03886*99 C FIND MATCHING SEQUENCE 03887*99 DO 300 K = 1, IPTR(20) 03888219 IF (ICOPY(IPOS).EQ.ITBLD(1,K)) THEN 03889*48 GO TO 400 03890*99 END IF 03891*99 300 CONTINUE 03892*99 C IF NOT FOUND ERROR 03893*99 C PRINT *,'EXIT FI8812 - IPTR(1) = 4' 03894*78 IPTR(1) = 4 03895*99 RETURN 03896*99 400 CONTINUE 03897*99 C APPEND SEQUENCE 03898*99 DO 410 LJ = 2, 14 03899*76 IF (ITBLD(LJ,K).NE.0) THEN 03900*48 NRCOPY = NRCOPY + 1 03901*99 ICOPY(NRCOPY) = ITBLD(LJ,K) 03902*48 END IF 03903*99 410 CONTINUE 03904*99 END IF 03905*99 IPOS = IPOS + 1 03906*99 GO TO 200 03907*99 450 CONTINUE 03908*99 C PRINT *,'SEQUENCE EXPANSION TO ',IPOS,' POSITIONS' 03909*23 C PRINT *,(ICOPY(JQ),JQ=1,IPOS) 03910*60 C HAVE LIST OF DESCRIPTORS BUT 03911*99 C MUST ISOLATE ELEMENT DESCRIPTORS 03912*99 C 03913*99 C PRINT *,'ISOLATE ELEMENT DESCRIPTORS' 03914*23 DO 460 KJ = 1, NRCOPY 03915211 IF (ICOPY(KJ).LT.16384) THEN 03916212 GO TO 461 03917211 END IF 03918211 460 CONTINUE 03919211 461 CONTINUE 03920211 NWLIST(1) = ICOPY(KJ) 03921211 IELEM = 1 03922105 C PRINT *,IELEM,NWLIST(IELEM) 03923**2 DO 500 I = KJ+1, NRCOPY 03924211 IF (ICOPY(I).LT.16384) THEN 03925*99 DO 470 J = 1, IELEM 03926105 IF (ICOPY(I).EQ.NWLIST(J)) THEN 03927105 GO TO 500 03928105 END IF 03929105 470 CONTINUE 03930105 IELEM = IELEM + 1 03931*99 NWLIST(IELEM) = ICOPY(I) 03932*99 C PRINT *,IELEM,NWLIST(IELEM) 03933**2 END IF 03934*99 500 CONTINUE 03935*99 C 03936*99 C HAVE A UNIQUE SET, SORT INTO ASCENDING ORDER 03937*99 C 03938*99 DO 2000 I = 1, IELEM-1 03939105 NEXT = I + 1 03940*99 DO 1000 J = NEXT, IELEM 03941*99 IF (NWLIST(I).GT.NWLIST(J)) THEN 03942*99 IHOLD = NWLIST(I) 03943*99 NWLIST(I) = NWLIST(J) 03944*99 NWLIST(J) = IHOLD 03945*99 END IF 03946*99 1000 CONTINUE 03947*99 C PRINT *,'1000 SORTED',I,NWLIST(I) 03948*60 2000 CONTINUE 03949*99 C PRINT *,'2000 SORTED',IELEM,NWLIST(IELEM) 03950*60 C 03951*99 C READ IN SELECTED SUBSET OF TABLE B 03952*99 C PRINT *,' READING TABLE B' 03953*23 REWIND IUNITB 03954*86 4100 CONTINUE 03955*86 C READ(UNIT=IUNITB,FMT=20,ERR=9999,END=4110)MF, 03956105 C * MX,MY, 03957105 C * (ANAME2(1)(K:K),K=1,40), 03958105 C * (AUNIT1(1)(K:K),K=1,24), 03959105 C * ISCAL1(1),IRFVL1(1,1),IWIDE1(1) 03960105 C JFXY = 16384*MF + MX*256 + MY 03961105 C WRITE (6,19)JFXY,MF,MX,MY, 03962105 C *z (ANAME2(1)(K:K),K=1,40), 03963105 C * (AUNIT1(1)(K:K),K=1,24), 03964105 C * ISCAL1(1),IRFVL1(1,1),IWIDE1(1) 03965105 19 FORMAT(1X,I5,2X,I1,I2,I3,1X,40A1,2X,24A1,2X,I5,2X,I15,2X,I4,/)03966*86 C GO TO 4100 03967105 4110 CONTINUE 03968*86 REWIND IUNITB 03969*99 C I POINTS TO CURRENTLY HELD MASTER TABLE B ENTRY 03970169 I = 1 03971*99 C J POINTS TO CURRENT POSITION IN ANCILLARY TABLE B03972169 J = 1 03973129 4000 CONTINUE 03974*99 C QUIT IF HAVE ALL DESCRIPTORS NEEDED 03975106 C PRINT *,'LOOKING FOR MATCH ON',NWLIST(I),I,' OF',IELEM 03976207 IF (I.GT.IELEM) THEN 03977106 GO TO 175 03978106 END IF 03979106 READ(UNIT=IUNITB,FMT=20,ERR=9999,END=175)MF, 03980*99 * MX,MY, 03981*99 * (ANAME2(I)(K:K),K=1,40), 03982149 * (AUNIT1(I)(K:K),K=1,24), 03983149 * ISCAL1(I),IRFVL1(1,I),IWIDE1(I) 03984*44 20 FORMAT(I1,I2,I3,40A1,24A1,I5,I15,1X,I4) 03985*99 KFXY1(I) = MF*16384 + MX*256 + MY 03986149 5000 CONTINUE 03987169 IF (NWLIST(I).LT.KFXY1(I)) THEN 03988149 C GET NEXT MASTER TABLE B ENTRY 03989169 GO TO 4000 03990169 ELSE IF (NWLIST(I).GT.KFXY1(I)) THEN 03991149 C NO MASTER TABLE B ENTRY 03992169 C IF ANCILLARY TABLE B IS AVAILABLE 03993169 C TRY IT 03994169 5200 CONTINUE 03995192 IF (IPTR(41).NE.0.AND.J.LE.IPTR(41)) THEN 03996169 C TRY ANCILLARY TABLE B 03997169 IF (NWLIST(I).GT.KFXY2(J)) THEN 03998192 C HAVE NOT YET WORKED UP TO THIS ENTRY 03999169 J = J + 1 04000169 GO TO 5200 04001192 ELSE IF (NWLIST(I).LT.KFXY2(J)) THEN 04002192 C NO MATCHING DESCRIPTOR IN 04003169 C MASTER OR ANCILLARY TABLE B 04004169 PRINT *,'NO MATCHING DESCRIPTOR IN MASTER ', 04005169 * 'OR ANCILLARY TABLE B FOR',NWLIST(I) 04006169 IPTR(1) = 3 04007169 RETURN 04008169 ELSE 04009169 C FOUND ANCILLARY MATCH, MOVE INTO TABLE B 04010169 C INDEX OVER THIS ENTRY 04011169 04012192 C PRINT *,'ANCILLARY MATCH FIRST' 04013*60 GO TO 6000 04014169 END IF 04015169 END IF 04016169 ELSE 04017*99 C MATCH ON MASTER TABLE B 04018169 C BUT MAY BE SUPERCEDED BY ANCILLARY TABLE B 04019169 5500 CONTINUE 04020169 C PRINT *,'FOUND MASTER FIRST' 04021105 IF (IPTR(41).NE.0.AND.J.LE.IPTR(41)) THEN 04022130 C TRY ANCILLARY TABLE B 04023130 IF (NWLIST(I).LT.KFXY2(J)) THEN 04024152 C HAVE NOT YET WORKED UP TO THIS ENTRY 04025130 J = J + 1 04026169 GO TO 5500 C 04027169 ELSE IF (NWLIST(I).GT.KFXY2(J)) THEN 04028152 C HAVE SKIPPED OVER AN ANCILLARY ENTRY 04029130 C ACCEPT MASTER TABLE B ENTRY 04030169 C PRINT *,'USING MASTER' 04031*78 I = I + 1 04032169 GO TO 4000 04033169 ELSE 04034130 C FOUND ANCILLARY MATCH, MOVE INTO TABLE B 04035130 C INDEX OVER THIS ENTRY 04036130 C PRINT *,'SUBSTITUTING ANCILLARY' 04037*78 GO TO 6000 04038169 END IF 04039130 END IF 04040130 GO TO 6500 04041169 6000 CONTINUE 04042169 KFXY1(I) = KFXY2(J) 04043169 C PRINT *,'MATCH',KFXY1(I) 04044*60 ANAME1(I)(1:40) = ANAME2(J)(1:40) 04045169 AUNIT1(I)(1:24) = AUNIT2(J)(1:24) 04046169 ISCAL1(I) = ISCAL2(J) 04047169 IRFVL1(1,I) = IRFVL2(J) 04048105 IWIDE1(I) = IWIDE2(J) 04049169 I = I + 1 04050169 J = J + 1 04051169 GO TO 4000 04052169 6500 CONTINUE 04053169 C WRITE(6,21) MF,MX,MY,KFXY1(I), 04054*23 C * (ANAME2(I)(K:K),K=1,40), 04055*23 C * (AUNIT1(I)(K:K),K=1,24), 04056*23 C * ISCAL1(I),IRFVL1(1,I),IWIDE1(I) 04057*44 21 FORMAT(1X,I1,I2,I3,1X,I6,1X,40A1, 04058*23 * 2X,24A1,2X,I5,2X,I15,1X,I4) 04059*23 C PRINT *,I,NWLIST(I),KFXY1(I),' MATCH' 04060*60 C HAVE A MATCH 04061*99 I = I + 1 04062*99 END IF 04063*99 GO TO 4000 04064*99 175 CONTINUE 04065*99 IPTR(21) = IELEM 04066**2 C ====================================================== 04067*99 GO TO 9000 04068*99 9999 CONTINUE 04069*99 C ERROR READING TABLE B 04070*99 IPTR(1) = 9 04071*99 9000 CONTINUE 04072*99 C PRINT *,'EXIT FI8812' 04073*78 RETURN 04074*99 END 04075*99 SUBROUTINE FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT, 04076*78 * ITBLD2,ANAME2,AUNIT2,KFXY2,ISCAL2,IRFVL2,IWIDE2) 04077149 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 04078115 C . . . . 04079115 C SUBPROGRAM: FI8813 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES 04080*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04 04081191 C 04082115 C ABSTRACT: EXTRACT TABLE A, TABLE B, TABLE D ENTRIES FROM A 04083115 C DECODED BUFR MESSAGE. 04084115 C 04085115 C PROGRAM HISTORY LOG: 04086115 C 94-03-04 CAVANAUGH 04087191 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE 04088115 C 04089115 C USAGE: CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT, 04090*78 C * ITBLD2,ANAME2,AUNIT2,KFXY2,ISCAL2,IRFVL2,IWIDE2) 04091191 C INPUT ARGUMENT LIST: 04092115 C IPTR 04093191 C MAXR 04094191 C MAXD 04095191 C MSTACK 04096191 C KDATA 04097191 C IDENT 04098198 C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, 04099115 C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. 04100115 C 04101115 C OUTPUT ARGUMENT LIST: 04102115 C ITBLD2 04103198 C ANAME2 04104198 C AUNIT2 04105198 C KFXY2 04106198 C ISCAL2 04107198 C IRFVL2 04108198 C IWIDE2 04109198 C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. 04110115 C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN 04111115 C ERRFLAG - EVEN IF MANY LINES ARE NEEDED 04112115 C 04113115 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION 04114115 C 04115115 C ATTRIBUTES: 04116115 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS 04117115 C MACHINE: NAS, CYBER, WHATEVER 04118115 C 04119115 C$$$ 04120115 C .................................................. 04121*43 C 04122*43 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE 04123*43 C 04124*43 INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*) 04125*43 CHARACTER*64 ANAME2(*) 04126*43 CHARACTER*24 AUNIT2(*) 04127*43 C .................................................. 04128*43 C 04129*41 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE 04130*41 C 04131*41 INTEGER ITBLD2(14,*) 04132*76 C .................................................. 04133*41 CHARACTER*32 SPACES/' '/ 04134221 CHARACTER*4 ASCCHR 04135*44 CHARACTER*12 AAAA 04136*84 C 04137115 INTEGER I1(15),I2(15),I3(15) 04138176 INTEGER IPTR(*),MAXR,MAXD,MSTACK(2,MAXD) 04139123 INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD) 04140123 INTEGER IEXTRA/0/ 04141115 INTEGER KEYSET/0/,ISCSGN(200),IRFSGN(200) 04142139 INTEGER IDENT(*),IHOLD 04143*41 EQUIVALENCE (IHOLD,ASCCHR) 04144*74 C ============================================================== 04145115 C PRINT *,'FI8813',IPTR(41),IPTR(42),IPTR(31) 04146*78 C BUILD SPACE CONSTANT 04147135 C INITIALIZE ENTRY COUNTS 04148135 IXA = 0 04149115 IXB = IPTR(41) 04150251 IXD = IPTR(42) 04151251 C 04152135 C SET FOR COMPRESSED OR NON COMPRESSED 04153135 C PROCESSING 04154135 C 04155135 C PRINT *,'FI8813 - 2',IDENT(16),IDENT(14) 04156*78 IF (IDENT(16).EQ.0) THEN 04157135 JK = 1 04158135 ELSE 04159135 JK = IDENT(14) 04160135 END IF 04161135 C PRINT *,'FI8813 - 3, JK=',JK 04162*78 C 04163115 C 04164135 C START PROCESSING ENTRIES 04165135 C PRINT *,'START PROCESSING ENTRIES' 04166215 C 04167115 C DO 995 I = 1, IPTR(31) 04168232 C PRINT *,I,MSTACK(1,I) 04169232 C 995 CONTINUE 04170232 I = 0 04171123 IEXTRA = 0 04172123 1000 CONTINUE 04173115 C 04174115 C SET POINTER TO CORRECT DATA POSITION 04175115 C I IS THE NUMBER OF DESCRIPTORS 04176123 C IEXTRA IS THE NUMBER OF WORDS ADDED 04177123 C FOR TEXT DATA 04178123 C 04179115 I = I + 1 04180115 IF (I.GT.IPTR(31)) THEN 04181171 C RETURN IF COMPLETED SEARCH 04182171 GO TO 9000 04183171 END IF 04184171 KLK = I + IEXTRA 04185123 C PRINT *,'ENTRY',KLK,I,IPTR(31),IEXTRA,MSTACK(1,KLK) 04186*60 C 04187115 C IF TABLE A ENTRY OR EDITION NUMBER 04188115 C OR IF DESCRIPTOR IS NOT IN CLASS 0 04189115 C SKIP OVER 04190115 C 04191115 IF (MSTACK(1,KLK).EQ.1) THEN 04192123 C PRINT *,'A ENTRY' 04193164 GO TO 1000 04194**2 ELSE IF (MSTACK(1,KLK).EQ.2) THEN 04195123 C PRINT *,'A ENTRY LINE 1' 04196164 IEXTRA = IEXTRA + 7 04197123 GO TO 1000 04198**2 ELSE IF (MSTACK(1,KLK).EQ.3) THEN 04199123 C PRINT *,'A ENTRY LINE 2' 04200164 IEXTRA = IEXTRA + 7 04201123 GO TO 1000 04202**2 ELSE IF (MSTACK(1,KLK).GE.34048.AND.MSTACK(1,KLK).LE.34303) THEN 04203164 LY = MOD(MSTACK(1,KLK),256) 04204164 C PRINT *,'CLASS C - HAVE',LY,' BYTES OF TEXT' 04205*60 IF (MOD(LY,4).EQ.0) THEN 04206164 IWDS = LY / 4 04207164 ELSE 04208164 IWDS = LY / 4 + 1 04209164 END IF 04210164 IEXTRA = IEXTRA + IWDS - 1 04211164 GO TO 1000 04212164 ELSE IF (MSTACK(1,KLK).LT.10.OR.MSTACK(1,KLK).GT.255) THEN 04213164 C PRINT *,MSTACK(1,KLK),' NOT CLASS 0' 04214*60 GO TO 1000 04215115 END IF 04216115 C 04217115 C MUST FIND F X Y KEY FOR TABLE B 04218115 C OR TABLE D ENTRY 04219115 C 04220115 IZ = 1 04221164 KEYSET = 0 04222*40 10 CONTINUE 04223*36 IF (I.GT.IPTR(31)) THEN 04224164 GO TO 9000 04225164 END IF 04226164 KLK = I + IEXTRA 04227123 IF (MSTACK(1,KLK).GE.34048.AND.MSTACK(1,KLK).LE.34303) THEN 04228164 LY = MOD(MSTACK(1,KLK),256) 04229164 C PRINT *,'CLASS C - HAVE',LY,' TEXT BYTES' 04230249 IF (MOD(LY,4).EQ.0) THEN 04231164 IWDS = LY / 4 04232164 ELSE 04233164 IWDS = LY / 4 + 1 04234164 END IF 04235164 IEXTRA = IEXTRA + IWDS - 1 04236164 I = I + 1 04237164 GO TO 10 04238164 END IF 04239164 IF (MSTACK(1,KLK).GE.10.AND.MSTACK(1,KLK).LE.12) THEN 04240123 C 04241*40 C MUST INCLUDE PROCESSING FOR COMPRESSED DATA 04242*40 C 04243115 C BUILD DESCRIPTOR SEGMENT 04244115 C 04245115 IF (MSTACK(1,KLK).EQ.10) THEN 04246123 CALL FI8814 (KDATA(IZ,KLK),1,MF,IERR) 04247*78 C PRINT *,'F =',MF,KDATA(IZ,KLK),IPTR(31),I,IEXTRA 04248*60 KEYSET = IOR(KEYSET,4) 04249*46 C PRINT *,' KEYSET =',KEYSET 04250123 I = I + 1 04251136 GO TO 10 04252136 ELSE IF (MSTACK(1,KLK).EQ.11) THEN 04253123 CALL FI8814 (KDATA(IZ,KLK),2,MX,IERR) 04254*78 C PRINT *,'X =',MX,KDATA(IZ1,KLK) 04255*60 KEYSET = IOR(KEYSET,2) 04256*46 C PRINT *,' KEYSET =',KEYSET 04257123 I = I + 1 04258136 GO TO 10 04259136 ELSE IF (MSTACK(1,KLK).EQ.12) THEN 04260123 CALL FI8814 (KDATA(IZ,KLK),3,MY,IERR) 04261*78 C PRINT *,'Y =',MY,KDATA(IZ,KLK) 04262*60 KEYSET = IOR(KEYSET,1) 04263*46 C PRINT *,' KEYSET =',KEYSET 04264123 I = I + 1 04265*43 GO TO 10 04266*46 ELSE 04267135 C ERROR CONDITION 04268136 PRINT *,'LOOKING FOR KEY DESCRIPTOR FOR A TABLE B' 04269136 PRINT *,'OR A TABLE D ENTRY, BUT, GOT LOST' 04270136 END IF 04271115 END IF 04272115 IF (KEYSET.EQ.7) THEN 04273*47 C PRINT *,'HAVE KEY DESCRIPTOR',IZ,KFXY2(IXB+IZ),MF,MX,MY 04274248 C PRINT *,' MSTACK(1,',KLK,') =',MSTACK(1,KLK) 04275248 C 04276*47 C TEST NEXT DESCRIPTOR FOR TABLE B 04277*47 C OR TABLE D ENTRY, PROCESS ACCORDINGLY 04278*47 C 04279*47 IF (MSTACK(1,KLK).EQ.30) THEN 04280123 ITBLD2(1,IXD+IZ) =16384 * MF + 256 * MX + MY 04281*48 C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD2(1,IXD+IZ) 04282*60 GO TO 300 04283*47 ELSE IF (MSTACK(1,KLK).GE.13.AND.MSTACK(1,KLK).LE.20) THEN 04284123 KFXY2(IXB+IZ) = 16384 * MF + 256 * MX + MY 04285123 C PRINT *,'ELEMENT DESCRIPTOR',MF,MX,MY,KFXY2(IXB+IZ) 04286165 GO TO 200 04287*47 END IF 04288123 I = I + 1 04289124 IF (I.GT.IPTR(31)) THEN 04290123 GO TO 9000 04291164 END IF 04292123 GO TO 10 04293123 END IF 04294*47 GO TO 1000 04295115 C ================================================================== 04296115 200 CONTINUE 04297115 IBFLAG = 1 04298146 20 CONTINUE 04299*57 KLK = I + IEXTRA 04300123 C PRINT *,'ZZZ',KLK,I,IEXTRA,MSTACK(1,KLK),KDATA(IZ,KLK) 04301247 IF (MSTACK(1,KLK).LT.13.OR.MSTACK(1,KLK).GT.20) THEN 04302123 PRINT *,'IMPROPER SEQUENCE OF DESCRIPTORS IN LIST' 04303*53 C =============================================================== 04304123 ELSE IF (MSTACK(1,KLK).EQ.13) THEN 04305123 C 04306123 C ELEMENT NAME PART 1 - 32 BYTES/8 WDS 04307123 C 04308123 C FOR EACH SUBSET 04309123 C DO 210 IZ = 1, JK 04310164 C FOR THIS PARAMETER 04311123 JJ = IEXTRA 04312123 DO 21 LL = 1, 32, 4 04313123 LLL = LL + 3 04314123 KQK = I + JJ 04315123 IHOLD = KDATA(IZ,KQK) 04316123 C CALL W3AI39 (ASCCHR,4) 04317123 ANAME2(IXB+IZ)(LL:LLL) = ASCCHR 04318123 JJ = JJ + 1 04319123 21 CONTINUE 04320123 C 210 CONTINUE 04321164 IEXTRA = IEXTRA + 7 04322123 C DO 211 IZ = 1, JK 04323164 C PRINT *,'NAME1',IZ,JK,ANAME2(IXB+IZ) 04324165 C 211 CONTINUE 04325164 IBFLAG = IOR(IBFLAG,64) 04326123 C =============================================================== 04327123 ELSE IF (MSTACK(1,KLK).EQ.14) THEN 04328123 C 04329115 C ELEMENT NAME PART 2 - 32 BYTES/8 WDS 04330135 C 04331115 C FOR EACH SUBSET 04332123 C DO 220 IZ = 1, JK 04333164 C FOR THIS PARAMETER 04334123 JJ = IEXTRA 04335123 DO 22 LL = 33, 64, 4 04336123 LLL = LL + 3 04337123 KQK = I + JJ 04338123 IHOLD = KDATA(IZ,KQK) 04339123 C CALL W3AI39 (ASCCHR,4) 04340123 ANAME2(IXB+IZ)(LL:LLL) = ASCCHR 04341123 JJ = JJ + 1 04342123 22 CONTINUE 04343123 C 220 CONTINUE 04344164 IEXTRA = IEXTRA + 7 04345123 C DO 221 IZ = 1, JK 04346164 C PRINT *,'NAME2',IZ,JK,ANAME2(IXB+IZ) 04347165 C 221 CONTINUE 04348164 IBFLAG = IOR(IBFLAG,32) 04349123 C =============================================================== 04350123 ELSE IF (MSTACK(1,KLK).EQ.15) THEN 04351123 C 04352115 C UNITS NAME - 24 BYTES/6 WDS 04353115 C 04354115 C FOR EACH SUBSET 04355123 C DO 230 IZ = 1, JK 04356164 C FOR THIS PARAMETER 04357123 JJ = IEXTRA 04358123 DO 23 LL = 1, 24, 4 04359123 LLL = LL + 3 04360123 KQK = I + JJ 04361123 IHOLD = KDATA(IZ,KQK) 04362123 C CALL W3AI39 (ASCCHR,4) 04363123 AUNIT2(IXB+IZ)(LL:LLL) = ASCCHR 04364123 JJ = JJ + 1 04365123 23 CONTINUE 04366123 C 230 CONTINUE 04367164 IEXTRA = IEXTRA + 5 04368123 C DO 231 IZ = 1, JK 04369164 C PRINT *,'UNITS',IZ,JK,AUNIT2(IXB+IZ) 04370165 C 231 CONTINUE 04371164 IBFLAG = IOR(IBFLAG,16) 04372123 C =============================================================== 04373123 ELSE IF (MSTACK(1,KLK).EQ.16) THEN 04374123 C 04375115 C SCALE SIGN - 1 BYTE/ 1 WD 04376161 C 0 = POS, 1 = NEG 04377115 KLK = I + IEXTRA 04379123 IHOLD = KDATA(IZ,KLK) 04413120 IF (INDEX(ASCCHR,'-').EQ.0) THEN 04380120 ISCSGN(IZ) = 1 04381120 ELSE 04382120 ISCSGN(IZ) = -1 04383120 END IF 04384120 C =============================================================== 04385123 ELSE IF (MSTACK(1,KLK).EQ.17) THEN 04386123 C 04387115 C SCALE - 3 BYTES/ 1 WD 04388161 C 04389115 DO 25 LL = 1, 24, 4 04390123 KLK = I + IEXTRA 04391123 C DO 250 IZ = 1, JK 04392164 CALL FI8814(KDATA(IZ,KLK),3,ISCAL2(IXB+IZ),IERR) 04393*78 IF (IERR.NE.0) THEN 04394123 PRINT *,'NON-NUMERIC CHAR - CANNOT CONVERT' 04395123 IPTR(1) = 888 04396123 GO TO 9000 04397164 END IF 04398123 ISCAL2(IXB+IZ) = ISCAL2(IXB+IZ) * ISCSGN(IZ) 04399119 C 250 CONTINUE 04400164 25 CONTINUE 04401123 C DO 251 IZ = 1, JK 04402164 C PRINT *,'SCAL ',IXB+IZ,JK,ISCAL2(IXB+IZ) 04403165 C 251 CONTINUE 04404164 IBFLAG = IOR(IBFLAG,8) 04405123 C =============================================================== 04406123 ELSE IF (MSTACK(1,KLK).EQ.18) THEN 04407123 C 04408115 C REFERENCE SIGN - 1 BYTE/ 1 WD 04409161 C 0 = POS, 1 = NEG 04410115 C 04411115 KLK = I + IEXTRA 04412120 IHOLD = KDATA(IZ,KLK) 04413120 IF (INDEX(ASCCHR,'-').EQ.0) THEN 04414120 IRFSGN(IZ) = 1 04415123 ELSE 04416123 IRFSGN(IZ) = -1 04417123 END IF 04418123 C =============================================================== 04419123 ELSE IF (MSTACK(1,KLK).EQ.19) THEN 04420123 C 04421115 C REFERENCE VALUE - 10 BYTES/ 3 WDS 04422161 C 04423115 C DO 260, IZ = 1, JK 04424164 JJ = IEXTRA 04425123 KQK = I + JJ 04426123 DO 26 LL = 1, 12, 4 04427123 LLL = LL + 3 04428123 KQK = I + JJ 04429123 IHOLD = KDATA(IZ,KQK) 04430123 AAAA(LL:LLL) = ASCCHR 04431123 JJ = JJ + 1 04432123 26 CONTINUE 04433123 CALL FI8814(AAAA,10,IRFVL2(IXB+IZ),IERR) 04434*78 IF (IERR.NE.0) THEN 04435123 PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT' 04436123 IPTR(1) = 888 04437123 GO TO 9000 04438164 END IF 04439123 IRFVL2(IXB+IZ) = IRFVL2(IXB+IZ) * IRFSGN(IZ) 04440119 C 260 CONTINUE 04441164 IEXTRA = IEXTRA + 2 04442123 C DO 261 IZ = 1, JK 04443164 C PRINT *,'RFVAL',IXB+IZ,JK,IRFVL2(IXB+IZ) 04444165 C 261 CONTINUE 04445164 IBFLAG = IOR(IBFLAG,4) 04446123 C =============================================================== 04447123 ELSE 04448123 C 04449115 C ELEMENT DATA WIDTH - 3 BYTES/ 1 WD 04450115 C 04451115 DO 27 LL = 1, 24, 4 04452123 KLK = I + IEXTRA 04453123 C DO 270 IZ = 1, JK 04454164 CALL FI8814(KDATA(IZ,KLK),3,IWIDE2(IXB+IZ),IERR) 04455*78 IF (IERR.NE.0) THEN 04456123 PRINT *,'NON-NUMERIC CHAR - CANNOT CONVERT' 04457123 IPTR(1) = 888 04458123 GO TO 9000 04459164 END IF 04460123 IF (IWIDE2(IXB+IZ).LT.1) THEN 04461111 IPTR(1) = 890 04462109 C PRINT *,'CLASS 0 DESCRIPTOR, WIDTH=0',KFXY2(IXB+IZ)04463113 GO TO 9000 04464109 END IF 04465109 C 270 CONTINUE 04466164 27 CONTINUE 04467123 C DO 271 IZ = 1, JK 04468164 C PRINT *,'WIDTH',IXB+IZ,JK,IWIDE2(IXB+IZ) 04469165 C 271 CONTINUE 04470164 IBFLAG = IOR(IBFLAG,2) 04471123 END IF 04472123 C NO, IT ISN'T 04473115 C 04474115 C IF THERE ARE ENOUGH OF THE ELEMENTS 04475115 C NECESSARY TO ACCEPT A TABLE B ENTRY 04476115 C 04477146 C PRINT *,' IBFLAG =',IBFLAG 04478123 IF (IAND(IBFLAG,64).NE.0) THEN 04479123 IF (IAND(IBFLAG,32).NE.0) THEN 04480123 IF (IAND(IBFLAG,16).NE.0) THEN 04481123 IF (IAND(IBFLAG,8).NE.0) THEN 04482123 IF (IAND(IBFLAG,4).NE.0) THEN 04483123 IF (IAND(IBFLAG,2).NE.0) THEN 04484123 C PRINT *,'COMPLETE TABLE B ENTRY' 04485165 C HAVE A COMPLETE TABLE B ENTRY 04486146 IXB = IXB + IZ 04487164 C PRINT *,'B',IXB,JK,KFXY2(IXB),ANAME2(IXB) 04488107 C PRINT *,' ',AUNIT2(IXB),ISCAL2(IXB), 04489107 C * IRFVL2(IXB),IWIDE2(IXB) 04490107 IPTR(41) = IXB 04491164 GO TO 1000 04492123 END IF 04493123 END IF 04494123 END IF 04495123 END IF 04496123 END IF 04497123 END IF 04498123 I = I + 1 04499123 C 04500123 C CHECK NEXT DESCRIPTOR 04501123 C 04502123 IF (I.GT.IPTR(31)) THEN 04503123 C RETURN IF COMPLETED SEARCH 04504123 GO TO 9000 04505123 END IF 04506123 GO TO 20 04507*55 C ================================================================== 04508115 300 CONTINUE 04509115 ISEQ = 0 04510135 30 CONTINUE 04511135 KLK = I + IEXTRA 04512123 C PRINT *,'HAVE A SEQUENCE DESCRIPTOR',KLK,KDATA(IZ,KLK) 04513250 IF (MSTACK(1,KLK).EQ.30) THEN 04514123 C FROM TEXT FIELD (6 BYTES/2 WDS) 04515115 C STRIP OUT NEXT DESCRIPTOR IN SEQUENCE 04516115 C 04517115 C DO 350 IZ = 1, JK 04518164 C F - EXTRACT AND CONVERT TO DECIMAL 04519115 JJ = IEXTRA 04520123 DO 351 LL = 1, 6, 4 04521123 KQK = I + JJ 04522123 LLL = LL + 3 04523123 IHOLD = KDATA(IZ,KQK) 04524123 C PRINT *,KDATA(IZ,KQK) 04525248 AAAA(LL:LLL) = ASCCHR(1:4) 04526123 JJ = JJ + 1 04527129 351 CONTINUE 04528123 C CONVERT TO INTEGER 04529123 CALL FI8814(AAAA,6,IHOLD,IERR) 04530*95 C PRINT *,'INTEGER=',IHOLD 04531250 IF (IERR.NE.0) THEN 04532*65 PRINT *,'NON NUMERIC CHARACTER FOUND IN F X Y' 04533*65 IPTR(1) = 888 04534123 GO TO 9000 04535164 END IF 04536123 C CONSTRUCT SEQUENCE DESCRIPTOR 04537135 IFF = IHOLD / 100000 04538123 IXX = MOD((IHOLD/1000),100) 04539123 IYY = MOD(IHOLD,1000) 04540123 C INSERT IN PROPER SEQUENCE 04541135 ITBLD2(ISEQ+2,IXD+IZ) = 16384 * IFF + 256 * IXX + IYY 04542*48 C PRINT *,'SEQUENCE',IZ,AAAA,IHOLD,ITBLD2(ISEQ+2,IXD+IZ) 04543*48 ISEQ = ISEQ + 1 04544135 C IF (ISEQ.GT.10) PRINT *,'ISEQ =',ISEQ 04545*78 C 350 CONTINUE 04546164 C SET TO LOOK AT NEXT DESCRIPTOR 04547135 I = I + 1 04548164 IEXTRA = IEXTRA + 1 04549164 GO TO 30 04550135 ELSE 04551135 C NEXT DESCRIPTOR IS NOT A SEQUENCE DESC04552135 IF (ISEQ.GT.1) THEN 04553135 IXD = IXD + IZ 04554164 IPTR(42) = IXD 04555164 END IF 04556135 I = I - 1 04557168 END IF 04558115 C GO TEST NEXT DESCRIPTOR 04559135 GO TO 1000 04560135 C ================================================================== 04561115 9000 CONTINUE 04562164 C PRINT *,IPTR(41),' ENTRIES IN ANCILLARY TABLE B' 04563164 C PRINT *,IPTR(42),' ENTRIES IN ANCILLARY TABLE D' 04564164 IF (I.GE.IPTR(31)) THEN 04565164 C 04566164 C ALL DESCRIPTORS CHECKED 04567164 IF (IPTR(41).NE.0) THEN 04568164 C PRINT OUT TABLE B 04569164 KK = IPTR(41) + 1 04570*21 DO 6000 I = 1, IPTR(41)-1 04571*21 DO 5000 J = I+1, IPTR(41) 04572*21 IF (KFXY2(J).LT.KFXY2(I)) THEN 04573*23 KFXY2(KK) = KFXY2(I) 04574*21 KFXY2(I) = KFXY2(J) 04575*23 KFXY2(J) = KFXY2(KK) 04576*21 ANAME2(KK) = ANAME2( I) 04577*21 ANAME2( I) = ANAME2( J) 04578*21 ANAME2( J) = ANAME2(KK) 04579*21 AUNIT2(KK) = AUNIT2( I) 04580*21 AUNIT2( I) = AUNIT2( J) 04581*21 AUNIT2( J) = AUNIT2(KK) 04582*21 ISCAL2(KK) = ISCAL2( I) 04583*21 ISCAL2( I) = ISCAL2( J) 04584*21 ISCAL2( J) = ISCAL2(KK) 04585*21 IRFVL2(KK) = IRFVL2( I) 04586*22 IRFVL2( I) = IRFVL2( J) 04587*22 IRFVL2( J) = IRFVL2(KK) 04588*22 IWIDE2(KK) = IWIDE2( I) 04589*21 IWIDE2( I) = IWIDE2( J) 04590*21 IWIDE2( J) = IWIDE2(KK) 04591*21 END IF 04592*21 5000 CONTINUE 04593*21 6000 CONTINUE 04594*21 C PRINT *,' HERE IS THE ANCILLARY TABLE B' 04595*78 DO 2000 KB = 1, IPTR(41) 04596164 JF = KFXY2(KB) / 16384 04597164 JX = MOD((KFXY2(KB) / 256),64) 04598164 JY = MOD(KFXY2(KB),256) 04599164 C WRITE (6,2001)JF,JX,JY,ANAME2(KB), 04600*78 C * AUNIT2(KB),ISCAL2(KB),IRFVL2(KB),IWIDE2(KB) 04601*78 2000 CONTINUE 04602164 2001 FORMAT (1X,I1,1X,I2,1X,I3,2X,A64,3X,A24,2X,I5,2X,I12, 04603164 * 2X,I4) 04604164 ELSE 04605164 C PRINT *,'NO ANCILLARY TABLE B' 04606164 END IF 04607164 IF (IPTR(42).NE.0) THEN 04608164 C PRINT OUT TABLE 04609164 KK = IPTR(42) + 1 04610*25 DO 8000 I = 1, IPTR(42)-1 04611*25 DO 7000 J = I+1, IPTR(42) 04612*25 C SWAP POSITIONS 04613*25 IF (ITBLD2(1,J).LT.ITBLD2(1,I)) THEN 04614*48 DO 6500 M = 1, 14 04615*76 ITBLD2(M,KK) = ITBLD2(M,I) 04616*48 ITBLD2(M,I) = ITBLD2(M,J) 04617*48 ITBLD2(M,J) = ITBLD2(M,KK) 04618*48 6500 CONTINUE 04619*25 END IF 04620*25 7000 CONTINUE 04621*25 8000 CONTINUE 04622*25 C PRINT *,' HERE IS THE ANCILLARY TABLE D' 04623164 DO 3000 KB = 1, IPTR(42) 04624164 DO 2999 KZ = 1, 14 04625*76 I1(KZ) = ITBLD2(KZ,KB) / 16384 04626*48 I2(KZ) = MOD((ITBLD2(KZ,KB)/256),64) 04627*48 I3(KZ) = MOD(ITBLD2(KZ,KB),256) 04628*48 2999 CONTINUE 04629164 C WRITE (6,3001)(I1(KZ),I2(KZ),I3(KZ),KZ=1,13) 04630*78 3000 CONTINUE 04631164 3001 FORMAT (15(2X,I1,I2,I3)) 04632164 ELSE 04633164 C PRINT *,'NO ANCILLARY TABLE D' 04634164 END IF 04635164 C EXIT ROUTINE, ALL DONE WITH PASS 04636164 END IF 04637164 RETURN 04638164 END 04639115 SUBROUTINE FI8814 (ASCCHR,NPOS,NEWVAL,IERR) 04640*78 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 04641115 C . . . . 04642115 C SUBPROGRAM: FI8814 CONVERT ASCII TO INTEGER 04643*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04 04644191 C 04645115 C ABSTRACT: CONVERT ASCII CHARACTES TO INTEGER VALUE 04646115 C 04647115 C PROGRAM HISTORY LOG: 04648115 C 94-03-04 CAVANAUGH 04649191 C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE 04650115 C 04651115 C USAGE: CALL FI8814 (ASCCHR,NPOS,NEWVAL,IERR) 04652*78 C INPUT ARGUMENT LIST: 04653115 C ASCCHR - 04654191 C NPOS - 04655191 C NEWVAL - 04656191 C IERR - 04657191 C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, 04658115 C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. 04659115 C 04660115 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 04661115 C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. 04662115 C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN 04663115 C ERRFLAG - EVEN IF MANY LINES ARE NEEDED 04664115 C 04665115 C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) 04666115 C DDNAME1 - GENERIC NAME & CONTENT 04667115 C 04668115 C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) 04669115 C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE 04670115 C FT06F001 - INCLUDE IF ANY PRINTOUT 04671115 C 04672115 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION 04673115 C 04674115 C ATTRIBUTES: 04675115 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS 04676115 C MACHINE: NAS, CYBER, WHATEVER 04677115 C 04678115 C$$$ 04679115 INTEGER IERR, IHOLD 04680116 CHARACTER*4 AHOLD 04681*58 CHARACTER*64 ASCCHR 04682116 EQUIVALENCE (IHOLD,AHOLD) 04683*58 C ---------------------------------------------------------- 04684116 IERR = 0 04685115 NEWVAL = 0 04686115 C 04687115 DO 1000 I = 1, NPOS 04688115 IHOLD = 0 04689*58 AHOLD(4:4) = ASCCHR(I:I) 04690*58 IF (IHOLD.EQ.32) THEN 04691*79 GO TO 2000 04692*85 ELSE IF (IHOLD.LT.48.OR.IHOLD.GT.57) THEN 04693*79 IERR = 1 04694115 RETURN 04695115 ELSE 04696115 NEWVAL = NEWVAL * 10 + IHOLD - 48 04697115 END IF 04698115 1000 CONTINUE 04699115 2000 CONTINUE 04700*85 RETURN 04701117 END 04702117 SUBROUTINE FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD, 04703*78 * ANAME3,AUNIT3, 04704187 * ISCAL3,IRFVL3,IWIDE3, 04705187 * KEYSET,IBFLAG,IERR) 04706188 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 04707146 C . . . . 04708146 C SUBPROGRAM: FI8815 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES 04709*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04 04710191 C 04711146 C ABSTRACT: EXTRACT TABLE A, TABLE B, ENTRIES FROM ACTIVE BUFR MESSAGE 04712174 C TO BE RETAINED FOR USE DURING THE DECODING OF ACTIVE BUFR MESSAGE. 04713174 C THESE WILL BE DISCARDED WHEN DECODING OF CURRENT MESSAGE IS COMPLETE04714174 C 04715146 C PROGRAM HISTORY LOG: 04716146 C 94-03-04 CAVANAUGH 04717191 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE 04718146 C 04719146 C USAGE: CALL FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD, 04720*78 C * ANAME3,AUNIT3, 04721187 C * ISCAL3,IRFVL3,IWIDE3, 04722187 C * KEYSET,IBFLAG,IERR) 04723188 C INPUT ARGUMENT LIST: 04724146 C IPTR - 04725174 C MAXR - 04726174 C MAXD - 04727174 C MSTACK - 04728174 C KDATA - 04729174 C IDENT - 04730174 C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, 04731146 C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. 04732146 C 04733146 C OUTPUT ARGUMENT LIST: 04734146 C ANAME3 - 04735174 C AUNIT3 - 04736174 C KFXY3 - 04737174 C ISCAL3 - 04738174 C IRFVL3 - 04739174 C IWIDE3 - 04740174 C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. 04741146 C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN 04742146 C ERRFLAG - EVEN IF MANY LINES ARE NEEDED 04743146 C 04744146 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION 04745146 C 04746146 C ATTRIBUTES: 04747146 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS 04748146 C MACHINE: NAS, CYBER 04749174 C 04750146 C$$$ 04751146 CHARACTER*64 ANAME3(*),SPACES 04752182 CHARACTER*24 AUNIT3(*) 04753182 C 04754146 INTEGER IPTR(*),MAXR,MAXD,JDESC 04755182 INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD) 04756146 INTEGER IEXTRA 04757182 INTEGER KEYSET 04758182 INTEGER KFXY3(*),IDENT(*) 04759114 INTEGER ISCAL3(*),ISCSGN(150) 04760185 INTEGER IRFVL3(*),IRFSGN(150) 04761185 INTEGER IWIDE3(*) 04762182 C ============================================================== 04763146 C PRINT *,'FI8815' 04764*78 IEXTRA = 0 04765114 C BUILD SPACE CONSTANT 04766146 DO 1 I = 1, 64 04767146 SPACES(I:I) = ' ' 04768146 1 CONTINUE 04769146 C INITIALIZE ENTRY COUNTS 04770146 IXA = 0 04771146 IXB = 0 04772146 IXD = 0 04773146 C 04774146 C SET FOR COMPRESSED OR NON COMPRESSED 04775146 C PROCESSING 04776146 C 04777146 IF (IDENT(16).EQ.0) THEN 04778146 JK = 1 04779146 ELSE 04780146 JK = IDENT(14) 04781146 END IF 04782146 C 04783146 C CLEAR NECESSARY ENTRIES 04784146 C 04785146 DO 2 IY = 1, JK 04786146 C 04787146 C CLEAR NEXT TABLE B ENTRY 04788146 C 04789146 KFXY3(IXB+IY) = 0 04790183 ANAME3(IXB+IY)(1:64) = SPACES(1:64) 04791183 AUNIT3(IXB+IY)(1:24) = SPACES(1:24) 04792183 ISCAL3(IXB+IY) = 0 04793183 IRFVL3(IXB+IY) = 0 04794183 IWIDE3(IXB+IY) = 0 04795183 ISCSGN(IY) = 1 04796146 IRFSGN(IY) = 1 04797146 2 CONTINUE 04798146 C 04799146 C START PROCESSING ENTRIES 04800146 C 04801146 I = 0 04802146 1000 CONTINUE 04803146 C 04804146 C SET POINTER TO CORRECT DATA POSITION 04805146 C 04806146 K = I + IEXTRA 04807146 C 04808146 C MUST FIND F X Y KEY FOR TABLE B 04809146 C OR TABLE D ENTRY 04810146 C 04811146 IF (JDESC.GE.10.AND.JDESC.LE.12) THEN 04812183 10 CONTINUE 04813146 C 04814146 C BUILD DESCRIPTOR SEGMENT 04815146 C 04816146 DO 20 LY = 1,JK 04817198 IF (JDESC.EQ.10) THEN 04818198 KFXY3(IXB+LY) = KDATA(K,1) * 16384 + KFXY3(IXB+LY) 04819198 KEYSET = IOR(KEYSET,4) 04820198 I = I + 1 04821198 GO TO 10 04822198 ELSE IF (JDESC.EQ.11) THEN 04823198 KFXY3(IXB+LY) = KDATA(K,1) * 256 + KFXY3(IXB+LY) 04824198 KEYSET = IOR(KEYSET,2) 04825198 I = I + 1 04826198 GO TO 10 04827198 ELSE IF (JDESC.EQ.12) THEN 04828198 KFXY3(IXB+LY) = KDATA(K,1) + KFXY3(IXB+LY) 04829198 KEYSET = IOR(KEYSET,1) 04830198 END IF 04831198 20 CONTINUE 04832198 C ================================================================== 04833146 ELSE IF (JDESC.GE.13.AND.JDESC.LE.20) THEN 04834198 DO 250 IZ = 1, JK 04835187 IF (JDESC.EQ.13) THEN 04836183 C 04837146 C ELEMENT NAME PART 1 - 32 BYTES/8 WDS 04838146 C 04839146 CALL GBYTES (ANAME3(IXB+IZ),KDATA(K,IZ),0,32,0,8) 04840183 IBFLAG = IOR(IBFLAG,16) 04841187 ELSE IF (JDESC.EQ.14) THEN 04842183 C 04843146 C ELEMENT NAME PART 2 - 32 BYTES/8 WDS 04844146 C 04845146 CALL GBYTES(ANAME3(IXB+IZ)(33:33),KDATA(K,IZ),0,32,0,8)04846183 ELSE IF (JDESC.EQ.15) THEN 04847183 C 04848146 C UNITS NAME - 24 BYTES/6 WDS 04849146 C 04850146 CALL GBYTES (AUNIT3(IXB+IZ)(1:1),KDATA(K,IZ),0,32,0,6)04851183 IBFLAG = IOR(IBFLAG,8) 04852187 ELSE IF (JDESC.EQ.16) THEN 04853183 C 04854146 C UNITS SCALE SIGN - 1 BYTE/ 1 WD 04855146 C 0 = POS, 1 = NEG 04856146 IF (KDATA(K,1).NE.48) THEN 04857146 ISCSGN(IZ) = -1 04858146 ELSE 04859146 ISCSGN(IZ) = 1 04860146 END IF 04861146 ELSE IF (JDESC.EQ.17) THEN 04862183 C 04863146 C UNITS SCALE - 3 BYTES/ 1 WD 04864146 C 04865146 CALL FI8814(KDATA(K,IZ),3,ISCAL3(IXB+IZ),IERR) 04866116 IF (IERR.NE.0) THEN 04867146 PRINT *,'NON-NUMERIC CHARACTER - CANNOT CONVERT' 04868146 IPTR(1) = 888 04869146 RETURN 04870146 END IF 04871146 IBFLAG = IOR(IBFLAG,4) 04872187 ELSE IF (JDESC.EQ.18) THEN 04873183 C 04874146 C UNITS REFERENCE SIGN - 1 BYTE/ 1 WD 04875146 C 0 = POS, 1 = NEG 04876146 C 04877146 IF (KDATA(K,1).EQ.48) THEN 04878146 IRFSGN(IZ) = 1 04879146 ELSE 04880146 IRFSGN(IZ) = -1 04881146 END IF 04882146 ELSE IF (JDESC.EQ.19) THEN 04883183 C 04884146 C UNITS REFERENCE VALUE - 10 BYTES/ 3 WDS 04885146 C 04886146 CALL FI8814(KDATA(K,IZ),10,IRFVL3(IXB+IZ),IERR) 04887116 IF (IERR.NE.0) THEN 04888146 PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT' 04889146 IPTR(1) = 888 04890146 RETURN 04891146 END IF 04892146 IBFLAG = IOR(IBFLAG,2) 04893187 ELSE 04894146 C 04895146 C ELEMENT DATA WIDTH - 3 BYTES/ 1 WD 04896146 C 04897146 CALL FI8814(KDATA(K,1),3,IWIDE3(IXB+1),IERR) 04898116 IF (IERR.NE.0) THEN 04899146 PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT' 04900146 IPTR(1) = 888 04901146 RETURN 04902146 END IF 04903146 IBFLAG = IOR(IBFLAG,1) 04904187 END IF 04905146 250 CONTINUE 04906187 END IF 04907187 C ================================================================== 04908146 9000 RETURN 04909146 END 04910146 SUBROUTINE FI8818(IPTR, 04911*78 * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, 04912**2 * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) 04913**2 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 04914**2 C . . . . 04915**2 C SUBPROGRAM: FI8818 MERGE ANCILLARY & STANDARD B ENTRIES 04916*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD 04917**2 C 04918**2 C ABSTRACT: START ABSTRACT HERE AND INDENT TO COLUMN 5 ON THE 04919**2 C FOLLOWING LINES. SEE NMC HANDBOOK SECTION 3.1.1. FOR DETAILS 04920**2 C 04921**2 C PROGRAM HISTORY LOG: 04922**2 C YY-MM-DD CAVANAUGH 04923**2 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE 04924**2 C 04925**2 C USAGE: CALL FI8818(IPTR, 04926*78 C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, 04927**2 C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) 04928**2 C INPUT ARGUMENT LIST: 04929**2 C IPTR - 04930**2 C KFXY1 - 04931**2 C ANAME1 - 04932**2 C AUNIT1 - 04933**2 C ISCAL1 - 04934**2 C IRFVL1 - 04935**2 C IWIDE1 - 04936**2 C KFXY2 - 04937**2 C ANAME2 - 04938**2 C AUNIT2 - 04939**2 C ISCAL2 - 04940**2 C IRFVL2 - 04941**2 C IWIDE2 - 04942**2 C 04943**2 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 04944**2 C IPTR - 04945**2 C KFXY1 - 04946**2 C ANAME1 - 04947**2 C AUNIT1 - 04948**2 C ISCAL1 - 04949**2 C IRFVL1 - 04950**2 C IWIDE1 - 04951**2 C 04952**2 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION 04953**2 C 04954**2 C ATTRIBUTES: 04955**2 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS 04956**2 C MACHINE: NAS, CYBER, WHATEVER 04957**2 C 04958**2 C$$$ 04959**2 C .................................................. 04960*41 C 04961*41 C NEW BASE TABLE B 04962*41 C MAY BE A COMBINATION OF MASTER TABLE B 04963*41 C AND ANCILLARY TABLE B 04964*41 C 04965*41 INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) 04966*44 CHARACTER*40 ANAME1(*) 04967*41 CHARACTER*24 AUNIT1(*) 04968*41 C .................................................. 04969*43 C 04970*43 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE 04971*43 C 04972*43 INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*) 04973*43 CHARACTER*64 ANAME2(*) 04974*43 CHARACTER*24 AUNIT2(*) 04975*43 C .................................................. 04976*43 INTEGER IPTR(*) 04977**2 C 04978**2 C SET UP POINTERS 04979**2 C PRINT *,'FI8818-A',IPTR(21),IPTR(41) 04980*78 KAB = 1 04981**2 KB = 1 04982**2 1000 CONTINUE 04983**2 C PRINT *,KB,KAB,KFXY1(KB),KFXY2(KAB),IPTR(21) 04984*57 IF (KB.GT.IPTR(21)) THEN 04985**2 C NO MORE MASTER ENTRIES 04986**8 C PRINT *,'NO MORE MASTER ENTRIES' 04987*57 IF (KAB.GT.IPTR(41)) THEN 04988**6 GO TO 5000 04989**2 END IF 04990**2 C APPEND ANCILLARY ENTRY 04991**2 GO TO 2000 04992**2 ELSE IF (KB.LE.IPTR(21)) THEN 04993**2 C HAVE MORE MASTER ENTRIES 04994**8 IF (KAB.GT.IPTR(41)) THEN 04995**2 C NO MORE ANCILLARY ENTRIES 04996**8 GO TO 5000 04997**8 END IF 04998**2 IF (KFXY2(KAB).EQ.KFXY1(KB)) THEN 04999**2 C REPLACE MASTER ENTRY 05000**2 GO TO 3000 05001**2 ELSE IF (KFXY2(KAB).LT.KFXY1(KB)) THEN 05002**2 C INSERT ANCILLARY ENTRY 05003**2 GO TO 4000 05004**2 ELSE IF (KFXY2(KAB).GT.KFXY1(KB)) THEN 05005**2 C SKIP MASTER ENTRY 05006**2 KB = KB + 1 05007**2 END IF 05008**2 END IF 05009**2 GO TO 1000 05010**2 2000 CONTINUE 05011**2 IPTR(21) = IPTR(21) + 1 05012**2 C APPEND ANCILLARY ENTRY 05013**2 KFXY1(IPTR(21)) = KFXY2(KAB) 05014**2 ANAME1(IPTR(21))(1:40) = ANAME2(KAB)(1:40) 05015**2 AUNIT1(IPTR(21)) = AUNIT2(KAB) 05016**2 ISCAL1(IPTR(21)) = ISCAL2(KAB) 05017**2 IRFVL1(1,IPTR(21)) = IRFVL2(KAB) 05018*44 IWIDE1(IPTR(21)) = IWIDE2(KAB) 05019**2 C PRINT *,IPTR(21),KFXY1(IPTR(21)),' APPENDED' 05020106 KAB = KAB + 1 05021**2 GO TO 1000 05022**2 3000 CONTINUE 05023**2 C REPLACE MASTER ENTRY 05024**2 KFXY1(KB) = KFXY2(KAB) 05025**2 ANAME1(KB) = ANAME2(KAB)(1:40) 05026**2 AUNIT1(KB) = AUNIT2(KAB) 05027**2 ISCAL1(KB) = ISCAL2(KAB) 05028**2 IRFVL1(1,KB) = IRFVL2(KAB) 05029*44 IWIDE1(KB) = IWIDE2(KAB) 05030**2 C PRINT *,KB,KFXY1(KB),'REPLACED',IWIDE1(KB) 05031106 KAB = KAB + 1 05032**2 KB = KB + 1 05033**2 GO TO 1000 05034**2 4000 CONTINUE 05035**2 MV = IPTR(21) - KB + 1 05036**2 MV1 = IPTR(21) 05037**2 C SHIFT TAIL UP 1 POSITION 05038**2 DO 4500 I = 1, MV 05039**2 MV2 = MV1 + 1 05040**2 KFXY1(MV2) = KFXY1(MV1) 05041**2 ANAME1(MV2) = ANAME1(MV1) 05042**2 AUNIT1(MV2) = AUNIT1(MV1) 05043**2 ISCAL1(MV2) = ISCAL1(MV1) 05044**2 IRFVL1(1,MV2) = IRFVL1(1,MV1) 05045*44 IWIDE1(MV2) = IWIDE1(MV1) 05046**2 MV1 = MV1 - 1 05047**2 4500 CONTINUE 05048**2 C INSERT ANCILLARY ENTRY 05049**2 KFXY1(KB) = KFXY2(KAB) 05050**2 ANAME1(KB)(1:40) = ANAME2(KAB)(1:40) 05051**2 AUNIT1(KB) = AUNIT2(KAB) 05052**2 ISCAL1(KB) = ISCAL2(KAB) 05053**2 IRFVL1(1,KB) = IRFVL2(KAB) 05054*48 IWIDE1(KB) = IWIDE2(KAB) 05055**2 IPTR(21) = IPTR(21) + 1 05056**2 C PRINT *,KB,KFXY1(KB),'INSERTED' 05057*57 KAB = KAB + 1 05058*14 GO TO 1000 05059**2 5000 CONTINUE 05060**2 IPTR(41) = 0 05061**2 C PROCESSING COMPLETE 05062**2 C PRINT *,'FI8818-B',IPTR(21),IPTR(41) 05063*78 C DO 6000 I = 1, IPTR(21) 05064*78 C PRINT *,'FI8818-C',I,KFXY1(I) 05065*78 C6000 CONTINUE 05066*78 RETURN 05067**2 END 05068**2 SUBROUTINE FI8819(IPTR,ITBLD,ITBLD2) 05069*78 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 05070**2 C . . . . 05071**2 C SUBPROGRAM: FI8819 MERGE ANCILLARY & MASTER TABLE D 05072*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD 05073**2 C 05074**2 C ABSTRACT: MERGE TABLE D ENTRIES WITH THE ENTRIES FROM THE STANDARD 05075**2 C TABLE D. ASSURE THAT ENTRIES ARE SEQUENTIAL. 05076**2 C 05077**2 C PROGRAM HISTORY LOG: 05078**2 C YY-MM-DD CAVANAUGH 05079**2 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE 05080**2 C 05081**2 C USAGE: CALL FI8819(IPTR,ITBLD,ITBLD2) 05082*78 C INPUT ARGUMENT LIST: 05083**2 C IPTR - 05084**2 C ITBLD - 05085**2 C ITBLD2 - 05086**2 C 05087**2 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 05088**2 C IPTR - 05089**2 C ITBLD - 05090**2 C 05091**2 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION 05092**2 C 05093**2 C ATTRIBUTES: 05094**2 C LANGUAGE: FORTRAN 77 05095**2 C MACHINE: NAS, CYBER 05096**2 C 05097**2 C$$$ 05098**2 C .................................................. 05099*41 C 05100*41 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE 05101*41 C 05102*41 INTEGER ITBLD2(14,*) 05103*77 C .................................................. 05104*42 C 05105*42 C NEW BASE TABLE D 05106*42 C 05107*42 INTEGER ITBLD(14,*) 05108*77 C .................................................. 05109*42 INTEGER IPTR(*) 05110**2 C PRINT *,'FI8819-A',IPTR(20),IPTR(42) 05111*78 C SET UP POINTERS 05112**2 KAD = 1 05113**2 KD = 1 05114**2 1000 CONTINUE 05115**2 C PRINT *,'FI8819-A',KD,ITBLD(1,KD),KAD,ITBLD2(1,KAD) 05116*78 IF (ITBLD2(1,KAD).EQ.ITBLD(1,KD)) THEN 05117*48 C REPLACE MASTER W / ANCILLARY 05118*30 C PRINT *,'REPLACE' 05119*57 DO 4250 I = 1, 14 05120*77 ITBLD(I,KD) = ITBLD2(I,KAD) 05121*48 4250 CONTINUE 05122*30 KD = KD + 1 05123*30 KAD = KAD + 1 05124*30 IF (KAD.GT.IPTR(42)) THEN 05125*35 05126*35 GO TO 5000 05127*30 END IF 05128*30 ELSE IF (ITBLD2(1,KAD).LT.ITBLD(1,KD)) THEN 05129*48 C INSERT 05130*30 C SHIFT TAIL TO GET OPENING 05131*30 C PRINT *,'INSERT ' 05132*57 MV = IPTR(20) - KD + 1 05133*36 MV1 = IPTR(20) 05134*30 DO 3500 I = 1, MV 05135*30 MV2 = MV1 + 1 05136*30 DO 3250 J = 1, 14 05137*77 ITBLD(J,MV2) = ITBLD(J,MV1) 05138*48 3250 CONTINUE 05139*30 MV1 = MV1 - 1 05140*30 3500 CONTINUE 05141*30 C INSERT ANCILLARY INTO MASTER 05142*30 DO 3750 I = 1, 14 05143*77 ITBLD(I,KD) = ITBLD2(I,KAD) 05144*48 3750 CONTINUE 05145*30 IPTR(20) = IPTR(20) + 1 05146*30 KD = KD + 1 05147*30 KAD = KAD + 1 05148*30 ELSE 05149*30 IF (KD.GT.IPTR(20)) THEN 05150*30 C APPEND THIS ANCILLARY ENTRY 05151*30 C PRINT *,'APPEND ' 05152*57 IPTR(20) = IPTR(20) + 1 05153*30 DO 2500 I = 1, 14 05154*77 ITBLD(I,IPTR(20)) = ITBLD2(I,KAD) 05155*48 2500 CONTINUE 05156*30 KAD = KAD + 1 05157*30 KD = KD + 1 05158*30 ELSE 05159*34 C SKIP MASTER ENTRY 05160*34 KD = KD + 1 05161*34 END IF 05162*30 END IF 05163*30 IF (KAD.GT.IPTR(42)) THEN 05164*35 GO TO 5000 05165*30 END IF 05166*30 GO TO 1000 05167*30 C ======================================================= 05168*30 5000 CONTINUE 05169**2 IPTR(42) = 0 05170**2 C PRINT *,'MERGED TABLE D -- FI8819-B',IPTR(20),IPTR(42) 05171*78 DO 6000 I = 1, IPTR(20) 05172*27 C WRITE (6,6001)I,(ITBLD(J,I),J=1,14) 05173*77 6001 FORMAT(15(1X,I5)) 05174*77 6000 CONTINUE 05175*27 RETURN 05176**2 END 05177**2 SUBROUTINE FI8820 (ITBLD,IUNITD,IPTR,ITBLD2) 05178*78 C$$$ SUBPROGRAM DOCUMENTATION BLOCK 05179*99 C . . . . 05180*99 C SUBPROGRAM: FI8820 READ IN BUFR TABLE D 05181*78 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-05-06 05182*99 C 05183*99 C ABSTRACT: READ IN BUFR TABLE D 05184*99 C 05185*99 C PROGRAM HISTORY LOG: 05186*99 C 93-05-06 CAVANAUGH 05187*99 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE 05188*99 C 05189*99 C USAGE: CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2) 05190*78 C INPUT ARGUMENT LIST: 05191*99 C IUNITD - UNIT NUMBER FOR TABLE D INPUT 05192*99 C IPTR - ARRAY OF WORKING VALUES 05193*99 C 05194*99 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 05195*99 C ITBLD - ARRAY TO CONTAIN TABLE D 05196*99 C 05197*99 C REMARKS: 05198*99 C 05199*99 C ATTRIBUTES: 05200*99 C LANGUAGE: FORTRAN 77 05201*99 C MACHINE: NAS 05202*99 C 05203*99 C$$$ 05204*99 C .................................................. 05205*41 C 05206*41 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE 05207*41 C 05208*41 INTEGER ITBLD2(14,*) 05209*77 C .................................................. 05210*42 C 05211*42 C NEW BASE TABLE D 05212*42 C 05213*42 INTEGER ITBLD(14,*) 05214*77 C .................................................. 05215*42 C 05216*99 INTEGER IHOLD(33),IPTR(*) 05217*42 LOGICAL MORE 05218192 C 05219192 MORE = .TRUE. 05220200 I = 0 05221202 C 05222*99 C READ IN TABLE D, BUT JUST ONCE 05223*99 C PRINT *,'TABLE D SWITCH=',IPTR(20),' ANCILLARY D SW=',IPTR(42) 05224*78 IF (IPTR(20).EQ.0) THEN 05225219 IERR = 0 05226*99 C PRINT *,'FI8820 - READING TABLE D' 05227*78 KEY = 0 05228192 100 CONTINUE 05229192 C READ NEXT TABLE D ENTRY 05230201 READ(IUNITD,15,ERR=9998,END=9000)(IHOLD(M),M=1,33) 05231203 15 FORMAT(11(I1,I2,I3,1X),3X) 05232203 C BUILD KEY FROM MASTER D ENTRY 05233192 C INSERT NEW MASTER INTO TABLE B 05234202 I = I + 1 05235205 IPTR(20) = IPTR(20) + 1 05236*49 DO 25 JJ = 1, 41, 3 05237*77 KK = (JJ/3) + 1 05238*56 IF (JJ.LE.31) THEN 05239*77 ITBLD(KK,I) = IHOLD(JJ)*16384 + 05240*56 * IHOLD(JJ+1)*256 + IHOLD(JJ+2) 05241202 C IF (ITBLD(KK,I).EQ.0) THEN 05242*56 C GO TO 50 05243*56 C END IF 05244*56 ELSE 05245*56 ITBLD(KK,I) = 0 05246*56 END IF 05247*56 25 CONTINUE 05248202 50 CONTINUE 05249202 C WRITE (6,51)I,(ITBLD(L,I),L=1,13) 05250*56 51 FORMAT (7H TABLED,14(1X,I5)) 05251*59 GO TO 100 05252202 ELSE 05253192 C PRINT *,'TABLE D IS IN PLACE' 05254192 END IF 05255192 GO TO 9999 05256204 9000 CONTINUE 05257204 CLOSE(UNIT=IUNITD,STATUS='KEEP') 05258192 GO TO 9999 05259*99 9998 CONTINUE 05260*99 IPTR(1) = 8 05261*99 C 05262*99 9999 CONTINUE 05263*99 C PRINT *,'THERE ARE',IPTR(20),' ENTRIES IN TABLE D' 05264*49 RETURN 05265*99 END 05266*99