var/external/bufr/ufbcup.f

   1       SUBROUTINE UFBCUP(LUBIN,LUBOT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBCUP
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE MAKES ONE COPY OF EACH UNIQUE ELEMENT IN AN
   9 C   INPUT SUBSET BUFFER INTO THE IDENTICAL MNEMONIC SLOT IN THE OUTPUT
  10 C   SUBSET BUFFER.
  11 C
  12 C PROGRAM HISTORY LOG:
  13 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  14 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  15 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  16 C                           ROUTINE "BORT"
  17 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  18 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  19 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  20 C                           BUFR FILES UNDER THE MPI)
  21 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  22 C                           INTERDEPENDENCIES
  23 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  24 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  25 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  26 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  27 C                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
  28 C                           INFO WHEN ROUTINE TERMINATES ABNORMALLY
  29 C
  30 C USAGE:    CALL UFBCUP (LUBIN, LUBOT)
  31 C   INPUT ARGUMENT LIST:
  32 C     LUBIN    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR
  33 C                FILE
  34 C     LUBOT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR
  35 C                FILE
  36 C
  37 C REMARKS:
  38 C    THIS ROUTINE CALLS:        BORT     STATUS
  39 C    THIS ROUTINE IS CALLED BY: None
  40 C                               Normally called only by application
  41 C                               programs.
  42 C
  43 C ATTRIBUTES:
  44 C   LANGUAGE: FORTRAN 77
  45 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  46 C
  47 C$$$
  48
  49       INCLUDE 'bufrlib.prm'
  50
  51       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  52      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  53      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  54      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  55      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  56
  57       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  58      .                INODE(NFILES),IDATE(NFILES)
  59       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  60
  61       CHARACTER*10 TAG,TAGI(MAXJL),TAGO
  62       CHARACTER*3  TYP
  63       DIMENSION    NINI(MAXJL)
  64       REAL*8       VAL
  65
  66 C----------------------------------------------------------------------
  67 C----------------------------------------------------------------------
  68
  69 C  CHECK THE FILE STATUSES AND I-NODE
  70 C  ----------------------------------
  71
  72       CALL STATUS(LUBIN,LUI,IL,IM)
  73       IF(IL.EQ.0) GOTO 900
  74       IF(IL.GT.0) GOTO 901
  75       IF(IM.EQ.0) GOTO 902
  76       IF(INODE(LUI).NE.INV(1,LUI)) GOTO 903
  77
  78       CALL STATUS(LUBOT,LUO,IL,IM)
  79       IF(IL.EQ.0) GOTO 904
  80       IF(IL.LT.0) GOTO 905
  81       IF(IM.EQ.0) GOTO 906
  82
  83 C  MAKE A LIST OF UNIQUE TAGS IN INPUT BUFFER
  84 C  ------------------------------------------
  85
  86       NTAG = 0
  87
  88       DO 5 NI=1,NVAL(LUI)
  89       NIN = INV(NI,LUI)
  90       IF(ITP(NIN).GE.2) THEN
  91          DO NV=1,NTAG
  92          IF(TAGI(NV).EQ.TAG(NIN)) GOTO 5
  93          ENDDO
  94          NTAG = NTAG+1
  95          NINI(NTAG) = NI
  96          TAGI(NTAG) = TAG(NIN)
  97       ENDIF
  98 5     ENDDO
  99
 100       IF(NTAG.EQ.0) GOTO 907
 101
 102 C  GIVEN A LIST MAKE ONE COPY OF COMMON ELEMENTS TO OUTPUT BUFFER
 103 C  --------------------------------------------------------------
 104
 105       DO 10 NV=1,NTAG
 106       NI = NINI(NV)
 107       DO NO=1,NVAL(LUO)
 108       TAGO = TAG(INV(NO,LUO))
 109       IF(TAGI(NV).EQ.TAGO) THEN
 110          VAL(NO,LUO) = VAL(NI,LUI)
 111          GOTO 10
 112       ENDIF
 113       ENDDO
 114 10    ENDDO
 115
 116 C  EXITS
 117 C  -----
 118
 119       RETURN
 120 900   CALL BORT('BUFRLIB: UFBCUP - INPUT BUFR FILE IS CLOSED, IT '//
 121      . 'MUST BE OPEN FOR INPUT')
 122 901   CALL BORT('BUFRLIB: UFBCUP - INPUT BUFR FILE IS OPEN FOR '//
 123      . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
 124 902   CALL BORT('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN INPUT '//
 125      . 'BUFR FILE, NONE ARE')
 126 903   CALL BORT('BUFRLIB: UFBCUP - LOCATION OF INTERNAL TABLE FOR '//
 127      . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
 128      . 'INTERNAL SUBSET ARRAY')
 129 904   CALL BORT('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS CLOSED, IT '//
 130      . 'MUST BE OPEN FOR OUTPUT')
 131 905   CALL BORT('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS OPEN FOR '//
 132      . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
 133 906   CALL BORT('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN OUTPUT '//
 134      . 'BUFR FILE, NONE ARE')
 135 907   CALL BORT('BUFRLIB: UFBCUP - THERE ARE NO ELEMENTS (TAGS) IN '//
 136      . 'INPUT SUBSET BUFFER')
 137       END