source: palm/trunk/SOURCE/write_compressed.f90 @ 1310

Last change on this file since 1310 was 1310, checked in by raasch, 7 years ago

update of GPL copyright

  • Property svn:keywords set to Id
File size: 6.7 KB
Line 
1 SUBROUTINE write_compressed( field, fid_avs, fid_fld, my_id, nxl, nxr, nyn, &
2                              nys, nzb, nz_do3d, prec, nbgp )
3
4!--------------------------------------------------------------------------------!
5! This file is part of PALM.
6!
7! PALM is free software: you can redistribute it and/or modify it under the terms
8! of the GNU General Public License as published by the Free Software Foundation,
9! either version 3 of the License, or (at your option) any later version.
10!
11! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
12! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
13! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
14!
15! You should have received a copy of the GNU General Public License along with
16! PALM. If not, see <http://www.gnu.org/licenses/>.
17!
18! Copyright 1997-2014 Leibniz Universitaet Hannover
19!--------------------------------------------------------------------------------!
20!
21! Current revisions:
22! ------------------
23!
24!
25! Former revisions:
26! -----------------
27! $Id: write_compressed.f90 1310 2014-03-14 08:01:56Z raasch $
28!
29! 1092 2013-02-02 11:24:22Z raasch
30! unused variables removed
31!
32! 1036 2012-10-22 13:43:42Z raasch
33! code put under GPL (PALM 3.9)
34!
35! 667 2010-12-23 12:06:00Z suehring/gryschka
36! Array bounds and nx, ny adapted with nbgp
37!
38! 622 2010-12-10 08:08:13Z raasch
39! optional barriers included in order to speed up collective operations
40!
41! Feb. 2007
42! RCS Log replace by Id keyword, revision history cleaned up
43!
44! Revision 1.4  2006/02/23 13:15:09  raasch
45! nz_plot3d renamed nz_do3d
46!
47! Revision 1.1  1999/03/02 09:25:21  raasch
48! Initial revision
49!
50!
51! Description:
52! ------------
53! In this routine, 3D-data (to be plotted) are scaled and compressed by
54! the method of bit shifting. It is designed for the use outside of PALM
55! also, which is the reason why most of the data is passed by subroutine
56! arguments. Nevertheless, the module pegrid is needed by MPI calls.
57!
58! Arguments:
59! field         = data array to be compressed
60! fid_avs       = file-ID of AVS-data-file
61! fid_fld       = file-ID of AVS-header-file
62! my_id         = ID of the calling PE
63! nxl, nxr      = index bounds of the subdomain along x
64! nyn, nys      = index bounds of the subdomain along y
65! nzb,nz_do3d   = index bounds of the domain along z (can be smaller than
66!                 the total domain)
67! prec          = precision of packed data (number of digits after decimal
68!                 point)
69!------------------------------------------------------------------------------!
70
71    USE pegrid         !  needed for MPI_ALLREDUCE
72
73    IMPLICIT NONE
74
75    INTEGER, PARAMETER   :: ip4 = SELECTED_INT_KIND ( 9 )
76    INTEGER, PARAMETER   :: spk = SELECTED_REAL_KIND( 6 )
77
78    INTEGER ::  ampl, dummy1, dummy2, factor, i, ifieldmax, ifieldmax_l, &
79                ifieldmin, ifieldmin_l, ii, length, nfree, npack, nsize, &
80                nx, ny, nz, startpos
81    INTEGER(ip4) ::  imask (32)
82    INTEGER(ip4), DIMENSION(:), ALLOCATABLE ::  ifield, packed_ifield
83
84    INTEGER, INTENT(IN) ::  fid_avs, fid_fld, my_id, nxl, nxr, nyn, nys, nzb, &
85                            nz_do3d, prec, nbgp
86
87    REAL(spk), INTENT(IN) :: field(1:((nxr-nxl+1+2*nbgp)*(nyn-nys+1+2*nbgp)*(nz_do3d-nzb+1)))
88
89!
90!-- Initialise local variables
91    ampl      = 0
92    ifieldmax = 0
93    ifieldmin = 0
94    npack = 0
95    nsize = 0
96    DO  i = 1,32
97       imask(i) = (2**i) - 1
98    ENDDO
99
100    nx     = nxr - nxl + 2*nbgp
101    ny     = nyn - nys + 2*nbgp
102    nz     = nz_do3d - nzb
103    length = (nx+1) * (ny+1) * (nz+1)
104
105!
106!-- Allocate memory for integer array
107    ALLOCATE ( ifield(1:length) )
108
109!
110!-- Store data on integer (in desired precision)
111    factor = 10**prec
112    DO  i = 1, length
113       ifield(i) = NINT( field(i) * factor )
114    ENDDO
115
116!
117!-- Find minimum and maximum
118    ifieldmax_l = MAXVAL( ifield )
119    ifieldmin_l = MINVAL( ifield )
120
121#if defined( __parallel )
122    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
123    CALL MPI_ALLREDUCE( ifieldmax_l, ifieldmax, 1, MPI_INTEGER, MPI_MAX, &
124                        comm2d, ierr )
125    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
126    CALL MPI_ALLREDUCE( ifieldmin_l, ifieldmin, 1, MPI_INTEGER, MPI_MIN, &
127                        comm2d, ierr )
128#else
129    ifieldmax = ifieldmax_l
130    ifieldmin = ifieldmin_l
131#endif
132
133!
134!-- Minimum scaling
135    ifield = ifield - ifieldmin
136
137!
138!-- Calculate the number of bits needed for each value
139    ampl  = ifieldmax - ifieldmin
140    nsize = 1
141
142    DO WHILE ( imask(nsize) < ampl )
143       nsize = nsize + 1
144    ENDDO
145
146!
147!-- Calculate size of the packed array
148    npack = length * nsize
149    IF ( MOD( npack, 32 ) /= 0 )  npack = npack + 32
150    npack = npack / 32
151
152!
153!-- Start packing the data
154    ALLOCATE ( packed_ifield(1:npack) )
155    packed_ifield = 0
156
157!
158!-- Starting position of a word
159    startpos = 0
160
161!
162!-- Starting position of the word to which data are actually written
163    ii = 1
164
165!
166!-- Compress all data
167    DO  i = 1, length
168
169!
170!--    Cut the significant bits from the actual grid point value (GPV)
171       dummy1 = IAND( ifield(i), imask(nsize) )
172
173!
174!--    Calculate number of free bits of the actual word after packing the GPV
175       nfree = 32 - startpos - nsize
176
177       IF ( nfree > 0 )  THEN 
178!
179!--       GPV fits to the actual word (ii), additional bits are still free.
180!--       Shift GPV to the new position
181          dummy2 = ISHFT( dummy1 ,nfree )
182
183!
184!--       Append bits to the already packed data
185          packed_ifield(ii) = packed_ifield(ii) + dummy2
186
187!
188!--       Calculate new starting position
189          startpos = startpos + nsize
190
191       ELSEIF ( nfree .EQ. 0 )  THEN 
192!
193!--       GPV fills the actual word (ii) exactly
194          packed_ifield(ii) = packed_ifield(ii) + dummy1
195
196!
197!--       Activate next (new) word
198          ii = ii + 1
199
200!
201!--       Reset starting position of the new word
202          startpos = 0
203
204       ELSE 
205!
206!--       GPV must be split up to the actual (ii) and the following (ii+1)
207!--       word. Shift first part of GPV to its position.
208          dummy2 = ISHFT( dummy1, nfree )
209
210!
211!--       Append bits
212          packed_ifield(ii) = packed_ifield(ii) + dummy2
213
214!
215!--       Store rest of GPV on the next word
216          ii = ii + 1
217          packed_ifield(ii) = ISHFT( dummy1, 32+nfree )
218!
219!--       Calculate starting position of the next GPV
220          startpos = -nfree
221
222       ENDIF
223
224    ENDDO
225
226!
227!-- Write the compressed 3D array
228    WRITE ( fid_avs )  packed_ifield
229
230!
231!-- Write additional informations on  FLD-file
232    IF ( my_id == 0 )  WRITE ( fid_fld, 100 )  prec, ifieldmin, nsize, length
233
234    DEALLOCATE( ifield, packed_ifield )
235
236!
237!-- Formats
238100 FORMAT ('# precision = ',I4/ &
239            '# feldmin   = ',I8/ &
240            '# nbits     = ',I2/ &
241            '# nskip     = ',I8)
242
243END SUBROUTINE write_compressed
Note: See TracBrowser for help on using the repository browser.