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 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
    USE mathelp, ONLY: trans_buff, moycum
    USE mathop_m, ONLY: mathop
    use netcdf, only: NF90_PUT_VAR

    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			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 histcom_var, ONLY: buffer, buff_pos, datasz_max, deltat, &
15			last_opp, last_wrt, missing_val, nbopp, nb_opp, nb_wrt, ncdf_ids, &
16			ncvar_ids, point, regular, scal, scsize, sopps, tax_last, tdimid, &
17			topp, var_axid, zorig, zsize
18	guez	67	USE mathelp, ONLY: trans_buff, moycum
19			USE mathop_m, ONLY: mathop
20			use netcdf, only: NF90_PUT_VAR
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	67	tsz = zsize(fileid, varid, 1) * zsize(fileid, varid, 2) &
56			* zsize(fileid, varid, 3)
57	guez	45
58			! 1.0 We allocate the memory needed to store the data between write
59	guez	67	! and the temporary space needed for operations.
60			! We have to keep precedent buffer if needed
61	guez	45
62			IF (.NOT. ALLOCATED(buffer)) THEN
63			ALLOCATE(buffer(buff_pos))
64			buffer_sz = buff_pos
65			buffer(:)=0.0
66			ELSE IF (buffer_sz < buff_pos) THEN
67			IF (SUM(buffer)/=0.0) THEN
68	guez	67	ALLOCATE(buffer_used(buffer_sz))
69	guez	45	buffer_used(:)=buffer(:)
70	guez	67	DEALLOCATE(buffer)
71			ALLOCATE(buffer(buff_pos))
72	guez	45	buffer_sz = buff_pos
73			buffer(:SIZE(buffer_used))=buffer_used
74	guez	67	DEALLOCATE(buffer_used)
75	guez	45	ELSE
76	guez	67	DEALLOCATE(buffer)
77			ALLOCATE(buffer(buff_pos))
78	guez	45	buffer_sz = buff_pos
79			buffer(:)=0.0
80			ENDIF
81			ENDIF
82
83			! The buffers are only deallocated when more space is needed. This
84			! reduces the umber of allocates but increases memory needs.
85
86			IF (.NOT.ALLOCATED(buff_tmp2)) THEN
87	guez	67	ALLOCATE(buff_tmp2(datasz_max(fileid, varid)))
88	guez	62	buff_tmp2_sz = datasz_max(fileid, varid)
89	guez	67	ELSE IF (datasz_max(fileid, varid) > buff_tmp2_sz) THEN
90			DEALLOCATE(buff_tmp2)
91			ALLOCATE(buff_tmp2(datasz_max(fileid, varid)))
92	guez	62	buff_tmp2_sz = datasz_max(fileid, varid)
93	guez	45	ENDIF
94
95	guez	62	rtime = itau * deltat(fileid)
96			tmp_opp = topp(fileid, varid)
97	guez	45
98			! 3.0 Do the operations or transfer the slab of data into buff_tmp
99
100			! 3.1 DO the Operations only if needed
101
102	guez	67	IF (do_oper) THEN
103	guez	62	i = fileid
104	guez	45	nbout = nbdpt
105
106	guez	67	! 3.4 We continue the sequence of operations
107			! we started in the interface routine
108	guez	45
109			DO io = 2, nbopp(i, varid), 2
110			nbin = nbout
111			nbout = datasz_max(i, varid)
112			CALL mathop(sopps(i, varid, io), nbin, buff_tmp, missing_val, &
113	guez	62	nbindex, nindex, scal(i, varid, io), nbout, buff_tmp2)
114	guez	45
115			nbin = nbout
116			nbout = datasz_max(i, varid)
117			CALL mathop(sopps(i, varid, io+1), nbin, buff_tmp2, missing_val, &
118	guez	62	nbindex, nindex, scal(i, varid, io+1), nbout, buff_tmp)
119	guez	45	ENDDO
120
121	guez	67	! 3.5 Zoom into the data
122	guez	45
123	guez	67	CALL trans_buff(zorig(i, varid, 1), zsize(i, varid, 1), &
124			zorig(i, varid, 2), zsize(i, varid, 2), zorig(i, varid, 3), &
125			zsize(i, varid, 3), scsize(i, varid, 1), scsize(i, varid, 2), &
126			scsize(i, varid, 3), buff_tmp, buff_tmp2_sz, buff_tmp2)
127	guez	45
128	guez	67	! 5.0 Do the operations if needed. In the case of instantaneous
129			! output we do not transfer to the buffer.
130	guez	45
131	guez	62	ipt = point(fileid, varid)
132	guez	45
133	guez	67	IF ((TRIM(tmp_opp) /= "inst") &
134			.AND.(TRIM(tmp_opp) /= "once")) THEN
135	guez	45	CALL moycum(tmp_opp, tsz, buffer(ipt:), &
136	guez	62	buff_tmp2, nb_opp(fileid, varid))
137	guez	45	ENDIF
138
139	guez	62	last_opp(fileid, varid) = itau
140			nb_opp(fileid, varid) = nb_opp(fileid, varid)+1
141	guez	45
142			ENDIF
143
144			! 6.0 Write to file if needed
145
146	guez	67	IF (do_write) THEN
147	guez	62	ncvarid = ncvar_ids(fileid, varid)
148			ncid = ncdf_ids(fileid)
149	guez	45
150	guez	67	! 6.1 Do the operations that are needed before writting
151			IF ((TRIM(tmp_opp) /= "inst") .AND. (TRIM(tmp_opp) /= "once")) THEN
152			rtime = (rtime + last_wrt(fileid, varid)*deltat(fileid)) / 2.
153	guez	45	ENDIF
154
155	guez	67	! 6.2 Add a value to the time axis of this variable if needed
156			IF (TRIM(tmp_opp) /= "l_max" .AND. TRIM(tmp_opp) /= "l_min" &
157			.AND. TRIM(tmp_opp) /= "once") THEN
158	guez	62	itax = var_axid(fileid, varid)
159	guez	67	itime = nb_wrt(fileid, varid) + 1
160	guez	45
161	guez	62	IF (tax_last(fileid, itax) < itime) THEN
162	guez	67	iret = NF90_PUT_VAR(ncid, tdimid(fileid, itax), (/rtime/), &
163			start=(/itime/))
164	guez	62	tax_last(fileid, itax) = itime
165	guez	45	ENDIF
166			ELSE
167			itime=1
168			ENDIF
169
170	guez	67	! 6.3 Write the data. Only in the case of instantaneous output
171			! we do not write the buffer.
172	guez	45
173	guez	62	IF (scsize(fileid, varid, 3) == 1) THEN
174			IF (regular(fileid)) THEN
175	guez	67	corner(1:4) = (/1, 1, itime, 0/)
176			edges(1:4) = (/zsize(fileid, varid, 1), &
177	guez	62	zsize(fileid, varid, 2), &
178	guez	67	1, 0/)
179	guez	45	ELSE
180	guez	67	corner(1:4) = (/1, itime, 0, 0/)
181			edges(1:4) = (/zsize(fileid, varid, 1), 1, 0, 0/)
182	guez	45	ENDIF
183			ELSE
184	guez	67	IF (regular(fileid)) THEN
185			corner(1:4) = (/1, 1, 1, itime/)
186			edges(1:4) = (/zsize(fileid, varid, 1), &
187	guez	62	zsize(fileid, varid, 2), &
188	guez	67	zsize(fileid, varid, 3), 1/)
189	guez	45	ELSE
190	guez	67	corner(1:4) = (/1, 1, itime, 0/)
191			edges(1:4) = (/zsize(fileid, varid, 1), &
192			zsize(fileid, varid, 3), 1, 0/)
193	guez	45	ENDIF
194			ENDIF
195
196	guez	62	ipt = point(fileid, varid)
197	guez	45
198	guez	67	IF ((TRIM(tmp_opp) /= "inst") .AND. (TRIM(tmp_opp) /= "once")) THEN
199			iret = NF90_PUT_VAR(ncid, ncvarid, buffer(ipt:), &
200	guez	62	start=corner(1:4), count=edges(1:4))
201	guez	45	ELSE
202	guez	67	iret = NF90_PUT_VAR(ncid, ncvarid, buff_tmp2, &
203	guez	62	start=corner(1:4), count=edges(1:4))
204	guez	45	ENDIF
205
206	guez	62	last_wrt(fileid, varid) = itau
207			nb_wrt(fileid, varid) = nb_wrt(fileid, varid)+1
208			nb_opp(fileid, varid) = 0
209	guez	45	ENDIF
210	guez	62
211	guez	45	END SUBROUTINE histwrite_real
212
213			end module histwrite_real_m