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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 32 - (show annotations)
Tue Apr 6 17:52:58 2010 UTC (14 years, 1 month ago) by guez
Original Path: trunk/libf/IOIPSL/histwrite.f90
File size: 29199 byte(s) 
Split "stringop.f90" into single-procedure files. Gathered files in directory
"IOIPSL/Stringop".

Split "flincom.f90" into "flincom.f90" and "flinget.f90". Removed
unused procedures from module "flincom". Removed unused argument
"filename" of procedure "flinopen_nozoom".

Removed unused files.

Split "grid_change.f90" into "grid_change.f90" and
"gr_phy_write_3d.f90".

Removed unused procedures from modules "calendar", "ioipslmpp",
"grid_atob", "gath_cpl" and "getincom". Removed unused procedures in
files "ppm3d.f" and "thermcell.f".

Split "mathelp.f90" into "mathelp.f90" and "mathop.f90".

Removed unused variable "dpres" of module "comvert".

Use argument "itau" instead of local variables "iadvtr" and "first" to
control algorithm in procedure "fluxstokenc".

Removed unused arguments of procedure "integrd".

Removed useless computations at the end of procedure "leapfrog".

Merged common block "matrfil" into module "parafilt".
1 MODULE histwrite_m
2
3 ! From histcom.f90, version 2.1 2004/04/21 09:27:10
4
5 implicit none
6
7 PRIVATE
8 PUBLIC histwrite
9
10 INTERFACE histwrite
11 ! The "histwrite" procedures give the data to the input-output system.
12 ! They trigger the operations to be performed and the writing to
13 ! the file if needed.
14
15 ! We test the work to be done at this time here so that at a
16 ! later stage we can call different operations and write subroutines
17 ! for the REAL and INTEGER interfaces.
18
19 ! INTEGER, INTENT(IN):: pfileid
20 ! The ID of the file on which this variable is to be written.
21 ! The variable should have been defined in this file before.
22
23 ! CHARACTER(LEN=*), INTENT(IN):: pvarname
24 ! short name of the variable
25
26 ! INTEGER, INTENT(IN):: pitau
27 ! current timestep
28
29 ! REAL, INTENT(IN):: pdata(:) or (:, :) or (:, :, :)
30 ! values of the variable
31
32 ! INTEGER, INTENT(IN):: nbindex
33 ! number of indices provided
34 ! If it is equal to the size of the full field as provided in histdef
35 ! then nothing is done.
36
37 ! INTEGER, INTENT(IN):: nindex(nbindex)
38 ! The indices used to expand the variable (pdata) onto the full field
39
40 ! The difference between the procedures is the rank of "pdata".
41
42 MODULE PROCEDURE histwrite_r1d, histwrite_r2d, histwrite_r3d
43 END INTERFACE
44
45 CONTAINS
46
47 SUBROUTINE histwrite_r1d(pfileid, pvarname, pitau, pdata)
48
49 USE errioipsl, ONLY : histerr
50 use calendar, only: isittime
51 USE mathop_m, ONLY : mathop
52 use histcom_var
53
54 INTEGER, INTENT(IN) :: pfileid, pitau
55 REAL, INTENT(IN) :: pdata(:)
56 CHARACTER(LEN=*), INTENT(IN) :: pvarname
57
58 ! Variables local to the procedure:
59 integer nbindex, nindex(size(pdata))
60 LOGICAL :: do_oper, do_write, largebuf
61 INTEGER :: varid, io, nbpt_in, nbpt_out
62 REAL, ALLOCATABLE, SAVE :: buff_tmp(:)
63 INTEGER, SAVE :: buff_tmp_sz
64 CHARACTER(LEN=7) :: tmp_opp
65
66 !--------------------------------------------------------------------
67
68 nbindex = size(nindex)
69 nindex = 0
70
71 ! 1.0 Try to catch errors like specifying the wrong file ID.
72 ! Thanks Marine for showing us what errors users can make !
73
74 IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN
75 CALL histerr (3, "histwrite", &
76 & 'Illegal file ID in the histwrite of variable', pvarname, ' ')
77 ENDIF
78
79 ! 1.1 Find the id of the variable to be written and the real time
80
81 CALL histvar_seq (pfileid, pvarname, varid)
82
83 ! 2.0 do nothing for never operation
84
85 tmp_opp = topp(pfileid, varid)
86
87 IF (TRIM(tmp_opp) == "never") THEN
88 last_opp_chk(pfileid, varid) = -99
89 last_wrt_chk(pfileid, varid) = -99
90 ENDIF
91
92 ! 3.0 We check if we need to do an operation
93
94 IF (last_opp_chk(pfileid, varid) == pitau) THEN
95 CALL histerr (3, "histwrite", &
96 & 'This variable as already been analysed at the present', &
97 & 'time step', ' ')
98 ENDIF
99
100 CALL isittime &
101 & (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), &
102 & last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper)
103
104 ! 4.0 We check if we need to write the data
105
106 IF (last_wrt_chk(pfileid, varid) == pitau) THEN
107 CALL histerr (3, "histwrite", &
108 & 'This variable as already been written for the present', &
109 & 'time step', ' ')
110 ENDIF
111
112 CALL isittime &
113 & (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), &
114 & last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write)
115
116 ! 5.0 histwrite called
117
118 IF (do_oper.OR.do_write) THEN
119
120 !- 5.1 Get the sizes of the data we will handle
121
122 IF (datasz_in(pfileid, varid, 1) <= 0) THEN
123 !--- There is the risk here that the user has over-sized the array.
124 !--- But how can we catch this ?
125 !--- In the worst case we will do impossible operations
126 !--- on part of the data !
127 datasz_in(pfileid, varid, 1) = SIZE(pdata)
128 datasz_in(pfileid, varid, 2) = -1
129 datasz_in(pfileid, varid, 3) = -1
130 ENDIF
131
132 !- 5.2 The maximum size of the data will give the size of the buffer
133
134 IF (datasz_max(pfileid, varid) <= 0) THEN
135 largebuf = .FALSE.
136 DO io=1, nbopp(pfileid, varid)
137 IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN
138 largebuf = .TRUE.
139 ENDIF
140 ENDDO
141 IF (largebuf) THEN
142 datasz_max(pfileid, varid) = &
143 & scsize(pfileid, varid, 1) &
144 & *scsize(pfileid, varid, 2) &
145 & *scsize(pfileid, varid, 3)
146 ELSE
147 datasz_max(pfileid, varid) = &
148 & datasz_in(pfileid, varid, 1)
149 ENDIF
150 ENDIF
151
152 IF (.NOT.ALLOCATED(buff_tmp)) THEN
153 ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))
154 buff_tmp_sz = datasz_max(pfileid, varid)
155 ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN
156 DEALLOCATE (buff_tmp)
157 ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))
158 buff_tmp_sz = datasz_max(pfileid, varid)
159 ENDIF
160
161 !- We have to do the first operation anyway.
162 !- Thus we do it here and change the ranke
163 !- of the data at the same time. This should speed up things.
164
165 nbpt_in = datasz_in(pfileid, varid, 1)
166 nbpt_out = datasz_max(pfileid, varid)
167 CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, &
168 & missing_val, nbindex, nindex, &
169 & scal(pfileid, varid, 1), nbpt_out, buff_tmp)
170 CALL histwrite_real (pfileid, varid, pitau, nbpt_out, &
171 & buff_tmp, nbindex, nindex, do_oper, do_write)
172 ENDIF
173
174 ! 6.0 Manage time steps
175
176 IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
177 last_opp_chk(pfileid, varid) = pitau
178 last_wrt_chk(pfileid, varid) = pitau
179 ELSE
180 last_opp_chk(pfileid, varid) = -99
181 last_wrt_chk(pfileid, varid) = -99
182 ENDIF
183 !--------------------------
184 END SUBROUTINE histwrite_r1d
185
186 !===
187
188 SUBROUTINE histwrite_r2d (pfileid, pvarname, pitau, pdata)
189 !--------------------------------------------------------------------
190
191 use calendar, only: isittime
192 USE errioipsl, ONLY : histerr
193 USE mathop_m, ONLY : mathop
194 use histcom_var
195
196 INTEGER, INTENT(IN) :: pfileid, pitau
197 REAL, DIMENSION(:, :), INTENT(IN) :: pdata
198 CHARACTER(LEN=*), INTENT(IN) :: pvarname
199
200 integer nbindex, nindex(size(pdata))
201 LOGICAL :: do_oper, do_write, largebuf
202 INTEGER :: varid, io, nbpt_in(1:2), nbpt_out
203 REAL, ALLOCATABLE, SAVE :: buff_tmp(:)
204 INTEGER, SAVE :: buff_tmp_sz
205 CHARACTER(LEN=7) :: tmp_opp
206
207 !--------------------------------------------------------------------
208
209 nbindex = size(nindex)
210 nindex = 0
211
212 ! 1.0 Try to catch errors like specifying the wrong file ID.
213 ! Thanks Marine for showing us what errors users can make !
214
215 IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN
216 CALL histerr (3, "histwrite", &
217 & 'Illegal file ID in the histwrite of variable', pvarname, ' ')
218 ENDIF
219
220 ! 1.1 Find the id of the variable to be written and the real time
221
222 CALL histvar_seq (pfileid, pvarname, varid)
223
224 ! 2.0 do nothing for never operation
225
226 tmp_opp = topp(pfileid, varid)
227
228 IF (TRIM(tmp_opp) == "never") THEN
229 last_opp_chk(pfileid, varid) = -99
230 last_wrt_chk(pfileid, varid) = -99
231 ENDIF
232
233 ! 3.0 We check if we need to do an operation
234
235 IF (last_opp_chk(pfileid, varid) == pitau) THEN
236 CALL histerr (3, "histwrite", &
237 & 'This variable as already been analysed at the present', &
238 & 'time step', ' ')
239 ENDIF
240
241 CALL isittime &
242 & (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), &
243 & last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper)
244
245 ! 4.0 We check if we need to write the data
246
247 IF (last_wrt_chk(pfileid, varid) == pitau) THEN
248 CALL histerr (3, "histwrite", &
249 & 'This variable as already been written for the present', &
250 & 'time step', ' ')
251 ENDIF
252
253 CALL isittime &
254 & (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), &
255 & last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write)
256
257 ! 5.0 histwrite called
258
259 IF (do_oper.OR.do_write) THEN
260
261 !- 5.1 Get the sizes of the data we will handle
262
263 IF (datasz_in(pfileid, varid, 1) <= 0) THEN
264 !--- There is the risk here that the user has over-sized the array.
265 !--- But how can we catch this ?
266 !--- In the worst case we will do impossible operations
267 !--- on part of the data !
268 datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1)
269 datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2)
270 datasz_in(pfileid, varid, 3) = -1
271 ENDIF
272
273 !- 5.2 The maximum size of the data will give the size of the buffer
274
275 IF (datasz_max(pfileid, varid) <= 0) THEN
276 largebuf = .FALSE.
277 DO io=1, nbopp(pfileid, varid)
278 IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN
279 largebuf = .TRUE.
280 ENDIF
281 ENDDO
282 IF (largebuf) THEN
283 datasz_max(pfileid, varid) = &
284 & scsize(pfileid, varid, 1) &
285 & *scsize(pfileid, varid, 2) &
286 & *scsize(pfileid, varid, 3)
287 ELSE
288 datasz_max(pfileid, varid) = &
289 & datasz_in(pfileid, varid, 1) &
290 & *datasz_in(pfileid, varid, 2)
291 ENDIF
292 ENDIF
293
294 IF (.NOT.ALLOCATED(buff_tmp)) THEN
295 ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))
296 buff_tmp_sz = datasz_max(pfileid, varid)
297 ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN
298 DEALLOCATE (buff_tmp)
299 ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))
300 buff_tmp_sz = datasz_max(pfileid, varid)
301 ENDIF
302
303 !- We have to do the first operation anyway.
304 !- Thus we do it here and change the ranke
305 !- of the data at the same time. This should speed up things.
306
307 nbpt_in(1:2) = datasz_in(pfileid, varid, 1:2)
308 nbpt_out = datasz_max(pfileid, varid)
309 CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, &
310 & missing_val, nbindex, nindex, &
311 & scal(pfileid, varid, 1), nbpt_out, buff_tmp)
312 CALL histwrite_real (pfileid, varid, pitau, nbpt_out, &
313 & buff_tmp, nbindex, nindex, do_oper, do_write)
314 ENDIF
315
316 ! 6.0 Manage time steps
317
318 IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
319 last_opp_chk(pfileid, varid) = pitau
320 last_wrt_chk(pfileid, varid) = pitau
321 ELSE
322 last_opp_chk(pfileid, varid) = -99
323 last_wrt_chk(pfileid, varid) = -99
324 ENDIF
325 !--------------------------
326 END SUBROUTINE histwrite_r2d
327
328 !===
329
330 SUBROUTINE histwrite_r3d (pfileid, pvarname, pitau, pdata)
331 !--------------------------------------------------------------------
332
333 use calendar, only: isittime
334 USE errioipsl, ONLY : histerr
335 USE mathop_m, ONLY : mathop
336 use histcom_var
337
338 INTEGER, INTENT(IN) :: pfileid, pitau
339 REAL, DIMENSION(:, :, :), INTENT(IN) :: pdata
340 CHARACTER(LEN=*), INTENT(IN) :: pvarname
341
342 integer nbindex, nindex(size(pdata))
343 LOGICAL :: do_oper, do_write, largebuf
344 INTEGER :: varid, io, nbpt_in(1:3), nbpt_out
345 REAL, ALLOCATABLE, SAVE :: buff_tmp(:)
346 INTEGER, SAVE :: buff_tmp_sz
347 CHARACTER(LEN=7) :: tmp_opp
348
349 !--------------------------------------------------------------------
350
351 nbindex = size(nindex)
352 nindex = 0
353
354 ! 1.0 Try to catch errors like specifying the wrong file ID.
355 ! Thanks Marine for showing us what errors users can make !
356
357 IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN
358 CALL histerr (3, "histwrite", &
359 & 'Illegal file ID in the histwrite of variable', pvarname, ' ')
360 ENDIF
361
362 ! 1.1 Find the id of the variable to be written and the real time
363
364 CALL histvar_seq (pfileid, pvarname, varid)
365
366 ! 2.0 do nothing for never operation
367
368 tmp_opp = topp(pfileid, varid)
369
370 IF (TRIM(tmp_opp) == "never") THEN
371 last_opp_chk(pfileid, varid) = -99
372 last_wrt_chk(pfileid, varid) = -99
373 ENDIF
374
375 ! 3.0 We check if we need to do an operation
376
377 IF (last_opp_chk(pfileid, varid) == pitau) THEN
378 CALL histerr (3, "histwrite", &
379 & 'This variable as already been analysed at the present', &
380 & 'time step', ' ')
381 ENDIF
382
383 CALL isittime &
384 & (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), &
385 & last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper)
386
387 ! 4.0 We check if we need to write the data
388
389 IF (last_wrt_chk(pfileid, varid) == pitau) THEN
390 CALL histerr (3, "histwrite", &
391 & 'This variable as already been written for the present', &
392 & 'time step', ' ')
393 ENDIF
394
395 CALL isittime &
396 & (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), &
397 & last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write)
398
399 ! 5.0 histwrite called
400
401 IF (do_oper.OR.do_write) THEN
402
403 !- 5.1 Get the sizes of the data we will handle
404
405 IF (datasz_in(pfileid, varid, 1) <= 0) THEN
406 !--- There is the risk here that the user has over-sized the array.
407 !--- But how can we catch this ?
408 !--- In the worst case we will do impossible operations
409 !--- on part of the data !
410 datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1)
411 datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2)
412 datasz_in(pfileid, varid, 3) = SIZE(pdata, DIM=3)
413 ENDIF
414
415 !- 5.2 The maximum size of the data will give the size of the buffer
416
417 IF (datasz_max(pfileid, varid) <= 0) THEN
418 largebuf = .FALSE.
419 DO io =1, nbopp(pfileid, varid)
420 IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN
421 largebuf = .TRUE.
422 ENDIF
423 ENDDO
424 IF (largebuf) THEN
425 datasz_max(pfileid, varid) = &
426 & scsize(pfileid, varid, 1) &
427 & *scsize(pfileid, varid, 2) &
428 & *scsize(pfileid, varid, 3)
429 ELSE
430 datasz_max(pfileid, varid) = &
431 & datasz_in(pfileid, varid, 1) &
432 & *datasz_in(pfileid, varid, 2) &
433 & *datasz_in(pfileid, varid, 3)
434 ENDIF
435 ENDIF
436
437 IF (.NOT.ALLOCATED(buff_tmp)) THEN
438 ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))
439 buff_tmp_sz = datasz_max(pfileid, varid)
440 ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN
441 DEALLOCATE (buff_tmp)
442 ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))
443 buff_tmp_sz = datasz_max(pfileid, varid)
444 ENDIF
445
446 !- We have to do the first operation anyway.
447 !- Thus we do it here and change the ranke
448 !- of the data at the same time. This should speed up things.
449
450 nbpt_in(1:3) = datasz_in(pfileid, varid, 1:3)
451 nbpt_out = datasz_max(pfileid, varid)
452 CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, &
453 & missing_val, nbindex, nindex, &
454 & scal(pfileid, varid, 1), nbpt_out, buff_tmp)
455 CALL histwrite_real (pfileid, varid, pitau, nbpt_out, &
456 & buff_tmp, nbindex, nindex, do_oper, do_write)
457 ENDIF
458
459 ! 6.0 Manage time steps
460
461 IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
462 last_opp_chk(pfileid, varid) = pitau
463 last_wrt_chk(pfileid, varid) = pitau
464 ELSE
465 last_opp_chk(pfileid, varid) = -99
466 last_wrt_chk(pfileid, varid) = -99
467 ENDIF
468 !--------------------------
469 END SUBROUTINE histwrite_r3d
470
471 !===
472
473 SUBROUTINE histwrite_real(pfileid, varid, pitau, nbdpt, buff_tmp, nbindex, &
474 nindex, do_oper, do_write)
475
476 ! This subroutine is internal and does the calculations and writing
477 ! if needed. At a later stage it should be split into an operation
478 ! and writing subroutines.
479 !--------------------------------------------------------------------
480
481 USE mathop_m, ONLY : mathop
482 USE mathelp, ONLY : trans_buff, moycum
483 use netcdf, only: NF90_PUT_VAR
484 use histcom_var
485
486 INTEGER, INTENT(IN) :: pfileid, pitau, varid, &
487 & nbindex, nindex(nbindex), nbdpt
488 REAL, DIMENSION(:) :: buff_tmp
489 LOGICAL, INTENT(IN) :: do_oper, do_write
490
491 INTEGER :: tsz, ncid, ncvarid
492 INTEGER :: i, iret, ipt, itax
493 INTEGER :: io, nbin, nbout
494 INTEGER, DIMENSION(4) :: corner, edges
495 INTEGER :: itime
496
497 REAL :: rtime
498 CHARACTER(LEN=7) :: tmp_opp
499
500 REAL, ALLOCATABLE, SAVE :: buff_tmp2(:)
501 INTEGER, SAVE :: buff_tmp2_sz
502 REAL, ALLOCATABLE, SAVE :: buffer_used(:)
503 INTEGER, SAVE :: buffer_sz
504
505 !--------------------------------------------------------------------
506
507 ! The sizes which can be encoutered
508
509 tsz = zsize(pfileid, varid, 1)*zsize(pfileid, varid, 2)*zsize(pfileid, varid, 3)
510
511 ! 1.0 We allocate the memory needed to store the data between write
512 ! and the temporary space needed for operations.
513 ! We have to keep precedent buffer if needed
514
515 IF (.NOT. ALLOCATED(buffer)) THEN
516 ALLOCATE(buffer(buff_pos))
517 buffer_sz = buff_pos
518 buffer(:)=0.0
519 ELSE IF (buffer_sz < buff_pos) THEN
520 IF (SUM(buffer)/=0.0) THEN
521 ALLOCATE (buffer_used(buffer_sz))
522 buffer_used(:)=buffer(:)
523 DEALLOCATE (buffer)
524 ALLOCATE (buffer(buff_pos))
525 buffer_sz = buff_pos
526 buffer(:SIZE(buffer_used))=buffer_used
527 DEALLOCATE (buffer_used)
528 ELSE
529 DEALLOCATE (buffer)
530 ALLOCATE (buffer(buff_pos))
531 buffer_sz = buff_pos
532 buffer(:)=0.0
533 ENDIF
534 ENDIF
535
536 ! The buffers are only deallocated when more space is needed. This
537 ! reduces the umber of allocates but increases memory needs.
538
539 IF (.NOT.ALLOCATED(buff_tmp2)) THEN
540 ALLOCATE (buff_tmp2(datasz_max(pfileid, varid)))
541 buff_tmp2_sz = datasz_max(pfileid, varid)
542 ELSE IF ( datasz_max(pfileid, varid) > buff_tmp2_sz) THEN
543 DEALLOCATE (buff_tmp2)
544 ALLOCATE (buff_tmp2(datasz_max(pfileid, varid)))
545 buff_tmp2_sz = datasz_max(pfileid, varid)
546 ENDIF
547
548 rtime = pitau * deltat(pfileid)
549 tmp_opp = topp(pfileid, varid)
550
551 ! 3.0 Do the operations or transfer the slab of data into buff_tmp
552
553 ! 3.1 DO the Operations only if needed
554
555 IF ( do_oper ) THEN
556 i = pfileid
557 nbout = nbdpt
558
559 !- 3.4 We continue the sequence of operations
560 !- we started in the interface routine
561
562 DO io = 2, nbopp(i, varid), 2
563 nbin = nbout
564 nbout = datasz_max(i, varid)
565 CALL mathop(sopps(i, varid, io), nbin, buff_tmp, missing_val, &
566 & nbindex, nindex, scal(i, varid, io), nbout, buff_tmp2)
567
568 nbin = nbout
569 nbout = datasz_max(i, varid)
570 CALL mathop(sopps(i, varid, io+1), nbin, buff_tmp2, missing_val, &
571 & nbindex, nindex, scal(i, varid, io+1), nbout, buff_tmp)
572 ENDDO
573
574 ! 3.5 Zoom into the data
575
576 CALL trans_buff &
577 & (zorig(i, varid, 1), zsize(i, varid, 1), &
578 & zorig(i, varid, 2), zsize(i, varid, 2), &
579 & zorig(i, varid, 3), zsize(i, varid, 3), &
580 & scsize(i, varid, 1), scsize(i, varid, 2), scsize(i, varid, 3), &
581 & buff_tmp, buff_tmp2_sz, buff_tmp2)
582
583 !- 5.0 Do the operations if needed. In the case of instantaneous
584 !- output we do not transfer to the buffer.
585
586 ipt = point(pfileid, varid)
587
588 IF ( (TRIM(tmp_opp) /= "inst") &
589 & .AND.(TRIM(tmp_opp) /= "once") ) THEN
590 CALL moycum(tmp_opp, tsz, buffer(ipt:), &
591 & buff_tmp2, nb_opp(pfileid, varid))
592 ENDIF
593
594 last_opp(pfileid, varid) = pitau
595 nb_opp(pfileid, varid) = nb_opp(pfileid, varid)+1
596
597 ENDIF
598
599 ! 6.0 Write to file if needed
600
601 IF ( do_write ) THEN
602
603 ncvarid = ncvar_ids(pfileid, varid)
604 ncid = ncdf_ids(pfileid)
605
606 !- 6.1 Do the operations that are needed before writting
607
608 IF ( (TRIM(tmp_opp) /= "inst") &
609 & .AND.(TRIM(tmp_opp) /= "once") ) THEN
610 rtime = (rtime+last_wrt(pfileid, varid)*deltat(pfileid))/2.0
611 ENDIF
612
613 !- 6.2 Add a value to the time axis of this variable if needed
614
615 IF ( (TRIM(tmp_opp) /= "l_max") &
616 & .AND.(TRIM(tmp_opp) /= "l_min") &
617 & .AND.(TRIM(tmp_opp) /= "once") ) THEN
618
619 itax = var_axid(pfileid, varid)
620 itime = nb_wrt(pfileid, varid)+1
621
622 IF (tax_last(pfileid, itax) < itime) THEN
623 iret = NF90_PUT_VAR (ncid, tdimid(pfileid, itax), (/ rtime /), &
624 & start=(/ itime /), count=(/ 1 /))
625 tax_last(pfileid, itax) = itime
626 ENDIF
627 ELSE
628 itime=1
629 ENDIF
630
631 !- 6.3 Write the data. Only in the case of instantaneous output
632 ! we do not write the buffer.
633
634 IF (scsize(pfileid, varid, 3) == 1) THEN
635 IF (regular(pfileid)) THEN
636 corner(1:4) = (/ 1, 1, itime, 0 /)
637 edges(1:4) = (/ zsize(pfileid, varid, 1), &
638 & zsize(pfileid, varid, 2), &
639 & 1, 0 /)
640 ELSE
641 corner(1:4) = (/ 1, itime, 0, 0 /)
642 edges(1:4) = (/ zsize(pfileid, varid, 1), 1, 0, 0 /)
643 ENDIF
644 ELSE
645 IF ( regular(pfileid) ) THEN
646 corner(1:4) = (/ 1, 1, 1, itime /)
647 edges(1:4) = (/ zsize(pfileid, varid, 1), &
648 & zsize(pfileid, varid, 2), &
649 & zsize(pfileid, varid, 3), 1 /)
650 ELSE
651 corner(1:4) = (/ 1, 1, itime, 0 /)
652 edges(1:4) = (/ zsize(pfileid, varid, 1), &
653 & zsize(pfileid, varid, 3), 1, 0 /)
654 ENDIF
655 ENDIF
656
657 ipt = point(pfileid, varid)
658
659 IF ( (TRIM(tmp_opp) /= "inst") &
660 & .AND.(TRIM(tmp_opp) /= "once") ) THEN
661 iret = NF90_PUT_VAR (ncid, ncvarid, buffer(ipt:), &
662 & start=corner(1:4), count=edges(1:4))
663 ELSE
664 iret = NF90_PUT_VAR (ncid, ncvarid, buff_tmp2, &
665 & start=corner(1:4), count=edges(1:4))
666 ENDIF
667
668 last_wrt(pfileid, varid) = pitau
669 nb_wrt(pfileid, varid) = nb_wrt(pfileid, varid)+1
670 nb_opp(pfileid, varid) = 0
671 !--
672 ! After the write the file can be synchronized so that no data is
673 ! lost in case of a crash. This feature gives up on the benefits of
674 ! buffering and should only be used in debuging mode. A flag is
675 ! needed here to switch to this mode.
676 !--
677 ! iret = NF90_SYNC (ncid)
678
679 ENDIF
680 !---------------------------
681 END SUBROUTINE histwrite_real
682
683 !*************************************************************
684
685 SUBROUTINE histvar_seq (pfid, pvarname, pvid)
686
687 ! This subroutine optimized the search for the variable in the table.
688 ! In a first phase it will learn the succession of the variables
689 ! called and then it will use the table to guess what comes next.
690 ! It is the best solution to avoid lengthy searches through array
691 ! vectors.
692
693 ! ARGUMENTS :
694
695 ! pfid : id of the file on which we work
696 ! pvarname : The name of the variable we are looking for
697 ! pvid : The var id we found
698
699 USE find_str_m, ONLY: find_str
700 USE errioipsl, ONLY : histerr
701 use histcom_var
702
703 INTEGER, INTENT(in) :: pfid
704 CHARACTER(LEN=*), INTENT(IN) :: pvarname
705 INTEGER, INTENT(out) :: pvid
706
707 LOGICAL, SAVE :: learning(nb_files_max)=.TRUE.
708 INTEGER, SAVE :: overlap(nb_files_max) = -1
709 INTEGER, SAVE :: varseq(nb_files_max, nb_var_max*3)
710 INTEGER, SAVE :: varseq_len(nb_files_max) = 0
711 INTEGER, SAVE :: varseq_pos(nb_files_max)
712 INTEGER, SAVE :: varseq_err(nb_files_max) = 0
713 INTEGER :: nb, sp, nx, pos, ib
714 CHARACTER(LEN=20), DIMENSION(nb_var_max) :: tab_str20
715 CHARACTER(LEN=20) :: str20
716 CHARACTER(LEN=70) :: str70
717 INTEGER :: tab_str20_length(nb_var_max)
718
719 !--------------------------------------------------------------------
720 nb = nb_var(pfid)
721
722 IF (learning(pfid)) THEN
723
724 !- 1.0 We compute the length over which we are going
725 !- to check the overlap
726
727 IF (overlap(pfid) <= 0) THEN
728 IF (nb_var(pfid) > 6) THEN
729 overlap(pfid) = nb_var(pfid)/3*2
730 ELSE
731 overlap(pfid) = nb_var(pfid)
732 ENDIF
733 ENDIF
734
735 !- 1.1 Find the position of this string
736
737 str20 = pvarname
738 tab_str20(1:nb) = name(pfid, 1:nb)
739 tab_str20_length(1:nb) = name_length(pfid, 1:nb)
740
741 CALL find_str (nb, tab_str20, tab_str20_length, str20, pos)
742
743 IF (pos > 0) THEN
744 pvid = pos
745 ELSE
746 CALL histerr (3, "histvar_seq", &
747 & 'The name of the variable you gave has not been declared', &
748 & 'You should use subroutine histdef for declaring variable', &
749 & TRIM(str20))
750 ENDIF
751
752 !- 1.2 If we have not given up we store the position
753 !- in the sequence of calls
754
755 IF ( varseq_err(pfid) .GE. 0 ) THEN
756 sp = varseq_len(pfid)+1
757 IF (sp <= nb_var_max*3) THEN
758 varseq(pfid, sp) = pvid
759 varseq_len(pfid) = sp
760 ELSE
761 CALL histerr (2, "histvar_seq", &
762 & 'The learning process has failed and we give up. '// &
763 & 'Either you sequence is', &
764 & 'too complex or I am too dumb. '// &
765 & 'This will only affect the efficiency', &
766 & 'of your code. Thus if you wish to save time'// &
767 & ' contact the IOIPSL team. ')
768 WRITE(*, *) 'The sequence we have found up to now :'
769 WRITE(*, *) varseq(pfid, 1:sp-1)
770 varseq_err(pfid) = -1
771 ENDIF
772
773 !--- 1.3 Check if we have found the right overlap
774
775 IF (varseq_len(pfid) .GE. overlap(pfid)*2) THEN
776
777 !----- We skip a few variables if needed as they could come
778 !----- from the initialisation of the model.
779
780 DO ib = 0, sp-overlap(pfid)*2
781 IF ( learning(pfid) .AND.&
782 & SUM(ABS(varseq(pfid, ib+1:ib+overlap(pfid)) -&
783 & varseq(pfid, sp-overlap(pfid)+1:sp))) == 0 ) THEN
784 learning(pfid) = .FALSE.
785 varseq_len(pfid) = sp-overlap(pfid)-ib
786 varseq_pos(pfid) = overlap(pfid)+ib
787 varseq(pfid, 1:varseq_len(pfid)) = &
788 & varseq(pfid, ib+1:ib+varseq_len(pfid))
789 ENDIF
790 ENDDO
791 ENDIF
792 ENDIF
793 ELSE
794
795 !- 2.0 Now we know how the calls to histwrite are sequenced
796 !- and we can get a guess at the var ID
797
798 nx = varseq_pos(pfid)+1
799 IF (nx > varseq_len(pfid)) nx = 1
800
801 pvid = varseq(pfid, nx)
802
803 IF ( (INDEX(name(pfid, pvid), pvarname) <= 0) &
804 & .OR.(name_length(pfid, pvid) /= len_trim(pvarname)) ) THEN
805 str20 = pvarname
806 tab_str20(1:nb) = name(pfid, 1:nb)
807 tab_str20_length(1:nb) = name_length(pfid, 1:nb)
808 CALL find_str (nb, tab_str20, tab_str20_length, str20, pos)
809 IF (pos > 0) THEN
810 pvid = pos
811 ELSE
812 CALL histerr(3, "histvar_seq", &
813 & 'The name of the variable you gave has not been declared', &
814 & 'You should use subroutine histdef for declaring variable', str20)
815 ENDIF
816 varseq_err(pfid) = varseq_err(pfid)+1
817 ELSE
818
819 !--- We only keep the new position if we have found the variable
820 !--- this way. This way an out of sequence call to histwrite does
821 !--- not defeat the process.
822
823 varseq_pos(pfid) = nx
824 ENDIF
825
826 IF (varseq_err(pfid) .GE. 10) THEN
827 WRITE(str70, '("for file ", I3)') pfid
828 CALL histerr(2, "histvar_seq", &
829 & 'There were 10 errors in the learned sequence of variables', &
830 & str70, 'This looks like a bug, please report it.')
831 varseq_err(pfid) = 0
832 ENDIF
833 ENDIF
834
835 END SUBROUTINE histvar_seq
836
837 END MODULE histwrite_m
  ViewVC Help
Powered by ViewVC 1.1.21