ufbovr.f

Go to the documentation of this file.

C> @file
C> @brief Overwrite one or more data values within a data subset.
C>
C> @author Woollen @date 1994-01-06
 
C> This subroutine writes over specified values which exist
C> in current internal BUFR subset arrays in a file open for output.
C> The data values correspond to mnemonics which are part of a
C> delayed-replication sequence, or for which there is no replication
C> at all. Either BUFR archive library subroutine openmg() or openmb()
C> must have been previously called to open and initialize a BUFR
C> message within memory for this lunit. In addition, BUFR archive
C> library subroutine writsb() or invmrg() must have been called to
C> store data in the internal output subset arrays.
C>
C> @param[in] LUNIT - integer: Fortran logical unit number for BUFR file.
C> @param[in] USR - real*8(*,*): data values
C> @param[in] I1 - integer: First dimension of USR as allocated within
C> the calling program.
C> @param[in] I2 - integer: Number of replications of STR that are to
C> be written into the data subset.
C> @param[out] IRET - integer: Number of replications of STR that were
C> written into the data subset.
C> @param[in] STR - character*(*): string of blank-separated Table B
C> mnemonics in one-to-one correspondence with first dimension of USR.
C>
C> @author Woollen @date 1994-01-06
      RECURSIVE SUBROUTINE ufbovr(LUNIT,USR,I1,I2,IRET,STR)
 
      USE modv_im8b
 
      USE moda_usrint
      USE moda_msgcwd
 
      COMMON /quiet / iprt
 
      CHARACTER*128 bort_str1,bort_str2,errstr
      CHARACTER*(*) str
      real*8        usr(i1,i2)
 
      DATA ifirst1/0/,ifirst2/0/
 
      SAVE ifirst1, ifirst2
 
C----------------------------------------------------------------------
C----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunit,my_lunit,1)
         CALL x84(i1,my_i1,1)
         CALL x84(i2,my_i2,1)
         CALL ufbovr(my_lunit,usr,my_i1,my_i2,iret,str)
         CALL x48(iret,iret,1)
 
         im8b=.true.
         RETURN
      ENDIF
 
      iret = 0
 
C  CHECK THE FILE STATUS AND I-NODE
C  --------------------------------
 
      CALL status(lunit,lun,il,im)
      IF(il.EQ.0) GOTO 900
      IF(il.LT.0) GOTO 901
      IF(im.EQ.0) GOTO 902
      IF(inode(lun).NE.inv(1,lun)) GOTO 903
 
C  .... DK: Why check, isn't IO always 1 here?
      io = min(max(0,il),1)
 
      IF(i1.LE.0) THEN
         IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBOVR - 3rd ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
         GOTO 100
      ELSEIF(i2.LE.0) THEN
         IF(iprt.EQ.-1)  ifirst1 = 1
         IF(io.EQ.0 .OR. ifirst1.EQ.0 .OR. iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBOVR - 4th ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
            IF(iprt.EQ.0 .AND. io.EQ.1) THEN
      errstr = 'Note: Only the first occurrence of this WARNING ' //
     .   'message is printed, there may be more.  To output all ' //
     .   'such messages,'
      CALL errwrt(errstr)
      errstr = 'modify your application program to add ' //
     .   '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
     .   'to a BUFRLIB routine.'
      CALL errwrt(errstr)
            ENDIF
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
            ifirst1 = 1
         ENDIF
         GOTO 100
      ENDIF
 
C  PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES
C  ----------------------------------------------------
 
      CALL string(str,lun,i1,io)
      CALL trybump(lun,usr,i1,i2,io,iret)
 
      IF(io.EQ.1 .AND. iret.NE.i2) GOTO 904
 
      IF(iret.EQ.0)  THEN
         IF(iprt.EQ.-1)  ifirst2 = 1
         IF(ifirst2.EQ.0 .OR. iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = 'BUFRLIB: UFBOVR - NO SPECIFIED VALUES WRITTEN OUT, ' //
     .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
               IF(iprt.EQ.0) THEN
      errstr = 'Note: Only the first occurrence of this WARNING ' //
     .   'message is printed, there may be more.  To output all ' //
     .   'such messages,'
      CALL errwrt(errstr)
      errstr = 'modify your application program to add ' //
     .   '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
     .   'to a BUFRLIB routine.'
      CALL errwrt(errstr)
               ENDIF
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
            ifirst2 = 1
         ENDIF
      ENDIF
 
C  EXITS
C  -----
 
100   RETURN
900   CALL bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT '//
     . 'MUST BE OPEN FOR OUTPUT')
901   CALL bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR '//
     . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
902   CALL bort('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT '//
     . 'BUFR FILE, NONE ARE')
903   CALL bort('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '//
     . 'OUTPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
     . 'INTERNAL SUBSET ARRAY')
904   WRITE(bort_str1,'("BUFRLIB: UFBOVR - MNEMONIC STRING READ IN IS'//
     . ': ",A)') str
      WRITE(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '//
     . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'//
     . ' - INCOMPLETE WRITE")')  iret,i2
      CALL bort2(bort_str1,bort_str2)
      END