/[lmdze]/trunk/Sources/IOIPSL/histwrite.f
ViewVC logotype

Contents of /trunk/Sources/IOIPSL/histwrite.f

Parent Directory Parent Directory | Revision Log Revision Log


Revision 45 - (show annotations)
Wed Apr 27 13:00:12 2011 UTC (13 years ago) by guez
Original Path: trunk/libf/IOIPSL/histwrite.f90
File size: 16539 byte(s)
Split file "histwrite.f90" into "histwrite.f90", "histwrite_real.f90"
and "histvar_seq.f90".

Extracted documentation from "psextbar.f" into "psextbar.txt" (out of SVN).

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

  ViewVC Help
Powered by ViewVC 1.1.21