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

Diff of /trunk/IOIPSL/histwrite.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/IOIPSL/histwrite.f90 revision 56 by guez, Tue Jan 10 19:02:02 2012 UTC trunk/IOIPSL/histwrite.f revision 92 by guez, Wed Mar 26 18:16:05 2014 UTC
# Line 2  MODULE histwrite_m Line 2  MODULE histwrite_m
2    
3    ! From histcom.f90, version 2.1 2004/04/21 09:27:10    ! From histcom.f90, version 2.1 2004/04/21 09:27:10
4    
5      USE errioipsl, ONLY: histerr
6      USE histcom_var, ONLY: datasz_in, datasz_max, date0, deltat, &
7           freq_opp, freq_wrt, fuchnbout, last_opp, last_opp_chk, last_wrt, &
8           last_wrt_chk, missing_val, nbopp, nb_files, scal, scsize, sopps, &
9           topp
10      use histvar_seq_m, only: histvar_seq
11      use histwrite_real_m, only: histwrite_real
12      use isittime_m, only: isittime
13      USE mathop_m, ONLY: mathop
14    
15    implicit none    implicit none
16    
17    INTERFACE histwrite    INTERFACE histwrite
# Line 13  MODULE histwrite_m Line 23  MODULE histwrite_m
23       ! later stage we can call different operations and write subroutines       ! later stage we can call different operations and write subroutines
24       ! for the REAL and INTEGER interfaces.       ! for the REAL and INTEGER interfaces.
25    
26       ! INTEGER, INTENT(IN):: pfileid       ! INTEGER, INTENT(IN):: fileid
27       ! The ID of the file on which this variable is to be written.       ! The ID of the file on which this variable is to be written.
28       ! The variable should have been defined in this file before.       ! The variable should have been defined in this file before.
29    
30       ! CHARACTER(LEN=*), INTENT(IN):: pvarname       ! CHARACTER(LEN=*), INTENT(IN):: varname
31       ! short name of the variable       ! short name of the variable
32    
33       ! INTEGER, INTENT(IN):: pitau       ! INTEGER, INTENT(IN):: itau
34       ! current timestep       ! current timestep
35    
36       ! REAL, INTENT(IN):: pdata(:) or (:, :) or (:, :, :)       ! REAL, INTENT(IN):: pdata(:) or (:, :) or (:, :, :)
# Line 29  MODULE histwrite_m Line 39  MODULE histwrite_m
39       ! The difference between the procedures is the rank of "pdata".       ! The difference between the procedures is the rank of "pdata".
40    
41       MODULE PROCEDURE histwrite_r1d, histwrite_r2d, histwrite_r3d       MODULE PROCEDURE histwrite_r1d, histwrite_r2d, histwrite_r3d
42    END INTERFACE    END INTERFACE histwrite
43    
44    PRIVATE histwrite_r1d, histwrite_r2d, histwrite_r3d    PRIVATE
45      public histwrite
46    
47  CONTAINS  CONTAINS
48    
49    SUBROUTINE histwrite_r1d(pfileid, pvarname, pitau, pdata)    SUBROUTINE histwrite_r1d(fileid, varname, itau, pdata)
   
     USE errioipsl, ONLY : histerr  
     use calendar, only: isittime  
     USE mathop_m, ONLY : mathop  
     USE histcom_var, ONLY : datasz_in, datasz_max, date0, deltat, &  
          freq_opp, freq_wrt, fuchnbout, last_opp, last_opp_chk, last_wrt, &  
          last_wrt_chk, missing_val, nbopp, nb_files, scal, scsize, sopps, &  
          topp  
     use histvar_seq_m, only: histvar_seq  
     use histwrite_real_m, only: histwrite_real  
50    
51      INTEGER, INTENT(IN):: pfileid, pitau      INTEGER, INTENT(IN):: fileid, itau
52        CHARACTER(LEN=*), INTENT(IN):: varname
53      REAL, INTENT(IN):: pdata(:)      REAL, INTENT(IN):: pdata(:)
     CHARACTER(LEN=*), INTENT(IN):: pvarname  
54    
55      ! Variables local to the procedure:      ! Variables local to the procedure:
56      integer nbindex, nindex(size(pdata))      integer nbindex, nindex(size(pdata))
# Line 66  CONTAINS Line 67  CONTAINS
67    
68      ! 1.0 Try to catch errors like specifying the wrong file ID.      ! 1.0 Try to catch errors like specifying the wrong file ID.
69    
70      IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN      IF ((fileid < 1) .OR. (fileid > nb_files)) THEN
71         CALL histerr (3, "histwrite", &         CALL histerr(3, "histwrite", &
72              &    'Illegal file ID in the histwrite of variable', pvarname, ' ')              'Illegal file ID in the histwrite of variable', varname, ' ')
73      ENDIF      ENDIF
74    
75      ! 1.1 Find the id of the variable to be written and the real time      ! 1.1 Find the id of the variable to be written and the real time
76    
77      CALL histvar_seq (pfileid, pvarname, varid)      CALL histvar_seq(fileid, varname, varid)
78    
79      ! 2.0 do nothing for never operation      ! 2.0 do nothing for never operation
80    
81      tmp_opp = topp(pfileid, varid)      tmp_opp = topp(fileid, varid)
82    
83      IF (TRIM(tmp_opp) == "never") THEN      IF (TRIM(tmp_opp) == "never") THEN
84         last_opp_chk(pfileid, varid) = -99         last_opp_chk(fileid, varid) = -99
85         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(fileid, varid) = -99
86      ENDIF      ENDIF
87    
88      ! 3.0 We check if we need to do an operation      ! 3.0 We check if we need to do an operation
89    
90      IF (last_opp_chk(pfileid, varid) == pitau) THEN      IF (last_opp_chk(fileid, varid) == itau) THEN
91         CALL histerr (3, "histwrite", &         CALL histerr(3, "histwrite", &
92              &    'This variable as already been analysed at the present', &              'This variable as already been analysed at the present', &
93              &    'time step', ' ')              'time step', ' ')
94      ENDIF      ENDIF
95    
96      CALL isittime &      CALL isittime(itau, date0(fileid), deltat(fileid), &
97           &  (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), &           freq_opp(fileid, varid), last_opp(fileid, varid), &
98           &   last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper)           last_opp_chk(fileid, varid), do_oper)
99    
100      ! 4.0 We check if we need to write the data      ! 4.0 We check if we need to write the data
101    
102      IF (last_wrt_chk(pfileid, varid) == pitau) THEN      IF (last_wrt_chk(fileid, varid) == itau) THEN
103         CALL histerr (3, "histwrite", &         CALL histerr(3, "histwrite", &
104              &    'This variable as already been written for the present', &              'This variable as already been written for the present', &
105              &    'time step', ' ')              'time step', ' ')
106      ENDIF      ENDIF
107    
108      CALL isittime &      CALL isittime(itau, date0(fileid), deltat(fileid), &
109           &  (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), &           freq_wrt(fileid, varid), last_wrt(fileid, varid), &
110           &   last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write)           last_wrt_chk(fileid, varid), do_write)
111    
112      ! 5.0 histwrite called      ! 5.0 histwrite called
113    
114      IF (do_oper.OR.do_write) THEN      IF (do_oper .OR. do_write) THEN
115           ! 5.1 Get the sizes of the data we will handle
        !- 5.1 Get the sizes of the data we will handle  
116    
117         IF (datasz_in(pfileid, varid, 1) <= 0) THEN         IF (datasz_in(fileid, varid, 1) <= 0) THEN
118            !--- There is the risk here that the user has over-sized the array.            ! There is the risk here that the user has over-sized the array.
119            !--- But how can we catch this ?            ! But how can we catch this ?
120            !--- In the worst case we will do impossible operations            ! In the worst case we will do impossible operations
121            !--- on part of the data !            ! on part of the data !
122            datasz_in(pfileid, varid, 1) = SIZE(pdata)            datasz_in(fileid, varid, 1) = SIZE(pdata)
123            datasz_in(pfileid, varid, 2) = -1            datasz_in(fileid, varid, 2) = -1
124            datasz_in(pfileid, varid, 3) = -1            datasz_in(fileid, varid, 3) = -1
125         ENDIF         ENDIF
126    
127         !- 5.2 The maximum size of the data will give the size of the buffer         ! 5.2 The maximum size of the data will give the size of the buffer
128    
129         IF (datasz_max(pfileid, varid) <= 0) THEN         IF (datasz_max(fileid, varid) <= 0) THEN
130            largebuf = .FALSE.            largebuf = .FALSE.
131            DO io=1, nbopp(pfileid, varid)            DO io=1, nbopp(fileid, varid)
132               IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN               IF (INDEX(fuchnbout, sopps(fileid, varid, io)) > 0) THEN
133                  largebuf = .TRUE.                  largebuf = .TRUE.
134               ENDIF               ENDIF
135            ENDDO            ENDDO
136            IF (largebuf) THEN            IF (largebuf) THEN
137               datasz_max(pfileid, varid) = &               datasz_max(fileid, varid) = scsize(fileid, varid, 1) &
138                    &        scsize(pfileid, varid, 1) &                    * scsize(fileid, varid, 2) *scsize(fileid, varid, 3)
                   &       *scsize(pfileid, varid, 2) &  
                   &       *scsize(pfileid, varid, 3)  
139            ELSE            ELSE
140               datasz_max(pfileid, varid) = &               datasz_max(fileid, varid) = datasz_in(fileid, varid, 1)
                   &        datasz_in(pfileid, varid, 1)  
141            ENDIF            ENDIF
142         ENDIF         ENDIF
143    
144         IF (.NOT.ALLOCATED(buff_tmp)) THEN         IF (.NOT.ALLOCATED(buff_tmp)) THEN
145            ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))            ALLOCATE(buff_tmp(datasz_max(fileid, varid)))
146            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(fileid, varid)
147         ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN         ELSE IF (datasz_max(fileid, varid) > buff_tmp_sz) THEN
148            DEALLOCATE (buff_tmp)            DEALLOCATE(buff_tmp)
149            ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))            ALLOCATE(buff_tmp(datasz_max(fileid, varid)))
150            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(fileid, varid)
151         ENDIF         ENDIF
152    
153         !- We have to do the first operation anyway.         ! We have to do the first operation anyway. Thus we do it here
154         !- Thus we do it here and change the ranke         ! and change the ranke of the data at the same time. This
155         !- of the data at the same time. This should speed up things.         ! should speed up things.
156    
157         nbpt_in = datasz_in(pfileid, varid, 1)         nbpt_in = datasz_in(fileid, varid, 1)
158         nbpt_out = datasz_max(pfileid, varid)         nbpt_out = datasz_max(fileid, varid)
159         CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, &         CALL mathop(sopps(fileid, varid, 1), nbpt_in, pdata, missing_val, &
160              &               missing_val, nbindex, nindex, &              nbindex, nindex, scal(fileid, varid, 1), nbpt_out, buff_tmp)
161              &               scal(pfileid, varid, 1), nbpt_out, buff_tmp)         CALL histwrite_real(fileid, varid, itau, nbpt_out, buff_tmp, nbindex, &
162         CALL histwrite_real (pfileid, varid, pitau, nbpt_out, &              nindex, do_oper, do_write)
             &            buff_tmp, nbindex, nindex, do_oper, do_write)  
163      ENDIF      ENDIF
164    
165      ! 6.0 Manage time steps      ! 6.0 Manage time steps
166    
167      IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN      IF ((TRIM(tmp_opp) /= "once") .AND. (TRIM(tmp_opp) /= "never")) THEN
168         last_opp_chk(pfileid, varid) = pitau         last_opp_chk(fileid, varid) = itau
169         last_wrt_chk(pfileid, varid) = pitau         last_wrt_chk(fileid, varid) = itau
170      ELSE      ELSE
171         last_opp_chk(pfileid, varid) = -99         last_opp_chk(fileid, varid) = -99
172         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(fileid, varid) = -99
173      ENDIF      ENDIF
174    
175    END SUBROUTINE histwrite_r1d    END SUBROUTINE histwrite_r1d
176    
177    !************************************************************************    !************************************************************************
178    
179    SUBROUTINE histwrite_r2d (pfileid, pvarname, pitau, pdata)    SUBROUTINE histwrite_r2d (fileid, varname, itau, pdata)
180    
181      use calendar, only: isittime      INTEGER, INTENT(IN):: fileid, itau
     USE errioipsl, ONLY : histerr  
     USE mathop_m, ONLY : mathop  
     USE histcom_var, ONLY : datasz_in, datasz_max, date0, deltat, &  
          freq_opp, freq_wrt, fuchnbout, last_opp, last_opp_chk, last_wrt, &  
          last_wrt_chk, missing_val, nbopp, nb_files, scal, scsize, sopps, &  
          topp  
     use histvar_seq_m, only: histvar_seq  
     use histwrite_real_m, only: histwrite_real  
   
     INTEGER, INTENT(IN):: pfileid, pitau  
182      REAL, INTENT(IN):: pdata(:, :)      REAL, INTENT(IN):: pdata(:, :)
183      CHARACTER(LEN=*), INTENT(IN):: pvarname      CHARACTER(LEN=*), INTENT(IN):: varname
184    
185      integer nbindex, nindex(size(pdata))      integer nbindex, nindex(size(pdata))
186      LOGICAL:: do_oper, do_write, largebuf      LOGICAL:: do_oper, do_write, largebuf
# Line 210  CONTAINS Line 196  CONTAINS
196    
197      ! 1.0 Try to catch errors like specifying the wrong file ID.      ! 1.0 Try to catch errors like specifying the wrong file ID.
198    
199      IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN      IF ( (fileid < 1).OR.(fileid > nb_files) ) THEN
200         CALL histerr (3, "histwrite", &         CALL histerr (3, "histwrite", &
201              &    'Illegal file ID in the histwrite of variable', pvarname, ' ')              'Illegal file ID in the histwrite of variable', varname, ' ')
202      ENDIF      ENDIF
203    
204      ! 1.1 Find the id of the variable to be written and the real time      ! 1.1 Find the id of the variable to be written and the real time
205    
206      CALL histvar_seq (pfileid, pvarname, varid)      CALL histvar_seq (fileid, varname, varid)
207    
208      ! 2.0 do nothing for never operation      ! 2.0 do nothing for never operation
209    
210      tmp_opp = topp(pfileid, varid)      tmp_opp = topp(fileid, varid)
211    
212      IF (TRIM(tmp_opp) == "never") THEN      IF (TRIM(tmp_opp) == "never") THEN
213         last_opp_chk(pfileid, varid) = -99         last_opp_chk(fileid, varid) = -99
214         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(fileid, varid) = -99
215      ENDIF      ENDIF
216    
217      ! 3.0 We check if we need to do an operation      ! 3.0 We check if we need to do an operation
218    
219      IF (last_opp_chk(pfileid, varid) == pitau) THEN      IF (last_opp_chk(fileid, varid) == itau) CALL histerr (3, "histwrite", &
220         CALL histerr (3, "histwrite", &           'This variable as already been analysed at the present', &
221              &    'This variable as already been analysed at the present', &           'time step', ' ')
222              &    'time step', ' ')  
223      ENDIF      CALL isittime(itau, date0(fileid), deltat(fileid), &
224             freq_opp(fileid, varid), last_opp(fileid, varid), &
225      CALL isittime &           last_opp_chk(fileid, varid), do_oper)
          &  (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), &  
          &   last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper)  
226    
227      ! 4.0 We check if we need to write the data      ! 4.0 We check if we need to write the data
228    
229      IF (last_wrt_chk(pfileid, varid) == pitau) THEN      IF (last_wrt_chk(fileid, varid) == itau) THEN
230         CALL histerr (3, "histwrite", &         CALL histerr (3, "histwrite", &
231              &    'This variable as already been written for the present', &              'This variable as already been written for the present', &
232              &    'time step', ' ')              'time step', ' ')
233      ENDIF      ENDIF
234    
235      CALL isittime &      CALL isittime &
236           &  (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), &           (itau, date0(fileid), deltat(fileid), freq_wrt(fileid, varid), &
237           &   last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write)           last_wrt(fileid, varid), last_wrt_chk(fileid, varid), do_write)
238    
239      ! 5.0 histwrite called      ! 5.0 histwrite called
240    
# Line 258  CONTAINS Line 242  CONTAINS
242    
243         !- 5.1 Get the sizes of the data we will handle         !- 5.1 Get the sizes of the data we will handle
244    
245         IF (datasz_in(pfileid, varid, 1) <= 0) THEN         IF (datasz_in(fileid, varid, 1) <= 0) THEN
246            !--- There is the risk here that the user has over-sized the array.            !--- There is the risk here that the user has over-sized the array.
247            !--- But how can we catch this ?            !--- But how can we catch this ?
248            !--- In the worst case we will do impossible operations            !--- In the worst case we will do impossible operations
249            !--- on part of the data !            !--- on part of the data !
250            datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1)            datasz_in(fileid, varid, 1) = SIZE(pdata, DIM=1)
251            datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2)            datasz_in(fileid, varid, 2) = SIZE(pdata, DIM=2)
252            datasz_in(pfileid, varid, 3) = -1            datasz_in(fileid, varid, 3) = -1
253         ENDIF         ENDIF
254    
255         !- 5.2 The maximum size of the data will give the size of the buffer         !- 5.2 The maximum size of the data will give the size of the buffer
256    
257         IF (datasz_max(pfileid, varid) <= 0) THEN         IF (datasz_max(fileid, varid) <= 0) THEN
258            largebuf = .FALSE.            largebuf = .FALSE.
259            DO io=1, nbopp(pfileid, varid)            DO io=1, nbopp(fileid, varid)
260               IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN               IF (INDEX(fuchnbout, sopps(fileid, varid, io)) > 0) THEN
261                  largebuf = .TRUE.                  largebuf = .TRUE.
262               ENDIF               ENDIF
263            ENDDO            ENDDO
264            IF (largebuf) THEN            IF (largebuf) THEN
265               datasz_max(pfileid, varid) = &               datasz_max(fileid, varid) = &
266                    &        scsize(pfileid, varid, 1) &                    scsize(fileid, varid, 1) &
267                    &       *scsize(pfileid, varid, 2) &                    *scsize(fileid, varid, 2) &
268                    &       *scsize(pfileid, varid, 3)                    *scsize(fileid, varid, 3)
269            ELSE            ELSE
270               datasz_max(pfileid, varid) = &               datasz_max(fileid, varid) = &
271                    &        datasz_in(pfileid, varid, 1) &                    datasz_in(fileid, varid, 1) &
272                    &       *datasz_in(pfileid, varid, 2)                    *datasz_in(fileid, varid, 2)
273            ENDIF            ENDIF
274         ENDIF         ENDIF
275    
276         IF (.NOT.ALLOCATED(buff_tmp)) THEN         IF (.NOT.ALLOCATED(buff_tmp)) THEN
277            ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))            ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
278            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(fileid, varid)
279         ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN         ELSE IF (datasz_max(fileid, varid) > buff_tmp_sz) THEN
280            DEALLOCATE (buff_tmp)            DEALLOCATE (buff_tmp)
281            ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))            ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
282            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(fileid, varid)
283         ENDIF         ENDIF
284    
285         !- We have to do the first operation anyway.         !- We have to do the first operation anyway.
286         !- Thus we do it here and change the ranke         !- Thus we do it here and change the ranke
287         !- of the data at the same time. This should speed up things.         !- of the data at the same time. This should speed up things.
288    
289         nbpt_in(1:2) = datasz_in(pfileid, varid, 1:2)         nbpt_in(1:2) = datasz_in(fileid, varid, 1:2)
290         nbpt_out = datasz_max(pfileid, varid)         nbpt_out = datasz_max(fileid, varid)
291         CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, &         CALL mathop (sopps(fileid, varid, 1), nbpt_in, pdata, &
292              &               missing_val, nbindex, nindex, &              missing_val, nbindex, nindex, &
293              &               scal(pfileid, varid, 1), nbpt_out, buff_tmp)              scal(fileid, varid, 1), nbpt_out, buff_tmp)
294         CALL histwrite_real (pfileid, varid, pitau, nbpt_out, &         CALL histwrite_real (fileid, varid, itau, nbpt_out, &
295              &            buff_tmp, nbindex, nindex, do_oper, do_write)              buff_tmp, nbindex, nindex, do_oper, do_write)
296      ENDIF      ENDIF
297    
298      ! 6.0 Manage time steps      ! 6.0 Manage time steps
299    
300      IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN      IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
301         last_opp_chk(pfileid, varid) = pitau         last_opp_chk(fileid, varid) = itau
302         last_wrt_chk(pfileid, varid) = pitau         last_wrt_chk(fileid, varid) = itau
303      ELSE      ELSE
304         last_opp_chk(pfileid, varid) = -99         last_opp_chk(fileid, varid) = -99
305         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(fileid, varid) = -99
306      ENDIF      ENDIF
307    
308    END SUBROUTINE histwrite_r2d    END SUBROUTINE histwrite_r2d
309    
310    !************************************************************************    !************************************************************************
311    
312    SUBROUTINE histwrite_r3d (pfileid, pvarname, pitau, pdata)    SUBROUTINE histwrite_r3d (fileid, varname, itau, pdata)
   
     use calendar, only: isittime  
     USE errioipsl, ONLY : histerr  
     USE mathop_m, ONLY : mathop  
     USE histcom_var, ONLY : datasz_in, datasz_max, date0, deltat, &  
          freq_opp, freq_wrt, fuchnbout, last_opp, last_opp_chk, last_wrt, &  
          last_wrt_chk, missing_val, nbopp, nb_files, scal, scsize, sopps, &  
          topp  
     use histvar_seq_m, only: histvar_seq  
     use histwrite_real_m, only: histwrite_real  
313    
314      INTEGER, INTENT(IN):: pfileid, pitau      INTEGER, INTENT(IN):: fileid, itau
315      REAL, DIMENSION(:, :, :), INTENT(IN):: pdata      REAL, DIMENSION(:, :, :), INTENT(IN):: pdata
316      CHARACTER(LEN=*), INTENT(IN):: pvarname      CHARACTER(LEN=*), INTENT(IN):: varname
317    
318      integer nbindex, nindex(size(pdata))      integer nbindex, nindex(size(pdata))
319      LOGICAL:: do_oper, do_write, largebuf      LOGICAL:: do_oper, do_write, largebuf
# Line 356  CONTAINS Line 330  CONTAINS
330      ! 1.0 Try to catch errors like specifying the wrong file ID.      ! 1.0 Try to catch errors like specifying the wrong file ID.
331      !     Thanks Marine for showing us what errors users can make !      !     Thanks Marine for showing us what errors users can make !
332    
333      IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN      IF ( (fileid < 1).OR.(fileid > nb_files) ) THEN
334         CALL histerr (3, "histwrite", &         CALL histerr (3, "histwrite", &
335              &    'Illegal file ID in the histwrite of variable', pvarname, ' ')              'Illegal file ID in the histwrite of variable', varname, ' ')
336      ENDIF      ENDIF
337    
338      ! 1.1 Find the id of the variable to be written and the real time      ! 1.1 Find the id of the variable to be written and the real time
339    
340      CALL histvar_seq (pfileid, pvarname, varid)      CALL histvar_seq (fileid, varname, varid)
341    
342      ! 2.0 do nothing for never operation      ! 2.0 do nothing for never operation
343    
344      tmp_opp = topp(pfileid, varid)      tmp_opp = topp(fileid, varid)
345    
346      IF (TRIM(tmp_opp) == "never") THEN      IF (TRIM(tmp_opp) == "never") THEN
347         last_opp_chk(pfileid, varid) = -99         last_opp_chk(fileid, varid) = -99
348         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(fileid, varid) = -99
349      ENDIF      ENDIF
350    
351      ! 3.0 We check if we need to do an operation      ! 3.0 We check if we need to do an operation
352    
353      IF (last_opp_chk(pfileid, varid) == pitau) THEN      IF (last_opp_chk(fileid, varid) == itau) THEN
354         CALL histerr (3, "histwrite", &         CALL histerr (3, "histwrite", &
355              &    'This variable as already been analysed at the present', &              'This variable as already been analysed at the present', &
356              &    'time step', ' ')              'time step', ' ')
357      ENDIF      ENDIF
358    
359      CALL isittime &      CALL isittime &
360           &  (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), &           (itau, date0(fileid), deltat(fileid), freq_opp(fileid, varid), &
361           &   last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper)           last_opp(fileid, varid), last_opp_chk(fileid, varid), do_oper)
362    
363      ! 4.0 We check if we need to write the data      ! 4.0 We check if we need to write the data
364    
365      IF (last_wrt_chk(pfileid, varid) == pitau) THEN      IF (last_wrt_chk(fileid, varid) == itau) THEN
366         CALL histerr (3, "histwrite", &         CALL histerr (3, "histwrite", &
367              &    'This variable as already been written for the present', &              'This variable as already been written for the present', &
368              &    'time step', ' ')              'time step', ' ')
369      ENDIF      ENDIF
370    
371      CALL isittime &      CALL isittime &
372           &  (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), &           (itau, date0(fileid), deltat(fileid), freq_wrt(fileid, varid), &
373           &   last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write)           last_wrt(fileid, varid), last_wrt_chk(fileid, varid), do_write)
374    
375      ! 5.0 histwrite called      ! 5.0 histwrite called
376    
# Line 404  CONTAINS Line 378  CONTAINS
378    
379         !- 5.1 Get the sizes of the data we will handle         !- 5.1 Get the sizes of the data we will handle
380    
381         IF (datasz_in(pfileid, varid, 1) <= 0) THEN         IF (datasz_in(fileid, varid, 1) <= 0) THEN
382            !--- There is the risk here that the user has over-sized the array.            !--- There is the risk here that the user has over-sized the array.
383            !--- But how can we catch this ?            !--- But how can we catch this ?
384            !--- In the worst case we will do impossible operations            !--- In the worst case we will do impossible operations
385            !--- on part of the data !            !--- on part of the data !
386            datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1)            datasz_in(fileid, varid, 1) = SIZE(pdata, DIM=1)
387            datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2)            datasz_in(fileid, varid, 2) = SIZE(pdata, DIM=2)
388            datasz_in(pfileid, varid, 3) = SIZE(pdata, DIM=3)            datasz_in(fileid, varid, 3) = SIZE(pdata, DIM=3)
389         ENDIF         ENDIF
390    
391         !- 5.2 The maximum size of the data will give the size of the buffer         !- 5.2 The maximum size of the data will give the size of the buffer
392    
393         IF (datasz_max(pfileid, varid) <= 0) THEN         IF (datasz_max(fileid, varid) <= 0) THEN
394            largebuf = .FALSE.            largebuf = .FALSE.
395            DO io =1, nbopp(pfileid, varid)            DO io =1, nbopp(fileid, varid)
396               IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN               IF (INDEX(fuchnbout, sopps(fileid, varid, io)) > 0) THEN
397                  largebuf = .TRUE.                  largebuf = .TRUE.
398               ENDIF               ENDIF
399            ENDDO            ENDDO
400            IF (largebuf) THEN            IF (largebuf) THEN
401               datasz_max(pfileid, varid) = &               datasz_max(fileid, varid) = &
402                    &        scsize(pfileid, varid, 1) &                    scsize(fileid, varid, 1) &
403                    &       *scsize(pfileid, varid, 2) &                    *scsize(fileid, varid, 2) &
404                    &       *scsize(pfileid, varid, 3)                    *scsize(fileid, varid, 3)
405            ELSE            ELSE
406               datasz_max(pfileid, varid) = &               datasz_max(fileid, varid) = &
407                    &        datasz_in(pfileid, varid, 1) &                    datasz_in(fileid, varid, 1) &
408                    &       *datasz_in(pfileid, varid, 2) &                    *datasz_in(fileid, varid, 2) &
409                    &       *datasz_in(pfileid, varid, 3)                    *datasz_in(fileid, varid, 3)
410            ENDIF            ENDIF
411         ENDIF         ENDIF
412    
413         IF (.NOT.ALLOCATED(buff_tmp)) THEN         IF (.NOT.ALLOCATED(buff_tmp)) THEN
414            ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))            ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
415            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(fileid, varid)
416         ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN         ELSE IF (datasz_max(fileid, varid) > buff_tmp_sz) THEN
417            DEALLOCATE (buff_tmp)            DEALLOCATE (buff_tmp)
418            ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))            ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
419            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(fileid, varid)
420         ENDIF         ENDIF
421    
422         !- We have to do the first operation anyway.         !- We have to do the first operation anyway.
423         !- Thus we do it here and change the ranke         !- Thus we do it here and change the ranke
424         !- of the data at the same time. This should speed up things.         !- of the data at the same time. This should speed up things.
425    
426         nbpt_in(1:3) = datasz_in(pfileid, varid, 1:3)         nbpt_in(1:3) = datasz_in(fileid, varid, 1:3)
427         nbpt_out = datasz_max(pfileid, varid)         nbpt_out = datasz_max(fileid, varid)
428         CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, &         CALL mathop (sopps(fileid, varid, 1), nbpt_in, pdata, &
429              &               missing_val, nbindex, nindex, &              missing_val, nbindex, nindex, &
430              &               scal(pfileid, varid, 1), nbpt_out, buff_tmp)              scal(fileid, varid, 1), nbpt_out, buff_tmp)
431         CALL histwrite_real (pfileid, varid, pitau, nbpt_out, &         CALL histwrite_real (fileid, varid, itau, nbpt_out, &
432              &            buff_tmp, nbindex, nindex, do_oper, do_write)              buff_tmp, nbindex, nindex, do_oper, do_write)
433      ENDIF      ENDIF
434    
435      ! 6.0 Manage time steps      ! 6.0 Manage time steps
436    
437      IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN      IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
438         last_opp_chk(pfileid, varid) = pitau         last_opp_chk(fileid, varid) = itau
439         last_wrt_chk(pfileid, varid) = pitau         last_wrt_chk(fileid, varid) = itau
440      ELSE      ELSE
441         last_opp_chk(pfileid, varid) = -99         last_opp_chk(fileid, varid) = -99
442         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(fileid, varid) = -99
443      ENDIF      ENDIF
444    
445    END SUBROUTINE histwrite_r3d    END SUBROUTINE histwrite_r3d
Legend:
Removed from v.56  
changed lines
  Added in v.92
  ViewVC Help
Powered by ViewVC 1.1.21