SUBROUTINE STNDRD(LUNIT,MSGIN,LMSGOT,MSGOT)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: STNDRD
C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18
C
C ABSTRACT: THIS SUBROUTINE READS AN INPUT NCEP BUFR MESSAGE CONTAINED
C WITHIN ARRAY MSGIN AND, USING THE BUFR TABLES INFORMATION ASSOCIATED
C WITH LOGICAL UNIT LUNIT, OUTPUTS A "STANDARDIZED" VERSION OF THIS
C SAME MESSAGE WITHIN ARRAY MSGOT. THIS "STANDARDIZATION" INVOLVES
C REMOVING ALL OCCURRENCES OF NCEP BUFRLIB-SPECIFIC BYTE COUNTERS AND
C BIT PADS IN SECTION 4 AS WELL AS REPLACING THE TOP-LEVEL TABLE A FXY
C NUMBER IN SECTION 3 WITH AN EQUIVALENT SEQUENCE OF LOWER-LEVEL
C TABLE B, TABLE C, TABLE D AND/OR REPLICATION FXY NUMBERS WHICH
C DIRECTLY CONSTITUTE THAT TABLE A FXY NUMBER AND WHICH THEMSELVES ARE
C ALL WMO-STANDARD. THE RESULT IS THAT THE OUTPUT MESSAGE IN MSGOT IS
C NOW ENTIRELY COMPLIANT WITH WMO FM-94 BUFR REGULATIONS (I.E. IT IS
C NOW "STANDARD"). IT IS IMPORTANT TO NOTE THAT THE SEQUENCE EXPANSION
C WITHIN SECTION 3 MAY CAUSE THE FINAL "STANDARDIZED" BUFR MESSAGE TO
C BE LONGER THAN THE ORIGINAL INPUT NCEP BUFR MESSAGE BY AS MANY AS
C (MAXNC*2) BYTES (SEE 'bufrlib.prm' FOR AN EXPLANATION OF MAXNC), SO
C THE USER MUST ALLOW FOR ENOUGH SPACE TO ACCOMODATE SUCH AN EXPANSION
C WITHIN THE MSGOT ARRAY.
C
C PROGRAM HISTORY LOG:
C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR
C THIS SUBROUTINE IS MODELED AFTER SUBROUTINE
C STANDARD; HOWEVER, IT USES SUBROUTINE RESTD
C TO EXPAND SECTION 3 AS MANY LEVELS AS
C NECESSARY IN ORDER TO ATTAIN TRUE WMO
C STANDARDIZATION (WHEREAS STANDARD ONLY
C EXPANDED THE TOP-LEVEL TABLE A FXY NUMBER
C ONE LEVEL DEEP), AND IT ALSO CONTAINS AN
C EXTRA INPUT ARGUMENT LMSGOT WHICH PREVENTS
C OVERFLOW OF THE MSGOT ARRAY
C 2005-11-29 J. ATOR -- USE GETLENS AND IUPBS01; ENSURE THAT BYTE 4
C OF SECTION 4 IS ZEROED OUT IN MSGOT; CHECK
C EDITION NUMBER OF BUFR MESSAGE BEFORE
C PADDING TO AN EVEN BYTE COUNT
C 2009-03-23 J. ATOR -- USE IUPBS3 AND NEMTBAX; DON'T ASSUME THAT
C COMPRESSED MESSAGES ARE ALREADY FULLY
C STANDARDIZED WITHIN SECTION 3
C
C USAGE: CALL STNDRD (LUNIT, MSGIN, LMSGOT, MSGOT)
C INPUT ARGUMENT LIST:
C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C MSGIN - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE IN NCEP
C BUFR
C LMSGOT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT;
C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT
C OVERFLOW THE MSGOT ARRAY
C
C OUTPUT ARGUMENT LIST:
C MSGOT - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE
C NOW IN STANDARDIZED BUFR
C
C REMARKS:
C MSGIN AND MSGOT MUST BE SEPARATE ARRAYS.
C
C THIS ROUTINE CALLS: BORT GETLENS ISTDESC IUPB
C IUPBS01 IUPBS3 MVB NEMTBAX
C NUMTAB PKB PKC RESTD
C STATUS UPB UPC
C THIS ROUTINE IS CALLED BY: MSGWRT
C Also called by application programs.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
INCLUDE 'bufrlib.prm'
DIMENSION ICD(MAXNC)
COMMON /HRDWRD/ NBYTW,NBITW,IORD(8)
DIMENSION MSGIN(*),MSGOT(*)
CHARACTER*128 BORT_STR
CHARACTER*8 SUBSET
CHARACTER*4 SEVN
CHARACTER*1 TAB
LOGICAL FOUND
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C LUNIT MUST POINT TO AN OPEN BUFR FILE
C -------------------------------------
CALL STATUS(LUNIT,LUN,IL,IM)
IF(IL.EQ.0) GOTO 900
C IDENTIFY THE SECTION LENGTHS AND ADDRESSES IN MSGIN
C ---------------------------------------------------
CALL GETLENS(MSGIN,5,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5)
IAD3 = LEN0+LEN1+LEN2
IAD4 = IAD3+LEN3
LENN = LEN0+LEN1+LEN2+LEN3+LEN4+LEN5
LENM = IUPBS01(MSGIN,'LENM')
IF(LENN.NE.LENM) GOTO 901
MBIT = (LENN-4)*8
CALL UPC(SEVN,4,MSGIN,MBIT)
IF(SEVN.NE.'7777') GOTO 902
C COPY SECTIONS 0 THROUGH PART OF SECTION 3 INTO MSGOT
C ----------------------------------------------------
MXBYTO = (LMSGOT*NBYTW) - 8
LBYTO = IAD3+7
IF(LBYTO.GT.MXBYTO) GOTO 905
CALL MVB(MSGIN,1,MSGOT,1,LBYTO)
C REWRITE NEW SECTION 3 IN A "STANDARD" FORM
C ------------------------------------------
C LOCATE THE TOP-LEVEL TABLE A DESCRIPTOR
FOUND = .FALSE.
II = 10
DO WHILE ((.NOT.FOUND).AND.(II.GE.8))
ISUB = IUPB(MSGIN,IAD3+II,16)
CALL NUMTAB(LUN,ISUB,SUBSET,TAB,ITAB)
IF((ITAB.NE.0).AND.(TAB.EQ.'D')) THEN
CALL NEMTBAX(LUN,SUBSET,MTYP,MSBT,INOD)
IF(INOD.NE.0) FOUND = .TRUE.
ENDIF
II = II - 2
ENDDO
IF(.NOT.FOUND) GOTO 903
IF (ISTDESC(ISUB).EQ.0) THEN
C ISUB IS A NON-STANDARD TABLE A DESCRIPTOR AND NEEDS
C TO BE EXPANDED INTO AN EQUIVALENT STANDARD SEQUENCE
CALL RESTD(LUN,ISUB,NCD,ICD)
ELSE
C ISUB IS ALREADY A STANDARD DESCRIPTOR, SO JUST COPY
C IT "AS IS" INTO THE NEW SECTION 3 (I.E. NO EXPANSION
C IS NECESSARY!)
NCD = 1
ICD(NCD) = ISUB
ENDIF
C USE THE EDITION NUMBER TO DETERMINE THE LENGTH OF THE
C NEW SECTION 3
LEN3 = 7+(NCD*2)
IBEN = IUPBS01(MSGIN,'BEN')
IF(IBEN.LT.4) THEN
LEN3 = LEN3+1
ENDIF
LBYTO = LBYTO + LEN3 - 7
IF(LBYTO.GT.MXBYTO) GOTO 905
C STORE THE DESCRIPTORS INTO THE NEW SECTION 3
IBIT = (IAD3+7)*8
DO N=1,NCD
CALL PKB(ICD(N),16,MSGOT,IBIT)
ENDDO
C DEPENDING ON THE EDITION NUMBER, PAD OUT THE NEW SECTION 3 WITH AN
C ADDITIONAL ZEROED-OUT BYTE IN ORDER TO ENSURE AN EVEN BYTE COUNT
IF(IBEN.LT.4) THEN
CALL PKB(0,8,MSGOT,IBIT)
ENDIF
C STORE THE LENGTH OF THE NEW SECTION 3
IBIT = IAD3*8
CALL PKB(LEN3,24,MSGOT,IBIT)
C NOW THE TRICKY PART - NEW SECTION 4
C -----------------------------------
IF(IUPBS3(MSGIN,'ICMP').EQ.1) THEN
C THE DATA IN SECTION 4 IS COMPRESSED AND IS THEREFORE ALREADY
C STANDARDIZED, SO COPY IT "AS IS" INTO THE NEW SECTION 4
IF((LBYTO+LEN4+4).GT.MXBYTO) GOTO 905
CALL MVB(MSGIN,IAD4+1,MSGOT,LBYTO+1,LEN4)
JBIT = (LBYTO+LEN4)*8
ELSE
NAD4 = IAD3+LEN3
IBIT = (IAD4+4)*8
JBIT = (NAD4+4)*8
LBYTO = LBYTO + 4
C COPY THE SUBSETS, MINUS THE BYTE COUNTERS AND BIT PADS, INTO
C THE NEW SECTION 4
NSUB = IUPBS3(MSGIN,'NSUB')
DO 10 I=1,NSUB
CALL UPB(LSUB,16,MSGIN,IBIT)
DO L=1,LSUB-2
CALL UPB(NVAL,8,MSGIN,IBIT)
LBYTO = LBYTO + 1
IF(LBYTO.GT.MXBYTO) GOTO 905
CALL PKB(NVAL,8,MSGOT,JBIT)
ENDDO
DO K=1,8
KBIT = IBIT-K-8
CALL UPB(KVAL,8,MSGIN,KBIT)
IF(KVAL.EQ.K) THEN
JBIT = JBIT-K-8
GOTO 10
ENDIF
ENDDO
GOTO 904
10 ENDDO
C FROM THIS POINT ON, WE WILL NEED (AT MOST) 6 MORE BYTES OF
C SPACE WITHIN MSGOT IN ORDER TO BE ABLE TO STORE THE ENTIRE
C STANDARDIZED MESSAGE (I.E. WE WILL NEED (AT MOST) 2 MORE
C ZEROED-OUT BYTES IN SECTION 4 PLUS THE 4 BYTES '7777' IN
C SECTION 5), SO DO A FINAL MSGOT OVERFLOW CHECK NOW.
IF(LBYTO+6.GT.MXBYTO) GOTO 905
C PAD THE NEW SECTION 4 WITH ZEROES UP TO THE NEXT WHOLE BYTE
C BOUNDARY.
DO WHILE(.NOT.(MOD(JBIT,8).EQ.0))
CALL PKB(0,1,MSGOT,JBIT)
ENDDO
C DEPENDING ON THE EDITION NUMBER, WE MAY NEED TO FURTHER PAD
C THE NEW SECTION 4 WITH AN ADDITIONAL ZEROED-OUT BYTE IN ORDER
C TO ENSURE THAT THE PADDING IS UP TO AN EVEN BYTE BOUNDARY.
IF( (IBEN.LT.4) .AND. (MOD(JBIT/8,2).NE.0) ) THEN
CALL PKB(0,8,MSGOT,JBIT)
ENDIF
IBIT = NAD4*8
LEN4 = JBIT/8 - NAD4
CALL PKB(LEN4,24,MSGOT,IBIT)
CALL PKB(0,8,MSGOT,IBIT)
ENDIF
C FINISH THE NEW MESSAGE WITH AN UPDATED SECTION 0 BYTE COUNT
C -----------------------------------------------------------
IBIT = 32
LENN = LEN0+LEN1+LEN2+LEN3+LEN4+LEN5
CALL PKB(LENN,24,MSGOT,IBIT)
CALL PKC('7777',4,MSGOT,JBIT)
C EXITS
C -----
RETURN
900 CALL BORT('BUFRLIB: STNDRD - BUFR FILE IS CLOSED, IT MUST BE'//
. ' OPEN')
901 WRITE(BORT_STR,'("BUFRLIB: STNDRD - INPUT MESSAGE LENGTH FROM'//
. ' SECTION 0",I6," DOES NOT EQUAL SUM OF ALL INDIVIDUAL SECTION'//
. ' LENGTHS (",I6,")")') LENM,LENN
CALL BORT(BORT_STR)
902 WRITE(BORT_STR,'("BUFRLIB: STNDRD - INPUT MESSAGE DOES NOT '//
. 'END WITH ""7777"" (ENDS WITH ",A)') SEVN
CALL BORT(BORT_STR)
903 CALL BORT('BUFRLIB: STNDRD - TABLE A SUBSET DESCRIPTOR '//
. 'NOT FOUND')
904 CALL BORT('BUFRLIB: STNDRD - BIT MISMATCH COPYING SECTION 4 '//
. 'FROM INPUT TO OUTPUT (STANDARD) MESSAGE')
905 CALL BORT('BUFRLIB: STNDRD - OVERFLOW OF OUTPUT (STANDARD) '//
. 'MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY')
END