wrfv2_fire/var/external/bufr/stndrd.inc

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