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

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

last commit documented

  • Property svn:keywords set to Id
File size: 7.6 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 1321 2014-03-20 09:40:40Z raasch $
28!
29! 1320 2014-03-20 08:40:49Z raasch
30! kind-parameters added to all INTEGER and REAL declaration statements,
31! kinds are defined in new module kinds,
32! old module precision_kind is removed,
33! revision history before 2012 removed,
34! comment fields (!:) to be used for variable explanations added to
35! all variable declaration statements
36!
37! 1092 2013-02-02 11:24:22Z raasch
38! unused variables removed
39!
40! 1036 2012-10-22 13:43:42Z raasch
41! code put under GPL (PALM 3.9)
42!
43! Revision 1.1  1999/03/02 09:25:21  raasch
44! Initial revision
45!
46!
47! Description:
48! ------------
49! In this routine, 3D-data (to be plotted) are scaled and compressed by
50! the method of bit shifting. It is designed for the use outside of PALM
51! also, which is the reason why most of the data is passed by subroutine
52! arguments. Nevertheless, the module pegrid is needed by MPI calls.
53!
54! Arguments:
55! field         = data array to be compressed
56! fid_avs       = file-ID of AVS-data-file
57! fid_fld       = file-ID of AVS-header-file
58! my_id         = ID of the calling PE
59! nxl, nxr      = index bounds of the subdomain along x
60! nyn, nys      = index bounds of the subdomain along y
61! nzb,nz_do3d   = index bounds of the domain along z (can be smaller than
62!                 the total domain)
63! prec          = precision of packed data (number of digits after decimal
64!                 point)
65!------------------------------------------------------------------------------!
66
67    USE kinds
68   
69    USE pegrid         !  needed for MPI_ALLREDUCE
70
71    IMPLICIT NONE
72
73    INTEGER(iwp) ::  ampl          !:
74    INTEGER(iwp) ::  dummy1        !:
75    INTEGER(iwp) ::  dummy2        !:
76    INTEGER(iwp) ::  factor        !:
77    INTEGER(iwp) ::  i             !:
78    INTEGER(iwp) ::  ifieldmax     !:
79    INTEGER(iwp) ::  ifieldmax_l   !:
80    INTEGER(iwp) ::  ifieldmin     !:
81    INTEGER(iwp) ::  ifieldmin_l   !:
82    INTEGER(iwp) ::  ii            !:
83    INTEGER(iwp) ::  length        !:
84    INTEGER(iwp) ::  nfree         !:
85    INTEGER(iwp) ::  npack         !:
86    INTEGER(iwp) ::  nsize         !:
87    INTEGER(iwp) ::  nx            !:
88    INTEGER(iwp) ::  ny            !:
89    INTEGER(iwp) ::  nz            !:
90    INTEGER(iwp) ::  startpos      !:
91   
92    INTEGER(isp) ::  imask (32)    !:
93   
94    INTEGER(isp), DIMENSION(:), ALLOCATABLE ::  ifield          !:
95    INTEGER(isp), DIMENSION(:), ALLOCATABLE ::  packed_ifield   !:
96
97    INTEGER, INTENT(IN) ::  fid_avs   !:
98    INTEGER, INTENT(IN) ::  fid_fld   !:
99    INTEGER, INTENT(IN) ::  my_id     !:
100    INTEGER, INTENT(IN) ::  nxl       !:
101    INTEGER, INTENT(IN) ::  nxr       !:
102    INTEGER, INTENT(IN) ::  nyn       !:
103    INTEGER, INTENT(IN) ::  nys       !:
104    INTEGER, INTENT(IN) ::  nzb       !:
105    INTEGER, INTENT(IN) ::  nz_do3d   !:
106    INTEGER, INTENT(IN) ::  prec      !:
107    INTEGER, INTENT(IN) ::  nbgp      !:
108
109    REAL(sp), INTENT(IN) ::  field(1:((nxr-nxl+1+2*nbgp)*(nyn-nys+1+2*nbgp)*(nz_do3d-nzb+1)))   !:
110
111!
112!-- Initialise local variables
113    ampl      = 0
114    ifieldmax = 0
115    ifieldmin = 0
116    npack = 0
117    nsize = 0
118    DO  i = 1,32
119       imask(i) = (2**i) - 1
120    ENDDO
121
122    nx     = nxr - nxl + 2*nbgp
123    ny     = nyn - nys + 2*nbgp
124    nz     = nz_do3d - nzb
125    length = (nx+1) * (ny+1) * (nz+1)
126
127!
128!-- Allocate memory for integer array
129    ALLOCATE ( ifield(1:length) )
130
131!
132!-- Store data on integer (in desired precision)
133    factor = 10**prec
134    DO  i = 1, length
135       ifield(i) = NINT( field(i) * factor )
136    ENDDO
137
138!
139!-- Find minimum and maximum
140    ifieldmax_l = MAXVAL( ifield )
141    ifieldmin_l = MINVAL( ifield )
142
143#if defined( __parallel )
144    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
145    CALL MPI_ALLREDUCE( ifieldmax_l, ifieldmax, 1, MPI_INTEGER, MPI_MAX,       &
146                        comm2d, ierr )
147    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
148    CALL MPI_ALLREDUCE( ifieldmin_l, ifieldmin, 1, MPI_INTEGER, MPI_MIN,       &
149                        comm2d, ierr )
150#else
151    ifieldmax = ifieldmax_l
152    ifieldmin = ifieldmin_l
153#endif
154
155!
156!-- Minimum scaling
157    ifield = ifield - ifieldmin
158
159!
160!-- Calculate the number of bits needed for each value
161    ampl  = ifieldmax - ifieldmin
162    nsize = 1
163
164    DO WHILE ( imask(nsize) < ampl )
165       nsize = nsize + 1
166    ENDDO
167
168!
169!-- Calculate size of the packed array
170    npack = length * nsize
171    IF ( MOD( npack, 32 ) /= 0 )  npack = npack + 32
172    npack = npack / 32
173
174!
175!-- Start packing the data
176    ALLOCATE ( packed_ifield(1:npack) )
177    packed_ifield = 0
178
179!
180!-- Starting position of a word
181    startpos = 0
182
183!
184!-- Starting position of the word to which data are actually written
185    ii = 1
186
187!
188!-- Compress all data
189    DO  i = 1, length
190
191!
192!--    Cut the significant bits from the actual grid point value (GPV)
193       dummy1 = IAND( ifield(i), imask(nsize) )
194
195!
196!--    Calculate number of free bits of the actual word after packing the GPV
197       nfree = 32 - startpos - nsize
198
199       IF ( nfree > 0 )  THEN 
200!
201!--       GPV fits to the actual word (ii), additional bits are still free.
202!--       Shift GPV to the new position
203          dummy2 = ISHFT( dummy1 ,nfree )
204
205!
206!--       Append bits to the already packed data
207          packed_ifield(ii) = packed_ifield(ii) + dummy2
208
209!
210!--       Calculate new starting position
211          startpos = startpos + nsize
212
213       ELSEIF ( nfree .EQ. 0 )  THEN 
214!
215!--       GPV fills the actual word (ii) exactly
216          packed_ifield(ii) = packed_ifield(ii) + dummy1
217
218!
219!--       Activate next (new) word
220          ii = ii + 1
221
222!
223!--       Reset starting position of the new word
224          startpos = 0
225
226       ELSE 
227!
228!--       GPV must be split up to the actual (ii) and the following (ii+1)
229!--       word. Shift first part of GPV to its position.
230          dummy2 = ISHFT( dummy1, nfree )
231
232!
233!--       Append bits
234          packed_ifield(ii) = packed_ifield(ii) + dummy2
235
236!
237!--       Store rest of GPV on the next word
238          ii = ii + 1
239          packed_ifield(ii) = ISHFT( dummy1, 32+nfree )
240!
241!--       Calculate starting position of the next GPV
242          startpos = -nfree
243
244       ENDIF
245
246    ENDDO
247
248!
249!-- Write the compressed 3D array
250    WRITE ( fid_avs )  packed_ifield
251
252!
253!-- Write additional informations on  FLD-file
254    IF ( my_id == 0 )  WRITE ( fid_fld, 100 )  prec, ifieldmin, nsize, length
255
256    DEALLOCATE( ifield, packed_ifield )
257
258!
259!-- Formats
260100 FORMAT ('# precision = ',I4/                                               &
261            '# feldmin   = ',I8/                                               &
262            '# nbits     = ',I2/                                               &
263            '# nskip     = ',I8)
264
265END SUBROUTINE write_compressed
Note: See TracBrowser for help on using the repository browser.