SUBROUTINE USRTPL(LUN,INVN,NBMP) 24,27
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: USRTPL
C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL
C SUBSET ARRAYS IN COMMON BLOCK /USRINT/ FOR CASES OF NODE EXPANSION
C (I.E. WHEN THE NODE IS EITHER A TABLE A MNEMONIC OR A DELAYED
C REPLICATION FACTOR).
C
C PROGRAM HISTORY LOG:
C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C ROUTINE "BORT"
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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
C INTERDEPENDENCIES
C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C INCREASED FROM 15000 TO 16000 (WAS IN
C VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C WRF; ADDED DOCUMENTATION (INCLUDING
C HISTORY) (INCOMPLETE); OUTPUTS MORE
C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C TERMINATES ABNORMALLY OR UNUSUAL THINGS
C HAPPEN; COMMENTED OUT HARDWIRE OF VTMP TO
C "BMISS" (10E10) WHEN IT IS > 10E9 (CAUSED
C PROBLEMS ON SOME FOREIGN MACHINES)
C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION
C 2009-04-21 J. ATOR -- USE ERRWRT
C
C USAGE: CALL USRTPL
(LUN, INVN, NBMP)
C INPUT ARGUMENT LIST:
C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C INVN - INTEGER: STARTING JUMP/LINK TABLE INDEX OF THE NODE
C TO BE EXPANDED WITHIN THE SUBSET TEMPLATE
C NBMP - INTEGER: NUMBER OF TIMES BY WHICH INVN IS TO BE
C EXPANDED (I.E. NUMBER OF REPLICATIONS OF NODE)
C
C REMARKS:
C THIS ROUTINE CALLS: BORT ERRWRT
C THIS ROUTINE IS CALLED BY: DRFINI DRSTPL MSGUPD OPENMB
C OPENMG RDCMPS TRYBUMP UFBGET
C UFBTAB UFBTAM WRCMPS WRITLC
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 /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
. INODE(NFILES),IDATE(NFILES)
COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
. JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
. IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
. ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
. ISEQ(MAXJL,2),JSEQ(MAXJL)
COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
COMMON /QUIET / IPRT
CHARACTER*128 BORT_STR,ERRSTR
CHARACTER*10 TAG
CHARACTER*3 TYP
DIMENSION ITMP(MAXJL)
LOGICAL DRP,DRS,DRB,DRX
REAL*8 VAL,VTMP(MAXJL)
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
IF(IPRT.GE.2) THEN
CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,I5,A,I5,A,A10)' )
. 'BUFRLIB: USRTPL - LUN:INVN:NBMP:TAG(INODE(LUN)) = ',
. LUN, ':', INVN, ':', NBMP, ':', TAG(INODE(LUN))
CALL ERRWRT(ERRSTR)
CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
CALL ERRWRT(' ')
ENDIF
IF(NBMP.LE.0) THEN
IF(IPRT.GE.1) THEN
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
CALL ERRWRT('BUFRLIB: USRTPL - NBMP .LE. 0 - IMMEDIATE RETURN')
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
CALL ERRWRT(' ')
ENDIF
GOTO 100
ENDIF
DRP = .FALSE.
DRS = .FALSE.
DRX = .FALSE.
C SET UP A NODE EXPANSION
C -----------------------
IF(INVN.EQ.1) THEN
c .... case where node is a Table A mnemonic (nodi is positional index)
NODI = INODE(LUN)
INV(1,LUN) = NODI
NVAL(LUN) = 1
IF(NBMP.NE.1) GOTO 900
ELSEIF(INVN.GT.0 .AND. INVN.LE.NVAL(LUN)) THEN
c .... case where node is (hopefully) a delayed replication factor
NODI = INV(INVN,LUN)
DRP = TYP(NODI) .EQ. 'DRP'
DRS = TYP(NODI) .EQ. 'DRS'
DRB = TYP(NODI) .EQ. 'DRB'
DRX = DRP .OR. DRS .OR. DRB
IVAL = VAL(INVN,LUN)
JVAL = 2**IBT(NODI)-1
VAL(INVN,LUN) = IVAL+NBMP
IF(DRB.AND.NBMP.NE.1) GOTO 901
IF(.NOT.DRX ) GOTO 902
IF(IVAL.LT.0. ) GOTO 903
IF(IVAL+NBMP.GT.JVAL) GOTO 904
ELSE
GOTO 905
ENDIF
C RECALL A PRE-FAB NODE EXPANSION SEGMENT
C ---------------------------------------
NEWN = 0
N1 = ISEQ(NODI,1)
N2 = ISEQ(NODI,2)
IF(N1.EQ.0 ) GOTO 906
IF(N2-N1+1.GT.MAXJL) GOTO 907
DO N=N1,N2
NEWN = NEWN+1
ITMP(NEWN) = JSEQ(N)
VTMP(NEWN) = VALI(JSEQ(N))
ENDDO
C MOVE OLD NODES - STORE NEW ONES
C -------------------------------
IF(NVAL(LUN)+NEWN*NBMP.GT.MAXSS) GOTO 908
DO J=NVAL(LUN),INVN+1,-1
INV(J+NEWN*NBMP,LUN) = INV(J,LUN)
VAL(J+NEWN*NBMP,LUN) = VAL(J,LUN)
ENDDO
IF(DRP.OR.DRS) VTMP(1) = NEWN
KNVN = INVN
DO I=1,NBMP
DO J=1,NEWN
KNVN = KNVN+1
INV(KNVN,LUN) = ITMP(J)
VAL(KNVN,LUN) = VTMP(J)
ENDDO
ENDDO
C RESET POINTERS AND COUNTERS
C ---------------------------
NVAL(LUN) = NVAL(LUN) + NEWN*NBMP
IF(IPRT.GE.2) THEN
CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
WRITE ( UNIT=ERRSTR, FMT='(A,A,A10,3(A,I5))' )
. 'BUFRLIB: USRTPL - TAG(INV(INVN,LUN)):NEWN:NBMP:',
. 'NVAL(LUN) = ', TAG(INV(INVN,LUN)), ':', NEWN, ':',
. NBMP, ':', NVAL(LUN)
CALL ERRWRT(ERRSTR)
DO I=1,NEWN
WRITE ( UNIT=ERRSTR, FMT='(2(A,I5),A,A10)' )
. 'For I = ', I, ', ITMP(I) = ', ITMP(I),
. ', TAG(ITMP(I)) = ', TAG(ITMP(I))
CALL ERRWRT(ERRSTR)
ENDDO
CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
CALL ERRWRT(' ')
ENDIF
IF(DRX) THEN
NODE = NODI
INVR = INVN
4 NODE = JMPB(NODE)
IF(NODE.GT.0) THEN
IF(ITP(NODE).EQ.0) THEN
DO INVR=INVR-1,1,-1
IF(INV(INVR,LUN).EQ.NODE) THEN
VAL(INVR,LUN) = VAL(INVR,LUN)+NEWN*NBMP
GOTO 4
ENDIF
ENDDO
GOTO 909
ELSE
GOTO 4
ENDIF
ENDIF
ENDIF
C EXITS
C -----
100 RETURN
900 WRITE(BORT_STR,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'//
. 'I4,", MUST BE 1 WHEN SECOND ARGUMENT (INPUT) IS 1 (SUBSET '//
. 'NODE) (",A,")")') NBMP,TAG(NODI)
CALL BORT(BORT_STR)
901 WRITE(BORT_STR,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'//
. 'I4,", MUST BE 1 WHEN NODE IS DRB (1-BIT DELAYED REPL. FACTOR)'//
. ' (",A,")")') NBMP,TAG(NODI)
CALL BORT(BORT_STR)
902 WRITE(BORT_STR,'("BUFRLIB: USRTPL - NODE IS OF TYPE ",A," - IT '//
. 'MUST BE EITHER A SUBSET OR DELAYED REPL. FACTOR (",A,")")')
. TYP(NODI),TAG(NODI)
CALL BORT(BORT_STR)
903 WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR IS '//
. 'NEGATIVE (=",I5,") (",A,")")') IVAL,TAG(NODI)
CALL BORT(BORT_STR)
904 WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR OVERFLOW'//
. ' (EXCEEDS MAXIMUM OF",I6," (",A,")")') JVAL,TAG(NODI)
CALL BORT(BORT_STR)
905 WRITE(BORT_STR,'("BUFRLIB: USRTPL - INVENTORY INDEX {FIRST '//
. 'ARGUMENT (INPUT)} OUT OF BOUNDS (=",I5,", RANGE IS 1 TO",I6,"'//
. ') (",A,")")') INVN,NVAL(LUN),TAG(NODI)
CALL BORT(BORT_STR)
906 WRITE(BORT_STR,'("BUFRLIB: USRTPL - UNSET EXPANSION SEGMENT (",'//
. 'A,")")') TAG(NODI)
CALL BORT(BORT_STR)
907 WRITE(BORT_STR,'("BUFRLIB: USRTPL - TEMPLATE ARRAY OVERFLOW, '//
. 'EXCEEDS THE LIMIT (",I6,") (",A,")")') MAXJL,TAG(NODI)
CALL BORT(BORT_STR)
908 WRITE(BORT_STR,'("BUFRLIB: USRTPL - INVENTORY OVERFLOW (",I6,")'//
. ', EXCEEDS THE LIMIT (",I6,") (",A,")")')
. NVAL(LUN)+NEWN*NBMP,MAXSS,TAG(NODI)
CALL BORT(BORT_STR)
909 WRITE(BORT_STR,'("BUFRLIB: USRTPL - BAD BACKUP STRATEGY (",A,'//
. '")")') TAG(NODI)
CALL BORT(BORT_STR)
END