| 1 | #include "cppdefs.h"
|
|---|
| 2 | MODULE nf_fwrite4d_mod
|
|---|
| 3 | !
|
|---|
| 4 | !svn $Id$
|
|---|
| 5 | !================================================== Hernan G. Arango ===
|
|---|
| 6 | ! Copyright (c) 2002-2018 The ROMS/TOMS Group !
|
|---|
| 7 | ! Licensed under a MIT/X style license !
|
|---|
| 8 | ! See License_ROMS.txt !
|
|---|
| 9 | !=======================================================================
|
|---|
| 10 | ! !
|
|---|
| 11 | ! This function writes out a generic floating point 4D array into an !
|
|---|
| 12 | ! output NetCDF file. !
|
|---|
| 13 | ! !
|
|---|
| 14 | ! On Input: !
|
|---|
| 15 | ! !
|
|---|
| 16 | ! ng Nested grid number. !
|
|---|
| 17 | ! model Calling model identifier. !
|
|---|
| 18 | ! ncid NetCDF file ID. !
|
|---|
| 19 | ! ncvarid NetCDF variable ID. !
|
|---|
| 20 | ! tindex NetCDF time record index to write. !
|
|---|
| 21 | ! gtype Grid type. If negative, only write water points. !
|
|---|
| 22 | ! LBi I-dimension Lower bound. !
|
|---|
| 23 | ! UBi I-dimension Upper bound. !
|
|---|
| 24 | ! LBj J-dimension Lower bound. !
|
|---|
| 25 | ! UBj J-dimension Upper bound. !
|
|---|
| 26 | ! LBk K-dimension Lower bound. !
|
|---|
| 27 | ! UBk K-dimension Upper bound. !
|
|---|
| 28 | ! LBt Time-dimension Lower bound. !
|
|---|
| 29 | ! UBt Time-dimension Upoer bound. !
|
|---|
| 30 | ! Amask land/Sea mask, if any (real). !
|
|---|
| 31 | ! Ascl Factor to scale field before writing (real). !
|
|---|
| 32 | ! A Field to write out (real). !
|
|---|
| 33 | ! SetFillVal Logical switch to set fill value in land areas !
|
|---|
| 34 | ! (optional). !
|
|---|
| 35 | ! !
|
|---|
| 36 | ! On Output: !
|
|---|
| 37 | ! !
|
|---|
| 38 | ! nf_fwrite4d Error flag (integer). !
|
|---|
| 39 | ! !
|
|---|
| 40 | #ifdef POSITIVE_ZERO
|
|---|
| 41 | ! Starting F95 zero values can be signed (-0 or +0) following the !
|
|---|
| 42 | ! IEEE 754 floating point standard. This may produce different !
|
|---|
| 43 | ! output data in serial and parallel applications. Since comparing !
|
|---|
| 44 | ! serial and parallel output is essential for tracking parallel !
|
|---|
| 45 | ! partition bugs, "positive zero" is enforced. !
|
|---|
| 46 | ! !
|
|---|
| 47 | #endif
|
|---|
| 48 | !=======================================================================
|
|---|
| 49 | !
|
|---|
| 50 | implicit none
|
|---|
| 51 |
|
|---|
| 52 | CONTAINS
|
|---|
| 53 |
|
|---|
| 54 | #if defined PARALLEL_IO && defined DISTRIBUTE
|
|---|
| 55 | !
|
|---|
| 56 | !***********************************************************************
|
|---|
| 57 | FUNCTION nf_fwrite4d (ng, model, ncid, ncvarid, tindex, gtype, &
|
|---|
| 58 | & LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt, &
|
|---|
| 59 | & Ascl, &
|
|---|
| 60 | # ifdef MASKING
|
|---|
| 61 | & Amask, &
|
|---|
| 62 | # endif
|
|---|
| 63 | & A, SetFillVal)
|
|---|
| 64 | !***********************************************************************
|
|---|
| 65 | !
|
|---|
| 66 | USE mod_param
|
|---|
| 67 | USE mod_parallel
|
|---|
| 68 | USE mod_ncparam
|
|---|
| 69 | USE mod_netcdf
|
|---|
| 70 | USE mod_scalars
|
|---|
| 71 |
|
|---|
| 72 | # ifdef MASKING
|
|---|
| 73 | !
|
|---|
| 74 | USE distribute_mod, ONLY : mp_collect
|
|---|
| 75 | # endif
|
|---|
| 76 | !
|
|---|
| 77 | ! Imported variable declarations.
|
|---|
| 78 | !
|
|---|
| 79 | logical, intent(in), optional :: SetFillVal
|
|---|
| 80 |
|
|---|
| 81 | integer, intent(in) :: ng, model, ncid, ncvarid, tindex, gtype
|
|---|
| 82 | integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt
|
|---|
| 83 |
|
|---|
| 84 | real(r8), intent(in) :: Ascl
|
|---|
| 85 |
|
|---|
| 86 | # ifdef ASSUMED_SHAPE
|
|---|
| 87 | # ifdef MASKING
|
|---|
| 88 | real(r8), intent(in) :: Amask(LBi:,LBj:)
|
|---|
| 89 | # endif
|
|---|
| 90 | real(r8), intent(in) :: A(LBi:,LBj:,LBk:,LBt:)
|
|---|
| 91 | # else
|
|---|
| 92 | # ifdef MASKING
|
|---|
| 93 | real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
|
|---|
| 94 | # endif
|
|---|
| 95 | real(r8), intent(in) :: A(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
|
|---|
| 96 | # endif
|
|---|
| 97 | !
|
|---|
| 98 | ! Local variable declarations.
|
|---|
| 99 | !
|
|---|
| 100 | # ifdef MASKING
|
|---|
| 101 | logical :: LandFill
|
|---|
| 102 | # endif
|
|---|
| 103 | integer :: i, ic, j, jc, k, kc, l, lc, Npts
|
|---|
| 104 | integer :: Imin, Imax, Jmin, Jmax, Kmin, Kmax
|
|---|
| 105 | integer :: Ioff, Joff, Koff, Loff
|
|---|
| 106 | integer :: Istr, Iend
|
|---|
| 107 | integer :: Ilen, Isize, Jlen, Jsize, IJlen, IJKlen, Klen, Llen
|
|---|
| 108 | integer :: MyType, status
|
|---|
| 109 |
|
|---|
| 110 | integer, dimension(5) :: start, total
|
|---|
| 111 |
|
|---|
| 112 | integer :: nf_fwrite4d
|
|---|
| 113 |
|
|---|
| 114 | real(r8), parameter :: IniVal = 0.0_r8
|
|---|
| 115 |
|
|---|
| 116 | real(r8), allocatable :: Awrk(:)
|
|---|
| 117 | !
|
|---|
| 118 | !-----------------------------------------------------------------------
|
|---|
| 119 | ! Set starting and ending indices to process.
|
|---|
| 120 | !-----------------------------------------------------------------------
|
|---|
| 121 | !
|
|---|
| 122 | ! Set first and last grid point according to staggered C-grid
|
|---|
| 123 | ! classification.
|
|---|
| 124 | !
|
|---|
| 125 | MyType=gtype
|
|---|
| 126 |
|
|---|
| 127 | SELECT CASE (ABS(MyType))
|
|---|
| 128 | CASE (p2dvar, p3dvar)
|
|---|
| 129 | Imin=BOUNDS(ng)%Istr (MyRank)
|
|---|
| 130 | Imax=BOUNDS(ng)%IendR(MyRank)
|
|---|
| 131 | Jmin=BOUNDS(ng)%Jstr (MyRank)
|
|---|
| 132 | Jmax=BOUNDS(ng)%JendR(MyRank)
|
|---|
| 133 | Isize=IOBOUNDS(ng)%xi_psi
|
|---|
| 134 | Jsize=IOBOUNDS(ng)%eta_psi
|
|---|
| 135 | CASE (r2dvar, r3dvar)
|
|---|
| 136 | Imin=BOUNDS(ng)%IstrR(MyRank)
|
|---|
| 137 | Imax=BOUNDS(ng)%IendR(MyRank)
|
|---|
| 138 | Jmin=BOUNDS(ng)%JstrR(MyRank)
|
|---|
| 139 | Jmax=BOUNDS(ng)%JendR(MyRank)
|
|---|
| 140 | Isize=IOBOUNDS(ng)%xi_rho
|
|---|
| 141 | Jsize=IOBOUNDS(ng)%eta_rho
|
|---|
| 142 | CASE (u2dvar, u3dvar)
|
|---|
| 143 | Imin=BOUNDS(ng)%Istr (MyRank)
|
|---|
| 144 | Imax=BOUNDS(ng)%IendR(MyRank)
|
|---|
| 145 | Jmin=BOUNDS(ng)%JstrR(MyRank)
|
|---|
| 146 | Jmax=BOUNDS(ng)%JendR(MyRank)
|
|---|
| 147 | Isize=IOBOUNDS(ng)%xi_u
|
|---|
| 148 | Jsize=IOBOUNDS(ng)%eta_u
|
|---|
| 149 | CASE (v2dvar, v3dvar)
|
|---|
| 150 | Imin=BOUNDS(ng)%IstrR(MyRank)
|
|---|
| 151 | Imax=BOUNDS(ng)%IendR(MyRank)
|
|---|
| 152 | Jmin=BOUNDS(ng)%Jstr (MyRank)
|
|---|
| 153 | Jmax=BOUNDS(ng)%JendR(MyRank)
|
|---|
| 154 | Isize=IOBOUNDS(ng)%xi_v
|
|---|
| 155 | Jsize=IOBOUNDS(ng)%eta_v
|
|---|
| 156 | CASE DEFAULT
|
|---|
| 157 | Imin=BOUNDS(ng)%IstrR(MyRank)
|
|---|
| 158 | Imax=BOUNDS(ng)%IendR(MyRank)
|
|---|
| 159 | Jmin=BOUNDS(ng)%JstrR(MyRank)
|
|---|
| 160 | Jmax=BOUNDS(ng)%JendR(MyRank)
|
|---|
| 161 | Isize=IOBOUNDS(ng)%xi_rho
|
|---|
| 162 | Jsize=IOBOUNDS(ng)%eta_rho
|
|---|
| 163 | END SELECT
|
|---|
| 164 |
|
|---|
| 165 | Ilen=Imax-Imin+1
|
|---|
| 166 | Jlen=Jmax-Jmin+1
|
|---|
| 167 | Klen=UBk-LBk+1
|
|---|
| 168 | Llen=UBt-LBt+1
|
|---|
| 169 |
|
|---|
| 170 | # ifdef MASKING
|
|---|
| 171 | !
|
|---|
| 172 | ! Set switch to replace land areas with fill value, spval.
|
|---|
| 173 | !
|
|---|
| 174 | IF (PRESENT(SetFillVal)) THEN
|
|---|
| 175 | LandFill=SetFillVal
|
|---|
| 176 | ELSE
|
|---|
| 177 | LandFill=tindex.gt.0
|
|---|
| 178 | END IF
|
|---|
| 179 | # endif
|
|---|
| 180 | !
|
|---|
| 181 | !-----------------------------------------------------------------------
|
|---|
| 182 | ! Parallel I/O: Pack tile data into 1D array in column-major order.
|
|---|
| 183 | # ifdef MASKING
|
|---|
| 184 | ! Overwrite masked points with special value.
|
|---|
| 185 | # endif
|
|---|
| 186 | !-----------------------------------------------------------------------
|
|---|
| 187 | !
|
|---|
| 188 | IF (gtype.gt.0) THEN
|
|---|
| 189 | !
|
|---|
| 190 | ! Set offsets due the NetCDF dimensions. Recall that some output
|
|---|
| 191 | ! variables not always start at one.
|
|---|
| 192 | !
|
|---|
| 193 | SELECT CASE (ABS(MyType))
|
|---|
| 194 | CASE (p2dvar, p3dvar)
|
|---|
| 195 | Ioff=0
|
|---|
| 196 | Joff=0
|
|---|
| 197 | CASE (r2dvar, r3dvar)
|
|---|
| 198 | Ioff=1
|
|---|
| 199 | Joff=1
|
|---|
| 200 | CASE (u2dvar, u3dvar)
|
|---|
| 201 | Ioff=0
|
|---|
| 202 | Joff=1
|
|---|
| 203 | CASE (v2dvar, v3dvar)
|
|---|
| 204 | Ioff=1
|
|---|
| 205 | Joff=0
|
|---|
| 206 | CASE DEFAULT
|
|---|
| 207 | Ioff=1
|
|---|
| 208 | Joff=1
|
|---|
| 209 | END SELECT
|
|---|
| 210 |
|
|---|
| 211 | IF (LBk.eq.0) THEN
|
|---|
| 212 | Koff=1
|
|---|
| 213 | ELSE
|
|---|
| 214 | Koff=0
|
|---|
| 215 | END IF
|
|---|
| 216 |
|
|---|
| 217 | IF (LBt.eq.0) THEN
|
|---|
| 218 | Loff=1
|
|---|
| 219 | ELSE
|
|---|
| 220 | Loff=0
|
|---|
| 221 | END IF
|
|---|
| 222 | !
|
|---|
| 223 | ! Allocate and initialize scratch work array.
|
|---|
| 224 | !
|
|---|
| 225 | IJlen=Ilen*Jlen
|
|---|
| 226 | IJKlen=IJlen*Klen
|
|---|
| 227 | Npts=IJKlen*Llen
|
|---|
| 228 |
|
|---|
| 229 | IF (.not.allocated(Awrk)) THEN
|
|---|
| 230 | allocate ( Awrk(Npts) )
|
|---|
| 231 | Awrk=IniVal
|
|---|
| 232 | END IF
|
|---|
| 233 | !
|
|---|
| 234 | ! Pack and scale tile data.
|
|---|
| 235 | !
|
|---|
| 236 | ic=0
|
|---|
| 237 | DO l=LBt,UBt
|
|---|
| 238 | DO k=LBk,UBk
|
|---|
| 239 | DO j=Jmin,Jmax
|
|---|
| 240 | DO i=Imin,Imax
|
|---|
| 241 | ic=ic+1
|
|---|
| 242 | Awrk(ic)=A(i,j,k,l)*Ascl
|
|---|
| 243 | # ifdef POSITIVE_ZERO
|
|---|
| 244 | IF (ABS(Awrk(ic)).eq.0.0_r8) THEN
|
|---|
| 245 | Awrk(ic)=0.0_r8 ! impose positive zero
|
|---|
| 246 | END IF
|
|---|
| 247 | # endif
|
|---|
| 248 | # ifdef MASKING
|
|---|
| 249 | IF ((Amask(i,j).eq.0.0_r8).and.LandFill) THEN
|
|---|
| 250 | Awrk(ic)=spval
|
|---|
| 251 | END IF
|
|---|
| 252 | # endif
|
|---|
| 253 | END DO
|
|---|
| 254 | END DO
|
|---|
| 255 | END DO
|
|---|
| 256 | END DO
|
|---|
| 257 | !
|
|---|
| 258 | ! Write out data: all parallel nodes write their own packed tile data.
|
|---|
| 259 | !
|
|---|
| 260 | start(1)=Imin+Ioff
|
|---|
| 261 | total(1)=Ilen
|
|---|
| 262 | start(2)=Jmin+Joff
|
|---|
| 263 | total(2)=Jlen
|
|---|
| 264 | start(3)=LBk+Koff
|
|---|
| 265 | total(3)=Klen
|
|---|
| 266 | start(4)=LBt+Loff
|
|---|
| 267 | total(4)=Llen
|
|---|
| 268 | start(5)=tindex
|
|---|
| 269 | total(5)=1
|
|---|
| 270 |
|
|---|
| 271 | status=nf90_put_var(ncid, ncvarid, Awrk, start, total)
|
|---|
| 272 | nf_fwrite4d=status
|
|---|
| 273 | END IF
|
|---|
| 274 |
|
|---|
| 275 | # if defined WRITE_WATER && defined MASKING
|
|---|
| 276 | !
|
|---|
| 277 | !-----------------------------------------------------------------------
|
|---|
| 278 | ! Parallel I/O: Remove land points and pack tile data into 1D array.
|
|---|
| 279 | !-----------------------------------------------------------------------
|
|---|
| 280 | !
|
|---|
| 281 | IF (gtype.lt.0) THEN
|
|---|
| 282 | !
|
|---|
| 283 | ! Set offsets due array packing into 1D array in column-major order.
|
|---|
| 284 | !
|
|---|
| 285 | SELECT CASE (ABS(MyType))
|
|---|
| 286 | CASE (p2dvar, p3dvar)
|
|---|
| 287 | Ioff=0
|
|---|
| 288 | Joff=1
|
|---|
| 289 | CASE (r2dvar, r3dvar)
|
|---|
| 290 | Ioff=1
|
|---|
| 291 | Joff=0
|
|---|
| 292 | CASE (u2dvar, u3dvar)
|
|---|
| 293 | Ioff=0
|
|---|
| 294 | Joff=0
|
|---|
| 295 | CASE (v2dvar, v3dvar)
|
|---|
| 296 | Ioff=1
|
|---|
| 297 | Joff=1
|
|---|
| 298 | CASE DEFAULT
|
|---|
| 299 | Ioff=1
|
|---|
| 300 | Joff=0
|
|---|
| 301 | END SELECT
|
|---|
| 302 |
|
|---|
| 303 | IF (LBk.eq.0) THEN
|
|---|
| 304 | Koff=0
|
|---|
| 305 | ELSE
|
|---|
| 306 | Koff=1
|
|---|
| 307 | END IF
|
|---|
| 308 |
|
|---|
| 309 | IF (LBt.eq.0) THEN
|
|---|
| 310 | Loff=0
|
|---|
| 311 | ELSE
|
|---|
| 312 | Loff=1
|
|---|
| 313 | END IF
|
|---|
| 314 | !
|
|---|
| 315 | ! Allocate and initialize scratch work array.
|
|---|
| 316 | !
|
|---|
| 317 | IJlen=Isize*Jsize
|
|---|
| 318 | IJKlen=IJlen*Klen
|
|---|
| 319 | Npts=IJKlen*Llen
|
|---|
| 320 |
|
|---|
| 321 | IF (.not.allocated(Awrk)) THEN
|
|---|
| 322 | allocate ( Awrk(Npts) )
|
|---|
| 323 | Awrk=IniVal
|
|---|
| 324 | END IF
|
|---|
| 325 | !
|
|---|
| 326 | ! Scale and gather data from all spawned nodes. Store data into a 1D
|
|---|
| 327 | ! global array, packed in column-major order. Flag land point with
|
|---|
| 328 | ! special value.
|
|---|
| 329 | !
|
|---|
| 330 | DO l=LBt,UBt
|
|---|
| 331 | lc=(l-Loff)*IJKlen
|
|---|
| 332 | DO k=LBk,UBk
|
|---|
| 333 | kc=(k-Koff)*IJlen+lc
|
|---|
| 334 | DO j=Jmin,Jmax
|
|---|
| 335 | jc=(j-Joff)*Isize+kc
|
|---|
| 336 | DO i=Imin,Imax
|
|---|
| 337 | ic=i+Ioff+jc
|
|---|
| 338 | Awrk(ic)=A(i,j,k,l)*Ascl
|
|---|
| 339 | # ifdef POSITIVE_ZERO
|
|---|
| 340 | IF (ABS(Awrk(ic)).eq.0.0_r8) THEN
|
|---|
| 341 | Awrk(ic)=0.0_r8 ! impose positive zero
|
|---|
| 342 | END IF
|
|---|
| 343 | # endif
|
|---|
| 344 | IF (Amask(i,j).eq.0.0_r8) THEN
|
|---|
| 345 | Awrk(ic)=spval
|
|---|
| 346 | END IF
|
|---|
| 347 | END DO
|
|---|
| 348 | END DO
|
|---|
| 349 | END DO
|
|---|
| 350 | END DO
|
|---|
| 351 | !
|
|---|
| 352 | ! Global reduction of work array.
|
|---|
| 353 | !
|
|---|
| 354 | CALL mp_collect (ng, model, Npts, IniVal, Awrk)
|
|---|
| 355 | !
|
|---|
| 356 | ! Remove land points.
|
|---|
| 357 | !
|
|---|
| 358 | ic=0
|
|---|
| 359 | DO i=1,Npts
|
|---|
| 360 | IF (Awrk(i).lt.spval) THEN
|
|---|
| 361 | ic=ic+1
|
|---|
| 362 | Awrk(ic)=Awrk(i)
|
|---|
| 363 | END IF
|
|---|
| 364 | END DO
|
|---|
| 365 | Npts=ic
|
|---|
| 366 | !
|
|---|
| 367 | ! Write out data: all parallel nodes write a section of the packed
|
|---|
| 368 | ! data.
|
|---|
| 369 | !
|
|---|
| 370 | CALL tile_bounds_1d (ng, MyRank, Npts, Istr, Iend)
|
|---|
| 371 |
|
|---|
| 372 | start(1)=Istr
|
|---|
| 373 | total(1)=Iend-Istr+1
|
|---|
| 374 | start(2)=tindex
|
|---|
| 375 | total(2)=1
|
|---|
| 376 |
|
|---|
| 377 | status=nf90_put_var(ncid, ncvarid, Awrk(Istr:), start, total)
|
|---|
| 378 | nf_fwrite4d=status
|
|---|
| 379 | END IF
|
|---|
| 380 | # endif
|
|---|
| 381 | !
|
|---|
| 382 | !-----------------------------------------------------------------------
|
|---|
| 383 | ! Deallocate scratch work array.
|
|---|
| 384 | !-----------------------------------------------------------------------
|
|---|
| 385 | !
|
|---|
| 386 | IF (allocated(Awrk)) THEN
|
|---|
| 387 | deallocate (Awrk)
|
|---|
| 388 | END IF
|
|---|
| 389 |
|
|---|
| 390 | RETURN
|
|---|
| 391 | END FUNCTION nf_fwrite4d
|
|---|
| 392 |
|
|---|
| 393 | #else
|
|---|
| 394 |
|
|---|
| 395 | !
|
|---|
| 396 | !***********************************************************************
|
|---|
| 397 | FUNCTION nf_fwrite4d (ng, model, ncid, ncvarid, tindex, gtype, &
|
|---|
| 398 | & LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt, &
|
|---|
| 399 | & Ascl, &
|
|---|
| 400 | # ifdef MASKING
|
|---|
| 401 | & Amask, &
|
|---|
| 402 | # endif
|
|---|
| 403 | & A, SetFillVal)
|
|---|
| 404 | !***********************************************************************
|
|---|
| 405 | !
|
|---|
| 406 | USE mod_param
|
|---|
| 407 | USE mod_parallel
|
|---|
| 408 | USE mod_ncparam
|
|---|
| 409 | USE mod_netcdf
|
|---|
| 410 | USE mod_scalars
|
|---|
| 411 |
|
|---|
| 412 | # ifdef DISTRIBUTE
|
|---|
| 413 | !
|
|---|
| 414 | USE distribute_mod, ONLY : mp_bcasti
|
|---|
| 415 | # ifdef INLINE_2DIO
|
|---|
| 416 | USE distribute_mod, ONLY : mp_gather2d
|
|---|
| 417 | # else
|
|---|
| 418 | USE distribute_mod, ONLY : mp_gather3d
|
|---|
| 419 | # endif
|
|---|
| 420 | # endif
|
|---|
| 421 | !
|
|---|
| 422 | ! Imported variable declarations.
|
|---|
| 423 | !
|
|---|
| 424 | logical, intent(in), optional :: SetFillVal
|
|---|
| 425 |
|
|---|
| 426 | integer, intent(in) :: ng, model, ncid, ncvarid, tindex, gtype
|
|---|
| 427 | integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt
|
|---|
| 428 |
|
|---|
| 429 | real(r8), intent(in) :: Ascl
|
|---|
| 430 |
|
|---|
| 431 | # ifdef ASSUMED_SHAPE
|
|---|
| 432 | # ifdef MASKING
|
|---|
| 433 | real(r8), intent(in) :: Amask(LBi:,LBj:)
|
|---|
| 434 | # endif
|
|---|
| 435 | real(r8), intent(in) :: A(LBi:,LBj:,LBk:,LBt:)
|
|---|
| 436 | # else
|
|---|
| 437 | # ifdef MASKING
|
|---|
| 438 | real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
|
|---|
| 439 | # endif
|
|---|
| 440 | real(r8), intent(in) :: A(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
|
|---|
| 441 | # endif
|
|---|
| 442 | !
|
|---|
| 443 | ! Local variable declarations.
|
|---|
| 444 | !
|
|---|
| 445 | # ifdef MASKING
|
|---|
| 446 | logical :: LandFill
|
|---|
| 447 | # endif
|
|---|
| 448 | integer :: i, j, k, ic, fourth, Npts
|
|---|
| 449 | integer :: Imin, Imax, Jmin, Jmax, Kmin, Kmax, Koff, Loff
|
|---|
| 450 | integer :: Ilen, Jlen, Klen, IJlen, MyType, status
|
|---|
| 451 |
|
|---|
| 452 | integer, dimension(5) :: start, total
|
|---|
| 453 |
|
|---|
| 454 | integer :: nf_fwrite4d
|
|---|
| 455 |
|
|---|
| 456 | # if defined INLINE_2DIO && defined DISTRIBUTE
|
|---|
| 457 | real(r8), dimension((Lm(ng)+2)*(Mm(ng)+2)) :: Awrk
|
|---|
| 458 | # else
|
|---|
| 459 | real(r8), dimension((Lm(ng)+2)*(Mm(ng)+2)*(UBk-LBk+1)) :: Awrk
|
|---|
| 460 | # endif
|
|---|
| 461 | !
|
|---|
| 462 | !-----------------------------------------------------------------------
|
|---|
| 463 | ! Set starting and ending indices to process.
|
|---|
| 464 | !-----------------------------------------------------------------------
|
|---|
| 465 | !
|
|---|
| 466 | ! Set first and last grid point according to staggered C-grid
|
|---|
| 467 | ! classification. Set loops offsets.
|
|---|
| 468 | !
|
|---|
| 469 | MyType=gtype
|
|---|
| 470 |
|
|---|
| 471 | SELECT CASE (ABS(MyType))
|
|---|
| 472 | CASE (p2dvar, p3dvar)
|
|---|
| 473 | Imin=IOBOUNDS(ng)%ILB_psi
|
|---|
| 474 | Imax=IOBOUNDS(ng)%IUB_psi
|
|---|
| 475 | Jmin=IOBOUNDS(ng)%JLB_psi
|
|---|
| 476 | Jmax=IOBOUNDS(ng)%JUB_psi
|
|---|
| 477 | CASE (r2dvar, r3dvar)
|
|---|
| 478 | Imin=IOBOUNDS(ng)%ILB_rho
|
|---|
| 479 | Imax=IOBOUNDS(ng)%IUB_rho
|
|---|
| 480 | Jmin=IOBOUNDS(ng)%JLB_rho
|
|---|
| 481 | Jmax=IOBOUNDS(ng)%JUB_rho
|
|---|
| 482 | CASE (u2dvar, u3dvar)
|
|---|
| 483 | Imin=IOBOUNDS(ng)%ILB_u
|
|---|
| 484 | Imax=IOBOUNDS(ng)%IUB_u
|
|---|
| 485 | Jmin=IOBOUNDS(ng)%JLB_u
|
|---|
| 486 | Jmax=IOBOUNDS(ng)%JUB_u
|
|---|
| 487 | CASE (v2dvar, v3dvar)
|
|---|
| 488 | Imin=IOBOUNDS(ng)%ILB_v
|
|---|
| 489 | Imax=IOBOUNDS(ng)%IUB_v
|
|---|
| 490 | Jmin=IOBOUNDS(ng)%JLB_v
|
|---|
| 491 | Jmax=IOBOUNDS(ng)%JUB_v
|
|---|
| 492 | CASE DEFAULT
|
|---|
| 493 | Imin=IOBOUNDS(ng)%ILB_rho
|
|---|
| 494 | Imax=IOBOUNDS(ng)%IUB_rho
|
|---|
| 495 | Jmin=IOBOUNDS(ng)%JLB_rho
|
|---|
| 496 | Jmax=IOBOUNDS(ng)%JUB_rho
|
|---|
| 497 | END SELECT
|
|---|
| 498 |
|
|---|
| 499 | Ilen=Imax-Imin+1
|
|---|
| 500 | Jlen=Jmax-Jmin+1
|
|---|
| 501 | Klen=UBk-LBk+1
|
|---|
| 502 | IJlen=Ilen*Jlen
|
|---|
| 503 |
|
|---|
| 504 | IF (LBk.eq.0) THEN
|
|---|
| 505 | Koff=0
|
|---|
| 506 | ELSE
|
|---|
| 507 | Koff=1
|
|---|
| 508 | END IF
|
|---|
| 509 |
|
|---|
| 510 | IF (LBt.eq.0) THEN
|
|---|
| 511 | Loff=1
|
|---|
| 512 | ELSE
|
|---|
| 513 | Loff=0
|
|---|
| 514 | END IF
|
|---|
| 515 |
|
|---|
| 516 | # ifdef MASKING
|
|---|
| 517 | !
|
|---|
| 518 | ! Set switch to replace land areas with fill value, spval.
|
|---|
| 519 | !
|
|---|
| 520 | IF (PRESENT(SetFillVal)) THEN
|
|---|
| 521 | LandFill=SetFillVal
|
|---|
| 522 | ELSE
|
|---|
| 523 | LandFill=tindex.gt.0
|
|---|
| 524 | END IF
|
|---|
| 525 | # endif
|
|---|
| 526 | !
|
|---|
| 527 | ! Initialize local array to avoid denormalized numbers. This
|
|---|
| 528 | ! facilitates processing and debugging.
|
|---|
| 529 | !
|
|---|
| 530 | Awrk=0.0_r8
|
|---|
| 531 |
|
|---|
| 532 | # ifdef DISTRIBUTE
|
|---|
| 533 | !
|
|---|
| 534 | !-----------------------------------------------------------------------
|
|---|
| 535 | ! If distributed-memory set-up, collect tile data from all spawned
|
|---|
| 536 | ! nodes and store it into a global scratch 1D array, packed in column-
|
|---|
| 537 | ! major order.
|
|---|
| 538 | # ifdef MASKING
|
|---|
| 539 | # ifdef WRITE_WATER
|
|---|
| 540 | ! Remove land points and pack water points into 1D-array.
|
|---|
| 541 | # else
|
|---|
| 542 | ! Overwrite masked points with special value.
|
|---|
| 543 | # endif
|
|---|
| 544 | # endif
|
|---|
| 545 | !-----------------------------------------------------------------------
|
|---|
| 546 | !
|
|---|
| 547 | !
|
|---|
| 548 | DO fourth=LBt,UBt
|
|---|
| 549 | # ifdef INLINE_2DIO
|
|---|
| 550 |
|
|---|
| 551 | ! If appropriate, process 3D data level by level to reduce memory
|
|---|
| 552 | ! requirements.
|
|---|
| 553 | !
|
|---|
| 554 | DO k=LBk,UBk
|
|---|
| 555 | CALL mp_gather2d (ng, model, LBi, UBi, LBj, UBj, &
|
|---|
| 556 | & tindex, gtype, Ascl, &
|
|---|
| 557 | # ifdef MASKING
|
|---|
| 558 | & Amask, &
|
|---|
| 559 | # endif
|
|---|
| 560 | & A(:,:,k,fourth), Npts, Awrk, SetFillVal)
|
|---|
| 561 | # else
|
|---|
| 562 | CALL mp_gather3d (ng, model, LBi, UBi, LBj, UBj, LBk, UBk, &
|
|---|
| 563 | & tindex, gtype, Ascl, &
|
|---|
| 564 | # ifdef MASKING
|
|---|
| 565 | & Amask, &
|
|---|
| 566 | # endif
|
|---|
| 567 | & A(:,:,:,fourth), Npts, Awrk, SetFillVal)
|
|---|
| 568 | # endif
|
|---|
| 569 |
|
|---|
| 570 | !
|
|---|
| 571 | !-----------------------------------------------------------------------
|
|---|
| 572 | ! Write output buffer into NetCDF file.
|
|---|
| 573 | !-----------------------------------------------------------------------
|
|---|
| 574 | !
|
|---|
| 575 | nf_fwrite4d=nf90_noerr
|
|---|
| 576 | IF (OutThread) THEN
|
|---|
| 577 | IF (gtype.gt.0) THEN
|
|---|
| 578 | start(1)=1
|
|---|
| 579 | total(1)=Ilen
|
|---|
| 580 | start(2)=1
|
|---|
| 581 | total(2)=Jlen
|
|---|
| 582 | # ifdef INLINE_2DIO
|
|---|
| 583 | start(3)=k-Koff+1
|
|---|
| 584 | total(3)=1
|
|---|
| 585 | # else
|
|---|
| 586 | start(3)=1
|
|---|
| 587 | total(3)=Klen
|
|---|
| 588 | # endif
|
|---|
| 589 | start(4)=fourth+Loff
|
|---|
| 590 | total(4)=1
|
|---|
| 591 | start(5)=tindex
|
|---|
| 592 | total(5)=1
|
|---|
| 593 | # ifdef MASKING
|
|---|
| 594 | ELSE
|
|---|
| 595 | start(1)=1+(fourth+Loff-1)*Npts
|
|---|
| 596 | total(1)=Npts
|
|---|
| 597 | start(2)=tindex
|
|---|
| 598 | total(2)=1
|
|---|
| 599 | # endif
|
|---|
| 600 | END IF
|
|---|
| 601 | # ifdef POSITIVE_ZERO
|
|---|
| 602 | DO ic=1,Npts
|
|---|
| 603 | IF (ABS(Awrk(ic)).eq.0.0_r8) THEN
|
|---|
| 604 | Awrk(ic)=0.0_r8 ! impose positive zero
|
|---|
| 605 | END IF
|
|---|
| 606 | END DO
|
|---|
| 607 | # endif
|
|---|
| 608 | status=nf90_put_var(ncid, ncvarid, Awrk, start, total)
|
|---|
| 609 | nf_fwrite4d=status
|
|---|
| 610 | END IF
|
|---|
| 611 | # ifdef INLINE_2DIO
|
|---|
| 612 | END DO
|
|---|
| 613 | # endif
|
|---|
| 614 | END DO
|
|---|
| 615 | # else
|
|---|
| 616 | !
|
|---|
| 617 | !-----------------------------------------------------------------------
|
|---|
| 618 | ! If serial or shared-memory applications and serial output, pack data
|
|---|
| 619 | ! into a global 1D array in column-major order.
|
|---|
| 620 | # ifdef MASKING
|
|---|
| 621 | # ifdef WRITE_WATER
|
|---|
| 622 | ! Remove land points and pack water points into 1D-array.
|
|---|
| 623 | # else
|
|---|
| 624 | ! Overwrite masked points with special value.
|
|---|
| 625 | # endif
|
|---|
| 626 | # endif
|
|---|
| 627 | !-----------------------------------------------------------------------
|
|---|
| 628 | !
|
|---|
| 629 | ! Process data as 3D slices.
|
|---|
| 630 | !
|
|---|
| 631 | DO fourth=LBt,UBt
|
|---|
| 632 | IF (gtype.gt.0) THEN
|
|---|
| 633 | ic=0
|
|---|
| 634 | Npts=IJlen*Klen
|
|---|
| 635 | DO k=LBk,UBk
|
|---|
| 636 | DO j=Jmin,Jmax
|
|---|
| 637 | DO i=Imin,Imax
|
|---|
| 638 | ic=ic+1
|
|---|
| 639 | Awrk(ic)=A(i,j,k,fourth)*Ascl
|
|---|
| 640 | # ifdef MASKING
|
|---|
| 641 | IF ((Amask(i,j).eq.0.0_r8).and.LandFill) THEN
|
|---|
| 642 | Awrk(ic)=spval
|
|---|
| 643 | END IF
|
|---|
| 644 | # endif
|
|---|
| 645 | END DO
|
|---|
| 646 | END DO
|
|---|
| 647 | END DO
|
|---|
| 648 | # ifdef MASKING
|
|---|
| 649 | ELSE
|
|---|
| 650 | Npts=0
|
|---|
| 651 | DO k=LBk,UBk
|
|---|
| 652 | DO j=Jmin,Jmax
|
|---|
| 653 | DO i=Imin,Imax
|
|---|
| 654 | IF (Amask(i,j).gt.0.0_r8) THEN
|
|---|
| 655 | Npts=Npts+1
|
|---|
| 656 | Awrk(Npts)=A(i,j,k,fourth)*Ascl
|
|---|
| 657 | END IF
|
|---|
| 658 | END DO
|
|---|
| 659 | END DO
|
|---|
| 660 | END DO
|
|---|
| 661 | # endif
|
|---|
| 662 | END IF
|
|---|
| 663 | !
|
|---|
| 664 | !-----------------------------------------------------------------------
|
|---|
| 665 | ! Write output buffer into NetCDF file.
|
|---|
| 666 | !-----------------------------------------------------------------------
|
|---|
| 667 | !
|
|---|
| 668 | nf_fwrite4d=nf90_noerr
|
|---|
| 669 | IF (OutThread) THEN
|
|---|
| 670 | IF (gtype.gt.0) THEN
|
|---|
| 671 | start(1)=1
|
|---|
| 672 | total(1)=Ilen
|
|---|
| 673 | start(2)=1
|
|---|
| 674 | total(2)=Jlen
|
|---|
| 675 | start(3)=1
|
|---|
| 676 | total(3)=Klen
|
|---|
| 677 | start(4)=fourth+Loff
|
|---|
| 678 | total(4)=1
|
|---|
| 679 | start(5)=tindex
|
|---|
| 680 | total(5)=1
|
|---|
| 681 | # ifdef MASKING
|
|---|
| 682 | ELSE
|
|---|
| 683 | start(1)=1+(fourth+Loff-1)*Npts
|
|---|
| 684 | total(1)=Npts
|
|---|
| 685 | start(2)=tindex
|
|---|
| 686 | total(2)=1
|
|---|
| 687 | # endif
|
|---|
| 688 | END IF
|
|---|
| 689 | # ifdef POSITIVE_ZERO
|
|---|
| 690 | DO ic=1,Npts
|
|---|
| 691 | IF (ABS(Awrk(ic)).eq.0.0_r8) THEN
|
|---|
| 692 | Awrk(ic)=0.0_r8 ! impose positive zero
|
|---|
| 693 | END IF
|
|---|
| 694 | END DO
|
|---|
| 695 | # endif
|
|---|
| 696 | status=nf90_put_var(ncid, ncvarid, Awrk, start, total)
|
|---|
| 697 | END IF
|
|---|
| 698 | END DO
|
|---|
| 699 | # endif
|
|---|
| 700 | # ifdef DISTRIBUTE
|
|---|
| 701 | !
|
|---|
| 702 | !-----------------------------------------------------------------------
|
|---|
| 703 | ! Broadcast IO error flag to all nodes.
|
|---|
| 704 | !-----------------------------------------------------------------------
|
|---|
| 705 | !
|
|---|
| 706 | CALL mp_bcasti (ng, model, status)
|
|---|
| 707 | # endif
|
|---|
| 708 | nf_fwrite4d=status
|
|---|
| 709 |
|
|---|
| 710 | RETURN
|
|---|
| 711 | END FUNCTION nf_fwrite4d
|
|---|
| 712 | #endif
|
|---|
| 713 | END MODULE nf_fwrite4d_mod
|
|---|
