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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 31 - (hide annotations)
Thu Apr 1 14:59:19 2010 UTC (14 years, 1 month ago) by guez
Original Path: trunk/libf/IOIPSL/histwrite.f90
File size: 29170 byte(s) 
Split "vlsplt.f" in single-procedure files. Gathered the files in
directory "dyn3d/Vlsplt".

Defined "pbarum(:, 1, :)" and "pbarum(:, jjm + 1, :)" in procedure
"groupe".
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     USE mathelp, 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     USE mathelp, 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     USE mathelp, 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     USE mathelp, ONLY : mathop, trans_buff, moycum
482     use netcdf, only: NF90_PUT_VAR
483 guez 31 use histcom_var
484 guez 30
485     INTEGER, INTENT(IN) :: pfileid, pitau, varid, &
486     & nbindex, nindex(nbindex), nbdpt
487     REAL, DIMENSION(:) :: buff_tmp
488     LOGICAL, INTENT(IN) :: do_oper, do_write
489    
490     INTEGER :: tsz, ncid, ncvarid
491     INTEGER :: i, iret, ipt, itax
492     INTEGER :: io, nbin, nbout
493     INTEGER, DIMENSION(4) :: corner, edges
494     INTEGER :: itime
495    
496     REAL :: rtime
497     CHARACTER(LEN=7) :: tmp_opp
498    
499     REAL, ALLOCATABLE, SAVE :: buff_tmp2(:)
500     INTEGER, SAVE :: buff_tmp2_sz
501     REAL, ALLOCATABLE, SAVE :: buffer_used(:)
502     INTEGER, SAVE :: buffer_sz
503    
504 guez 31 !--------------------------------------------------------------------
505 guez 30
506     ! The sizes which can be encoutered
507    
508     tsz = zsize(pfileid, varid, 1)*zsize(pfileid, varid, 2)*zsize(pfileid, varid, 3)
509    
510     ! 1.0 We allocate the memory needed to store the data between write
511     ! and the temporary space needed for operations.
512     ! We have to keep precedent buffer if needed
513    
514     IF (.NOT. ALLOCATED(buffer)) THEN
515     ALLOCATE(buffer(buff_pos))
516     buffer_sz = buff_pos
517     buffer(:)=0.0
518     ELSE IF (buffer_sz < buff_pos) THEN
519     IF (SUM(buffer)/=0.0) THEN
520     ALLOCATE (buffer_used(buffer_sz))
521     buffer_used(:)=buffer(:)
522     DEALLOCATE (buffer)
523     ALLOCATE (buffer(buff_pos))
524     buffer_sz = buff_pos
525     buffer(:SIZE(buffer_used))=buffer_used
526     DEALLOCATE (buffer_used)
527     ELSE
528     DEALLOCATE (buffer)
529     ALLOCATE (buffer(buff_pos))
530     buffer_sz = buff_pos
531     buffer(:)=0.0
532     ENDIF
533     ENDIF
534    
535     ! The buffers are only deallocated when more space is needed. This
536     ! reduces the umber of allocates but increases memory needs.
537    
538     IF (.NOT.ALLOCATED(buff_tmp2)) THEN
539     ALLOCATE (buff_tmp2(datasz_max(pfileid, varid)))
540     buff_tmp2_sz = datasz_max(pfileid, varid)
541     ELSE IF ( datasz_max(pfileid, varid) > buff_tmp2_sz) THEN
542     DEALLOCATE (buff_tmp2)
543     ALLOCATE (buff_tmp2(datasz_max(pfileid, varid)))
544     buff_tmp2_sz = datasz_max(pfileid, varid)
545     ENDIF
546    
547     rtime = pitau * deltat(pfileid)
548     tmp_opp = topp(pfileid, varid)
549    
550     ! 3.0 Do the operations or transfer the slab of data into buff_tmp
551    
552     ! 3.1 DO the Operations only if needed
553    
554     IF ( do_oper ) THEN
555     i = pfileid
556     nbout = nbdpt
557    
558 guez 31 !- 3.4 We continue the sequence of operations
559     !- we started in the interface routine
560 guez 30
561     DO io = 2, nbopp(i, varid), 2
562     nbin = nbout
563     nbout = datasz_max(i, varid)
564     CALL mathop(sopps(i, varid, io), nbin, buff_tmp, missing_val, &
565     & nbindex, nindex, scal(i, varid, io), nbout, buff_tmp2)
566    
567     nbin = nbout
568     nbout = datasz_max(i, varid)
569     CALL mathop(sopps(i, varid, io+1), nbin, buff_tmp2, missing_val, &
570     & nbindex, nindex, scal(i, varid, io+1), nbout, buff_tmp)
571     ENDDO
572    
573     ! 3.5 Zoom into the data
574    
575     CALL trans_buff &
576     & (zorig(i, varid, 1), zsize(i, varid, 1), &
577     & zorig(i, varid, 2), zsize(i, varid, 2), &
578     & zorig(i, varid, 3), zsize(i, varid, 3), &
579     & scsize(i, varid, 1), scsize(i, varid, 2), scsize(i, varid, 3), &
580     & buff_tmp, buff_tmp2_sz, buff_tmp2)
581    
582 guez 31 !- 5.0 Do the operations if needed. In the case of instantaneous
583     !- output we do not transfer to the buffer.
584 guez 30
585     ipt = point(pfileid, varid)
586    
587     IF ( (TRIM(tmp_opp) /= "inst") &
588     & .AND.(TRIM(tmp_opp) /= "once") ) THEN
589     CALL moycum(tmp_opp, tsz, buffer(ipt:), &
590     & buff_tmp2, nb_opp(pfileid, varid))
591     ENDIF
592    
593     last_opp(pfileid, varid) = pitau
594     nb_opp(pfileid, varid) = nb_opp(pfileid, varid)+1
595    
596     ENDIF
597    
598     ! 6.0 Write to file if needed
599    
600     IF ( do_write ) THEN
601    
602     ncvarid = ncvar_ids(pfileid, varid)
603     ncid = ncdf_ids(pfileid)
604    
605 guez 31 !- 6.1 Do the operations that are needed before writting
606 guez 30
607     IF ( (TRIM(tmp_opp) /= "inst") &
608     & .AND.(TRIM(tmp_opp) /= "once") ) THEN
609     rtime = (rtime+last_wrt(pfileid, varid)*deltat(pfileid))/2.0
610     ENDIF
611    
612 guez 31 !- 6.2 Add a value to the time axis of this variable if needed
613 guez 30
614     IF ( (TRIM(tmp_opp) /= "l_max") &
615     & .AND.(TRIM(tmp_opp) /= "l_min") &
616     & .AND.(TRIM(tmp_opp) /= "once") ) THEN
617    
618     itax = var_axid(pfileid, varid)
619     itime = nb_wrt(pfileid, varid)+1
620    
621     IF (tax_last(pfileid, itax) < itime) THEN
622     iret = NF90_PUT_VAR (ncid, tdimid(pfileid, itax), (/ rtime /), &
623     & start=(/ itime /), count=(/ 1 /))
624     tax_last(pfileid, itax) = itime
625     ENDIF
626     ELSE
627     itime=1
628     ENDIF
629    
630 guez 31 !- 6.3 Write the data. Only in the case of instantaneous output
631 guez 30 ! we do not write the buffer.
632    
633     IF (scsize(pfileid, varid, 3) == 1) THEN
634     IF (regular(pfileid)) THEN
635     corner(1:4) = (/ 1, 1, itime, 0 /)
636     edges(1:4) = (/ zsize(pfileid, varid, 1), &
637     & zsize(pfileid, varid, 2), &
638     & 1, 0 /)
639     ELSE
640     corner(1:4) = (/ 1, itime, 0, 0 /)
641     edges(1:4) = (/ zsize(pfileid, varid, 1), 1, 0, 0 /)
642     ENDIF
643     ELSE
644     IF ( regular(pfileid) ) THEN
645     corner(1:4) = (/ 1, 1, 1, itime /)
646     edges(1:4) = (/ zsize(pfileid, varid, 1), &
647     & zsize(pfileid, varid, 2), &
648     & zsize(pfileid, varid, 3), 1 /)
649     ELSE
650     corner(1:4) = (/ 1, 1, itime, 0 /)
651     edges(1:4) = (/ zsize(pfileid, varid, 1), &
652     & zsize(pfileid, varid, 3), 1, 0 /)
653     ENDIF
654     ENDIF
655    
656     ipt = point(pfileid, varid)
657    
658     IF ( (TRIM(tmp_opp) /= "inst") &
659     & .AND.(TRIM(tmp_opp) /= "once") ) THEN
660     iret = NF90_PUT_VAR (ncid, ncvarid, buffer(ipt:), &
661     & start=corner(1:4), count=edges(1:4))
662     ELSE
663     iret = NF90_PUT_VAR (ncid, ncvarid, buff_tmp2, &
664     & start=corner(1:4), count=edges(1:4))
665     ENDIF
666    
667     last_wrt(pfileid, varid) = pitau
668     nb_wrt(pfileid, varid) = nb_wrt(pfileid, varid)+1
669     nb_opp(pfileid, varid) = 0
670 guez 31 !--
671 guez 30 ! After the write the file can be synchronized so that no data is
672     ! lost in case of a crash. This feature gives up on the benefits of
673     ! buffering and should only be used in debuging mode. A flag is
674     ! needed here to switch to this mode.
675 guez 31 !--
676 guez 30 ! iret = NF90_SYNC (ncid)
677    
678     ENDIF
679 guez 31 !---------------------------
680 guez 30 END SUBROUTINE histwrite_real
681    
682     !*************************************************************
683    
684     SUBROUTINE histvar_seq (pfid, pvarname, pvid)
685    
686 guez 31 ! This subroutine optimized the search for the variable in the table.
687     ! In a first phase it will learn the succession of the variables
688     ! called and then it will use the table to guess what comes next.
689     ! It is the best solution to avoid lengthy searches through array
690     ! vectors.
691 guez 30
692 guez 31 ! ARGUMENTS :
693 guez 30
694 guez 31 ! pfid : id of the file on which we work
695     ! pvarname : The name of the variable we are looking for
696     ! pvid : The var id we found
697 guez 30
698     USE stringop, ONLY: find_str
699     USE errioipsl, ONLY : histerr
700 guez 31 use histcom_var
701 guez 30
702     INTEGER, INTENT(in) :: pfid
703     CHARACTER(LEN=*), INTENT(IN) :: pvarname
704     INTEGER, INTENT(out) :: pvid
705    
706     LOGICAL, SAVE :: learning(nb_files_max)=.TRUE.
707     INTEGER, SAVE :: overlap(nb_files_max) = -1
708     INTEGER, SAVE :: varseq(nb_files_max, nb_var_max*3)
709     INTEGER, SAVE :: varseq_len(nb_files_max) = 0
710     INTEGER, SAVE :: varseq_pos(nb_files_max)
711     INTEGER, SAVE :: varseq_err(nb_files_max) = 0
712     INTEGER :: nb, sp, nx, pos, ib
713     CHARACTER(LEN=20), DIMENSION(nb_var_max) :: tab_str20
714     CHARACTER(LEN=20) :: str20
715     CHARACTER(LEN=70) :: str70
716     INTEGER :: tab_str20_length(nb_var_max)
717    
718 guez 31 !--------------------------------------------------------------------
719 guez 30 nb = nb_var(pfid)
720    
721     IF (learning(pfid)) THEN
722    
723 guez 31 !- 1.0 We compute the length over which we are going
724     !- to check the overlap
725 guez 30
726     IF (overlap(pfid) <= 0) THEN
727     IF (nb_var(pfid) > 6) THEN
728     overlap(pfid) = nb_var(pfid)/3*2
729     ELSE
730     overlap(pfid) = nb_var(pfid)
731     ENDIF
732     ENDIF
733    
734 guez 31 !- 1.1 Find the position of this string
735 guez 30
736     str20 = pvarname
737     tab_str20(1:nb) = name(pfid, 1:nb)
738     tab_str20_length(1:nb) = name_length(pfid, 1:nb)
739    
740     CALL find_str (nb, tab_str20, tab_str20_length, str20, pos)
741    
742     IF (pos > 0) THEN
743     pvid = pos
744     ELSE
745     CALL histerr (3, "histvar_seq", &
746     & 'The name of the variable you gave has not been declared', &
747     & 'You should use subroutine histdef for declaring variable', &
748     & TRIM(str20))
749     ENDIF
750    
751 guez 31 !- 1.2 If we have not given up we store the position
752     !- in the sequence of calls
753 guez 30
754     IF ( varseq_err(pfid) .GE. 0 ) THEN
755     sp = varseq_len(pfid)+1
756     IF (sp <= nb_var_max*3) THEN
757     varseq(pfid, sp) = pvid
758     varseq_len(pfid) = sp
759     ELSE
760     CALL histerr (2, "histvar_seq", &
761     & 'The learning process has failed and we give up. '// &
762     & 'Either you sequence is', &
763     & 'too complex or I am too dumb. '// &
764     & 'This will only affect the efficiency', &
765     & 'of your code. Thus if you wish to save time'// &
766     & ' contact the IOIPSL team. ')
767     WRITE(*, *) 'The sequence we have found up to now :'
768     WRITE(*, *) varseq(pfid, 1:sp-1)
769     varseq_err(pfid) = -1
770     ENDIF
771    
772 guez 31 !--- 1.3 Check if we have found the right overlap
773 guez 30
774     IF (varseq_len(pfid) .GE. overlap(pfid)*2) THEN
775    
776 guez 31 !----- We skip a few variables if needed as they could come
777     !----- from the initialisation of the model.
778 guez 30
779     DO ib = 0, sp-overlap(pfid)*2
780     IF ( learning(pfid) .AND.&
781     & SUM(ABS(varseq(pfid, ib+1:ib+overlap(pfid)) -&
782     & varseq(pfid, sp-overlap(pfid)+1:sp))) == 0 ) THEN
783     learning(pfid) = .FALSE.
784     varseq_len(pfid) = sp-overlap(pfid)-ib
785     varseq_pos(pfid) = overlap(pfid)+ib
786     varseq(pfid, 1:varseq_len(pfid)) = &
787     & varseq(pfid, ib+1:ib+varseq_len(pfid))
788     ENDIF
789     ENDDO
790     ENDIF
791     ENDIF
792     ELSE
793    
794 guez 31 !- 2.0 Now we know how the calls to histwrite are sequenced
795     !- and we can get a guess at the var ID
796 guez 30
797     nx = varseq_pos(pfid)+1
798     IF (nx > varseq_len(pfid)) nx = 1
799    
800     pvid = varseq(pfid, nx)
801    
802     IF ( (INDEX(name(pfid, pvid), pvarname) <= 0) &
803     & .OR.(name_length(pfid, pvid) /= len_trim(pvarname)) ) THEN
804     str20 = pvarname
805     tab_str20(1:nb) = name(pfid, 1:nb)
806     tab_str20_length(1:nb) = name_length(pfid, 1:nb)
807     CALL find_str (nb, tab_str20, tab_str20_length, str20, pos)
808     IF (pos > 0) THEN
809     pvid = pos
810     ELSE
811     CALL histerr(3, "histvar_seq", &
812     & 'The name of the variable you gave has not been declared', &
813     & 'You should use subroutine histdef for declaring variable', str20)
814     ENDIF
815     varseq_err(pfid) = varseq_err(pfid)+1
816     ELSE
817    
818 guez 31 !--- We only keep the new position if we have found the variable
819     !--- this way. This way an out of sequence call to histwrite does
820     !--- not defeat the process.
821 guez 30
822     varseq_pos(pfid) = nx
823     ENDIF
824    
825     IF (varseq_err(pfid) .GE. 10) THEN
826     WRITE(str70, '("for file ", I3)') pfid
827     CALL histerr(2, "histvar_seq", &
828     & 'There were 10 errors in the learned sequence of variables', &
829     & str70, 'This looks like a bug, please report it.')
830     varseq_err(pfid) = 0
831     ENDIF
832     ENDIF
833    
834     END SUBROUTINE histvar_seq
835    
836     END MODULE histwrite_m
  ViewVC Help
Powered by ViewVC 1.1.21