/[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

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