stndrd.f

Go to the documentation of this file.

C> @file
C> @brief Standardize a BUFR message.

C> This subroutine performs the same function as subroutine stdmsg(),
C> except that it operates on a BUFR message passed in via a memory array
C> and returns its output via a separate memory array,
C> whereas stdmsg() operates on BUFR messages stored internally
C> within the software.
C> 
C> @author J. Ator
C> @date 2004-08-18
C>
C> @param[in] LUNIT    - integer: Fortran logical unit number for
C>                       BUFR file
C> @param[in] MSGIN    - integer(*): BUFR message
C> @param[in] LMSGOT   - integer: Dimensioned size (in integers) of
C>                       MSGOT; used by the subroutine to ensure that
C>                       it doesn't overflow the MSGOT array
C> @param[out] MSGOT   - integer(*): Standardized copy of MSGIN
C>
C> @remarks
C> - MSGIN and MSGOT must be separate arrays.
C> - Standardized messages are usually longer in length than their
C> non-standard counterparts, so it's usually a good idea to allow
C> for extra space when allocating MSGOT within the application program.
C> 
C> <b>Program history log:</b>
C> - 2004-08-18  J. Ator    -- Original author
C> - 2005-11-29  J. Ator    -- Use getlens() and iupbs01(); ensure that
C>                           byte 4 of Section 4 is zeroed out in MSGOT;
C>                           check 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
C>                           that compressed messages are already fully
C>                           standardized within Section 3
C> - 2014-02-04  J. Ator    -- Account for subsets with byte count > 65530
C> - 2020-07-16  J. Ator    -- Fix bug in ISLEN computation when NSUB = 1
C>
      SUBROUTINE stndrd(LUNIT,MSGIN,LMSGOT,MSGOT)

      USE modv_maxnc

      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,.true.)
      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)
              IF(nsub.GT.1) THEN

C                 USE THE BYTE COUNTER TO COPY THIS SUBSET

                  islen = lsub-2
              ELSE

C                 THIS IS THE ONLY SUBSET IN THE MESSAGE, AND IT COULD
C                 POSSIBLY BE AN OVERLARGE (> 65530 BYTES) SUBSET, IN
C                 WHICH CASE WE CAN'T RELY ON THE VALUE STORED IN THE
C                 BYTE COUNTER.  EITHER WAY, WE DON'T REALLY NEED IT.

                  islen = iad4+len4-(ibit/8)
                  IF (mod(len4,2).EQ.0) islen = islen - 1
              ENDIF
              DO l=1,islen
                  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