copysb.f

Go to the documentation of this file.

C> @file
C> @brief Copy a BUFR data subset.
C>
C> @author J. Woollen @date 1994-01-06
 
C> This subroutine copies a BUFR data subset from one Fortran logical
C> unit to another.
C>
C> 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> 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> The compression status of the data subset (i.e. compressed or
C> uncompressed) will be preserved when copying from LUNIN to LUNOT.
C>
C> 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> @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> @author J. Woollen @date 1994-01-06
      RECURSIVE SUBROUTINE copysb(LUNIN,LUNOT,IRET)
 
      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_tables
      USE modv_im8b
 
      CHARACTER*128 bort_str
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunin,my_lunin,1)
         CALL x84(lunot,my_lunot,1)
         CALL copysb(my_lunin,my_lunot,iret)
         CALL x48(iret,iret,1)
 
         im8b=.true.
         RETURN
      ENDIF
 
      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