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

Data Types

interface  nf_fread2d
 

Functions/Subroutines

integer function nf90_fread2d (ng, model, ncname, ncid, ncvname, ncvarid, tindex, gtype, vsize, lbi, ubi, lbj, ubj, ascl, amin, amax, amask, adat, checksum, lregrid)
 
integer function pio_fread2d (ng, model, ncname, piofile, ncvname, piovar, tindex, piodesc, vsize, lbi, ubi, lbj, ubj, ascl, amin, amax, amask, adat, checksum, lregrid)
 

Function/Subroutine Documentation

◆ nf90_fread2d()

integer function nf_fread2d_mod::nf90_fread2d ( integer, intent(in) ng,
integer, intent(in) model,
character (len=*), intent(in) ncname,
integer, intent(in) ncid,
character (len=*), intent(in) ncvname,
integer, intent(in) ncvarid,
integer, intent(in) tindex,
integer, intent(in) gtype,
integer, dimension(4), intent(in) vsize,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
real(dp), intent(in) ascl,
real(r8), intent(out) amin,
real(r8), intent(out) amax,
real(r8), dimension(lbi:,lbj:), intent(in) amask,
real(r8), dimension(lbi:,lbj:), intent(out) adat,
integer(i8b), intent(out), optional checksum,
logical, intent(out), optional lregrid )

Definition at line 81 of file nf_fread2d.F.

92!***********************************************************************
93!
94 USE mod_netcdf
95!
96 USE distribute_mod, ONLY : mp_bcasti, mp_collect, mp_reduce
97 USE get_bounds_mod, ONLY : tile_bounds_1d, tile_bounds_2d
98 USE regrid_mod, ONLY : regrid_nf90
99!
100! Imported variable declarations.
101!
102 logical, intent(out), optional :: Lregrid
103!
104 integer, intent(in) :: ng, model, ncid, ncvarid, tindex, gtype
105 integer, intent(in) :: LBi, UBi, LBj, UBj
106 integer, intent(in) :: Vsize(4)
107!
108 integer(i8b), intent(out), optional :: checksum
109!
110 real(dp), intent(in) :: Ascl
111 real(r8), intent(out) :: Amin
112 real(r8), intent(out) :: Amax
113!
114 character (len=*), intent(in) :: ncname
115 character (len=*), intent(in) :: ncvname
116!
117# ifdef ASSUMED_SHAPE
118# ifdef MASKING
119 real(r8), intent(in) :: Amask(LBi:,LBj:)
120# endif
121 real(r8), intent(out) :: Adat(LBi:,LBj:)
122# else
123# ifdef MASKING
124 real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
125# endif
126 real(r8), intent(out) :: Adat(LBi:UBi,LBj:UBj)
127# endif
128!
129! Local variable declarations.
130!
131 logical :: Lchecksum, interpolate
132!
133 logical, dimension(3) :: foundit
134!
135 integer :: i, ic, ij, j, jc, np, MyNpts, Npts
136 integer :: Imin, Imax, Isize, Jmin, Jmax, Jsize, IJsize
137 integer :: Istr, Iend, Jstr, Jend
138 integer :: Ioff, Joff, IJoff
139 integer :: Ilen, Itile, Jlen, Jtile, IJlen
140 integer :: Cgrid, MyType, ghost, status, wtype
141
142 integer, dimension(3) :: start, total
143!
144 real(r8) :: Afactor, Aoffset, Aspval
145
146 real(r8), parameter :: IniVal = 0.0_r8
147
148 real(r8), dimension(2) :: rbuffer
149 real(r8), dimension(3) :: AttValue
150
151 real(r8), allocatable :: Awrk(:,:)
152# if defined MASKING && defined READ_WATER
153 real(r8), allocatable :: A2d(:)
154# endif
155 real(r8), allocatable :: wrk(:)
156!
157 character (len= 3), dimension(2) :: op_handle
158 character (len=12), dimension(3) :: AttName
159
160 character (len=*), parameter :: MyFile = &
161 & __FILE__//", nf90_fread2d"
162!
163!-----------------------------------------------------------------------
164! Set starting and ending indices to process.
165!-----------------------------------------------------------------------
166!
167 status=nf90_noerr
168!
169! Set first and last grid point according to staggered C-grid
170! classification. Set the offsets for variables with starting
171! zero-index. Recall the NetCDF does not support a zero-index.
172!
173! Notice that (Imin,Jmin) and (Imax,Jmax) are the corner of the
174! computational tile. If ghost=0, ghost points are not processed.
175! They will be processed elsewhere by the appropriate call to any
176! of the routines in "mp_exchange.F". If ghost=1, the ghost points
177! are read.
178!
179# ifdef NO_READ_GHOST
180 ghost=0 ! non-overlapping, no ghost points
181# else
182 IF (model.eq.iadm) THEN
183 ghost=0 ! non-overlapping, no ghost points
184 ELSE
185 ghost=1 ! overlapping, read ghost points
186 END IF
187# endif
188
189 mytype=gtype
190
191 SELECT CASE (abs(mytype))
192 CASE (p2dvar, p3dvar)
193 cgrid=1
194 isize=iobounds(ng)%xi_psi
195 jsize=iobounds(ng)%eta_psi
196 CASE (r2dvar, r3dvar)
197 cgrid=2
198 isize=iobounds(ng)%xi_rho
199 jsize=iobounds(ng)%eta_rho
200 CASE (u2dvar, u3dvar)
201 cgrid=3
202 isize=iobounds(ng)%xi_u
203 jsize=iobounds(ng)%eta_u
204 CASE (v2dvar, v3dvar)
205 cgrid=4
206 isize=iobounds(ng)%xi_v
207 jsize=iobounds(ng)%eta_v
208 CASE DEFAULT
209 cgrid=2
210 isize=iobounds(ng)%xi_rho
211 jsize=iobounds(ng)%eta_rho
212 END SELECT
213
214 imin=bounds(ng)%Imin(cgrid,ghost,myrank)
215 imax=bounds(ng)%Imax(cgrid,ghost,myrank)
216 jmin=bounds(ng)%Jmin(cgrid,ghost,myrank)
217 jmax=bounds(ng)%Jmax(cgrid,ghost,myrank)
218
219 ilen=imax-imin+1
220 jlen=jmax-jmin+1
221!
222! Determine if interpolating from coarse gridded data to model grid
223! is required. This is only allowed for gridded 2D fields. This is
224! convenient for atmospheric forcing datasets that are usually on
225! coarser grids. The user can provide coarser gridded data to avoid
226! very large input files.
227!
228 interpolate=.false.
229 IF (((vsize(1).gt.0).and.(vsize(1).ne.isize)).or. &
230 & ((vsize(2).gt.0).and.(vsize(2).ne.jsize))) THEN
231 interpolate=.true.
232 ilen=vsize(1)
233 jlen=vsize(2)
234 END IF
235 IF (PRESENT(lregrid)) THEN
236 lregrid=interpolate
237 END IF
238!
239! Check if the following attributes: "scale_factor", "add_offset", and
240! "_FillValue" are present in the input NetCDF variable:
241!
242! If the "scale_value" attribute is present, the data is multiplied by
243! this factor after reading.
244! If the "add_offset" attribute is present, this value is added to the
245! data after reading.
246! If both "scale_factor" and "add_offset" attributes are present, the
247! data are first scaled before the offset is added.
248! If the "_FillValue" attribute is present, the data having this value
249! is treated as missing and it is replaced with zero. This feature it
250! is usually related with the land/sea masking.
251!
252 attname(1)='scale_factor'
253 attname(2)='add_offset '
254 attname(3)='_FillValue '
255
256 CALL netcdf_get_fatt (ng, model, ncname, ncvarid, attname, &
257 & attvalue, foundit, &
258 & ncid = ncid)
259 IF (founderror(exit_flag, noerror, __line__, myfile)) THEN
260 status=ioerror
261 RETURN
262 END IF
263
264 IF (.not.foundit(1)) THEN
265 afactor=1.0_r8
266 ELSE
267 afactor=attvalue(1)
268 END IF
269
270 IF (.not.foundit(2)) THEN
271 aoffset=0.0_r8
272 ELSE
273 aoffset=attvalue(2)
274 END IF
275
276 IF (.not.foundit(3)) THEN
277 aspval=spval_check
278 ELSE
279 aspval=attvalue(3)
280 END IF
281!
282! Initialize checsum value.
283!
284 IF (PRESENT(checksum)) THEN
285 lchecksum=.true.
286 checksum=0_i8b
287 ELSE
288 lchecksum=.false.
289 END IF
290!
291!-----------------------------------------------------------------------
292! Parallel I/O: Read in tile data from requested field and scale it.
293! Processing both water and land points.
294!-----------------------------------------------------------------------
295!
296 IF (gtype.gt.0) THEN
297!
298! Set offsets due the NetCDF dimensions. Recall that some output
299! variables not always start at one.
300!
301 SELECT CASE (abs(mytype))
302 CASE (p2dvar, p3dvar)
303 ioff=0
304 joff=0
305 CASE (r2dvar, r3dvar)
306 ioff=1
307 joff=1
308 CASE (u2dvar, u3dvar)
309 ioff=0
310 joff=1
311 CASE (v2dvar, v3dvar)
312 ioff=1
313 joff=0
314 CASE DEFAULT
315 ioff=1
316 joff=1
317 END SELECT
318
319 npts=ilen*jlen
320!
321! Allocate scratch work arrays.
322!
323 IF (interpolate) THEN
324 IF (.not.allocated(awrk)) THEN
325 allocate ( awrk(ilen,jlen) )
326 awrk=inival
327 END IF
328 IF (.not.allocated(wrk)) THEN
329 allocate ( wrk(npts) )
330 wrk=inival
331 END IF
332 ELSE
333 IF (.not.allocated(wrk)) THEN
334 allocate ( wrk(tilesize(ng)) )
335 wrk=0.0_r8
336 END IF
337 END IF
338!
339! Read in data: all parallel nodes read their own tile data.
340!
341 IF (interpolate) THEN
342 CALL tile_bounds_2d (ng, myrank, ilen, jlen, itile, jtile, &
343 & istr, iend, jstr, jend)
344 start(1)=istr
345 total(1)=iend-istr+1
346 start(2)=jstr
347 total(2)=jend-jstr+1
348 ELSE
349 start(1)=imin+ioff
350 total(1)=ilen
351 start(2)=jmin+joff
352 total(2)=jlen
353 END IF
354 mynpts=total(1)*total(2)
355 start(3)=tindex
356 total(3)=1
357
358 status=nf90_get_var(ncid, ncvarid, wrk, start, total)
359!
360! Scale read data and process fill values, if any. Compute minimum
361! and maximum values.
362!
363 IF (status.eq.nf90_noerr) THEN
364 amin=spval
365 amax=-spval
366 DO i=1,mynpts
367 IF (abs(wrk(i)).ge.abs(aspval)) THEN
368 wrk(i)=0.0_r8 ! masked with _FillValue
369 ELSE
370 wrk(i)=ascl*(afactor*wrk(i)+aoffset)
371 amin=min(amin,wrk(i))
372 amax=max(amax,wrk(i))
373 END IF
374 END DO
375 IF ((abs(amin).ge.abs(aspval)).and. &
376 & (abs(amax).ge.abs(aspval))) THEN
377 amin=0.0_r8 ! the entire data is all
378 amax=0.0_r8 ! field value, _FillValue
379 END IF
380!
381! Set minimum and maximum values: global reduction.
382!
383 rbuffer(1)=amin
384 op_handle(1)='MIN'
385 rbuffer(2)=amax
386 op_handle(2)='MAX'
387 CALL mp_reduce (ng, model, 2, rbuffer, op_handle)
388 amin=rbuffer(1)
389 amax=rbuffer(2)
390!
391! Unpack read data. If not interpolating, the data is loaded into
392! model array.
393!
394 IF (interpolate) THEN
395 CALL mp_collect (ng, model, npts, inival, wrk)
396 ic=0
397 DO j=jstr,jend
398 DO i=istr,iend
399 ic=ic+1
400 awrk(i,j)=wrk(ic)
401 END DO
402 END DO
403 ELSE
404 ic=0
405 DO j=jmin,jmax
406 DO i=imin,imax
407 ic=ic+1
408 adat(i,j)=wrk(ic)
409 END DO
410 END DO
411 END IF
412 ELSE
413 exit_flag=2
414 ioerror=status
415 END IF
416 END IF
417
418# if defined MASKING && defined READ_WATER
419!
420!-----------------------------------------------------------------------
421! Parallel I/O: Read in tile data from requested field and scale it.
422! Processing water points only. Interpolation is not
423! allowed.
424!-----------------------------------------------------------------------
425!
426 IF (gtype.lt.0) THEN
427!
428! Set number of points to process, grid type switch, and offsets due
429! array packing into 1D array in column-major order.
430!
431 SELECT CASE (abs(mytype))
432 CASE (p2dvar)
433 npts=iobounds(ng)%xy_psi
434 wtype=p2dvar
435 ioff=0
436 joff=1
437 CASE (r2dvar)
438 npts=iobounds(ng)%xy_rho
439 wtype=r2dvar
440 ioff=1
441 joff=0
442 CASE (u2dvar)
443 npts=iobounds(ng)%xy_u
444 wtype=u2dvar
445 ioff=0
446 joff=0
447 CASE (v2dvar)
448 npts=iobounds(ng)%xy_v
449 wtype=v2dvar
450 ioff=1
451 joff=1
452 CASE DEFAULT
453 npts=iobounds(ng)%xy_rho
454 wtype=r2dvar
455 ioff=1
456 joff=0
457 END SELECT
458 ijsize=isize*jsize
459!
460! Allocate scratch work arrays.
461!
462 IF (.not.allocated(a2d)) THEN
463 allocate ( a2d(ijsize) )
464 a2d=inival
465 END IF
466 IF (.not.allocated(wrk)) THEN
467 allocate ( wrk(npts) )
468 wrk=inival
469 END IF
470!
471! Read in data: all parallel nodes read a segment of the 1D data.
472! Recall that water points are pack in the NetCDF file in a single
473! dimension.
474!
475 CALL tile_bounds_1d (ng, myrank, npts, istr, iend)
476
477 start(1)=istr
478 total(1)=iend-istr+1
479 start(2)=1
480 total(2)=tindex
481
482 status=nf90_get_var(ncid, ncvarid, wrk(istr:), start, total)
483!
484! Global reduction of work array. We need this because the packing
485! of the water point only affects the model tile partition.
486!
487 IF (status.eq.nf90_noerr) THEN
488 CALL mp_collect (ng, model, npts, inival, wrk)
489!
490! Scale read data and process fill values, if any. Compute minimum
491! and maximum values.
492!
493 amin=spval
494 amax=-spval
495 DO i=1,npts
496 IF (abs(wrk(i)).ge.abs(aspval)) THEN
497 wrk(i)=0.0_r8 ! masked with _FillValue
498 ELSE
499 wrk(i)=ascl*(afactor*wrk(i)+aoffset)
500 amin=min(amin,wrk(i))
501 amax=max(amax,wrk(i))
502 END IF
503 END DO
504 IF ((abs(amin).ge.abs(aspval)).and. &
505 & (abs(amax).ge.abs(aspval))) THEN
506 amin=0.0_r8 ! the entire data is all
507 amax=0.0_r8 ! field value, _FillValue
508 END IF
509!
510! Unpack read data. This is tricky in parallel I/O. The cheapeast
511! thing to do is reconstruct a packed global array and then select
512! the appropriate values for the tile.
513!
514 DO np=1,npts
515 ij=scalars(ng)%IJwater(np,wtype)
516 a2d(ij)=wrk(np)
517 END DO
518
519 DO j=jmin,jmax
520 jc=(j-joff)*isize
521 DO i=imin,imax
522 ij=i+ioff+jc
523 adat(i,j)=a2d(ij)
524 END DO
525 END DO
526 ELSE
527 exit_flag=2
528 ioerror=status
529 END IF
530 END IF
531# endif
532!
533!-----------------------------------------------------------------------
534! Parallel I/O: If interpolating from gridded data, read its associated
535! locations and interpolate.
536!-----------------------------------------------------------------------
537!
538 IF (interpolate.and.(status.eq.nf90_noerr)) THEN
539 SELECT CASE (abs(mytype))
540 CASE (p2dvar, p3dvar)
541 IF (spherical) THEN
542 CALL regrid_nf90 (ng, model, ncname, ncid, &
543 & ncvname, ncvarid, mytype, interpflag, &
544 & ilen, jlen, awrk, amin, amax, &
545 & lbi, ubi, lbj, ubj, &
546 & imin, imax, jmin, jmax, &
547# ifdef MASKING
548 & grid(ng) % pmask, &
549# endif
550 & grid(ng) % MyLon, &
551 & grid(ng) % lonp, &
552 & grid(ng) % latp, &
553 & adat)
554 ELSE
555 CALL regrid_nf90 (ng, model, ncname, ncid, &
556 & ncvname, ncvarid, mytype, interpflag, &
557 & ilen, jlen, awrk, amin, amax, &
558 & lbi, ubi, lbj, ubj, &
559 & imin, imax, jmin, jmax, &
560# ifdef MASKING
561 & grid(ng) % pmask, &
562# endif
563 & grid(ng) % MyLon, &
564 & grid(ng) % xp, &
565 & grid(ng) % yp, &
566 & adat)
567 END IF
568 CASE (r2dvar, r3dvar)
569 IF (spherical) THEN
570 CALL regrid_nf90 (ng, model, ncname, ncid, &
571 & ncvname, ncvarid, mytype, interpflag, &
572 & ilen, jlen, awrk, amin, amax, &
573 & lbi, ubi, lbj, ubj, &
574 & imin, imax, jmin, jmax, &
575# ifdef MASKING
576 & grid(ng) % rmask, &
577# endif
578 & grid(ng) % MyLon, &
579 & grid(ng) % lonr, &
580 & grid(ng) % latr, &
581 & adat)
582 ELSE
583 CALL regrid_nf90 (ng, model, ncname, ncid, &
584 & ncvname, ncvarid, mytype, interpflag, &
585 & ilen, jlen, awrk, amin, amax, &
586 & lbi, ubi, lbj, ubj, &
587 & imin, imax, jmin, jmax, &
588# ifdef MASKING
589 & grid(ng) % rmask, &
590# endif
591 & grid(ng) % MyLon, &
592 & grid(ng) % xr, &
593 & grid(ng) % yr, &
594 & adat)
595 END IF
596 CASE (u2dvar, u3dvar)
597 IF (spherical) THEN
598 CALL regrid_nf90 (ng, model, ncname, ncid, &
599 & ncvname, ncvarid, mytype, interpflag, &
600 & ilen, jlen, awrk, amin, amax, &
601 & lbi, ubi, lbj, ubj, &
602 & imin, imax, jmin, jmax, &
603# ifdef MASKING
604 & grid(ng) % umask, &
605# endif
606 & grid(ng) % MyLon, &
607 & grid(ng) % lonu, &
608 & grid(ng) % latu, &
609 & adat)
610 ELSE
611 CALL regrid_nf90 (ng, model, ncname, ncid, &
612 & ncvname, ncvarid, mytype, interpflag, &
613 & ilen, jlen, awrk, amin, amax, &
614 & lbi, ubi, lbj, ubj, &
615 & imin, imax, jmin, jmax, &
616# ifdef MASKING
617 & grid(ng) % umask, &
618# endif
619 & grid(ng) % MyLon, &
620 & grid(ng) % xu, &
621 & grid(ng) % yu, &
622 & adat)
623 END IF
624 CASE (v2dvar, v3dvar)
625 IF (spherical) THEN
626 CALL regrid_nf90 (ng, model, ncname, ncid, &
627 & ncvname, ncvarid, mytype, interpflag, &
628 & ilen, jlen, awrk, amin, amax, &
629 & lbi, ubi, lbj, ubj, &
630 & imin, imax, jmin, jmax, &
631# ifdef MASKING
632 & grid(ng) % vmask, &
633# endif
634 & grid(ng) % MyLon, &
635 & grid(ng) % lonv, &
636 & grid(ng) % latv, &
637 & adat)
638 ELSE
639 CALL regrid_nf90 (ng, model, ncname, ncid, &
640 & ncvname, ncvarid, mytype, interpflag, &
641 & ilen, jlen, awrk, amin, amax, &
642 & lbi, ubi, lbj, ubj, &
643 & imin, imax, jmin, jmax, &
644# ifdef MASKING
645 & grid(ng) % vmask, &
646# endif
647 & grid(ng) % MyLon, &
648 & grid(ng) % xv, &
649 & grid(ng) % yv, &
650 & adat)
651 END IF
652 CASE DEFAULT
653 IF (spherical) THEN
654 CALL regrid_nf90 (ng, model, ncname, ncid, &
655 & ncvname, ncvarid, mytype, interpflag, &
656 & ilen, jlen, awrk, amin, amax, &
657 & lbi, ubi, lbj, ubj, &
658 & imin, imax, jmin, jmax, &
659# ifdef MASKING
660 & grid(ng) % rmask, &
661# endif
662 & grid(ng) % MyLon, &
663 & grid(ng) % lonr, &
664 & grid(ng) % latr, &
665 & adat)
666 ELSE
667 CALL regrid_nf90 (ng, model, ncname, ncid, &
668 & ncvname, ncvarid, mytype, interpflag, &
669 & ilen, jlen, awrk, amin, amax, &
670 & lbi, ubi, lbj, ubj, &
671 & imin, imax, jmin, jmax, &
672# ifdef MASKING
673 & grid(ng) % rmask, &
674# endif
675 & grid(ng) % MyLon, &
676 & grid(ng) % xr, &
677 & grid(ng) % yr, &
678 & adat)
679 END IF
680 END SELECT
681 END IF
682!
683!-----------------------------------------------------------------------
684! Deallocate scratch work arrays.
685!-----------------------------------------------------------------------
686!
687 IF (interpolate) THEN
688 IF (allocated(awrk)) THEN
689 deallocate ( awrk )
690 END IF
691 END IF
692
693# if defined MASKING && defined READ_WATER
694 IF (allocated(a2d)) THEN
695 deallocate (a2d)
696 END IF
697# endif
698
699 IF (allocated(wrk)) THEN
700 deallocate (wrk)
701 END IF
702!
703 RETURN
distribute_mod::mp_bcasti
Definition distribute.F:95
distribute_mod::mp_collect
Definition distribute.F:108
distribute_mod::mp_reduce
Definition distribute.F:113
mod_netcdf::netcdf_get_fatt
Definition mod_netcdf.F:38
distribute_mod
Definition distribute.F:3
get_bounds_mod
Definition get_bounds.F:2
get_bounds_mod::tile_bounds_2d
subroutine, public tile_bounds_2d(ng, tile, imax, jmax, itile, jtile, istr, iend, jstr, jend)
Definition get_bounds.F:974
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
regrid_mod
Definition regrid.F:2
regrid_mod::regrid_nf90
subroutine, public regrid_nf90(ng, model, ncname, ncid, ncvname, ncvarid, gtype, iflag, nx, ny, finp, amin, amax, lbi, ubi, lbj, ubj, imin, imax, jmin, jmax, mymask, myxout, xout, yout, fout)
Definition regrid.F:107

◆ pio_fread2d()

integer function nf_fread2d_mod::pio_fread2d ( integer, intent(in) ng,
integer, intent(in) model,
character (len=*), intent(in) ncname,
type (file_desc_t), intent(inout) piofile,
character (len=*), intent(in) ncvname,
type (my_vardesc), intent(inout) piovar,
integer, intent(in) tindex,
type (io_desc_t), intent(inout) piodesc,
integer, dimension(4), intent(in) vsize,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
real(dp), intent(in) ascl,
real(r8), intent(out) amin,
real(r8), intent(out) amax,
real(r8), dimension(lbi:,lbj:), intent(in) amask,
real(r8), dimension(lbi:,lbj:), intent(out) adat,
integer(i8b), intent(out), optional checksum,
logical, intent(out), optional lregrid )

Definition at line 1260 of file nf_fread2d.F.

1271!***********************************************************************
1272!
1273 USE mod_pio_netcdf
1274!
1275 USE distribute_mod, ONLY : mp_reduce
1276 USE regrid_mod, ONLY : regrid_pio
1277!
1278! Imported variable declarations.
1279!
1280 logical, intent(out), optional :: Lregrid
1281!
1282 integer, intent(in) :: ng, model, tindex
1283 integer, intent(in) :: LBi, UBi, LBj, UBj
1284 integer, intent(in) :: Vsize(4)
1285!
1286 integer(i8b), intent(out), optional :: checksum
1287!
1288 real(dp), intent(in) :: Ascl
1289 real(r8), intent(out) :: Amin
1290 real(r8), intent(out) :: Amax
1291!
1292 character (len=*), intent(in) :: ncname
1293 character (len=*), intent(in) :: ncvname
1294!
1295# ifdef ASSUMED_SHAPE
1296# ifdef MASKING
1297 real(r8), intent(in) :: Amask(LBi:,LBj:)
1298# endif
1299 real(r8), intent(out) :: Adat(LBi:,LBj:)
1300# else
1301# ifdef MASKING
1302 real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
1303# endif
1304 real(r8), intent(out) :: Adat(LBi:UBi,LBj:UBj)
1305# endif
1306!
1307 TYPE (File_desc_t), intent(inout) :: pioFile
1308 TYPE (IO_Desc_t), intent(inout) :: pioDesc
1309 TYPE (My_VarDesc), intent(inout) :: pioVar
1310!
1311! Local variable declarations.
1312!
1313 logical :: Lchecksum, interpolate
1314
1315 logical, dimension(3) :: foundit
1316!
1317 integer :: i, j, Npts, status
1318 integer :: Is, Ie, Js, Je ! global bounds
1319 integer :: Imin, Imax, Jmin, Jmax ! tile bounds
1320 integer :: Ilen, Jlen, IJlen
1321 integer :: Cgrid, ghost, dkind, gtype
1322
1323 integer, dimension(3) :: start, total
1324!
1325 real(r8) :: Afactor, Aoffset, Aspval, Avalue
1326 real(r8) :: my_Amin, my_Amax
1327
1328 real(r8), dimension(3) :: AttValue
1329 real(r8), dimension(2) :: rbuffer
1330!
1331 real(r4), pointer :: Awrk4(:,:) ! single precision
1332 real(r8), pointer :: Awrk8(:,:) ! double precision
1333 real(r8), allocatable :: Cwrk(:) ! used for checksum
1334 real(r8), allocatable :: wrk(:,:) ! interpolating, regrid
1335!
1336 character (len=12), dimension(3) :: AttName
1337 character (len= 3), dimension(2) :: op_handle
1338
1339 character (len=*), parameter :: MyFile = &
1340 & __FILE__//", pio_fread2d"
1341!
1342!-----------------------------------------------------------------------
1343! Set starting and ending indices to process.
1344!-----------------------------------------------------------------------
1345!
1346 status=pio_noerr
1347 amin=spval
1348 amax=-spval
1349 my_amin=spval
1350 my_amax=-spval
1351!
1352! Set global (interior plus boundary) starting and ending grid cell
1353! indices in the I- and J-directions according to staggered C-grid
1354! classification.
1355!
1356 dkind=piovar%dkind
1357 gtype=piovar%gtype
1358!
1359 SELECT CASE (abs(gtype))
1360 CASE (p2dvar, p3dvar)
1361 cgrid=1 ! PSI-points
1362 is=iobounds(ng)%ILB_psi
1363 ie=iobounds(ng)%IUB_psi
1364 js=iobounds(ng)%JLB_psi
1365 je=iobounds(ng)%JUB_psi
1366 CASE (r2dvar, r3dvar)
1367 cgrid=2 ! RHO-points
1368 is=iobounds(ng)%ILB_rho
1369 ie=iobounds(ng)%IUB_rho
1370 js=iobounds(ng)%JLB_rho
1371 je=iobounds(ng)%JUB_rho
1372 CASE (u2dvar, u3dvar)
1373 cgrid=3 ! U-points
1374 is=iobounds(ng)%ILB_u
1375 ie=iobounds(ng)%IUB_u
1376 js=iobounds(ng)%JLB_u
1377 je=iobounds(ng)%JUB_u
1378 CASE (v2dvar, v3dvar)
1379 cgrid=4 ! V-points
1380 is=iobounds(ng)%ILB_v
1381 ie=iobounds(ng)%IUB_v
1382 js=iobounds(ng)%JLB_v
1383 je=iobounds(ng)%JUB_v
1384 CASE DEFAULT
1385 cgrid=2 ! RHO-points
1386 is=iobounds(ng)%ILB_rho
1387 ie=iobounds(ng)%IUB_rho
1388 js=iobounds(ng)%JLB_rho
1389 je=iobounds(ng)%JUB_rho
1390 END SELECT
1391!
1392! Compute the global lengths of the I- and J-directions. They are
1393! needed to check if regridding is required.
1394!
1395 ilen=ie-is+1
1396 jlen=je-js+1
1397!
1398! Set the tile computational I- and J-bounds (no ghost points).
1399!
1400 ghost=0
1401 imin=bounds(ng)%Imin(cgrid,ghost,myrank)
1402 imax=bounds(ng)%Imax(cgrid,ghost,myrank)
1403 jmin=bounds(ng)%Jmin(cgrid,ghost,myrank)
1404 jmax=bounds(ng)%Jmax(cgrid,ghost,myrank)
1405!
1406! Determine if interpolating from coarse gridded data to model grid
1407! is required. This is only allowed for gridded 2D fields. This is
1408! convenient for atmospheric forcing datasets that are usually on
1409! coarser grids. The user can provide coarser gridded data to avoid
1410! very large input files.
1411!
1412 interpolate=.false.
1413 IF (((vsize(1).gt.0).and.(vsize(1).ne.ilen)).or. &
1414 & ((vsize(2).gt.0).and.(vsize(2).ne.jlen))) THEN
1415 interpolate=.true.
1416 ilen=vsize(1) ! data and state variable are incongruent
1417 jlen=vsize(2) ! horizontal interpolation is required
1418 END IF
1419 IF (PRESENT(lregrid)) THEN
1420 lregrid=interpolate
1421 END IF
1422 ijlen=ilen*jlen
1423!
1424! Check if the following attributes: "scale_factor", "add_offset", and
1425! "_FillValue" are present in the input NetCDF variable:
1426!
1427! If the "scale_value" attribute is present, the data is multiplied by
1428! this factor after reading.
1429! If the "add_offset" attribute is present, this value is added to the
1430! data after reading.
1431! If both "scale_factor" and "add_offset" attributes are present, the
1432! data are first scaled before the offset is added.
1433! If the "_FillValue" attribute is present, the data having this value
1434! is treated as missing and it is replaced with zero. This feature it
1435! is usually related with the land/sea masking.
1436!
1437 attname(1)='scale_factor'
1438 attname(2)='add_offset '
1439 attname(3)='_FillValue '
1440
1441 CALL pio_netcdf_get_fatt (ng, model, ncname, piovar%vd, attname, &
1442 & attvalue, foundit, &
1443 & piofile = piofile)
1444 IF (founderror(exit_flag, noerror, __line__, myfile)) THEN
1445 status=ioerror
1446 RETURN
1447 END IF
1448
1449 IF (.not.foundit(1)) THEN
1450 afactor=1.0_r8
1451 ELSE
1452 afactor=attvalue(1)
1453 END IF
1454
1455 IF (.not.foundit(2)) THEN
1456 aoffset=0.0_r8
1457 ELSE
1458 aoffset=attvalue(2)
1459 END IF
1460
1461 IF (.not.foundit(3)) THEN
1462 aspval=spval_check
1463 ELSE
1464 aspval=attvalue(3)
1465 END IF
1466!
1467!-----------------------------------------------------------------------
1468! If interpolting, read in input data with the non-tiled PIO interface.
1469!-----------------------------------------------------------------------
1470!
1471 IF (interpolate) THEN
1472 IF (.not.allocated(wrk)) THEN
1473 allocate ( wrk(ilen,jlen) )
1474 END IF
1475 wrk=0.0_r8
1476!
1477 start(1)=1
1478 total(1)=ilen
1479 start(2)=1
1480 total(2)=jlen
1481 start(3)=tindex
1482 total(3)=1
1483!
1484! The generic routine "pio_netcdf_get_fvar" checks if the attributes
1485! "scale_factor", "add_offset", and "_FillValue" are present in the
1486! input NetCDF variable and it applies its operators.
1487!
1488 CALL pio_netcdf_get_fvar (ng, model, ncname, &
1489 & ncvname, wrk, &
1490 & piofile = piofile, &
1491 & start = start, &
1492 & total = total, &
1493 & broadcast = .false., &
1494 & min_val = amin, &
1495 & max_val = amax)
1496!
1497! Multipy by user metadata scale.
1498!
1499 DO j=1,jlen
1500 DO i=1,ilen
1501 wrk(i,j)=ascl*wrk(i,j)
1502 END DO
1503 END DO
1504 END IF
1505!
1506! Initialize checsum value.
1507!
1508 IF (PRESENT(checksum)) THEN
1509 lchecksum=.true.
1510 checksum=0_i8b
1511 ELSE
1512 lchecksum=.false.
1513 END IF
1514!
1515!-----------------------------------------------------------------------
1516! If not interpolated, read in requested tiled field and scale it.
1517!-----------------------------------------------------------------------
1518!
1519 IF (.not.interpolate) THEN
1520!
1521! Allocate and initialize local array used for reading. The local array
1522! needs to be of the same precision as "A" and its IO decomposition
1523! descriptor "pioDesc".
1524!
1525 IF (dkind.eq.pio_double) THEN ! double precision
1526 IF (.not.associated(awrk8)) THEN
1527 allocate ( awrk8(imin:imax, jmin:jmax) )
1528 END IF
1529 awrk8=0.0_r8
1530 ELSE ! single precision
1531 IF (.not.associated(awrk4)) THEN
1532 allocate ( awrk4(imin:imax, jmin:jmax) )
1533 END IF
1534 awrk4=0.0_r4
1535 END IF
1536!
1537! Set unlimited time dimension record to write, if any.
1538!
1539 IF (tindex.gt.0) THEN
1540 CALL pio_setframe (piofile, &
1541 & piovar%vd, &
1542 & int(tindex, kind=pio_offset_kind))
1543 END IF
1544!
1545! Read in and load double precision data from NetCDF file.
1546!
1547 IF (dkind.eq.pio_double) THEN
1548 CALL pio_read_darray (piofile, &
1549 & piovar%vd, &
1550 & piodesc, &
1551 & awrk8(imin:,jmin:), &
1552 & status)
1553!
1554 DO j=jmin,jmax
1555 DO i=imin,imax
1556 IF (abs(awrk8(i,j)).ge.abs(aspval)) THEN
1557 adat(i,j)=0.0_r8 ! masked with _FillValue
1558 ELSE
1559 avalue=ascl*(afactor*awrk8(i,j)+aoffset)
1560 adat(i,j)=avalue
1561 my_amin=min(my_amin,avalue)
1562 my_amax=max(my_amax,avalue)
1563 END IF
1564 END DO
1565 END DO
1566 IF (associated(awrk8)) deallocate (awrk8)
1567!
1568! Read in and load single precision data from NetCDF file.
1569!
1570 ELSE
1571 CALL pio_read_darray (piofile, &
1572 & piovar%vd, &
1573 & piodesc, &
1574 & awrk4(imin:,jmin:), &
1575 & status)
1576!
1577 DO j=jmin,jmax
1578 DO i=imin,imax
1579 IF (abs(awrk4(i,j)).ge.abs(real(aspval,r4))) THEN
1580 adat(i,j)=0.0_r8 ! masked with _FillValue
1581 ELSE
1582 avalue=real(ascl*(afactor*awrk4(i,j)+aoffset),r8)
1583 adat(i,j)=avalue
1584 my_amin=real(min(my_amin,avalue),r8)
1585 my_amax=real(max(my_amax,avalue),r8)
1586 END IF
1587 END DO
1588 END DO
1589 IF (associated(awrk4)) deallocate (awrk4)
1590 END IF
1591!
1592! Compute global minimum and maximum values.
1593!
1594 rbuffer(1)=my_amin
1595 rbuffer(2)=my_amax
1596 op_handle(1)='MIN'
1597 op_handle(2)='MAX'
1598 CALL mp_reduce (ng, model, 2, rbuffer, op_handle)
1599 amin=rbuffer(1)
1600 amax=rbuffer(2)
1601!
1602 IF ((abs(amin).ge.abs(spval)).and. &
1603 & (abs(amax).ge.abs(spval))) THEN
1604 amin=0.0_r8 ! the entire data is all
1605 amax=0.0_r8 ! field value, _FillValue
1606 END IF ! and was zeroth out
1607 END IF
1608!
1609!-----------------------------------------------------------------------
1610! If interpolating from gridded data, read its associated locations
1611! and interpolate.
1612!-----------------------------------------------------------------------
1613!
1614 IF (interpolate) THEN
1615 SELECT CASE (gtype)
1616 CASE (p2dvar, p3dvar)
1617 IF (spherical) THEN
1618 CALL regrid_pio (ng, model, ncname, piofile, &
1619 & ncvname, piovar, gtype, interpflag, &
1620 & ilen, jlen, wrk, amin, amax, &
1621 & lbi, ubi, lbj, ubj, &
1622 & imin, imax, jmin, jmax, &
1623# ifdef MASKING
1624 & amask, &
1625# endif
1626 & grid(ng) % MyLon, &
1627 & grid(ng) % lonp, &
1628 & grid(ng) % latp, &
1629 & adat)
1630 ELSE
1631 CALL regrid_pio (ng, model, ncname, piofile, &
1632 & ncvname, piovar, gtype, interpflag, &
1633 & ilen, jlen, wrk, amin, amax, &
1634 & lbi, ubi, lbj, ubj, &
1635 & imin, imax, jmin, jmax, &
1636# ifdef MASKING
1637 & amask, &
1638# endif
1639 & grid(ng) % MyLon, &
1640 & grid(ng) % xp, &
1641 & grid(ng) % yp, &
1642 & adat)
1643 END IF
1644 CASE (r2dvar, r3dvar)
1645 IF (spherical) THEN
1646 CALL regrid_pio (ng, model, ncname, piofile, &
1647 & ncvname, piovar, gtype, interpflag, &
1648 & ilen, jlen, wrk, amin, amax, &
1649 & lbi, ubi, lbj, ubj, &
1650 & imin, imax, jmin, jmax, &
1651# ifdef MASKING
1652 & grid(ng) % rmask, &
1653# endif
1654 & grid(ng) % MyLon, &
1655 & grid(ng) % lonr, &
1656 & grid(ng) % latr, &
1657 & adat)
1658 ELSE
1659 CALL regrid_pio (ng, model, ncname, piofile, &
1660 & ncvname, piovar, gtype, interpflag, &
1661 & ilen, jlen, wrk, amin, amax, &
1662 & lbi, ubi, lbj, ubj, &
1663 & imin, imax, jmin, jmax, &
1664# ifdef MASKING
1665 & grid(ng) % rmask, &
1666# endif
1667 & grid(ng) % MyLon, &
1668 & grid(ng) % xr, &
1669 & grid(ng) % yr, &
1670 & adat)
1671 END IF
1672 CASE (u2dvar, u3dvar)
1673 IF (spherical) THEN
1674 CALL regrid_pio (ng, model, ncname, piofile, &
1675 & ncvname, piovar, gtype, interpflag, &
1676 & ilen, jlen, wrk, amin, amax, &
1677 & lbi, ubi, lbj, ubj, &
1678 & imin, imax, jmin, jmax, &
1679# ifdef MASKING
1680 & grid(ng) % umask, &
1681# endif
1682 & grid(ng) % MyLon, &
1683 & grid(ng) % lonu, &
1684 & grid(ng) % latu, &
1685 & adat)
1686 ELSE
1687 CALL regrid_pio (ng, model, ncname, piofile, &
1688 & ncvname, piovar, gtype, interpflag, &
1689 & ilen, jlen, wrk, amin, amax, &
1690 & lbi, ubi, lbj, ubj, &
1691 & imin, imax, jmin, jmax, &
1692# ifdef MASKING
1693 & grid(ng) % umask, &
1694# endif
1695 & grid(ng) % MyLon, &
1696 & grid(ng) % xu, &
1697 & grid(ng) % yu, &
1698 & adat)
1699 END IF
1700 CASE (v2dvar, v3dvar)
1701 IF (spherical) THEN
1702 CALL regrid_pio (ng, model, ncname, piofile, &
1703 & ncvname, piovar, gtype, interpflag, &
1704 & ilen, jlen, wrk, amin, amax, &
1705 & lbi, ubi, lbj, ubj, &
1706 & imin, imax, jmin, jmax, &
1707# ifdef MASKING
1708 & grid(ng) % vmask, &
1709# endif
1710 & grid(ng) % MyLon, &
1711 & grid(ng) % lonv, &
1712 & grid(ng) % latv, &
1713 & adat)
1714 ELSE
1715 CALL regrid_pio (ng, model, ncname, piofile, &
1716 & ncvname, piovar, gtype, interpflag, &
1717 & ilen, jlen, wrk, amin, amax, &
1718 & lbi, ubi, lbj, ubj, &
1719 & imin, imax, jmin, jmax, &
1720# ifdef MASKING
1721 & grid(ng) % vmask, &
1722# endif
1723 & grid(ng) % MyLon, &
1724 & grid(ng) % xv, &
1725 & grid(ng) % yv, &
1726 & adat)
1727 END IF
1728 CASE DEFAULT
1729 IF (spherical) THEN
1730 CALL regrid_pio (ng, model, ncname, piofile, &
1731 & ncvname, piovar, gtype, interpflag, &
1732 & ilen, jlen, wrk, amin, amax, &
1733 & lbi, ubi, lbj, ubj, &
1734 & imin, imax, jmin, jmax, &
1735# ifdef MASKING
1736 & grid(ng) % rmask, &
1737# endif
1738 & grid(ng) % MyLon, &
1739 & grid(ng) % lonr, &
1740 & grid(ng) % latr, &
1741 & adat)
1742 ELSE
1743 CALL regrid_pio (ng, model, ncname, piofile, &
1744 & ncvname, piovar, gtype, interpflag, &
1745 & ilen, jlen, wrk, amin, amax, &
1746 & lbi, ubi, lbj, ubj, &
1747 & imin, imax, jmin, jmax, &
1748# ifdef MASKING
1749 & grid(ng) % rmask, &
1750# endif
1751 & grid(ng) % MyLon, &
1752 & grid(ng) % xr, &
1753 & grid(ng) % yr, &
1754 & adat)
1755 END IF
1756 END SELECT
1757!
1758! Deallocate regridding work array.
1759!
1760 IF (allocated(wrk)) THEN
1761 deallocate (wrk)
1762 END IF
1763 END IF
1764!
1765! If requested, compute input data checksum value.
1766!
1767 IF (lchecksum) THEN
1768 npts=(imax-imin+1)*(jmax-jmin+1)
1769 IF (.not.allocated(cwrk)) allocate ( cwrk(npts) )
1770 cwrk=pack(adat(imin:imax, jmin:jmax), .true.)
1771 CALL get_hash (cwrk, npts, checksum, .true.)
1772 IF (allocated(cwrk)) deallocate (cwrk)
1773 END IF
1774!
1775 RETURN
mod_pio_netcdf::pio_netcdf_get_fatt
Definition mod_pio_netcdf.F:45
mod_pio_netcdf::pio_netcdf_get_fvar
Definition mod_pio_netcdf.F:52
mod_pio_netcdf
Definition mod_pio_netcdf.F:2
regrid_mod::regrid_pio
subroutine, public regrid_pio(ng, model, ncname, piofile, ncvname, piovar, gtype, iflag, nx, ny, finp, amin, amax, lbi, ubi, lbj, ubj, imin, imax, jmin, jmax, mymask, myxout, xout, yout, fout)
Definition regrid.F:378