var/external/bufr/stbfdx.f

   1       SUBROUTINE STBFDX(LUN,MESG)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    STBFDX
   6 C   PRGMMR: J. ATOR          ORG: NP12       DATE: 2009-03-23
   7 C
   8 C ABSTRACT: THIS SUBROUTINE COPIES A BUFR TABLE (DICTIONARY) MESSAGE
   9 C   FROM THE INPUT ARRAY MESG INTO THE INTERNAL MEMORY ARRAYS IN
  10 C   COMMON BLOCK /TABABD/.
  11 C
  12 C PROGRAM HISTORY LOG:
  13 C 2009-03-23  J. ATOR    -- ORIGINAL AUTHOR, USING LOGIC COPIED
  14 C                           FROM PREVIOUS VERSION OF RDBFDX
  15 C
  16 C USAGE:    CALL STBFDX (LUN,MESG)
  17 C   INPUT ARGUMENT LIST:
  18 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  19 C     MESG     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING
  20 C                BUFR TABLE (DICTIONARY) MESSAGE
  21 C
  22 C REMARKS:
  23 C    THIS ROUTINE CALLS:        BORT     CAPIT    CHRTRN   CHRTRNA
  24 C                               GETLENS  IGETNTBI IDN30    IFXY
  25 C                               IUPBS01  IUPM     NENUBD   NMWRD
  26 C                               PKTDD    STNTBIA
  27 C    THIS ROUTINE IS CALLED BY: RDBFDX   RDMEMM   READERME
  28 C                               Normally not called by any application
  29 C                               programs.
  30 C
  31 C ATTRIBUTES:
  32 C   LANGUAGE: FORTRAN 77
  33 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  34 C
  35 C$$$
  36
  37       INCLUDE 'bufrlib.prm'
  38
  39       COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
  40      .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
  41      .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
  42      .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
  43      .                TABD(MAXTBD,NFILES)
  44       COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10),
  45      .                LD30(10),DXSTR(10)
  46
  47       CHARACTER*600 TABD
  48       CHARACTER*128 BORT_STR
  49       CHARACTER*128 TABB,TABB1,TABB2
  50       CHARACTER*128 TABA
  51       CHARACTER*56  DXSTR
  52       CHARACTER*55  CSEQ
  53       CHARACTER*50  DXCMP
  54       CHARACTER*24  UNIT
  55       CHARACTER*8   NEMO
  56       CHARACTER*6   NUMB,CIDN
  57       CHARACTER*1   MOCT(MXMSGL)
  58       DIMENSION     MBAY(MXMSGLD4),LDXBD(10),LDXBE(10)
  59
  60       DIMENSION     MESG(*)
  61
  62       EQUIVALENCE   (MBAY(1),MOCT(1))
  63
  64       DATA LDXBD /38,70,8*0/
  65       DATA LDXBE /42,42,8*0/
  66
  67 C-----------------------------------------------------------------------
  68       JA(I) = IA+1+LDA*(I-1)
  69       JB(I) = IB+1+LDB*(I-1)
  70 C-----------------------------------------------------------------------
  71
  72 C  MAKE A LOCAL COPY OF THE MESSAGE (SO IT CAN BE EQUIVALENCED!)
  73 C  -------------------------------------------------------------
  74
  75       DO II = 1,NMWRD(MESG)
  76         MBAY(II) = MESG(II)
  77       ENDDO
  78
  79 C  GET SOME PRELIMINARY INFORMATION FROM THE MESSAGE
  80 C  -------------------------------------------------
  81
  82       IDXS = IUPBS01(MBAY,'MSBT')+1
  83       IF(IDXS.GT.IDXV+1) IDXS = IUPBS01(MBAY,'MTVL')+1
  84       IF(LDXA(IDXS).EQ.0) GOTO 901
  85       IF(LDXB(IDXS).EQ.0) GOTO 901
  86       IF(LDXD(IDXS).EQ.0) GOTO 901
  87
  88       CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5)
  89       I3 = LEN0+LEN1+LEN2
  90       DXCMP = ' '
  91       CALL CHRTRN(DXCMP,MOCT(I3+8),NXSTR(IDXS))
  92       IF(DXCMP.NE.DXSTR(IDXS)) GOTO 902
  93
  94 C  SECTION 4 - READ DEFINITIONS FOR TABLES A, B AND D
  95 C  --------------------------------------------------
  96
  97       LDA  = LDXA (IDXS)
  98       LDB  = LDXB (IDXS)
  99       LDD  = LDXD (IDXS)
 100       LDBD = LDXBD(IDXS)
 101       LDBE = LDXBE(IDXS)
 102       L30  = LD30 (IDXS)
 103
 104       IA = I3+LEN3+5
 105       LA = IUPM(MOCT(IA),8)
 106       IB = JA(LA+1)
 107       LB = IUPM(MOCT(IB),8)
 108       ID = JB(LB+1)
 109       LD = IUPM(MOCT(ID),8)
 110
 111 C  TABLE A
 112 C  -------
 113
 114       DO I=1,LA
 115         N = IGETNTBI(LUN,'A')
 116         CALL CHRTRNA(TABA(N,LUN),MOCT(JA(I)),LDA)
 117         NUMB = '   '//TABA(N,LUN)(1:3)
 118         NEMO = TABA(N,LUN)(4:11)
 119         CSEQ = TABA(N,LUN)(13:67)
 120         CALL STNTBIA(N,LUN,NUMB,NEMO,CSEQ)
 121       ENDDO
 122
 123 C  TABLE B
 124 C  -------
 125
 126       DO I=1,LB
 127         N = IGETNTBI(LUN,'B')
 128         CALL CHRTRNA(TABB1,MOCT(JB(I)     ),LDBD)
 129         CALL CHRTRNA(TABB2,MOCT(JB(I)+LDBD),LDBE)
 130         TABB(N,LUN) = TABB1(1:LDXBD(IDXV+1))//TABB2(1:LDXBE(IDXV+1))
 131         NUMB = TABB(N,LUN)(1:6)
 132         NEMO = TABB(N,LUN)(7:14)
 133         CALL NENUBD(NEMO,NUMB,LUN)
 134         IDNB(N,LUN) = IFXY(NUMB)
 135         UNIT = TABB(N,LUN)(71:94)
 136         CALL CAPIT(UNIT)
 137         TABB(N,LUN)(71:94) = UNIT
 138         NTBB(LUN) = N
 139       ENDDO
 140
 141 C  TABLE D
 142 C  -------
 143
 144       DO I=1,LD
 145         N = IGETNTBI(LUN,'D')
 146         CALL CHRTRNA(TABD(N,LUN),MOCT(ID+1),LDD)
 147         NUMB = TABD(N,LUN)(1:6)
 148         NEMO = TABD(N,LUN)(7:14)
 149         CALL NENUBD(NEMO,NUMB,LUN)
 150         IDND(N,LUN) = IFXY(NUMB)
 151         ND = IUPM(MOCT(ID+LDD+1),8)
 152         IF(ND.GT.MAXCD) GOTO 903
 153         DO J=1,ND
 154           NDD = ID+LDD+2 + (J-1)*L30
 155           CALL CHRTRNA(CIDN,MOCT(NDD),L30)
 156           IDN = IDN30(CIDN,L30)
 157           CALL PKTDD(N,LUN,IDN,IRET)
 158           IF(IRET.LT.0) GOTO 904
 159         ENDDO
 160         ID = ID+LDD+1 + ND*L30
 161         IF(IUPM(MOCT(ID+1),8).EQ.0) ID = ID+1
 162         NTBD(LUN) = N
 163       ENDDO
 164
 165 C  EXITS
 166 C  -----
 167
 168       RETURN
 169 901   CALL BORT('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '//
 170      . 'SUBTYPE OR LOCAL VERSION NUMBER (E.G., L.V.N. HIGHER THAN '//
 171      . 'KNOWN)')
 172 902   CALL BORT('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '//
 173      . 'CONTENTS')
 174 903   WRITE(BORT_STR,'("BUFRLIB: STBFDX - NUMBER OF DESCRIPTORS IN '//
 175      . 'TABLE D ENTRY ",A," IN BUFR TABLE (",I4,") EXCEEDS THE LIMIT '//
 176      . ' (",I4,")")') NEMO,ND,MAXCD
 177       CALL BORT(BORT_STR)
 178 904   CALL BORT('BUFRLIB: STBFDX - BAD RETURN FROM BUFRLIB ROUTINE '//
 179      . 'PKTDD, SEE PREVIOUS WARNING MESSAGE')
 180       END