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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 30 - (hide annotations)
Thu Apr 1 09:07:28 2010 UTC (14 years, 1 month ago) by guez
Original Path: trunk/libf/IOIPSL/histwrite.f90
File size: 29162 byte(s) 
Imported Source files of the external library "IOIPSL_Lionel" into
"libf/IOIPSL".

Split "cray.f90" into "scopy.f90" and "ssum.f90".

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