var/external/bufr/ufbstp.f

   1       SUBROUTINE UFBSTP(LUNIO,USR,I1,I2,IRET,STR)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBSTP
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1999-11-18
   7 C
   8 C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM
   9 C   THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE
  10 C   DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF
  11 C   ABS(LUNIO) (I.E., IF ABS(LUNIO) POINTS TO A BUFR FILE THAT IS OPEN
  12 C   FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET;
  13 C   OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET).
  14 C   THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED
  15 C   STRINGS OF MNEMONICS WHICH ARE EITHER:
  16 C       1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE
  17 C                OR
  18 C       2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN
  19 C          OVERALL SUBSET DEFINITION
  20 C   SO IN THAT RESPECT IT IS VERY SIMILAR TO BUFR ARCHIVE LIBRARY
  21 C   SUBROUTINE UFBREP.  HOWEVER, THERE IS AN IMPORTANT DIFFERENCE IN
  22 C   HOW UFBSTP PROCESSES THE INPUT MNEMONIC STRING STR; FOR MORE DETAILS
  23 C   SEE THE EXAMPLE IN THE DOCBLOCK FOR SUBROUTINE UFBREP.
  24 C
  25 C PROGRAM HISTORY LOG:
  26 C 1999-11-18  J. WOOLLEN -- ORIGINAL AUTHOR
  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); UNIFIED/PORTABLE FOR
  32 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  33 C                           HISTORY) (INCOMPLETE); OUTPUTS MORE
  34 C                           COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  35 C                           TERMINATES ABNORMALLY OR UNUSUAL THINGS
  36 C                           HAPPEN; CHANGED CALL FROM BORT TO BORT2 IN
  37 C                           SOME CASES
  38 C 2004-08-18  J. ATOR    -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS
  39 C 2009-04-21  J. ATOR    -- USE ERRWRT
  40 C
  41 C USAGE:    CALL UFBSTP (LUNIO, USR, I1, I2, IRET, STR)
  42 C   INPUT ARGUMENT LIST:
  43 C     LUNIO    - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT
  44 C                NUMBER FOR BUFR FILE
  45 C                  - IF BUFR FILE OPEN FOR OUTPUT AND LUNIO IS LESS
  46 C                    THAN ZERO, UFBSTP TREATS THE BUFR FILE AS THOUGH
  47 C                    IT WERE OPEN FOR INPUT
  48 C     USR      - ONLY IF BUFR FILE OPEN FOR OUTPUT:
  49 C                   REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
  50 C                   WRITTEN TO DATA SUBSET
  51 C     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE
  52 C                NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER
  53 C                MUST BE AT LEAST AS LARGE AS LATTER)
  54 C     I2       - INTEGER:
  55 C                  - IF BUFR FILE OPEN FOR INPUT:  LENGTH OF SECOND
  56 C                    DIMENSION OF USR
  57 C                  - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS
  58 C                    OF DATA VALUES TO BE WRITTEN TO DATA SUBSET
  59 C     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
  60 C                MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST
  61 C                DIMENSION OF USR
  62 C                  - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE
  63 C                     "GENERIC" MNEMONICS NOT RELATED TO TABLE B,
  64 C                     THESE RETURN THE FOLLOWING INFORMATION IN
  65 C                     CORRESPONDING USR LOCATION:
  66 C                     'NUL'  WHICH ALWAYS RETURNS BMISS ("MISSING")
  67 C                     'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR
  68 C                            MESSAGE (RECORD) NUMBER IN WHICH THIS
  69 C                            SUBSET RESIDES
  70 C                     'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET
  71 C                            NUMBER OF THIS SUBSET WITHIN THE BUFR
  72 C                            MESSAGE (RECORD) NUMBER 'IREC'
  73 C
  74 C   OUTPUT ARGUMENT LIST:
  75 C     USR      - ONLY IF BUFR FILE OPEN FOR INPUT:
  76 C                   REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
  77 C                   READ FROM DATA SUBSET
  78 C     IRET     - INTEGER:
  79 C                  - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF
  80 C                    DATA VALUES READ FROM DATA SUBSET (MUST BE NO
  81 C                    LARGER THAN I2)
  82 C                  - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS"
  83 C                    OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE
  84 C                    SAME AS I2)
  85 C
  86 C REMARKS:
  87 C    THIS ROUTINE CALLS:        BORT     BORT2    ERRWRT   STATUS
  88 C                               STRING   UFBSP
  89 C    THIS ROUTINE IS CALLED BY: None
  90 C                               Normally called only by application
  91 C                               programs.
  92 C
  93 C ATTRIBUTES:
  94 C   LANGUAGE: FORTRAN 77
  95 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  96 C
  97 C$$$
  98
  99       INCLUDE 'bufrlib.prm'
 100
 101       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
 102      .                INODE(NFILES),IDATE(NFILES)
 103       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
 104       COMMON /QUIET / IPRT
 105
 106       CHARACTER*(*) STR
 107       CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR
 108       REAL*8        USR(I1,I2),VAL
 109
 110       DATA IFIRST1/0/,IFIRST2/0/
 111
 112       SAVE IFIRST1, IFIRST2
 113
 114 C----------------------------------------------------------------------
 115 C----------------------------------------------------------------------
 116
 117       IRET = 0
 118
 119 C  CHECK THE FILE STATUS AND I-NODE
 120 C  --------------------------------
 121
 122       LUNIT = ABS(LUNIO)
 123       CALL STATUS(LUNIT,LUN,IL,IM)
 124       IF(IL.EQ.0) GOTO 900
 125       IF(IM.EQ.0) GOTO 901
 126       IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902
 127
 128       IO = MIN(MAX(0,IL),1)
 129       IF(LUNIO.NE.LUNIT) IO = 0
 130
 131       IF(I1.LE.0) THEN
 132          IF(IPRT.GE.0) THEN
 133       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 134       ERRSTR = 'BUFRLIB: UFBSTP - 3rd ARG. (INPUT) IS .LE. 0, ' //
 135      .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
 136       CALL ERRWRT(ERRSTR)
 137       CALL ERRWRT(STR)
 138       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 139       CALL ERRWRT(' ')
 140          ENDIF
 141          GOTO 100
 142       ELSEIF(I2.LE.0) THEN
 143          IF(IPRT.EQ.-1)  IFIRST1 = 1
 144          IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1)  THEN
 145       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 146       ERRSTR = 'BUFRLIB: UFBSTP - 4th ARG. (INPUT) IS .LE. 0, ' //
 147      .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
 148       CALL ERRWRT(ERRSTR)
 149       CALL ERRWRT(STR)
 150             IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN
 151       ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
 152      .   'message is printed, there may be more.  To output all ' //
 153      .   'such messages,'
 154       CALL ERRWRT(ERRSTR)
 155       ERRSTR = 'modify your application program to add ' //
 156      .   '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
 157      .   'to a BUFRLIB routine.'
 158       CALL ERRWRT(ERRSTR)
 159             ENDIF
 160       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 161       CALL ERRWRT(' ')
 162             IFIRST1 = 1
 163          ENDIF
 164          GOTO 100
 165       ENDIF
 166
 167 C  INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION
 168 C  --------------------------------------------------
 169
 170       IF(IO.EQ.0) THEN
 171          DO J=1,I2
 172          DO I=1,I1
 173          USR(I,J) = BMISS
 174          ENDDO
 175          ENDDO
 176       ENDIF
 177
 178 C  PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES
 179 C  ----------------------------------------------------
 180
 181       CALL STRING(STR,LUN,I1,IO)
 182
 183 C  CALL THE MNEMONIC READER/WRITER
 184 C  -------------------------------
 185
 186       CALL UFBSP(LUN,USR,I1,I2,IO,IRET)
 187
 188       IF(IO.EQ.1 .AND. IRET.NE.I2) GOTO 903
 189
 190       IF(IRET.EQ.0)  THEN
 191          IF(IO.EQ.0) THEN
 192             IF(IPRT.GE.1)  THEN
 193       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 194       ERRSTR = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES READ IN, ' //
 195      .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
 196       CALL ERRWRT(ERRSTR)
 197       CALL ERRWRT(STR)
 198       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 199       CALL ERRWRT(' ')
 200             ENDIF
 201          ELSE
 202             IF(IPRT.EQ.-1)  IFIRST2 = 1
 203             IF(IFIRST2.EQ.0 .OR. IPRT.GE.1)  THEN
 204       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 205       ERRSTR = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES WRITTEN OUT, ' //
 206      .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
 207       CALL ERRWRT(ERRSTR)
 208       CALL ERRWRT(STR)
 209       CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)')
 210                IF(IPRT.EQ.0) THEN
 211       ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
 212      .   'message is printed, there may be more.  To output all ' //
 213      .   'such messages,'
 214       CALL ERRWRT(ERRSTR)
 215       ERRSTR = 'modify your application program to add ' //
 216      .   '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
 217      .   'to a BUFRLIB routine.'
 218       CALL ERRWRT(ERRSTR)
 219                ENDIF
 220       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 221       CALL ERRWRT(' ')
 222                IFIRST2 = 1
 223             ENDIF
 224          ENDIF
 225       ENDIF
 226
 227 C  EXITS
 228 C  -----
 229
 230 100   RETURN
 231 900   CALL BORT('BUFRLIB: UFBSTP - BUFR FILE IS CLOSED, IT MUST BE'//
 232      . ' OPEN')
 233 901   CALL BORT('BUFRLIB: UFBSTP - A MESSAGE MUST BE OPEN IN BUFR '//
 234      . 'FILE, NONE ARE')
 235 902   CALL BORT('BUFRLIB: UFBSTP - LOCATION OF INTERNAL TABLE FOR '//
 236      . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '//
 237      . 'SUBSET ARRAY')
 238 903   WRITE(BORT_STR1,'("BUFRLIB: UFBSTP - MNEMONIC STRING READ IN IS'//
 239      . ': ",A)') STR
 240       WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '//
 241      . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'//
 242      . ' - INCOMPLETE WRITE")')  IRET,I2
 243       CALL BORT2(BORT_STR1,BORT_STR2)
 244       END