var/external/bufr/stndrd.f

   1       SUBROUTINE STNDRD(LUNIT,MSGIN,LMSGOT,MSGOT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    STNDRD
   6 C   PRGMMR: ATOR             ORG: NP12       DATE: 2004-08-18
   7 C
   8 C ABSTRACT: THIS SUBROUTINE READS AN INPUT NCEP BUFR MESSAGE CONTAINED
   9 C   WITHIN ARRAY MSGIN AND, USING THE BUFR TABLES INFORMATION ASSOCIATED
  10 C   WITH LOGICAL UNIT LUNIT, OUTPUTS A "STANDARDIZED" VERSION OF THIS
  11 C   SAME MESSAGE WITHIN ARRAY MSGOT.  THIS "STANDARDIZATION" INVOLVES
  12 C   REMOVING ALL OCCURRENCES OF NCEP BUFRLIB-SPECIFIC BYTE COUNTERS AND
  13 C   BIT PADS IN SECTION 4 AS WELL AS REPLACING THE TOP-LEVEL TABLE A FXY
  14 C   NUMBER IN SECTION 3 WITH AN EQUIVALENT SEQUENCE OF LOWER-LEVEL
  15 C   TABLE B, TABLE C, TABLE D AND/OR REPLICATION FXY NUMBERS WHICH
  16 C   DIRECTLY CONSTITUTE THAT TABLE A FXY NUMBER AND WHICH THEMSELVES ARE
  17 C   ALL WMO-STANDARD.  THE RESULT IS THAT THE OUTPUT MESSAGE IN MSGOT IS
  18 C   NOW ENTIRELY COMPLIANT WITH WMO FM-94 BUFR REGULATIONS (I.E. IT IS
  19 C   NOW "STANDARD"). IT IS IMPORTANT TO NOTE THAT THE SEQUENCE EXPANSION
  20 C   WITHIN SECTION 3 MAY CAUSE THE FINAL "STANDARDIZED" BUFR MESSAGE TO
  21 C   BE LONGER THAN THE ORIGINAL INPUT NCEP BUFR MESSAGE BY AS MANY AS
  22 C   (MAXNC*2) BYTES (SEE 'bufrlib.prm' FOR AN EXPLANATION OF MAXNC), SO
  23 C   THE USER MUST ALLOW FOR ENOUGH SPACE TO ACCOMODATE SUCH AN EXPANSION
  24 C   WITHIN THE MSGOT ARRAY.
  25 C
  26 C PROGRAM HISTORY LOG:
  27 C 2004-08-18  J. ATOR    -- ORIGINAL AUTHOR
  28 C                           THIS SUBROUTINE IS MODELED AFTER SUBROUTINE
  29 C                           STANDARD; HOWEVER, IT USES SUBROUTINE RESTD
  30 C                           TO EXPAND SECTION 3 AS MANY LEVELS AS
  31 C                           NECESSARY IN ORDER TO ATTAIN TRUE WMO
  32 C                           STANDARDIZATION (WHEREAS STANDARD ONLY
  33 C                           EXPANDED THE TOP-LEVEL TABLE A FXY NUMBER
  34 C                           ONE LEVEL DEEP), AND IT ALSO CONTAINS AN
  35 C                           EXTRA INPUT ARGUMENT LMSGOT WHICH PREVENTS
  36 C                           OVERFLOW OF THE MSGOT ARRAY
  37 C 2005-11-29  J. ATOR    -- USE GETLENS AND IUPBS01; ENSURE THAT BYTE 4
  38 C                           OF SECTION 4 IS ZEROED OUT IN MSGOT; CHECK
  39 C                           EDITION NUMBER OF BUFR MESSAGE BEFORE
  40 C                           PADDING TO AN EVEN BYTE COUNT
  41 C 2009-03-23  J. ATOR    -- USE IUPBS3 AND NEMTBAX; DON'T ASSUME THAT
  42 C                           COMPRESSED MESSAGES ARE ALREADY FULLY
  43 C                           STANDARDIZED WITHIN SECTION 3
  44 C
  45 C USAGE:    CALL STNDRD (LUNIT, MSGIN, LMSGOT, MSGOT)
  46 C   INPUT ARGUMENT LIST:
  47 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  48 C     MSGIN    - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE IN NCEP
  49 C                BUFR
  50 C     LMSGOT   - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT;
  51 C                USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT
  52 C                OVERFLOW THE MSGOT ARRAY
  53 C
  54 C   OUTPUT ARGUMENT LIST:
  55 C     MSGOT    - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE
  56 C                NOW IN STANDARDIZED BUFR
  57 C
  58 C REMARKS:
  59 C    MSGIN AND MSGOT MUST BE SEPARATE ARRAYS.
  60 C
  61 C    THIS ROUTINE CALLS:        BORT     GETLENS  ISTDESC  IUPB
  62 C                               IUPBS01  IUPBS3   MVB      NEMTBAX
  63 C                               NUMTAB   PKB      PKC      RESTD
  64 C                               STATUS   UPB      UPC
  65 C    THIS ROUTINE IS CALLED BY: MSGWRT
  66 C                               Also called by application programs.
  67 C
  68 C ATTRIBUTES:
  69 C   LANGUAGE: FORTRAN 77
  70 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  71 C
  72 C$$$
  73
  74       INCLUDE 'bufrlib.prm'
  75
  76       DIMENSION ICD(MAXNC)
  77
  78       COMMON /HRDWRD/ NBYTW,NBITW,IORD(8)
  79
  80       DIMENSION MSGIN(*),MSGOT(*)
  81
  82       CHARACTER*128 BORT_STR
  83       CHARACTER*8   SUBSET
  84       CHARACTER*4   SEVN
  85       CHARACTER*1   TAB
  86
  87       LOGICAL FOUND
  88
  89 C-----------------------------------------------------------------------
  90 C-----------------------------------------------------------------------
  91
  92 C  LUNIT MUST POINT TO AN OPEN BUFR FILE
  93 C  -------------------------------------
  94
  95       CALL STATUS(LUNIT,LUN,IL,IM)
  96       IF(IL.EQ.0) GOTO 900
  97
  98 C  IDENTIFY THE SECTION LENGTHS AND ADDRESSES IN MSGIN
  99 C  ---------------------------------------------------
 100
 101       CALL GETLENS(MSGIN,5,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5)
 102
 103       IAD3 = LEN0+LEN1+LEN2
 104       IAD4 = IAD3+LEN3
 105
 106       LENN = LEN0+LEN1+LEN2+LEN3+LEN4+LEN5
 107
 108       LENM = IUPBS01(MSGIN,'LENM')
 109
 110       IF(LENN.NE.LENM) GOTO 901
 111
 112       MBIT = (LENN-4)*8
 113       CALL UPC(SEVN,4,MSGIN,MBIT)
 114       IF(SEVN.NE.'7777') GOTO 902
 115
 116 C  COPY SECTIONS 0 THROUGH PART OF SECTION 3 INTO MSGOT
 117 C  ----------------------------------------------------
 118
 119       MXBYTO = (LMSGOT*NBYTW) - 8
 120
 121       LBYTO = IAD3+7
 122       IF(LBYTO.GT.MXBYTO) GOTO 905
 123       CALL MVB(MSGIN,1,MSGOT,1,LBYTO)
 124
 125 C  REWRITE NEW SECTION 3 IN A "STANDARD" FORM
 126 C  ------------------------------------------
 127
 128 C     LOCATE THE TOP-LEVEL TABLE A DESCRIPTOR
 129
 130       FOUND = .FALSE.
 131       II = 10
 132       DO WHILE ((.NOT.FOUND).AND.(II.GE.8))
 133           ISUB = IUPB(MSGIN,IAD3+II,16)
 134           CALL NUMTAB(LUN,ISUB,SUBSET,TAB,ITAB)
 135           IF((ITAB.NE.0).AND.(TAB.EQ.'D')) THEN
 136               CALL NEMTBAX(LUN,SUBSET,MTYP,MSBT,INOD)
 137               IF(INOD.NE.0) FOUND = .TRUE.
 138           ENDIF
 139           II = II - 2
 140       ENDDO
 141       IF(.NOT.FOUND) GOTO 903
 142
 143       IF (ISTDESC(ISUB).EQ.0) THEN
 144
 145 C         ISUB IS A NON-STANDARD TABLE A DESCRIPTOR AND NEEDS
 146 C         TO BE EXPANDED INTO AN EQUIVALENT STANDARD SEQUENCE
 147
 148           CALL RESTD(LUN,ISUB,NCD,ICD)
 149       ELSE
 150
 151 C         ISUB IS ALREADY A STANDARD DESCRIPTOR, SO JUST COPY
 152 C         IT "AS IS" INTO THE NEW SECTION 3 (I.E. NO EXPANSION
 153 C         IS NECESSARY!)
 154
 155           NCD = 1
 156           ICD(NCD) = ISUB
 157       ENDIF
 158
 159 C     USE THE EDITION NUMBER TO DETERMINE THE LENGTH OF THE
 160 C     NEW SECTION 3
 161
 162       LEN3 = 7+(NCD*2)
 163       IBEN = IUPBS01(MSGIN,'BEN')
 164       IF(IBEN.LT.4) THEN
 165           LEN3 = LEN3+1
 166       ENDIF
 167       LBYTO = LBYTO + LEN3 - 7
 168       IF(LBYTO.GT.MXBYTO) GOTO 905
 169
 170 C     STORE THE DESCRIPTORS INTO THE NEW SECTION 3
 171
 172       IBIT = (IAD3+7)*8
 173       DO N=1,NCD
 174           CALL PKB(ICD(N),16,MSGOT,IBIT)
 175       ENDDO
 176
 177 C     DEPENDING ON THE EDITION NUMBER, PAD OUT THE NEW SECTION 3 WITH AN
 178 C     ADDITIONAL ZEROED-OUT BYTE IN ORDER TO ENSURE AN EVEN BYTE COUNT
 179
 180       IF(IBEN.LT.4) THEN
 181           CALL PKB(0,8,MSGOT,IBIT)
 182       ENDIF
 183
 184 C     STORE THE LENGTH OF THE NEW SECTION 3
 185
 186       IBIT = IAD3*8
 187       CALL PKB(LEN3,24,MSGOT,IBIT)
 188
 189 C  NOW THE TRICKY PART - NEW SECTION 4
 190 C  -----------------------------------
 191
 192       IF(IUPBS3(MSGIN,'ICMP').EQ.1) THEN
 193
 194 C         THE DATA IN SECTION 4 IS COMPRESSED AND IS THEREFORE ALREADY
 195 C         STANDARDIZED, SO COPY IT "AS IS" INTO THE NEW SECTION 4
 196
 197           IF((LBYTO+LEN4+4).GT.MXBYTO) GOTO 905
 198
 199           CALL MVB(MSGIN,IAD4+1,MSGOT,LBYTO+1,LEN4)
 200
 201           JBIT = (LBYTO+LEN4)*8
 202
 203       ELSE
 204
 205           NAD4 = IAD3+LEN3
 206
 207           IBIT = (IAD4+4)*8
 208           JBIT = (NAD4+4)*8
 209
 210           LBYTO = LBYTO + 4
 211
 212 C         COPY THE SUBSETS, MINUS THE BYTE COUNTERS AND BIT PADS, INTO
 213 C         THE NEW SECTION 4
 214
 215           NSUB = IUPBS3(MSGIN,'NSUB')
 216
 217           DO 10 I=1,NSUB
 218               CALL UPB(LSUB,16,MSGIN,IBIT)
 219               DO L=1,LSUB-2
 220                   CALL UPB(NVAL,8,MSGIN,IBIT)
 221                   LBYTO = LBYTO + 1
 222                   IF(LBYTO.GT.MXBYTO) GOTO 905
 223                   CALL PKB(NVAL,8,MSGOT,JBIT)
 224               ENDDO
 225               DO K=1,8
 226                   KBIT = IBIT-K-8
 227                   CALL UPB(KVAL,8,MSGIN,KBIT)
 228                   IF(KVAL.EQ.K) THEN
 229                      JBIT = JBIT-K-8
 230                      GOTO 10
 231                   ENDIF
 232               ENDDO
 233               GOTO 904
 234 10        ENDDO
 235
 236 C         FROM THIS POINT ON, WE WILL NEED (AT MOST) 6 MORE BYTES OF
 237 C         SPACE WITHIN MSGOT IN ORDER TO BE ABLE TO STORE THE ENTIRE
 238 C         STANDARDIZED MESSAGE (I.E. WE WILL NEED (AT MOST) 2 MORE
 239 C         ZEROED-OUT BYTES IN SECTION 4 PLUS THE 4 BYTES '7777' IN
 240 C         SECTION 5), SO DO A FINAL MSGOT OVERFLOW CHECK NOW.
 241
 242           IF(LBYTO+6.GT.MXBYTO) GOTO 905
 243
 244 C         PAD THE NEW SECTION 4 WITH ZEROES UP TO THE NEXT WHOLE BYTE
 245 C         BOUNDARY.
 246
 247           DO WHILE(.NOT.(MOD(JBIT,8).EQ.0))
 248              CALL PKB(0,1,MSGOT,JBIT)
 249           ENDDO
 250
 251 C         DEPENDING ON THE EDITION NUMBER, WE MAY NEED TO FURTHER PAD
 252 C         THE NEW SECTION 4 WITH AN ADDITIONAL ZEROED-OUT BYTE IN ORDER
 253 C         TO ENSURE THAT THE PADDING IS UP TO AN EVEN BYTE BOUNDARY.
 254
 255           IF( (IBEN.LT.4) .AND. (MOD(JBIT/8,2).NE.0) ) THEN
 256              CALL PKB(0,8,MSGOT,JBIT)
 257           ENDIF
 258
 259           IBIT = NAD4*8
 260           LEN4 = JBIT/8 - NAD4
 261           CALL PKB(LEN4,24,MSGOT,IBIT)
 262           CALL PKB(0,8,MSGOT,IBIT)
 263       ENDIF
 264
 265 C  FINISH THE NEW MESSAGE WITH AN UPDATED SECTION 0 BYTE COUNT
 266 C  -----------------------------------------------------------
 267
 268       IBIT = 32
 269       LENN = LEN0+LEN1+LEN2+LEN3+LEN4+LEN5
 270       CALL PKB(LENN,24,MSGOT,IBIT)
 271
 272       CALL PKC('7777',4,MSGOT,JBIT)
 273
 274 C  EXITS
 275 C  -----
 276
 277       RETURN
 278 900   CALL BORT('BUFRLIB: STNDRD - BUFR FILE IS CLOSED, IT MUST BE'//
 279      . ' OPEN')
 280 901   WRITE(BORT_STR,'("BUFRLIB: STNDRD - INPUT MESSAGE LENGTH FROM'//
 281      . ' SECTION 0",I6," DOES NOT EQUAL SUM OF ALL INDIVIDUAL SECTION'//
 282      . ' LENGTHS (",I6,")")') LENM,LENN
 283       CALL BORT(BORT_STR)
 284 902   WRITE(BORT_STR,'("BUFRLIB: STNDRD - INPUT MESSAGE DOES NOT '//
 285      . 'END WITH ""7777"" (ENDS WITH ",A)') SEVN
 286       CALL BORT(BORT_STR)
 287 903   CALL BORT('BUFRLIB: STNDRD - TABLE A SUBSET DESCRIPTOR '//
 288      . 'NOT FOUND')
 289 904   CALL BORT('BUFRLIB: STNDRD - BIT MISMATCH COPYING SECTION 4 '//
 290      . 'FROM INPUT TO OUTPUT (STANDARD) MESSAGE')
 291 905   CALL BORT('BUFRLIB: STNDRD - OVERFLOW OF OUTPUT (STANDARD) '//
 292      . 'MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY')
 293       END