var/external/bufr/ishrdx.f

   1       INTEGER FUNCTION ISHRDX(LUD,LUN)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    ISHRDX
   6 C   PRGMMR: J. ATOR          ORG: NP20       DATE: 2009-11-30
   7 C
   8 C ABSTRACT: THIS FUNCTION DETERMINES WHETHER LOGICAL UNIT IOLUN(LUN) IS
   9 C   SHARING INTERNAL TABLE INFORMATION WITH LOGICAL UNIT IOLUN(LUD).
  10 C   NOTE THAT TWO LOGICAL UNITS CAN HAVE THE SAME INTERNAL TABLE
  11 C   INFORMATION WITHOUT ACTUALLY SHARING IT.
  12 C
  13 C PROGRAM HISTORY LOG:
  14 C 2009-11-30  J. ATOR    -- ORIGINAL AUTHOR
  15 C
  16 C USAGE:    ISHRDX (LUD, LUN)
  17 C   INPUT ARGUMENT LIST:
  18 C     LUD      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  19 C                FOR FIRST LOGICAL UNIT
  20 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  21 C                FOR SECOND LOGICAL UNIT
  22 C
  23 C   OUTPUT ARGUMENT LIST:
  24 C     ISHRDX   - INTEGER: RETURN CODE INDICATING WHETHER IOLUN(LUN)
  25 C                IS SHARING TABLE INFORMATION WITH IOLUN(LUD):
  26 C                  0 - NO
  27 C                  1 - YES
  28 C
  29 C REMARKS:
  30 C    THIS ROUTINE CALLS:        None
  31 C    THIS ROUTINE IS CALLED BY: ICMPDX  MAKESTAB
  32 C                               Normally not called by any application
  33 C                               programs.
  34 C
  35 C ATTRIBUTES:
  36 C   LANGUAGE: FORTRAN 77
  37 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  38 C
  39 C$$$
  40
  41       INCLUDE 'bufrlib.prm'
  42
  43       COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
  44      .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
  45      .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
  46      .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
  47      .                TABD(MAXTBD,NFILES)
  48
  49       CHARACTER*600 TABD
  50       CHARACTER*128 TABB
  51       CHARACTER*128 TABA
  52
  53 C-----------------------------------------------------------------------
  54 C-----------------------------------------------------------------------
  55
  56 C     Note that, for any I/O stream index value LUx, the MTAB(*,LUx)
  57 C     array contains pointer indices into the internal jump/link table
  58 C     for each of the Table A mnemonics that is currently defined for
  59 C     that LUx value.  Thus, if all of these indices are identical for
  60 C     two different LUx values, then the associated logical units are
  61 C     sharing table information.
  62
  63       IF ( ( NTBA(LUD) .GE. 1 ) .AND.
  64      +      ( NTBA(LUD) .EQ. NTBA(LUN) ) ) THEN
  65         II = 1
  66         ISHRDX = 1
  67         DO WHILE ( ( II .LE. NTBA(LUD) ) .AND. ( ISHRDX .EQ. 1 ) )
  68           IF ( ( MTAB(II,LUD) .NE. 0 ) .AND.
  69      +          ( MTAB(II,LUD) .EQ. MTAB(II,LUN) ) ) THEN
  70             II = II + 1
  71           ELSE
  72             ISHRDX = 0
  73           ENDIF
  74         ENDDO
  75       ELSE
  76         ISHRDX = 0
  77       ENDIF
  78
  79       RETURN
  80       END