1 |
MODULE histwrite_m |
2 |
|
3 |
! From histcom.f90, version 2.1 2004/04/21 09:27:10 |
4 |
|
5 |
implicit none |
6 |
|
7 |
INTERFACE histwrite |
8 |
! The "histwrite" procedures give the data to the input-output system. |
9 |
! They trigger the operations to be performed and the writing to |
10 |
! the file if needed. |
11 |
|
12 |
! We test the work to be done at this time here so that at a |
13 |
! later stage we can call different operations and write subroutines |
14 |
! for the REAL and INTEGER interfaces. |
15 |
|
16 |
! INTEGER, INTENT(IN):: pfileid |
17 |
! The ID of the file on which this variable is to be written. |
18 |
! The variable should have been defined in this file before. |
19 |
|
20 |
! CHARACTER(LEN=*), INTENT(IN):: pvarname |
21 |
! short name of the variable |
22 |
|
23 |
! INTEGER, INTENT(IN):: pitau |
24 |
! current timestep |
25 |
|
26 |
! REAL, INTENT(IN):: pdata(:) or (:, :) or (:, :, :) |
27 |
! values of the variable |
28 |
|
29 |
! INTEGER, INTENT(IN):: nbindex |
30 |
! number of indices provided |
31 |
! If it is equal to the size of the full field as provided in histdef |
32 |
! then nothing is done. |
33 |
|
34 |
! INTEGER, INTENT(IN):: nindex(nbindex) |
35 |
! The indices used to expand the variable (pdata) onto the full field |
36 |
|
37 |
! The difference between the procedures is the rank of "pdata". |
38 |
|
39 |
MODULE PROCEDURE histwrite_r1d, histwrite_r2d, histwrite_r3d |
40 |
END INTERFACE |
41 |
|
42 |
PRIVATE histwrite_r1d, histwrite_r2d, histwrite_r3d |
43 |
|
44 |
CONTAINS |
45 |
|
46 |
SUBROUTINE histwrite_r1d(pfileid, pvarname, pitau, pdata) |
47 |
|
48 |
USE errioipsl, ONLY : histerr |
49 |
use calendar, only: isittime |
50 |
USE mathop_m, ONLY : mathop |
51 |
use histcom_var |
52 |
use histvar_seq_m, only: histvar_seq |
53 |
use histwrite_real_m, only: histwrite_real |
54 |
|
55 |
INTEGER, INTENT(IN) :: pfileid, pitau |
56 |
REAL, INTENT(IN) :: pdata(:) |
57 |
CHARACTER(LEN=*), INTENT(IN) :: pvarname |
58 |
|
59 |
! Variables local to the procedure: |
60 |
integer nbindex, nindex(size(pdata)) |
61 |
LOGICAL :: do_oper, do_write, largebuf |
62 |
INTEGER :: varid, io, nbpt_in, nbpt_out |
63 |
REAL, ALLOCATABLE, SAVE :: buff_tmp(:) |
64 |
INTEGER, SAVE :: buff_tmp_sz |
65 |
CHARACTER(LEN=7) :: tmp_opp |
66 |
|
67 |
!-------------------------------------------------------------------- |
68 |
|
69 |
nbindex = size(nindex) |
70 |
nindex = 0 |
71 |
|
72 |
! 1.0 Try to catch errors like specifying the wrong file ID. |
73 |
! Thanks Marine for showing us what errors users can make ! |
74 |
|
75 |
IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN |
76 |
CALL histerr (3, "histwrite", & |
77 |
& 'Illegal file ID in the histwrite of variable', pvarname, ' ') |
78 |
ENDIF |
79 |
|
80 |
! 1.1 Find the id of the variable to be written and the real time |
81 |
|
82 |
CALL histvar_seq (pfileid, pvarname, varid) |
83 |
|
84 |
! 2.0 do nothing for never operation |
85 |
|
86 |
tmp_opp = topp(pfileid, varid) |
87 |
|
88 |
IF (TRIM(tmp_opp) == "never") THEN |
89 |
last_opp_chk(pfileid, varid) = -99 |
90 |
last_wrt_chk(pfileid, varid) = -99 |
91 |
ENDIF |
92 |
|
93 |
! 3.0 We check if we need to do an operation |
94 |
|
95 |
IF (last_opp_chk(pfileid, varid) == pitau) THEN |
96 |
CALL histerr (3, "histwrite", & |
97 |
& 'This variable as already been analysed at the present', & |
98 |
& 'time step', ' ') |
99 |
ENDIF |
100 |
|
101 |
CALL isittime & |
102 |
& (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), & |
103 |
& last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper) |
104 |
|
105 |
! 4.0 We check if we need to write the data |
106 |
|
107 |
IF (last_wrt_chk(pfileid, varid) == pitau) THEN |
108 |
CALL histerr (3, "histwrite", & |
109 |
& 'This variable as already been written for the present', & |
110 |
& 'time step', ' ') |
111 |
ENDIF |
112 |
|
113 |
CALL isittime & |
114 |
& (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), & |
115 |
& last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write) |
116 |
|
117 |
! 5.0 histwrite called |
118 |
|
119 |
IF (do_oper.OR.do_write) THEN |
120 |
|
121 |
!- 5.1 Get the sizes of the data we will handle |
122 |
|
123 |
IF (datasz_in(pfileid, varid, 1) <= 0) THEN |
124 |
!--- There is the risk here that the user has over-sized the array. |
125 |
!--- But how can we catch this ? |
126 |
!--- In the worst case we will do impossible operations |
127 |
!--- on part of the data ! |
128 |
datasz_in(pfileid, varid, 1) = SIZE(pdata) |
129 |
datasz_in(pfileid, varid, 2) = -1 |
130 |
datasz_in(pfileid, varid, 3) = -1 |
131 |
ENDIF |
132 |
|
133 |
!- 5.2 The maximum size of the data will give the size of the buffer |
134 |
|
135 |
IF (datasz_max(pfileid, varid) <= 0) THEN |
136 |
largebuf = .FALSE. |
137 |
DO io=1, nbopp(pfileid, varid) |
138 |
IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN |
139 |
largebuf = .TRUE. |
140 |
ENDIF |
141 |
ENDDO |
142 |
IF (largebuf) THEN |
143 |
datasz_max(pfileid, varid) = & |
144 |
& scsize(pfileid, varid, 1) & |
145 |
& *scsize(pfileid, varid, 2) & |
146 |
& *scsize(pfileid, varid, 3) |
147 |
ELSE |
148 |
datasz_max(pfileid, varid) = & |
149 |
& datasz_in(pfileid, varid, 1) |
150 |
ENDIF |
151 |
ENDIF |
152 |
|
153 |
IF (.NOT.ALLOCATED(buff_tmp)) THEN |
154 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
155 |
buff_tmp_sz = datasz_max(pfileid, varid) |
156 |
ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN |
157 |
DEALLOCATE (buff_tmp) |
158 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
159 |
buff_tmp_sz = datasz_max(pfileid, varid) |
160 |
ENDIF |
161 |
|
162 |
!- We have to do the first operation anyway. |
163 |
!- Thus we do it here and change the ranke |
164 |
!- of the data at the same time. This should speed up things. |
165 |
|
166 |
nbpt_in = datasz_in(pfileid, varid, 1) |
167 |
nbpt_out = datasz_max(pfileid, varid) |
168 |
CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, & |
169 |
& missing_val, nbindex, nindex, & |
170 |
& scal(pfileid, varid, 1), nbpt_out, buff_tmp) |
171 |
CALL histwrite_real (pfileid, varid, pitau, nbpt_out, & |
172 |
& buff_tmp, nbindex, nindex, do_oper, do_write) |
173 |
ENDIF |
174 |
|
175 |
! 6.0 Manage time steps |
176 |
|
177 |
IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN |
178 |
last_opp_chk(pfileid, varid) = pitau |
179 |
last_wrt_chk(pfileid, varid) = pitau |
180 |
ELSE |
181 |
last_opp_chk(pfileid, varid) = -99 |
182 |
last_wrt_chk(pfileid, varid) = -99 |
183 |
ENDIF |
184 |
!-------------------------- |
185 |
END SUBROUTINE histwrite_r1d |
186 |
|
187 |
!=== |
188 |
|
189 |
SUBROUTINE histwrite_r2d (pfileid, pvarname, pitau, pdata) |
190 |
!-------------------------------------------------------------------- |
191 |
|
192 |
use calendar, only: isittime |
193 |
USE errioipsl, ONLY : histerr |
194 |
USE mathop_m, ONLY : mathop |
195 |
use histcom_var |
196 |
use histvar_seq_m, only: histvar_seq |
197 |
use histwrite_real_m, only: histwrite_real |
198 |
|
199 |
INTEGER, INTENT(IN) :: pfileid, pitau |
200 |
REAL, DIMENSION(:, :), INTENT(IN) :: pdata |
201 |
CHARACTER(LEN=*), INTENT(IN) :: pvarname |
202 |
|
203 |
integer nbindex, nindex(size(pdata)) |
204 |
LOGICAL :: do_oper, do_write, largebuf |
205 |
INTEGER :: varid, io, nbpt_in(1:2), nbpt_out |
206 |
REAL, ALLOCATABLE, SAVE :: buff_tmp(:) |
207 |
INTEGER, SAVE :: buff_tmp_sz |
208 |
CHARACTER(LEN=7) :: tmp_opp |
209 |
|
210 |
!-------------------------------------------------------------------- |
211 |
|
212 |
nbindex = size(nindex) |
213 |
nindex = 0 |
214 |
|
215 |
! 1.0 Try to catch errors like specifying the wrong file ID. |
216 |
! Thanks Marine for showing us what errors users can make ! |
217 |
|
218 |
IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN |
219 |
CALL histerr (3, "histwrite", & |
220 |
& 'Illegal file ID in the histwrite of variable', pvarname, ' ') |
221 |
ENDIF |
222 |
|
223 |
! 1.1 Find the id of the variable to be written and the real time |
224 |
|
225 |
CALL histvar_seq (pfileid, pvarname, varid) |
226 |
|
227 |
! 2.0 do nothing for never operation |
228 |
|
229 |
tmp_opp = topp(pfileid, varid) |
230 |
|
231 |
IF (TRIM(tmp_opp) == "never") THEN |
232 |
last_opp_chk(pfileid, varid) = -99 |
233 |
last_wrt_chk(pfileid, varid) = -99 |
234 |
ENDIF |
235 |
|
236 |
! 3.0 We check if we need to do an operation |
237 |
|
238 |
IF (last_opp_chk(pfileid, varid) == pitau) THEN |
239 |
CALL histerr (3, "histwrite", & |
240 |
& 'This variable as already been analysed at the present', & |
241 |
& 'time step', ' ') |
242 |
ENDIF |
243 |
|
244 |
CALL isittime & |
245 |
& (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), & |
246 |
& last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper) |
247 |
|
248 |
! 4.0 We check if we need to write the data |
249 |
|
250 |
IF (last_wrt_chk(pfileid, varid) == pitau) THEN |
251 |
CALL histerr (3, "histwrite", & |
252 |
& 'This variable as already been written for the present', & |
253 |
& 'time step', ' ') |
254 |
ENDIF |
255 |
|
256 |
CALL isittime & |
257 |
& (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), & |
258 |
& last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write) |
259 |
|
260 |
! 5.0 histwrite called |
261 |
|
262 |
IF (do_oper.OR.do_write) THEN |
263 |
|
264 |
!- 5.1 Get the sizes of the data we will handle |
265 |
|
266 |
IF (datasz_in(pfileid, varid, 1) <= 0) THEN |
267 |
!--- There is the risk here that the user has over-sized the array. |
268 |
!--- But how can we catch this ? |
269 |
!--- In the worst case we will do impossible operations |
270 |
!--- on part of the data ! |
271 |
datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1) |
272 |
datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2) |
273 |
datasz_in(pfileid, varid, 3) = -1 |
274 |
ENDIF |
275 |
|
276 |
!- 5.2 The maximum size of the data will give the size of the buffer |
277 |
|
278 |
IF (datasz_max(pfileid, varid) <= 0) THEN |
279 |
largebuf = .FALSE. |
280 |
DO io=1, nbopp(pfileid, varid) |
281 |
IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN |
282 |
largebuf = .TRUE. |
283 |
ENDIF |
284 |
ENDDO |
285 |
IF (largebuf) THEN |
286 |
datasz_max(pfileid, varid) = & |
287 |
& scsize(pfileid, varid, 1) & |
288 |
& *scsize(pfileid, varid, 2) & |
289 |
& *scsize(pfileid, varid, 3) |
290 |
ELSE |
291 |
datasz_max(pfileid, varid) = & |
292 |
& datasz_in(pfileid, varid, 1) & |
293 |
& *datasz_in(pfileid, varid, 2) |
294 |
ENDIF |
295 |
ENDIF |
296 |
|
297 |
IF (.NOT.ALLOCATED(buff_tmp)) THEN |
298 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
299 |
buff_tmp_sz = datasz_max(pfileid, varid) |
300 |
ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN |
301 |
DEALLOCATE (buff_tmp) |
302 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
303 |
buff_tmp_sz = datasz_max(pfileid, varid) |
304 |
ENDIF |
305 |
|
306 |
!- We have to do the first operation anyway. |
307 |
!- Thus we do it here and change the ranke |
308 |
!- of the data at the same time. This should speed up things. |
309 |
|
310 |
nbpt_in(1:2) = datasz_in(pfileid, varid, 1:2) |
311 |
nbpt_out = datasz_max(pfileid, varid) |
312 |
CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, & |
313 |
& missing_val, nbindex, nindex, & |
314 |
& scal(pfileid, varid, 1), nbpt_out, buff_tmp) |
315 |
CALL histwrite_real (pfileid, varid, pitau, nbpt_out, & |
316 |
& buff_tmp, nbindex, nindex, do_oper, do_write) |
317 |
ENDIF |
318 |
|
319 |
! 6.0 Manage time steps |
320 |
|
321 |
IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN |
322 |
last_opp_chk(pfileid, varid) = pitau |
323 |
last_wrt_chk(pfileid, varid) = pitau |
324 |
ELSE |
325 |
last_opp_chk(pfileid, varid) = -99 |
326 |
last_wrt_chk(pfileid, varid) = -99 |
327 |
ENDIF |
328 |
!-------------------------- |
329 |
END SUBROUTINE histwrite_r2d |
330 |
|
331 |
!=== |
332 |
|
333 |
SUBROUTINE histwrite_r3d (pfileid, pvarname, pitau, pdata) |
334 |
!-------------------------------------------------------------------- |
335 |
|
336 |
use calendar, only: isittime |
337 |
USE errioipsl, ONLY : histerr |
338 |
USE mathop_m, ONLY : mathop |
339 |
use histcom_var |
340 |
use histvar_seq_m, only: histvar_seq |
341 |
use histwrite_real_m, only: histwrite_real |
342 |
|
343 |
INTEGER, INTENT(IN) :: pfileid, pitau |
344 |
REAL, DIMENSION(:, :, :), INTENT(IN) :: pdata |
345 |
CHARACTER(LEN=*), INTENT(IN) :: pvarname |
346 |
|
347 |
integer nbindex, nindex(size(pdata)) |
348 |
LOGICAL :: do_oper, do_write, largebuf |
349 |
INTEGER :: varid, io, nbpt_in(1:3), nbpt_out |
350 |
REAL, ALLOCATABLE, SAVE :: buff_tmp(:) |
351 |
INTEGER, SAVE :: buff_tmp_sz |
352 |
CHARACTER(LEN=7) :: tmp_opp |
353 |
|
354 |
!-------------------------------------------------------------------- |
355 |
|
356 |
nbindex = size(nindex) |
357 |
nindex = 0 |
358 |
|
359 |
! 1.0 Try to catch errors like specifying the wrong file ID. |
360 |
! Thanks Marine for showing us what errors users can make ! |
361 |
|
362 |
IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN |
363 |
CALL histerr (3, "histwrite", & |
364 |
& 'Illegal file ID in the histwrite of variable', pvarname, ' ') |
365 |
ENDIF |
366 |
|
367 |
! 1.1 Find the id of the variable to be written and the real time |
368 |
|
369 |
CALL histvar_seq (pfileid, pvarname, varid) |
370 |
|
371 |
! 2.0 do nothing for never operation |
372 |
|
373 |
tmp_opp = topp(pfileid, varid) |
374 |
|
375 |
IF (TRIM(tmp_opp) == "never") THEN |
376 |
last_opp_chk(pfileid, varid) = -99 |
377 |
last_wrt_chk(pfileid, varid) = -99 |
378 |
ENDIF |
379 |
|
380 |
! 3.0 We check if we need to do an operation |
381 |
|
382 |
IF (last_opp_chk(pfileid, varid) == pitau) THEN |
383 |
CALL histerr (3, "histwrite", & |
384 |
& 'This variable as already been analysed at the present', & |
385 |
& 'time step', ' ') |
386 |
ENDIF |
387 |
|
388 |
CALL isittime & |
389 |
& (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), & |
390 |
& last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper) |
391 |
|
392 |
! 4.0 We check if we need to write the data |
393 |
|
394 |
IF (last_wrt_chk(pfileid, varid) == pitau) THEN |
395 |
CALL histerr (3, "histwrite", & |
396 |
& 'This variable as already been written for the present', & |
397 |
& 'time step', ' ') |
398 |
ENDIF |
399 |
|
400 |
CALL isittime & |
401 |
& (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), & |
402 |
& last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write) |
403 |
|
404 |
! 5.0 histwrite called |
405 |
|
406 |
IF (do_oper.OR.do_write) THEN |
407 |
|
408 |
!- 5.1 Get the sizes of the data we will handle |
409 |
|
410 |
IF (datasz_in(pfileid, varid, 1) <= 0) THEN |
411 |
!--- There is the risk here that the user has over-sized the array. |
412 |
!--- But how can we catch this ? |
413 |
!--- In the worst case we will do impossible operations |
414 |
!--- on part of the data ! |
415 |
datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1) |
416 |
datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2) |
417 |
datasz_in(pfileid, varid, 3) = SIZE(pdata, DIM=3) |
418 |
ENDIF |
419 |
|
420 |
!- 5.2 The maximum size of the data will give the size of the buffer |
421 |
|
422 |
IF (datasz_max(pfileid, varid) <= 0) THEN |
423 |
largebuf = .FALSE. |
424 |
DO io =1, nbopp(pfileid, varid) |
425 |
IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN |
426 |
largebuf = .TRUE. |
427 |
ENDIF |
428 |
ENDDO |
429 |
IF (largebuf) THEN |
430 |
datasz_max(pfileid, varid) = & |
431 |
& scsize(pfileid, varid, 1) & |
432 |
& *scsize(pfileid, varid, 2) & |
433 |
& *scsize(pfileid, varid, 3) |
434 |
ELSE |
435 |
datasz_max(pfileid, varid) = & |
436 |
& datasz_in(pfileid, varid, 1) & |
437 |
& *datasz_in(pfileid, varid, 2) & |
438 |
& *datasz_in(pfileid, varid, 3) |
439 |
ENDIF |
440 |
ENDIF |
441 |
|
442 |
IF (.NOT.ALLOCATED(buff_tmp)) THEN |
443 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
444 |
buff_tmp_sz = datasz_max(pfileid, varid) |
445 |
ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN |
446 |
DEALLOCATE (buff_tmp) |
447 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
448 |
buff_tmp_sz = datasz_max(pfileid, varid) |
449 |
ENDIF |
450 |
|
451 |
!- We have to do the first operation anyway. |
452 |
!- Thus we do it here and change the ranke |
453 |
!- of the data at the same time. This should speed up things. |
454 |
|
455 |
nbpt_in(1:3) = datasz_in(pfileid, varid, 1:3) |
456 |
nbpt_out = datasz_max(pfileid, varid) |
457 |
CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, & |
458 |
& missing_val, nbindex, nindex, & |
459 |
& scal(pfileid, varid, 1), nbpt_out, buff_tmp) |
460 |
CALL histwrite_real (pfileid, varid, pitau, nbpt_out, & |
461 |
& buff_tmp, nbindex, nindex, do_oper, do_write) |
462 |
ENDIF |
463 |
|
464 |
! 6.0 Manage time steps |
465 |
|
466 |
IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN |
467 |
last_opp_chk(pfileid, varid) = pitau |
468 |
last_wrt_chk(pfileid, varid) = pitau |
469 |
ELSE |
470 |
last_opp_chk(pfileid, varid) = -99 |
471 |
last_wrt_chk(pfileid, varid) = -99 |
472 |
ENDIF |
473 |
!-------------------------- |
474 |
END SUBROUTINE histwrite_r3d |
475 |
|
476 |
END MODULE histwrite_m |