copysb.f

Go to the documentation of this file.

C> @file
C> @brief Copy a BUFR data subset.

C> This subroutine copies a BUFR data subset from one Fortran logical
C> unit to another.
C>
C> @author J. Woollen
C> @date 1994-01-06
C>
C> @param[in] LUNIN    - integer: Fortran logical unit number for
C>                       source BUFR file
C> @param[in] LUNOT    - integer: Fortran logical unit number for
C>                       target BUFR file
C> @param[out] IRET    - integer: return code
C>                       - 0 = normal return
C>                       - -1 = a BUFR data subset could not be
C>                              read from the BUFR message in
C>                              internal arrays for LUNIN
C>
C> <p>Logical unit LUNIN should have already been opened for input
C> operations via a previous call to subroutine openbf(), and a BUFR
C> message should have already been read into internal arrays for
C> LUNIN via a previous call to one of the
C> [message-reading subroutines](@ref hierarchy).
C>
C> <p>Logical unit LUNOT should have already been opened for output
C> operations via a previous call to subroutine openbf(), and a BUFR
C> message should already be open for output within internal arrays
C> via a previous call to one of the BUFRLIB
C> [message-writing subroutines](@ref hierarchy).
C>
C> <p>The compression status of the data subset (i.e. compressed or
C> uncompressed) will be preserved when copying from LUNIN to LUNOT.
C>
C> <p>If LUNOT < 0, then a data subset is read from the BUFR message
C> in internal arrays for LUNIN but is not copied to the BUFR
C> message in internal arrays for LUNOT.  Otherwise, the
C> [DX BUFR Table information](@ref dfbftab) associated with
C> each of the logical units LUNIN and LUNOT must contain identical
C> definitions for the type of BUFR message containing the data
C> subset to be copied from LUNIN to LUNOT.
C>
C> <b>Program history log:</b>
C> - 1994-01-06  J. Woollen -- Original author
C> - 1998-07-08  J. Woollen -- Replaced call to Cray library routine ABORT
C>                             with call to new internal routine bort()
C> - 1999-11-18  J. Woollen -- The number of BUFR files which can be
C>                             opened at one time increased from 10 to 32
C>                             (necessary in order to process multiple
C>                             BUFR files under the MPI)
C> - 2000-09-19  J. Woollen -- Maximum message length increased
C>                             from 10,000 to 20,000 bytes
C> - 2002-05-14  J. Woollen -- Removed old Cray compiler directives
C> - 2004-08-09  J. Ator    -- Maximum message length increased
C>                             from 20,000 to 50,000 bytes
C> - 2005-09-16  J. Woollen -- Now writes out compressed subset/message if
C>                           input subset/message is compressed (before
C>                           could only write out uncompressed subset/
C>                           message regardless of compression status of
C>                           input subset/message)
C> - 2009-06-26  J. Ator    -- Use iok2cpy()
C> - 2014-11-03  J. Ator    -- Handle oversized (>65530 bytes) subsets
C> - 2014-12-10  J. Ator    -- Use modules instead of COMMON blocks
C>
      SUBROUTINE copysb(LUNIN,LUNOT,IRET)

      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_tables

      CHARACTER*128 bort_str

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

      iret = 0

C  CHECK THE FILE STATUSES
C  -----------------------

      CALL status(lunin,lin,il,im)
      IF(il.EQ.0) goto 900
      IF(il.GT.0) goto 901
      IF(im.EQ.0) goto 902

      IF(lunot.GT.0) THEN
         CALL status(lunot,lot,il,im)
         IF(il.EQ.0) goto 903
         IF(il.LT.0) goto 904
         IF(im.EQ.0) goto 905
         IF(inode(lin).NE.inode(lot)) THEN
           IF( (tag(inode(lin)).NE.tag(inode(lot))) .OR.
     .        (iok2cpy(lin,lot).NE.1) ) goto 906
         ENDIF
      ENDIF

C  SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE
C  ---------------------------------------------

      IF(nsub(lin).EQ.msub(lin)) THEN
         iret = -1
         goto 100
      ENDIF

C  CHECK COMPRESSION STATUS OF INPUT MESSAGE, OUTPUT MESSAGE WILL MATCH
C  --------------------------------------------------------------------

      CALL mesgbc(-lunin,mest,icmp)

      IF(icmp.EQ.1) THEN

C  -------------------------------------------------------
C  THIS BRANCH IS FOR COMPRESSED INPUT/OUTPUT MESSAGES
C  -------------------------------------------------------
C  READ IN AND UNCOMPRESS SUBSET, THEN COPY IT TO COMPRESSED OUTPUT MSG
C  --------------------------------------------------------------------

         CALL readsb(lunin,iret)
         IF(lunot.GT.0) THEN
            CALL ufbcpy(lunin,lunot)
            CALL cmpmsg('Y')
            CALL writsb(lunot)
            CALL cmpmsg('N')
         ENDIF
         goto 100
      ELSE  IF(icmp.EQ.0) THEN

C  -------------------------------------------------------
C  THIS BRANCH IS FOR UNCOMPRESSED INPUT/OUTPUT MESSAGES
C  -------------------------------------------------------
C  COPY THE SUBSET TO THE OUTPUT MESSAGE AND/OR RESET THE POINTERS
C  ---------------------------------------------------------------

         ibit = (mbyt(lin))*8
         CALL upb(nbyt,16,mbay(1,lin),ibit)
         IF (nbyt.GT.65530) THEN

C          This is an oversized subset, so we can't rely on the value
C          of NBYT as being the true size (in bytes) of the subset.

           IF ( (nsub(lin).EQ.0) .AND. (msub(lin).EQ.1) )  THEN

C            But it's also the first and only subset in the message,
C            so we can determine its true size in a different way.

             CALL getlens(mbay(1,lin),4,len0,len1,len2,len3,len4,l5)
             nbyt = len4 - 4
           ELSE

C            We have no way to easily determine the true size of this
C            oversized subset.

             iret = -1
             goto 100
           ENDIF
         ENDIF
         IF(lunot.GT.0) CALL cpyupd(lunot,lin,lot,nbyt)
         mbyt(lin) = mbyt(lin) + nbyt
         nsub(lin) = nsub(lin) + 1
      ELSE
         goto 907
      ENDIF

C  EXITS
C  -----

100   RETURN
900   CALL bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS CLOSED, IT '//
     . 'MUST BE OPEN FOR INPUT')
901   CALL bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS OPEN FOR '//
     . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
902   CALL bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN INPUT '//
     . 'BUFR FILE, NONE ARE')
903   CALL bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS CLOSED, IT '//
     . 'MUST BE OPEN FOR OUTPUT')
904   CALL bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS OPEN FOR '//
     . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
905   CALL bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN OUTPUT '//
     . 'BUFR FILE, NONE ARE')
906   CALL bort('BUFRLIB: COPYSB - INPUT AND OUTPUT BUFR FILES MUST '//
     . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
907   WRITE(bort_str,'("BUFRLIB: COPYSB - INVALID COMPRESSION '//
     . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '//
     . 'ROUTINE MESGBC")') icmp
      CALL bort(bort_str)
      END