C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C C MAIN PROGRAM: BUFR_REMOREST C PRGMMR: Keyser ORG: EMC DATE: 2017-10-20 C C ABSTRACT: THIS PROGRAM READS THROUGH AN INPUT BUFR FILE (NORMALLY C EITHER A PREPBUFR OR A DATA DUMP FILE) WHICH CAN CONTAIN A MIXTURE C OF REPORTS WHICH ARE UNRESTRICTED OR RESTRICTED FOR AT LEAST C SOME PERIOD OF TIME (W.R.T. REDISTRIBUTION OUTSIDE OF NCEP) AND C EITHER WRITES OUT (TO AN OTHERWISE IDENTICAL BUFR FILE) ONLY THOSE C REPORTS WHICH ARE NON-RESTRICTED OR WRITES OUT ALL REPORTS BUT WITH C MASKED REPORT ID's FOR THOSE REPORTS WHICH ARE RESTRICTED (WHAT IT C DOES IS BASED ON NAMELIST SWITCHES). {NOTE: WHEN A RESTRICTED C REPORT IS WRITTEN OUT WITH A MASKED REPORT ID, ITS RESTRICTION FLAG C (MNEMONIC "RSRD") AND ITS NUMBER OF HOURS UNTIL THE RESTRICTION C EXPIRES (MNEMONIC "EXPRSRD") ARE RE-SET TO MISSING SO THAT THE C REPORT IS NO LONGER CONSIDERED TO BE RESTRICTED.} IT DETERMINES C WHICH REPORTS ARE RESTRICTED BASED ON EITHER THE MESSAGE TYPE AND C SUBTYPE (MAKING UP THE TABLE A ENTRY IN DATA DUMP FILES), THE C PREPBUFR TABLE A ENTRY (PREPBUFR FILES) (IN EITHER CASE WHEN THE C MESSAGE IS KNOWN TO CONTAIN EITHER ALL RESTRICTED OR ALL NON- C RESTRICTED REPORTS), THE DUMP REPORT TYPE (WHEN REPORTS IN A C PARTICULAR PREPBUFR TABLE A ENTRY ARE MASKED) OR THE REPORT'S C VALUE FOR "RSRD") AND, IF "RSRD" IS SET, ITS VALUE FOR "EXPRSRD" C WITHIN EACH REPORT IN A MESSAGE (WHEN THE MESSAGE MAY CONTAIN A C MIXTURE OF RESTRICTED AND NON-RESTRICTED REPORTS). (NOTE: THE CASE C OF MASKING REPORT ID's IN DATA DUMP FILES CAN ONLY BE DONE C CURRENTLY FOR TABLE A ENTRIES WHERE ALL REPORTS ARE CONSIDERED TO C BE RESTRICTED. C C PROGRAM HISTORY LOG: C 2003-07-14 D. A. KEYSER -- ORIGINAL AUTHOR C 2007-11-21 D. A. KEYSER -- ADDED OPTION TO MASK THE REPORT ID FOR C SPECIFIC TABLE A ENTRIES (AND POSSIBLY FOR SPECIFIC DUMP REPORT C TYPES WITHIN TABLE A ENTRIES WHEN PROCESSING A PREPBUFR FILE), C WHICH RETAINS RESTRICTED REPORTS OF THIS TYPE (RATHER THAN C TOSSING RESTRICTED REPORTS AS IN THE OTHER, PREVIOUS OPTIONS) BUT C CHANGES THEIR TRUE REPORT ID TO "MASKSTID" WHERE THE ID IS STORED C BY ITSELF (I.E., IN PREPBUFR FILES, MNEMONIC "SID"; IN DUMP C FILES, MNEMONIC "RPID" FOR ALL TYPES PLUS FOR SHIPS IN TABLE A C ENTRY "NC001001" MNEMONIC "SHPC8") AND REPLACES THE REPORT ID C WITH ALL "X"'s WHERE THE ID IS EMBEDDED IN THE REPLICATED RAW C BULLETIN HEADER STRING; USES NEW NAMELIST SWITCHES "MSG_MASKA" C TO IDENTIFY THOSE TABLE A ENTRIES FOR WHICH SOME OR ALL REPORTS C ARE CONSIDERED TO BE RESTRICTED AND MUST HAVE THEIR REPORT ID C MASKED AND, IN PREPBUFR FILES ONLY, "IMASK_T29" TO IDENTIFY THOSE C SPECIFIC DUMP REPORT TYPES WITHIN "MSG_MASKA" WHICH ARE C RESTRICTED AND MUST HAVE THEIR REPORT ID MASKED C 2008-09-12 D. A. KEYSER -- INCREASED THE NUMBER OF MESSAGE TYPE C ENTRIES IN NAMELIST SWITCHES "MSG_RESTR", "MSG_MIXED" AND C "MSG_MASKA" FROM 10 TO 20 AND SET UP THEIR DEFAULT VALUES C (8 BLANK CHARACTERS) SO THAT ALL 20 VALUES DO NOT HAVE TO BE C SPECIFIED IN THE NAMELIST PASSED IN FROM THE EXECUTING SCRIPT C 2013-03-15 JWhiting -- ported to WCOSS (no logic changes) C 2017-01-06 DStokes -- Added call of bufrlib routine SETBMISS to set C the missing value used for bufr reads and writes to 10E8_8. C Function GETBMISS is then used to define variable BMISS rather C than using a hardwired value of 10E10. This change was made C to reduce the risk of integer overflows on WCOSS. C 2017-10-20 D. A. KEYSER C - Added minutes to print statement everytime a new BUFR message C is read. In the case of a PREPBUFR file this is the central C (analysis) time (which is the same) for every message. In the C case of a DUMP file, this is the central dump time for the C first (dummy) message read in, the dump file creation time for C the second (dummy) message read in, and the message YYYYMMDDHH C (with minutes always zero) for all data messages read in. The C minutes are obtained from Section 1 of the message read in via C call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time and PREPBUFR (analysis) C time minutes was always zero. However, with the C implementation of the new RTMA_RU, these times can C now also have minutes = 15, 30 or 45 (since the C RTMA_RU runs 4 times per hour). This change allows C this print statement to reflect this new message time C format. C - Fixed a bug in cases where individual subsets in an input C message must be read in and checked/updated before being C written back out if not rejected altogether (see * below for C cases). Here code was opening output message via OPENMG which C does not take into account input message's Section 1 minutes C value (it thus opens a message with default of zero minutes C in Section 1 date). Updated to call BUFRLIB routine MINIMG in C such cases to encode non-zero minutes value (previously read C in via BUFRLIB routine IUPVS01, see first change above) into C Section 1 date when OPENMB actually does open a new message. C * - either the input message contains a mixture of restricted C and non-restricted reports or contains restricted reports C which can be made non-restricted by masking their id C BENEFIT: Applies only to PREPBUFR files for RTMA_RU runs at C 15, 30 or 45 minutes past the hour: ensures that all C messages in output file have the same (correct) C center date out to minutes in Section 1 {rather than C messages created via OPENMB (e.g., ADPSFC, SFCSHP in C RTMA_RU runs) having Section 1 minutes of zero}. C 2020-12-16 S. Melchior -- added call to bufrlib routine maxout for C gpsro data. The default max message size of 10000 bytes is C not sufficient for GPS-RO data. C BENEFIT: Commercial GPS-RO data will be stripped from gpsro C BUFR dump files for safe external user C dissemination. C 2021-01-26 S. MELCHIOR C - Included subset NC001101 in logic section that replaces station C ID w/ MASKSTID. C BENEFIT: BUFR format restricted ships data can be properly C dispensed to public users. C XXXX-XX-XX D. A. KEYSER -- All reports in message types in namelist C "MSG_MIXED" are now also tested for their value for EXPRSRD C (number of hours until the restriction expires) when their C restriction flag (RSRD) is set - any reports with a non-missing C EXPRSRD less than the difference in hours between the current C UTC wall-clock date and the BUFR file center time ("DIFF_HR") C minus 4 are now not considered restricted and are copied (prior C to this, the value of EXPRSRD was ignored and all reports with C RSRD set were restricted and skipped), "DIFF_HR" is a new C imported script environment variable; Improved information that C is printed out for each report that is either skipped or retained C (latter is currently commented out); Improved information printed C out at end summarizing counts of reports retained, skipped or C masked C XXXX-XX-XX D. A. KEYSER -- C - For PREPBUFR files only, all reports in message types in C namelist "MSG_MASK" (if their dump report type is listed in C namelist "IMASK_T29") are now tested for their values for both C RSRD and EXPRSRD and are only considered to be restricted if C RSRD is set and EXPRSRD is .GE. the difference in hours between C the current UTC wall-clock date and the BUFR file center time C (read in via imported script environment variable "DIFF_HR") C minus 4. (Prior to this RSRD and EXPRSRD were not examined, ALL C reports from the message type having the listed dump report type C were considered to be restricted. This is still the case for C message types in namelist "MSG_MASK" for DUMP files.) C - When a report coming out of "MSG_MASK" is deemed to be C restricted (either PREPBUFR or DUMP) and its id is masked to be C "MASKSTID", the report's value for RSRD is now re-set to MISSING C when copied to non-restricted file (EXPRSRD is also set to C MISSING, but it likely was already MISSING). C - Improved documentation and printout. C C USAGE: C INPUT FILES: C UNIT 05 - DATA CARDS CONTAINING NAMELIST SWITCHES (SEE REMARKS) C UNIT 11 - INPUT BUFR FILENAME (IN CHARACTER) (USED ONLY FOR C DIAGNOSTIC PRINT INFO) C UNIT 21 - BUFR FILE (PREPBUFR OR DUMP) CONTAINING A MIXTURE OF C RESTRICTED (AT LEAST FOR SOME PERIOD FO TIME) AND C NON-RESTRICTED REPORTS C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C UNIT 51 - BUFR FILE (PREPBUFR OR DUMP) CONTAINING EITHER ONLY C NON-RESTRICTED REPORTS OR NON-RESTRICTED REPORTS AND C PREVIOUSLY RESTRICTED REPORTS WHOSE REPORT ID's HAVE C BEEN MASKED {I.E., ALL OCCURRENCES OF ID IN A REPORT C ARE UNILATERALLY CHANGED TO EITHER "MASKSTID" (WHERE C THE ID IS STORED BY ITSELF) OR TO ALL "X"'s WHERE THE C NUMBER OF "X"'s CORRESPONDS TO THE THE NUMBER OF C CHARACTERS IN THE ORIGINAL REPORT ID (WHERE THE ID IS C EMBEDDED IN THE REPLICATED RAW REPORT BULLETIN HEADER C STRING), THE LATTER APPLY ONLY TO DUMP FILES} C C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES) C C UNIQUE: - NONE C SYSTEM: - GET_ENVIRONMENT_VARIABLE C LIBRARY: C W3LIB - W3TAGB W3TAGE ERREXIT C BUFR - DATELEN OPENBF IREADMG UFBCNT NMSUB C SETBMISS GETBMISS iupvs01 minimg maxout C C EXIT STATES: C COND = 0 - SUCCESSFUL RUN C > 0 - PROBLEM C C REMARKS: C CONTENTS OF INPUT NAMELIST "SWITCHES": C MSG_RESTR - 20-WORD CHARACTER*8 ARRAY CONTAINING UP TO 20 BUFR C MESSAGE TABLE A ENTRIES FOR WHICH ALL REPORTS ARE C CONSIDERED TO BE RESTRICTED AND WILL ALWAYS BE C REMOVED (These messages are skipped over without C unpacking any reports) C MSG_MIXED - 20-WORD CHARACTER*8 ARRAY CONTAINING UP TO 20 BUFR C MESSAGE TABLE A ENTRIES WHICH MAY CONTAIN A MIXTURE C OF REPORTS WITH AND WITHOUT THEIR RESTRICTION C INDICATOR (BUFR MNEMONIC "RSRD") BEING SET. IF "RSRD" C IS NOT SET -OR- IT IS SET AND THE TIME IN HOURS FOR C THE EXPIRATION ON RESTRICTION (BUFR MNEMONIC C "EXPRSRD") IS ALSO SET AND HAS A VALUE LESS THAN C "DIFF_HR" (THE DIFFERENCE IN HOURS BETWEEN THE C CURRENT UTC WALL-CLOCK DATE AND THE BUFR FILE CENTER C TIME) MINUS 4, THE REPORT WILL BE RETAINED. C OTHERWISE, IT WILL BE REMOVED. (These messages must C be unpacked and values for "RSRD" and "EXPRSRD" must C be checked for every report. If "EXPRSRD is missing, C it is set to 99999999 hours essentially meaning the C report is restricted for all time if "RSRD" is set.) C MSG_MASKA - FOR PREPBUFR FILES: C 20-WORD CHARACTER*8 ARRAY CONTAINING UP TO 20 BUFR C MESSAGE TABLE A ENTRIES WHICH, IF THEIR DUMP REPORT C TYPE IS ONE OF UP TO 10 POSSIBLE LISTED IN SWITCH C IMASK_T29 (WHERE EACH LINE IN IMASK_T29 APPLIES TO C THE TABLE A ENTRY IN THE SAME LINE NUMBER HERE), MAY C CONTAIN A MIXTURE OF REPORTS WITH AND WITHOUT THEIR C RESTRICTION INDICATOR (BUFR MNEMONIC "RSRD") BEING C SET. IF "RSRD" IS NOT SET FOR A REPORT -OR- IT IS SET C AND THE TIME IN HOURS FOR THE EXPIRATION ON C RESTRICTION (BUFR MNEMONIC "EXPRSRD") IS ALSO SET AND C HAS A VALUE LESS THAN "DIFF_HR" (THE DIFFERENCE IN C HOURS BETWEEN THE CURRENT UTC WALL-CLOCK DATE AND THE C PREPBUFR FILE CENTER TIME) MINUS 4, THE REPORT WILL C BE COPIED WITHOUT ANY CHANGES. OTHERWISE, THE REPORT C WILL NOT BE REMOVED, BUT ALL OCCURRENCES OF ITS ID C WILL BE CHANGED TO "MASKSTID". IN ADDITION, ITS C VALUES FOR "RSRD" AND "EXPRSRD" WILL BE RE-SET TO C MISSING SO THAT THE REPORT WILL NO LONGER BE C CONSIDERED AS RESTRICTED. REPORTS WITH A DUMP REPORT C TYPE NOT LISTED IN SWITCH IMASK_T29 ARE CONSIDERED TO C BE NON-RESTRICTED AND THEIR REPORT IDS ARE NOT C CHANGED (MASKED OUT) WHEN COPIED. (These m essages C must be unpacked and the values for "T29", "RSRD" and C "EXPRSRD" must be checked for every report. If C "EXPRSRD" is missing, it is set to 99999999 hours C essentially meaning the report is restricted for all C time if "RSRD" is set.) C FOR DATA DUMP FILES: C 20-WORD CHARACTER*8 ARRAY CONTAINING UP TO 20 BUFR C MESSAGE TABLE A ENTRIES FOR WHICH ALL REPORTS ARE C CONSIDERED TO BE RESTRICTED. THEY WILL NOT BE C REMOVED, BUT ALL OCCURRENCES OF THEIR REPORT IDS WILL C BE UNILATERALLY CHANGED TO EITHER "MASKSTID" (WHERE C THE ID IS STORED BY ITSELF) OR TO ALL "X"'s WHERE THE C NUMBER OF "X"'s CORRESPONDS TO THE NUMBER OF C CHARACTERS IN THE ORIGINAL REPORT ID (WHERE THE ID IS C EMBEDDED IN THE RAW REPORT BULLETIN HEADER STRING). C IN ADDITION, THEIR VALUES FOR "RSRD" AND "EXPRSRD" C WILL BE RE-SET TO MISSING SO THAT THE REPORTS WILL NO C LONGER BE CONSIDERED AS RESTRICTED. (These messages C must be unpacked and every occurrence of every C report's id must be changed to either "MASKSTID" or C "X"'s and every report's "RSRD" and "EXPRSRD" values C must be changed to missing before the report is C copied. Switch IMASK_T29 is not considered here.) C IMASK_T29 - (10,20) INTEGER ARRAY CONTAINING UP TO 10 POSSIBLE C DUMP REPORT TYPES (1ST DIMENSION) FOR THE UP TO 20 C POSSIBLE PREPBUFR TABLE A ENTRIES LISTED IN SWITCH C MSG_MASKA (2ND DIMENSION) (APPLIES ONLY TO PREPBUFR C FILES) C C Note 1: A particular Table A entry should NEVER appear in more C than one of MSG_RESTR, MSG_MIXED or MSG_MASKA. C Note 2: Any Table A entry not in either MSG_RESTR, MSG_MIXED or C MSG_MASKA is assumed to be a Table A entry for BUFR C messages for which ALL reports are NON-RESTRICTED (these C messages are copied intact, no reports are unpacked). C Note 3: Always fill in these arrays MSG_RESTR, MSG_MIXED and C MSG_MASKA beginning with word 1. If there are less than C 20 words filled in an array, either set the extra words to C " " (8 blank characters) or do not specify them C here (they default to " "). C Note 4: For data dump Table A entries in the form "NCtttsss", C where "ttt" is the BUFR message type and "sss" is the C BUFR message subtype, if the last three characters (the C subtype) is specified as 'xxx', then ALL BUFR messages C of that type are either treated as having all restricted C data all which is to be removed (if in MSG_RESTR), mixed C data some of which is to be removed (if in MSG_MIXED) or C all restricted data all of which is to have its report id C masked (if in MSG_MASKA), regardless of the message C subtype. (For example, if MSG_RESTR(1)='NC255xxx', then C ALL mesonet BUFR messages are considered to have all C restricted data and are all removed regardless of their C subtype.) C Note 5: For PREPBUFR files, a value of "99999" in array IMASK_T29 C means not applicable whereas a value of "000" means C reports in all dump report types in the corresponding C Table A entry in MSG_MASKA should be considered {in this C case IMASK_T29(1,x) should be set to 000 and C IMASK_T29(2:10,x) should be set to 99999 for all reports C in Table A entry MSG_MASKA(x) since they would all be C ignored - this is the default for all Table A entries C MSG_MASKA(1:20) if this is not set (i.e., for data dump C files)} C C LIST OF REPORT ID MNEMONICS IN EACH REPORT WHICH ARE CURRENTLY C MASKED WHEN TABLE A ENTRY IS FOUND IN MSG_MASKA (AND FOR PREPBUFR C FILES DUMP REPORT TYPE MATCHES ONE OF THE TYPES IN IMASK_T29 C AND THE REPORT IS CONSIDERED TO BE RESTRICTED BASED ON ITS VALUES C FOR "RSRD" and "EXPRSRD"): C C PREPBUFR file: "SID" - chgd to "MASKSTID" (all Tbl A entries) C (PREPBUFR file "RSRD" and "EXPRSRD" also set to missing) C DUMP file: "RPID" - chgd to "MASKSTID" (all Tbl A entries) C DUMP file: "SHPC8" - chgd to "MASKSTID" (Tbl A entry NC001001 C and NC001101) C DUMP file: "RRSTG" - chgd to "X" (where the number of "X"'s C corresponds to the the number of C characters in the original report id ) C (all applicable Tbl A entries) C (DUMP file: "RSRD" and "EXPRSRD" also set to missing) C C Note: Currently for dump files, the only Table A entry where all C occurrences of report id in a report are known to be masked C is NC001001 and NC001101. This code may have to be modified C to add this ability to mask all occurrences of report id for C other Table A entries. C C C ONE SCRIPT ENVIRONMENT VARIABLE IS READ IN: C DIFF_HR - The difference in hours between the current UTC C wall-clock date and the BUFR file center time C (should always be a positive number!). This C is used (after subtracting 4 hours***) to C determine if a BUFR subset that is marked as C restricted (via mnemonic "RSRD") is past the C expiration time of the restriction (mnemonic C "EXPRSRD") and should thus not be filtered out. C (Note: used only for BUFR DUMP and PREPBUFR C subsets in message types listed in namelist C switch MSG_MIXED and for PREPBUFR subsets in C applicalbe dump types and message types listed C in namelist switches IMASK_T29 and MSG_MASKA.) C Defaults to ZERO if not found (i.e., not C exported by the executing script). C *** Four hours is subtracted from DIFF_HR prior to C testing against the BUFR file center time in C order to account for some reports having an obx C time as much as 3-4 hours prior to the center C time in either a dump or PEPBUFR file. This C ensures that these reports are not inadvertently C retained if the difference between the current C wall-clock date and the BUFR file center time is C very close to the time period of the restriction. C DIFF_HR minus 4 can never be less than zero. C C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS (iDataPlex and Cray-XC40) C C$$$ PROGRAM BUFR_REMOREST CHARACTER*2040 RAWRPT_STG CHARACTER*80 FILE CHARACTER*8 DIFF_HR,PREPBUFR_MSGTYP(21),PRVSTG_prep,SPRVSTG_prep, $ PRVSTG_dump,SPRVSTG_dump CHARACTER*8 SUBSET,SID,MSG_RESTR(20),MSG_MIXED(20),MSG_MASKA(20), $ RAWRPT(255),SID_orig REAL*8 RID_8(8),RASTR_8(255),LALOH_8(2),ACRN_8,ACID_8,SID_8, $ RPID_8,PRV_prep_8(2),PRV1_dump_8(255), $ PRV2_dump_8(255),BMISS,GETBMISS,rsrd_8(2) INTEGER IMASK_T29(10,20),IRSUB_this_MR(20),IRSUB_this_MM(20), $ IMSUB_this(10,20),IRSUB_this_sub_MR(20,0:255), $ IRSUB_this_sub_MM(20,0:255),IUSUB_this(0:255,0:256) EQUIVALENCE (RID_8(1),SID),(RAWRPT,RASTR_8), $ (PRV_prep_8(1),PRVSTG_prep), $ (PRV_prep_8(2),SPRVSTG_prep), $ (PRV1_dump_8(1),PRVSTG_dump), $ (PRV2_dump_8(1),SPRVSTG_dump) DATA LUBFI/21/,LUBFJ/51/,IREC/0/,IRSUB/0/,IMSUB/0/, $ IRSUB_this_MR/20*0/,IRSUB_this_MM/20*0/,IMSUB_this/200*0/, $ IUSUB/0/,IRSUB_this_sub_MR/5120*0/,IRSUB_this_sub_MM/5120*0/, $ IUSUB_this/65792*0/,ireco_last/0/ DATA PREPBUFR_MSGTYP/'ADPUPA ','AIRCAR ','AIRCFT ','SATWND ', $ 'PROFLR ','VADWND ','SATEMP ','ADPSFC ', $ 'SFCSHP ','SFCBOG ','SPSSMI ','SYNDAT ', $ 'ERS1DA ','GOESND ','QKSWND ','MSONET ', $ 'GPSIPW ','RASSDA ','WDSATR ','ASCATW ', $ 'unknown '/ NAMELIST/SWITCHES/MSG_RESTR,MSG_MIXED,MSG_MASKA,IMASK_T29 CALL W3TAGB('BUFR_REMOREST',2021,0175,0012,'NP22') READ(11,'(Q,A)',END=1) NBYTES,FILE(1:NBYTES) 1 CONTINUE PRINT 100, FILE(1:NBYTES) 100 FORMAT(/15X,'WELCOME TO THE BUFR_REMOREST - THE PROGRAM THAT ', $ 'REMOVES OR MASKS RESTRICTED REPORTS FROM A BUFR FILE'/42X, $ 'LAST REVISION 24 Jun 2021'//30X,'INPUT BUFR FILENAME IS: ',A) IMASK_T29 = 99999 IMASK_T29(1,:) = 000 MSG_RESTR = ' ' MSG_MIXED = ' ' MSG_MASKA = ' ' IDIFF_HR = 0 READ(5,SWITCHES) C Set BUFRLIB missing (BMISS) to 10E8_8 to avoid integer*4 overflows C ------------------------------------------------------------------ CALL SETBMISS(10E8_8) BMISS=GETBMISS() print'(1X)' print'(" BUFRLIB value for missing is: ",G0)', bmiss print'(1X)' C .... store rsrd_8 array as "almost" missing, will later encode back C into output *.nr PRPEBUFR file for reports with id masked, C overwriting original value (won't overwrite if exactly missing) C --------------------------------------------------------------- rsrd_8 = bmiss - 0.01_8 IF(MSG_RESTR(1).NE.' ') THEN PRINT 107 107 FORMAT(//' ALL BUFR MESSAGES READ IN WITH THE FOLLOWING TABLE A ', $ 'ENTRIES ARE SKIPPED (WITHOUT UNPACKING) BECAUSE THEY'/ $ ' CONTAIN ONLY RESTRICTED REPORTS (FOR SOME PERIOD OF TIME) ALL', $ ' OF WHICH ARE TO BE REMOVED:'/) DO I = 1,20 IF(MSG_RESTR(I).EQ.' ') EXIT PRINT *, MSG_RESTR(I) ENDDO END IF IF(MSG_MIXED(1).NE.' ') THEN PRINT 108 108 FORMAT(//' ALL BUFR MESSAGES READ IN WITH THE FOLLOWING TABLE A ', $ 'ENTRIES ARE UNPACKED REPORT BY REPORT BECAUSE THEY CAN'/ $ ' CONTAIN A MIXTURE OF BOTH NON-RESTRICTED AND RESTRICTED ', $ 'REPORTS - ALL RESTRICTED REPORTS WITHIN THE TIME'/' PERIOD OF ', $ 'THE RESTRICTION ARE TO BE REMOVED:'/) DO I = 1,20 IF(MSG_MIXED(I).EQ.' ') EXIT PRINT *, MSG_MIXED(I) ENDDO CALL GET_ENVIRONMENT_VARIABLE('DIFF_HR',DIFF_HR) READ(DIFF_HR,'(I8)',END=88,ERR=88) IDIFF_HR cppppp ccc print * ccc print *, 'DIFF_HR, IDIFF_HR : ',DIFF_HR, IDIFF_HR ccc print * cppppp GO TO 89 88 CONTINUE PRINT 115 115 FORMAT(/'+++++BUFR_REMOREST: WARNING: ERROR OBTAINING IDIFF_HR -', $ ' SET TO ZERO AND CONTINUE'/) IDIFF_HR = 0 89 CONTINUE IDIFF_HR_m4 = IDIFF_HR - 4 IDIFF_HR_m4 = MAX(IDIFF_HR_m4,0) PRINT 118, IDIFF_HR,IDIFF_HR_m4 118 FORMAT(/' ===> The difference between the current wall-clock ', $ 'date and the BUFR file center time is',I8,' hours.'/6X, $ 'Will consider the difference here to be only',I8,' hours when ', $ 'comparing against the time period of the'/6X,'restriction ', $ '(this takes into account that some reports may have obs times ', $ 'as much as 3-4 hours prior to'/6X,'the BUFR file center time, ', $ 'and so ensures that these reports are not inadvertently ', $ 'retained if the'/6X,'difference between the current wall-clock', $ ' date and the BUFR file center time is very close to the'/ $ 6X,'the time period of the restriction).'/) END IF IF(MSG_MASKA(1).NE.' ') THEN if(MSG_MASKA(1)(1:2).eq.'NC') then c .. DUMP file case c -------------- PRINT 1107 1107 FORMAT(//' ALL BUFR MESSAGES READ IN WITH THE FOLLOWING TABLE A ', $ 'ENTRIES CONTAIN REPORTS ALL CONSIDERED TO BE RESTRICTED. THEY '/ $ 'ARE'/' UNPACKED REPORT BY REPORT AND EACH REPORT''S ID (ALL ', $ 'OCCURRENCES IN A REPORT) IS CHANGED TO "MASKSTID" OR "X"''S ', $ '(MASKED)'/' AND IT''S VALUES FOR "RSRD" AND "EXPRSRD" ARE RE-', $ 'SET TO MISSING PRIOR TO THEIR BEING WRITTEN BACK OUT:'/) else c .. PREPBUFR file case c ------------------ print 3108 3108 FORMAT(//' ALL BUFR MESSAGES READ IN WITH THE FOLLOWING TABLE A ', $ 'ENTRIES ARE UNPACKED REPORT BY REPORT BECAUSE THEY CAN'/ $ ' CONTAIN A MIXTURE OF BOTH NON-RESTRICTED AND RESTRICTED ', $ 'REPORTS - THE ID''s FOR ALL RESTRICTED REPORTS WITHIN THE'/ $ ' TIME PERIOD OF THE RESTRICTION ARE ALL CHANGED TO "MASKSTID" ', $ '(MASKED) AND THEIR VALUES FOR "RSRD" AND "EXPRSRD"'/' ARE RE-', $ 'SET TO MISSING PRIOR TO THEIR BEING WRITTEN BACK OUT:'/) end if DO I = 1,20 IF(MSG_MASKA(I).EQ.' ') EXIT PRINT *, MSG_MASKA(I) ENDDO if(MSG_MASKA(1)(1:2).ne.'NC') then c .. PREPBUFR file case c ------------------ CALL GET_ENVIRONMENT_VARIABLE('DIFF_HR',DIFF_HR) READ(DIFF_HR,'(I8)',END=988,ERR=988) IDIFF_HR cppppp ccc print * ccc print *, 'DIFF_HR, IDIFF_HR : ',DIFF_HR, IDIFF_HR ccc print * cppppp GO TO 989 988 CONTINUE PRINT 115 IDIFF_HR = 0 989 CONTINUE IDIFF_HR_m4 = IDIFF_HR - 4 IDIFF_HR_m4 = MAX(IDIFF_HR_m4,0) PRINT 118, IDIFF_HR,IDIFF_HR_m4 end if END IF PRINT 109 109 FORMAT(//' ALL OTHER BUFR MESSAGES READ IN ARE COPIED INTACT ', $ '(WITHOUT UNPACKING) BECAUSE THEY CONTAIN ONLY NON-RESTRICTED ', $ 'REPORTS'//) CALL DATELEN(10) CALL OPENBF(LUBFI,'IN',LUBFI) PRINT 101, LUBFI,LUBFI 101 FORMAT(/5X,'===> BUFR FILE IN UNIT',I3,' SUCCESSFULLY OPENED ', $ 'FOR INPUT; BUFR TABLE IS OBTAINED INTERNALLY FROM UNIT',I3/) CALL OPENBF(LUBFJ,'OUT',LUBFI) PRINT 102, LUBFJ,LUBFI,LUBFJ 102 FORMAT(/5X,'===> BUFR FILE IN UNIT',I3,' SUCCESSFULLY OPENED FOR', $ ' OUTPUT; BUFR TABLE IS OBTAINED FROM UNIT',I3,' AND STORED'/10X, $ 'INTERNALLY INTO UNIT',I3/) C CHECK TO MAKE SURE THE SAME TABLE A ENTRY DOES NOT APPEAR IN MORE C THAN ONE OF THE ARRAYS MSG_RESTR, MSG_MIXED OR MSG_MASKA C ----------------------------------------------------------------- DO I = 1,20 IF(MSG_RESTR(I).EQ.' ') EXIT DO J = 1,20 IF(MSG_MIXED(J).EQ.' ') EXIT IF(MSG_RESTR(I).EQ.MSG_MIXED(J)) THEN PRINT 105, I,MSG_RESTR(I),J 105 FORMAT('#####BUFR_REMOREST: WORD ',I2,' OF NAMELIST VARIABLE ', $ 'MSG_RESTR CONTAINS THE SAME TABLE A ENTRY (=',A,') AS WORD ',I2, $ 'OF NAMELIST VARIABLE MSG_MIXED - STOP 99') CALL W3TAGE('BUFR_REMOREST') CALL ERREXIT(99) END IF IF(MSG_RESTR(I).EQ.MSG_MASKA(J)) THEN PRINT 1105, I,MSG_RESTR(I),J 1105 FORMAT('#####BUFR_REMOREST: WORD ',I2,' OF NAMELIST VARIABLE ', $ 'MSG_RESTR CONTAINS THE SAME TABLE A ENTRY (=',A,') AS WORD ',I2, $ 'OF NAMELIST VARIABLE MSG_MASKA - STOP 99') CALL W3TAGE('BUFR_REMOREST') CALL ERREXIT(99) END IF ENDDO ENDDO DO I = 1,20 IF(MSG_MIXED(I).EQ.' ') EXIT DO J = 1,20 IF(MSG_MASKA(J).EQ.' ') EXIT IF(MSG_MIXED(I).EQ.MSG_MASKA(J)) THEN PRINT 2105, I,MSG_MIXED(I),J 2105 FORMAT('#####BUFR_REMOREST: WORD ',I2,' OF NAMELIST VARIABLE ', $ 'MSG_MIXED CONTAINS THE SAME TABLE A ENTRY (=',A,') AS WORD ',I2, $ 'OF NAMELIST VARIABLE MSG_MASKA - STOP 99') CALL W3TAGE('BUFR_REMOREST') CALL ERREXIT(99) END IF ENDDO ENDDO C READ IN NEXT INPUT BUFR MESSAGE FROM BUFR FILE C ---------------------------------------------- LOOP1: DO WHILE(IREADMG(LUBFI,SUBSET,IDATE).EQ.0) C For GPS-RO, increase max message length if(subset.eq.'NC003010') then call maxout(200000) end if CALL UFBCNT(LUBFI,IREC,ISUB) ISUB = NMSUB(LUBFI) iminu = iupvs01(lubfi,'MINU') PRINT 103, IREC,SUBSET,IDATE,iminu,ISUB 103 FORMAT(/5X,'===> READ IN BUFR DATA MESSAGE NO. ',I5,' - TABLE', $ ' A ENTRY IS ',A8,' DATE IS',I11,':',i2.2,' NO. OF RPTS IN ', $ 'MESSAGE IS',I6) LOOP1n1: DO I = 1,20 IF(MSG_RESTR(I).EQ.MSG_MIXED(I) .AND. $ MSG_MIXED(I).EQ.MSG_MASKA(I)) THEN EXIT LOOP1n1 ! All are " " - no need to test C********************************************************************** ELSE IF(IREC.LE.2.AND.SUBSET(1:2).EQ.'NC'.AND.ISUB.EQ.0) $ THEN PRINT 111 111 FORMAT(' This is a dummy message at the top of a data dump BUFR ', $ 'file containing the center dump time (record 1) or the dump'/ $ ' processing time (record 2); irregardless of any restriction ', $ 'switch on this message, copy it, intact, to output BUFR file') CALL CLOSMG(LUBFJ) CALL COPYMG(LUBFI,LUBFJ) CYCLE LOOP1 C********************************************************************** ELSE IF(SUBSET.EQ.MSG_RESTR(I) .OR. (MSG_RESTR(I)(6:8).EQ. $ 'xxx'.AND.SUBSET(1:5).EQ.MSG_RESTR(I)(1:5))) THEN PRINT 112 112 FORMAT(' #####>>>> ALL reports in this message are RESTRICTED ', $ 'and are REMOVED - do NOT copy this message to output BUFR file') IRSUB_this_MR(I) = IRSUB_this_MR(I) + ISUB IF(SUBSET(1:2).EQ.'NC'.AND.MSG_RESTR(I)(6:8).EQ.'xxx')THEN READ(SUBSET(6:8),'(I3)') ISUBSET_678 IF(ISUBSET_678.GE.0.AND.ISUBSET_678.LE.255) THEN IRSUB_this_sub_MR(I,ISUBSET_678) = $ IRSUB_this_sub_MR(I,ISUBSET_678) + ISUB ELSE PRINT 7115, ISUBSET_678,SUBSET 7115 FORMAT(/'+++++BUFR_REMOREST: WARNING: INVALID BUFR MESSAGE ', $ 'SUBTYPE READ IN: ',I5.3,', SUBSET = ',A,' CANNOT INCREMENT ', $ 'RESTRICTED REPORT'/29X,'SKIPPED COUNTER FOR THIS SUBSET'/) END IF END IF IRSUB = IRSUB + ISUB CYCLE LOOP1 C********************************************************************** ELSE IF(SUBSET.EQ.MSG_MIXED(I) .OR. (MSG_MIXED(I)(6:8).EQ. $ 'xxx'.AND.SUBSET(1:5).EQ.MSG_MIXED(I)(1:5))) THEN PRINT 113 113 FORMAT(' #####>>>> rpts in this msg mixed restr/non-restr- restr', $ 'data w/i exp. time REMOVED- unpk each rpt & test mnems. ', $ '"RSRD" & "EXPRSRD"') C READ A SUBSET (REPORT) IN MESSAGE C --------------------------------- LOOP1n2: DO WHILE(IREADSB(LUBFI).EQ.0) C DECODE THE SUBSET (REPORT) LOOKING FOR RESTRICTED FLAG (MNEMONIC C "RSRD") AND TIME OF EXPIRATION ON RESTRICTION (MNEMONIC "EXPRSRD") C (if "EXPRSRD" is missing set it to 99999999 hours essentially C meaning the report is restricted for all time) C ------------------------------------------------------------------- CALL UFBINT(LUBFI,RID_8,7,1,NLV, $ 'SID RPT YOB XOB TYP RSRD EXPRSRD') IF(RID_8(6).GT.0.AND.IBFMS(RID_8(6)).EQ.0) THEN IF(IBFMS(RID_8(7)).NE.0) RID_8(7) = 99999999. IF(IDIFF_HR_m4.LE.RID_8(7)) THEN IF(IBFMS(RID_8(5)).EQ.0) THEN C Normally for PREPBUFR files C --------------------------- IF(SUBSET.EQ.'MSONET ') THEN CALL UFBINT(LUBFI,PRV_prep_8,2,1,NLV, $ 'PRVSTG SPRVSTG') PRINT 8104, SID,(RID_8(II),II=2,4), $ (NINT(RID_8(II)),II=5,7),PRVSTG_prep, $ SPRVSTG_prep 8104 FORMAT(5X,'- **Skip ',A8,F7.2,'UTC',F7.2,'(N+/S-) LAT',F7.2,' E ', $ 'LON, RTYP=',I3,', RSRD=',I5,' EXPRSRD=',I5,', PRVID=',A8, $ ' SPRVID=',A8) ELSE PRINT 104, SID,(RID_8(II),II=2,4), $ (NINT(RID_8(II)),II=5,7) 104 FORMAT(5X,'- **Skip report ',A8,' at ',F6.2,' UTC, ',F6.2, $ ' (N+/S-) LAT, ',F7.2,' E LON, RTYP= ',I3,', RSRD=',I5, $ ' EXPRSRD=',I5) END IF ELSE C Normally for DATA DUMP files C ---------------------------- CALL UFBINT(LUBFI,RID_8,7,1,NLV, $ 'RPID HOUR MINU CLAT CLON RSRD EXPRSRD') IF(IBFMS(RID_8(4)).NE.0) THEN CALL UFBINT(LUBFI,LALOH_8,2,1,NLV, $ 'CLATH CLONH') RID_8(4:5) = LALOH_8 END IF IF(IBFMS(RID_8(1)).NE.0) THEN IF(SUBSET.EQ.'NC004004' .OR. $ SUBSET.EQ.'NC004006' .OR. $ SUBSET.EQ.'NC004009' .OR. $ SUBSET.EQ.'NC004010' .OR. $ SUBSET.EQ.'NC004011' .OR. $ SUBSET.EQ.'NC004014') THEN CALL UFBINT(LUBFI,ACRN_8,1,1,NLV,'ACRN') RID_8(1) = ACRN_8 ELSE IF(SUBSET.EQ.'NC004008' .OR. $ SUBSET.EQ.'NC004012' .OR. $ SUBSET.EQ.'NC004013') THEN CALL UFBINT(LUBFI,ACID_8,1,1,NLV,'ACID') RID_8(1) = ACID_8 ELSE IF(SUBSET.EQ.'NC007001' .OR. $ SUBSET.EQ.'NC007002') THEN SID = ' ' ELSE SID = 'MISSING ' END IF END IF IF(SUBSET(3:5).EQ.'255') THEN CALL UFBINT(LUBFI,PRV1_dump_8,1,255,NLV, $ 'PRVSTG') IF(NLV.LT.1) PRVSTG_dump = ' ' CALL UFBINT(LUBFI,PRV2_dump_8,1,255,NLV, $ 'SPRVSTG') IF(NLV.LT.1) SPRVSTG_dump = ' ' PRINT 8105, SID,(NINT(RID_8(II)),II=2,3), $ (RID_8(II),II=4,5), NINT(RID_8(6)), $ NINT(RID_8(7)),PRVSTG_dump,SPRVSTG_dump 8105 FORMAT(5X,'- **Skip ',A8,' at ',2(I2.2),' UTC',F7.2,' (N+/S-) ', $ 'LAT',F8.2,' (E+/W-) LON, RSRD=',I5,' EXPRSRD=',I5,', PRVID=',A8, $ ' SPRVID=',A8) ELSE PRINT 110, SID,(NINT(RID_8(II)),II=2,3), $ (RID_8(II),II=4,5), NINT(RID_8(6)), $ NINT(RID_8(7)) 110 FORMAT(5X,'- **Skip report ',A8,' at ',2(I2.2),' UTC, ',F6.2, $ ' (N+/S-) LAT, ',F7.2,'(E+/W-) LON, RSRD=',I5,' EXPRSRD=',I5) END IF END IF IRSUB_this_MM(I) = IRSUB_this_MM(I) + 1 IF(SUBSET(1:2).EQ.'NC'.AND. $ MSG_MIXED(I)(6:8).EQ.'xxx') THEN READ(SUBSET(6:8),'(I3)') ISUBSET_678 IF(ISUBSET_678.GE.0.AND.ISUBSET_678.LE.255) $ THEN IRSUB_this_sub_MM(I,ISUBSET_678) = $ IRSUB_this_sub_MM(I,ISUBSET_678) + 1 ELSE PRINT 7115, ISUBSET_678,SUBSET END IF END IF IRSUB = IRSUB + 1 CYCLE LOOP1n2 END IF END IF cppppp ccc IF(IBFMS(RID_8(5)).EQ.0) THEN ccc IF(SUBSET.EQ.'MSONET ') THEN ccc CALL UFBINT(LUBFI,PRV_prep_8,2,1,NLV, ccc $ 'PRVSTG SPRVSTG') ccc PRINT 9104, SID,(RID_8(II),II=2,4), ccc $ (NINT(RID_8(II)),II=5,7),PRVSTG_prep, ccc $ SPRVSTG_prep 9104 FORMAT(5X,'- Retain ',A8,F7.2,'UTC',F7.2,'(N+/S-) LAT',F7.2,' E ', $ 'LON, RTYP=',I3,', RSRD=',I5,' EXPRSRD=',I5,', PRVID=',A8, $ ' SPRVID=',A8) ccc ELSE ccc PRINT 214, SID,(RID_8(II),II=2,4), ccc $ (NINT(RID_8(II)),II=5,7) 214 FORMAT(5X,'- Retain report ',A8,' at ',F6.2,' UTC, ',F6.2, $ ' (N+/S-) LAT, ',F7.2,' E LON, RTYP= ',I3,', RSRD=',I5, $ ' EXPRSRD=',I5) ccc END IF ccc ELSE ccc CALL UFBINT(LUBFI,RID_8,7,1,NLV, ccc $ 'RPID HOUR MINU CLAT CLON RSRD EXPRSRD') ccc IF(IBFMS(RID_8(4)).NE.0) THEN ccc CALL UFBINT(LUBFI,LALOH_8,2,1,NLV,'CLATH CLONH') ccc RID_8(4:5) = LALOH_8 ccc END IF ccc IF(IBFMS(RID_8(1)).NE.0) THEN ccc IF(SUBSET.EQ.'NC004004' .OR. ccc $ SUBSET.EQ.'NC004006' .OR. ccc $ SUBSET.EQ.'NC004009' .OR. ccc $ SUBSET.EQ.'NC004010' .OR. ccc $ SUBSET.EQ.'NC004011' .OR. ccc $ SUBSET.EQ.'NC004014') THEN ccc CALL UFBINT(LUBFI,ACRN_8,1,1,NLV,'ACRN') ccc RID_8(1) = ACRN_8 ccc ELSE IF(SUBSET.EQ.'NC004008' .OR. ccc $ SUBSET.EQ.'NC004012' .OR. ccc $ SUBSET.EQ.'NC004013') THEN ccc CALL UFBINT(LUBFI,ACID_8,1,1,NLV,'ACID') ccc RID_8(1) = ACID_8 ccc ELSE IF(SUBSET.EQ.'NC007001' .OR. ccc $ SUBSET.EQ.'NC007002') THEN ccc SID = ' ' ccc ELSE ccc SID = 'MISSING ' ccc END IF ccc END IF ccc IF(SUBSET(3:5).EQ.'255') THEN ccc CALL UFBINT(LUBFI,PRV1_dump_8,1,255,NLV, ccc $ 'PRVSTG') ccc IF(NLV.LT.1) PRVSTG_dump = ' ' ccc CALL UFBINT(LUBFI,PRV2_dump_8,1,255,NLV, ccc $ 'SPRVSTG') ccc IF(NLV.LT.1) SPRVSTG_dump = ' ' ccc PRINT 9105, SID,(NINT(RID_8(II)),II=2,3), ccc $ (RID_8(II),II=4,5), NINT(RID_8(6)), ccc $ NINT(RID_8(7)),PRVSTG_dump,SPRVSTG_dump 9105 FORMAT(5X,'- Retain ',A8,' at ',2(I2.2),' UTC',F7.2,' (N+/S-) ', $ 'LAT',F8.2,' (E+/W-) LON, RSRD=',I5,' EXPRSRD=',I5,', PRVID=',A8, $ ' SPRVID=',A8) ccc ELSE ccc PRINT 215, SID,(NINT(RID_8(II)),II=2,3), ccc $ (RID_8(II),II=4,5),NINT(RID_8(6)), ccc $ NINT(RID_8(7)) 215 FORMAT(5X,'- Retain report ',A8,' at ',2(I2.2),' UTC, ',F6.2, $ ' (N+/S-) LAT, ',F7.2,'(E+/W-) LON, RSRD=',I5,' EXPRSRD=',I5) ccc END IF ccc END IF cppppp CALL OPENMB(LUBFJ,SUBSET,IDATE) call ufbcnt(lubfj,ireco,isubo) if(ireco.ne.ireco_last) then C Encode minutes into Sec. 1 of new output message header if non-zero if(iminu.ne.0) call minimg(lubfj,iminu) end if ireco_last = ireco CALL UFBCPY(LUBFI,LUBFJ) CALL WRITSB(LUBFJ) IF(SUBSET(1:2).EQ.'NC') THEN READ(SUBSET(3:5),'(I3)') ISUBSET_345 READ(SUBSET(6:8),'(I3)') ISUBSET_678 ELSE ISUBSET_678 = 256 ISUBSET_345 = -99 DO II = 1,20 IF(SUBSET.EQ.PREPBUFR_MSGTYP(II)) THEN ISUBSET_345 = II EXIT END IF ENDDO IF(ISUBSET_345.EQ.-99) ISUBSET_345 = 21 END IF IF(SUBSET(1:2).EQ.'NC' .AND. $ ((ISUBSET_345.LT.0.OR.ISUBSET_345.GT.255) .OR. $ (ISUBSET_678.LT.0.OR.ISUBSET_678.GT.255))) THEN PRINT 7116, SUBSET 7116 FORMAT(/'+++++BUFR_REMOREST: WARNING: INVALID BUFR MESSAGE ', $ 'TYPE AND/OR SUBTYPE READ IN, SUBSET = ',A,' CANNOT INCREMENT' $ /29X,'NON-RESTRICTED REPORT COPIED COUNTER FOR THIS SUBSET'/) ELSE IUSUB_this(ISUBSET_345,ISUBSET_678) = $ IUSUB_this(ISUBSET_345,ISUBSET_678) + 1 END IF IUSUB = IUSUB + 1 ENDDO LOOP1n2 CYCLE LOOP1 C********************************************************************** ELSE IF(SUBSET.EQ.MSG_MASKA(I) .OR. (MSG_MASKA(I)(6:8).EQ. $ 'xxx'.AND.SUBSET(1:5).EQ.MSG_MASKA(I)(1:5))) THEN IF(IMASK_T29(1,I).EQ.000) THEN if(subset(1:2).eq.'NC') then c .. DUMP file case c -------------- PRINT 1113 1113 FORMAT(' ###>> ALL rpts in msg RESTRICTED - unpk each rpt, MASK ', $ 'all id''s (chg to "MASKSTID" or "X"''s), set to non-restr, ', $ ' copy to output file') else c .. PREPBUFR file case c ------------------ print 1114 end if ELSE c .. PREPBUFR file case c ------------------ PRINT 1114 1114 FORMAT(' ###>> some rpts in msg may be RESTRICTED: if so & w/i ', $ 'expir time, MASK id (chg to "MASKSTID"), set to non-restr, cpy', $ ' to output file') DO J = 1,10 IF(IMASK_T29(J,I).NE.99999) PRINT 1115, $ IMASK_T29(J,I) 1115 FORMAT(' -- rpts in dump type ',I3,' mixed restr./non-restr.- ', $ 'for restr. rpts w/i expir. time, MASK id, set to non-restr & ', $ 'copy to output file') ENDDO END IF C READ A SUBSET (REPORT) IN MESSAGE C --------------------------------- LOOP1n3: DO WHILE(IREADSB(LUBFI).EQ.0) C DECODE THE SUBSET (REPORT) IN ORDER TO OBTAIN THE REPORT ID C ----------------------------------------------------------- CALL OPENMB(LUBFJ,SUBSET,IDATE) call ufbcnt(lubfj,ireco,isubo) if(ireco.ne.ireco_last) then C Encode minutes into Sec. 1 of new output message header if non-zero if(iminu.ne.0) call minimg(lubfj,iminu) end if ireco_last = ireco CALL UFBCPY(LUBFI,LUBFJ) CALL UFBINT(LUBFI,RID_8,8,1,NLV, $ 'SID RPT YOB XOB TYP T29 RSRD EXPRSRD') IF(IBFMS(RID_8(5)).EQ.0) THEN C Come here for PREPBUFR files (report id is in mnemonic "SID") C -- check for a match of dump report type C ------------------------------------------------------------- DO J = 1,10 IF(IMASK_T29(1,I).EQ.000.OR. $ IMASK_T29(J,I).EQ.NINT(RID_8(6))) THEN C .... dump report types match - look for restricted flag (mnemonic C "RSRD") and time of expiration on restriction (mnemonic C "EXPRSRD") (if "EXPRSRD" is missing set it to 99999999 hours C essentially meaning the report is restricted for all time) C ------------------------------------------------------------ if(rid_8(7).gt.0.and.ibfms(rid_8(7)).EQ.0) $ then if(ibfms(rid_8(8)).ne.0) $ rid_8(8) = 99999999. if(IDIFF_HR_m4.le.rid_8(8)) then PRINT 1104, SID,(RID_8(II),II=2,4), $ (NINT(RID_8(II)),II=5,8) 1104 FORMAT(5X,'- Chg ID of rpt ',A8,' at',F6.2,' UTC, ',F6.2, $ ' LAT,',F7.2,' E LON, RTYP=',I3,', DTYP=',I5, $ ', RSRD=',I5,', EXPRSRD=',I5,' TO "MASKSTID"') SID = 'MASKSTID' SID_8 = RID_8(1) IMSUB_this(J,I) = IMSUB_this(J,I) + 1 C .... update report id to masked value - "MASKSTID" C --------------------------------------------- CALL UFBINT(LUBFJ,SID_8,1,1,IRET,'SID') C .... re-set RSRD & EXPRSRD to "almost" missing so rpt is no longer C restricted C -----------------------r------------------------------------- call ufbint(lubfj,rsrd_8,2,1,iret,'RSRD EXPRSRD') EXIT END IF END IF END IF ENDDO ELSE C Come here for DATA DUMP files where all reports are restricted C {report id is in mnemonic "RPID" (and for surface ship reports in C Table A entry 'NC001001' and 'NC001101' also in mnemonic "SHPC8"), C report id may also be embedded in replicated raw bulletin header C string if it is present} C ------------------------------------------------------------------- IUPDATE_RAWRPT = 0 CALL UFBINT(LUBFI,RID_8,7,1,NLV, $ 'RPID HOUR MINU CLAT CLON RSRD EXPRSRD') PRINT 1110, SID,(NINT(RID_8(II)),II=2,3), $ (RID_8(II),II=4,5), NINT(RID_8(6)),NINT(RID_8(7)) 1110 FORMAT(' - Chg all instances of rpt id ',A8,' ',2(I2.2),' UTC, ', $ F6.2,'(N+/S-) LAT ',F7.2,'(E+/W-) LON, RSRD=',I5,', EXPRSRD=',I5, $ ' to MASKSTID or X''s') SID_orig = SID SID = 'MASKSTID' RPID_8 = RID_8(1) IMSUB_this(1,I) = IMSUB_this(1,I) + 1 C .... update report id in output file to masked value - "MASKSTID" C ------------------------------------------------------------ CALL UFBINT(LUBFJ,RPID_8,1,1,IRET,'RPID') C .... re-set RSRD & EXPRSRD to "almost" missing so rpt is no longer C restricted C -----------------------r------------------------------------- call ufbint(lubfj,rsrd_8,2,1,iret,'RSRD EXPRSRD') CALL UFBINT(LUBFJ,RID_8(1),1,1,IRET,'RPID') IF(SUBSET.EQ.'NC001001'.or. $ subset.eq.'NC001101') THEN C .... update 2nd rpt id in ship rpts in output file to masked value C - "MASKSTID" C ------------------------------------------------------------- CALL UFBINT(LUBFJ,RPID_8,1,1,IRET,'SHPC8') END IF C .... see if a replicated raw report bulletin header string is C present C -------------------------------------------------------- CALL UFBINT(LUBFI,RASTR_8,1,255,NLV,'RRSTG') IST = 1 IF(NLV.GT.0) THEN C .... it is, store entire string in character array RAWRPT_STG C -------------------------------------------------------- DO II = 1,NLV IEN = IST+7 RAWRPT_STG(IST:IEN) = RAWRPT(II) IST = IST + 8 ENDDO cppppp ccc print *, 'orig RAWRPT_STG: "',RAWRPT_STG(1:IEN),'", IEN = ',ien cppppp C .... next determine character length of report id (ICHAR_id) C for later check to see if it is embedded one or more C times in raw report bulletin header string C ------------------------------------------------------- DO II = 1,8 IF(SID_orig(II:II).EQ.' ') THEN ICHAR_id = II - 1 EXIT END IF ENDDO cppppp ccc print *, 'original sid had ',ICHAR_id,' characters' cppppp IF(ICHAR_id.GE.1) THEN C .... next parse through entire raw report bulletin header C string looking for one or more occurrences of report id C and "X" out the id C ------------------------------------------------------- DO II = 1,IEN IF(II+ICHAR_id-1.GT.IEN) EXIT IF(RAWRPT_STG(II:II+ICHAR_id-1).EQ. $ SID_orig(1:ICHAR_id)) THEN cppppp ccc print *, 'Found a match to orig sid in RAWRPT_STG',' - in bytes ', ccc $ II,' to ',II+ICHAR_id-1,' - set to "X"' cppppp DO JJ = II,II+ICHAR_id-1 RAWRPT_STG(JJ:JJ) = 'X' ENDDO IUPDATE_RAWRPT = 1 END IF ENDDO C .... reconstruct replicated raw report bulletin header string, C but now with the id "X"'d out C --------------------------------------------------------- IF(IUPDATE_RAWRPT.EQ.1) THEN IST = 1 DO II = 1,NLV IEN = IST+7 RAWRPT(II) = RAWRPT_STG(IST:IEN) IST = IST + 8 ENDDO C .... finally, update replicated raw report bulletin header C string with the id "X"'d out in output file C ----------------------------------------------------- CALL UFBINT(LUBFJ,RASTR_8,1,NLV,IRET, $ 'RRSTG') cppppp ccc print *, 'updt RAWRPT_STG: "',RAWRPT_STG(1:IEN),'", IEN = ',ien cppppp END IF END IF END IF END IF IF(SID.EQ.'MASKSTID') THEN IMSUB = IMSUB + 1 ELSE IF(SUBSET(1:2).EQ.'NC') THEN READ(SUBSET(3:5),'(I3)') ISUBSET_345 READ(SUBSET(6:8),'(I3)') ISUBSET_678 ELSE ISUBSET_678 = 256 ISUBSET_345 = -99 DO II = 1,20 IF(SUBSET.EQ.PREPBUFR_MSGTYP(II)) THEN ISUBSET_345 = II EXIT END IF ENDDO IF(ISUBSET_345.EQ.-99) ISUBSET_345 = 21 END IF IF(SUBSET(1:2).EQ.'NC' .AND. $ ((ISUBSET_345.LT.0.OR.ISUBSET_345.GT.255) .OR. $ (ISUBSET_678.LT.0.OR.ISUBSET_678.GT.255))) THEN PRINT 7116, SUBSET ELSE IUSUB_this(ISUBSET_345,ISUBSET_678) = $ IUSUB_this(ISUBSET_345,ISUBSET_678) + 1 END IF IUSUB = IUSUB + 1 END IF CALL WRITSB(LUBFJ) ENDDO LOOP1n3 CYCLE LOOP1 END IF ENDDO LOOP1n1 C********************************************************************** PRINT 114 114 FORMAT(' ALL reports in this message are NON-RESTRICTED - copy', $ ' this message, intact, to output BUFR file') IF(SUBSET(1:2).EQ.'NC') THEN READ(SUBSET(3:5),'(I3)') ISUBSET_345 READ(SUBSET(6:8),'(I3)') ISUBSET_678 ELSE ISUBSET_678 = 256 ISUBSET_345 = -99 DO II = 1,20 IF(SUBSET.EQ.PREPBUFR_MSGTYP(II)) THEN ISUBSET_345 = II EXIT END IF ENDDO IF(ISUBSET_345.EQ.-99) ISUBSET_345 = 21 END IF IF(SUBSET(1:2).EQ.'NC' .AND. $ ((ISUBSET_345.LT.0.OR.ISUBSET_345.GT.255) .OR. $ (ISUBSET_678.LT.0.OR.ISUBSET_678.GT.255))) THEN PRINT 7116, SUBSET ELSE IUSUB_this(ISUBSET_345,ISUBSET_678) = $ IUSUB_this(ISUBSET_345,ISUBSET_678) + ISUB END IF IUSUB = IUSUB + ISUB CALL CLOSMG(LUBFJ) CALL COPYMG(LUBFI,LUBFJ) C********************************************************************** ENDDO LOOP1 C ALL MESSAGES IN INPUT PREPBUFR/DATA DUMP FILE HAVE BEEN READ AND C PROCESSED C ---------------------------------------------------------------- CALL CLOSBF(LUBFI) CALL CLOSBF(LUBFJ) PRINT 106, IRSUB 106 FORMAT(//'==> A TOTAL OF',I11,' RESTRICTED REPORTS WERE ', $ 'SKIPPED') DO I = 1,20 IF(IRSUB_this_MR(I).GT.0) THEN PRINT 1106, IRSUB_this_MR(I),MSG_RESTR(I) DO J = 0,255 IF(IRSUB_this_sub_MR(I,J).GT.0) THEN PRINT 2106, IRSUB_this_sub_MR(I,J),MSG_RESTR(I)(1:5),J END IF ENDDO END IF ENDDO DO I = 1,20 IF(IRSUB_this_MM(I).GT.0) THEN PRINT 1106, IRSUB_this_MM(I),MSG_MIXED(I) DO J = 0,255 IF(IRSUB_this_sub_MM(I,J).GT.0) THEN PRINT 2106, IRSUB_this_sub_MM(I,J),MSG_MIXED(I)(1:5),J END IF ENDDO END IF ENDDO 1106 FORMAT(16X,'--> ',I11,' reports from message type ',A) 2106 FORMAT(21X,'--> ',I11,' reports from message type ',A,I3.3) PRINT 116, IMSUB 116 FORMAT(//'==> A TOTAL OF',I11,' RESTRICTED REPORTS WERE ', $ 'MASKED AND THEN COPIED') DO I = 1,20 DO J = 1,10 IF(IMSUB_this(J,I).GT.0) THEN IF(IMASK_T29(J,I).GT.0) THEN PRINT 1108,IMSUB_this(J,I),MSG_MASKA(I),IMASK_T29(J,I) ELSE PRINT 1106,IMSUB_this(J,I),MSG_MASKA(I) END IF END IF ENDDO ENDDO 1108 FORMAT(16X,'--> ',I11,' reports from message type ',A, $ ', DUMP report type ',I5) PRINT 117, IUSUB 117 FORMAT(//'==> A TOTAL OF',I11,' NON-RESTRICTED REPORTS WERE ', $ 'COPIED'/) IPRINT_FLAG = 0 DO I = 1,21 IF(IUSUB_this(I,256).GT.0) THEN PRINT 2108, IUSUB_this(I,256),PREPBUFR_MSGTYP(I) IPRINT_FLAG = 1 END IF ENDDO 2108 FORMAT(16X,'--> ',I11,' reports from message type ',A) IF(IPRINT_FLAG.EQ.0) THEN DO I = 0,255 DO J = 0,255 IF(IUSUB_this(I,J).GT.0) THEN PRINT 2107, IUSUB_this(I,J),I,J END IF ENDDO ENDDO END IF 2107 FORMAT(16X,'--> ',I11,' reports from message type NC',I3.3,I3.3) PRINT 3117 3117 FORMAT(//'PROGRAM COMPLETED SUCCESSFULLY'/) CALL W3TAGE('BUFR_REMOREST') STOP END