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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 62 - (show annotations)
Thu Jul 26 14:37:37 2012 UTC (11 years, 9 months ago) by guez
Original Path: trunk/libf/IOIPSL/histwrite.f90
File size: 16407 byte(s) 
Changed handling of compiler in compilation system.

Removed the prefix letters "y", "p", "t" or "z" in some names of variables.

Replaced calls to NetCDF by calls to NetCDF95.

Extracted "ioget_calendar" procedures from "calendar.f90" into a
separate file.

Extracted to a separate file, "mathop2.f90", procedures that were not
part of the generic interface "mathop" in "mathop.f90".

Removed computation of "dq" in "bilan_dyn", which was not used.

In "iniadvtrac", removed schemes 20 Slopes and 30 Prather. Was not
compatible with declarations of array sizes.

In "clcdrag", "ustarhb", "vdif_kcay", "yamada4" and "coefkz", changed
the size of some arrays from "klon" to "knon".

Removed possible call to "conema3" in "physiq".

Removed unused argument "cd" in "yamada".
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
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 &
108 & (itau, date0(fileid), deltat(fileid), freq_wrt(fileid, varid), &
109 & last_wrt(fileid, varid), last_wrt_chk(fileid, 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(fileid, 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(fileid, varid, 1) = SIZE(pdata)
123 datasz_in(fileid, varid, 2) = -1
124 datasz_in(fileid, 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(fileid, varid) <= 0) THEN
130 largebuf = .FALSE.
131 DO io=1, nbopp(fileid, varid)
132 IF (INDEX(fuchnbout, sopps(fileid, varid, io)) > 0) THEN
133 largebuf = .TRUE.
134 ENDIF
135 ENDDO
136 IF (largebuf) THEN
137 datasz_max(fileid, varid) = &
138 & scsize(fileid, varid, 1) &
139 & *scsize(fileid, varid, 2) &
140 & *scsize(fileid, varid, 3)
141 ELSE
142 datasz_max(fileid, varid) = &
143 & datasz_in(fileid, varid, 1)
144 ENDIF
145 ENDIF
146
147 IF (.NOT.ALLOCATED(buff_tmp)) THEN
148 ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
149 buff_tmp_sz = datasz_max(fileid, varid)
150 ELSE IF (datasz_max(fileid, varid) > buff_tmp_sz) THEN
151 DEALLOCATE (buff_tmp)
152 ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
153 buff_tmp_sz = datasz_max(fileid, 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(fileid, varid, 1)
161 nbpt_out = datasz_max(fileid, varid)
162 CALL mathop (sopps(fileid, varid, 1), nbpt_in, pdata, &
163 & missing_val, nbindex, nindex, &
164 & scal(fileid, varid, 1), nbpt_out, buff_tmp)
165 CALL histwrite_real (fileid, varid, itau, 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(fileid, varid) = itau
173 last_wrt_chk(fileid, varid) = itau
174 ELSE
175 last_opp_chk(fileid, varid) = -99
176 last_wrt_chk(fileid, varid) = -99
177 ENDIF
178
179 END SUBROUTINE histwrite_r1d
180
181 !************************************************************************
182
183 SUBROUTINE histwrite_r2d (fileid, varname, itau, 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):: fileid, itau
196 REAL, INTENT(IN):: pdata(:, :)
197 CHARACTER(LEN=*), INTENT(IN):: varname
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 ( (fileid < 1).OR.(fileid > nb_files) ) THEN
214 CALL histerr (3, "histwrite", &
215 & 'Illegal file ID in the histwrite of variable', varname, ' ')
216 ENDIF
217
218 ! 1.1 Find the id of the variable to be written and the real time
219
220 CALL histvar_seq (fileid, varname, varid)
221
222 ! 2.0 do nothing for never operation
223
224 tmp_opp = topp(fileid, varid)
225
226 IF (TRIM(tmp_opp) == "never") THEN
227 last_opp_chk(fileid, varid) = -99
228 last_wrt_chk(fileid, varid) = -99
229 ENDIF
230
231 ! 3.0 We check if we need to do an operation
232
233 IF (last_opp_chk(fileid, varid) == itau) 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 & (itau, date0(fileid), deltat(fileid), freq_opp(fileid, varid), &
241 & last_opp(fileid, varid), last_opp_chk(fileid, varid), do_oper)
242
243 ! 4.0 We check if we need to write the data
244
245 IF (last_wrt_chk(fileid, varid) == itau) 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 & (itau, date0(fileid), deltat(fileid), freq_wrt(fileid, varid), &
253 & last_wrt(fileid, varid), last_wrt_chk(fileid, 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(fileid, 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(fileid, varid, 1) = SIZE(pdata, DIM=1)
267 datasz_in(fileid, varid, 2) = SIZE(pdata, DIM=2)
268 datasz_in(fileid, 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(fileid, varid) <= 0) THEN
274 largebuf = .FALSE.
275 DO io=1, nbopp(fileid, varid)
276 IF (INDEX(fuchnbout, sopps(fileid, varid, io)) > 0) THEN
277 largebuf = .TRUE.
278 ENDIF
279 ENDDO
280 IF (largebuf) THEN
281 datasz_max(fileid, varid) = &
282 & scsize(fileid, varid, 1) &
283 & *scsize(fileid, varid, 2) &
284 & *scsize(fileid, varid, 3)
285 ELSE
286 datasz_max(fileid, varid) = &
287 & datasz_in(fileid, varid, 1) &
288 & *datasz_in(fileid, varid, 2)
289 ENDIF
290 ENDIF
291
292 IF (.NOT.ALLOCATED(buff_tmp)) THEN
293 ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
294 buff_tmp_sz = datasz_max(fileid, varid)
295 ELSE IF (datasz_max(fileid, varid) > buff_tmp_sz) THEN
296 DEALLOCATE (buff_tmp)
297 ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
298 buff_tmp_sz = datasz_max(fileid, 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(fileid, varid, 1:2)
306 nbpt_out = datasz_max(fileid, varid)
307 CALL mathop (sopps(fileid, varid, 1), nbpt_in, pdata, &
308 & missing_val, nbindex, nindex, &
309 & scal(fileid, varid, 1), nbpt_out, buff_tmp)
310 CALL histwrite_real (fileid, varid, itau, 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(fileid, varid) = itau
318 last_wrt_chk(fileid, varid) = itau
319 ELSE
320 last_opp_chk(fileid, varid) = -99
321 last_wrt_chk(fileid, varid) = -99
322 ENDIF
323
324 END SUBROUTINE histwrite_r2d
325
326 !************************************************************************
327
328 SUBROUTINE histwrite_r3d (fileid, varname, itau, 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):: fileid, itau
341 REAL, DIMENSION(:, :, :), INTENT(IN):: pdata
342 CHARACTER(LEN=*), INTENT(IN):: varname
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 ( (fileid < 1).OR.(fileid > nb_files) ) THEN
360 CALL histerr (3, "histwrite", &
361 & 'Illegal file ID in the histwrite of variable', varname, ' ')
362 ENDIF
363
364 ! 1.1 Find the id of the variable to be written and the real time
365
366 CALL histvar_seq (fileid, varname, varid)
367
368 ! 2.0 do nothing for never operation
369
370 tmp_opp = topp(fileid, varid)
371
372 IF (TRIM(tmp_opp) == "never") THEN
373 last_opp_chk(fileid, varid) = -99
374 last_wrt_chk(fileid, varid) = -99
375 ENDIF
376
377 ! 3.0 We check if we need to do an operation
378
379 IF (last_opp_chk(fileid, varid) == itau) 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 & (itau, date0(fileid), deltat(fileid), freq_opp(fileid, varid), &
387 & last_opp(fileid, varid), last_opp_chk(fileid, varid), do_oper)
388
389 ! 4.0 We check if we need to write the data
390
391 IF (last_wrt_chk(fileid, varid) == itau) 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 & (itau, date0(fileid), deltat(fileid), freq_wrt(fileid, varid), &
399 & last_wrt(fileid, varid), last_wrt_chk(fileid, 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(fileid, 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(fileid, varid, 1) = SIZE(pdata, DIM=1)
413 datasz_in(fileid, varid, 2) = SIZE(pdata, DIM=2)
414 datasz_in(fileid, 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(fileid, varid) <= 0) THEN
420 largebuf = .FALSE.
421 DO io =1, nbopp(fileid, varid)
422 IF (INDEX(fuchnbout, sopps(fileid, varid, io)) > 0) THEN
423 largebuf = .TRUE.
424 ENDIF
425 ENDDO
426 IF (largebuf) THEN
427 datasz_max(fileid, varid) = &
428 & scsize(fileid, varid, 1) &
429 & *scsize(fileid, varid, 2) &
430 & *scsize(fileid, varid, 3)
431 ELSE
432 datasz_max(fileid, varid) = &
433 & datasz_in(fileid, varid, 1) &
434 & *datasz_in(fileid, varid, 2) &
435 & *datasz_in(fileid, varid, 3)
436 ENDIF
437 ENDIF
438
439 IF (.NOT.ALLOCATED(buff_tmp)) THEN
440 ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
441 buff_tmp_sz = datasz_max(fileid, varid)
442 ELSE IF (datasz_max(fileid, varid) > buff_tmp_sz) THEN
443 DEALLOCATE (buff_tmp)
444 ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
445 buff_tmp_sz = datasz_max(fileid, 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(fileid, varid, 1:3)
453 nbpt_out = datasz_max(fileid, varid)
454 CALL mathop (sopps(fileid, varid, 1), nbpt_in, pdata, &
455 & missing_val, nbindex, nindex, &
456 & scal(fileid, varid, 1), nbpt_out, buff_tmp)
457 CALL histwrite_real (fileid, varid, itau, 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(fileid, varid) = itau
465 last_wrt_chk(fileid, varid) = itau
466 ELSE
467 last_opp_chk(fileid, varid) = -99
468 last_wrt_chk(fileid, varid) = -99
469 ENDIF
470
471 END SUBROUTINE histwrite_r3d
472
473 END MODULE histwrite_m
  ViewVC Help
Powered by ViewVC 1.1.21