var/external/bufr/lcmgdf.f

   1       INTEGER FUNCTION LCMGDF(LUNIT,SUBSET)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    LCMGDF
   6 C   PRGMMR: J. ATOR          ORG: NP20       DATE: 2009-07-09
   7 C
   8 C ABSTRACT: THIS FUNCTION CHECKS WHETHER AT LEAST ONE "LONG" (I.E.
   9 C   GREATER THAN 8 BYTES) CHARACTER STRING EXISTS WITHIN THE INTERNAL
  10 C   DICTIONARY DEFINITION FOR THE TABLE A MESSAGE TYPE GIVEN BY SUBSET.
  11 C
  12 C PROGRAM HISTORY LOG:
  13 C 2009-07-09  J. ATOR    -- ORIGINAL AUTHOR
  14 C
  15 C USAGE:    LCMGDF (LUNIT, SUBSET)
  16 C   INPUT ARGUMENT LIST:
  17 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER ASSOCIATED WITH
  18 C                SUBSET DEFINITION
  19 C     SUBSET   - CHARACTER*8: TABLE A MNEMONIC FOR MESSAGE TYPE
  20 C
  21 C   OUTPUT ARGUMENT LIST:
  22 C     LCMGDF   - INTEGER: RETURN CODE INDICATING WHETHER SUBSET CONTAINS
  23 C                AT LEAST ONE "LONG" CHARACTER STRING IN ITS DEFINITION
  24 C                  0 - NO
  25 C                  1 - YES
  26 C
  27 C REMARKS:
  28 C    THIS ROUTINE CALLS:        BORT     NEMTBA   STATUS
  29 C    THIS ROUTINE IS CALLED BY: None
  30 C                               Normally called only by application
  31 C                               programs.
  32 C
  33 C ATTRIBUTES:
  34 C   LANGUAGE: FORTRAN 77
  35 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  36 C
  37 C$$$
  38
  39       INCLUDE 'bufrlib.prm'
  40
  41       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  42      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  43      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  44      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  45      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  46
  47       CHARACTER*10 TAG
  48       CHARACTER*8  SUBSET
  49       CHARACTER*3  TYP
  50
  51 C-----------------------------------------------------------------------
  52 C-----------------------------------------------------------------------
  53
  54 C     Get LUN from LUNIT.
  55
  56       CALL STATUS(LUNIT,LUN,IL,IM)
  57       IF (IL.EQ.0) GOTO 900
  58
  59 C     Confirm that SUBSET is defined for this logical unit.
  60
  61       CALL NEMTBA(LUN,SUBSET,MTYP,MSBT,INOD)
  62
  63 C     Check if there's a long character string in the definition.
  64
  65       NTE = ISC(INOD)-INOD
  66
  67       DO I = 1, NTE
  68         IF ( (TYP(INOD+I).EQ.'CHR') .AND. (IBT(INOD+I).GT.64) ) THEN
  69           LCMGDF = 1
  70           RETURN
  71         ENDIF
  72       ENDDO
  73
  74       LCMGDF = 0
  75
  76       RETURN
  77 900   CALL BORT('BUFRLIB: LCMGDF - INPUT BUFR FILE IS CLOSED, IT MUST'//
  78      . ' BE OPEN')
  79       END