wrfv2_fire/var/external/bufr/rcstpl.inc

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