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

Last change on this file since 623 was 623, checked in by raasch, 11 years ago

last commit documented

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