NCEPLIBS-bufr  12.0.0
copysb.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Copy a BUFR data subset.
3 C>
4 C> @author J. Woollen @date 1994-01-06
5 
6 C> This subroutine copies a BUFR data subset from one Fortran logical
7 C> unit to another.
8 C>
9 C> Logical unit LUNIN should have already been opened for input
10 C> operations via a previous call to subroutine openbf(), and a BUFR
11 C> message should have already been read into internal arrays for
12 C> LUNIN via a previous call to one of the
13 C> [message-reading subroutines](@ref hierarchy).
14 C>
15 C> Logical unit LUNOT should have already been opened for output
16 C> operations via a previous call to subroutine openbf(), and a BUFR
17 C> message should already be open for output within internal arrays
18 C> via a previous call to one of the BUFRLIB
19 C> [message-writing subroutines](@ref hierarchy).
20 C>
21 C> The compression status of the data subset (i.e. compressed or
22 C> uncompressed) will be preserved when copying from LUNIN to LUNOT.
23 C>
24 C> If LUNOT < 0, then a data subset is read from the BUFR message
25 C> in internal arrays for LUNIN but is not copied to the BUFR
26 C> message in internal arrays for LUNOT. Otherwise, the
27 C> [DX BUFR Table information](@ref dfbftab) associated with
28 C> each of the logical units LUNIN and LUNOT must contain identical
29 C> definitions for the type of BUFR message containing the data
30 C> subset to be copied from LUNIN to LUNOT.
31 C>
32 C> @param[in] LUNIN -- integer: Fortran logical unit number for
33 C> source BUFR file
34 C> @param[in] LUNOT -- integer: Fortran logical unit number for
35 C> target BUFR file
36 C> @param[out] IRET -- integer: return code
37 C> - 0 = normal return
38 C> - -1 = a BUFR data subset could not be
39 C> read from the BUFR message in
40 C> internal arrays for LUNIN
41 C>
42 C> @author J. Woollen @date 1994-01-06
43  RECURSIVE SUBROUTINE copysb(LUNIN,LUNOT,IRET)
44 
45  USE moda_msgcwd
46  USE moda_bitbuf
47  USE moda_tables
48  USE modv_im8b
49 
50  CHARACTER*128 bort_str
51 
52 C-----------------------------------------------------------------------
53 C-----------------------------------------------------------------------
54 
55 C CHECK FOR I8 INTEGERS
56 C ---------------------
57 
58  IF(im8b) THEN
59  im8b=.false.
60 
61  CALL x84(lunin,my_lunin,1)
62  CALL x84(lunot,my_lunot,1)
63  CALL copysb(my_lunin,my_lunot,iret)
64  CALL x48(iret,iret,1)
65 
66  im8b=.true.
67  RETURN
68  ENDIF
69 
70  iret = 0
71 
72 C CHECK THE FILE STATUSES
73 C -----------------------
74 
75  CALL status(lunin,lin,il,im)
76  IF(il.EQ.0) GOTO 900
77  IF(il.GT.0) GOTO 901
78  IF(im.EQ.0) GOTO 902
79 
80  IF(lunot.GT.0) THEN
81  CALL status(lunot,lot,il,im)
82  IF(il.EQ.0) GOTO 903
83  IF(il.LT.0) GOTO 904
84  IF(im.EQ.0) GOTO 905
85  IF(inode(lin).NE.inode(lot)) THEN
86  IF( (tag(inode(lin)).NE.tag(inode(lot))) .OR.
87  . (iok2cpy(lin,lot).NE.1) ) GOTO 906
88  ENDIF
89  ENDIF
90 
91 C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE
92 C ---------------------------------------------
93 
94  IF(nsub(lin).EQ.msub(lin)) THEN
95  iret = -1
96  GOTO 100
97  ENDIF
98 
99 C CHECK COMPRESSION STATUS OF INPUT MESSAGE, OUTPUT MESSAGE WILL MATCH
100 C --------------------------------------------------------------------
101 
102  CALL mesgbc(-lunin,mest,icmp)
103 
104  IF(icmp.EQ.1) THEN
105 
106 C -------------------------------------------------------
107 C THIS BRANCH IS FOR COMPRESSED INPUT/OUTPUT MESSAGES
108 C -------------------------------------------------------
109 C READ IN AND UNCOMPRESS SUBSET, THEN COPY IT TO COMPRESSED OUTPUT MSG
110 C --------------------------------------------------------------------
111 
112  CALL readsb(lunin,iret)
113  IF(lunot.GT.0) THEN
114  CALL ufbcpy(lunin,lunot)
115  CALL cmpmsg('Y')
116  CALL writsb(lunot)
117  CALL cmpmsg('N')
118  ENDIF
119  GOTO 100
120  ELSE IF(icmp.EQ.0) THEN
121 
122 C -------------------------------------------------------
123 C THIS BRANCH IS FOR UNCOMPRESSED INPUT/OUTPUT MESSAGES
124 C -------------------------------------------------------
125 C COPY THE SUBSET TO THE OUTPUT MESSAGE AND/OR RESET THE POINTERS
126 C ---------------------------------------------------------------
127 
128  ibit = (mbyt(lin))*8
129  CALL upb(nbyt,16,mbay(1,lin),ibit)
130  IF (nbyt.GT.65530) THEN
131 
132 C This is an oversized subset, so we can't rely on the value
133 C of NBYT as being the true size (in bytes) of the subset.
134 
135  IF ( (nsub(lin).EQ.0) .AND. (msub(lin).EQ.1) ) THEN
136 
137 C But it's also the first and only subset in the message,
138 C so we can determine its true size in a different way.
139 
140  CALL getlens(mbay(1,lin),4,len0,len1,len2,len3,len4,l5)
141  nbyt = len4 - 4
142  ELSE
143 
144 C We have no way to easily determine the true size of this
145 C oversized subset.
146 
147  iret = -1
148  GOTO 100
149  ENDIF
150  ENDIF
151  IF(lunot.GT.0) CALL cpyupd(lunot,lin,lot,nbyt)
152  mbyt(lin) = mbyt(lin) + nbyt
153  nsub(lin) = nsub(lin) + 1
154  ELSE
155  GOTO 907
156  ENDIF
157 
158 C EXITS
159 C -----
160 
161 100 RETURN
162 900 CALL bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS CLOSED, IT '//
163  . 'MUST BE OPEN FOR INPUT')
164 901 CALL bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS OPEN FOR '//
165  . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
166 902 CALL bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN INPUT '//
167  . 'BUFR FILE, NONE ARE')
168 903 CALL bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS CLOSED, IT '//
169  . 'MUST BE OPEN FOR OUTPUT')
170 904 CALL bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS OPEN FOR '//
171  . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
172 905 CALL bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN OUTPUT '//
173  . 'BUFR FILE, NONE ARE')
174 906 CALL bort('BUFRLIB: COPYSB - INPUT AND OUTPUT BUFR FILES MUST '//
175  . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
176 907 WRITE(bort_str,'("BUFRLIB: COPYSB - INVALID COMPRESSION '//
177  . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '//
178  . 'ROUTINE MESGBC")') icmp
179  CALL bort(bort_str)
180  END
subroutine bort(STR)
Log one error message and abort application program.
Definition: bort.f:18
subroutine cmpmsg(CF)
Specify the use of compression when writing BUFR messages.
Definition: cmpmsg.f:39
recursive subroutine copysb(LUNIN, LUNOT, IRET)
This subroutine copies a BUFR data subset from one Fortran logical unit to another.
Definition: copysb.f:44
subroutine cpyupd(LUNIT, LIN, LUN, IBYT)
This subroutine copies a BUFR data subset from one unit to another within internal memory and resets ...
Definition: cpyupd.f:29
recursive subroutine getlens(MBAY, LL, LEN0, LEN1, LEN2, LEN3, LEN4, LEN5)
This subroutine reads the lengths of all of the individual sections of a given BUFR message,...
Definition: getlens.f:36
integer function iok2cpy(LUI, LUO)
This function determines whether a BUFR message, or a data subset from within a BUFR message,...
Definition: iok2cpy.f:28
recursive subroutine mesgbc(LUNIN, MESGTYP, ICOMP)
This subroutine examines a BUFR message and returns both the message type (from Section 1) and messag...
Definition: mesgbc.f:51
This module contains array and variable declarations used to store BUFR messages internally for multi...
integer ibit
Bit pointer within IBAY.
integer, dimension(:,:), allocatable mbay
Current BUFR message for each internal I/O stream.
integer, dimension(:), allocatable mbyt
Length (in bytes) of current BUFR message for each internal I/O stream.
This module contains declarations for arrays used to store information about the current BUFR message...
integer, dimension(:), allocatable inode
Table A mnemonic for type of BUFR message.
integer, dimension(:), allocatable msub
Total number of data subsets in message.
integer, dimension(:), allocatable nsub
Current subset pointer within message.
This module contains array and variable declarations used to store the internal jump/link table.
character *10, dimension(:), allocatable tag
Mnemonics in the jump/link table.
This module declares and initializes the IM8B variable.
logical, public im8b
Status indicator to keep track of whether all future calls to BUFRLIB subroutines and functions from ...
recursive subroutine readsb(LUNIT, IRET)
Read the next data subset from a BUFR message.
Definition: readsb.f:33
recursive subroutine status(LUNIT, LUN, IL, IM)
Check whether a specified Fortran logical unit number is currently connected to the NCEPLIBS-bufr sof...
Definition: status.f:36
recursive subroutine ufbcpy(LUBIN, LUBOT)
Copy a BUFR data subset.
Definition: ufbcpy.f:34
subroutine upb(NVAL, NBITS, IBAY, IBIT)
This subroutine decodes an integer value from within a specified number of bits of an integer array,...
Definition: upb.f:28
recursive subroutine writsb(LUNIT)
Write a data subset into a BUFR message.
Definition: writsb.f:45
subroutine x48(IIN4, IOUT8, NVAL)
Encode one or more 4-byte integer values as 8-byte integer values.
Definition: x48.F:19
subroutine x84(IIN8, IOUT4, NVAL)
Encode one or more 8-byte integer values as 4-byte integer values.
Definition: x84.F:19