var/external/bufr/rcstpl.f

   1       SUBROUTINE RCSTPL(LUN)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    RCSTPL
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL
   9 C   SUBSET ARRAYS IN COMMON BLOCKS /USRINT/ AND /USRBIT/.  THIS IS IN
  10 C   PREPARATION FOR THE ACTUAL UNPACKING OF THE SUBSET IN BUFR ARCHIVE
  11 C   LIBRARY SUBROUTINE RDTREE.
  12 C
  13 C PROGRAM HISTORY LOG:
  14 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  15 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  16 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  17 C                           ROUTINE "BORT"
  18 C 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
  19 C                           LINING CODE WITH FPP DIRECTIVES
  20 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  21 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  22 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  23 C                           BUFR FILES UNDER THE MPI)
  24 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  25 C                           10,000 TO 20,000 BYTES
  26 C 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
  27 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  28 C                           INTERDEPENDENCIES
  29 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  30 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  31 C                           VERIFICATION VERSION); MAXRCR (MAXIMUM
  32 C                           NUMBER OF RECURSION LEVELS) INCREASED FROM
  33 C                           50 TO 100  (WAS IN VERIFICATION VERSION);
  34 C                           UNIFIED/PORTABLE FOR WRF; ADDED
  35 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  36 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  37 C                           TERMINATES ABNORMALLY; COMMENTED OUT
  38 C                           HARDWIRE OF VTMP TO "BMISS" (10E10) WHEN IT
  39 C                           IS > 10E9 (CAUSED PROBLEMS ON SOME FOREIGN
  40 C                           MACHINES)
  41 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  42 C                           20,000 TO 50,000 BYTES
  43 C
  44 C USAGE:    CALL RCSTPL (LUN)
  45 C   INPUT ARGUMENT LIST:
  46 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  47 C
  48 C REMARKS:
  49 C    THIS ROUTINE CALLS:        BORT     UPBB
  50 C    THIS ROUTINE IS CALLED BY: RDTREE
  51 C                               Normally not called by any application
  52 C                               programs.
  53 C
  54 C ATTRIBUTES:
  55 C   LANGUAGE: FORTRAN 77
  56 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  57 C
  58 C$$$
  59
  60       INCLUDE 'bufrlib.prm'
  61
  62       PARAMETER (MAXRCR=100)
  63
  64       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  65      .                MBAY(MXMSGLD4,NFILES)
  66       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  67      .                INODE(NFILES),IDATE(NFILES)
  68       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  69      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  70      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  71      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  72      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  73       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  74       COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS)
  75       COMMON /USRTMP/ ITMP(MAXJL,MAXRCR),VTMP(MAXJL,MAXRCR)
  76
  77       CHARACTER*128 BORT_STR
  78       CHARACTER*10  TAG
  79       CHARACTER*3   TYP
  80       DIMENSION     NBMP(2,MAXRCR),NEWN(2,MAXRCR)
  81       DIMENSION     KNX(MAXRCR)
  82       REAL*8        VAL,VTMP
  83
  84 C-----------------------------------------------------------------------
  85 C-----------------------------------------------------------------------
  86
  87 C  SET THE INITIAL VALUES FOR THE TEMPLATE
  88 C  ---------------------------------------
  89
  90 c  .... Positional index of Table A mnem.
  91       INV(1,LUN) = INODE(LUN)
  92       VAL(1,LUN) = 0
  93       NBMP(1,1) = 1
  94       NBMP(2,1) = 1
  95       NODI = INODE(LUN)
  96       NODE = INODE(LUN)
  97       MBMP = 1
  98       KNVN = 1
  99       NR   = 0
 100
 101       DO I=1,MAXRCR
 102       KNX(I) = 0
 103       ENDDO
 104
 105 C  SET UP THE PARAMETERS FOR A LEVEL OF RECURSION
 106 C  ----------------------------------------------
 107
 108 10    CONTINUE
 109
 110       NR = NR+1
 111       IF(NR.GT.MAXRCR) GOTO 900
 112       NBMP(1,NR) = 1
 113       NBMP(2,NR) = MBMP
 114
 115       N1 = ISEQ(NODE,1)
 116       N2 = ISEQ(NODE,2)
 117       IF(N1.EQ.0         ) GOTO 901
 118       IF(N2-N1+1.GT.MAXJL) GOTO 902
 119       NEWN(1,NR) = 1
 120       NEWN(2,NR) = N2-N1+1
 121
 122       DO N=1,NEWN(2,NR)
 123       NN = JSEQ(N+N1-1)
 124       ITMP(N,NR) = NN
 125       VTMP(N,NR) = VALI(NN)
 126       ENDDO
 127
 128 C  STORE NODES AT SOME RECURSION LEVEL
 129 C  -----------------------------------
 130
 131 20    DO I=NBMP(1,NR),NBMP(2,NR)
 132       IF(KNX(NR).EQ.0000) KNX(NR) = KNVN
 133       IF(I.GT.NBMP(1,NR)) NEWN(1,NR) = 1
 134       DO J=NEWN(1,NR),NEWN(2,NR)
 135       KNVN = KNVN+1
 136       NODE = ITMP(J,NR)
 137 c  .... INV is positional index in internal jump/link table for packed
 138 c       subset element KNVN in MBAY
 139       INV(KNVN,LUN) = NODE
 140 c  .... Actual unpacked subset values (VAL) are initialized here
 141 c       (numbers as BMISS)
 142       VAL(KNVN,LUN) = VTMP(J,NR)
 143 c  .... MBIT is the bit in MBAY pointing to where the packed subset
 144 c       element KNVN begins
 145       MBIT(KNVN) = MBIT(KNVN-1)+NBIT(KNVN-1)
 146 c  .... NBIT is the number of bits in MBAY occupied by packed subset
 147 c       element KNVN
 148       NBIT(KNVN) = IBT(NODE)
 149       IF(ITP(NODE).EQ.1) THEN
 150          CALL UPBB(MBMP,NBIT(KNVN),MBIT(KNVN),MBAY(1,LUN))
 151          NEWN(1,NR) = J+1
 152          NBMP(1,NR) = I
 153          GOTO 10
 154       ENDIF
 155       ENDDO
 156       NEW = KNVN-KNX(NR)
 157       VAL(KNX(NR)+1,LUN) = VAL(KNX(NR)+1,LUN) + NEW
 158       KNX(NR) = 0
 159       ENDDO
 160
 161 C  CONTINUE AT ONE RECURSION LEVEL BACK
 162 C  ------------------------------------
 163
 164       IF(NR-1.NE.0) THEN
 165          NR = NR-1
 166          GOTO 20
 167       ENDIF
 168
 169 C  FINALLY STORE THE LENGTH OF (NUMBER OF ELEMENTS IN) SUBSET TEMPLATE
 170 C  -------------------------------------------------------------------
 171
 172       NVAL(LUN) = KNVN
 173
 174 C  EXITS
 175 C  -----
 176
 177       RETURN
 178 900   WRITE(BORT_STR,'("BUFRLIB: RCSTPL - THE NUMBER OF RECURSION '//
 179      . 'LEVELS EXCEEDS THE LIMIT (",I3,")")') MAXRCR
 180       CALL BORT(BORT_STR)
 181 901   WRITE(BORT_STR,'("BUFRLIB: RCSTPL - UNSET EXPANSION SEGMENT ",A)')
 182      . TAG(NODI)
 183       CALL BORT(BORT_STR)
 184 902   WRITE(BORT_STR,'("BUFRLIB: RCSTPL - TEMPLATE ARRAY OVERFLOW, '//
 185      . 'EXCEEDS THE LIMIT (",I6,") (",A,")")') MAXJL,TAG(NODI)
 186       CALL BORT(BORT_STR)
 187       END