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

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

ONLY-attribute added to USE-statements,
kind-parameters added to all INTEGER and REAL declaration statements,
kinds are defined in new module kinds,
old module precision_kind is removed,
revision history before 2012 removed,
comment fields (!:) to be used for variable explanations added to all variable declaration statements

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