trunk/IOIPSL/histwrite_real.f

module histwrite_real_m

  implicit none

  REAL, ALLOCATABLE, SAVE:: buffer(:)

contains

  SUBROUTINE histwrite_real(datasz_max, 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 histbeg_totreg_m, only: deltat, regular
    USE histcom_var, ONLY: last_opp, last_wrt, missing_val, nbopp, nb_opp, &
         nb_wrt, ncdf_ids, scal, scsize, sopps, tax_last, tdimid, topp, &
         var_axid, zorig, zsize
    use histdef_m, only: buff_pos, point
    use histend_m, only: ncvar_ids
    USE mathop_m, ONLY: mathop
    use moycum_m, only: moycum
    use netcdf, only: NF90_PUT_VAR
    USE trans_buff_m, ONLY: trans_buff

    INTEGER, INTENT(IN):: datasz_max(:, :) ! (nb_files_max, nb_var_max)
    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.
       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/))
             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
    ENDIF

  END SUBROUTINE histwrite_real

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