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

Last change on this file since 1 was 1, checked in by raasch, 15 years ago

Initial repository layout and content

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