var/external/bufr/gettagpr.f

   1         SUBROUTINE GETTAGPR ( LUNIT, TAGCH, NTAGCH, TAGPR, IRET )
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    GETTAGPR
   6 C   PRGMMR: J. ATOR          ORG: NP12       DATE: 2012-09-12
   7 C
   8 C ABSTRACT:  GIVEN A MNEMONIC CORRESPONDING TO A CHILD DESCRIPTOR
   9 C   WITHIN A PARENT SEQUENCE, THIS SUBROUTINE RETURNS THE MNEMONIC
  10 C   CORRESPONDING TO THE PARENT SEQUENCE.  A SUBSET DEFINITION MUST
  11 C   ALREADY BE IN SCOPE, EITHER VIA A PREVIOUS CALL TO BUFR ARCHIVE
  12 C   LIBRARY SUBROUTINE READSB OR EQUIVALENT (FOR INPUT FILES) OR TO
  13 C   SUBROUTINE OPENMB OR EQUIVALENT (FOR OUTPUT FILES).  IF THERE IS
  14 C   MORE THAN ONE OCCURRENCE OF THE CHILD DESCRIPTOR WITHIN THE
  15 C   OVERALL SUBSET DEFINITION, THIS SUBROUTINE WILL RETURN THE PARENT
  16 C   MNEMONIC CORRESPONDING TO THE (NTAGCH)th OCCURRENCE OF THE CHILD,
  17 C   COUNTING FROM THE BEGINNING OF THE OVERALL SUBSET DEFINITION.
  18 C
  19 C PROGRAM HISTORY LOG:
  20 C 2012-09-12  J. ATOR    -- ORIGINAL AUTHOR
  21 C
  22 C USAGE:    CALL GETTAGPR (LUNIT, TAGCH, NTAGCH, TAGPR, IRET)
  23 C   INPUT ARGUMENT LIST:
  24 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  25 C     TAGCH    - CHARACTER*(*): MNEMONIC CORRESPONDING TO CHILD
  26 C                DESCRIPTOR
  27 C     NTAGCH   - INTEGER: ORDINAL OCCURRENCE OF TAGCH FOR WHICH
  28 C                TAGPR IS TO BE RETURNED, COUNTING FROM THE
  29 C                BEGINNING OF THE OVERALL SUBSET DEFINITION
  30 C
  31 C   OUTPUT ARGUMENT LIST:
  32 C     TAGPR    - CHARACTER*(*): MNEMONIC CORRESPONDING TO PARENT
  33 C                SEQUENCE DESCRIPTOR
  34 C     IRET     - INTEGER: RETURN CODE
  35 C                   0 = NORMAL RETURN
  36 C                  -1 = PARENT MNEMONIC COULD NOT BE FOUND, OR SOME
  37 C                       OTHER ERROR OCCURRED
  38 C
  39 C REMARKS:
  40 C    THIS ROUTINE CALLS:        PARSTR   STATUS
  41 C    THIS ROUTINE IS CALLED BY: None
  42 C                               Normally called only by application
  43 C                               programs
  44 C
  45 C ATTRIBUTES:
  46 C   LANGUAGE: FORTRAN 77
  47 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  48 C
  49 C$$$
  50
  51         INCLUDE 'bufrlib.prm'
  52
  53         COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  54      .                  INODE(NFILES),IDATE(NFILES)
  55         COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  56      .                  JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  57      .                  IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  58      .                  ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  59      .                  ISEQ(MAXJL,2),JSEQ(MAXJL)
  60         COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  61
  62         CHARACTER*10  TAG,TGS(15)
  63         CHARACTER*3   TYP
  64
  65         CHARACTER*(*) TAGCH, TAGPR
  66
  67         REAL*8 VAL
  68
  69         DATA MAXTG  /15/
  70
  71 C----------------------------------------------------------------------
  72 C----------------------------------------------------------------------
  73
  74         IRET = -1
  75
  76 C       Get LUN from LUNIT.
  77
  78         CALL STATUS(LUNIT,LUN,IL,IM)
  79         IF (IL.EQ.0) RETURN
  80         IF (INODE(LUN).NE.INV(1,LUN)) RETURN
  81
  82 C       Get TAGPR from the (NTAGCH)th occurrence of TAGCH.
  83
  84         CALL PARSTR(TAGCH,TGS,MAXTG,NTG,' ',.TRUE.)
  85         IF (NTG.NE.1) RETURN
  86
  87         ITAGCT = 0
  88         DO N=1,NVAL(LUN)
  89             NOD = INV(N,LUN)
  90             IF(TGS(1).EQ.TAG(NOD)) THEN
  91                 ITAGCT = ITAGCT + 1
  92                 IF(ITAGCT.EQ.NTAGCH) THEN
  93                     TAGPR = TAG(JMPB(NOD))
  94                     IRET = 0
  95                     RETURN
  96                 ENDIF
  97             ENDIF
  98         ENDDO
  99
 100         RETURN
 101         END