msgwrt.f

Go to the documentation of this file.

C> @file
C> @brief Finalize a BUFR message for output and write the message to
C> a BUFR file.

C> This subroutine performs final checks and updates on a BUFR message
C> before writing it to a specified Fortran logical unit.
C>
C> <p>These final checks and updates include:
C> - Standardizing the BUFR message, if requested via a previous call
C> subroutine stdmsg()
C> - Converting the BUFR message from edition 3 to edition 4, if
C> requested via a previous call to subroutine pkvs01()
C> - Storing any customized values into Section 0 or Section 1 of the
C> BUFR message, if requested via one or more previous calls to
C> subroutine pkvs01()
C> - Storing a tank receipt time into Section 1 of the BUFR message,
C> if requested via a previous call to subroutine strcpt()
C> - For edition 3 BUFR messages, ensuring each section of the message
C> contains an even number of bytes
C> - Storing '7777' into the last four bytes of the BUFR message, and
C> storing the final message length in Section 0
C> - Appending zeroed-out bytes after the end of the BUFR message, up
C> to the next machine word boundary
C> - Encapsulating the BUFR message with IEEE Fortran control words,
C> if requested via a previous call to subroutine setblock()
C> - Storing a copy of the final message into internal arrays for
C> possible later retrival via subroutine writsa()
C>
C> @author J. Woollen
C> @date 1994-01-06
C>
C> @param[in] LUNIT  - integer: Fortran logical unit number for BUFR
C>                     file
C> @param[in] MESG   - integer(*): BUFR message
C> @param[in] MGBYT  - integer: Size (in bytes) of BUFR message
C>
C> <b>Program history log:</b>
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 ABORT
C>                             with call to new internal 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
C>                           from 10,000 to 20,000 bytes
C> - 2003-11-04  J. Ator    -- Don't write to LUNIT if opened by
C>                           openbf() using IO = 'NUL'
C> - 2003-11-04  S. Bender  -- Added remarks and routine 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, unusual things happen or for
C>                             informational purposes
C> - 2005-11-29  J. Ator    -- Use getlens(), iupbs01(), padmsg(), pkbs1()
C>                           and nmwrd(); added logic to call pkbs1()
C>                           and/or cnved4() when necessary
C> - 2009-03-23  J. Ator    -- Use idxmsg() and errwrt(); add call to
C>                           atrcpt(); allow standardizing via
C>                           COMMON /MSGSTD/ even if data is compressed;
C>                           work on local copy of input message
C> - 2012-09-15  J. Woollen -- Modified for C/I/O/BUFR interface;
C>                           call new routine blocks() for file blocking
C>                           and new C routine cwrbufr() to write BUFR
C>                           message to disk file
C> - 2014-12-10  J. Ator    -- Use modules instead of COMMON blocks
C> - 2019-05-09  J. Ator    -- Added dimensions for MSGLEN and MSGTXT
C>
      SUBROUTINE msgwrt(LUNIT,MESG,MGBYT)

      USE moda_nulbfr
      USE moda_bufrmg
      USE moda_mgwa
      USE moda_mgwb
      USE moda_s01cm

      COMMON /quiet / iprt
      COMMON /msgstd/ csmf
      COMMON /tnkrcp/ itryr,itrmo,itrdy,itrhr,itrmi,ctrt

      CHARACTER*128 errstr

      CHARACTER*4 bufr,sevn
      CHARACTER*1 csmf
      CHARACTER*1 ctrt
      dimension   mesg(*)
      dimension   iec0(2)

      DATA bufr/'BUFR'/
      DATA sevn/'7777'/

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

C     MAKE A LOCAL COPY OF THE INPUT MESSAGE FOR USE WITHIN THIS
C     SUBROUTINE, SINCE CALLS TO ANY OR ALL OF THE SUBROUTINES STNDRD,
C     CNVED4, PKBS1, ATRCPT, ETC. MAY END UP MODIFYING THE MESSAGE
C     BEFORE IT FINALLY GETS WRITTEN OUT TO LUNIT.

      mbyt = mgbyt

      iec0(1) = mesg(1)
      iec0(2) = mesg(2)
      ibit = 32
      CALL pkb(mbyt,24,iec0,ibit)

      DO ii = 1, nmwrd(iec0)
        mgwa(ii) = mesg(ii)
      ENDDO

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') THEN
            IF(ivmnem(i).EQ.4) THEN

C             INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE CNVED4.

              ibit = 32
              CALL pkb(mbyt,24,mgwa,ibit)

              CALL cnved4(mgwa,mxmsgld4,mgwb)

C             COMPUTE MBYT FOR THE NEW EDITION 4 MESSAGE.

              mbyt = iupbs01(mgwb,'LENM')

C             COPY THE MGWB ARRAY BACK INTO MGWA.

              DO ii = 1, nmwrd(mgwb)
                mgwa(ii) = mgwb(ii)
              ENDDO
            ENDIF
          ELSE

C           OVERWRITE THE REQUESTED VALUE.

            CALL pkbs1(ivmnem(i),mgwa,cmnem(i))
          ENDIF
        ENDDO
      ENDIF

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".

      IF ( ( csmf.EQ.'Y' ) .AND. ( idxmsg(mgwa).NE.1 ) )  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,mgwa,ibit)
        ibit = (mbyt-4)*8
        CALL pkc(sevn,4,mgwa,ibit)

        CALL stndrd(lunit,mgwa,mxmsgld4,mgwb)

C       COMPUTE MBYT FOR THE NEW "STANDARDIZED" MESSAGE.

        mbyt = iupbs01(mgwb,'LENM')

C       COPY THE MGWB ARRAY BACK INTO MGWA.

        DO ii = 1, nmwrd(mgwb)
          mgwa(ii) = mgwb(ii)
        ENDDO
      ENDIF

C     APPEND THE TANK RECEIPT TIME TO SECTION 1 IF REQUESTED VIA
C     COMMON /TNKRCP/, UNLESS THE MESSAGE CONTAINS BUFR TABLE (DX)
C     INFORMATION. 

      IF ( ( ctrt.EQ.'Y' ) .AND. ( idxmsg(mgwa).NE.1 ) ) THEN

C       INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE ATRCPT.

        ibit = 32
        CALL pkb(mbyt,24,mgwa,ibit)

        CALL atrcpt(mgwa,mxmsgld4,mgwb)

C       COMPUTE MBYT FOR THE REVISED MESSAGE.

        mbyt = iupbs01(mgwb,'LENM')

C       COPY THE MGWB ARRAY BACK INTO MGWA.

        DO ii = 1, nmwrd(mgwb)
          mgwa(ii) = mgwb(ii)
        ENDDO
      ENDIF

C     GET THE SECTION LENGTHS.

      CALL getlens(mgwa,4,len0,len1,len2,len3,len4,l5)

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(mgwa,'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,mgwa,ibit)
           ibit = iad5*8
           CALL pkb(0,8,mgwa,ibit)
           mbyt = mbyt+1
        ENDIF
      ENDIF

C  WRITE SECTION 0 BYTE COUNT AND SECTION 5
C  ----------------------------------------

      ibit = 0
      CALL pkc(bufr, 4,mgwa,ibit)
      CALL pkb(mbyt,24,mgwa,ibit)

      kbit = (mbyt-4)*8
      CALL pkc(sevn, 4,mgwa,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     MGWA(*) (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(mgwa,mxmsgld4,npbyt)

C  WRITE THE MESSAGE PLUS PADDING TO A WORD BOUNDARY IF NULL(LUN) = 0
C  ------------------------------------------------------------------

      mwrd = nmwrd(mgwa)
      CALL status(lunit,lun,il,im)
      IF(null(lun).EQ.0) THEN
         CALL blocks(mgwa,mwrd)
         CALL cwrbufr(lun,mgwa,mwrd)
      ENDIF

      IF(iprt.GE.2) THEN
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      WRITE ( unit=errstr, fmt='(A,I4,A,I7)')
     .  'BUFRLIB: MSGWRT: LUNIT =', lunit, ', BYTES =', mbyt+npbyt
      CALL errwrt(errstr)
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      CALL errwrt(' ')
      ENDIF

C  SAVE A MEMORY COPY OF THIS MESSAGE, UNLESS IT'S A DX MESSAGE
C  ------------------------------------------------------------

      IF(idxmsg(mgwa).NE.1) THEN

C        STORE A COPY OF THIS MESSAGE WITHIN MODULE BUFRMG,
C        FOR POSSIBLE LATER RETRIEVAL DURING A FUTURE CALL TO
C        SUBROUTINE WRITSA.

         msglen(lun) = mwrd
         DO i=1,msglen(lun)
           msgtxt(i,lun) = mgwa(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