7 use mom_coms,
only : max_across_pes, min_across_pes
8 use mom_cpu_clock,
only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
11 use mom_domains,
only : root_pe, to_all, scalar_pair, cgrid_ne, agrid
19 use mom_io,
only : open_file, read_data, read_axis_data, single_file, multiple
24 use mom_time_manager,
only : get_external_field_axes, get_external_field_missing
26 use mpp_io_mod,
only : axistype
27 use mpp_domains_mod,
only : mpp_global_field, mpp_get_compute_domain
28 use mpp_mod,
only : mpp_broadcast,mpp_root_pe,mpp_sync,mpp_sync_self
29 use mpp_mod,
only : mpp_max
30 use horiz_interp_mod,
only : horiz_interp_new, horiz_interp,horiz_interp_type
31 use horiz_interp_mod,
only : horiz_interp_init, horiz_interp_del
33 use mpp_io_mod,
only : mpp_get_axis_data
34 use mpp_io_mod,
only : mpp_single
37 implicit none ;
private
39 #include <MOM_memory.h>
47 module procedure fill_boundaries_real
48 module procedure fill_boundaries_int
53 module procedure horiz_interp_and_extrap_tracer_record
54 module procedure horiz_interp_and_extrap_tracer_fms_id
60 subroutine mystats(array, missing, is, ie, js, je, k, mesg)
61 real,
dimension(:,:),
intent(in) :: array
62 real,
intent(in) :: missing
65 integer :: is,ie,js,je
68 character(len=*) :: mesg
73 character(len=120) :: lmesg
74 mina = 9.e24 ; maxa = -9.e24 ; found = .false.
76 do j=js,je ;
do i=is,ie
77 if (array(i,j) /= array(i,j)) stop
'Nan!'
78 if (abs(array(i,j)-missing) > 1.e-6*abs(missing))
then
80 mina = min(mina, array(i,j))
81 maxa = max(maxa, array(i,j))
89 call min_across_pes(mina)
90 call max_across_pes(maxa)
91 if (is_root_pe())
then
92 write(lmesg(1:120),
'(2(a,es12.4),a,i3,x,a)') &
93 'init_from_Z: min=',mina,
' max=',maxa,
' Level=',k,trim(mesg)
94 call mom_mesg(lmesg,2)
97 end subroutine mystats
104 subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, keep_bug, debug)
108 real,
dimension(SZI_(G),SZJ_(G)), &
109 intent(inout) :: aout
110 real,
dimension(SZI_(G),SZJ_(G)), &
113 real,
dimension(SZI_(G),SZJ_(G)), &
116 real,
dimension(SZI_(G),SZJ_(G)), &
117 optional,
intent(in) :: prev
118 logical,
optional,
intent(in) :: smooth
120 integer,
optional,
intent(in) :: num_pass
121 real,
optional,
intent(in) :: relc
122 real,
optional,
intent(in) :: crit
123 logical,
optional,
intent(in) :: keep_bug
125 logical,
optional,
intent(in) :: debug
128 real,
dimension(SZI_(G),SZJ_(G)) :: b,r
129 real,
dimension(SZI_(G),SZJ_(G)) :: fill_pts, good_, good_new
131 character(len=256) :: mesg
133 real :: east,west,north,south,sor
134 real :: ge,gw,gn,gs,ngood
135 logical :: do_smooth,siena_bug
136 real :: nfill, nfill_prev
137 integer,
parameter :: num_pass_default = 10000
138 real,
parameter :: relc_default = 0.25, crit_default = 1.e-3
141 integer :: is, ie, js, je
142 real :: relax_coeff, acrit, ares
146 if (
PRESENT(debug)) debug_it=debug
148 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
150 npass = num_pass_default
151 if (
PRESENT(num_pass)) npass = num_pass
153 relax_coeff = relc_default
154 if (
PRESENT(relc)) relax_coeff = relc
157 if (
PRESENT(crit)) acrit = crit
160 if (
PRESENT(keep_bug)) siena_bug = keep_bug
163 if (
PRESENT(smooth)) do_smooth=smooth
165 fill_pts(:,:) = fill(:,:)
167 nfill = sum(fill(is:ie,js:je))
168 call sum_across_pes(nfill)
171 good_(:,:) = good(:,:)
174 do while (nfill > 0.0)
180 good_new(:,:)=good_(:,:)
182 do j=js,je ;
do i=is,ie
184 if (good_(i,j) == 1.0 .or. fill(i,j) == 0.) cycle
186 ge=good_(i+1,j) ; gw=good_(i-1,j)
187 gn=good_(i,j+1) ; gs=good_(i,j-1)
188 east=0.0 ; west=0.0 ; north=0.0 ; south=0.0
189 if (ge == 1.0) east = aout(i+1,j)*ge
190 if (gw == 1.0) west = aout(i-1,j)*gw
191 if (gn == 1.0) north = aout(i,j+1)*gn
192 if (gs == 1.0) south = aout(i,j-1)*gs
196 b(i,j)=(east+west+north+south)/ngood
204 aout(is:ie,js:je) = b(is:ie,js:je)
205 good_(is:ie,js:je) = good_new(is:ie,js:je)
207 nfill = sum(fill_pts(is:ie,js:je))
208 call sum_across_pes(nfill)
210 if (nfill == nfill_prev .and.
PRESENT(prev))
then
211 do j=js,je ;
do i=is,ie ;
if (fill_pts(i,j) == 1.0)
then
212 aout(i,j) = prev(i,j)
214 endif ;
enddo ;
enddo
215 elseif (nfill == nfill_prev)
then
216 call mom_error(warning, &
217 'Unable to fill missing points using either data at the same vertical level from a connected basin'//&
218 'or using a point from a previous vertical level. Make sure that the original data has some valid'//&
219 'data in all basins.', .true.)
220 write(mesg,*)
'nfill=',nfill
221 call mom_error(warning, mesg, .true.)
224 nfill = sum(fill_pts(is:ie,js:je))
225 call sum_across_pes(nfill)
229 if (do_smooth)
then ;
do k=1,npass
231 do j=js,je ;
do i=is,ie
232 if (fill(i,j) == 1)
then
233 east = max(good(i+1,j),fill(i+1,j)) ; west = max(good(i-1,j),fill(i-1,j))
234 north = max(good(i,j+1),fill(i,j+1)) ; south = max(good(i,j-1),fill(i,j-1))
235 r(i,j) = relax_coeff*(south*aout(i,j-1)+north*aout(i,j+1) + &
236 west*aout(i-1,j)+east*aout(i+1,j) - &
237 (south+north+west+east)*aout(i,j))
247 do j=js,je ;
do i=is,ie
248 aout(i,j) = r(i,j) + aout(i,j)
249 ares = max(ares, abs(r(i,j)))
251 call max_across_pes(ares)
252 if (ares <= acrit)
exit
255 do j=js,je ;
do i=is,ie
256 if (good_(i,j) == 0.0 .and. fill_pts(i,j) == 1.0)
then
257 write(mesg,*)
'In fill_miss, fill, good,i,j= ',fill_pts(i,j),good_(i,j),i,j
258 call mom_error(warning, mesg, .true.)
259 call mom_error(fatal,
"MOM_initialize: "// &
260 "fill is true and good is false after fill_miss, how did this happen? ")
264 end subroutine fill_miss_2d
267 subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, &
268 mask_z, z_in, z_edges_in, missing_value, reentrant_x, &
269 tripolar_n, homogenize, m_to_Z)
271 character(len=*),
intent(in) :: filename
273 character(len=*),
intent(in) :: varnam
274 real,
intent(in) :: conversion
275 integer,
intent(in) :: recnum
277 real,
allocatable,
dimension(:,:,:) :: tr_z
279 real,
allocatable,
dimension(:,:,:) :: mask_z
281 real,
allocatable,
dimension(:) :: z_in
282 real,
allocatable,
dimension(:) :: z_edges_in
283 real,
intent(out) :: missing_value
284 logical,
intent(in) :: reentrant_x
285 logical,
intent(in) :: tripolar_n
286 logical,
optional,
intent(in) :: homogenize
288 real,
optional,
intent(in) :: m_to_Z
292 real,
dimension(:,:),
allocatable :: tr_in, tr_inp
295 real,
dimension(:,:),
allocatable :: mask_in
298 integer :: rcode, ncid, varid, ndims, id, jd, kd, jdp
300 integer,
dimension(4) :: start, count, dims, dim_id
301 real,
dimension(:,:),
allocatable :: x_in, y_in
302 real,
dimension(:),
allocatable :: lon_in, lat_in
303 real,
dimension(:),
allocatable :: lat_inp, last_row
304 real :: max_lat, min_lat, pole, max_depth, npole
306 real :: add_offset, scale_factor
308 character(len=8) :: laynum
309 type(horiz_interp_type) :: Interp
310 integer :: is, ie, js, je
311 integer :: isc,iec,jsc,jec
312 integer :: isg, ieg, jsg, jeg
313 integer :: isd, ied, jsd, jed
314 integer :: id_clock_read
315 character(len=12) :: dim_name(4)
316 logical :: debug=.false.
317 real :: npoints,varAvg
318 real,
dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out, tr_out, mask_out
319 real,
dimension(SZI_(G),SZJ_(G)) :: good, fill
320 real,
dimension(SZI_(G),SZJ_(G)) :: tr_outf,tr_prev
321 real,
dimension(SZI_(G),SZJ_(G)) :: good2,fill2
322 real,
dimension(SZI_(G),SZJ_(G)) :: nlevs
324 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
325 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
326 isg = g%isg ; ieg = g%ieg ; jsg = g%jsg ; jeg = g%jeg
328 id_clock_read = cpu_clock_id(
'(Initialize tracer from Z) read', grain=clock_loop)
331 if (
allocated(tr_z))
deallocate(tr_z)
332 if (
allocated(mask_z))
deallocate(mask_z)
333 if (
allocated(z_edges_in))
deallocate(z_edges_in)
340 call cpu_clock_begin(id_clock_read)
343 rcode = nf90_open(filename, nf90_nowrite, ncid)
344 if (rcode /= 0)
call mom_error(fatal,
"error opening file "//trim(filename)//&
345 " in hinterp_extrap")
346 rcode = nf90_inq_varid(ncid, varnam, varid)
347 if (rcode /= 0)
call mom_error(fatal,
"error finding variable "//trim(varnam)//&
348 " in file "//trim(filename)//
" in hinterp_extrap")
350 rcode = nf90_inquire_variable(ncid, varid, ndims=ndims, dimids=dims)
351 if (rcode /= 0)
call mom_error(fatal,
'error inquiring dimensions hinterp_extrap')
352 if (ndims < 3)
call mom_error(fatal,
"Variable "//trim(varnam)//
" in file "// &
353 trim(filename)//
" has too few dimensions.")
355 rcode = nf90_inquire_dimension(ncid, dims(1), dim_name(1), len=id)
356 if (rcode /= 0)
call mom_error(fatal,
"error reading dimension 1 data for "// &
357 trim(varnam)//
" in file "// trim(filename)//
" in hinterp_extrap")
358 rcode = nf90_inq_varid(ncid, dim_name(1), dim_id(1))
359 if (rcode /= 0)
call mom_error(fatal,
"error finding variable "//trim(dim_name(1))//&
360 " in file "//trim(filename)//
" in hinterp_extrap")
361 rcode = nf90_inquire_dimension(ncid, dims(2), dim_name(2), len=jd)
362 if (rcode /= 0)
call mom_error(fatal,
"error reading dimension 2 data for "// &
363 trim(varnam)//
" in file "// trim(filename)//
" in hinterp_extrap")
364 rcode = nf90_inq_varid(ncid, dim_name(2), dim_id(2))
365 if (rcode /= 0)
call mom_error(fatal,
"error finding variable "//trim(dim_name(2))//&
366 " in file "//trim(filename)//
" in hinterp_extrap")
367 rcode = nf90_inquire_dimension(ncid, dims(3), dim_name(3), len=kd)
368 if (rcode /= 0)
call mom_error(fatal,
"error reading dimension 3 data for "// &
369 trim(varnam)//
" in file "// trim(filename)//
" in hinterp_extrap")
370 rcode = nf90_inq_varid(ncid, dim_name(3), dim_id(3))
371 if (rcode /= 0)
call mom_error(fatal,
"error finding variable "//trim(dim_name(3))//&
372 " in file "//trim(filename)//
" in hinterp_extrap")
376 rcode = nf90_get_att(ncid, varid,
"_FillValue", missing_value)
377 if (rcode /= 0)
call mom_error(fatal,
"error finding missing value for "//&
378 trim(varnam)//
" in file "// trim(filename)//
" in hinterp_extrap")
380 rcode = nf90_get_att(ncid, varid,
"add_offset", add_offset)
381 if (rcode /= 0) add_offset = 0.0
383 rcode = nf90_get_att(ncid, varid,
"scale_factor", scale_factor)
384 if (rcode /= 0) scale_factor = 1.0
387 if (
allocated(lon_in))
deallocate(lon_in)
388 if (
allocated(lat_in))
deallocate(lat_in)
389 if (
allocated(z_in))
deallocate(z_in)
390 if (
allocated(z_edges_in))
deallocate(z_edges_in)
391 if (
allocated(tr_z))
deallocate(tr_z)
392 if (
allocated(mask_z))
deallocate(mask_z)
395 allocate(lon_in(id),lat_in(jd),z_in(kd),z_edges_in(kd+1))
396 allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd))
398 start = 1; count = 1; count(1) = id
399 rcode = nf90_get_var(ncid, dim_id(1), lon_in, start, count)
400 if (rcode /= 0)
call mom_error(fatal,
"error reading dimension 1 values for var_name "// &
401 trim(varnam)//
",dim_name "//trim(dim_name(1))//
" in file "// trim(filename)//
" in hinterp_extrap")
402 start = 1; count = 1; count(1) = jd
403 rcode = nf90_get_var(ncid, dim_id(2), lat_in, start, count)
404 if (rcode /= 0)
call mom_error(fatal,
"error reading dimension 2 values for var_name "// &
405 trim(varnam)//
",dim_name "//trim(dim_name(2))//
" in file "// trim(filename)//
" in hinterp_extrap")
406 start = 1; count = 1; count(1) = kd
407 rcode = nf90_get_var(ncid, dim_id(3), z_in, start, count)
408 if (rcode /= 0)
call mom_error(fatal,
"error reading dimension 3 values for var_name "// &
409 trim(varnam//
",dim_name "//trim(dim_name(3)))//
" in file "// trim(filename)//
" in hinterp_extrap")
411 call cpu_clock_end(id_clock_read)
413 if (
present(m_to_z))
then ;
do k=1,kd ; z_in(k) = m_to_z * z_in(k) ;
enddo ;
endif
417 max_lat = maxval(lat_in)
419 if (max_lat < 90.0)
then
422 allocate(lat_inp(jdp))
423 lat_inp(1:jd)=lat_in(:)
426 allocate(lat_in(1:jdp))
436 z_edges_in(k)=0.5*(z_in(k-1)+z_in(k))
438 z_edges_in(kd+1)=2.0*z_in(kd) - z_in(kd-1)
440 call horiz_interp_init()
442 lon_in = lon_in*pi_180
443 lat_in = lat_in*pi_180
444 allocate(x_in(id,jdp),y_in(id,jdp))
445 call meshgrid(lon_in,lat_in, x_in, y_in)
447 lon_out(:,:) = g%geoLonT(:,:)*pi_180
448 lat_out(:,:) = g%geoLatT(:,:)*pi_180
451 allocate(tr_in(id,jd)) ; tr_in(:,:)=0.0
452 allocate(tr_inp(id,jdp)) ; tr_inp(:,:)=0.0
453 allocate(mask_in(id,jdp)) ; mask_in(:,:)=0.0
454 allocate(last_row(id)) ; last_row(:)=0.0
456 max_depth = maxval(g%bathyT)
457 call mpp_max(max_depth)
459 if (z_edges_in(kd+1)<max_depth) z_edges_in(kd+1)=max_depth
466 roundoff = 3.0*epsilon(missing_value)
470 write(laynum,
'(I8)') k ; laynum = adjustl(laynum)
472 if (is_root_pe())
then
473 start = 1 ; start(3) = k ; count(:) = 1 ; count(1) = id ; count(2) = jd
474 rcode = nf90_get_var(ncid,varid, tr_in, start, count)
475 if (rcode /= 0)
call mom_error(fatal,
"hinterp_and_extract_from_Fie: "//&
476 "error reading level "//trim(laynum)//
" of variable "//&
477 trim(varnam)//
" in file "// trim(filename))
480 last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0
482 if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value))
then
483 pole = pole+last_row(i)
492 tr_inp(:,1:jd) = tr_in(:,:)
495 tr_inp(:,:) = tr_in(:,:)
501 call mpp_broadcast(tr_inp, id*jdp, root_pe())
508 if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value))
then
510 tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion
512 tr_inp(i,j) = missing_value
522 call horiz_interp_new(interp,x_in,y_in,lon_out(is:ie,js:je),lat_out(is:ie,js:je), &
523 interp_method=
'bilinear',src_modulo=reentrant_x)
527 call mystats(tr_inp,missing_value, is,ie,js,je,k,
'Tracer from file')
532 call horiz_interp(interp,tr_inp,tr_out(is:ie,js:je), missing_value=missing_value, new_missing_handle=.true.)
537 if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j)=0.
541 fill = 0.0; good = 0.0
543 npoints = 0 ; varavg = 0.
546 if (mask_out(i,j) < 1.0)
then
547 tr_out(i,j)=missing_value
550 npoints = npoints + 1
551 varavg = varavg + tr_out(i,j)
553 if (g%mask2dT(i,j) == 1.0 .and. z_edges_in(k) <= g%bathyT(i,j) .and. mask_out(i,j) < 1.0) &
561 call mystats(tr_out,missing_value, is,ie,js,je,k,
'variable from horiz_interp()')
565 if (
PRESENT(homogenize))
then
567 call sum_across_pes(npoints)
568 call sum_across_pes(varavg)
570 varavg = varavg/real(npoints)
579 tr_outf(:,:) = tr_out(:,:)
580 if (k==1) tr_prev(:,:) = tr_outf(:,:)
581 good2(:,:) = good(:,:)
582 fill2(:,:) = fill(:,:)
584 call fill_miss_2d(tr_outf, good2, fill2, tr_prev, g, smooth=.true.)
585 call mystats(tr_outf, missing_value, is, ie, js, je, k,
'field from fill_miss_2d()')
587 tr_z(:,:,k) = tr_outf(:,:) * g%mask2dT(:,:)
588 mask_z(:,:,k) = good2(:,:) + fill2(:,:)
590 tr_prev(:,:) = tr_z(:,:,k)
593 call hchksum(tr_prev,
'field after fill ',g%HI)
598 end subroutine horiz_interp_and_extrap_tracer_record
601 subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, tr_z, mask_z, &
602 z_in, z_edges_in, missing_value, reentrant_x, &
603 tripolar_n, homogenize, m_to_Z)
605 integer,
intent(in) :: fms_id
606 type(time_type),
intent(in) :: Time
607 real,
intent(in) :: conversion
609 real,
allocatable,
dimension(:,:,:) :: tr_z
611 real,
allocatable,
dimension(:,:,:) :: mask_z
613 real,
allocatable,
dimension(:) :: z_in
614 real,
allocatable,
dimension(:) :: z_edges_in
615 real,
intent(out) :: missing_value
616 logical,
intent(in) :: reentrant_x
617 logical,
intent(in) :: tripolar_n
618 logical,
optional,
intent(in) :: homogenize
620 real,
optional,
intent(in) :: m_to_Z
624 real,
dimension(:,:),
allocatable :: tr_in,tr_inp
627 real,
dimension(:,:,:),
allocatable :: data_in
629 real,
dimension(:,:),
allocatable :: mask_in
632 integer :: rcode, ncid, varid, ndims, id, jd, kd, jdp
634 integer,
dimension(4) :: start, count, dims, dim_id
635 real,
dimension(:,:),
allocatable :: x_in, y_in
636 real,
dimension(:),
allocatable :: lon_in, lat_in
637 real,
dimension(:),
allocatable :: lat_inp, last_row
638 real :: max_lat, min_lat, pole, max_depth, npole
641 character(len=8) :: laynum
642 type(horiz_interp_type) :: Interp
643 type(axistype),
dimension(4) :: axes_data
644 integer :: is, ie, js, je
645 integer :: isc,iec,jsc,jec
646 integer :: isg, ieg, jsg, jeg
647 integer :: isd, ied, jsd, jed
648 integer :: id_clock_read
649 integer,
dimension(4) :: fld_sz
650 character(len=12) :: dim_name(4)
651 logical :: debug=.false.
652 real :: npoints,varAvg
653 real,
dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out, tr_out, mask_out
654 real,
dimension(SZI_(G),SZJ_(G)) :: good, fill
655 real,
dimension(SZI_(G),SZJ_(G)) :: tr_outf,tr_prev
656 real,
dimension(SZI_(G),SZJ_(G)) :: good2,fill2
657 real,
dimension(SZI_(G),SZJ_(G)) :: nlevs
659 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
660 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
661 isg = g%isg ; ieg = g%ieg ; jsg = g%jsg ; jeg = g%jeg
663 id_clock_read = cpu_clock_id(
'(Initialize tracer from Z) read', grain=clock_loop)
671 call cpu_clock_begin(id_clock_read)
673 fld_sz = get_external_field_size(fms_id)
675 if (
allocated(lon_in))
deallocate(lon_in)
676 if (
allocated(lat_in))
deallocate(lat_in)
677 if (
allocated(z_in))
deallocate(z_in)
678 if (
allocated(z_edges_in))
deallocate(z_edges_in)
679 if (
allocated(tr_z))
deallocate(tr_z)
680 if (
allocated(mask_z))
deallocate(mask_z)
682 axes_data = get_external_field_axes(fms_id)
684 id = fld_sz(1) ; jd = fld_sz(2) ; kd = fld_sz(3)
685 allocate(lon_in(id),lat_in(jd),z_in(kd),z_edges_in(kd+1))
686 allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd))
688 call mpp_get_axis_data(axes_data(1), lon_in)
689 call mpp_get_axis_data(axes_data(2), lat_in)
690 call mpp_get_axis_data(axes_data(3), z_in)
692 if (
present(m_to_z))
then ;
do k=1,kd ; z_in(k) = m_to_z * z_in(k) ;
enddo ;
endif
694 call cpu_clock_end(id_clock_read)
696 missing_value = get_external_field_missing(fms_id)
701 max_lat = maxval(lat_in)
703 if (max_lat < 90.0)
then
706 allocate(lat_inp(jdp))
707 lat_inp(1:jd) = lat_in(:)
710 allocate(lat_in(1:jdp))
711 lat_in(:) = lat_inp(:)
720 z_edges_in(k) = 0.5*(z_in(k-1)+z_in(k))
722 z_edges_in(kd+1) = 2.0*z_in(kd) - z_in(kd-1)
724 call horiz_interp_init()
726 lon_in = lon_in*pi_180
727 lat_in = lat_in*pi_180
728 allocate(x_in(id,jdp), y_in(id,jdp))
729 call meshgrid(lon_in, lat_in, x_in, y_in)
731 lon_out(:,:) = g%geoLonT(:,:)*pi_180
732 lat_out(:,:) = g%geoLatT(:,:)*pi_180
734 allocate(data_in(id,jd,kd)) ; data_in(:,:,:)=0.0
735 allocate(tr_in(id,jd)) ; tr_in(:,:)=0.0
736 allocate(tr_inp(id,jdp)) ; tr_inp(:,:)=0.0
737 allocate(mask_in(id,jdp)) ; mask_in(:,:)=0.0
738 allocate(last_row(id)) ; last_row(:)=0.0
740 max_depth = maxval(g%bathyT)
741 call mpp_max(max_depth)
743 if (z_edges_in(kd+1)<max_depth) z_edges_in(kd+1)=max_depth
746 call time_interp_external(fms_id, time, data_in, verbose=.true.)
756 write(laynum,
'(I8)') k ; laynum = adjustl(laynum)
758 if (is_root_pe())
then
759 tr_in(1:id,1:jd) = data_in(1:id,1:jd,k)
761 last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0
763 if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value))
then
764 pole = pole+last_row(i)
773 tr_inp(:,1:jd) = tr_in(:,:)
776 tr_inp(:,:) = tr_in(:,:)
782 call mpp_broadcast(tr_inp, id*jdp, root_pe())
787 do j=1,jdp ;
do i=1,id
788 if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value))
then
790 tr_inp(i,j) = tr_inp(i,j) * conversion
792 tr_inp(i,j) = missing_value
798 call horiz_interp_new(interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), &
799 interp_method=
'bilinear', src_modulo=reentrant_x)
803 call mystats(tr_in, missing_value, 1, id, 1, jd, k,
'Tracer from file')
808 call horiz_interp(interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value, &
809 new_missing_handle=.true.)
812 do j=js,je ;
do i=is,ie
813 if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j) = 0.
816 fill(:,:) = 0.0 ; good(:,:) = 0.0
818 npoints = 0 ; varavg = 0.
819 do j=js,je ;
do i=is,ie
820 if (mask_out(i,j) < 1.0)
then
821 tr_out(i,j) = missing_value
824 npoints = npoints + 1
825 varavg = varavg + tr_out(i,j)
827 if ((g%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= g%bathyT(i,j)) .and. &
828 (mask_out(i,j) < 1.0)) &
835 call mystats(tr_out, missing_value, is, ie, js, je, k,
'variable from horiz_interp()')
839 if (
PRESENT(homogenize))
then ;
if (homogenize)
then
840 call sum_across_pes(npoints)
841 call sum_across_pes(varavg)
843 varavg = varavg/real(npoints)
851 tr_outf(:,:) = tr_out(:,:)
852 if (k==1) tr_prev(:,:) = tr_outf(:,:)
853 good2(:,:) = good(:,:)
854 fill2(:,:) = fill(:,:)
856 call fill_miss_2d(tr_outf, good2, fill2, tr_prev, g, smooth=.true.)
864 tr_z(:,:,k) = tr_outf(:,:)*g%mask2dT(:,:)
865 mask_z(:,:,k) = good2(:,:) + fill2(:,:)
866 tr_prev(:,:) = tr_z(:,:,k)
869 call hchksum(tr_prev,
'field after fill ',g%HI)
874 end subroutine horiz_interp_and_extrap_tracer_fms_id
879 subroutine meshgrid(x, y, x_T, y_T)
880 real,
dimension(:),
intent(in) :: x
881 real,
dimension(:),
intent(in) :: y
882 real,
dimension(size(x,1),size(y,1)),
intent(inout) :: x_T
883 real,
dimension(size(x,1),size(y,1)),
intent(inout) :: y_T
887 ni=
size(x,1) ; nj=
size(y,1)
889 do j=1,nj ;
do i=1,ni
893 do j=1,nj ;
do i=1,ni
897 end subroutine meshgrid
902 function fill_boundaries_int(m,cyclic_x,tripolar_n)
result(mp)
903 integer,
dimension(:,:),
intent(in) :: m
904 logical,
intent(in) :: cyclic_x
905 logical,
intent(in) :: tripolar_n
906 integer,
dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp
908 real,
dimension(size(m,1),size(m,2)) :: m_real
909 real,
dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp_real
913 mp_real = fill_boundaries_real(m_real,cyclic_x,tripolar_n)
917 end function fill_boundaries_int
920 function fill_boundaries_real(m,cyclic_x,tripolar_n)
result(mp)
921 real,
dimension(:,:),
intent(in) :: m
922 logical,
intent(in) :: cyclic_x
923 logical,
intent(in) :: tripolar_n
924 real,
dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp
928 ni=
size(m,1); nj=
size(m,2)
933 mp(0,1:nj)=m(ni,1:nj)
934 mp(ni+1,1:nj)=m(1,1:nj)
937 mp(ni+1,1:nj)=m(ni,1:nj)
943 mp(i,nj+1)=m(ni-i+1,nj)
946 mp(1:ni,nj+1)=m(1:ni,nj)
949 end function fill_boundaries_real
957 subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n)
958 real,
dimension(:,:),
intent(inout) :: zi
959 integer,
dimension(size(zi,1),size(zi,2)),
intent(in) :: fill
960 integer,
dimension(size(zi,1),size(zi,2)),
intent(in) :: bad
961 real,
intent(in) :: sor
962 integer,
intent(in) :: niter
963 logical,
intent(in) :: cyclic_x
964 logical,
intent(in) :: tripolar_n
967 real,
dimension(size(zi,1),size(zi,2)) :: res, m
968 integer,
dimension(size(zi,1),size(zi,2),4) :: B
969 real,
dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: mp
970 integer,
dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: nm
975 ni=
size(zi,1) ; nj=
size(zi,2)
985 if (fill(i,j) == 1)
then
986 b(i,j,1)=1-nm(i+1,j);b(i,j,2)=1-nm(i-1,j)
987 b(i,j,3)=1-nm(i,j+1);b(i,j,4)=1-nm(i,j-1)
995 if (fill(i,j) == 1)
then
996 bsum = real(b(i,j,1)+b(i,j,2)+b(i,j,3)+b(i,j,4))
998 res(i,j)=isum*(b(i,j,1)*mp(i+1,j)+b(i,j,2)*mp(i-1,j)+&
999 b(i,j,3)*mp(i,j+1)+b(i,j,4)*mp(i,j-1)) - mp(i,j)
1003 res(:,:)=res(:,:)*sor
1007 mp(i,j)=mp(i,j)+res(i,j)
1011 zi(:,:)=mp(1:ni,1:nj)
1015 end subroutine smooth_heights