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

Diff of /trunk/IOIPSL/histwrite.f90

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

revision 30 by guez, Thu Apr 1 09:07:28 2010 UTC revision 45 by guez, Wed Apr 27 13:00:12 2011 UTC
# Line 1  Line 1 
1  MODULE histwrite_m  MODULE histwrite_m
2    
3    ! From histcom.f90, v 2.1 2004/04/21 09:27:10    ! From histcom.f90, version 2.1 2004/04/21 09:27:10
   
   use histcom_var  
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       ! They trigger the operations to be performed and the writing to
10       !- and the writing to the file if needed.       ! the file if needed.
11    
12       !- We test the work to be done at this time here so that at a       ! We test the work to be done at this time here so that at a
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):: pfileid
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.
# Line 44  MODULE histwrite_m Line 39  MODULE histwrite_m
39       MODULE PROCEDURE histwrite_r1d, histwrite_r2d, histwrite_r3d       MODULE PROCEDURE histwrite_r1d, histwrite_r2d, histwrite_r3d
40    END INTERFACE    END INTERFACE
41    
42      PRIVATE histwrite_r1d, histwrite_r2d, histwrite_r3d
43    
44  CONTAINS  CONTAINS
45    
46    SUBROUTINE histwrite_r1d(pfileid, pvarname, pitau, pdata)    SUBROUTINE histwrite_r1d(pfileid, pvarname, pitau, pdata)
47    
48      USE errioipsl, ONLY : histerr      USE errioipsl, ONLY : histerr
49      use calendar, only: isittime      use calendar, only: isittime
50      USE mathelp, ONLY : mathop      USE mathop_m, ONLY : mathop
51        use histcom_var
52        use histvar_seq_m, only: histvar_seq
53        use histwrite_real_m, only: histwrite_real
54    
55      INTEGER, INTENT(IN) :: pfileid, pitau      INTEGER, INTENT(IN) :: pfileid, pitau
56      REAL, INTENT(IN) :: pdata(:)      REAL, INTENT(IN) :: pdata(:)
# Line 64  CONTAINS Line 64  CONTAINS
64      INTEGER, SAVE :: buff_tmp_sz      INTEGER, SAVE :: buff_tmp_sz
65      CHARACTER(LEN=7) :: tmp_opp      CHARACTER(LEN=7) :: tmp_opp
66    
67      !---------------------------------------------------------------------      !--------------------------------------------------------------------
68    
69      nbindex = size(nindex)      nbindex = size(nindex)
70      nindex = 0      nindex = 0
# Line 118  CONTAINS Line 118  CONTAINS
118    
119      IF (do_oper.OR.do_write) THEN      IF (do_oper.OR.do_write) THEN
120    
121         !-- 5.1 Get the sizes of the data we will handle         !- 5.1 Get the sizes of the data we will handle
122    
123         IF (datasz_in(pfileid, varid, 1) <= 0) THEN         IF (datasz_in(pfileid, varid, 1) <= 0) THEN
124            !---- 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.
125            !---- But how can we catch this ?            !--- But how can we catch this ?
126            !---- In the worst case we will do impossible operations            !--- In the worst case we will do impossible operations
127            !---- on part of the data !            !--- on part of the data !
128            datasz_in(pfileid, varid, 1) = SIZE(pdata)            datasz_in(pfileid, varid, 1) = SIZE(pdata)
129            datasz_in(pfileid, varid, 2) = -1            datasz_in(pfileid, varid, 2) = -1
130            datasz_in(pfileid, varid, 3) = -1            datasz_in(pfileid, varid, 3) = -1
131         ENDIF         ENDIF
132    
133         !-- 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
134    
135         IF (datasz_max(pfileid, varid) <= 0) THEN         IF (datasz_max(pfileid, varid) <= 0) THEN
136            largebuf = .FALSE.            largebuf = .FALSE.
# Line 159  CONTAINS Line 159  CONTAINS
159            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(pfileid, varid)
160         ENDIF         ENDIF
161    
162         !-- We have to do the first operation anyway.         !- We have to do the first operation anyway.
163         !-- Thus we do it here and change the ranke         !- Thus we do it here and change the ranke
164         !-- of the data at the same time. This should speed up things.         !- of the data at the same time. This should speed up things.
165    
166         nbpt_in = datasz_in(pfileid, varid, 1)         nbpt_in = datasz_in(pfileid, varid, 1)
167         nbpt_out = datasz_max(pfileid, varid)         nbpt_out = datasz_max(pfileid, varid)
# Line 181  CONTAINS Line 181  CONTAINS
181         last_opp_chk(pfileid, varid) = -99         last_opp_chk(pfileid, varid) = -99
182         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(pfileid, varid) = -99
183      ENDIF      ENDIF
184      !---------------------------      !--------------------------
185    END SUBROUTINE histwrite_r1d    END SUBROUTINE histwrite_r1d
186    
187    !===    !===
188    
189    SUBROUTINE histwrite_r2d (pfileid, pvarname, pitau, pdata)    SUBROUTINE histwrite_r2d (pfileid, pvarname, pitau, pdata)
190      !---------------------------------------------------------------------      !--------------------------------------------------------------------
191    
192      use calendar, only: isittime      use calendar, only: isittime
193      USE errioipsl, ONLY : histerr      USE errioipsl, ONLY : histerr
194      USE mathelp, ONLY : mathop      USE mathop_m, ONLY : mathop
195        use histcom_var
196        use histvar_seq_m, only: histvar_seq
197        use histwrite_real_m, only: histwrite_real
198    
199      INTEGER, INTENT(IN) :: pfileid, pitau      INTEGER, INTENT(IN) :: pfileid, pitau
200      REAL, DIMENSION(:, :), INTENT(IN) :: pdata      REAL, DIMENSION(:, :), INTENT(IN) :: pdata
# Line 204  CONTAINS Line 207  CONTAINS
207      INTEGER, SAVE :: buff_tmp_sz      INTEGER, SAVE :: buff_tmp_sz
208      CHARACTER(LEN=7) :: tmp_opp      CHARACTER(LEN=7) :: tmp_opp
209    
210      !---------------------------------------------------------------------      !--------------------------------------------------------------------
211    
212      nbindex = size(nindex)      nbindex = size(nindex)
213      nindex = 0      nindex = 0
# Line 258  CONTAINS Line 261  CONTAINS
261    
262      IF (do_oper.OR.do_write) THEN      IF (do_oper.OR.do_write) THEN
263    
264         !-- 5.1 Get the sizes of the data we will handle         !- 5.1 Get the sizes of the data we will handle
265    
266         IF (datasz_in(pfileid, varid, 1) <= 0) THEN         IF (datasz_in(pfileid, varid, 1) <= 0) THEN
267            !---- 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.
268            !---- But how can we catch this ?            !--- But how can we catch this ?
269            !---- In the worst case we will do impossible operations            !--- In the worst case we will do impossible operations
270            !---- on part of the data !            !--- on part of the data !
271            datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1)            datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1)
272            datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2)            datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2)
273            datasz_in(pfileid, varid, 3) = -1            datasz_in(pfileid, varid, 3) = -1
274         ENDIF         ENDIF
275    
276         !-- 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
277    
278         IF (datasz_max(pfileid, varid) <= 0) THEN         IF (datasz_max(pfileid, varid) <= 0) THEN
279            largebuf = .FALSE.            largebuf = .FALSE.
# Line 300  CONTAINS Line 303  CONTAINS
303            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(pfileid, varid)
304         ENDIF         ENDIF
305    
306         !-- We have to do the first operation anyway.         !- We have to do the first operation anyway.
307         !-- Thus we do it here and change the ranke         !- Thus we do it here and change the ranke
308         !-- of the data at the same time. This should speed up things.         !- of the data at the same time. This should speed up things.
309    
310         nbpt_in(1:2) = datasz_in(pfileid, varid, 1:2)         nbpt_in(1:2) = datasz_in(pfileid, varid, 1:2)
311         nbpt_out = datasz_max(pfileid, varid)         nbpt_out = datasz_max(pfileid, varid)
# Line 322  CONTAINS Line 325  CONTAINS
325         last_opp_chk(pfileid, varid) = -99         last_opp_chk(pfileid, varid) = -99
326         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(pfileid, varid) = -99
327      ENDIF      ENDIF
328      !---------------------------      !--------------------------
329    END SUBROUTINE histwrite_r2d    END SUBROUTINE histwrite_r2d
330    
331    !===    !===
332    
333    SUBROUTINE histwrite_r3d (pfileid, pvarname, pitau, pdata)    SUBROUTINE histwrite_r3d (pfileid, pvarname, pitau, pdata)
334      !---------------------------------------------------------------------      !--------------------------------------------------------------------
335    
336      use calendar, only: isittime      use calendar, only: isittime
337      USE errioipsl, ONLY : histerr      USE errioipsl, ONLY : histerr
338      USE mathelp, ONLY : mathop      USE mathop_m, ONLY : mathop
339        use histcom_var
340        use histvar_seq_m, only: histvar_seq
341        use histwrite_real_m, only: histwrite_real
342    
343      INTEGER, INTENT(IN) :: pfileid, pitau      INTEGER, INTENT(IN) :: pfileid, pitau
344      REAL, DIMENSION(:, :, :), INTENT(IN) :: pdata      REAL, DIMENSION(:, :, :), INTENT(IN) :: pdata
# Line 345  CONTAINS Line 351  CONTAINS
351      INTEGER, SAVE :: buff_tmp_sz      INTEGER, SAVE :: buff_tmp_sz
352      CHARACTER(LEN=7) :: tmp_opp      CHARACTER(LEN=7) :: tmp_opp
353    
354      !---------------------------------------------------------------------      !--------------------------------------------------------------------
355    
356      nbindex = size(nindex)      nbindex = size(nindex)
357      nindex = 0      nindex = 0
# Line 399  CONTAINS Line 405  CONTAINS
405    
406      IF (do_oper.OR.do_write) THEN      IF (do_oper.OR.do_write) THEN
407    
408         !-- 5.1 Get the sizes of the data we will handle         !- 5.1 Get the sizes of the data we will handle
409    
410         IF (datasz_in(pfileid, varid, 1) <= 0) THEN         IF (datasz_in(pfileid, varid, 1) <= 0) THEN
411            !---- 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.
412            !---- But how can we catch this ?            !--- But how can we catch this ?
413            !---- In the worst case we will do impossible operations            !--- In the worst case we will do impossible operations
414            !---- on part of the data !            !--- on part of the data !
415            datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1)            datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1)
416            datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2)            datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2)
417            datasz_in(pfileid, varid, 3) = SIZE(pdata, DIM=3)            datasz_in(pfileid, varid, 3) = SIZE(pdata, DIM=3)
418         ENDIF         ENDIF
419    
420         !-- 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
421    
422         IF (datasz_max(pfileid, varid) <= 0) THEN         IF (datasz_max(pfileid, varid) <= 0) THEN
423            largebuf = .FALSE.            largebuf = .FALSE.
# Line 442  CONTAINS Line 448  CONTAINS
448            buff_tmp_sz = datasz_max(pfileid, varid)            buff_tmp_sz = datasz_max(pfileid, varid)
449         ENDIF         ENDIF
450    
451         !-- We have to do the first operation anyway.         !- We have to do the first operation anyway.
452         !-- Thus we do it here and change the ranke         !- Thus we do it here and change the ranke
453         !-- of the data at the same time. This should speed up things.         !- of the data at the same time. This should speed up things.
454    
455         nbpt_in(1:3) = datasz_in(pfileid, varid, 1:3)         nbpt_in(1:3) = datasz_in(pfileid, varid, 1:3)
456         nbpt_out = datasz_max(pfileid, varid)         nbpt_out = datasz_max(pfileid, varid)
# Line 464  CONTAINS Line 470  CONTAINS
470         last_opp_chk(pfileid, varid) = -99         last_opp_chk(pfileid, varid) = -99
471         last_wrt_chk(pfileid, varid) = -99         last_wrt_chk(pfileid, varid) = -99
472      ENDIF      ENDIF
473      !---------------------------      !--------------------------
474    END SUBROUTINE histwrite_r3d    END SUBROUTINE histwrite_r3d
475    
   !===  
   
   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  
   
     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  
     ENDIF  
   
     ! The buffers are only deallocated when more space is needed. This  
     ! 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  
   
     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  
   
476  END MODULE histwrite_m  END MODULE histwrite_m
Legend:
Removed from v.30  
changed lines
  Added in v.45
  ViewVC Help
Powered by ViewVC 1.1.21