trunk/IOIPSL/histwrite_real.f

module histwrite_real_m

  implicit none

contains

  SUBROUTINE histwrite_real(fileid, varid, itau, 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, ONLY: buffer, buff_pos, datasz_max, deltat, &
         last_opp, last_wrt, missing_val, nbopp, nb_opp, nb_wrt, ncdf_ids, &
         ncvar_ids, point, regular, scal, scsize, sopps, tax_last, tdimid, &
         topp, var_axid, zorig, zsize

    INTEGER, INTENT(IN):: fileid, varid, itau, nbdpt
    REAL buff_tmp(:)

    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

    LOGICAL, INTENT(IN):: do_oper, do_write

    ! Local:

    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(fileid, varid, 1)*zsize(fileid, varid, 2)*zsize(fileid, 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(fileid, varid)))
       buff_tmp2_sz = datasz_max(fileid, varid)
    ELSE IF ( datasz_max(fileid, varid) > buff_tmp2_sz) THEN
       DEALLOCATE (buff_tmp2)
       ALLOCATE (buff_tmp2(datasz_max(fileid, varid)))
       buff_tmp2_sz = datasz_max(fileid, varid)
    ENDIF

    rtime = itau * deltat(fileid)
    tmp_opp = topp(fileid, 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 = fileid
       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(fileid, varid)

       IF (     (TRIM(tmp_opp) /= "inst") &
            .AND.(TRIM(tmp_opp) /= "once") ) THEN
          CALL moycum(tmp_opp, tsz, buffer(ipt:), &
               buff_tmp2, nb_opp(fileid, varid))
       ENDIF

       last_opp(fileid, varid) = itau
       nb_opp(fileid, varid) = nb_opp(fileid, varid)+1

    ENDIF

    ! 6.0 Write to file if needed

    IF ( do_write ) THEN

       ncvarid = ncvar_ids(fileid, varid)
       ncid = ncdf_ids(fileid)

       !- 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(fileid, varid)*deltat(fileid))/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(fileid, varid)
          itime = nb_wrt(fileid, varid)+1

          IF (tax_last(fileid, itax) < itime) THEN
             iret = NF90_PUT_VAR (ncid, tdimid(fileid, itax), (/ rtime /), &
                  start=(/ itime /), count=(/ 1 /))
             tax_last(fileid, 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(fileid, varid, 3) == 1) THEN
          IF (regular(fileid)) THEN
             corner(1:4) = (/ 1, 1, itime, 0 /)
             edges(1:4) = (/ zsize(fileid, varid, 1), &
                  zsize(fileid, varid, 2), &
                  1, 0 /)
          ELSE
             corner(1:4) = (/ 1, itime, 0, 0 /)
             edges(1:4) = (/ zsize(fileid, varid, 1), 1, 0, 0 /)
          ENDIF
       ELSE
          IF ( regular(fileid) ) THEN
             corner(1:4) = (/ 1, 1, 1, itime /)
             edges(1:4) = (/ zsize(fileid, varid, 1), &
                  zsize(fileid, varid, 2), &
                  zsize(fileid, varid, 3), 1 /)
          ELSE
             corner(1:4) = (/ 1, 1, itime, 0 /)
             edges(1:4) = (/ zsize(fileid, varid, 1), &
                  zsize(fileid, varid, 3), 1, 0 /)
          ENDIF
       ENDIF

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