trunk/IOIPSL/histwrite_real.f

module histwrite_real_m

  implicit none

contains

  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 mathop_m, ONLY : mathop
    USE mathelp, ONLY : 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
    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

end module histwrite_real_m
1	guez	45	module histwrite_real_m
2
3			implicit none
4
5			contains
6
7			SUBROUTINE histwrite_real(pfileid, varid, pitau, nbdpt, buff_tmp, nbindex, &
8			nindex, do_oper, do_write)
9
10			! This subroutine is internal and does the calculations and writing
11			! if needed. At a later stage it should be split into an operation
12			! and writing subroutines.
13			!--------------------------------------------------------------------
14
15			USE mathop_m, ONLY : mathop
16			USE mathelp, ONLY : trans_buff, moycum
17			use netcdf, only: NF90_PUT_VAR
18			use histcom_var
19
20			INTEGER, INTENT(IN) :: pfileid, pitau, varid, &
21			& nbindex, nindex(nbindex), nbdpt
22			REAL, DIMENSION(:) :: buff_tmp
23			LOGICAL, INTENT(IN) :: do_oper, do_write
24
25			INTEGER :: tsz, ncid, ncvarid
26			INTEGER :: i, iret, ipt, itax
27			INTEGER :: io, nbin, nbout
28			INTEGER, DIMENSION(4) :: corner, edges
29			INTEGER :: itime
30
31			REAL :: rtime
32			CHARACTER(LEN=7) :: tmp_opp
33
34			REAL, ALLOCATABLE, SAVE :: buff_tmp2(:)
35			INTEGER, SAVE :: buff_tmp2_sz
36			REAL, ALLOCATABLE, SAVE :: buffer_used(:)
37			INTEGER, SAVE :: buffer_sz
38
39			!--------------------------------------------------------------------
40
41			! The sizes which can be encoutered
42
43			tsz = zsize(pfileid, varid, 1)zsize(pfileid, varid, 2)zsize(pfileid, varid, 3)
44
45			! 1.0 We allocate the memory needed to store the data between write
46			! and the temporary space needed for operations.
47			! We have to keep precedent buffer if needed
48
49			IF (.NOT. ALLOCATED(buffer)) THEN
50			ALLOCATE(buffer(buff_pos))
51			buffer_sz = buff_pos
52			buffer(:)=0.0
53			ELSE IF (buffer_sz < buff_pos) THEN
54			IF (SUM(buffer)/=0.0) THEN
55			ALLOCATE (buffer_used(buffer_sz))
56			buffer_used(:)=buffer(:)
57			DEALLOCATE (buffer)
58			ALLOCATE (buffer(buff_pos))
59			buffer_sz = buff_pos
60			buffer(:SIZE(buffer_used))=buffer_used
61			DEALLOCATE (buffer_used)
62			ELSE
63			DEALLOCATE (buffer)
64			ALLOCATE (buffer(buff_pos))
65			buffer_sz = buff_pos
66			buffer(:)=0.0
67			ENDIF
68			ENDIF
69
70			! The buffers are only deallocated when more space is needed. This
71			! reduces the umber of allocates but increases memory needs.
72
73			IF (.NOT.ALLOCATED(buff_tmp2)) THEN
74			ALLOCATE (buff_tmp2(datasz_max(pfileid, varid)))
75			buff_tmp2_sz = datasz_max(pfileid, varid)
76			ELSE IF ( datasz_max(pfileid, varid) > buff_tmp2_sz) THEN
77			DEALLOCATE (buff_tmp2)
78			ALLOCATE (buff_tmp2(datasz_max(pfileid, varid)))
79			buff_tmp2_sz = datasz_max(pfileid, varid)
80			ENDIF
81
82			rtime = pitau * deltat(pfileid)
83			tmp_opp = topp(pfileid, varid)
84
85			! 3.0 Do the operations or transfer the slab of data into buff_tmp
86
87			! 3.1 DO the Operations only if needed
88
89			IF ( do_oper ) THEN
90			i = pfileid
91			nbout = nbdpt
92
93			!- 3.4 We continue the sequence of operations
94			!- we started in the interface routine
95
96			DO io = 2, nbopp(i, varid), 2
97			nbin = nbout
98			nbout = datasz_max(i, varid)
99			CALL mathop(sopps(i, varid, io), nbin, buff_tmp, missing_val, &
100			& nbindex, nindex, scal(i, varid, io), nbout, buff_tmp2)
101
102			nbin = nbout
103			nbout = datasz_max(i, varid)
104			CALL mathop(sopps(i, varid, io+1), nbin, buff_tmp2, missing_val, &
105			& nbindex, nindex, scal(i, varid, io+1), nbout, buff_tmp)
106			ENDDO
107
108			! 3.5 Zoom into the data
109
110			CALL trans_buff &
111			& (zorig(i, varid, 1), zsize(i, varid, 1), &
112			& zorig(i, varid, 2), zsize(i, varid, 2), &
113			& zorig(i, varid, 3), zsize(i, varid, 3), &
114			& scsize(i, varid, 1), scsize(i, varid, 2), scsize(i, varid, 3), &
115			& buff_tmp, buff_tmp2_sz, buff_tmp2)
116
117			!- 5.0 Do the operations if needed. In the case of instantaneous
118			!- output we do not transfer to the buffer.
119
120			ipt = point(pfileid, varid)
121
122			IF ( (TRIM(tmp_opp) /= "inst") &
123			& .AND.(TRIM(tmp_opp) /= "once") ) THEN
124			CALL moycum(tmp_opp, tsz, buffer(ipt:), &
125			& buff_tmp2, nb_opp(pfileid, varid))
126			ENDIF
127
128			last_opp(pfileid, varid) = pitau
129			nb_opp(pfileid, varid) = nb_opp(pfileid, varid)+1
130
131			ENDIF
132
133			! 6.0 Write to file if needed
134
135			IF ( do_write ) THEN
136
137			ncvarid = ncvar_ids(pfileid, varid)
138			ncid = ncdf_ids(pfileid)
139
140			!- 6.1 Do the operations that are needed before writting
141
142			IF ( (TRIM(tmp_opp) /= "inst") &
143			& .AND.(TRIM(tmp_opp) /= "once") ) THEN
144			rtime = (rtime+last_wrt(pfileid, varid)*deltat(pfileid))/2.0
145			ENDIF
146
147			!- 6.2 Add a value to the time axis of this variable if needed
148
149			IF ( (TRIM(tmp_opp) /= "l_max") &
150			& .AND.(TRIM(tmp_opp) /= "l_min") &
151			& .AND.(TRIM(tmp_opp) /= "once") ) THEN
152
153			itax = var_axid(pfileid, varid)
154			itime = nb_wrt(pfileid, varid)+1
155
156			IF (tax_last(pfileid, itax) < itime) THEN
157			iret = NF90_PUT_VAR (ncid, tdimid(pfileid, itax), (/ rtime /), &
158			& start=(/ itime /), count=(/ 1 /))
159			tax_last(pfileid, itax) = itime
160			ENDIF
161			ELSE
162			itime=1
163			ENDIF
164
165			!- 6.3 Write the data. Only in the case of instantaneous output
166			! we do not write the buffer.
167
168			IF (scsize(pfileid, varid, 3) == 1) THEN
169			IF (regular(pfileid)) THEN
170			corner(1:4) = (/ 1, 1, itime, 0 /)
171			edges(1:4) = (/ zsize(pfileid, varid, 1), &
172			& zsize(pfileid, varid, 2), &
173			& 1, 0 /)
174			ELSE
175			corner(1:4) = (/ 1, itime, 0, 0 /)
176			edges(1:4) = (/ zsize(pfileid, varid, 1), 1, 0, 0 /)
177			ENDIF
178			ELSE
179			IF ( regular(pfileid) ) THEN
180			corner(1:4) = (/ 1, 1, 1, itime /)
181			edges(1:4) = (/ zsize(pfileid, varid, 1), &
182			& zsize(pfileid, varid, 2), &
183			& zsize(pfileid, varid, 3), 1 /)
184			ELSE
185			corner(1:4) = (/ 1, 1, itime, 0 /)
186			edges(1:4) = (/ zsize(pfileid, varid, 1), &
187			& zsize(pfileid, varid, 3), 1, 0 /)
188			ENDIF
189			ENDIF
190
191			ipt = point(pfileid, varid)
192
193			IF ( (TRIM(tmp_opp) /= "inst") &
194			& .AND.(TRIM(tmp_opp) /= "once") ) THEN
195			iret = NF90_PUT_VAR (ncid, ncvarid, buffer(ipt:), &
196			& start=corner(1:4), count=edges(1:4))
197			ELSE
198			iret = NF90_PUT_VAR (ncid, ncvarid, buff_tmp2, &
199			& start=corner(1:4), count=edges(1:4))
200			ENDIF
201
202			last_wrt(pfileid, varid) = pitau
203			nb_wrt(pfileid, varid) = nb_wrt(pfileid, varid)+1
204			nb_opp(pfileid, varid) = 0
205			!--
206			! After the write the file can be synchronized so that no data is
207			! lost in case of a crash. This feature gives up on the benefits of
208			! buffering and should only be used in debuging mode. A flag is
209			! needed here to switch to this mode.
210			!--
211			! iret = NF90_SYNC (ncid)
212
213			ENDIF
214			!---------------------------
215			END SUBROUTINE histwrite_real
216
217			end module histwrite_real_m