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

Data Types

interface  nf_fwrite3d
 

Functions/Subroutines

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

Function/Subroutine Documentation

◆ nf90_fwrite3d()

integer function nf_fwrite3d_mod::nf90_fwrite3d ( 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,
real(dp), intent(in) ascl,
real(r8), dimension(lbi:,lbj:), intent(in) amask,
real(r8), dimension(lbi:,lbj:,lbk:), 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 90 of file nf_fwrite3d.F.

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

integer function nf_fwrite3d_mod::pio_fwrite3d ( 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,
real(dp), intent(in) ascl,
real(r8), dimension(lbi:,lbj:), intent(in) amask,
real(r8), dimension(lbi:,lbj:,lbk:), 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 623 of file nf_fwrite3d.F.

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