C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: BUFR1B C PRGMMR: KEYSER ORG: NP22 DATE: 2007-02-09 C C ABSTRACT: GENERATES BUFR REPORT FROM TOVS/ATOVS 1B DATA AND ENCODES C IT INTO OUTPUT BUFR FILE. C C PROGRAM HISTORY LOG: C 2000-09-06 WOOLLEN -- ORIGINAL CODE C 2002-02-11 WOOLLEN -- MODIFICATIONS AND CORRECTIONS TO OUTPUT BUFR C DATASET: "SAID" (0-01-007) CORRECTED TO PROPER WMO CODE TABLE C VALUE (WAS 14 FOR NOAA-14, ETC.), "SIID" (0-02-019) REPLACED C "SIDU" (0-02-021) WHICH DIDN'T SEEM TO BE CORRECT, "HMSL" C (0-07-002) CORRECTED TO PROPER UNITS OF METERS (WAS BEING C STORED IN KM), "LSQL" (0-08-012) CORRECTED TO PROPER WMO CODE C TABLE VALUE (0-LAND/1-SEA) (WAS BACKWARDS), "TMBR" (0-12-163) C CORRECTED TO PROPER UNITS OF K (WAS BEING STORED AS C K + 273.15), CHANNEL 20 "TMBR" SET TO MISSING FOR HIRS-2 AND C HIRS-3 TYPES C 2004-01-23 KEYSER -- BASED ON NEW NAMELIST SWITCH "COMPRESS", NOW C HAS OPTION TO WRITE COMPRESSED BUFR MESSAGES USING WRITCP C INSTEAD OF WRITSB (REMOVES THE NEED FOR THE DOWNSTREAM PROGRAM C BUFR_COMPRESS) C 2005-04-29 KEYSER -- MODIFIED TO HANDLE PROCESSING OF AMSU-A C ANTENNA TEMPERATURE (Ta) REPORTS INTO MESSAGE TYPE NC021123 C 2005-06-21 KEYSER -- MODIFIED TO HANDLE PROCESSING OF MHS AND C HIRS-4 BRIGHTNESS TEMPERATURE (Tb) REPORTS INTO MESSAGE TYPES C NC021027 AND NC021028, RESPECTIVELY C 2006-07-20 KEYSER -- MODIFIED TO ENCODE THE FOLLOWING NEW C INFORMATION INTO OUTPUT BUFR FILE FOR AMSU-A, AMSU-B, MHS, C HIRS-3 AND HIRS-4 REPORTS: ESTIMATED SOLAR AZIMUTH (MNEMONIC C SOLAZI) AND ESTIMATED SATELLITE AZIMUTH (MNEMONIC BEARAZ) FOR C EACH SUBSET (RETRIEVAL); MODIFIED TO ENCODE COLD SPACE C TEMPERATURE CORRECTION (MNEMONIC CSTC) FOR EACH CHANNEL IN C SUBSET FOR AMSU-A, AMSU-B AND MHS REPORTS; INPUT ARGUMENT ARRAY C "RDATA" NOW CONTAINS HOUR-OF-DAY, MINUTE-OF-HOUR AND SECOND-OF- C MINUTE RATHER THAN ONLY SECOND-OF-DAY (SINCE THE HOUR, MINUTE C AND SECOND ARE ACTUALLY ENCODED INTO BUFR, SECOND NOW ROUNDED TO C NEAREST WHOLE SECOND RATHER THAN TRUNCATED) C 2007-02-09 KEYSER -- MODIFIED, IN RESPONSE TO MAIN PROGRAM CHANGE, C TO EXPECT BUFR CODE TABLE VALUE 0-01-007 IN WORD 1 OF INPUT C ARRAY "RDATA", THE BUFR VALUE FOR SATELLITE ID, RATHER THAN THE C ACTUAL SATELLITE NUMBER AS BEFORE - SINCE THIS IS THEN ENCODED C DIRECTLY INTO BUFR THE CODE IS SIMPLIFIED C C USAGE: CALL BUFR1B(LUBFR,SUBSET,NREAL,NCHAN,RDATA,NREP) C C INPUT ARGUMENTS: C LUBFR - LOGICAL UNIT FOR BUFR FILE C SUBSET - BUFR MESSAGE TYPE FOR TOVS/ATOVS INSTRUMENT/TEMPERATURE C TYPE COMBINATION C NREAL - NUMBER OF TOVS/ATOVS HEADER ELEMENTS C NCHAN - NUMBER OF TOVS/ATOVS CHANNELS C RDATA - REAL ARRAY WITH TOVS/ATOVS HEADER AND CHANNEL DATA C NREP - NUMBER OF BUFR REPORTS WRITTEN PRIOR TO THIS CALL TO C BUFR1B C C OUTPUT ARGUMENTS: C NREP - NUMBER OF BUFR REPORTS WRITTEN AFTER TO THIS CALL TO C BUFR1B C C SUBPROGRAMS CALLED: C C LIBRARY: C BUFRLIB - OPENMB WRITSB WRITCP UFBSEQ C C REMARKS: C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE BUFR1B(LUBFR,SUBSET,NREAL,NCHAN,RDATA,NREP) PARAMETER(NDAT=100) CHARACTER*8 SUBSET,COMPRESS,PROCESS_Tb,PROCESS_Ta REAL*4 RDATA(*) REAL*8 BUFRF(NDAT) LOGICAL HIRS COMMON/SWITCHES/COMPRESS,PROCESS_Tb,PROCESS_Ta DATA BMISS /10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C ISOLATE THE DATE/TIME OF THIS REPORT C ------------------------------------ IYR = RDATA(3) IMO = RDATA(4) IDY = RDATA(5) IHR = RDATA(6) C DETERMINE THE BUFR SATELLITE INSTRUMENT (CODE TABLE 0-02-019) BASED C ON THE BUFR MESSAGE SUBTYPE C ------------------------------------------------------------------ HIRS = (SUBSET.EQ.'NC021021' .OR. SUBSET.EQ.'NC021025' .OR. . SUBSET.EQ.'NC021028') IF(SUBSET(7:8).EQ.'21') THEN JCODE = 605 ! hirs-2 (NC021021) (Tb) ELSE IF(SUBSET(7:8).EQ.'22') THEN JCODE = 623 ! msu (NC021022) (Tb) ELSE IF(SUBSET(7:8).EQ.'23') THEN JCODE = 570 ! amsu-a (NC021023) (Tb) or (NC021123) (Ta) ELSE IF(SUBSET(7:8).EQ.'24') THEN JCODE = 574 ! amsu-b (NC021024) (Tb) ELSE IF(SUBSET(7:8).EQ.'25') THEN JCODE = 606 ! hirs-3 (NC021025) (Tb) ELSE IF(SUBSET(7:8).EQ.'27') THEN JCODE = 203 ! mhs (NC021027) (Tb) ELSE IF(SUBSET(7:8).EQ.'28') THEN JCODE = 607 ! hirs-4 (NC021028) (Tb) ELSE WRITE(6,*) '** UNKNOWN SATELLITE INSTRUMENT', . (RDATA(III),III=1,NREAL) CALL W3TAGE('BUFR_TRANHIRS2') CALL ERREXIT(7) ENDIF C FLIP THE SENSE OF THE LAND/SEA FLAG C ----------------------------------- IF(NINT(RDATA(9)).EQ.0) THEN LANDSEA = 1 ELSE IF(NINT(RDATA(9)).EQ.1) THEN LANDSEA = 0 ENDIF C TRANSLATE THE 1B RECORD TO BUFR FORMAT C C AMSU-A, AMSU-B, MHS: C -------------------------------------------------------------- C NC021sss | YEAR MNTH DAYS HOUR MINU SECO C NC021sss | CLAT CLON SAID SIID FOVN LSQL C NC021sss | SAZA SOZA HOLS HMSL SOLAZI BEARAZ C NC021sss | "BRITCSTC"xx C BRITCSTC | CHNM TMBR CSTC C -------------------------------------------------------------- C where xx=15 for AMSU-A, =5 for AMSU-B/MHS C C HIRS-3, HIRS-4: C -------------------------------------------------------------- C NC021sss | YEAR MNTH DAYS HOUR MINU SECO C NC021sss | CLAT CLON SAID SIID FOVN LSQL C NC021sss | SAZA SOZA HOLS HMSL SOLAZI BEARAZ C NC021sss | "BRIT"20 C BRITCSTC | CHNM TMBR C -------------------------------------------------------------- C C HIRS-2, MSU: C -------------------------------------------------------------- C NC021sss | YEAR MNTH DAYS HOUR MINU SECO C NC021sss | CLAT CLON SAID SIID FOVN LSQL C NC021sss | SAZA SOZA HOLS HMSL C NC021sss | "BRIT"xx C BRIT | CHNM TMBR C -------------------------------------------------------------- C where xx=20 for HIRS-2, =4 for MSU NPERCHAN = 2 MREAL = 17 BUFRF( 1) = IYR BUFRF( 2) = IMO BUFRF( 3) = IDY BUFRF( 4) = IHR BUFRF( 5) = RDATA(7) BUFRF( 6) = RDATA(8) BUFRF( 7) = RDATA(11) BUFRF( 8) = RDATA(12) BUFRF( 9) = RDATA(1) BUFRF(10) = JCODE BUFRF(11) = RDATA(10) BUFRF(12) = LANDSEA BUFRF(13) = RDATA(13) BUFRF(14) = RDATA(14) BUFRF(15) = RDATA(15) BUFRF(16) = RDATA(16)*1000. IF(SUBSET(7:8).GE.'23') THEN BUFRF(17) = RDATA(17) BUFRF(18) = RDATA(18) IF(.NOT.HIRS) NPERCHAN = 3 MREAL = 19 ENDIF DO N=1,NCHAN M = (N-1)*NPERCHAN IF(SUBSET(7:8).EQ.'23' .OR. SUBSET(7:8).EQ.'24' .OR. . SUBSET(7:8).EQ.'27') THEN BUFRF(MREAL+M) = (N) BUFRF(MREAL+1+M) = RDATA(NREAL-1+N*2) BUFRF(MREAL+2+M) = RDATA(NREAL-0+N*2) ELSE BUFRF(MREAL+M) = (N) BUFRF(MREAL+1+M) = RDATA(NREAL+N) C HIRS-2, HIRS-3 AND HIRS-4 chn 20 temperature is always missing C -------------------------------------------------------------- IF(N.EQ.20 .AND. HIRS) BUFRF(MREAL+1+M) = BMISS ENDIF ENDDO C WRITE THIS ARRAY INTO BUFR C -------------------------- IDATE = IYR*1000000+IMO*10000+IDY*100+IHR CALL OPENMB(LUBFR,SUBSET,IDATE) CALL UFBSEQ(LUBFR,BUFRF,NDAT,1,IRET,SUBSET) NREP = NREP + 1 IF(COMPRESS.EQ.'YES' .OR. COMPRESS.EQ.'yes') THEN CALL WRITCP(LUBFR) ELSE CALL WRITSB(LUBFR) ENDIF C EXIT HERE C --------- RETURN END