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

Contents of /trunk/IOIPSL/histwrite.f

Parent Directory Parent Directory | Revision Log Revision Log


Revision 82 - (show annotations)
Wed Mar 5 14:57:53 2014 UTC (10 years, 2 months ago) by guez
File size: 15920 byte(s)
Changed all ".f90" suffixes to ".f".
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) CALL histerr (3, "histwrite", &
229 'This variable as already been analysed at the present', &
230 'time step', ' ')
231
232 CALL isittime(itau, date0(fileid), deltat(fileid), &
233 freq_opp(fileid, varid), last_opp(fileid, varid), &
234 last_opp_chk(fileid, varid), do_oper)
235
236 ! 4.0 We check if we need to write the data
237
238 IF (last_wrt_chk(fileid, varid) == itau) THEN
239 CALL histerr (3, "histwrite", &
240 'This variable as already been written for the present', &
241 'time step', ' ')
242 ENDIF
243
244 CALL isittime &
245 (itau, date0(fileid), deltat(fileid), freq_wrt(fileid, varid), &
246 last_wrt(fileid, varid), last_wrt_chk(fileid, varid), do_write)
247
248 ! 5.0 histwrite called
249
250 IF (do_oper.OR.do_write) THEN
251
252 !- 5.1 Get the sizes of the data we will handle
253
254 IF (datasz_in(fileid, varid, 1) <= 0) THEN
255 !--- There is the risk here that the user has over-sized the array.
256 !--- But how can we catch this ?
257 !--- In the worst case we will do impossible operations
258 !--- on part of the data !
259 datasz_in(fileid, varid, 1) = SIZE(pdata, DIM=1)
260 datasz_in(fileid, varid, 2) = SIZE(pdata, DIM=2)
261 datasz_in(fileid, varid, 3) = -1
262 ENDIF
263
264 !- 5.2 The maximum size of the data will give the size of the buffer
265
266 IF (datasz_max(fileid, varid) <= 0) THEN
267 largebuf = .FALSE.
268 DO io=1, nbopp(fileid, varid)
269 IF (INDEX(fuchnbout, sopps(fileid, varid, io)) > 0) THEN
270 largebuf = .TRUE.
271 ENDIF
272 ENDDO
273 IF (largebuf) THEN
274 datasz_max(fileid, varid) = &
275 scsize(fileid, varid, 1) &
276 *scsize(fileid, varid, 2) &
277 *scsize(fileid, varid, 3)
278 ELSE
279 datasz_max(fileid, varid) = &
280 datasz_in(fileid, varid, 1) &
281 *datasz_in(fileid, varid, 2)
282 ENDIF
283 ENDIF
284
285 IF (.NOT.ALLOCATED(buff_tmp)) THEN
286 ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
287 buff_tmp_sz = datasz_max(fileid, varid)
288 ELSE IF (datasz_max(fileid, varid) > buff_tmp_sz) THEN
289 DEALLOCATE (buff_tmp)
290 ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
291 buff_tmp_sz = datasz_max(fileid, varid)
292 ENDIF
293
294 !- We have to do the first operation anyway.
295 !- Thus we do it here and change the ranke
296 !- of the data at the same time. This should speed up things.
297
298 nbpt_in(1:2) = datasz_in(fileid, varid, 1:2)
299 nbpt_out = datasz_max(fileid, varid)
300 CALL mathop (sopps(fileid, varid, 1), nbpt_in, pdata, &
301 missing_val, nbindex, nindex, &
302 scal(fileid, varid, 1), nbpt_out, buff_tmp)
303 CALL histwrite_real (fileid, varid, itau, nbpt_out, &
304 buff_tmp, nbindex, nindex, do_oper, do_write)
305 ENDIF
306
307 ! 6.0 Manage time steps
308
309 IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
310 last_opp_chk(fileid, varid) = itau
311 last_wrt_chk(fileid, varid) = itau
312 ELSE
313 last_opp_chk(fileid, varid) = -99
314 last_wrt_chk(fileid, varid) = -99
315 ENDIF
316
317 END SUBROUTINE histwrite_r2d
318
319 !************************************************************************
320
321 SUBROUTINE histwrite_r3d (fileid, varname, itau, pdata)
322
323 use calendar, only: isittime
324 USE errioipsl, ONLY: histerr
325 USE mathop_m, ONLY: mathop
326 USE histcom_var, ONLY: datasz_in, datasz_max, date0, deltat, &
327 freq_opp, freq_wrt, fuchnbout, last_opp, last_opp_chk, last_wrt, &
328 last_wrt_chk, missing_val, nbopp, nb_files, scal, scsize, sopps, &
329 topp
330 use histvar_seq_m, only: histvar_seq
331 use histwrite_real_m, only: histwrite_real
332
333 INTEGER, INTENT(IN):: fileid, itau
334 REAL, DIMENSION(:, :, :), INTENT(IN):: pdata
335 CHARACTER(LEN=*), INTENT(IN):: varname
336
337 integer nbindex, nindex(size(pdata))
338 LOGICAL:: do_oper, do_write, largebuf
339 INTEGER:: varid, io, nbpt_in(1:3), nbpt_out
340 REAL, ALLOCATABLE, SAVE:: buff_tmp(:)
341 INTEGER, SAVE:: buff_tmp_sz
342 CHARACTER(LEN=7):: tmp_opp
343
344 !--------------------------------------------------------------------
345
346 nbindex = size(nindex)
347 nindex = 0
348
349 ! 1.0 Try to catch errors like specifying the wrong file ID.
350 ! Thanks Marine for showing us what errors users can make !
351
352 IF ( (fileid < 1).OR.(fileid > nb_files) ) THEN
353 CALL histerr (3, "histwrite", &
354 'Illegal file ID in the histwrite of variable', varname, ' ')
355 ENDIF
356
357 ! 1.1 Find the id of the variable to be written and the real time
358
359 CALL histvar_seq (fileid, varname, varid)
360
361 ! 2.0 do nothing for never operation
362
363 tmp_opp = topp(fileid, varid)
364
365 IF (TRIM(tmp_opp) == "never") THEN
366 last_opp_chk(fileid, varid) = -99
367 last_wrt_chk(fileid, varid) = -99
368 ENDIF
369
370 ! 3.0 We check if we need to do an operation
371
372 IF (last_opp_chk(fileid, varid) == itau) THEN
373 CALL histerr (3, "histwrite", &
374 'This variable as already been analysed at the present', &
375 'time step', ' ')
376 ENDIF
377
378 CALL isittime &
379 (itau, date0(fileid), deltat(fileid), freq_opp(fileid, varid), &
380 last_opp(fileid, varid), last_opp_chk(fileid, varid), do_oper)
381
382 ! 4.0 We check if we need to write the data
383
384 IF (last_wrt_chk(fileid, varid) == itau) THEN
385 CALL histerr (3, "histwrite", &
386 'This variable as already been written for the present', &
387 'time step', ' ')
388 ENDIF
389
390 CALL isittime &
391 (itau, date0(fileid), deltat(fileid), freq_wrt(fileid, varid), &
392 last_wrt(fileid, varid), last_wrt_chk(fileid, varid), do_write)
393
394 ! 5.0 histwrite called
395
396 IF (do_oper.OR.do_write) THEN
397
398 !- 5.1 Get the sizes of the data we will handle
399
400 IF (datasz_in(fileid, varid, 1) <= 0) THEN
401 !--- There is the risk here that the user has over-sized the array.
402 !--- But how can we catch this ?
403 !--- In the worst case we will do impossible operations
404 !--- on part of the data !
405 datasz_in(fileid, varid, 1) = SIZE(pdata, DIM=1)
406 datasz_in(fileid, varid, 2) = SIZE(pdata, DIM=2)
407 datasz_in(fileid, varid, 3) = SIZE(pdata, DIM=3)
408 ENDIF
409
410 !- 5.2 The maximum size of the data will give the size of the buffer
411
412 IF (datasz_max(fileid, varid) <= 0) THEN
413 largebuf = .FALSE.
414 DO io =1, nbopp(fileid, varid)
415 IF (INDEX(fuchnbout, sopps(fileid, varid, io)) > 0) THEN
416 largebuf = .TRUE.
417 ENDIF
418 ENDDO
419 IF (largebuf) THEN
420 datasz_max(fileid, varid) = &
421 scsize(fileid, varid, 1) &
422 *scsize(fileid, varid, 2) &
423 *scsize(fileid, varid, 3)
424 ELSE
425 datasz_max(fileid, varid) = &
426 datasz_in(fileid, varid, 1) &
427 *datasz_in(fileid, varid, 2) &
428 *datasz_in(fileid, varid, 3)
429 ENDIF
430 ENDIF
431
432 IF (.NOT.ALLOCATED(buff_tmp)) THEN
433 ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
434 buff_tmp_sz = datasz_max(fileid, varid)
435 ELSE IF (datasz_max(fileid, varid) > buff_tmp_sz) THEN
436 DEALLOCATE (buff_tmp)
437 ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
438 buff_tmp_sz = datasz_max(fileid, varid)
439 ENDIF
440
441 !- We have to do the first operation anyway.
442 !- Thus we do it here and change the ranke
443 !- of the data at the same time. This should speed up things.
444
445 nbpt_in(1:3) = datasz_in(fileid, varid, 1:3)
446 nbpt_out = datasz_max(fileid, varid)
447 CALL mathop (sopps(fileid, varid, 1), nbpt_in, pdata, &
448 missing_val, nbindex, nindex, &
449 scal(fileid, varid, 1), nbpt_out, buff_tmp)
450 CALL histwrite_real (fileid, varid, itau, nbpt_out, &
451 buff_tmp, nbindex, nindex, do_oper, do_write)
452 ENDIF
453
454 ! 6.0 Manage time steps
455
456 IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
457 last_opp_chk(fileid, varid) = itau
458 last_wrt_chk(fileid, varid) = itau
459 ELSE
460 last_opp_chk(fileid, varid) = -99
461 last_wrt_chk(fileid, varid) = -99
462 ENDIF
463
464 END SUBROUTINE histwrite_r3d
465
466 END MODULE histwrite_m

  ViewVC Help
Powered by ViewVC 1.1.21