/[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 45 by guez, Wed Apr 27 13:00:12 2011 UTC trunk/IOIPSL/histwrite.f90 revision 76 by guez, Fri Nov 15 18:45:49 2013 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) CALL histerr (3, "histwrite", &
229         CALL histerr (3, "histwrite", &           'This variable as already been analysed at the present', &
230              &    'This variable as already been analysed at the present', &           'time step', ' ')
231              &    'time step', ' ')  
232      ENDIF      CALL isittime(itau, date0(fileid), deltat(fileid), &
233             freq_opp(fileid, varid), last_opp(fileid, varid), &
234      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)  
235    
236      ! 4.0 We check if we need to write the data      ! 4.0 We check if we need to write the data
237    
238      IF (last_wrt_chk(pfileid, varid) == pitau) THEN      IF (last_wrt_chk(fileid, varid) == itau) THEN
239         CALL histerr (3, "histwrite", &         CALL histerr (3, "histwrite", &
240              &    'This variable as already been written for the present', &              'This variable as already been written for the present', &
241              &    'time step', ' ')              'time step', ' ')
242      ENDIF      ENDIF
243    
244      CALL isittime &      CALL isittime &
245           &  (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), &           (itau, date0(fileid), deltat(fileid), freq_wrt(fileid, varid), &
246           &   last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write)           last_wrt(fileid, varid), last_wrt_chk(fileid, varid), do_write)
247    
248      ! 5.0 histwrite called      ! 5.0 histwrite called
249    
# Line 263  CONTAINS Line 251  CONTAINS
251    
252         !- 5.1 Get the sizes of the data we will handle         !- 5.1 Get the sizes of the data we will handle
253    
254         IF (datasz_in(pfileid, varid, 1) <= 0) THEN         IF (datasz_in(fileid, varid, 1) <= 0) THEN
255            !--- 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.
256            !--- But how can we catch this ?            !--- But how can we catch this ?
257            !--- In the worst case we will do impossible operations            !--- In the worst case we will do impossible operations
258            !--- on part of the data !            !--- on part of the data !
259            datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1)            datasz_in(fileid, varid, 1) = SIZE(pdata, DIM=1)
260            datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2)            datasz_in(fileid, varid, 2) = SIZE(pdata, DIM=2)
261            datasz_in(pfileid, varid, 3) = -1            datasz_in(fileid, varid, 3) = -1
262         ENDIF         ENDIF
263    
264         !- 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
265    
266         IF (datasz_max(pfileid, varid) <= 0) THEN         IF (datasz_max(fileid, varid) <= 0) THEN
267            largebuf = .FALSE.            largebuf = .FALSE.
268            DO io=1, nbopp(pfileid, varid)            DO io=1, nbopp(fileid, varid)
269               IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN               IF (INDEX(fuchnbout, sopps(fileid, varid, io)) > 0) THEN
270                  largebuf = .TRUE.                  largebuf = .TRUE.
271               ENDIF               ENDIF
272            ENDDO            ENDDO
273            IF (largebuf) THEN            IF (largebuf) THEN
274               datasz_max(pfileid, varid) = &               datasz_max(fileid, varid) = &
275                    &        scsize(pfileid, varid, 1) &                    scsize(fileid, varid, 1) &
276                    &       *scsize(pfileid, varid, 2) &                    *scsize(fileid, varid, 2) &
277                    &       *scsize(pfileid, varid, 3)                    *scsize(fileid, varid, 3)
278            ELSE            ELSE
279               datasz_max(pfileid, varid) = &               datasz_max(fileid, varid) = &
280                    &        datasz_in(pfileid, varid, 1) &                    datasz_in(fileid, varid, 1) &
281                    &       *datasz_in(pfileid, varid, 2)                    *datasz_in(fileid, varid, 2)
282            ENDIF            ENDIF
283         ENDIF         ENDIF
284    
285         IF (.NOT.ALLOCATED(buff_tmp)) THEN         IF (.NOT.ALLOCATED(buff_tmp)) THEN
286            ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))            ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
287            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(fileid, varid)
288         ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN         ELSE IF (datasz_max(fileid, varid) > buff_tmp_sz) THEN
289            DEALLOCATE (buff_tmp)            DEALLOCATE (buff_tmp)
290            ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))            ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
291            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(fileid, varid)
292         ENDIF         ENDIF
293    
294         !- We have to do the first operation anyway.         !- We have to do the first operation anyway.
295         !- Thus we do it here and change the ranke         !- Thus we do it here and change the ranke
296         !- of the data at the same time. This should speed up things.         !- of the data at the same time. This should speed up things.
297    
298         nbpt_in(1:2) = datasz_in(pfileid, varid, 1:2)         nbpt_in(1:2) = datasz_in(fileid, varid, 1:2)
299         nbpt_out = datasz_max(pfileid, varid)         nbpt_out = datasz_max(fileid, varid)
300         CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, &         CALL mathop (sopps(fileid, varid, 1), nbpt_in, pdata, &
301              &               missing_val, nbindex, nindex, &              missing_val, nbindex, nindex, &
302              &               scal(pfileid, varid, 1), nbpt_out, buff_tmp)              scal(fileid, varid, 1), nbpt_out, buff_tmp)
303         CALL histwrite_real (pfileid, varid, pitau, nbpt_out, &         CALL histwrite_real (fileid, varid, itau, nbpt_out, &
304              &            buff_tmp, nbindex, nindex, do_oper, do_write)              buff_tmp, nbindex, nindex, do_oper, do_write)
305      ENDIF      ENDIF
306    
307      ! 6.0 Manage time steps      ! 6.0 Manage time steps
308    
309      IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN      IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
310         last_opp_chk(pfileid, varid) = pitau         last_opp_chk(fileid, varid) = itau
311         last_wrt_chk(pfileid, varid) = pitau         last_wrt_chk(fileid, varid) = itau
312      ELSE      ELSE
313         last_opp_chk(pfileid, varid) = -99         last_opp_chk(fileid, varid) = -99
314         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(fileid, varid) = -99
315      ENDIF      ENDIF
316      !--------------------------  
317    END SUBROUTINE histwrite_r2d    END SUBROUTINE histwrite_r2d
318    
319    !===    !************************************************************************
320    
321    SUBROUTINE histwrite_r3d (pfileid, pvarname, pitau, pdata)    SUBROUTINE histwrite_r3d (fileid, varname, itau, pdata)
     !--------------------------------------------------------------------  
322    
323      use calendar, only: isittime      use calendar, only: isittime
324      USE errioipsl, ONLY : histerr      USE errioipsl, ONLY: histerr
325      USE mathop_m, ONLY : mathop      USE mathop_m, ONLY: mathop
326      use histcom_var      USE histcom_var, ONLY: datasz_in, datasz_max, date0, deltat, &
327             freq_opp, freq_wrt, fuchnbout, last_opp, last_opp_chk, last_wrt, &
328             last_wrt_chk, missing_val, nbopp, nb_files, scal, scsize, sopps, &
329             topp
330      use histvar_seq_m, only: histvar_seq      use histvar_seq_m, only: histvar_seq
331      use histwrite_real_m, only: histwrite_real      use histwrite_real_m, only: histwrite_real
332    
333      INTEGER, INTENT(IN) :: pfileid, pitau      INTEGER, INTENT(IN):: fileid, itau
334      REAL, DIMENSION(:, :, :), INTENT(IN) :: pdata      REAL, DIMENSION(:, :, :), INTENT(IN):: pdata
335      CHARACTER(LEN=*), INTENT(IN) :: pvarname      CHARACTER(LEN=*), INTENT(IN):: varname
336    
337      integer nbindex, nindex(size(pdata))      integer nbindex, nindex(size(pdata))
338      LOGICAL :: do_oper, do_write, largebuf      LOGICAL:: do_oper, do_write, largebuf
339      INTEGER :: varid, io, nbpt_in(1:3), nbpt_out      INTEGER:: varid, io, nbpt_in(1:3), nbpt_out
340      REAL, ALLOCATABLE, SAVE :: buff_tmp(:)      REAL, ALLOCATABLE, SAVE:: buff_tmp(:)
341      INTEGER, SAVE :: buff_tmp_sz      INTEGER, SAVE:: buff_tmp_sz
342      CHARACTER(LEN=7) :: tmp_opp      CHARACTER(LEN=7):: tmp_opp
343    
344      !--------------------------------------------------------------------      !--------------------------------------------------------------------
345    
# Line 359  CONTAINS Line 349  CONTAINS
349      ! 1.0 Try to catch errors like specifying the wrong file ID.      ! 1.0 Try to catch errors like specifying the wrong file ID.
350      !     Thanks Marine for showing us what errors users can make !      !     Thanks Marine for showing us what errors users can make !
351    
352      IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN      IF ( (fileid < 1).OR.(fileid > nb_files) ) THEN
353         CALL histerr (3, "histwrite", &         CALL histerr (3, "histwrite", &
354              &    'Illegal file ID in the histwrite of variable', pvarname, ' ')              'Illegal file ID in the histwrite of variable', varname, ' ')
355      ENDIF      ENDIF
356    
357      ! 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
358    
359      CALL histvar_seq (pfileid, pvarname, varid)      CALL histvar_seq (fileid, varname, varid)
360    
361      ! 2.0 do nothing for never operation      ! 2.0 do nothing for never operation
362    
363      tmp_opp = topp(pfileid, varid)      tmp_opp = topp(fileid, varid)
364    
365      IF (TRIM(tmp_opp) == "never") THEN      IF (TRIM(tmp_opp) == "never") THEN
366         last_opp_chk(pfileid, varid) = -99         last_opp_chk(fileid, varid) = -99
367         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(fileid, varid) = -99
368      ENDIF      ENDIF
369    
370      ! 3.0 We check if we need to do an operation      ! 3.0 We check if we need to do an operation
371    
372      IF (last_opp_chk(pfileid, varid) == pitau) THEN      IF (last_opp_chk(fileid, varid) == itau) THEN
373         CALL histerr (3, "histwrite", &         CALL histerr (3, "histwrite", &
374              &    'This variable as already been analysed at the present', &              'This variable as already been analysed at the present', &
375              &    'time step', ' ')              'time step', ' ')
376      ENDIF      ENDIF
377    
378      CALL isittime &      CALL isittime &
379           &  (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), &           (itau, date0(fileid), deltat(fileid), freq_opp(fileid, varid), &
380           &   last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper)           last_opp(fileid, varid), last_opp_chk(fileid, varid), do_oper)
381    
382      ! 4.0 We check if we need to write the data      ! 4.0 We check if we need to write the data
383    
384      IF (last_wrt_chk(pfileid, varid) == pitau) THEN      IF (last_wrt_chk(fileid, varid) == itau) THEN
385         CALL histerr (3, "histwrite", &         CALL histerr (3, "histwrite", &
386              &    'This variable as already been written for the present', &              'This variable as already been written for the present', &
387              &    'time step', ' ')              'time step', ' ')
388      ENDIF      ENDIF
389    
390      CALL isittime &      CALL isittime &
391           &  (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), &           (itau, date0(fileid), deltat(fileid), freq_wrt(fileid, varid), &
392           &   last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write)           last_wrt(fileid, varid), last_wrt_chk(fileid, varid), do_write)
393    
394      ! 5.0 histwrite called      ! 5.0 histwrite called
395    
# Line 407  CONTAINS Line 397  CONTAINS
397    
398         !- 5.1 Get the sizes of the data we will handle         !- 5.1 Get the sizes of the data we will handle
399    
400         IF (datasz_in(pfileid, varid, 1) <= 0) THEN         IF (datasz_in(fileid, varid, 1) <= 0) THEN
401            !--- 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.
402            !--- But how can we catch this ?            !--- But how can we catch this ?
403            !--- In the worst case we will do impossible operations            !--- In the worst case we will do impossible operations
404            !--- on part of the data !            !--- on part of the data !
405            datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1)            datasz_in(fileid, varid, 1) = SIZE(pdata, DIM=1)
406            datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2)            datasz_in(fileid, varid, 2) = SIZE(pdata, DIM=2)
407            datasz_in(pfileid, varid, 3) = SIZE(pdata, DIM=3)            datasz_in(fileid, varid, 3) = SIZE(pdata, DIM=3)
408         ENDIF         ENDIF
409    
410         !- 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
411    
412         IF (datasz_max(pfileid, varid) <= 0) THEN         IF (datasz_max(fileid, varid) <= 0) THEN
413            largebuf = .FALSE.            largebuf = .FALSE.
414            DO io =1, nbopp(pfileid, varid)            DO io =1, nbopp(fileid, varid)
415               IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN               IF (INDEX(fuchnbout, sopps(fileid, varid, io)) > 0) THEN
416                  largebuf = .TRUE.                  largebuf = .TRUE.
417               ENDIF               ENDIF
418            ENDDO            ENDDO
419            IF (largebuf) THEN            IF (largebuf) THEN
420               datasz_max(pfileid, varid) = &               datasz_max(fileid, varid) = &
421                    &        scsize(pfileid, varid, 1) &                    scsize(fileid, varid, 1) &
422                    &       *scsize(pfileid, varid, 2) &                    *scsize(fileid, varid, 2) &
423                    &       *scsize(pfileid, varid, 3)                    *scsize(fileid, varid, 3)
424            ELSE            ELSE
425               datasz_max(pfileid, varid) = &               datasz_max(fileid, varid) = &
426                    &        datasz_in(pfileid, varid, 1) &                    datasz_in(fileid, varid, 1) &
427                    &       *datasz_in(pfileid, varid, 2) &                    *datasz_in(fileid, varid, 2) &
428                    &       *datasz_in(pfileid, varid, 3)                    *datasz_in(fileid, varid, 3)
429            ENDIF            ENDIF
430         ENDIF         ENDIF
431    
432         IF (.NOT.ALLOCATED(buff_tmp)) THEN         IF (.NOT.ALLOCATED(buff_tmp)) THEN
433            ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))            ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
434            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(fileid, varid)
435         ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN         ELSE IF (datasz_max(fileid, varid) > buff_tmp_sz) THEN
436            DEALLOCATE (buff_tmp)            DEALLOCATE (buff_tmp)
437            ALLOCATE (buff_tmp(datasz_max(pfileid, varid)))            ALLOCATE (buff_tmp(datasz_max(fileid, varid)))
438            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(fileid, varid)
439         ENDIF         ENDIF
440    
441         !- We have to do the first operation anyway.         !- We have to do the first operation anyway.
442         !- Thus we do it here and change the ranke         !- Thus we do it here and change the ranke
443         !- of the data at the same time. This should speed up things.         !- of the data at the same time. This should speed up things.
444    
445         nbpt_in(1:3) = datasz_in(pfileid, varid, 1:3)         nbpt_in(1:3) = datasz_in(fileid, varid, 1:3)
446         nbpt_out = datasz_max(pfileid, varid)         nbpt_out = datasz_max(fileid, varid)
447         CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, &         CALL mathop (sopps(fileid, varid, 1), nbpt_in, pdata, &
448              &               missing_val, nbindex, nindex, &              missing_val, nbindex, nindex, &
449              &               scal(pfileid, varid, 1), nbpt_out, buff_tmp)              scal(fileid, varid, 1), nbpt_out, buff_tmp)
450         CALL histwrite_real (pfileid, varid, pitau, nbpt_out, &         CALL histwrite_real (fileid, varid, itau, nbpt_out, &
451              &            buff_tmp, nbindex, nindex, do_oper, do_write)              buff_tmp, nbindex, nindex, do_oper, do_write)
452      ENDIF      ENDIF
453    
454      ! 6.0 Manage time steps      ! 6.0 Manage time steps
455    
456      IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN      IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
457         last_opp_chk(pfileid, varid) = pitau         last_opp_chk(fileid, varid) = itau
458         last_wrt_chk(pfileid, varid) = pitau         last_wrt_chk(fileid, varid) = itau
459      ELSE      ELSE
460         last_opp_chk(pfileid, varid) = -99         last_opp_chk(fileid, varid) = -99
461         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(fileid, varid) = -99
462      ENDIF      ENDIF
463      !--------------------------  
464    END SUBROUTINE histwrite_r3d    END SUBROUTINE histwrite_r3d
465    
466  END MODULE histwrite_m  END MODULE histwrite_m
Legend:
Removed from v.45  
changed lines
  Added in v.76
  ViewVC Help
Powered by ViewVC 1.1.21