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

Data Types

interface  nf_fwrite2d
 

Functions/Subroutines

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

Function/Subroutine Documentation

◆ nf90_fwrite2d()

integer function nf_fwrite2d_mod::nf90_fwrite2d ( 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,
real(dp), intent(in) ascl,
real(r8), dimension(lbi:,lbj:), intent(in) amask,
real(r8), dimension(lbi:,lbj:), 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 89 of file nf_fwrite2d.F.

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

integer function nf_fwrite2d_mod::pio_fwrite2d ( 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,
real(dp), intent(in) ascl,
real(r8), dimension(lbi:,lbj:), intent(in) amask,
real(r8), dimension(lbi:,lbj:), 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 591 of file nf_fwrite2d.F.

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