trybump.f

Go to the documentation of this file.

C> @file
C> @brief Try to expand a delayed replication sequence.
C>
C> @author Woollen @date 1994-01-06
 
C> This subroutine checks the first node associated with a
C> character string (parsed into arrays in common block /usrstr/) in
C> order to determine if it represents a delayed replication sequence.
C> If so, then the delayed replication sequence is initialized and
C> expanded (i.e. "bumped") to the value of input argument I2.
C> A call is then made to subroutine ufbrw() in order to write user data
C> into the newly expanded replication sequence.
C>
C> trybump() is usually called from ufbint() after ufbint() receives a
C> non-zero return code from ufbrw(). The cause of a bad return from
C> ufbrw() is usually a delayed replication sequence which isn't
C> expanded enough to hold the array of data the user is trying to
C> write. So trybump() is one last chance to resolve that situation.
C>
C> @note Argument IO is always passed in with a value of 1 at the present
C> time. In the future the subroutine may be expanded to allow it
C> to operate on input files.
C>
C> @param[in] LUN - integer: file ID of open BUFR file
C> @param[in] USR - real*8: (i1,i2) starting address of data values to be
C> written to data subset.
C> @param[in] I1 - integer: length of first dimension of USR.
C> @param[in] I2 - integer: number of "levels" of data values to be
C> written to data subset.
C> @param[in] IO - integer: status indicator for BUFR file
C> - 0 Input file (possible future use)
C> - 1 Output file
C> @param[out] IRET - integer: number of "levels" of data values
C> written to data subset.
C>
C> @author Woollen @date 1994-01-06
      SUBROUTINE trybump(LUN,USR,I1,I2,IO,IRET)
 
      USE moda_usrint
 
      COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
 
      real*8 usr(i1,i2)
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  SEE IF THERE IS A DELAYED REPLICATION GROUP INVOLVED
C  ----------------------------------------------------
 
      ndrp = lstjpb(nods(1),lun,'DRP')
      IF(ndrp.LE.0) GOTO 100
 
C  IF SO, CLEAN IT OUT AND BUMP IT TO I2
C  -------------------------------------
 
      invn = invwin(ndrp,lun,1,nval(lun))
      val(invn,lun) = 0
      jnvn = invn+1
      DO WHILE(nint(val(jnvn,lun)).GT.0)
         jnvn = jnvn+nint(val(jnvn,lun))
      ENDDO
      DO knvn=1,nval(lun)-jnvn+1
      inv(invn+knvn,lun) = inv(jnvn+knvn-1,lun)
      val(invn+knvn,lun) = val(jnvn+knvn-1,lun)
      ENDDO
      nval(lun) = nval(lun)-(jnvn-invn-1)
      CALL usrtpl(lun,invn,i2)
 
C  FINALLY, CALL THE MNEMONIC WRITER
C  ----------------------------------------
 
      CALL ufbrw(lun,usr,i1,i2,io,iret)
 
C  EXIT
C  ----
 
100   RETURN
      END