<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
<A NAME='PKTDD'><A href='../../html_code/bufr/pktdd.f.html#PKTDD' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE PKTDD(ID,LUN,IDN,IRET) 7,9
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: PKTDD
C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE STORES INFORMATION ABOUT A "CHILD"
C MNEMONIC WITHIN THE INTERNAL BUFR TABLE D ENTRY (IN COMMON BLOCK
C /TABABD/) FOR A TABLE D SEQUENCE ("PARENT") MNEMONIC WHEN THE
C "CHILD" MNEMONIC IS CONTAINED WITHIN THE SEQUENCE REPRESENTED BY
C THE "PARENT" MNEMONIC (AS DETERMINED WITHIN BUFR ARCHIVE LIBRARY
C SUBROUTINE SEQSDX).
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 J. ATOR -- ADDED DOCUMENTATION
C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
C INTERDEPENDENCIES
C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
C DOCUMENTATION; ADDED MORE COMPLETE
C DIAGNOSTIC INFO WHEN UNUSUAL THINGS HAPPEN
C 2009-04-21 J. ATOR -- USE ERRWRT
C
C USAGE: CALL PKTDD
(ID, LUN, IDN, IRET)
C INPUT ARGUMENT LIST:
C ID - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN
C INTERNAL BUFR TABLE D ARRAY TABD(*,*)
C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE
C CORRESPONDING TO CHILD MNEMONIC
C 0 = delete all information about all child
C mnemonics from within TABD(ID,LUN)
C
C OUTPUT ARGUMENT LIST:
C IRET - INTEGER: TOTAL NUMBER OF CHILD MNEMONICS STORED THUS
C FAR (INCLUDING IDN) FOR THE PARENT MNEMONIC GIVEN BY
C TABD(ID,LUN)
C 0 = information was cleared from TABD(ID,LUN)
C because input IDN value was 0
C -1 = bad counter value or maximum number of
C child mnemonics already stored for this
C parent mnemonic
C
C REMARKS:
C THIS ROUTINE CALLS: ERRWRT IPKM IUPM
C THIS ROUTINE IS CALLED BY: DXINIT SEQSDX STBFDX STSEQ
C Normally not called by any application
C programs.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
INCLUDE 'bufrlib.prm'
COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
. MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
. IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
. TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
. TABD(MAXTBD,NFILES)
COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10),
. LD30(10),DXSTR(10)
COMMON /QUIET / IPRT
CHARACTER*600 TABD
CHARACTER*128 TABB
CHARACTER*128 TABA
CHARACTER*128 ERRSTR
CHARACTER*56 DXSTR
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
LDD = LDXD(IDXV+1)+1
C LDD points to the byte within TABD(ID,LUN) which contains (in
C packed integer format) a count of the number of child mnemonics
C stored thus far for this parent mnemonic.
C ZERO THE COUNTER IF IDN IS ZERO
C -------------------------------
IF(IDN.EQ.0) THEN
CALL IPKM(TABD(ID,LUN)(LDD:LDD),1,0)
IRET = 0
GOTO 100
ENDIF
C UPDATE THE STORED DESCRIPTOR COUNT FOR THIS TABLE D ENTRY
C ---------------------------------------------------------
ND = IUPM(TABD(ID,LUN)(LDD:LDD),8)
C ND is the (unpacked) count of the number of child mnemonics
C stored thus far for this parent mnemonic.
IF(ND.LT.0 .OR. ND.EQ.MAXCD) THEN
IF(IPRT.GE.0) THEN
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
IF(ND.LT.0) THEN
WRITE ( UNIT=ERRSTR, FMT='(A,I4,A)' )
. 'BUFRLIB: PKTDD - BAD COUNTER VALUE (=', ND,
. ') - RETURN WITH IRET = -1'
ELSE
WRITE ( UNIT=ERRSTR, FMT='(A,I4,A,A)' )
. 'BUFRLIB: PKTDD - MAXIMUM NUMBER OF CHILD MNEMONICS (=',
. MAXCD, ') ALREADY STORED FOR THIS PARENT - RETURN WITH ',
. 'IRET = -1'
ENDIF
CALL ERRWRT(ERRSTR)
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
CALL ERRWRT(' ')
ENDIF
IRET = -1
GOTO 100
ELSE
ND = ND+1
CALL IPKM(TABD(ID,LUN)(LDD:LDD),1,ND)
IRET = ND
ENDIF
C PACK AND STORE THE DESCRIPTOR
C -----------------------------
IDM = LDD+1 + (ND-1)*2
C IDM points to the starting byte within TABD(ID,LUN) at which
C the IDN value for this child mnemonic will be stored (as a
C packed integer of width = 2 bytes).
CALL IPKM(TABD(ID,LUN)(IDM:IDM),2,IDN)
C EXIT
C ----
100 RETURN
END