/[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 31 by guez, Thu Apr 1 14:59:19 2010 UTC trunk/IOIPSL/histwrite.f90 revision 76 by guez, Fri Nov 15 18:45:49 2013 UTC
# Line 4  MODULE histwrite_m Line 4  MODULE histwrite_m
4    
5    implicit none    implicit none
6    
   PRIVATE  
   PUBLIC histwrite  
   
7    INTERFACE histwrite    INTERFACE histwrite
8       ! The "histwrite" procedures give the data to the input-output system.       ! The "histwrite" procedures give the data to the input-output system.
9       ! They trigger the operations to be performed and the writing to       ! They trigger the operations to be performed and the writing to
# Line 16  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
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 mathelp, 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      INTEGER, INTENT(IN) :: pfileid, pitau           last_wrt_chk, missing_val, nbopp, nb_files, scal, scsize, sopps, &
46      REAL, INTENT(IN) :: pdata(:)           topp
47      CHARACTER(LEN=*), INTENT(IN) :: pvarname      use histvar_seq_m, only: histvar_seq
48        use histwrite_real_m, only: histwrite_real
49    
50        INTEGER, INTENT(IN):: fileid, itau
51        CHARACTER(LEN=*), INTENT(IN):: varname
52        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 69  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 mathelp, 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      INTEGER, INTENT(IN) :: pfileid, pitau           last_wrt_chk, missing_val, nbopp, nb_files, scal, scsize, sopps, &
186      REAL, DIMENSION(:, :), INTENT(IN) :: pdata           topp
187      CHARACTER(LEN=*), INTENT(IN) :: pvarname      use histvar_seq_m, only: histvar_seq
188        use histwrite_real_m, only: histwrite_real
189    
190        INTEGER, INTENT(IN):: fileid, itau
191        REAL, INTENT(IN):: pdata(:, :)
192        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 210  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 260  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 mathelp, 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      INTEGER, INTENT(IN) :: pfileid, pitau           last_wrt_chk, missing_val, nbopp, nb_files, scal, scsize, sopps, &
329      REAL, DIMENSION(:, :, :), INTENT(IN) :: pdata           topp
330      CHARACTER(LEN=*), INTENT(IN) :: pvarname      use histvar_seq_m, only: histvar_seq
331        use histwrite_real_m, only: histwrite_real
332    
333        INTEGER, INTENT(IN):: fileid, itau
334        REAL, DIMENSION(:, :, :), INTENT(IN):: pdata
335        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 354  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 402  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
     ENDIF  
     !--------------------------  
   END SUBROUTINE histwrite_r3d  
   
   !===  
   
   SUBROUTINE histwrite_real(pfileid, varid, pitau, nbdpt, buff_tmp, nbindex, &  
        nindex, do_oper, do_write)  
   
     ! This subroutine is internal and does the calculations and writing  
     ! if needed. At a later stage it should be split into an operation  
     ! and writing subroutines.  
     !--------------------------------------------------------------------  
   
     USE mathelp, ONLY : mathop, trans_buff, moycum  
     use netcdf, only: NF90_PUT_VAR  
     use histcom_var  
   
     INTEGER, INTENT(IN) :: pfileid, pitau, varid, &  
          &                      nbindex, nindex(nbindex), nbdpt  
     REAL, DIMENSION(:)  :: buff_tmp  
     LOGICAL, INTENT(IN) :: do_oper, do_write  
   
     INTEGER :: tsz, ncid, ncvarid  
     INTEGER :: i, iret, ipt, itax  
     INTEGER :: io, nbin, nbout  
     INTEGER, DIMENSION(4) :: corner, edges  
     INTEGER :: itime  
   
     REAL :: rtime  
     CHARACTER(LEN=7) :: tmp_opp  
   
     REAL, ALLOCATABLE, SAVE :: buff_tmp2(:)  
     INTEGER, SAVE          :: buff_tmp2_sz  
     REAL, ALLOCATABLE, SAVE :: buffer_used(:)  
     INTEGER, SAVE          :: buffer_sz  
   
     !--------------------------------------------------------------------  
   
     ! The sizes which can be encoutered  
   
     tsz = zsize(pfileid, varid, 1)*zsize(pfileid, varid, 2)*zsize(pfileid, varid, 3)  
   
     ! 1.0 We allocate the memory needed to store the data between write  
     !     and the temporary space needed for operations.  
     !     We have to keep precedent buffer if needed  
   
     IF (.NOT. ALLOCATED(buffer)) THEN  
        ALLOCATE(buffer(buff_pos))  
        buffer_sz = buff_pos  
        buffer(:)=0.0  
     ELSE IF (buffer_sz < buff_pos) THEN  
        IF (SUM(buffer)/=0.0) THEN  
           ALLOCATE (buffer_used(buffer_sz))  
           buffer_used(:)=buffer(:)  
           DEALLOCATE (buffer)  
           ALLOCATE (buffer(buff_pos))  
           buffer_sz = buff_pos  
           buffer(:SIZE(buffer_used))=buffer_used  
           DEALLOCATE (buffer_used)  
        ELSE  
           DEALLOCATE (buffer)  
           ALLOCATE (buffer(buff_pos))  
           buffer_sz = buff_pos  
           buffer(:)=0.0  
        ENDIF  
462      ENDIF      ENDIF
463    
464      ! The buffers are only deallocated when more space is needed. This    END SUBROUTINE histwrite_r3d
     ! reduces the umber of allocates but increases memory needs.  
   
     IF (.NOT.ALLOCATED(buff_tmp2)) THEN  
        ALLOCATE (buff_tmp2(datasz_max(pfileid, varid)))  
        buff_tmp2_sz = datasz_max(pfileid, varid)  
     ELSE IF ( datasz_max(pfileid, varid) > buff_tmp2_sz) THEN  
        DEALLOCATE (buff_tmp2)  
        ALLOCATE (buff_tmp2(datasz_max(pfileid, varid)))  
        buff_tmp2_sz = datasz_max(pfileid, varid)  
     ENDIF  
   
     rtime = pitau * deltat(pfileid)  
     tmp_opp = topp(pfileid, varid)  
   
     ! 3.0 Do the operations or transfer the slab of data into buff_tmp  
   
     ! 3.1 DO the Operations only if needed  
   
     IF ( do_oper ) THEN  
        i = pfileid  
        nbout = nbdpt  
   
        !- 3.4 We continue the sequence of operations  
        !-     we started in the interface routine  
   
        DO io = 2, nbopp(i, varid), 2  
           nbin = nbout  
           nbout = datasz_max(i, varid)  
           CALL mathop(sopps(i, varid, io), nbin, buff_tmp, missing_val, &  
                &      nbindex, nindex, scal(i, varid, io), nbout, buff_tmp2)  
   
           nbin = nbout  
           nbout = datasz_max(i, varid)  
           CALL mathop(sopps(i, varid, io+1), nbin, buff_tmp2, missing_val, &  
                &      nbindex, nindex, scal(i, varid, io+1), nbout, buff_tmp)  
        ENDDO  
   
        !   3.5 Zoom into the data  
   
        CALL trans_buff &  
             &      (zorig(i, varid, 1), zsize(i, varid, 1), &  
             &       zorig(i, varid, 2), zsize(i, varid, 2), &  
             &       zorig(i, varid, 3), zsize(i, varid, 3), &  
             &       scsize(i, varid, 1), scsize(i, varid, 2), scsize(i, varid, 3), &  
             &       buff_tmp, buff_tmp2_sz, buff_tmp2)  
   
        !- 5.0 Do the operations if needed. In the case of instantaneous  
        !-     output we do not transfer to the buffer.  
   
        ipt = point(pfileid, varid)  
   
        IF (     (TRIM(tmp_opp) /= "inst") &  
             &    .AND.(TRIM(tmp_opp) /= "once") ) THEN  
           CALL moycum(tmp_opp, tsz, buffer(ipt:), &  
                &       buff_tmp2, nb_opp(pfileid, varid))  
        ENDIF  
   
        last_opp(pfileid, varid) = pitau  
        nb_opp(pfileid, varid) = nb_opp(pfileid, varid)+1  
   
     ENDIF  
   
     ! 6.0 Write to file if needed  
   
     IF ( do_write ) THEN  
   
        ncvarid = ncvar_ids(pfileid, varid)  
        ncid = ncdf_ids(pfileid)  
   
        !- 6.1 Do the operations that are needed before writting  
   
        IF (     (TRIM(tmp_opp) /= "inst") &  
             &    .AND.(TRIM(tmp_opp) /= "once") ) THEN  
           rtime = (rtime+last_wrt(pfileid, varid)*deltat(pfileid))/2.0  
        ENDIF  
   
        !- 6.2 Add a value to the time axis of this variable if needed  
   
        IF (     (TRIM(tmp_opp) /= "l_max") &  
             &    .AND.(TRIM(tmp_opp) /= "l_min") &  
             &    .AND.(TRIM(tmp_opp) /= "once") ) THEN  
   
           itax = var_axid(pfileid, varid)  
           itime = nb_wrt(pfileid, varid)+1  
   
           IF (tax_last(pfileid, itax) < itime) THEN  
              iret = NF90_PUT_VAR (ncid, tdimid(pfileid, itax), (/ rtime /), &  
                   &                            start=(/ itime /), count=(/ 1 /))  
              tax_last(pfileid, itax) = itime  
           ENDIF  
        ELSE  
           itime=1  
        ENDIF  
   
        !- 6.3 Write the data. Only in the case of instantaneous output  
        !       we do not write the buffer.  
   
        IF (scsize(pfileid, varid, 3) == 1) THEN  
           IF (regular(pfileid)) THEN  
              corner(1:4) = (/ 1, 1, itime, 0 /)  
              edges(1:4) = (/ zsize(pfileid, varid, 1), &  
                   &                      zsize(pfileid, varid, 2), &  
                   &                       1, 0 /)  
           ELSE  
              corner(1:4) = (/ 1, itime, 0, 0 /)  
              edges(1:4) = (/ zsize(pfileid, varid, 1), 1, 0, 0 /)  
           ENDIF  
        ELSE  
           IF ( regular(pfileid) ) THEN  
              corner(1:4) = (/ 1, 1, 1, itime /)  
              edges(1:4) = (/ zsize(pfileid, varid, 1), &  
                   &                      zsize(pfileid, varid, 2), &  
                   &                      zsize(pfileid, varid, 3), 1 /)  
           ELSE  
              corner(1:4) = (/ 1, 1, itime, 0 /)  
              edges(1:4) = (/ zsize(pfileid, varid, 1), &  
                   &                      zsize(pfileid, varid, 3), 1, 0 /)  
           ENDIF  
        ENDIF  
   
        ipt = point(pfileid, varid)  
   
        IF (     (TRIM(tmp_opp) /= "inst") &  
             &      .AND.(TRIM(tmp_opp) /= "once") ) THEN  
           iret = NF90_PUT_VAR (ncid, ncvarid, buffer(ipt:), &  
                &                       start=corner(1:4), count=edges(1:4))  
        ELSE  
           iret = NF90_PUT_VAR (ncid, ncvarid, buff_tmp2, &  
                &                       start=corner(1:4), count=edges(1:4))  
        ENDIF  
   
        last_wrt(pfileid, varid) = pitau  
        nb_wrt(pfileid, varid) = nb_wrt(pfileid, varid)+1  
        nb_opp(pfileid, varid) = 0  
        !--  
        !   After the write the file can be synchronized so that no data is  
        !   lost in case of a crash. This feature gives up on the benefits of  
        !   buffering and should only be used in debuging mode. A flag is  
        !   needed here to switch to this mode.  
        !--  
        !   iret = NF90_SYNC (ncid)  
   
     ENDIF  
     !---------------------------  
   END SUBROUTINE histwrite_real  
   
   !*************************************************************  
   
   SUBROUTINE histvar_seq (pfid, pvarname, pvid)  
   
     ! This subroutine optimized the search for the variable in the table.  
     ! In a first phase it will learn the succession of the variables  
     ! called and then it will use the table to guess what comes next.  
     ! It is the best solution to avoid lengthy searches through array  
     ! vectors.  
   
     ! ARGUMENTS :  
   
     ! pfid  : id of the file on which we work  
     ! pvarname : The name of the variable we are looking for  
     ! pvid     : The var id we found  
   
     USE stringop, ONLY: find_str  
     USE errioipsl, ONLY : histerr  
     use histcom_var  
   
     INTEGER, INTENT(in)  :: pfid  
     CHARACTER(LEN=*), INTENT(IN) :: pvarname  
     INTEGER, INTENT(out) :: pvid  
   
     LOGICAL, SAVE :: learning(nb_files_max)=.TRUE.  
     INTEGER, SAVE :: overlap(nb_files_max) = -1  
     INTEGER, SAVE :: varseq(nb_files_max, nb_var_max*3)  
     INTEGER, SAVE :: varseq_len(nb_files_max) = 0  
     INTEGER, SAVE :: varseq_pos(nb_files_max)  
     INTEGER, SAVE :: varseq_err(nb_files_max) = 0  
     INTEGER      :: nb, sp, nx, pos, ib  
     CHARACTER(LEN=20), DIMENSION(nb_var_max) :: tab_str20  
     CHARACTER(LEN=20) :: str20  
     CHARACTER(LEN=70) :: str70  
     INTEGER      :: tab_str20_length(nb_var_max)  
   
     !--------------------------------------------------------------------  
     nb = nb_var(pfid)  
   
     IF (learning(pfid)) THEN  
   
        !- 1.0 We compute the length over which we are going  
        !-     to check the overlap  
   
        IF (overlap(pfid) <= 0) THEN  
           IF (nb_var(pfid) > 6) THEN  
              overlap(pfid) = nb_var(pfid)/3*2  
           ELSE  
              overlap(pfid) = nb_var(pfid)  
           ENDIF  
        ENDIF  
   
        !- 1.1 Find the position of this string  
   
        str20 = pvarname  
        tab_str20(1:nb) = name(pfid, 1:nb)  
        tab_str20_length(1:nb) = name_length(pfid, 1:nb)  
   
        CALL find_str (nb, tab_str20, tab_str20_length, str20, pos)  
   
        IF (pos > 0) THEN  
           pvid = pos  
        ELSE  
           CALL histerr (3, "histvar_seq", &  
                &      'The name of the variable you gave has not been declared', &  
                &      'You should use subroutine histdef for declaring variable', &  
                &      TRIM(str20))  
        ENDIF  
   
        !- 1.2 If we have not given up we store the position  
        !-     in the sequence of calls  
   
        IF ( varseq_err(pfid) .GE. 0 ) THEN  
           sp = varseq_len(pfid)+1  
           IF (sp <= nb_var_max*3) THEN  
              varseq(pfid, sp) = pvid  
              varseq_len(pfid) = sp  
           ELSE  
              CALL histerr (2, "histvar_seq", &  
                   &       'The learning process has failed and we give up. '// &  
                   &       'Either you sequence is', &  
                   &       'too complex or I am too dumb. '// &  
                   &       'This will only affect the efficiency', &  
                   &       'of your code. Thus if you wish to save time'// &  
                   &       ' contact the IOIPSL team. ')  
              WRITE(*, *) 'The sequence we have found up to now :'  
              WRITE(*, *) varseq(pfid, 1:sp-1)  
              varseq_err(pfid) = -1  
           ENDIF  
   
           !--- 1.3 Check if we have found the right overlap  
   
           IF (varseq_len(pfid) .GE. overlap(pfid)*2) THEN  
   
              !----- We skip a few variables if needed as they could come  
              !----- from the initialisation of the model.  
   
              DO ib = 0, sp-overlap(pfid)*2  
                 IF ( learning(pfid) .AND.&  
                      & SUM(ABS(varseq(pfid, ib+1:ib+overlap(pfid)) -&  
                      & varseq(pfid, sp-overlap(pfid)+1:sp))) == 0 ) THEN  
                    learning(pfid) = .FALSE.  
                    varseq_len(pfid) = sp-overlap(pfid)-ib  
                    varseq_pos(pfid) = overlap(pfid)+ib  
                    varseq(pfid, 1:varseq_len(pfid)) = &  
                         &            varseq(pfid, ib+1:ib+varseq_len(pfid))  
                 ENDIF  
              ENDDO  
           ENDIF  
        ENDIF  
     ELSE  
   
        !- 2.0 Now we know how the calls to histwrite are sequenced  
        !-     and we can get a guess at the var ID  
   
        nx = varseq_pos(pfid)+1  
        IF (nx > varseq_len(pfid)) nx = 1  
   
        pvid = varseq(pfid, nx)  
   
        IF (    (INDEX(name(pfid, pvid), pvarname) <= 0)         &  
             &    .OR.(name_length(pfid, pvid) /= len_trim(pvarname)) ) THEN  
           str20 = pvarname  
           tab_str20(1:nb) = name(pfid, 1:nb)  
           tab_str20_length(1:nb) = name_length(pfid, 1:nb)  
           CALL find_str (nb, tab_str20, tab_str20_length, str20, pos)  
           IF (pos > 0) THEN  
              pvid = pos  
           ELSE  
              CALL histerr(3, "histvar_seq", &  
                   &  'The name of the variable you gave has not been declared', &  
                   &  'You should use subroutine histdef for declaring variable', str20)  
           ENDIF  
           varseq_err(pfid) = varseq_err(pfid)+1  
        ELSE  
   
           !--- We only keep the new position if we have found the variable  
           !--- this way. This way an out of sequence call to histwrite does  
           !--- not defeat the process.  
   
           varseq_pos(pfid) = nx  
        ENDIF  
   
        IF (varseq_err(pfid) .GE. 10) THEN  
           WRITE(str70, '("for file ", I3)') pfid  
           CALL histerr(2, "histvar_seq", &  
                &  'There were 10 errors in the learned sequence of variables', &  
                &  str70, 'This looks like a bug, please report it.')  
           varseq_err(pfid) = 0  
        ENDIF  
     ENDIF  
   
   END SUBROUTINE histvar_seq  
465    
466  END MODULE histwrite_m  END MODULE histwrite_m
Legend:
Removed from v.31  
changed lines
  Added in v.76
  ViewVC Help
Powered by ViewVC 1.1.21