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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 32 - (hide 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 guez 30 MODULE histwrite_m
2    
3 guez 31 ! From histcom.f90, version 2.1 2004/04/21 09:27:10
4 guez 30
5     implicit none
6    
7     PRIVATE
8     PUBLIC histwrite
9    
10     INTERFACE histwrite
11 guez 31 ! 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 guez 30
15 guez 31 ! 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 guez 30
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 guez 32 USE mathop_m, ONLY : mathop
52 guez 31 use histcom_var
53 guez 30
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 guez 31 !--------------------------------------------------------------------
67 guez 30
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 guez 31 !- 5.1 Get the sizes of the data we will handle
121 guez 30
122     IF (datasz_in(pfileid, varid, 1) <= 0) THEN
123 guez 31 !--- 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 guez 30 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 guez 31 !- 5.2 The maximum size of the data will give the size of the buffer
133 guez 30
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 guez 31 !- 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 guez 30
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 guez 31 !--------------------------
184 guez 30 END SUBROUTINE histwrite_r1d
185    
186     !===
187    
188     SUBROUTINE histwrite_r2d (pfileid, pvarname, pitau, pdata)
189 guez 31 !--------------------------------------------------------------------
190 guez 30
191     use calendar, only: isittime
192     USE errioipsl, ONLY : histerr
193 guez 32 USE mathop_m, ONLY : mathop
194 guez 31 use histcom_var
195 guez 30
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 guez 31 !--------------------------------------------------------------------
208 guez 30
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 guez 31 !- 5.1 Get the sizes of the data we will handle
262 guez 30
263     IF (datasz_in(pfileid, varid, 1) <= 0) THEN
264 guez 31 !--- 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 guez 30 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 guez 31 !- 5.2 The maximum size of the data will give the size of the buffer
274 guez 30
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 guez 31 !- 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 guez 30
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 guez 31 !--------------------------
326 guez 30 END SUBROUTINE histwrite_r2d
327    
328     !===
329    
330     SUBROUTINE histwrite_r3d (pfileid, pvarname, pitau, pdata)
331 guez 31 !--------------------------------------------------------------------
332 guez 30
333     use calendar, only: isittime
334     USE errioipsl, ONLY : histerr
335 guez 32 USE mathop_m, ONLY : mathop
336 guez 31 use histcom_var
337 guez 30
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 guez 31 !--------------------------------------------------------------------
350 guez 30
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 guez 31 !- 5.1 Get the sizes of the data we will handle
404 guez 30
405     IF (datasz_in(pfileid, varid, 1) <= 0) THEN
406 guez 31 !--- 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 guez 30 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 guez 31 !- 5.2 The maximum size of the data will give the size of the buffer
416 guez 30
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 guez 31 !- 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 guez 30
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 guez 31 !--------------------------
469 guez 30 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 guez 31 ! 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 guez 30
481 guez 32 USE mathop_m, ONLY : mathop
482     USE mathelp, ONLY : trans_buff, moycum
483 guez 30 use netcdf, only: NF90_PUT_VAR
484 guez 31 use histcom_var
485 guez 30
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 guez 31 !--------------------------------------------------------------------
506 guez 30
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 guez 31 !- 3.4 We continue the sequence of operations
560     !- we started in the interface routine
561 guez 30
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 guez 31 !- 5.0 Do the operations if needed. In the case of instantaneous
584     !- output we do not transfer to the buffer.
585 guez 30
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 guez 31 !- 6.1 Do the operations that are needed before writting
607 guez 30
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 guez 31 !- 6.2 Add a value to the time axis of this variable if needed
614 guez 30
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 guez 31 !- 6.3 Write the data. Only in the case of instantaneous output
632 guez 30 ! 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 guez 31 !--
672 guez 30 ! 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 guez 31 !--
677 guez 30 ! iret = NF90_SYNC (ncid)
678    
679     ENDIF
680 guez 31 !---------------------------
681 guez 30 END SUBROUTINE histwrite_real
682    
683     !*************************************************************
684    
685     SUBROUTINE histvar_seq (pfid, pvarname, pvid)
686    
687 guez 31 ! 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 guez 30
693 guez 31 ! ARGUMENTS :
694 guez 30
695 guez 31 ! 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 guez 30
699 guez 32 USE find_str_m, ONLY: find_str
700 guez 30 USE errioipsl, ONLY : histerr
701 guez 31 use histcom_var
702 guez 30
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 guez 31 !--------------------------------------------------------------------
720 guez 30 nb = nb_var(pfid)
721    
722     IF (learning(pfid)) THEN
723    
724 guez 31 !- 1.0 We compute the length over which we are going
725     !- to check the overlap
726 guez 30
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 guez 31 !- 1.1 Find the position of this string
736 guez 30
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 guez 31 !- 1.2 If we have not given up we store the position
753     !- in the sequence of calls
754 guez 30
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 guez 31 !--- 1.3 Check if we have found the right overlap
774 guez 30
775     IF (varseq_len(pfid) .GE. overlap(pfid)*2) THEN
776    
777 guez 31 !----- We skip a few variables if needed as they could come
778     !----- from the initialisation of the model.
779 guez 30
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 guez 31 !- 2.0 Now we know how the calls to histwrite are sequenced
796     !- and we can get a guess at the var ID
797 guez 30
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 guez 31 !--- 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 guez 30
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