MODULE nf_fwrite4d_mod ! !git $Id$ !svn $Id: nf_fwrite4d.F 1190 2023-08-18 19:51:09Z arango $ !================================================== Hernan G. Arango === ! Copyright (c) 2002-2023 The ROMS/TOMS Group ! ! Licensed under a MIT/X style license ! ! See License_ROMS.md ! !======================================================================= ! ! ! This function writes out a generic floating point 4D array into an ! ! output NetCDF file. ! ! ! ! On Input: ! ! ! ! ng Nested grid number ! ! model Calling model identifier ! ! ncid NetCDF file ID ! ! ifield Field metadata index (integer) ! ! ncvarid NetCDF variable ID ! ! tindex NetCDF time record index to write ! ! gtype Grid type. If negative, only write water points ! ! LBi I-dimension Lower bound ! ! UBi I-dimension Upper bound ! ! LBj J-dimension Lower bound ! ! UBj J-dimension Upper bound ! ! LBk K-dimension Lower bound ! ! UBk K-dimension Upper bound ! ! LBt Time-dimension Lower bound ! ! UBt Time-dimension Upper bound ! ! Amask land/Sea mask, if any (real) ! ! Ascl Factor to scale field before writing (real) ! ! Adat Field to write out (real) ! ! SetFillVal Logical switch to set fill value in land areas ! ! (OPTIONAL) ! ! ! ! On Output: ! ! ! ! status Error flag (integer) ! ! MinValue Minimum value (real, OPTIONAL) ! ! MaxValue Maximum value (real, OPTIONAL) ! ! ! !======================================================================= ! USE mod_param USE mod_parallel USE mod_ncparam USE mod_scalars ! implicit none ! INTERFACE nf_fwrite4d MODULE PROCEDURE nf90_fwrite4d END INTERFACE nf_fwrite4d ! CONTAINS ! !*********************************************************************** FUNCTION nf90_fwrite4d (ng, model, ncid, ifield, & & ncvarid, tindex, gtype, & & LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt, & & Ascl, & & Amask, & & Adat, SetFillVal, & & MinValue, MaxValue) RESULT (status) !*********************************************************************** ! USE mod_netcdf ! USE distribute_mod, ONLY : mp_bcasti USE distribute_mod, ONLY : mp_gather3d ! ! Imported variable declarations. ! logical, intent(in), optional :: SetFillVal ! integer, intent(in) :: ng, model, ncid, ncvarid, tindex, gtype integer, intent(in) :: ifield integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt ! real(dp), intent(in) :: Ascl ! real(r8), intent(in) :: Amask(LBi:,LBj:) real(r8), intent(in) :: Adat(LBi:,LBj:,LBk:,LBt:) real(r8), intent(out), optional :: MinValue real(r8), intent(out), optional :: MaxValue ! ! Local variable declarations. ! logical :: LandFill ! integer :: i, j, k, ic, fourth, Npts, tile integer :: Imin, Imax, Jmin, Jmax, Kmin, Kmax, Koff, Loff integer :: Ilen, Jlen, Klen, IJlen, MyType integer :: status integer, dimension(5) :: start, total ! real(r8), dimension((Lm(ng)+2)*(Mm(ng)+2)*(UBk-LBk+1)) :: Awrk ! !----------------------------------------------------------------------- ! Set starting and ending indices to process. !----------------------------------------------------------------------- ! status=nf90_noerr ! ! Set first and last grid point according to staggered C-grid ! classification. Set loops offsets. ! MyType=gtype ! SELECT CASE (ABS(MyType)) CASE (p2dvar, p3dvar) Imin=IOBOUNDS(ng)%ILB_psi Imax=IOBOUNDS(ng)%IUB_psi Jmin=IOBOUNDS(ng)%JLB_psi Jmax=IOBOUNDS(ng)%JUB_psi CASE (r2dvar, r3dvar) Imin=IOBOUNDS(ng)%ILB_rho Imax=IOBOUNDS(ng)%IUB_rho Jmin=IOBOUNDS(ng)%JLB_rho Jmax=IOBOUNDS(ng)%JUB_rho CASE (u2dvar, u3dvar) Imin=IOBOUNDS(ng)%ILB_u Imax=IOBOUNDS(ng)%IUB_u Jmin=IOBOUNDS(ng)%JLB_u Jmax=IOBOUNDS(ng)%JUB_u CASE (v2dvar, v3dvar) Imin=IOBOUNDS(ng)%ILB_v Imax=IOBOUNDS(ng)%IUB_v Jmin=IOBOUNDS(ng)%JLB_v Jmax=IOBOUNDS(ng)%JUB_v CASE DEFAULT Imin=IOBOUNDS(ng)%ILB_rho Imax=IOBOUNDS(ng)%IUB_rho Jmin=IOBOUNDS(ng)%JLB_rho Jmax=IOBOUNDS(ng)%JUB_rho END SELECT ! Ilen=Imax-Imin+1 Jlen=Jmax-Jmin+1 Klen=UBk-LBk+1 IJlen=Ilen*Jlen ! IF (LBk.eq.0) THEN Koff=0 ELSE Koff=1 END IF ! IF (LBt.eq.0) THEN Loff=1 ELSE Loff=0 END IF ! ! Set switch to replace land areas with fill value, spval. ! IF (PRESENT(SetFillVal)) THEN LandFill=SetFillVal ELSE LandFill=tindex.gt.0 END IF ! ! If appropriate, initialize minimum and maximum processed values. ! IF (PRESENT(MinValue)) THEN MinValue=spval MaxValue=-spval END IF ! ! Initialize local array to avoid denormalized numbers. This ! facilitates processing and debugging. ! Awrk=0.0_r8 ! !----------------------------------------------------------------------- ! If distributed-memory set-up, collect tile data from all spawned ! nodes and store it into a global scratch 1D array, packed in column- ! major order. ! Overwrite masked points with special value. !----------------------------------------------------------------------- ! DO fourth=LBt,UBt ! ! Process the data as 3D slices. ! CALL mp_gather3d (ng, model, LBi, UBi, LBj, UBj, LBk, UBk, & & tindex, gtype, Ascl, & & Amask, & & Adat(:,:,:,fourth), Npts, Awrk, SetFillVal) ! !----------------------------------------------------------------------- ! If applicable, compute output field minimum and maximum values. !----------------------------------------------------------------------- ! IF (PRESENT(MinValue)) THEN IF (OutThread) THEN DO i=1,Npts IF (ABS(Awrk(i)).lt.spval) THEN MinValue=MIN(MinValue,Awrk(i)) MaxValue=MAX(MaxValue,Awrk(i)) END IF END DO END IF END IF ! !----------------------------------------------------------------------- ! Write output buffer into NetCDF file. !----------------------------------------------------------------------- ! IF (OutThread) THEN IF (gtype.gt.0) THEN start(1)=1 total(1)=Ilen start(2)=1 total(2)=Jlen start(3)=1 total(3)=Klen start(4)=fourth+Loff total(4)=1 start(5)=tindex total(5)=1 ELSE start(1)=1+(fourth+Loff-1)*Npts total(1)=Npts start(2)=tindex total(2)=1 END IF status=nf90_put_var(ncid, ncvarid, Awrk, start, total) END IF END DO ! !----------------------------------------------------------------------- ! Broadcast IO error flag to all nodes. !----------------------------------------------------------------------- ! CALL mp_bcasti (ng, model, status) ! RETURN END FUNCTION nf90_fwrite4d ! END MODULE nf_fwrite4d_mod