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

Last change on this file since 550 was 484, checked in by raasch, 14 years ago

typo in file headers removed

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