var/external/bufr/pktdd.f

   1       SUBROUTINE PKTDD(ID,LUN,IDN,IRET)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    PKTDD
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE STORES INFORMATION ABOUT A "CHILD"
   9 C   MNEMONIC WITHIN THE INTERNAL BUFR TABLE D ENTRY (IN COMMON BLOCK
  10 C   /TABABD/) FOR A TABLE D SEQUENCE ("PARENT") MNEMONIC WHEN THE
  11 C   "CHILD" MNEMONIC IS CONTAINED WITHIN THE SEQUENCE REPRESENTED BY
  12 C   THE "PARENT" MNEMONIC (AS DETERMINED WITHIN BUFR ARCHIVE LIBRARY
  13 C   SUBROUTINE SEQSDX).
  14 C
  15 C PROGRAM HISTORY LOG:
  16 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  17 C 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
  18 C                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
  19 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  20 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  21 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  22 C                           BUFR FILES UNDER THE MPI)
  23 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  24 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  25 C                           INTERDEPENDENCIES
  26 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
  27 C                           DOCUMENTATION; ADDED MORE COMPLETE
  28 C                           DIAGNOSTIC INFO WHEN UNUSUAL THINGS HAPPEN
  29 C 2009-04-21  J. ATOR    -- USE ERRWRT
  30 C
  31 C USAGE:    CALL PKTDD (ID, LUN, IDN, IRET)
  32 C   INPUT ARGUMENT LIST:
  33 C     ID       - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN
  34 C                INTERNAL BUFR TABLE D ARRAY TABD(*,*)
  35 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  36 C     IDN      - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE
  37 C                CORRESPONDING TO CHILD MNEMONIC
  38 C                       0 = delete all information about all child
  39 C                           mnemonics from within TABD(ID,LUN)
  40 C
  41 C   OUTPUT ARGUMENT LIST:
  42 C     IRET     - INTEGER: TOTAL NUMBER OF CHILD MNEMONICS STORED THUS
  43 C                FAR (INCLUDING IDN) FOR THE PARENT MNEMONIC GIVEN BY
  44 C                TABD(ID,LUN)
  45 C                       0 = information was cleared from TABD(ID,LUN)
  46 C                           because input IDN value was 0
  47 C                      -1 = bad counter value or maximum number of
  48 C                           child mnemonics already stored for this
  49 C                           parent mnemonic
  50 C
  51 C REMARKS:
  52 C    THIS ROUTINE CALLS:        ERRWRT   IPKM     IUPM
  53 C    THIS ROUTINE IS CALLED BY: DXINIT   SEQSDX   STBFDX   STSEQ
  54 C                               Normally not called by any application
  55 C                               programs.
  56 C
  57 C ATTRIBUTES:
  58 C   LANGUAGE: FORTRAN 77
  59 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  60 C
  61 C$$$
  62
  63       INCLUDE 'bufrlib.prm'
  64
  65       COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
  66      .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
  67      .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
  68      .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
  69      .                TABD(MAXTBD,NFILES)
  70       COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10),
  71      .                LD30(10),DXSTR(10)
  72       COMMON /QUIET / IPRT
  73
  74       CHARACTER*600 TABD
  75       CHARACTER*128 TABB
  76       CHARACTER*128 TABA
  77       CHARACTER*128 ERRSTR
  78       CHARACTER*56  DXSTR
  79
  80 C-----------------------------------------------------------------------
  81 C-----------------------------------------------------------------------
  82
  83       LDD = LDXD(IDXV+1)+1
  84
  85 C     LDD points to the byte within TABD(ID,LUN) which contains (in
  86 C     packed integer format) a count of the number of child mnemonics
  87 C     stored thus far for this parent mnemonic.
  88
  89 C  ZERO THE COUNTER IF IDN IS ZERO
  90 C  -------------------------------
  91
  92       IF(IDN.EQ.0) THEN
  93          CALL IPKM(TABD(ID,LUN)(LDD:LDD),1,0)
  94          IRET = 0
  95          GOTO 100
  96       ENDIF
  97
  98 C  UPDATE THE STORED DESCRIPTOR COUNT FOR THIS TABLE D ENTRY
  99 C  ---------------------------------------------------------
 100
 101       ND = IUPM(TABD(ID,LUN)(LDD:LDD),8)
 102
 103 C     ND is the (unpacked) count of the number of child mnemonics
 104 C     stored thus far for this parent mnemonic.
 105
 106       IF(ND.LT.0 .OR. ND.EQ.MAXCD) THEN
 107       IF(IPRT.GE.0) THEN
 108       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 109          IF(ND.LT.0) THEN
 110             WRITE ( UNIT=ERRSTR, FMT='(A,I4,A)' )
 111      .        'BUFRLIB: PKTDD - BAD COUNTER VALUE (=', ND,
 112      .        ') - RETURN WITH IRET = -1'
 113          ELSE
 114             WRITE ( UNIT=ERRSTR, FMT='(A,I4,A,A)' )
 115      .        'BUFRLIB: PKTDD - MAXIMUM NUMBER OF CHILD MNEMONICS (=',
 116      .        MAXCD, ') ALREADY STORED FOR THIS PARENT - RETURN WITH ',
 117      .        'IRET = -1'
 118          ENDIF
 119       CALL ERRWRT(ERRSTR)
 120       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 121       CALL ERRWRT(' ')
 122       ENDIF
 123          IRET = -1
 124          GOTO 100
 125       ELSE
 126          ND = ND+1
 127          CALL IPKM(TABD(ID,LUN)(LDD:LDD),1,ND)
 128          IRET = ND
 129       ENDIF
 130
 131 C  PACK AND STORE THE DESCRIPTOR
 132 C  -----------------------------
 133
 134       IDM = LDD+1 + (ND-1)*2
 135
 136 C     IDM points to the starting byte within TABD(ID,LUN) at which
 137 C     the IDN value for this child mnemonic will be stored (as a
 138 C     packed integer of width = 2 bytes).
 139
 140       CALL IPKM(TABD(ID,LUN)(IDM:IDM),2,IDN)
 141
 142 C  EXIT
 143 C  ----
 144
 145 100   RETURN
 146       END