ROMS
Loading...
Searching...
No Matches
Data Types | Functions/Subroutines
nf_fwrite4d_mod Module Reference

Data Types

interface  nf_fwrite4d
 

Functions/Subroutines

integer function nf90_fwrite4d (ng, model, ncid, ifield, ncvarid, tindex, gtype, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, ascl, amask, adat, setfillval, extractfield, minvalue, maxvalue)
 
integer function pio_fwrite4d (ng, model, piofile, ifield, piovar, tindex, piodesc, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, ascl, amask, adat, setfillval, minvalue, maxvalue)
 

Function/Subroutine Documentation

◆ nf90_fwrite4d()

integer function nf_fwrite4d_mod::nf90_fwrite4d ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) ncid,
integer, intent(in) ifield,
integer, intent(in) ncvarid,
integer, intent(in) tindex,
integer, intent(in) gtype,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbk,
integer, intent(in) ubk,
integer, intent(in) lbt,
integer, intent(in) ubt,
real(dp), intent(in) ascl,
real(r8), dimension(lbi:,lbj:), intent(in) amask,
real(r8), dimension(lbi:,lbj:,lbk:,lbt:), intent(in) adat,
logical, intent(in), optional setfillval,
integer, intent(in), optional extractfield,
real(r8), intent(out), optional minvalue,
real(r8), intent(out), optional maxvalue )

Definition at line 92 of file nf_fwrite4d.F.

103!***********************************************************************
104!
105 USE mod_netcdf
106!
107# ifdef MASKING
108 USE distribute_mod, ONLY : mp_collect
109# endif
110 USE get_bounds_mod, ONLY : tile_bounds_1d
111!
112! Imported variable declarations.
113!
114 logical, intent(in), optional :: SetFillVal
115!
116 integer, intent(in) :: ng, model, ncid, ncvarid, tindex, gtype
117 integer, intent(in) :: ifield
118 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt
119!
120 integer, intent(in), optional :: ExtractField
121!
122 real(dp), intent(in) :: Ascl
123!
124# ifdef ASSUMED_SHAPE
125# ifdef MASKING
126 real(r8), intent(in) :: Amask(LBi:,LBj:)
127# endif
128 real(r8), intent(in) :: Adat(LBi:,LBj:,LBk:,LBt:)
129# else
130# ifdef MASKING
131 real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
132# endif
133 real(r8), intent(in) :: Adat(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
134# endif
135 real(r8), intent(out), optional :: MinValue
136 real(r8), intent(out), optional :: MaxValue
137!
138! Local variable declarations.
139!
140 logical :: LandFill
141!
142 integer :: Extract_Flag
143 integer :: i, ic, j, jc, k, kc, l, lc, Npts
144 integer :: Imin, Imax, Jmin, Jmax, Kmin, Kmax
145 integer :: Ioff, Joff, Koff, Loff
146 integer :: Istr, Iend
147 integer :: Ilen, Isize, Jlen, Jsize, IJlen, IJKlen, Klen, Llen
148 integer :: MyType
149 integer :: status
150
151 integer, dimension(5) :: start, total
152!
153 real(r8), parameter :: IniVal = 0.0_r8
154
155 real(r8), allocatable :: Awrk(:)
156!
157!-----------------------------------------------------------------------
158! Set starting and ending indices to process.
159!-----------------------------------------------------------------------
160!
161 status=nf90_noerr
162!
163! Set first and last grid point according to staggered C-grid
164! classification.
165!
166 mytype=gtype
167!
168 SELECT CASE (abs(mytype))
169 CASE (p2dvar, p3dvar)
170 imin=bounds(ng)%Istr (myrank)
171 imax=bounds(ng)%IendR(myrank)
172 jmin=bounds(ng)%Jstr (myrank)
173 jmax=bounds(ng)%JendR(myrank)
174 isize=iobounds(ng)%xi_psi
175 jsize=iobounds(ng)%eta_psi
176 CASE (r2dvar, r3dvar)
177 imin=bounds(ng)%IstrR(myrank)
178 imax=bounds(ng)%IendR(myrank)
179 jmin=bounds(ng)%JstrR(myrank)
180 jmax=bounds(ng)%JendR(myrank)
181 isize=iobounds(ng)%xi_rho
182 jsize=iobounds(ng)%eta_rho
183 CASE (u2dvar, u3dvar)
184 imin=bounds(ng)%Istr (myrank)
185 imax=bounds(ng)%IendR(myrank)
186 jmin=bounds(ng)%JstrR(myrank)
187 jmax=bounds(ng)%JendR(myrank)
188 isize=iobounds(ng)%xi_u
189 jsize=iobounds(ng)%eta_u
190 CASE (v2dvar, v3dvar)
191 imin=bounds(ng)%IstrR(myrank)
192 imax=bounds(ng)%IendR(myrank)
193 jmin=bounds(ng)%Jstr (myrank)
194 jmax=bounds(ng)%JendR(myrank)
195 isize=iobounds(ng)%xi_v
196 jsize=iobounds(ng)%eta_v
197 CASE DEFAULT
198 imin=bounds(ng)%IstrR(myrank)
199 imax=bounds(ng)%IendR(myrank)
200 jmin=bounds(ng)%JstrR(myrank)
201 jmax=bounds(ng)%JendR(myrank)
202 isize=iobounds(ng)%xi_rho
203 jsize=iobounds(ng)%eta_rho
204 END SELECT
205!
206 ilen=imax-imin+1
207 jlen=jmax-jmin+1
208 klen=ubk-lbk+1
209 llen=ubt-lbt+1
210!
211! Set switch to replace land areas with fill value, spval.
212!
213# ifdef MASKING
214 IF (PRESENT(setfillval)) THEN
215 landfill=setfillval
216 ELSE
217 landfill=tindex.gt.0
218 END IF
219# else
220 landfill=.false.
221# endif
222!
223! If appropriate, set the field extraction flag to the provided grid
224! geometry through interpolation or decimation.
225!
226 IF (PRESENT(extractfield)) THEN
227 extract_flag=extractfield
228 ELSE
229 extract_flag=0
230 END IF
231!
232!-----------------------------------------------------------------------
233! Parallel I/O: Pack tile data into 1D array in column-major order.
234# ifdef MASKING
235! Overwrite masked points with special value.
236# endif
237!-----------------------------------------------------------------------
238!
239 IF (gtype.gt.0) THEN
240!
241! Set offsets due the NetCDF dimensions. Recall that some output
242! variables not always start at one.
243!
244 SELECT CASE (abs(mytype))
245 CASE (p2dvar, p3dvar)
246 ioff=0
247 joff=0
248 CASE (r2dvar, r3dvar)
249 ioff=1
250 joff=1
251 CASE (u2dvar, u3dvar)
252 ioff=0
253 joff=1
254 CASE (v2dvar, v3dvar)
255 ioff=1
256 joff=0
257 CASE DEFAULT
258 ioff=1
259 joff=1
260 END SELECT
261
262 IF (lbk.eq.0) THEN
263 koff=1
264 ELSE
265 koff=0
266 END IF
267
268 IF (lbt.eq.0) THEN
269 loff=1
270 ELSE
271 loff=0
272 END IF
273!
274! Allocate and initialize scratch work array.
275!
276 ijlen=ilen*jlen
277 ijklen=ijlen*klen
278 npts=ijklen*llen
279
280 IF (.not.allocated(awrk)) THEN
281 allocate ( awrk(npts) )
282 awrk=inival
283 END IF
284!
285! Pack and scale tile data.
286!
287 ic=0
288 DO l=lbt,ubt
289 DO k=lbk,ubk
290 DO j=jmin,jmax
291 DO i=imin,imax
292 ic=ic+1
293 awrk(ic)=adat(i,j,k,l)*ascl
294# ifdef POSITIVE_ZERO
295 IF (abs(awrk(ic)).eq.0.0_r8) THEN
296 awrk(ic)=0.0_r8 ! impose positive zero
297 END IF
298# endif
299# ifdef MASKING
300 IF ((amask(i,j).eq.0.0_r8).and.landfill) THEN
301 awrk(ic)=spval
302 END IF
303# endif
304 END DO
305 END DO
306 END DO
307 END DO
308!
309! Write out data: all parallel nodes write their own packed tile data.
310!
311 start(1)=imin+ioff
312 total(1)=ilen
313 start(2)=jmin+joff
314 total(2)=jlen
315 start(3)=lbk+koff
316 total(3)=klen
317 start(4)=lbt+loff
318 total(4)=llen
319 start(5)=tindex
320 total(5)=1
321
322 status=nf90_put_var(ncid, ncvarid, awrk, start, total)
323 END IF
324
325# if defined WRITE_WATER && defined MASKING
326!
327!-----------------------------------------------------------------------
328! Parallel I/O: Remove land points and pack tile data into 1D array.
329!-----------------------------------------------------------------------
330!
331 IF (gtype.lt.0) THEN
332!
333! Set offsets due array packing into 1D array in column-major order.
334!
335 SELECT CASE (abs(mytype))
336 CASE (p2dvar, p3dvar)
337 ioff=0
338 joff=1
339 CASE (r2dvar, r3dvar)
340 ioff=1
341 joff=0
342 CASE (u2dvar, u3dvar)
343 ioff=0
344 joff=0
345 CASE (v2dvar, v3dvar)
346 ioff=1
347 joff=1
348 CASE DEFAULT
349 ioff=1
350 joff=0
351 END SELECT
352
353 IF (lbk.eq.0) THEN
354 koff=0
355 ELSE
356 koff=1
357 END IF
358
359 IF (lbt.eq.0) THEN
360 loff=0
361 ELSE
362 loff=1
363 END IF
364!
365! Allocate and initialize scratch work array.
366!
367 ijlen=isize*jsize
368 ijklen=ijlen*klen
369 npts=ijklen*llen
370
371 IF (.not.allocated(awrk)) THEN
372 allocate ( awrk(npts) )
373 awrk=inival
374 END IF
375!
376! Scale and gather data from all spawned nodes. Store data into a 1D
377! global array, packed in column-major order. Flag land point with
378! special value.
379!
380 DO l=lbt,ubt
381 lc=(l-loff)*ijklen
382 DO k=lbk,ubk
383 kc=(k-koff)*ijlen+lc
384 DO j=jmin,jmax
385 jc=(j-joff)*isize+kc
386 DO i=imin,imax
387 ic=i+ioff+jc
388 awrk(ic)=adat(i,j,k,l)*ascl
389# ifdef POSITIVE_ZERO
390 IF (abs(awrk(ic)).eq.0.0_r8) THEN
391 awrk(ic)=0.0_r8 ! impose positive zero
392 END IF
393# endif
394 IF (amask(i,j).eq.0.0_r8) THEN
395 awrk(ic)=spval
396 END IF
397 END DO
398 END DO
399 END DO
400 END DO
401!
402! Global reduction of work array.
403!
404 CALL mp_collect (ng, model, npts, inival, awrk)
405!
406! Remove land points.
407!
408 ic=0
409 DO i=1,npts
410 IF (awrk(i).lt.spval) THEN
411 ic=ic+1
412 awrk(ic)=awrk(i)
413 END IF
414 END DO
415 npts=ic
416!
417! Write out data: all parallel nodes write a section of the packed
418! data.
419!
420 CALL tile_bounds_1d (ng, myrank, npts, istr, iend)
421!
422 start(1)=istr
423 total(1)=iend-istr+1
424 start(2)=tindex
425 total(2)=1
426
427 status=nf90_put_var(ncid, ncvarid, awrk(istr:), start, total)
428 END IF
429# endif
430!
431!-----------------------------------------------------------------------
432! Deallocate scratch work array.
433!-----------------------------------------------------------------------
434!
435 IF (allocated(awrk)) THEN
436 deallocate (awrk)
437 END IF
438!
439 RETURN
distribute_mod::mp_collect
Definition distribute.F:108
distribute_mod
Definition distribute.F:3
get_bounds_mod
Definition get_bounds.F:2
get_bounds_mod::tile_bounds_1d
subroutine, public tile_bounds_1d(ng, tile, imax, istr, iend)
Definition get_bounds.F:921
mod_netcdf
Definition mod_netcdf.F:2

◆ pio_fwrite4d()

integer function nf_fwrite4d_mod::pio_fwrite4d ( integer, intent(in) ng,
integer, intent(in) model,
type (file_desc_t), intent(inout) piofile,
integer, intent(in) ifield,
type (my_vardesc), intent(inout) piovar,
integer, intent(in) tindex,
type (io_desc_t), intent(inout) piodesc,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbk,
integer, intent(in) ubk,
integer, intent(in) lbt,
integer, intent(in) ubt,
real(dp), intent(in) ascl,
real(r8), dimension(lbi:,lbj:), intent(in) amask,
real(r8), dimension(lbi:,lbj:,lbk:,lbt:), intent(in) adat,
logical, intent(in), optional setfillval,
real(r8), intent(out), optional minvalue,
real(r8), intent(out), optional maxvalue )

Definition at line 654 of file nf_fwrite4d.F.

663!***********************************************************************
664!
665 USE mod_pio_netcdf
666!
667 USE distribute_mod, ONLY : mp_reduce
668# ifdef OUTPUT_STATS
669 USE stats_mod, ONLY : stats_4dfld
670# endif
671!
672! Imported variable declarations.
673!
674 logical, intent(in), optional :: SetFillVal
675!
676 integer, intent(in) :: ng, model, tindex
677 integer, intent(in) :: ifield
678 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt
679!
680 integer, intent(in), optional :: ExtractField
681!
682 real(dp), intent(in) :: Ascl
683!
684# ifdef ASSUMED_SHAPE
685# ifdef MASKING
686 real(r8), intent(in) :: Amask(LBi:,LBj:)
687# endif
688 real(r8), intent(in) :: Adat(LBi:,LBj:,LBk:,LBt:)
689# else
690# ifdef MASKING
691 real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
692# endif
693 real(r8), intent(in) :: Adat(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
694# endif
695 real(r8), intent(out), optional :: MinValue
696 real(r8), intent(out), optional :: MaxValue
697!
698 TYPE (File_desc_t), intent(inout) :: pioFile
699 TYPE (IO_Desc_t), intent(inout) :: pioDesc
700 TYPE (My_VarDesc), intent(inout) :: pioVar
701!
702! Local variable declarations.
703!
704 logical :: LandFill, Lminmax
705
706 logical, pointer :: Lwater(:,:,:,:)
707!
708 integer :: Extract_Flag
709 integer :: i, j, k, l, tile
710 integer :: Imin, Imax, Jmin, Jmax
711 integer :: Cgrid, dkind, ghost, gtype
712 integer :: status
713
714 integer, dimension(5) :: start, total
715!
716 real(r8), dimension(2) :: rbuffer
717
718 real(r4), pointer :: Awrk4(:,:,:,:)
719 real(r8), pointer :: Awrk8(:,:,:,:)
720
721# ifdef OUTPUT_STATS
722!
723 TYPE (T_STATS) :: Stats
724# endif
725!
726 character (len= 3), dimension(2) :: op_handle
727!
728!-----------------------------------------------------------------------
729! Set starting and ending indices to process.
730!-----------------------------------------------------------------------
731!
732 status=pio_noerr
733!
734! Set first and last grid point according to staggered C-grid
735! classification. Set loops offsets.
736!
737 ghost=0
738 dkind=piovar%dkind
739 gtype=piovar%gtype
740!
741 SELECT CASE (abs(gtype))
742 CASE (p3dvar)
743 cgrid=1
744 CASE (l3dvar, l4dvar, r3dvar)
745 cgrid=2
746 CASE (u3dvar)
747 cgrid=3
748 CASE (v3dvar)
749 cgrid=4
750 CASE DEFAULT
751 cgrid=2
752 END SELECT
753!
754 imin=bounds(ng)%Imin(cgrid,ghost,myrank)
755 imax=bounds(ng)%Imax(cgrid,ghost,myrank)
756 jmin=bounds(ng)%Jmin(cgrid,ghost,myrank)
757 jmax=bounds(ng)%Jmax(cgrid,ghost,myrank)
758!
759! Set switch to compute minimum and maximum values.
760!
761 IF (PRESENT(minvalue)) THEN
762 lminmax=.true.
763 IF (.not.associated(lwater)) THEN
764 allocate ( lwater(lbi:ubi,lbj:ubj,lbk:ubk,lbt:ubt) )
765 lwater=.true.
766 END IF
767 ELSE
768 lminmax=.false.
769 END IF
770!
771! Set switch to replace land areas with fill value, spval.
772!
773# ifdef MASKING
774 IF (PRESENT(setfillval)) THEN
775 landfill=setfillval
776 ELSE
777 landfill=tindex.gt.0
778 END IF
779# else
780 landfill=.false.
781# endif
782!
783! If appropriate, set the field extraction flag to the provided grid
784! geometry through interpolation or decimation.
785!
786 IF (PRESENT(extractfield)) THEN
787 extract_flag=extractfield
788 ELSE
789 extract_flag=0
790 END IF
791
792# ifdef OUTPUT_STATS
793!
794! Initialize output variable statistics structure.
795!
796 stats % checksum=0_i8b
797 stats % count=0
798 stats % min=spval
799 stats % max=-spval
800 stats % avg=0.0_r8
801 stats % rms=0.0_r8
802# endif
803!
804!-----------------------------------------------------------------------
805! Write out data into NetCDF file.
806!-----------------------------------------------------------------------
807!
808! Allocate, initialize and load data into local array used for
809! writing. Overwrite masked points with special value.
810!
811 IF (dkind.eq.pio_double) THEN ! double precision
812 IF (.not.associated(awrk8)) THEN
813 allocate ( awrk8(lbi:ubi,lbj:ubj,lbk:ubk,lbt:ubt) )
814 awrk8=0.0_r8
815 END IF
816!
817 DO l=lbt,ubt
818 DO k=lbk,ubk
819 DO j=jmin,jmax
820 DO i=imin,imax
821 awrk8(i,j,k,l)=adat(i,j,k,l)*ascl
822# ifdef MASKING
823 IF ((amask(i,j).eq.0.0_r8).and.landfill) THEN
824 awrk8(i,j,k,l)=spval
825 IF (lminmax) lwater(i,j,k,l)=.false.
826 END IF
827# endif
828 END DO
829 END DO
830 END DO
831 END DO
832 IF (lminmax) THEN
833 rbuffer(1)=minval(awrk8, mask=lwater)
834 rbuffer(2)=maxval(awrk8, mask=lwater)
835 END IF
836 ELSE ! single precision
837 IF (.not.associated(awrk4)) THEN
838 allocate ( awrk4(lbi:ubi,lbj:ubj,lbk:ubk,lbt:ubt) )
839 awrk4=0.0_r8
840 END IF
841!
842 DO l=lbt,ubt
843 DO k=lbk,ubk
844 DO j=jmin,jmax
845 DO i=imin,imax
846 awrk4(i,j,k,l)=real(adat(i,j,k,l)*ascl, r4)
847# ifdef MASKING
848 IF ((amask(i,j).eq.0.0_r8).and.landfill) THEN
849 awrk4(i,j,k,l)=real(spval, r4)
850 END IF
851# endif
852 END DO
853 END DO
854 END DO
855 END DO
856 IF (lminmax) THEN
857 rbuffer(1)=real(minval(awrk4, mask=lwater),r8)
858 rbuffer(2)=real(maxval(awrk4, mask=lwater),r8)
859 END IF
860 END IF
861!
862! Set unlimited time dimension record to write, if any.
863!
864 IF (tindex.gt.0) THEN
865 CALL pio_setframe (piofile, &
866 & piovar%vd, &
867 & int(tindex, kind=pio_offset_kind))
868 END IF
869!
870! Write out data into NetCDF.
871!
872 IF (dkind.eq.pio_double) THEN ! double precision
873 CALL pio_write_darray (piofile, &
874 & piovar%vd, &
875 & piodesc, &
876 & awrk8(imin:imax,jmin:jmax, &
877 & lbk:ubk,lbt:ubt), &
878 & status)
879 ELSE ! single precision
880 CALL pio_write_darray (piofile, &
881 & piovar%vd, &
882 & piodesc, &
883 & awrk4(imin:imax,jmin:jmax, &
884 & lbk:ubk,lbt:ubt), &
885 & status)
886 END IF
887
888# ifdef OUTPUT_STATS
889!
890!-----------------------------------------------------------------------
891! Compute and report output field statistics.
892!-----------------------------------------------------------------------
893!
894# ifdef DISTRIBUTE
895 tile=myrank
896# else
897 tile=-1
898# endif
899 CALL stats_4dfld (ng, tile, model, gtype, stats, &
900 & extract_flag, &
901 & lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, &
902 & adat, &
903# ifdef MASKING
904 & fmask = amask, &
905# endif
906 & debug = .false.)
907 IF (outthread) THEN
908 WRITE (stdout,10) trim(vname(1,ifield)), stats%min, stats%max, &
909 & stats%checksum
910 10 FORMAT (4x,'- ',a,':',t35,'Min = ',1p,e15.8,', Max = ', &
911 & 1p,e15.8,', CheckSum = ',i0)
912 END IF
913# endif
914!
915!-----------------------------------------------------------------------
916! If applicable, compute global minimum and maximum values.
917!-----------------------------------------------------------------------
918!
919 IF (lminmax) THEN
920 op_handle(1)='MIN'
921 op_handle(2)='MAX'
922 CALL mp_reduce (ng, model, 2, rbuffer, op_handle)
923 minvalue=rbuffer(1)
924 maxvalue=rbuffer(2)
925 IF (associated(lwater)) deallocate (lwater)
926 END IF
927!
928! Deallocate local array.
929!
930 IF (dkind.eq.pio_double) THEN
931 IF (associated(awrk8)) deallocate (awrk8)
932 ELSE
933 IF (associated(awrk4)) deallocate (awrk4)
934 END IF
935!
936 RETURN
distribute_mod::mp_reduce
Definition distribute.F:113
mod_pio_netcdf
Definition mod_pio_netcdf.F:2
stats_mod
Definition stats.F:2
stats_mod::stats_4dfld
subroutine, public stats_4dfld(ng, tile, model, gtype, s, extract_flag, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, f, fmask, debug)
Definition stats.F:646