var/external/bufr/iupbs01.f

   1       FUNCTION IUPBS01(MBAY,S01MNEM)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    IUPBS01
   6 C   PRGMMR: ATOR             ORG: NP12       DATE: 2005-11-29
   7 C
   8 C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A SPECIFIED INTEGER VALUE
   9 C   FROM SECTION 0 OR SECTION 1 OF THE BUFR MESSAGE STORED IN ARRAY
  10 C   MBAY.  IT WILL WORK ON ANY MESSAGE ENCODED USING BUFR EDITION 2, 3
  11 C   OR 4.  THE START OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") MUST
  12 C   BE ALIGNED ON THE FIRST FOUR BYTES OF MBAY, AND THE VALUE TO BE
  13 C   UNPACKED IS SPECIFIED VIA THE MNEMONIC S01MNEM, AS EXPLAINED IN
  14 C   FURTHER DETAIL BELOW.
  15 C
  16 C PROGRAM HISTORY LOG:
  17 C 2005-11-29  J. ATOR    -- ORIGINAL AUTHOR
  18 C 2006-04-14  J. ATOR    -- ADDED OPTIONS FOR 'YCEN' AND 'CENT';
  19 C                           RESTRUCTURED LOGIC
  20 C
  21 C USAGE:    IUPBS01 (MBAY, S01MNEM)
  22 C   INPUT ARGUMENT LIST:
  23 C     MBAY     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING
  24 C                BUFR MESSAGE
  25 C     S01MNEM  - CHARACTER*(*): MNEMONIC SPECIFYING VALUE TO BE
  26 C                UNPACKED FROM SECTION 0 OR SECTION 1 OF BUFR MESSAGE:
  27 C                  'LENM'  = LENGTH (IN BYTES) OF BUFR MESSAGE
  28 C                  'LEN0'  = LENGTH (IN BYTES) OF SECTION 0
  29 C                  'BEN'   = BUFR EDITION NUMBER
  30 C                  'LEN1'  = LENGTH (IN BYTES) OF SECTION 1
  31 C                  'BMT'   = BUFR MASTER TABLE
  32 C                  'OGCE'  = ORIGINATING CENTER
  33 C                  'GSES'  = ORIGINATING SUBCENTER
  34 C                              (NOTE: THIS VALUE IS PRESENT ONLY IN
  35 C                                     BUFR EDITION 3 OR 4 MESSAGES!)
  36 C                  'USN'   = UPDATE SEQUENCE NUMBER
  37 C                  'ISC2'  = FLAG INDICATING ABSENCE/PRESENCE OF
  38 C                            (OPTIONAL) SECTION 2 IN BUFR MESSAGE:
  39 C                              0 = SECTION 2 ABSENT
  40 C                              1 = SECTION 2 PRESENT
  41 C                  'MTYP'  = DATA CATEGORY
  42 C                  'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL)
  43 C                              (NOTE: THIS VALUE IS PRESENT ONLY IN
  44 C                                     BUFR EDITION 4 MESSAGES!)
  45 C                  'MSBT'  = DATA SUBCATEGORY (LOCAL)
  46 C                  'MTV'   = VERSION NUMBER OF MASTER TABLE
  47 C                  'MTVL'  = VERSION NUMBER OF LOCAL TABLES
  48 C                  'YCEN'  = YEAR OF CENTURY (1-100)
  49 C                              (NOTE: THIS VALUE IS PRESENT ONLY IN
  50 C                                     BUFR EDITION 2 AND 3 MESSAGES!)
  51 C                  'CENT'  = CENTURY (I.E., 20 FOR YEARS 1901-2000,
  52 C                                           21 FOR YEARS 2001-2100)
  53 C                              (NOTE: THIS VALUE *MAY* BE PRESENT IN
  54 C                                     BUFR EDITION 2 AND 3 MESSAGES,
  55 C                                     BUT IT IS NEVER PRESENT IN ANY
  56 C                                     BUFR EDITION 4 MESSAGES!)
  57 C                  'YEAR'  = YEAR (4-DIGIT)
  58 C                              (NOTE: THIS VALUE IS PRESENT ONLY IN
  59 C                                     BUFR EDITION 4 MESSAGES.  FOR
  60 C                                     BUFR EDITION 2 AND 3 MESSAGES
  61 C                                     IT WILL BE CALCULATED USING THE
  62 C                                     VALUES FOR 'YCEN' AND 'CENT',
  63 C                                     EXCEPT WHEN THE LATTER IS NOT
  64 C                                     PRESENT AND IN WHICH CASE A
  65 C                                     "WINDOWING" TECHNIQUE WILL BE
  66 C                                     USED INSTEAD!)
  67 C                  'MNTH'  = MONTH
  68 C                  'DAYS'  = DAY
  69 C                  'HOUR'  = HOUR
  70 C                  'MINU'  = MINUTE
  71 C                  'SECO'  = SECOND
  72 C                              (NOTE: THIS VALUE IS PRESENT ONLY IN
  73 C                                     BUFR EDITION 4 MESSAGES!)
  74 C
  75 C   OUTPUT ARGUMENT LIST:
  76 C     IUPBS01  - INTEGER: UNPACKED INTEGER VALUE
  77 C                  -1 = THE INPUT S01MNEM MNEMONIC WAS INVALID FOR
  78 C                       THE EDITION OF BUFR MESSAGE IN MBAY
  79 C
  80 C REMARKS:
  81 C    THIS ROUTINE CALLS:        GETS1LOC I4DY     IUPB     WRDLEN
  82 C    THIS ROUTINE IS CALLED BY: ATRCPT   CKTABA   CNVED4   COPYBF
  83 C                               COPYMG   CPYMEM   CRBMG    CRDBUFR
  84 C                               DUMPBF   GETLENS  IDXMSG   IGETDATE
  85 C                               IUPVS01  MESGBC   MESGBF   MSGWRT
  86 C                               NMWRD    PADMSG   PKBS1    RDMSGB
  87 C                               READS3   RTRCPT   STBFDX   STNDRD
  88 C                               UFBMEX   WRCMPS
  89 C                               Also called by application programs.
  90 C
  91 C ATTRIBUTES:
  92 C   LANGUAGE: FORTRAN 77
  93 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  94 C
  95 C$$$
  96
  97         DIMENSION       MBAY(*)
  98
  99         CHARACTER*(*)   S01MNEM
 100
 101         LOGICAL         OK4CENT
 102
 103 C-----------------------------------------------------------------------
 104 C       This statement function checks whether its input value contains
 105 C       a valid century value.
 106
 107         OK4CENT(IVAL) = ((IVAL.GE.19).AND.(IVAL.LE.21))
 108 C-----------------------------------------------------------------------
 109
 110 C       Call subroutine WRDLEN to initialize some important information
 111 C       about the local machine, just in case subroutine OPENBF hasn't
 112 C       been called yet.
 113
 114         CALL WRDLEN
 115
 116 C       Handle some simple requests that do not depend on the BUFR
 117 C       edition number.
 118
 119         IF(S01MNEM.EQ.'LENM') THEN
 120             IUPBS01 = IUPB(MBAY,5,24)
 121             RETURN
 122         ENDIF
 123
 124         LEN0 = 8
 125         IF(S01MNEM.EQ.'LEN0') THEN
 126             IUPBS01 = LEN0
 127             RETURN
 128         ENDIF
 129
 130 C       Get the BUFR edition number.
 131
 132         IBEN = IUPB(MBAY,8,8)
 133         IF(S01MNEM.EQ.'BEN') THEN
 134             IUPBS01 = IBEN
 135             RETURN
 136         ENDIF
 137
 138 C       Use the BUFR edition number to handle any other requests.
 139
 140         CALL GETS1LOC(S01MNEM,IBEN,ISBYT,IWID,IRET)
 141         IF(IRET.EQ.0) THEN
 142             IUPBS01 = IUPB(MBAY,LEN0+ISBYT,IWID)
 143             IF(S01MNEM.EQ.'CENT') THEN
 144
 145 C               Test whether the returned value was a valid
 146 C               century value.
 147
 148                 IF(.NOT.OK4CENT(IUPBS01)) IUPBS01 = -1
 149             ENDIF
 150         ELSE IF( (S01MNEM.EQ.'YEAR') .AND. (IBEN.LT.4) ) THEN
 151
 152 C           Calculate the 4-digit year.
 153
 154             IYOC = IUPB(MBAY,21,8)
 155             ICEN = IUPB(MBAY,26,8)
 156
 157 C           Does ICEN contain a valid century value?
 158
 159             IF(OK4CENT(ICEN)) THEN
 160
 161 C               YES, so use it to calculate the 4-digit year. Note that,
 162 C               by international convention, the year 2000 was the 100th
 163 C               year of the 20th century, and the year 2001 was the 1st
 164 C               year of the 21st century
 165
 166                 IUPBS01 = (ICEN-1)*100 + IYOC
 167             ELSE
 168
 169 C               NO, so use a windowing technique to determine the
 170 C               4-digit year from the year of the century.
 171
 172                 IUPBS01 = I4DY(MOD(IYOC,100)*1000000)/10**6
 173             ENDIF
 174         ELSE
 175             IUPBS01 = -1
 176         ENDIF
 177
 178         RETURN
 179         END