15 implicit none ;
private
17 #include <MOM_memory.h>
30 real,
dimension(SZI_(G), SZJ_(G)),
intent(in) :: var
31 real,
optional,
intent(in) :: scale
33 real,
dimension(SZI_(G), SZJ_(G)) :: tmpforsumming
37 integer :: i, j, is, ie, js, je
38 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
40 scalefac = g%US%L_to_m**2 ;
if (
present(scale)) scalefac = g%US%L_to_m**2*scale
42 tmpforsumming(:,:) = 0.
43 do j=js,je ;
do i=is,ie
44 tmpforsumming(i,j) = var(i,j) * (scalefac * g%areaT(i,j) * g%mask2dT(i,j))
53 real,
dimension(SZI_(G), SZJ_(G)),
intent(in) :: var
54 real,
optional,
intent(in) :: scale
55 real,
dimension(SZI_(G), SZJ_(G)) :: tmpforsumming
59 integer :: i, j, is, ie, js, je
60 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
62 scalefac = g%US%L_to_m**2 ;
if (
present(scale)) scalefac = g%US%L_to_m**2*scale
64 tmpforsumming(:,:) = 0.
65 do j=js,je ;
do i=is, ie
66 tmpforsumming(i,j) = var(i,j) * (scalefac * g%areaT(i,j) * g%mask2dT(i,j))
76 real,
dimension(SZI_(G),SZJ_(G),SZK_(GV)),
intent(in) :: var
77 real,
dimension(SZI_(G),SZJ_(G),SZK_(GV)),
intent(in) :: h
78 real,
optional,
intent(in) :: scale
81 real,
dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: tmpforsumming, weight
82 real,
dimension(SZK_(GV)) :: scalarij, weightij
83 real,
dimension(SZK_(GV)) :: global_temp_scalar, global_weight_scalar
85 integer :: i, j, k, is, ie, js, je, nz
86 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = gv%ke
88 scalefac = 1.0 ;
if (
present(scale)) scalefac = scale
89 tmpforsumming(:,:,:) = 0. ; weight(:,:,:) = 0.
91 do k=1,nz ;
do j=js,je ;
do i=is,ie
92 weight(i,j,k) = (gv%H_to_m * h(i,j,k)) * (g%US%L_to_m**2*g%areaT(i,j) * g%mask2dT(i,j))
93 tmpforsumming(i,j,k) = scalefac * var(i,j,k) * weight(i,j,k)
109 real,
dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
111 real,
dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
113 real,
optional,
intent(in) :: scale
118 real,
dimension(SZI_(G), SZJ_(G)) :: tmpforsumming, sum_weight
119 integer :: i, j, k, is, ie, js, je, nz
120 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = gv%ke
122 scalefac = 1.0 ;
if (
present(scale)) scalefac = scale
123 tmpforsumming(:,:) = 0. ; sum_weight(:,:) = 0.
125 do k=1,nz ;
do j=js,je ;
do i=is,ie
126 weight_here = (gv%H_to_m * h(i,j,k)) * (g%US%L_to_m**2*g%areaT(i,j) * g%mask2dT(i,j))
127 tmpforsumming(i,j) = tmpforsumming(i,j) + scalefac * var(i,j,k) * weight_here
128 sum_weight(i,j) = sum_weight(i,j) + weight_here
129 enddo ;
enddo ;
enddo
140 real,
dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
142 real,
dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
143 optional,
intent(in) :: var
144 logical,
optional,
intent(in) :: on_pe_only
146 real,
optional,
intent(in) :: scale
150 real,
dimension(SZI_(G), SZJ_(G)) :: tmpforsumming
152 logical :: global_sum
153 integer :: i, j, k, is, ie, js, je, nz
154 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = gv%ke
156 scalefac = g%US%L_to_m**2 ;
if (
present(scale)) scalefac = g%US%L_to_m**2*scale
157 tmpforsumming(:,:) = 0.0
159 if (
present(var))
then
160 do k=1,nz ;
do j=js,je ;
do i=is,ie
161 tmpforsumming(i,j) = tmpforsumming(i,j) + var(i,j,k) * &
162 ((gv%H_to_kg_m2 * h(i,j,k)) * (scalefac*g%areaT(i,j) * g%mask2dT(i,j)))
163 enddo ;
enddo ;
enddo
165 do k=1,nz ;
do j=js,je ;
do i=is,ie
166 tmpforsumming(i,j) = tmpforsumming(i,j) + &
167 ((gv%H_to_kg_m2 * h(i,j,k)) * (scalefac*g%areaT(i,j) * g%mask2dT(i,j)))
168 enddo ;
enddo ;
enddo
170 global_sum = .true. ;
if (
present(on_pe_only)) global_sum = .not.on_pe_only
175 do j=js,je ;
do i=is,ie
185 subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale)
187 real,
dimension(SZI_(G),SZJ_(G)),
intent(in) :: array
188 real,
dimension(SZJ_(G)),
intent(out) :: i_mean
189 real,
dimension(SZI_(G),SZJ_(G)), &
190 optional,
intent(in) :: mask
191 real,
optional,
intent(in) :: scale
192 real,
optional,
intent(in) :: tmp_scale
196 type(
efp_type),
allocatable,
dimension(:) :: asum, mask_sum
200 integer :: is, ie, js, je, idg_off, jdg_off
203 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
204 idg_off = g%idg_offset ; jdg_off = g%jdg_offset
206 scalefac = 1.0 ;
if (
present(scale)) scalefac = scale
208 if (
present(tmp_scale))
then ;
if (tmp_scale /= 0.0)
then
209 scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale
213 allocate(asum(g%jsg:g%jeg))
214 if (
present(mask))
then
215 allocate(mask_sum(g%jsg:g%jeg))
218 asum(j) = real_to_efp(0.0) ; mask_sum(j) = real_to_efp(0.0)
221 do i=is,ie ;
do j=js,je
222 asum(j+jdg_off) = asum(j+jdg_off) + real_to_efp(scalefac*array(i,j)*mask(i,j))
223 mask_sum(j+jdg_off) = mask_sum(j+jdg_off) + real_to_efp(mask(i,j))
227 "global_i_mean overflow error occurred before sums across PEs.")
229 call efp_list_sum_across_pes(asum(g%jsg:g%jeg), g%jeg-g%jsg+1)
230 call efp_list_sum_across_pes(mask_sum(g%jsg:g%jeg), g%jeg-g%jsg+1)
233 "global_i_mean overflow error occurred during sums across PEs.")
236 mask_sum_r = efp_to_real(mask_sum(j+jdg_off))
237 if (mask_sum_r == 0.0 )
then ; i_mean(j) = 0.0 ;
else
238 i_mean(j) = efp_to_real(asum(j+jdg_off)) / mask_sum_r
244 do j=g%jsg,g%jeg ; asum(j) = real_to_efp(0.0) ;
enddo
246 do i=is,ie ;
do j=js,je
247 asum(j+jdg_off) = asum(j+jdg_off) + real_to_efp(scalefac*array(i,j))
251 "global_i_mean overflow error occurred before sum across PEs.")
253 call efp_list_sum_across_pes(asum(g%jsg:g%jeg), g%jeg-g%jsg+1)
256 "global_i_mean overflow error occurred during sum across PEs.")
259 i_mean(j) = efp_to_real(asum(j+jdg_off)) / real(g%ieg-g%isg+1)
263 if (unscale /= 1.0)
then ;
do j=js,je ; i_mean(j) = unscale*i_mean(j) ;
enddo ;
endif
271 subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale)
273 real,
dimension(SZI_(G),SZJ_(G)),
intent(in) :: array
274 real,
dimension(SZI_(G)),
intent(out) :: j_mean
275 real,
dimension(SZI_(G),SZJ_(G)), &
276 optional,
intent(in) :: mask
277 real,
optional,
intent(in) :: scale
278 real,
optional,
intent(in) :: tmp_scale
282 type(
efp_type),
allocatable,
dimension(:) :: asum, mask_sum
286 integer :: is, ie, js, je, idg_off, jdg_off
289 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
290 idg_off = g%idg_offset ; jdg_off = g%jdg_offset
292 scalefac = 1.0 ;
if (
present(scale)) scalefac = scale
294 if (
present(tmp_scale))
then ;
if (tmp_scale /= 0.0)
then
295 scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale
299 allocate(asum(g%isg:g%ieg))
300 if (
present(mask))
then
301 allocate (mask_sum(g%isg:g%ieg))
304 asum(i) = real_to_efp(0.0) ; mask_sum(i) = real_to_efp(0.0)
307 do i=is,ie ;
do j=js,je
308 asum(i+idg_off) = asum(i+idg_off) + real_to_efp(scalefac*array(i,j)*mask(i,j))
309 mask_sum(i+idg_off) = mask_sum(i+idg_off) + real_to_efp(mask(i,j))
313 "global_j_mean overflow error occurred before sums across PEs.")
315 call efp_list_sum_across_pes(asum(g%isg:g%ieg), g%ieg-g%isg+1)
316 call efp_list_sum_across_pes(mask_sum(g%isg:g%ieg), g%ieg-g%isg+1)
319 "global_j_mean overflow error occurred during sums across PEs.")
322 mask_sum_r = efp_to_real(mask_sum(i+idg_off))
323 if (mask_sum_r == 0.0 )
then ; j_mean(i) = 0.0 ;
else
324 j_mean(i) = efp_to_real(asum(i+idg_off)) / mask_sum_r
330 do i=g%isg,g%ieg ; asum(i) = real_to_efp(0.0) ;
enddo
332 do i=is,ie ;
do j=js,je
333 asum(i+idg_off) = asum(i+idg_off) + real_to_efp(scalefac*array(i,j))
337 "global_j_mean overflow error occurred before sum across PEs.")
339 call efp_list_sum_across_pes(asum(g%isg:g%ieg), g%ieg-g%isg+1)
342 "global_j_mean overflow error occurred during sum across PEs.")
345 j_mean(i) = efp_to_real(asum(i+idg_off)) / real(g%jeg-g%jsg+1)
349 if (unscale /= 1.0)
then ;
do i=is,ie ; j_mean(i) = unscale*j_mean(i) ;
enddo ;
endif
358 real,
dimension(SZI_(G),SZJ_(G)),
intent(inout) :: array
359 real,
optional,
intent(out) :: scaling
360 real,
optional,
intent(in) :: unit_scale
362 real,
dimension(SZI_(G), SZJ_(G)) :: posvals, negvals, areaxposvals, areaxnegvals
366 real :: areaintposvals, areaintnegvals, posscale, negscale
368 scalefac = 1.0 ;
if (
present(unit_scale)) scalefac = unit_scale
369 i_scalefac = 0.0 ;
if (scalefac /= 0.0) i_scalefac = 1.0 / scalefac
371 areaxposvals(:,:) = 0.
372 areaxnegvals(:,:) = 0.
374 do j=g%jsc,g%jec ;
do i=g%isc,g%iec
375 posvals(i,j) = max(0., scalefac*array(i,j))
376 areaxposvals(i,j) = g%US%L_to_m**2*g%areaT(i,j) * posvals(i,j)
377 negvals(i,j) = min(0., scalefac*array(i,j))
378 areaxnegvals(i,j) = g%US%L_to_m**2*g%areaT(i,j) * negvals(i,j)
384 posscale = 0.0 ; negscale = 0.0
385 if ((areaintposvals>0.).and.(areaintnegvals<0.))
then
386 if (areaintposvals>-areaintnegvals)
then
387 posscale = - areaintnegvals / areaintposvals
388 do j=g%jsc,g%jec ;
do i=g%isc,g%iec
389 array(i,j) = ((posscale * posvals(i,j)) + negvals(i,j)) * i_scalefac
391 elseif (areaintposvals<-areaintnegvals)
then
392 negscale = - areaintposvals / areaintnegvals
393 do j=g%jsc,g%jec ;
do i=g%isc,g%iec
394 array(i,j) = (posvals(i,j) + (negscale * negvals(i,j))) * i_scalefac
398 if (
present(scaling)) scaling = posscale - negscale