var/external/bufr/ufbovr.f

   1       SUBROUTINE UFBOVR(LUNIT,USR,I1,I2,IRET,STR)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBOVR
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE WRITES OVER SPECIFIED VALUES WHICH EXIST
   9 C   IN CURRENT INTERNAL BUFR SUBSET ARRAYS IN A FILE OPEN FOR OUTPUT.
  10 C   THE DATA VALUES CORRESPOND TO MNEMONICS WHICH ARE PART OF A
  11 C   DELAYED-REPLICATION SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION
  12 C   AT ALL.  EITHER BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR OPENMB
  13 C   MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A BUFR
  14 C   MESSAGE WITHIN MEMORY FOR THIS LUNIT.  IN ADDITION, BUFR ARCHIVE
  15 C   LIBRARY SUBROUTINE WRITSB OR INVMRG MUST HAVE BEEN CALLED TO STORE
  16 C   DATA IN THE INTERNAL OUTPUT SUBSET ARRAYS.
  17 C
  18 C PROGRAM HISTORY LOG:
  19 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  20 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  21 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  22 C                           ROUTINE "BORT"
  23 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  24 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  25 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  26 C                           BUFR FILES UNDER THE MPI)
  27 C 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
  28 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  29 C                           INTERDEPENDENCIES
  30 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  31 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  32 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  33 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  34 C                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
  35 C                           INFO WHEN ROUTINE TERMINATES ABNORMALLY OR
  36 C                           UNUSUAL THINGS HAPPEN; CHANGED CALL FROM
  37 C                           BORT TO BORT2 IN 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 UFBOVR (LUNIT, USR, I1, I2, IRET, STR)
  42 C   INPUT ARGUMENT LIST:
  43 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  44 C     USR      - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
  45 C                WRITTEN TO DATA SUBSET
  46 C     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE
  47 C                NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER
  48 C                MUST BE AT LEAST AS LARGE AS LATTER)
  49 C     I2       - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES TO BE
  50 C                WRITTEN TO DATA SUBSET
  51 C     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
  52 C                MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST
  53 C                DIMENSION OF USR
  54 C
  55 C   OUTPUT ARGUMENT LIST:
  56 C     IRET     - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES WRITTEN TO
  57 C                DATA SUBSET (SHOULD BE SAME AS I2)
  58 C
  59 C REMARKS:
  60 C    THIS ROUTINE CALLS:        BORT     BORT2    ERRWRT   STATUS
  61 C                               STRING   TRYBUMP
  62 C    THIS ROUTINE IS CALLED BY: None
  63 C                               Normally called only by application
  64 C                               programs.
  65 C
  66 C ATTRIBUTES:
  67 C   LANGUAGE: FORTRAN 77
  68 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  69 C
  70 C$$$
  71
  72       INCLUDE 'bufrlib.prm'
  73
  74       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  75      .                INODE(NFILES),IDATE(NFILES)
  76       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  77
  78       CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR
  79       CHARACTER*(*) STR
  80       REAL*8        USR(I1,I2),VAL
  81
  82       DATA IFIRST1/0/,IFIRST2/0/
  83
  84       SAVE IFIRST1, IFIRST2
  85
  86 C----------------------------------------------------------------------
  87 C----------------------------------------------------------------------
  88
  89       IRET = 0
  90
  91 C  CHECK THE FILE STATUS AND I-NODE
  92 C  --------------------------------
  93
  94       CALL STATUS(LUNIT,LUN,IL,IM)
  95       IF(IL.EQ.0) GOTO 900
  96       IF(IL.LT.0) GOTO 901
  97       IF(IM.EQ.0) GOTO 902
  98       IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903
  99
 100 C  .... DK: Why check, isn't IO always 1 here?
 101       IO = MIN(MAX(0,IL),1)
 102
 103       IF(I1.LE.0) THEN
 104          IF(IPRT.GE.0) THEN
 105       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 106       ERRSTR = 'BUFRLIB: UFBOVR - 3rd ARG. (INPUT) IS .LE. 0, ' //
 107      .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
 108       CALL ERRWRT(ERRSTR)
 109       CALL ERRWRT(STR)
 110       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 111       CALL ERRWRT(' ')
 112          ENDIF
 113          GOTO 100
 114       ELSEIF(I2.LE.0) THEN
 115          IF(IPRT.EQ.-1)  IFIRST1 = 1
 116          IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1)  THEN
 117       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 118       ERRSTR = 'BUFRLIB: UFBOVR - 4th ARG. (INPUT) IS .LE. 0, ' //
 119      .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
 120       CALL ERRWRT(ERRSTR)
 121       CALL ERRWRT(STR)
 122             IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN
 123       ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
 124      .   'message is printed, there may be more.  To output all ' //
 125      .   'such messages,'
 126       CALL ERRWRT(ERRSTR)
 127       ERRSTR = 'modify your application program to add ' //
 128      .   '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
 129      .   'to a BUFRLIB routine.'
 130       CALL ERRWRT(ERRSTR)
 131             ENDIF
 132       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 133       CALL ERRWRT(' ')
 134             IFIRST1 = 1
 135          ENDIF
 136          GOTO 100
 137       ENDIF
 138
 139 C  PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES
 140 C  ----------------------------------------------------
 141
 142       CALL STRING(STR,LUN,I1,IO)
 143       CALL TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET)
 144
 145       IF(IO.EQ.1 .AND. IRET.NE.I2) GOTO 904
 146
 147       IF(IRET.EQ.0)  THEN
 148          IF(IPRT.EQ.-1)  IFIRST2 = 1
 149          IF(IFIRST2.EQ.0 .OR. IPRT.GE.1)  THEN
 150       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 151       ERRSTR = 'BUFRLIB: UFBOVR - NO SPECIFIED VALUES WRITTEN OUT, ' //
 152      .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
 153       CALL ERRWRT(ERRSTR)
 154       CALL ERRWRT(STR)
 155       CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)')
 156                IF(IPRT.EQ.0) THEN
 157       ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
 158      .   'message is printed, there may be more.  To output all ' //
 159      .   'such messages,'
 160       CALL ERRWRT(ERRSTR)
 161       ERRSTR = 'modify your application program to add ' //
 162      .   '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
 163      .   'to a BUFRLIB routine.'
 164       CALL ERRWRT(ERRSTR)
 165                ENDIF
 166       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 167       CALL ERRWRT(' ')
 168             IFIRST2 = 1
 169          ENDIF
 170       ENDIF
 171
 172 C  EXITS
 173 C  -----
 174
 175 100   RETURN
 176 900   CALL BORT('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT '//
 177      . 'MUST BE OPEN FOR OUTPUT')
 178 901   CALL BORT('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR '//
 179      . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
 180 902   CALL BORT('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT '//
 181      . 'BUFR FILE, NONE ARE')
 182 903   CALL BORT('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '//
 183      . 'OUTPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
 184      . 'INTERNAL SUBSET ARRAY')
 185 904   WRITE(BORT_STR1,'("BUFRLIB: UFBOVR - MNEMONIC STRING READ IN IS'//
 186      . ': ",A)') STR
 187       WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '//
 188      . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'//
 189      . ' - INCOMPLETE WRITE")')  IRET,I2
 190       CALL BORT2(BORT_STR1,BORT_STR2)
 191       END