86
87
92# if defined PROPAGATOR && defined CHECKPOINTING && \
93 defined pio_lib && defined distribute
95# endif
97# ifdef PROPAGATOR
99# endif
100# ifdef DISTRIBUTE
101
103# if defined PROPAGATOR && defined CHECKPOINTING && defined PIO_LIB
105# endif
106# endif
107
108 implicit none
109
110
111
112 integer, intent(in) :: ng, tile, model
113 integer, intent(in) :: LBi, UBi, LBj, UBj
114 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
115
116# ifdef ASSUMED_SHAPE
117# ifdef MASKING
118# ifdef PROPAGATOR
119 integer, intent(out) :: IJwaterR(LBi:,LBj:)
120 integer, intent(out) :: IJwaterU(LBi:,LBj:)
121 integer, intent(out) :: IJwaterV(LBi:,LBj:)
122# endif
123 real(r8), intent(in) :: rmask_full(LBi:,LBj:)
124 real(r8), intent(in) :: pmask_full(LBi:,LBj:)
125 real(r8), intent(in) :: umask_full(LBi:,LBj:)
126 real(r8), intent(in) :: vmask_full(LBi:,LBj:)
127# endif
128 real(r8), intent(in) :: h(LBi:,LBj:)
129# else
130# ifdef MASKING
131# ifdef PROPAGATOR
132 integer, intent(out) :: IJwaterR(LBi:UBi,LBj:UBj)
133 integer, intent(out) :: IJwaterU(LBi:UBi,LBj:UBj)
134 integer, intent(out) :: IJwaterV(LBi:UBi,LBj:UBj)
135# endif
136 real(r8), intent(in) :: rmask_full(LBi:UBi,LBj:UBj)
137 real(r8), intent(in) :: pmask_full(LBi:UBi,LBj:UBj)
138 real(r8), intent(in) :: umask_full(LBi:UBi,LBj:UBj)
139 real(r8), intent(in) :: vmask_full(LBi:UBi,LBj:UBj)
140# endif
141 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
142# endif
143
144
145
146# if defined PROPAGATOR && defined CHECKPOINTING && \
147 defined pio_lib && defined distribute
148 logical, save :: first = .true.
149
150# endif
151 integer :: my_Nxyp, my_Nxyr, my_Nxyu, my_Nxyv
152# ifdef PROPAGATOR
153 integer :: my_NwaterR, my_NwaterU, my_NwaterV
154# endif
155
156# ifdef PROPAGATOR
157 integer :: Imin, Imax, Jmin, Jmax
158# endif
159 integer :: Uoff, Voff
160 integer :: NSUB, Npts, i, ic, ij, j
161# ifdef DISTRIBUTE
162# ifdef PROPAGATOR
163 integer :: block_size
164
165 real(r8), dimension(3) :: wp_buffer
166 character (len=3), dimension(3) :: wp_handle
167# endif
168# if defined MASKING && (defined READ_WATER || defined WRITE_WATER)
169 real(r8), dimension(4) :: io_buffer
170 character (len=3), dimension(4) :: io_handle
171# endif
172# endif
173# if defined READ_WATER || defined PROPAGATOR
174 real(r8), dimension((Lm(ng)+2)*(Mm(ng)+2)) :: mask
175# endif
176
177# include "set_bounds.h"
178
179# if defined MASKING && (defined READ_WATER || defined WRITE_WATER)
180
181
182
183
184
185
186
187 my_nxyr=0
188 my_nxyp=0
189 my_nxyu=0
190 my_nxyv=0
191
192 DO j=jstr,jend
193 DO i=istr,iend
194 IF (pmask_full(i,j).gt.0.0_r8) my_nxyp=my_nxyp+1
195 IF (rmask_full(i,j).gt.0.0_r8) my_nxyr=my_nxyr+1
196 IF (umask_full(i,j).gt.0.0_r8) my_nxyu=my_nxyu+1
197 IF (vmask_full(i,j).gt.0.0_r8) my_nxyv=my_nxyv+1
198 END DO
199 END DO
200
201
202
203
204 IF (
domain(ng)%Western_Edge(tile))
THEN
205 DO j=jstr,jend
206 IF (rmask_full(istr-1,j).gt.0.0_r8) my_nxyr=my_nxyr+1
207 IF (vmask_full(istr-1,j).gt.0.0_r8) my_nxyv=my_nxyv+1
208 END DO
209 END IF
210 IF (
domain(ng)%Eastern_Edge(tile))
THEN
211 DO j=jstr,jend
212 IF (pmask_full(iend+1,j).gt.0.0_r8) my_nxyp=my_nxyp+1
213 IF (rmask_full(iend+1,j).gt.0.0_r8) my_nxyr=my_nxyr+1
214 IF (umask_full(iend+1,j).gt.0.0_r8) my_nxyu=my_nxyu+1
215 IF (vmask_full(iend+1,j).gt.0.0_r8) my_nxyv=my_nxyv+1
216 END DO
217 END IF
218 IF (
domain(ng)%Southern_Edge(tile))
THEN
219 DO i=istr,iend
220 IF (rmask_full(i,jstr-1).gt.0.0_r8) my_nxyr=my_nxyr+1
221 IF (umask_full(i,jstr-1).gt.0.0_r8) my_nxyu=my_nxyu+1
222 END DO
223 END IF
224 IF (
domain(ng)%Northern_Edge(tile))
THEN
225 DO i=istr,iend
226 IF (pmask_full(i,jend+1).gt.0.0_r8) my_nxyp=my_nxyp+1
227 IF (rmask_full(i,jend+1).gt.0.0_r8) my_nxyr=my_nxyr+1
228 IF (umask_full(i,jend+1).gt.0.0_r8) my_nxyu=my_nxyu+1
229 IF (vmask_full(i,jend+1).gt.0.0_r8) my_nxyv=my_nxyv+1
230 END DO
231 END IF
232 IF (
domain(ng)%SouthWest_Corner(tile))
THEN
233 IF (rmask_full(istr-1,jstr-1).gt.0.0_r8) my_nxyr=my_nxyr+1
234 END IF
235 IF (
domain(ng)%SouthEast_Corner(tile))
THEN
236 IF (rmask_full(iend+1,jstr-1).gt.0.0_r8) my_nxyr=my_nxyr+1
237 IF (umask_full(iend+1,jstr-1).gt.0.0_r8) my_nxyu=my_nxyu+1
238 END IF
239 IF (
domain(ng)%NorthWest_Corner(tile))
THEN
240 IF (rmask_full(istr-1,jend+1).gt.0.0_r8) my_nxyr=my_nxyr+1
241 IF (vmask_full(istr-1,jend+1).gt.0.0_r8) my_nxyv=my_nxyv+1
242 END IF
243 IF (
domain(ng)%NorthEast_Corner(tile))
THEN
244 IF (pmask_full(iend+1,jend+1).gt.0.0_r8) my_nxyp=my_nxyp+1
245 IF (rmask_full(iend+1,jend+1).gt.0.0_r8) my_nxyr=my_nxyr+1
246 IF (umask_full(iend+1,jend+1).gt.0.0_r8) my_nxyu=my_nxyu+1
247 IF (vmask_full(iend+1,jend+1).gt.0.0_r8) my_nxyv=my_nxyv+1
248 END IF
249# endif
250# ifdef PROPAGATOR
251
252
253
254
255
256 my_nwaterr=0
257 my_nwateru=0
258 my_nwaterv=0
259
260 DO j=jr_range
261 DO i=ir_range
262# ifdef MASKING
263 IF (rmask_full(i,j).gt.0.0_r8) THEN
264 my_nwaterr=my_nwaterr+1
265 END IF
266# else
267 my_nwaterr=my_nwaterr+1
268# endif
269 END DO
270 DO i=iu_range
271# ifdef MASKING
272 IF (umask_full(i,j).gt.0.0_r8) THEN
273 my_nwateru=my_nwateru+1
274 END IF
275# else
276 my_nwateru=my_nwateru+1
277# endif
278 END DO
279 END DO
280 DO j=jv_range
281 DO i=ir_range
282# ifdef MASKING
283 IF (vmask_full(i,j).gt.0.0_r8) THEN
284 my_nwaterv=my_nwaterv+1
285 END IF
286# else
287 my_nwaterv=my_nwaterv+1
288# endif
289 END DO
290 END DO
291# endif
292
293
294
295# ifdef DISTRIBUTE
296 nsub=1
297# else
298 IF (
domain(ng)%SouthWest_Corner(tile).and. &
299 &
domain(ng)%NorthEast_Corner(tile))
THEN
300 nsub=1
301 ELSE
303 END IF
304# endif
305
307# if defined MASKING && (defined READ_WATER || defined WRITE_WATER)
312# endif
313# ifdef PROPAGATOR
317# endif
318 END IF
319# if defined MASKING && (defined READ_WATER || defined WRITE_WATER)
324# endif
325# ifdef PROPAGATOR
329# endif
333# ifdef DISTRIBUTE
334# if defined MASKING && (defined READ_WATER || defined WRITE_WATER)
335 io_buffer(1)=real(
nxyp(ng),r8)
336 io_buffer(2)=real(
nxyr(ng),r8)
337 io_buffer(3)=real(
nxyu(ng),r8)
338 io_buffer(4)=real(
nxyv(ng),r8)
339 io_handle(1)='SUM'
340 io_handle(2)='SUM'
341 io_handle(3)='SUM'
342 io_handle(4)='SUM'
343 CALL mp_reduce (ng, model, 4, io_buffer, io_handle)
344 nxyp(ng)=int(io_buffer(1))
345 nxyr(ng)=int(io_buffer(2))
346 nxyu(ng)=int(io_buffer(3))
347 nxyv(ng)=int(io_buffer(4))
348# endif
349# ifdef PROPAGATOR
350 wp_buffer(1)=real(
nwaterr(ng),r8)
351 wp_buffer(2)=real(
nwateru(ng),r8)
352 wp_buffer(3)=real(
nwaterv(ng),r8)
353 wp_handle(1)='SUM'
354 wp_handle(2)='SUM'
355 wp_handle(3)='SUM'
356 CALL mp_reduce (ng, model, 3, wp_buffer, wp_handle)
360# endif
361# endif
362# if defined MASKING && (defined READ_WATER || defined WRITE_WATER)
367# endif
368 END IF
369
370
371# ifdef PROPAGATOR
372
373
374
375
376# if defined FORCING_SV || \
377 defined so_semi || defined stochastic_opt
378
379
380
381
385 END IF
386# ifdef SOLVE3D
389 END IF
392 END IF
396 END IF
397 END DO
398# else
401 END IF
404 END IF
405# endif
408 END IF
411 END IF
412# ifdef SOLVE3D
416 END IF
417 END DO
418# endif
419# else
420# ifdef SOLVE3D
421
422
423
424
429# else
430
431
432
436# endif
437# endif
438# ifdef DISTRIBUTE
439
440
441
446 10 FORMAT (/,' Size of FULL state arrays for propagator of grid ', &
447 & i2.2,', Mstate = ', i10,/,38x, &
448 & 'NODE partition, Nstate = ', i10,/,/, &
449 & 9x,'Node',7x,'Nstr',7x,'Nend',7x,'Size',/)
451 i=1+ic*block_size
452 j=min(
mstate(ng),i+block_size-1)
453 WRITE (
stdout,20) ic, i, j, j-i+1
454 20 FORMAT (11x, i2, 3(1x,i10))
455 END DO
457 END IF
461# else
467 10 FORMAT (' Size of FULL state arrays for propagator of grid ', &
468 & i2.2, ', Mstate = ', i10,/)
469 END IF
470# endif
471# endif
472
473# if defined PIO_LIB && defined DISTRIBUTE && defined CHECKPOINTING
474
475
476
477
478
479
480 IF (first) THEN
481 IF (ng.eq.
ngrids) first=.false.
482
485 & 'Bvec', 2)
488 & 'resid', 1)
491 & 'SworkD', 1)
492
495 & 'Bvec', 2)
498 & 'resid', 1)
501 & 'SworkD', 1)
502 END IF
503# endif
504
505# if ((defined READ_WATER && defined DISTRIBUTE) || \
506 defined propagator) && defined masking
507
508
509
510
511
512
513
514
515
516
518 uoff=0
519 ELSE
520 uoff=1
521 END IF
522
524 voff=0
525 ELSE
526 voff=1
527 END IF
528
529# ifdef DISTRIBUTE
530
531
532
535 & rmask_full, rmask_full, npts, mask, .false.)
537# else
538
539
540
541 ic=0
544 ic=ic+1
545 mask(ic)=rmask_full(i,j)
546 END DO
547 END DO
548 npts=ic
549# endif
550# if defined READ_WATER && defined DISTRIBUTE
551
552
553
554 ic=0
555 DO ij=1,npts
556 IF (mask(ij).gt.0.0_r8) THEN
557 ic=ic+1
559 END IF
560 END DO
561 my_nxyr=ic
562# endif
563# ifdef PROPAGATOR
564
565
566
567 ic=0
568 ij=0
569# ifdef FULL_GRID
570 imin=0
572 jmin=0
574# else
575 imin=1
577 jmin=1
579# endif
582 ij=ij+1
583 IF ((mask(ij).gt.0.0_r8).and. &
584 & (imin.le.i).and.(i.le.imax).and. &
585 & (jmin.le.j).and.(j.le.jmax)) THEN
586 ic=ic+1
587 mask(ij)=real(ic,r8)
588 ELSE
589 mask(ij)=0.0_r8
590 END IF
591 END DO
592 END DO
593
594 ij=0
597 ij=ij+1
598 IF ((
rilb(ng).le.i).and.(i.le.
riub(ng)).and. &
599 & (
rjlb(ng).le.j).and.(j.le.
rjub(ng)))
THEN
600 IF (mask(ij).gt.0.0_r8) THEN
601 ijwaterr(i,j)=int(mask(ij))
602 ELSE
603 ijwaterr(i,j)=0
604 END IF
605 END IF
606 END DO
607 END DO
608# endif
609
610# if defined READ_WATER && defined DISTRIBUTE
611
612
613
616 & pmask_full, pmask_full, npts, mask, .false.)
618
619
620
621 ic=0
622 DO ij=1,npts
623 IF (mask(ij).gt.0.0_r8) THEN
624 ic=ic+1
626 END IF
627 END DO
628 my_nxyp=ic
629# endif
630
631# ifdef DISTRIBUTE
632
633
634
637 & umask_full, umask_full, npts, mask, .false.)
639# else
640
641
642
643 ic=0
646 ic=ic+1
647 mask(ic)=umask_full(i,j)
648 END DO
649 END DO
650 npts=ic
651# endif
652# if defined READ_WATER && defined DISTRIBUTE
653
654
655
656 ic=0
657 DO ij=1,npts
658 IF (mask(ij).gt.0.0_r8) THEN
659 ic=ic+1
661 END IF
662 END DO
663 my_nxyu=ic
664# endif
665# ifdef PROPAGATOR
666
667
668
669 ic=0
670 ij=0
671# ifdef FULL_GRID
672 imin=1
674 jmin=0
676# else
677 imin=1+uoff
679 jmin=1
681# endif
684 ij=ij+1
685 IF ((mask(ij).gt.0.0_r8).and. &
686 & (imin.le.i).and.(i.le.imax).and. &
687 & (jmin.le.j).and.(j.le.jmax)) THEN
688 ic=ic+1
689 mask(ij)=real(ic,r8)
690 ELSE
691 mask(ij)=0.0_r8
692 END IF
693 END DO
694 END DO
695
696 ij=0
699 ij=ij+1
700 IF ((
uilb(ng).le.i).and.(i.le.
uiub(ng)).and. &
701 & (
ujlb(ng).le.j).and.(j.le.
ujub(ng)))
THEN
702 IF (mask(ij).gt.0.0_r8) THEN
703 ijwateru(i,j)=int(mask(ij))
704 ELSE
705 ijwateru(i,j)=0
706 END IF
707 END IF
708 END DO
709 END DO
710# endif
711
712# ifdef DISTRIBUTE
713
714
715
718 & vmask_full, vmask_full, npts, mask, .false.)
720# else
721
722
723
724 ic=0
727 ic=ic+1
728 mask(ic)=vmask_full(i,j)
729 END DO
730 END DO
731 npts=ic
732# endif
733# if defined READ_WATER && defined DISTRIBUTE
734
735
736
737 ic=0
738 DO ij=1,npts
739 IF (mask(ij).gt.0.0_r8) THEN
740 ic=ic+1
742 END IF
743 END DO
744 my_nxyv=ic
745# endif
746# ifdef PROPAGATOR
747
748
749
750 ic=0
751 ij=0
752# ifdef FULL_GRID
753 imin=0
755 jmin=1
757# else
758 imin=1
760 jmin=1+voff
762# endif
765 ij=ij+1
766 IF ((mask(ij).gt.0.0_r8).and. &
767 & (imin.le.i).and.(i.le.imax).and. &
768 & (jmin.le.j).and.(j.le.jmax)) THEN
769 ic=ic+1
770 mask(ij)=real(ic,r8)
771 ELSE
772 mask(ij)=0.0_r8
773 END IF
774 END DO
775 END DO
776
777 ij=0
780 ij=ij+1
781 IF ((
vilb(ng).le.i).and.(i.le.
viub(ng)).and. &
782 & (
vjlb(ng).le.j).and.(j.le.
vjub(ng)))
THEN
783 IF (mask(ij).gt.0.0_r8) THEN
784 ijwaterv(i,j)=int(mask(ij))
785 ELSE
786 ijwaterv(i,j)=0
787 END IF
788 END IF
789 END DO
790 END DO
791# endif
792# endif
793
794# undef IR_RANGE
795# undef IU_RANGE
796# undef JR_RANGE
797# undef JV_RANGE
798
799 RETURN
subroutine mp_gather2d(ng, model, lbi, ubi, lbj, ubj, tindex, gtype, ascl, amask, a, npts, awrk, setfillval)
integer, dimension(:), allocatable nxyp
integer, dimension(:), allocatable riub
integer, dimension(:), allocatable rjlb
integer, dimension(:), allocatable nxyu
integer, dimension(:), allocatable vjlb
integer, dimension(:), allocatable uilb
integer, dimension(:), allocatable nwaterv
integer, dimension(:), allocatable nxyv
integer, dimension(:), allocatable vilb
integer, dimension(:), allocatable nwateru
integer, dimension(:), allocatable istvar
integer, dimension(:), allocatable vjub
integer, dimension(:), allocatable rjub
integer, dimension(:), allocatable ujlb
integer, dimension(:), allocatable ujub
integer, dimension(:), allocatable istsur
integer, dimension(:), allocatable nwaterr
integer, dimension(:), allocatable rilb
integer, dimension(:), allocatable uiub
integer, dimension(:), allocatable viub
integer, dimension(:), allocatable nxyr
integer, dimension(:), allocatable nstate
integer, dimension(:), allocatable n
integer, dimension(:), allocatable mstate
integer, dimension(:), allocatable nstr
integer, dimension(:), allocatable ntilex
type(t_iobounds), dimension(:), allocatable iobounds
type(t_domain), dimension(:), allocatable domain
integer, dimension(:), allocatable lm
integer, parameter u2dvar
integer, dimension(:), allocatable ntilee
integer, dimension(:), allocatable nend
integer, parameter p2dvar
integer, dimension(:), allocatable nt
integer, dimension(:), allocatable mm
integer, parameter r2dvar
integer, parameter v2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_resid
type(io_desc_t), dimension(:), pointer iodesc_sp_bvec
type(iosystem_desc_t), dimension(:,:), allocatable, target piosystem
type(io_desc_t), dimension(:), pointer iodesc_dp_bvec
type(io_desc_t), dimension(:), pointer iodesc_sp_sworkd
type(io_desc_t), dimension(:), pointer iodesc_sp_resid
type(io_desc_t), dimension(:), pointer iodesc_dp_sworkd
logical, dimension(:), allocatable ewperiodic
logical, dimension(:), allocatable nsperiodic
type(t_scalars), dimension(:), allocatable scalars
subroutine, public state_iodecomp(ng, iosystem, iotype, iodesc, iovname, ndims)