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