SUBROUTINE MSGWRT(LUNIT,MBAY,MBYT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MSGWRT C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE PERFORMS SOME FINAL CHECKS ON AN OUTPUT C BUFR MESSAGE (E.G., CONFIRMING THAT EACH SECTION OF THE MESSAGE HAS C AN EVEN NUMBER OF BYTES WHEN NECESSARY, "STANDARDIZING" THE MESSAGE C IF REQUESTED VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE C STDMSG, ETC.), AND THEN PREPARES THE MESSAGE FOR FINAL OUTPUT TO C LOGICAL UNIT LUNIT (E.G., ADDING THE STRING "7777" TO THE LAST FOUR C BYTES OF THE MESSAGE, APPENDING ZEROED-OUT BYTES UP TO A SUBSEQUENT C MACHINE WORD BOUNDARY, ETC.). IT THEN WRITES OUT THE FINISHED C MESSAGE TO LOGICAL UNIT LUNIT AND ALSO STORES A COPY OF IT WITHIN C COMMON /BUFRMG/ FOR POSSIBLE LATER RETRIEVAL VIA BUFR ARCHIVE C LIBRARY SUBROUTINE WRITSA. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1997-07-29 J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION C WRITTEN IN SECTION 0 FROM 2 TO 3 C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1998-11-24 J. WOOLLEN -- MODIFIED TO ZERO OUT THE PADDING BYTES C WRITTEN AT THE END OF SECTION 4 C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 10,000 TO 20,000 BYTES C 2003-11-04 J. ATOR -- DON'T WRITE TO LUNIT IF OPENED AS A NULL C FILE BY OPENBF {NULL(LUN) = 1 IN NEW C COMMON BLOCK /NULBFR/} (WAS IN DECODER C VERSION); ADDED DOCUMENTATION C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY C DOCUMENTATION; OUTPUTS MORE COMPLETE C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES C ABNORMALLY C 2004-08-18 J. ATOR -- IMPROVED DOCUMENTATION; ADDED LOGIC TO CALL C STNDRD IF REQUESTED VIA COMMON /MSGSTD/; C ADDED LOGIC TO CALL OVRBS1 IF NECESSARY; C MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2005-11-29 J. ATOR -- USE GETLENS, IUPBS01, PADMSG, PKBS1 AND C NMWRD; ADDED LOGIC TO CALL PKBS1 AND/OR C CNVED4 WHEN NECESSARY C C USAGE: CALL MSGWRT (LUNIT, MBAY, MBYT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR C MESSAGE TO OUTPUT TO LUNIT C MBYT - INTEGER: LENGTH OF BUFR MESSAGE IN BYTES C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT CNVED4 GETLENS IUPB C IUPBS01 NMWRD OVRBS1 PADMSG C PKB PKBS1 PKC STATUS C STNDRD C THIS ROUTINE IS CALLED BY: CLOSMG COPYMG CPYMEM CPYUPD C MSGUPD SUBUPD WRCMPS WRITDX C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' PARAMETER (MXCOD=15) COMMON /BUFRMG/ MSGLEN,MSGTXT(MXMSGLD4) COMMON /NULBFR/ NULL(NFILES) COMMON /QUIET / IPRT COMMON /MSGSTD/ CSMF COMMON /SECT01/ NCOD,ILCOD(MXCOD),IVCOD(MXCOD) COMMON /S01CM/ NS01V,CMNEM(MXS01V),IVMNEM(MXS01V) CHARACTER*8 CMNEM CHARACTER*4 BUFR,SEVN CHARACTER*1 CSMF DIMENSION MBAY(*) DIMENSION MSGNEW(MXMSGLD4) DATA BUFR/'BUFR'/ DATA SEVN/'7777'/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C OVERWRITE ANY VALUES WITHIN SECTION 0 OR SECTION 1 THAT WERE C REQUESTED VIA PREVIOUS CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE C PKVS01. IF A REQUEST WAS MADE TO CHANGE THE BUFR EDITION NUMBER C TO 4, THEN ACTUALLY CONVERT THE MESSAGE AS WELL. IF(NS01V.GT.0) THEN DO I=1,NS01V IF( (CMNEM(I).EQ.'BEN') .AND. (IVMNEM(I).EQ.4) ) THEN C INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE CNVED4. IBIT = 32 CALL PKB(MBYT,24,MBAY,IBIT) CALL CNVED4(MBAY,MXMSGLD4,MSGNEW) C COMPUTE MBYT FOR THE NEW EDITION 4 MESSAGE. MBYT = IUPBS01(MSGNEW,'LENM') C COPY THE MSGNEW ARRAY BACK INTO MBAY. DO II = 1, NMWRD(MSGNEW) MBAY(II) = MSGNEW(II) ENDDO ELSE C OVERWRITE THE REQUESTED VALUE. CALL PKBS1(IVMNEM(I),MBAY,CMNEM(I)) ENDIF ENDDO ENDIF C GET THE MESSAGE TYPE. MTYP = IUPBS01(MBAY,'MTYP') C GET THE SECTION LENGTHS. CALL GETLENS(MBAY,4,LEN0,LEN1,LEN2,LEN3,LEN4,L5) C GET THE COMPRESSION INDICATOR. NCMP = IUPB(MBAY,LEN0+LEN1+LEN2+7, 8) C "STANDARDIZE" THE MESSAGE IF REQUESTED VIA COMMON /MSGSTD/. C HOWEVER, WE DO NOT WANT TO DO THIS IF THE MESSAGE CONTAINS BUFR C TABLE (DX) INFORMATION (IN WHICH CASE IT IS ALREADY "STANDARD") C OR IF THE MESSAGE CONTAINS COMPRESSED DATA (IN WHICH CASE A C PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE CMSGINI SHOULD C HAVE ALREADY "STANDARDIZED" IT). IF ( ( CSMF.EQ.'Y' ) .AND. . ( MTYP.NE.11 ) .AND. . ( IAND(NCMP,64).EQ.0 ) ) THEN C INSTALL SECTION 0 BYTE COUNT AND SECTION 5 '7777' INTO THE C ORIGINAL MESSAGE. THIS IS NECESSARY BECAUSE SUBROUTINE STNDRD C REQUIRES A COMPLETE AND WELL-FORMED BUFR MESSAGE AS ITS INPUT. IBIT = 32 CALL PKB(MBYT,24,MBAY,IBIT) IBIT = (MBYT-4)*8 CALL PKC(SEVN,4,MBAY,IBIT) CALL STNDRD(LUNIT,MBAY,MXMSGLD4,MSGNEW) C COMPUTE MBYT FOR THE NEW "STANDARDIZED" MESSAGE. MBYT = IUPBS01(MSGNEW,'LENM') C COPY THE MSGNEW ARRAY BACK INTO MBAY. DO II = 1, NMWRD(MSGNEW) MBAY(II) = MSGNEW(II) ENDDO C GET THE SECTION LENGTHS OF THE NEW "STANDARDIZED" MESSAGE. CALL GETLENS(MBAY,4,LEN0,LEN1,LEN2,LEN3,LEN4,L5) ENDIF C OVERWRITE ANY VALUES WITHIN SECTION 1 (OR BYTE 8 OF SECTION 0) C THAT WERE REQUESTED VIA PREVIOUS CALLS TO BUFR ARCHIVE LIBRARY C SUBROUTINE PKVS1. IF(NCOD.GT.0) THEN DO I=1,NCOD CALL OVRBS1(IVCOD(I),MBAY,ILCOD(I)) ENDDO ENDIF C DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE C THAT EACH SECTION WITHIN THE MESSAGE HAS AN EVEN NUMBER OF BYTES. IF(IUPBS01(MBAY,'BEN').LT.4) THEN IF(MOD(LEN1,2).NE.0) GOTO 901 IF(MOD(LEN2,2).NE.0) GOTO 902 IF(MOD(LEN3,2).NE.0) GOTO 903 IF(MOD(LEN4,2).NE.0) THEN C PAD SECTION 4 WITH AN ADDITIONAL BYTE C THAT IS ZEROED OUT. IAD4 = LEN0+LEN1+LEN2+LEN3 IAD5 = IAD4+LEN4 IBIT = IAD4*8 LEN4 = LEN4+1 CALL PKB(LEN4,24,MBAY,IBIT) IBIT = IAD5*8 CALL PKB(0,8,MBAY,IBIT) MBYT = MBYT+1 ENDIF ENDIF C WRITE SECTION 0 BYTE COUNT AND SECTION 5 C ---------------------------------------- IBIT = 0 CALL PKC(BUFR, 4,MBAY,IBIT) CALL PKB(MBYT,24,MBAY,IBIT) KBIT = (MBYT-4)*8 CALL PKC(SEVN, 4,MBAY,KBIT) C ZERO OUT THE EXTRA BYTES WHICH WILL BE WRITTEN C ---------------------------------------------- C I.E. SINCE THE BUFR MESSAGE IS STORED WITHIN THE INTEGER ARRAY C MBAY(*) (RATHER THAN WITHIN A CHARACTER ARRAY), WE NEED TO MAKE C SURE THAT THE "7777" IS FOLLOWED BY ZEROED-OUT BYTES UP TO THE C BOUNDARY OF THE LAST MACHINE WORD THAT WILL BE WRITTEN OUT. CALL PADMSG(MBAY,MXMSGLD4,NPBYT) C WRITE THE MESSAGE PLUS PADDING TO A WORD BOUNDARY IF NULL(LUN) = 0 C ------------------------------------------------------------------ MWRD = NMWRD(MBAY) CALL STATUS(LUNIT,LUN,IL,IM) IF(NULL(LUN).EQ.0) WRITE(LUNIT) (MBAY(I),I=1,MWRD) IF(IPRT.GE.2) THEN PRINT* PRINT*,'+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++++' PRINT*,'BUFRLIB: MSGWRT - LUNIT=',LUNIT,' BYTES=',MBYT+NPBYT PRINT*,'+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++++' PRINT* ENDIF C SAVE A MEMORY COPY OF THIS MESSAGE - NO BUFR TABLES THOUGH C ---------------------------------------------------------- IF(MTYP.NE.11) THEN C STORE A COPY OF THIS MESSAGE WITHIN COMMON /BUFRMG/, C FOR POSSIBLE LATER RETRIEVAL DURING THE NEXT CALL TO C SUBROUTINE WRITSA. MSGLEN = MWRD DO I=1,MSGLEN MSGTXT(I) = MBAY(I) ENDDO ENDIF C EXITS C ----- RETURN 901 CALL BORT . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 1 IS NOT A MULTIPLE OF 2') 902 CALL BORT . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 2 IS NOT A MULTIPLE OF 2') 903 CALL BORT . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2') END