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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 57 - (show annotations)
Mon Jan 30 12:54:02 2012 UTC (12 years, 3 months ago) by guez
Original Path: trunk/libf/IOIPSL/histwrite.f90
File size: 16601 byte(s) 
Write used namelists to file "" instead of standard output.

Avoid aliasing in "inidissip" in calls to "divgrad2", "divgrad",
"gradiv2", "gradiv", "nxgraro2" and "nxgrarot". Add a degenerate
dimension to arrays so they have rank 3, like the dummy arguments in
"divgrad2", "divgrad", "gradiv2", "gradiv", "nxgraro2" and "nxgrarot".

Extract the initialization part from "bilan_dyn" and make a separate
procedure, "init_dynzon", from it.

Move variables from modules "iniprint" and "logic" to module
"conf_gcm_m".

Promote internal procedures of "fxy" to private procedures of module
"fxy_m".

Extracted documentation from "inigeom". Removed useless "save"
attributes. Removed useless intermediate variables. Extracted
processing of poles from loop on latitudes. Write coordinates to file
"longitude_latitude.txt" instead of standard output.

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