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> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 2004-08-18 | J. Ator | Original author |
C> | 2005-11-29 | J. Ator | Use getlens() and iupbs01(); ensure that byte 4 of Section 4 is zeroed out in MSGOT; check edition number of BUFR message before padding to an even byte count |
C> | 2009-03-23 | J. Ator | Use iupbs3() and nemtbax(); don't assume that compressed messages are already fully 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