/[lmdze]/trunk/libf/IOIPSL/histwrite.f90
ViewVC logotype

Contents of /trunk/libf/IOIPSL/histwrite.f90

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.21