ROMS
Loading...
Searching...
No Matches
nf_fread4d.F
Go to the documentation of this file.
1#include "cppdefs.h"
3!
4!git $Id$
5!================================================== Hernan G. Arango ===
6! Copyright (c) 2002-2025 The ROMS Group !
7! Licensed under a MIT/X style license !
8! See License_ROMS.md !
9!=======================================================================
10! !
11! This function reads in a generic floating point 4D array from an !
12! input NetCDF file. !
13! !
14! On Input: !
15! !
16! ng Nested grid number (integer) !
17! model Calling model identifier (integer) !
18! ncname NetCDF file name (string) !
19! ncid NetCDF file ID (integer) !
20#if defined PIO_LIB && defined DISTRIBUTE
21!or pioFile PIO file descriptor structure, TYPE(file_desc_t) !
22! pioFile%fh file handler !
23! pioFile%iosystem IO system descriptor (struct) !
24#endif
25! ncvname NetCDF variable name (string) !
26! ncvarid NetCDF variable ID (integer) !
27#if defined PIO_LIB && defined DISTRIBUTE
28!or pioVar PIO variable descriptor structure, TYPE(My_VarDesc) !
29! pioVar%vd variable descriptor TYPE(Var_Desc_t) !
30! pioVar%dkind variable data kind !
31! pioVar%gtype variable C-gridtype !
32#endif
33! tindex NetCDF time record index to read (integer) !
34! gtype C-grid type (integer) !
35#if defined PIO_LIB && defined DISTRIBUTE
36!or pioDesc IO data decomposition descriptor, TYPE(IO_desc_t) !
37#endif
38! Vsize Variable dimensions in NetCDF file (integer 1D array) !
39! LBi I-dimension Lower bound (integer) !
40! UBi I-dimension Upper bound (integer) !
41! LBj J-dimension Lower bound (integer) !
42! UBj J-dimension Upper bound (integer) !
43! LBk K-dimension Lower bound (integer) !
44! UBk K-dimension Upper bound (integer) !
45! LBt Time-dimension Lower bound (integer) !
46! UBt Time-dimension Upper bound (integer) !
47! Ascl Factor to scale field after reading (real). !
48! Amask Land/Sea mask, if any (real 4D array) !
49! !
50! On Output: !
51! !
52! Amin Field minimum value (real) !
53! Amax Field maximum value (real) !
54! Adat Field to read in (real 4D array) !
55! checksum Field checksum value (32-bit integer; OPTIONAL) !
56! status Result error flag (integer) !
57! !
58!=======================================================================
59!
60 USE mod_param
61 USE mod_parallel
62 USE mod_iounits
63 USE mod_ncparam
64 USE mod_scalars
65!
66 USE get_hash_mod, ONLY : get_hash
67 USE strings_mod, ONLY : founderror
68!
69 implicit none
70!
71 INTERFACE nf_fread4d
72 MODULE PROCEDURE nf90_fread4d
73#if defined PIO_LIB && defined DISTRIBUTE
74 MODULE PROCEDURE pio_fread4d
75#endif
76 END INTERFACE nf_fread4d
77!
78 CONTAINS
79
80#if defined PARALLEL_IO && defined DISTRIBUTE
81!
82!***********************************************************************
83 FUNCTION nf90_fread4d (ng, model, ncname, ncid, &
84 & ncvname, ncvarid, &
85 & tindex, gtype, Vsize, &
86 & LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt, &
87 & Ascl, Amin, Amax, &
88# ifdef MASKING
89 & Amask, &
90# endif
91 & Adat, &
92 & checksum) RESULT (status)
93!***********************************************************************
94!
95 USE mod_netcdf
96!
98# if defined MASKING && defined READ_WATER
99 USE distribute_mod, ONLY : mp_collect
100# endif
102!
103! Imported variable declarations.
104!
105 integer, intent(in) :: ng, model, ncid, ncvarid, tindex, gtype
106 integer, intent(in) :: lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt
107 integer, intent(in) :: vsize(4)
108!
109 integer(i8b), intent(out), optional :: checksum
110!
111 real(dp), intent(in) :: ascl
112 real(r8), intent(out) :: amin
113 real(r8), intent(out) :: amax
114!
115 character (len=*), intent(in) :: ncname
116 character (len=*), intent(in) :: ncvname
117!
118# ifdef ASSUMED_SHAPE
119# ifdef MASKING
120 real(r8), intent(in) :: amask(lbi:,lbj:)
121# endif
122 real(r8), intent(out) :: adat(lbi:,lbj:,lbk:,lbt:)
123# else
124# ifdef MASKING
125 real(r8), intent(in) :: amask(lbi:ubi,lbj:ubj)
126# endif
127 real(r8), intent(out) :: adat(lbi:ubi,lbj:ubj,lbk:ubk,lbt:ubt)
128# endif
129!
130! Local variable declarations.
131!
132 logical :: lchecksum
133 logical, dimension(3) :: foundit
134!
135 integer :: i, ic, ij, j, jc, k, kc, l, lc, np, npts
136 integer :: imin, imax, isize, jmin, jmax, jsize, ijsize
137 integer :: istr, iend
138 integer :: ioff, joff, koff, loff
139 integer :: ilen, jlen, klen, llen, ijlen
140 integer :: cgrid, mytype, ghost, status, wtype
141
142 integer, dimension(5) :: 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# if defined MASKING && defined READ_WATER
152 real(r8), allocatable :: a2d(:)
153# endif
154 real(r8), allocatable :: wrk(:)
155!
156 character (len= 3), dimension(2) :: op_handle
157 character (len=12), dimension(3) :: attname
158
159 character (len=*), parameter :: myfile = &
160 & __FILE__//", nf90_fread4d"
161!
162!-----------------------------------------------------------------------
163! Set starting and ending indices to process.
164!-----------------------------------------------------------------------
165!
166 status=nf90_noerr
167!
168! Set first and last grid point according to staggered C-grid
169! classification. Set the offsets for variables with starting
170! zero-index. Recall the NetCDF does not support a zero-index.
171!
172! Notice that (Imin,Jmin) and (Imax,Jmax) are the corner of the
173! computational tile. If ghost=0, ghost points are not processed.
174! They will be processed elsewhere by the appropriate call to any
175! of the routines in "mp_exchange.F". If ghost=1, the ghost points
176! are read.
177!
178# ifdef NO_READ_GHOST
179 ghost=0 ! non-overlapping, no ghost points
180# else
181 IF (model.eq.iadm) THEN
182 ghost=0 ! non-overlapping, no ghost points
183 ELSE
184 ghost=1 ! overlapping, read ghost points
185 END IF
186# endif
187
188 mytype=gtype
189
190 SELECT CASE (abs(mytype))
191 CASE (p2dvar, p3dvar)
192 cgrid=1
193 isize=iobounds(ng)%xi_psi
194 jsize=iobounds(ng)%eta_psi
195 CASE (r2dvar, r3dvar, w3dvar)
196 cgrid=2
197 isize=iobounds(ng)%xi_rho
198 jsize=iobounds(ng)%eta_rho
199 CASE (u2dvar, u3dvar)
200 cgrid=3
201 isize=iobounds(ng)%xi_u
202 jsize=iobounds(ng)%eta_u
203 CASE (v2dvar, v3dvar)
204 cgrid=4
205 isize=iobounds(ng)%xi_v
206 jsize=iobounds(ng)%eta_v
207 CASE DEFAULT
208 cgrid=2
209 isize=iobounds(ng)%xi_rho
210 jsize=iobounds(ng)%eta_rho
211 END SELECT
212
213 imin=bounds(ng)%Imin(cgrid,ghost,myrank)
214 imax=bounds(ng)%Imax(cgrid,ghost,myrank)
215 jmin=bounds(ng)%Jmin(cgrid,ghost,myrank)
216 jmax=bounds(ng)%Jmax(cgrid,ghost,myrank)
217
218 ilen=imax-imin+1
219 jlen=jmax-jmin+1
220 klen=ubk-lbk+1
221 llen=ubt-lbt+1
222!
223! Check if the following attributes: "scale_factor", "add_offset", and
224! "_FillValue" are present in the input NetCDF variable:
225!
226! If the "scale_value" attribute is present, the data is multiplied by
227! this factor after reading.
228! If the "add_offset" attribute is present, this value is added to the
229! data after reading.
230! If both "scale_factor" and "add_offset" attributes are present, the
231! data are first scaled before the offset is added.
232! If the "_FillValue" attribute is present, the data having this value
233! is treated as missing and it is replaced with zero. This feature it
234! is usually related with the land/sea masking.
235!
236 attname(1)='scale_factor'
237 attname(2)='add_offset '
238 attname(3)='_FillValue '
239
240 CALL netcdf_get_fatt (ng, model, ncname, ncvarid, attname, &
241 & attvalue, foundit, &
242 & ncid = ncid)
243 IF (founderror(exit_flag, noerror, __line__, myfile)) THEN
244 status=ioerror
245 RETURN
246 END IF
247
248 IF (.not.foundit(1)) THEN
249 afactor=1.0_r8
250 ELSE
251 afactor=attvalue(1)
252 END IF
253
254 IF (.not.foundit(2)) THEN
255 aoffset=0.0_r8
256 ELSE
257 aoffset=attvalue(2)
258 END IF
259
260 IF (.not.foundit(3)) THEN
261 aspval=spval_check
262 ELSE
263 aspval=attvalue(3)
264 END IF
265!
266! Initialize checsum value.
267!
268 IF (PRESENT(checksum)) THEN
269 lchecksum=.true.
270 checksum=0_i8b
271 ELSE
272 lchecksum=.false.
273 END IF
274!
275!-----------------------------------------------------------------------
276! Parallel I/O: Read in tile data from requested field and scale it.
277! Processing both water and land points.
278!-----------------------------------------------------------------------
279!
280 IF (gtype.gt.0) THEN
281!
282! Set offsets due the NetCDF dimensions. Recall that some output
283! variables not always start at one.
284!
285 SELECT CASE (abs(mytype))
286 CASE (p2dvar, p3dvar)
287 ioff=0
288 joff=0
289 CASE (r2dvar, r3dvar, w3dvar)
290 ioff=1
291 joff=1
292 CASE (u2dvar, u3dvar)
293 ioff=0
294 joff=1
295 CASE (v2dvar, v3dvar)
296 ioff=1
297 joff=0
298 CASE DEFAULT
299 ioff=1
300 joff=1
301 END SELECT
302
303 IF (lbk.eq.0) THEN
304 koff=1
305 ELSE
306 koff=0
307 END IF
308
309 IF (lbt.eq.0) THEN
310 loff=1
311 ELSE
312 loff=0
313 END IF
314
315 npts=ilen*jlen*klen*llen
316!
317! Allocate scratch work array.
318!
319 IF (.not.allocated(wrk)) THEN
320 allocate ( wrk(npts) )
321 wrk=0.0_r8
322 END IF
323!
324! Read in data: all parallel nodes read their own tile data.
325!
326 start(1)=imin+ioff
327 total(1)=ilen
328 start(2)=jmin+joff
329 total(2)=jlen
330 start(3)=lbk+koff
331 total(3)=klen
332 start(4)=lbt+loff
333 total(4)=llen
334 start(5)=tindex
335 total(5)=1
336
337 status=nf90_get_var(ncid, ncvarid, wrk, start, total)
338!
339! Scale read data and process fill values, if any. Compute minimum
340! and maximum values.
341!
342 IF (status.eq.nf90_noerr) THEN
343 amin=spval
344 amax=-spval
345 DO i=1,npts
346 IF (abs(wrk(i)).ge.abs(aspval)) THEN
347 wrk(i)=0.0_r8 ! masked with _FillValue
348 ELSE
349 wrk(i)=ascl*(afactor*wrk(i)+aoffset)
350 amin=min(amin,wrk(i))
351 amax=max(amax,wrk(i))
352 END IF
353 END DO
354 IF ((abs(amin).ge.abs(aspval)).and. &
355 & (abs(amax).ge.abs(aspval))) THEN
356 amin=0.0_r8 ! the entire data is all
357 amax=0.0_r8 ! field value, _FillValue
358 END IF
359!
360! Set minimum and maximum values: global reduction.
361!
362 rbuffer(1)=amin
363 op_handle(1)='MIN'
364 rbuffer(2)=amax
365 op_handle(2)='MAX'
366 CALL mp_reduce (ng, model, 2, rbuffer, op_handle)
367 amin=rbuffer(1)
368 amax=rbuffer(2)
369!
370! Unpack read data.
371!
372 ic=0
373 DO l=lbt,ubt
374 DO k=lbk,ubk
375 DO j=jmin,jmax
376 DO i=imin,imax
377 ic=ic+1
378 adat(i,j,k,l)=wrk(ic)
379 END DO
380 END DO
381 END DO
382 END DO
383 ELSE
384 exit_flag=2
385 ioerror=status
386 END IF
387 END IF
388
389# if defined MASKING && defined READ_WATER
390!
391!-----------------------------------------------------------------------
392! Parallel I/O: Read in tile data from requested field and scale it.
393! Processing water points only.
394!-----------------------------------------------------------------------
395!
396 IF (gtype.lt.0) THEN
397!
398! Set number of points to process, grid type switch, and offsets due
399! array packing into 1D array in column-major order.
400!
401 SELECT CASE (abs(mytype))
402 CASE (p3dvar)
403 ijlen=iobounds(ng)%xy_psi
404 wtype=p2dvar
405 ioff=0
406 joff=1
407 CASE (r3dvar, w3dvar)
408 ijlen=iobounds(ng)%xy_rho
409 wtype=r2dvar
410 ioff=1
411 joff=0
412 CASE (u3dvar)
413 ijlen=iobounds(ng)%xy_u
414 wtype=u2dvar
415 ioff=0
416 joff=0
417 CASE (v3dvar)
418 ijlen=iobounds(ng)%xy_v
419 wtype=v2dvar
420 ioff=1
421 joff=1
422 CASE DEFAULT
423 ijlen=iobounds(ng)%xy_rho
424 wtype=r2dvar
425 ioff=1
426 joff=0
427 END SELECT
428
429 IF (lbk.eq.0) THEN
430 koff=0
431 ELSE
432 koff=1
433 END IF
434
435 IF (lbt.eq.0) THEN
436 loff=1
437 ELSE
438 loff=0
439 END IF
440
441 npts=ijlen*klen*llen
442 ijsize=isize*jsize
443!
444! Allocate scratch work arrays.
445!
446 IF (.not.allocated(a2d)) THEN
447 allocate ( a2d(ijsize) )
448 END IF
449 IF (.not.allocated(wrk)) THEN
450 allocate ( wrk(npts) )
451 wrk=inival
452 END IF
453!
454! Read in data: all parallel nodes read a segment of the 1D data.
455! Recall that water points are pack in the NetCDF file in a single
456! dimension.
457!
458 CALL tile_bounds_1d (ng, myrank, npts, istr, iend)
459
460 start(1)=istr
461 total(1)=iend-istr+1
462 start(2)=1
463 total(2)=tindex
464
465 status=nf90_get_var(ncid, ncvarid, wrk(istr:), start, total)
466!
467! Global reduction of work array. We need this because the packing
468! of the water point only affects the model tile partition.
469!
470 IF (status.eq.nf90_noerr) THEN
471 CALL mp_collect (ng, model, npts, inival, wrk)
472!
473! Scale read data and process fill values, if any. Compute minimum
474! and maximum values.
475!
476 amin=spval
477 amax=-spval
478 DO i=1,npts
479 IF (abs(wrk(i)).ge.abs(aspval)) THEN
480 wrk(i)=0.0_r8 ! set _FillValue to zero
481 ELSE
482 wrk(i)=ascl*(afactor*wrk(i)+aoffset)
483 amin=min(amin,wrk(i))
484 amax=max(amax,wrk(i))
485 END IF
486 END DO
487 IF ((abs(amin).ge.abs(aspval)).and. &
488 & (abs(amax).ge.abs(aspval))) THEN
489 amin=0.0_r8 ! the entire data is all
490 amax=0.0_r8 ! field value, _FillValue
491 END IF
492!
493! Unpack read data. This is tricky in parallel I/O. The cheapeast
494! thing to do is reconstruct a packed 2D global array and then select
495! the appropriate values for the tile.
496!
497 DO l=lbt,ubt
498 lc=(l-loff)*ijlen*klen
499 DO k=lbk,ubk
500 kc=(k-koff)*ijlen+lc
501 a2d=inival
502 DO np=1,ijlen
503 ij=scalars(ng)%IJwater(np,wtype)
504 a2d(ij)=wrk(np+kc)
505 END DO
506 DO j=jmin,jmax
507 jc=(j-joff)*isize
508 DO i=imin,imax
509 ij=i+ioff+jc
510 adat(i,j,k,l)=a2d(ij)
511 END DO
512 END DO
513 END DO
514 END DO
515 ELSE
516 exit_flag=2
517 ioerror=status
518 END IF
519 END IF
520# endif
521!
522!-----------------------------------------------------------------------
523! Deallocate scratch work vector.
524!-----------------------------------------------------------------------
525!
526# if defined MASKING && defined READ_WATER
527 IF (allocated(a2d)) THEN
528 deallocate (a2d)
529 END IF
530# endif
531
532 IF (allocated(wrk)) THEN
533 deallocate (wrk)
534 END IF
535!
536 RETURN
537 END FUNCTION nf90_fread4d
538
539#else
540
541!
542!***********************************************************************
543 FUNCTION nf90_fread4d (ng, model, ncname, ncid, &
544 & ncvname, ncvarid, &
545 & tindex, gtype, Vsize, &
546 & LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt, &
547 & Ascl, Amin, Amax, &
548# ifdef MASKING
549 & Amask, &
550# endif
551 & Adat, &
552 & checksum) RESULT (status)
553!***********************************************************************
554!
555 USE mod_netcdf
556!
557# ifdef DISTRIBUTE
558 USE distribute_mod, ONLY : mp_bcasti
559# ifdef INLINE_2DIO
560 USE distribute_mod, ONLY : mp_scatter2d
561# else
562 USE distribute_mod, ONLY : mp_scatter3d
563# endif
564# endif
565!
566! Imported variable declarations.
567!
568 integer, intent(in) :: ng, model, ncid, ncvarid, tindex, gtype
569 integer, intent(in) :: lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt
570 integer, intent(in) :: vsize(4)
571!
572 integer(i8b), intent(out), optional :: checksum
573!
574 real(dp), intent(in) :: ascl
575 real(r8), intent(out) :: amin
576 real(r8), intent(out) :: amax
577!
578 character (len=*), intent(in) :: ncname
579 character (len=*), intent(in) :: ncvname
580!
581# ifdef ASSUMED_SHAPE
582# ifdef MASKING
583 real(r8), intent(in) :: amask(lbi:,lbj:)
584# endif
585 real(r8), intent(out) :: adat(lbi:,lbj:,lbk:,lbt:)
586# else
587# ifdef MASKING
588 real(r8), intent(in) :: amask(lbi:ubi,lbj:ubj)
589# endif
590 real(r8), intent(out) :: adat(lbi:ubi,lbj:ubj,lbk:ubk,lbt:ubt)
591# endif
592!
593! Local variable declarations.
594!
595 logical :: lchecksum
596 logical, dimension(3) :: foundit
597!
598 integer :: i, j, k, ic, fourth, npts, nwpts, status, wtype
599 integer :: is, ie, js, je
600 integer :: imin, imax, jmin, jmax
601 integer :: ilen, jlen, klen, ijlen, koff, loff
602 integer :: cgrid, mytype, ghost
603# ifdef DISTRIBUTE
604 integer :: nghost
605# endif
606 integer, dimension(5) :: start, total
607!
608 real(r8) :: afactor, aoffset, aspval
609
610 real(r8), dimension(3) :: attvalue
611!
612 real(r8), allocatable :: cwrk(:) ! used for checksum
613
614# if defined INLINE_2DIO && defined DISTRIBUTE
615 real(r8), dimension(2+(Lm(ng)+2)*(Mm(ng)+2)) :: wrk
616# else
617 real(r8), dimension(2+(Lm(ng)+2)*(Mm(ng)+2)*(UBk-LBk+1)) :: wrk
618# endif
619!
620 character (len=12), dimension(3) :: attname
621
622 character (len=*), parameter :: myfile = &
623 & __FILE__//", nf90_fread4d"
624!
625!-----------------------------------------------------------------------
626! Set starting and ending indices to process.
627!-----------------------------------------------------------------------
628!
629 status=nf90_noerr
630 amin=spval
631 amax=-spval
632!
633! Set global (interior plus boundary) starting and ending grid cell
634! indices in the I- and J-directions according to staggered C-grid
635! classification.
636!
637 mytype=gtype
638
639 SELECT CASE (abs(mytype))
640 CASE (p2dvar, p3dvar)
641 cgrid=1 ! PSI-points
642 is=iobounds(ng)%ILB_psi
643 ie=iobounds(ng)%IUB_psi
644 js=iobounds(ng)%JLB_psi
645 je=iobounds(ng)%JUB_psi
646 CASE (r2dvar, r3dvar, w3dvar)
647 cgrid=2 ! RHO-points
648 is=iobounds(ng)%ILB_rho
649 ie=iobounds(ng)%IUB_rho
650 js=iobounds(ng)%JLB_rho
651 je=iobounds(ng)%JUB_rho
652 CASE (u2dvar, u3dvar)
653 cgrid=3 ! U-points
654 is=iobounds(ng)%ILB_u
655 ie=iobounds(ng)%IUB_u
656 js=iobounds(ng)%JLB_u
657 je=iobounds(ng)%JUB_u
658 CASE (v2dvar, v3dvar)
659 cgrid=4 ! V-points
660 is=iobounds(ng)%ILB_v
661 ie=iobounds(ng)%IUB_v
662 js=iobounds(ng)%JLB_v
663 je=iobounds(ng)%JUB_v
664 CASE DEFAULT
665 cgrid=2 ! RHO-points
666 is=iobounds(ng)%ILB_rho
667 ie=iobounds(ng)%IUB_rho
668 js=iobounds(ng)%JLB_rho
669 je=iobounds(ng)%JUB_rho
670 END SELECT
671
672 ilen=ie-is+1
673 jlen=je-js+1
674 klen=ubk-lbk+1
675 ijlen=ilen*jlen
676
677#ifdef INLINE_2DIO
678 IF (lbk.eq.0) THEN
679 koff=0
680 ELSE
681 koff=1
682 END IF
683#endif
684
685 IF (lbt.eq.0) THEN
686 loff=1
687 ELSE
688 loff=0
689 END IF
690!
691! Set the tile computational I- and J-bounds (no ghost points).
692!
693 ghost=0
694 imin=bounds(ng)%Imin(cgrid,ghost,myrank)
695 imax=bounds(ng)%Imax(cgrid,ghost,myrank)
696 jmin=bounds(ng)%Jmin(cgrid,ghost,myrank)
697 jmax=bounds(ng)%Jmax(cgrid,ghost,myrank)
698!
699! Check if the following attributes: "scale_factor", "add_offset", and
700! "_FillValue" are present in the input NetCDF variable:
701!
702! If the "scale_value" attribute is present, the data is multiplied by
703! this factor after reading.
704! If the "add_offset" attribute is present, this value is added to the
705! data after reading.
706! If both "scale_factor" and "add_offset" attributes are present, the
707! data are first scaled before the offset is added.
708! If the "_FillValue" attribute is present, the data having this value
709! is treated as missing and it is replaced with zero. This feature it
710! is usually related with the land/sea masking.
711!
712 attname(1)='scale_factor'
713 attname(2)='add_offset '
714 attname(3)='_FillValue '
715
716 CALL netcdf_get_fatt (ng, model, ncname, ncvarid, attname, &
717 & attvalue, foundit, &
718 & ncid = ncid)
719 IF (founderror(exit_flag, noerror, __line__, myfile)) THEN
720 status=ioerror
721 RETURN
722 END IF
723
724 IF (.not.foundit(1)) THEN
725 afactor=1.0_r8
726 ELSE
727 afactor=attvalue(1)
728 END IF
729
730 IF (.not.foundit(2)) THEN
731 aoffset=0.0_r8
732 ELSE
733 aoffset=attvalue(2)
734 END IF
735
736 IF (.not.foundit(3)) THEN
737 aspval=spval_check
738 ELSE
739 aspval=attvalue(3)
740 END IF
741
742# ifdef DISTRIBUTE
743!
744! Set the number of tile ghost points, Nghost, to scatter in
745! distributed-memory applications. If Nghost=0, the ghost points
746! are not processed. They will be processed elsewhere by the
747! appropriate call to any of the routines in "mp_exchange.F".
748!
749# ifdef NO_READ_GHOST
750 nghost=0
751# else
752 IF (model.eq.iadm) THEN
753 nghost=0
754 ELSE
755 nghost=nghostpoints
756 END IF
757# endif
758# endif
759# if defined READ_WATER && defined MASKING
760!
761! If processing water points only, set number of points and type
762! switch.
763!
764 SELECT CASE (abs(mytype))
765 CASE (p3dvar)
766 npts=iobounds(ng)%xy_psi
767 wtype=p2dvar
768 CASE (r3dvar, w3dvar)
769 npts=iobounds(ng)%xy_rho
770 wtype=r2dvar
771 CASE (u3dvar)
772 npts=iobounds(ng)%xy_u
773 wtype=u2dvar
774 CASE (v3dvar)
775 npts=iobounds(ng)%xy_v
776 wtype=v2dvar
777 CASE DEFAULT
778 npts=iobounds(ng)%xy_rho
779 wtype=r2dvar
780 END SELECT
781 nwpts=(lm(ng)+2)*(mm(ng)+2)
782# if !(defined INLINE_2DIO && defined DISTRIBUTE)
783 npts=npts*klen
784# endif
785# endif
786!
787! Initialize local array to avoid denormalized numbers. This
788! facilitates processing and debugging.
789!
790 wrk=0.0_r8
791!
792! Initialize checsum value.
793!
794 IF (PRESENT(checksum)) THEN
795 lchecksum=.true.
796 checksum=0_i8b
797 ELSE
798 lchecksum=.false.
799 END IF
800!
801!-----------------------------------------------------------------------
802! Serial I/O: Read in requested field and scale it.
803!-----------------------------------------------------------------------
804!
805! Proccess data as 3D slides.
806!
807 DO fourth=lbt,ubt
808 IF (mytype.gt.0) THEN
809 start(1)=1
810 total(1)=ilen
811 start(2)=1
812 total(2)=jlen
813 start(3)=1
814 total(3)=klen
815 start(4)=fourth+loff
816 total(4)=1
817 start(5)=tindex
818 total(5)=1
819 npts=ijlen
820# if !(defined INLINE_2DIO && defined DISTRIBUTE)
821 npts=npts*klen
822# endif
823# if defined READ_WATER && defined MASKING
824 ELSE
825 start(1)=1+(fourth+loff-1)*npts
826 total(1)=npts
827 start(2)=1
828 total(2)=tindex
829# endif
830 END IF
831# if defined INLINE_2DIO && defined DISTRIBUTE
832!
833! Process data as 2D slices (level by level) to reduce memory
834! requirements.
835!
836 DO k=lbk,ubk
837 start(3)=k-koff+1
838 total(3)=1
839# endif
840 status=nf90_noerr
841 IF (inpthread) THEN
842 status=nf90_get_var(ncid, ncvarid, wrk, start, total)
843 IF (status.eq.nf90_noerr) THEN
844 DO i=1,npts
845 IF (abs(wrk(i)).ge.abs(aspval)) THEN
846 wrk(i)=0.0_r8 ! masked with _FillValue
847 ELSE
848 wrk(i)=ascl*(afactor*wrk(i)+aoffset)
849 amin=min(amin,wrk(i))
850 amax=max(amax,wrk(i))
851 END IF
852 END DO
853 IF ((abs(amin).ge.abs(aspval)).and. &
854 & (abs(amax).ge.abs(aspval))) THEN
855 amin=0.0_r8 ! the entire data is all
856 amax=0.0_r8 ! field value, _FillValue
857 END IF
858 END IF
859 IF (lchecksum) THEN
860 CALL get_hash (wrk, npts, checksum)
861 END IF
862 END IF
863# ifdef DISTRIBUTE
864 CALL mp_bcasti (ng, model, status)
865# endif
866 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
867 exit_flag=2
868 ioerror=status
869 RETURN
870 END IF
871!
872!-----------------------------------------------------------------------
873! Serial I/O: Unpack read field.
874!-----------------------------------------------------------------------
875
876# ifdef DISTRIBUTE
877!
878! Scatter read data over the distributed memory tiles.
879!
880# ifdef INLINE_2DIO
881 CALL mp_scatter2d (ng, model, lbi, ubi, lbj, ubj, &
882 & nghost, mytype, amin, amax, &
883# if defined READ_WATER && defined MASKING
884 & nwpts, scalars(ng)%IJwater(:,wtype), &
885# endif
886 & npts, wrk, adat(:,:,k,fourth))
887 END DO
888# else
889 CALL mp_scatter3d (ng, model, lbi, ubi, lbj, ubj, lbk, ubk, &
890 & nghost, mytype, amin, amax, &
891# if defined READ_WATER && defined MASKING
892 & nwpts, scalars(ng)%IJwater(:,wtype), &
893# endif
894 & npts, wrk, adat(:,:,:,fourth))
895# endif
896# else
897!
898! Unpack data into the global array: serial, serial with partitions,
899! and shared-memory applications.
900!
901 IF (mytype.gt.0) THEN
902 ic=0
903 DO k=lbk,ubk
904 DO j=js,je
905 DO i=is,ie
906 ic=ic+1
907 adat(i,j,k,fourth)=wrk(ic)
908 END DO
909 END DO
910 END DO
911# if defined MASKING || defined READ_WATER
912 ELSE
913 ic=0
914 DO k=lbk,ubk
915 DO j=js,je
916 DO i=is,ie
917 IF (amask(i,j).gt.0.0_r8) THEN
918 ic=ic+1
919 adat(i,j,k,fourth)=wrk(ic)
920 ELSE
921 adat(i,j,k,fourth)=0.0_r8
922 END IF
923 END DO
924 END DO
925 END DO
926# endif
927 END IF
928# endif
929 END DO
930!
931!-----------------------------------------------------------------------
932! If requested, compute data checksum value.
933!-----------------------------------------------------------------------
934!
935 IF (lchecksum) THEN
936# ifdef DISTRIBUTE
937 npts=(imax-imin+1)*(jmax-jmin+1)*(ubk-lbk+1)*(ubt-lbt+1)
938 IF (.not.allocated(cwrk)) allocate ( cwrk(npts) )
939 cwrk=pack(adat(imin:imax, jmin:jmax, lbk:ubk, lbt:ubt), .true.)
940 CALL get_hash (cwrk, npts, checksum, .true.)
941# else
942 npts=(ie-is+1)*(je-js+1)*(ubk-lbk+1)*(ubt-lbt+1)
943 IF (.not.allocated(cwrk)) allocate ( cwrk(npts) )
944 cwrk=pack(adat(is:ie, js:je, lbk:ubk, lbt:ubt), .true.)
945 CALL get_hash (cwrk, npts, checksum)
946# endif
947 IF (allocated(cwrk)) deallocate (cwrk)
948 END IF
949
950!
951 RETURN
952 END FUNCTION nf90_fread4d
953#endif
954
955#if defined PIO_LIB && defined DISTRIBUTE
956!
957!***********************************************************************
958 FUNCTION pio_fread4d (ng, model, ncname, pioFile, &
959 & ncvname, pioVar, &
960 & tindex, pioDesc, Vsize, &
961 & LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt, &
962 & Ascl, Amin, Amax, &
963# ifdef MASKING
964 & Amask, &
965# endif
966 & Adat, &
967 & checksum) RESULT (status)
968!***********************************************************************
969!
971!
972 USE distribute_mod, ONLY : mp_reduce
973!
974! Imported variable declarations.
975!
976 integer, intent(in) :: ng, model, tindex
977 integer, intent(in) :: lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt
978 integer, intent(in) :: vsize(4)
979!
980 integer(i8b), intent(out), optional :: checksum
981!
982 real(dp), intent(in) :: ascl
983 real(r8), intent(out) :: amin
984 real(r8), intent(out) :: amax
985!
986 character (len=*), intent(in) :: ncname
987 character (len=*), intent(in) :: ncvname
988!
989# ifdef ASSUMED_SHAPE
990# ifdef MASKING
991 real(r8), intent(in) :: amask(lbi:,lbj:)
992# endif
993 real(r8), intent(out) :: adat(lbi:,lbj:,lbk:,lbt:)
994# else
995# ifdef MASKING
996 real(r8), intent(in) :: amask(lbi:ubi,lbj:ubj)
997# endif
998 real(r8), intent(out) :: adat(lbi:ubi,lbj:ubj,lbk:ubk,lbt:ubt)
999# endif
1000!
1001 TYPE (file_desc_t), intent(inout) :: piofile
1002 TYPE (io_desc_t), intent(inout) :: piodesc
1003 TYPE (my_vardesc), intent(inout) :: piovar
1004!
1005! Local variable declarations.
1006!
1007 logical :: lchecksum
1008 logical, dimension(3) :: foundit
1009!
1010 integer :: i, j, k, l, npts, status
1011 integer :: is, ie, js, je
1012 integer :: imin, imax, jmin, jmax
1013 integer :: cgrid, ghost, dkind, gtype
1014
1015 integer, dimension(5) :: start, total
1016!
1017 real(r8) :: afactor, aoffset, aspval, avalue
1018 real(r8) :: my_amin, my_amax
1019
1020 real(r8), dimension(3) :: attvalue
1021 real(r8), dimension(2) :: rbuffer
1022!
1023 real(r4), pointer :: awrk4(:,:,:,:) ! single precision
1024 real(r8), pointer :: awrk8(:,:,:,:) ! double precision
1025 real(r8), allocatable :: cwrk(:) ! used for checksum
1026!
1027 character (len=12), dimension(3) :: attname
1028 character (len= 3), dimension(2) :: op_handle
1029
1030 character (len=*), parameter :: myfile = &
1031 & __FILE__//", pio_fread4d"
1032!
1033!-----------------------------------------------------------------------
1034! Set starting and ending indices to process.
1035!-----------------------------------------------------------------------
1036!
1037 status=pio_noerr
1038 amin=spval
1039 amax=-spval
1040 my_amin=spval
1041 my_amax=-spval
1042!
1043! Set global (interior plus boundary) starting and ending grid cell
1044! indices in the I- and J-directions according to staggered C-grid
1045! classification.
1046!
1047 dkind=piovar%dkind
1048 gtype=piovar%gtype
1049!
1050 SELECT CASE (abs(gtype))
1051 CASE (p2dvar, p3dvar)
1052 cgrid=1 ! PSI-points
1053 is=iobounds(ng)%ILB_psi
1054 ie=iobounds(ng)%IUB_psi
1055 js=iobounds(ng)%JLB_psi
1056 je=iobounds(ng)%JUB_psi
1057 CASE (l4dvar, r2dvar, r3dvar, w3dvar)
1058 cgrid=2 ! RHO-points
1059 is=iobounds(ng)%ILB_rho
1060 ie=iobounds(ng)%IUB_rho
1061 js=iobounds(ng)%JLB_rho
1062 je=iobounds(ng)%JUB_rho
1063 CASE (u2dvar, u3dvar)
1064 cgrid=3 ! U-points
1065 is=iobounds(ng)%ILB_u
1066 ie=iobounds(ng)%IUB_u
1067 js=iobounds(ng)%JLB_u
1068 je=iobounds(ng)%JUB_u
1069 CASE (v2dvar, v3dvar)
1070 cgrid=4 ! V-points
1071 is=iobounds(ng)%ILB_v
1072 ie=iobounds(ng)%IUB_v
1073 js=iobounds(ng)%JLB_v
1074 je=iobounds(ng)%JUB_v
1075 CASE DEFAULT
1076 cgrid=2 ! RHO-points
1077 is=iobounds(ng)%ILB_rho
1078 ie=iobounds(ng)%IUB_rho
1079 js=iobounds(ng)%JLB_rho
1080 je=iobounds(ng)%JUB_rho
1081 END SELECT
1082!
1083! Set the tile computational I- and J-bounds (no ghost points).
1084!
1085 ghost=0
1086 imin=bounds(ng)%Imin(cgrid,ghost,myrank)
1087 imax=bounds(ng)%Imax(cgrid,ghost,myrank)
1088 jmin=bounds(ng)%Jmin(cgrid,ghost,myrank)
1089 jmax=bounds(ng)%Jmax(cgrid,ghost,myrank)
1090!
1091! Check if the following attributes: "scale_factor", "add_offset", and
1092! "_FillValue" are present in the input NetCDF variable:
1093!
1094! If the "scale_value" attribute is present, the data is multiplied by
1095! this factor after reading.
1096! If the "add_offset" attribute is present, this value is added to the
1097! data after reading.
1098! If both "scale_factor" and "add_offset" attributes are present, the
1099! data are first scaled before the offset is added.
1100! If the "_FillValue" attribute is present, the data having this value
1101! is treated as missing and it is replaced with zero. This feature it
1102! is usually related with the land/sea masking.
1103!
1104 attname(1)='scale_factor'
1105 attname(2)='add_offset '
1106 attname(3)='_FillValue '
1107
1108 CALL pio_netcdf_get_fatt (ng, model, ncname, piovar%vd, attname, &
1109 & attvalue, foundit, &
1110 & piofile = piofile)
1111 IF (founderror(exit_flag, noerror, __line__, myfile)) THEN
1112 status=ioerror
1113 RETURN
1114 END IF
1115
1116 IF (.not.foundit(1)) THEN
1117 afactor=1.0_r8
1118 ELSE
1119 afactor=attvalue(1)
1120 END IF
1121
1122 IF (.not.foundit(2)) THEN
1123 aoffset=0.0_r8
1124 ELSE
1125 aoffset=attvalue(2)
1126 END IF
1127
1128 IF (.not.foundit(3)) THEN
1129 aspval=spval_check
1130 ELSE
1131 aspval=attvalue(3)
1132 END IF
1133!
1134! Initialize checsum value.
1135!
1136 IF (PRESENT(checksum)) THEN
1137 lchecksum=.true.
1138 checksum=0_i8b
1139 ELSE
1140 lchecksum=.false.
1141 END IF
1142!
1143!-----------------------------------------------------------------------
1144! Read in requested field and scale it.
1145!-----------------------------------------------------------------------
1146!
1147! Allocate and initialize local array used for reading. The local array
1148! needs to be of the same precision as "A" and its IO decomposition
1149! descriptor "pioDesc".
1150!
1151 IF (dkind.eq.pio_double) THEN ! double precision
1152 IF (.not.associated(awrk8)) THEN
1153 allocate ( awrk8(imin:imax, jmin:jmax, lbk:ubk, lbt:ubt) )
1154 END IF
1155 awrk8=0.0_r8
1156 ELSE ! single precision
1157 IF (.not.associated(awrk4)) THEN
1158 allocate ( awrk4(imin:imax, jmin:jmax, lbk:ubk, lbt:ubt) )
1159 END IF
1160 awrk4=0.0_r4
1161 END IF
1162!
1163! Set unlimited time dimension record to write, if any.
1164!
1165 IF (tindex.gt.0) THEN
1166 CALL pio_setframe (piofile, &
1167 & piovar%vd, &
1168 & int(tindex, kind=pio_offset_kind))
1169 END IF
1170!
1171! Read in double precision data from NetCDF file.
1172!
1173 IF (dkind.eq.pio_double) THEN
1174 CALL pio_read_darray (piofile, &
1175 & piovar%vd, &
1176 & piodesc, &
1177 & awrk8(imin:,jmin:,lbk:,lbt:), &
1178 & status)
1179!
1180 DO l=lbt,ubt
1181 DO k=lbk,ubk
1182 DO j=jmin,jmax
1183 DO i=imin,imax
1184 IF (abs(awrk8(i,j,k,l)).ge.abs(aspval)) THEN
1185 adat(i,j,k,l)=0.0_r8 ! masked with _FillValue
1186 ELSE
1187 avalue=ascl*(afactor*awrk8(i,j,k,l)+aoffset)
1188 adat(i,j,k,l)=avalue
1189 my_amin=min(my_amin,avalue)
1190 my_amax=max(my_amax,avalue)
1191 END IF
1192 END DO
1193 END DO
1194 END DO
1195 END DO
1196 IF (associated(awrk8)) deallocate (awrk8)
1197!
1198! Read in and load single precision data from NetCDF file.
1199!
1200 ELSE
1201 CALL pio_read_darray (piofile, &
1202 & piovar%vd, &
1203 & piodesc, &
1204 & awrk4(imin:,jmin:,lbk:,lbt:), &
1205 & status)
1206!
1207 DO l=lbt,ubt
1208 DO k=lbk,ubk
1209 DO j=jmin,jmax
1210 DO i=imin,imax
1211 IF (abs(awrk4(i,j,k,l)).ge.abs(aspval)) THEN
1212 adat(i,j,k,l)=0.0_r8 ! masked with _FillValue
1213 ELSE
1214 avalue=real(ascl*(afactor*awrk4(i,j,k,l)+aoffset),r8)
1215 adat(i,j,k,l)=avalue
1216 my_amin=real(min(my_amin,avalue),r8)
1217 my_amax=real(max(my_amax,avalue),r8)
1218 END IF
1219 END DO
1220 END DO
1221 END DO
1222 END DO
1223 IF (associated(awrk4)) deallocate (awrk4)
1224 END IF
1225!
1226! If requested, compute input data checksum value.
1227! (TODO: parallel gathering of checksum)
1228!
1229 IF (lchecksum) THEN
1230 npts=(imax-imin+1)*(jmax-jmin+1)*(ubk-lbk+1)*(ubt-lbt+1)
1231 IF (.not.allocated(cwrk)) allocate ( cwrk(npts) )
1232 cwrk=pack(adat(imin:imax, jmin:jmax, lbk:ubk, lbt:ubt), .true.)
1233 CALL get_hash (cwrk, npts, checksum, .true.)
1234 IF (allocated(cwrk)) deallocate (cwrk)
1235 END IF
1236!
1237! Compute global minimum and maximum values.
1238!
1239 rbuffer(1)=my_amin
1240 rbuffer(2)=my_amax
1241 op_handle(1)='MIN'
1242 op_handle(2)='MAX'
1243 CALL mp_reduce (ng, model, 2, rbuffer, op_handle)
1244 amin=rbuffer(1)
1245 amax=rbuffer(2)
1246!
1247 IF ((abs(amin).ge.abs(spval)).and. &
1248 & (abs(amax).ge.abs(spval))) THEN
1249 amin=0.0_r8 ! the entire data is all
1250 amax=0.0_r8 ! field value, _FillValue
1251 END IF ! and was zeroth out
1252!
1253 RETURN
1254 END FUNCTION pio_fread4d
1255#endif
1256 END MODULE nf_fread4d_mod
subroutine mp_scatter3d(ng, model, lbi, ubi, lbj, ubj, lbk, ubk, nghost, gtype, amin, amax, nwpts, ij_water, npts, a, awrk)
subroutine mp_scatter2d(ng, model, lbi, ubi, lbj, ubj, nghost, gtype, amin, amax, nwpts, ij_water, npts, a, awrk)
subroutine, public tile_bounds_1d(ng, tile, imax, istr, iend)
Definition get_bounds.F:921
subroutine, public get_hash(a, asize, hash, lreduce)
Definition get_hash.F:72
integer ioerror
logical inpthread
type(t_bounds), dimension(:), allocatable bounds
Definition mod_param.F:232
integer, parameter r3dvar
Definition mod_param.F:721
integer, parameter l4dvar
Definition mod_param.F:727
type(t_iobounds), dimension(:), allocatable iobounds
Definition mod_param.F:282
integer nghostpoints
Definition mod_param.F:710
integer, parameter iadm
Definition mod_param.F:665
integer, parameter u3dvar
Definition mod_param.F:722
integer, dimension(:), allocatable lm
Definition mod_param.F:455
integer, parameter u2dvar
Definition mod_param.F:718
integer, parameter w3dvar
Definition mod_param.F:724
integer, parameter p2dvar
Definition mod_param.F:716
integer, dimension(:), allocatable mm
Definition mod_param.F:456
integer, parameter r2dvar
Definition mod_param.F:717
integer, parameter v2dvar
Definition mod_param.F:719
integer, parameter p3dvar
Definition mod_param.F:720
integer, parameter v3dvar
Definition mod_param.F:723
real(dp), parameter spval
real(dp), parameter spval_check
integer exit_flag
type(t_scalars), dimension(:), allocatable scalars
Definition mod_scalars.F:65
integer noerror
integer function pio_fread4d(ng, model, ncname, piofile, ncvname, piovar, tindex, piodesc, vsize, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, ascl, amin, amax, amask, adat, checksum)
Definition nf_fread4d.F:968
integer function nf90_fread4d(ng, model, ncname, ncid, ncvname, ncvarid, tindex, gtype, vsize, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, ascl, amin, amax, amask, adat, checksum)
Definition nf_fread4d.F:93
logical function, public founderror(flag, noerr, line, routine)
Definition strings.F:52