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

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

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

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