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