dxinit.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE INITIALIZES THE INTERNAL ARRAYS
C>   (IN MODULE TABABD) HOLDING THE DICTIONARY TABLE.  IT THEN
C>   INITIALIZES THE TABLE WITH APRIORI TABLE B AND D ENTRIES
C>   (OPTIONAL).
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
C>                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
C>                           DOCUMENTATION (INCLUDING HISTORY)
C> 2009-03-23  J. ATOR    -- REMOVE INITIALIZATION OF COMMON /MSGCWD/
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL DXINIT (LUN, IOI)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>     IOI      - INTEGER: SWITCH:
C>                       0 = do not initialize the table with apriori
C>                           Table B and D entries
C>                    else = initialize the table with apriori Table B
C>                           and D entries
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        ADN30    IFXY     PKTDD
C>    THIS ROUTINE IS CALLED BY: CPBFDX   OPENBF   RDBFDX   RDUSDX
C>                               READERME READS3
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE dxinit(LUN,IOI)

      USE moda_tababd

      COMMON /padesc/ ibct,ipd1,ipd2,ipd3,ipd4
      COMMON /reptab/ idnr(5,2),typs(5,2),reps(5,2),lens(5)

      CHARACTER*8   inib(6,5),inid(5)
      CHARACTER*6   adn30
      CHARACTER*3   typs
      CHARACTER*1   reps

      DATA inib   /'------','BYTCNT  ','BYTES  ','+0','+0','16',
     .             '------','BITPAD  ','NONE   ','+0','+0','1 ',
     .             '031000','DRF1BIT ','NUMERIC','+0','+0','1 ',
     .             '031001','DRF8BIT ','NUMERIC','+0','+0','8 ',
     .             '031002','DRF16BIT','NUMERIC','+0','+0','16'/
      DATA ninib  /5/

      DATA inid   /'        ',
     .             'DRP16BIT',
     .             'DRP8BIT ',
     .             'DRPSTAK ',
     .             'DRP1BIT '/
      DATA ninid  /5/

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

C  CLEAR OUT A TABLE PARTITION
C  ---------------------------

      ntba(lun) = 0
      DO i=1,ntba(0)
      taba(i,lun) = ' '
      mtab(i,lun) = 0
      ENDDO

      ntbb(lun) = 0
      DO i=1,ntbb(0)
      tabb(i,lun) = ' '
      ENDDO

      ntbd(lun) = 0
      DO i=1,ntbd(0)
      tabd(i,lun) = ' '
c  .... This zeroes the counter in TABD array, IRET returns as 0 and
c       is not tested
      CALL pktdd(i,lun,0,iret)
      ENDDO

      IF(ioi.EQ.0) goto 100

C  INITIALIZE TABLE WITH APRIORI TABLE B AND D ENTRIES
C  ---------------------------------------------------

      inib(1,1) = adn30(ibct,6)
      inib(1,2) = adn30(ipd4,6)

      DO i=1,ninib
      ntbb(lun) = ntbb(lun)+1
      idnb(i,lun) = ifxy(inib(1,i))
      tabb(i,lun)(  1:  6) = inib(1,i)
      tabb(i,lun)(  7: 70) = inib(2,i)
      tabb(i,lun)( 71: 94) = inib(3,i)
      tabb(i,lun)( 95: 98) = inib(4,i)
      tabb(i,lun)( 99:109) = inib(5,i)
      tabb(i,lun)(110:112) = inib(6,i)
      ENDDO

      DO i=2,ninid
      n = ntbd(lun)+1
      idnd(n,lun) = idnr(i,1)
      tabd(n,lun)(1: 6) = adn30(idnr(i,1),6)
      tabd(n,lun)(7:70) = inid(i)
c  .... DK: what if IRET = -1 ???
      CALL pktdd(n,lun,idnr(1,1),iret)
c  .... DK: what if IRET = -1 ???
      CALL pktdd(n,lun,idnr(i,2),iret)
      ntbd(lun) = n
      ENDDO

C  EXIT
C  ----

100   RETURN
      END