NCEPLIBS-bufr  11.7.0
 All Data Structures Files Functions Variables Pages
copysb.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Copy a BUFR data subset.
3 
4 C> This subroutine copies a BUFR data subset from one Fortran logical
5 C> unit to another.
6 C>
7 C> @author J. Woollen
8 C> @date 1994-01-06
9 C>
10 C> @param[in] LUNIN -- integer: Fortran logical unit number for
11 C> source BUFR file
12 C> @param[in] LUNOT -- integer: Fortran logical unit number for
13 C> target BUFR file
14 C> @param[out] IRET -- integer: return code
15 C> - 0 = normal return
16 C> - -1 = a BUFR data subset could not be
17 C> read from the BUFR message in
18 C> internal arrays for LUNIN
19 C>
20 C> <p>Logical unit LUNIN should have already been opened for input
21 C> operations via a previous call to subroutine openbf(), and a BUFR
22 C> message should have already been read into internal arrays for
23 C> LUNIN via a previous call to one of the
24 C> [message-reading subroutines](@ref hierarchy).
25 C>
26 C> <p>Logical unit LUNOT should have already been opened for output
27 C> operations via a previous call to subroutine openbf(), and a BUFR
28 C> message should already be open for output within internal arrays
29 C> via a previous call to one of the BUFRLIB
30 C> [message-writing subroutines](@ref hierarchy).
31 C>
32 C> <p>The compression status of the data subset (i.e. compressed or
33 C> uncompressed) will be preserved when copying from LUNIN to LUNOT.
34 C>
35 C> <p>If LUNOT < 0, then a data subset is read from the BUFR message
36 C> in internal arrays for LUNIN but is not copied to the BUFR
37 C> message in internal arrays for LUNOT. Otherwise, the
38 C> [DX BUFR Table information](@ref dfbftab) associated with
39 C> each of the logical units LUNIN and LUNOT must contain identical
40 C> definitions for the type of BUFR message containing the data
41 C> subset to be copied from LUNIN to LUNOT.
42 C>
43 C> <b>Program history log:</b>
44 C> | Date | Programmer | Comments |
45 C> | -----|------------|----------|
46 C> | 1994-01-06 | J. Woollen | Original author |
47 C> | 1998-07-08 | J. Woollen | Replaced call to Cray library routine ABORT with call to new internal routine bort() |
48 C> | 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32 (necessary in order to process multiple BUFR files under the MPI) |
49 C> | 2000-09-19 | J. Woollen | Maximum message length increased from 10,000 to 20,000 bytes |
50 C> | 2002-05-14 | J. Woollen | Removed old Cray compiler directives |
51 C> | 2004-08-09 | J. Ator | Maximum message length increased from 20,000 to 50,000 bytes |
52 C> | 2005-09-16 | J. Woollen | Now writes out compressed subset/message if input subset/message is compressed |
53 C> | 2009-06-26 | J. Ator | Use iok2cpy() |
54 C> | 2014-11-03 | J. Ator | Handle oversized (>65530 bytes) subsets |
55 C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
56 C>
57  SUBROUTINE copysb(LUNIN,LUNOT,IRET)
58 
59  USE moda_msgcwd
60  USE moda_bitbuf
61  USE moda_tables
62 
63  CHARACTER*128 bort_str
64 
65 C-----------------------------------------------------------------------
66 C-----------------------------------------------------------------------
67 
68  iret = 0
69 
70 C CHECK THE FILE STATUSES
71 C -----------------------
72 
73  CALL status(lunin,lin,il,im)
74  IF(il.EQ.0) goto 900
75  IF(il.GT.0) goto 901
76  IF(im.EQ.0) goto 902
77 
78  IF(lunot.GT.0) THEN
79  CALL status(lunot,lot,il,im)
80  IF(il.EQ.0) goto 903
81  IF(il.LT.0) goto 904
82  IF(im.EQ.0) goto 905
83  IF(inode(lin).NE.inode(lot)) THEN
84  IF( (tag(inode(lin)).NE.tag(inode(lot))) .OR.
85  . (iok2cpy(lin,lot).NE.1) ) goto 906
86  ENDIF
87  ENDIF
88 
89 C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE
90 C ---------------------------------------------
91 
92  IF(nsub(lin).EQ.msub(lin)) THEN
93  iret = -1
94  goto 100
95  ENDIF
96 
97 C CHECK COMPRESSION STATUS OF INPUT MESSAGE, OUTPUT MESSAGE WILL MATCH
98 C --------------------------------------------------------------------
99 
100  CALL mesgbc(-lunin,mest,icmp)
101 
102  IF(icmp.EQ.1) THEN
103 
104 C -------------------------------------------------------
105 C THIS BRANCH IS FOR COMPRESSED INPUT/OUTPUT MESSAGES
106 C -------------------------------------------------------
107 C READ IN AND UNCOMPRESS SUBSET, THEN COPY IT TO COMPRESSED OUTPUT MSG
108 C --------------------------------------------------------------------
109 
110  CALL readsb(lunin,iret)
111  IF(lunot.GT.0) THEN
112  CALL ufbcpy(lunin,lunot)
113  CALL cmpmsg('Y')
114  CALL writsb(lunot)
115  CALL cmpmsg('N')
116  ENDIF
117  goto 100
118  ELSE IF(icmp.EQ.0) THEN
119 
120 C -------------------------------------------------------
121 C THIS BRANCH IS FOR UNCOMPRESSED INPUT/OUTPUT MESSAGES
122 C -------------------------------------------------------
123 C COPY THE SUBSET TO THE OUTPUT MESSAGE AND/OR RESET THE POINTERS
124 C ---------------------------------------------------------------
125 
126  ibit = (mbyt(lin))*8
127  CALL upb(nbyt,16,mbay(1,lin),ibit)
128  IF (nbyt.GT.65530) THEN
129 
130 C This is an oversized subset, so we can't rely on the value
131 C of NBYT as being the true size (in bytes) of the subset.
132 
133  IF ( (nsub(lin).EQ.0) .AND. (msub(lin).EQ.1) ) THEN
134 
135 C But it's also the first and only subset in the message,
136 C so we can determine its true size in a different way.
137 
138  CALL getlens(mbay(1,lin),4,len0,len1,len2,len3,len4,l5)
139  nbyt = len4 - 4
140  ELSE
141 
142 C We have no way to easily determine the true size of this
143 C oversized subset.
144 
145  iret = -1
146  goto 100
147  ENDIF
148  ENDIF
149  IF(lunot.GT.0) CALL cpyupd(lunot,lin,lot,nbyt)
150  mbyt(lin) = mbyt(lin) + nbyt
151  nsub(lin) = nsub(lin) + 1
152  ELSE
153  goto 907
154  ENDIF
155 
156 C EXITS
157 C -----
158 
159 100 RETURN
160 900 CALL bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS CLOSED, IT '//
161  . 'MUST BE OPEN FOR INPUT')
162 901 CALL bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS OPEN FOR '//
163  . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
164 902 CALL bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN INPUT '//
165  . 'BUFR FILE, NONE ARE')
166 903 CALL bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS CLOSED, IT '//
167  . 'MUST BE OPEN FOR OUTPUT')
168 904 CALL bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS OPEN FOR '//
169  . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
170 905 CALL bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN OUTPUT '//
171  . 'BUFR FILE, NONE ARE')
172 906 CALL bort('BUFRLIB: COPYSB - INPUT AND OUTPUT BUFR FILES MUST '//
173  . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
174 907 WRITE(bort_str,'("BUFRLIB: COPYSB - INVALID COMPRESSION '//
175  . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '//
176  . 'ROUTINE MESGBC")') icmp
177  CALL bort(bort_str)
178  END
subroutine upb(NVAL, NBITS, IBAY, IBIT)
THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER CONTAINED WITHIN NBITS BITS OF IBAY...
Definition: upb.f:49
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:39
subroutine copysb(LUNIN, LUNOT, IRET)
This subroutine copies a BUFR data subset from one Fortran logical unit to another.
Definition: copysb.f:57
subroutine cpyupd(LUNIT, LIN, LUN, IBYT)
THIS SUBROUTINE COPIES A SUBSET FROM ONE MESSAGE BUFFER (ARRAY MBAY IN MODULE BITBUF) TO ANOTHER AND/...
Definition: cpyupd.f:60
subroutine cmpmsg(CF)
This subroutine is used to specify whether BUFR messages output by future calls to message-writing su...
Definition: cmpmsg.f:41
subroutine mesgbc(LUNIN, MESGTYP, ICOMP)
THIS SUBROUTINE EXAMINES A BUFR MESSAGE AND RETURNS BOTH THE MESSAGE TYPE FROM SECTION 1 AND A MESSAG...
Definition: mesgbc.f:96
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
Definition: status.f:55
subroutine writsb(LUNIT)
This subroutine writes a complete data subset into a BUFR message, for eventual output to logical uni...
Definition: writsb.f:52
INTEGER function iok2cpy(LUI, LUO)
This function determines whether a BUFR message, or a data subset from within a BUFR message...
Definition: iok2cpy.f:37
subroutine ufbcpy(LUBIN, LUBOT)
THIS SUBROUTINE COPIES A COMPLETE SUBSET BUFFER, UNPACKED INTO INTERNAL MEMORY FROM LOGICAL UNIT LUBI...
Definition: ufbcpy.f:48
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22
This module contains array and variable declarations used to store BUFR messages internally for multi...
Definition: moda_bitbuf.F:10
subroutine readsb(LUNIT, IRET)
This subroutine reads the next data subset from a BUFR message into internal arrays.
Definition: readsb.f:47