52 function get_topog_mean_1d_(blon, blat, zmean)
54 real(kind=fms_top_kind_),
intent(in),
dimension(:) :: blon
55 real(kind=fms_top_kind_),
intent(in),
dimension(:) :: blat
56 real(kind=fms_top_kind_),
intent(out),
dimension(:,:) :: zmean
58 logical :: GET_TOPOG_MEAN_1D_
59 integer,
parameter :: lkind = fms_top_kind_
62 if (.not. module_is_initialized)
call topography_init()
64 if ( any(shape(zmean(:,:)) /= (/
size(blon(:))-1,
size(blat(:))-1/)) ) &
65 call error_mesg(
'get_topog_mean_1d',
'shape(zmean) is not&
66 & equal to (/size(blon)-1,size(blat)-1/))', fatal)
68 get_topog_mean_1d_ = open_topog_file()
70 if (get_topog_mean_1d_)
call interp_topog(blon, blat, zmean)
74 end function get_topog_mean_1d_
78 function get_topog_mean_2d_(blon, blat, zmean)
80 real(kind=fms_top_kind_),
intent(in),
dimension(:,:) :: blon, blat
81 real(kind=fms_top_kind_),
intent(out),
dimension(:,:) :: zmean
82 logical :: GET_TOPOG_MEAN_2D_
83 integer,
parameter :: lkind = fms_top_kind_
85 if (.not. module_is_initialized)
call topography_init()
87 if ( any(shape(zmean(:,:)) /= (/
size(blon,1)-1,
size(blon,2)-1/)) .or. &
88 any(shape(zmean(:,:)) /= (/
size(blat,1)-1,
size(blat,2)-1/)) ) &
89 call error_mesg(
'get_topog_mean_2d',
'shape(zmean) is not&
90 & equal to (/size(blon,1)-1,size(blon,2)-1/))', fatal)
92 get_topog_mean_2d_ = open_topog_file()
94 if (get_topog_mean_2d_)
call interp_topog(blon, blat, zmean)
97 end function get_topog_mean_2d_
110 function get_topog_stdev_1d_(blon, blat, stdev)
112 real(kind=fms_top_kind_),
intent(in),
dimension(:) :: blon
113 real(kind=fms_top_kind_),
intent(in),
dimension(:) :: blat
114 real(kind=fms_top_kind_),
intent(out),
dimension(:,:) :: stdev
117 logical :: GET_TOPOG_STDEV_1D_
118 integer,
parameter :: lkind = fms_top_kind_
120 if (.not. module_is_initialized)
call topography_init()
122 if ( any(shape(stdev(:,:)) /= (/
size(blon(:))-1,
size(blat(:))-1/)) ) &
123 call error_mesg(
'get_topog_stdev',
'shape(stdev) is not&
124 & equal to (/size(blon)-1,size(blat)-1/))', fatal)
126 get_topog_stdev_1d_ = open_topog_file()
128 if (get_topog_stdev_1d_)
call interp_topog(blon, blat, &
129 stdev, flag=compute_stdev)
133 end function get_topog_stdev_1d_
137 function get_topog_stdev_2d_(blon, blat, stdev)
139 real(FMS_TOP_KIND_),
intent(in),
dimension(:,:) :: blon, blat
140 real(FMS_TOP_KIND_),
intent(out),
dimension(:,:) :: stdev
141 logical :: GET_TOPOG_STDEV_2D_
142 integer,
parameter :: lkind = fms_top_kind_
144 if (.not. module_is_initialized)
call topography_init()
146 if ( any(shape(stdev(:,:)) /= (/
size(blon,1)-1,
size(blon,2)-1/)) .or. &
147 any(shape(stdev(:,:)) /= (/
size(blat,1)-1,
size(blat,2)-1/)) ) &
148 call error_mesg(
'get_topog_stdev_2d',
'shape(stdev) is not&
149 & equal to (/size(blon,1)-1,size(blon,2)-1/))', fatal)
151 get_topog_stdev_2d_ = open_topog_file()
153 if (get_topog_stdev_2d_)
call interp_topog(blon, blat, &
154 stdev, flag=compute_stdev)
157 end function get_topog_stdev_2d_
164 function get_ocean_frac_1d_(blon, blat, ocean_frac)
166 real(FMS_TOP_KIND_),
intent(in),
dimension(:) :: blon
167 real(FMS_TOP_KIND_),
intent(in),
dimension(:) :: blat
168 real(FMS_TOP_KIND_),
intent(out),
dimension(:,:) :: ocean_frac
170 logical :: GET_OCEAN_FRAC_1D_
171 integer,
parameter :: lkind = fms_top_kind_
173 if (.not. module_is_initialized)
call topography_init()
175 if ( any(shape(ocean_frac(:,:)) /= (/
size(blon(:))-1,
size(blat(:))-1/)) ) &
176 call error_mesg(
'get_ocean_frac',
'shape(ocean_frac) is not&
177 & equal to (/size(blon)-1,size(blat)-1/))', fatal)
179 get_ocean_frac_1d_ = open_water_file()
180 if(get_ocean_frac_1d_)
call interp_water( blon, blat, &
181 ocean_frac, do_ocean=.true. )
185 end function get_ocean_frac_1d_
189 function get_ocean_frac_2d_(blon, blat, ocean_frac)
191 real(kind=fms_top_kind_),
intent(in),
dimension(:,:) :: blon, blat
192 real(kind=fms_top_kind_),
intent(out),
dimension(:,:) :: ocean_frac
193 logical :: GET_OCEAN_FRAC_2D_
194 integer,
parameter :: lkind = fms_top_kind_
196 if (.not. module_is_initialized)
call topography_init()
198 if ( any(shape(ocean_frac(:,:)) /= (/
size(blon,1)-1,
size(blon,2)-1/)) .or. &
199 any(shape(ocean_frac(:,:)) /= (/
size(blat,1)-1,
size(blat,2)-1/)) ) &
200 call error_mesg(
'get_ocean_frac_2d',
'shape(ocean_frac) is not&
201 & equal to (/size(blon,1)-1,size(blon,2)-1/))', fatal)
203 get_ocean_frac_2d_ = open_water_file()
204 if(get_ocean_frac_2d_)
call interp_water( blon, blat, &
205 ocean_frac, do_ocean=.true. )
209 end function get_ocean_frac_2d_
216 function get_ocean_mask_1d_(blon, blat, ocean_mask)
218 real(kind=fms_top_kind_),
intent(in),
dimension(:) :: blon
219 real(kind=fms_top_kind_),
intent(in),
dimension(:) :: blat
220 logical,
intent(out),
dimension(:,:) :: ocean_mask
222 logical :: GET_OCEAN_MASK_1D_
223 real(kind=fms_top_kind_),
dimension(size(ocean_mask,1),size(ocean_mask,2)) :: ocean_frac
224 integer,
parameter :: lkind = fms_top_kind_
226 if (.not. module_is_initialized)
call topography_init()
228 if (get_ocean_frac(blon, blat, ocean_frac) )
then
229 where (ocean_frac > 0.50_lkind)
234 get_ocean_mask_1d_ = .true.
236 get_ocean_mask_1d_ = .false.
240 end function get_ocean_mask_1d_
244 function get_ocean_mask_2d_(blon, blat, ocean_mask)
246 real(kind=fms_top_kind_),
intent(in),
dimension(:,:) :: blon, blat
247 logical,
intent(out),
dimension(:,:) :: ocean_mask
248 logical :: GET_OCEAN_MASK_2D_
249 real(kind=fms_top_kind_),
dimension(size(ocean_mask,1),size(ocean_mask,2)) :: ocean_frac
250 integer,
parameter :: lkind = fms_top_kind_
252 if (.not. module_is_initialized)
call topography_init()
254 if (get_ocean_frac(blon, blat, ocean_frac) )
then
255 where (ocean_frac > 0.50_lkind)
260 get_ocean_mask_2d_ = .true.
262 get_ocean_mask_2d_ = .false.
267 end function get_ocean_mask_2d_
275 function get_water_frac_1d_(blon, blat, water_frac)
276 real(kind=fms_top_kind_),
intent(in),
dimension(:) :: blon
277 real(kind=fms_top_kind_),
intent(in),
dimension(:) :: blat
278 real(kind=fms_top_kind_),
intent(out),
dimension(:,:) :: water_frac
280 logical :: GET_WATER_FRAC_1D_
281 integer,
parameter :: lkind = fms_top_kind_
284 if (.not. module_is_initialized)
call topography_init()
286 if ( any(shape(water_frac(:,:)) /= (/
size(blon(:))-1,
size(blat(:))-1/)) ) &
287 call error_mesg(
'get_water_frac_1d',
'shape(water_frac) is not&
288 & equal to (/size(blon)-1,size(blat)-1/))', fatal)
290 get_water_frac_1d_ = open_water_file()
291 if(get_water_frac_1d_)
call interp_water( blon, blat, water_frac )
295 end function get_water_frac_1d_
299 function get_water_frac_2d_(blon, blat, water_frac)
301 real(kind=fms_top_kind_),
intent(in),
dimension(:,:) :: blon
302 real(kind=fms_top_kind_),
intent(in),
dimension(:,:) :: blat
303 real(kind=fms_top_kind_),
intent(out),
dimension(:,:) :: water_frac
305 logical :: GET_WATER_FRAC_2D_
306 integer,
parameter :: lkind = fms_top_kind_
309 if (.not. module_is_initialized)
call topography_init()
311 if ( any(shape(water_frac(:,:)) /= (/
size(blon,1)-1,
size(blon,2)-1/)) .or. &
312 any(shape(water_frac(:,:)) /= (/
size(blat,1)-1,
size(blat,2)-1/)) ) &
313 call error_mesg(
'get_water_frac_2d',
'shape(water_frac) is not&
314 & equal to (/size(blon,1)-1,size(blon,2)-1/))', fatal)
316 get_water_frac_2d_ = open_water_file()
317 if(get_water_frac_2d_)
call interp_water( blon, blat, water_frac )
321 end function get_water_frac_2d_
329 function get_water_mask_1d_(blon, blat, water_mask)
331 real(kind=fms_top_kind_),
intent(in),
dimension(:) :: blon
332 real(kind=fms_top_kind_),
intent(in),
dimension(:) :: blat
333 logical,
intent(out),
dimension(:,:) :: water_mask
335 logical :: GET_WATER_MASK_1D_
337 real(kind=fms_top_kind_),
dimension(size(water_mask,1),size(water_mask,2)) :: water_frac
338 integer,
parameter :: lkind = fms_top_kind_
340 if (.not. module_is_initialized)
call topography_init()
342 if (get_water_frac(blon, blat, water_frac) )
then
343 where (water_frac > 0.50_lkind)
348 get_water_mask_1d_ = .true.
350 get_water_mask_1d_ = .false.
354 end function get_water_mask_1d_
358 function get_water_mask_2d_(blon, blat, water_mask)
360 real(kind=fms_top_kind_),
intent(in),
dimension(:,:) :: blon
361 real(kind=fms_top_kind_),
intent(in),
dimension(:,:) :: blat
362 logical,
intent(out),
dimension(:,:) :: water_mask
364 logical :: GET_WATER_MASK_2D_
365 real(kind=fms_top_kind_),
dimension(size(water_mask,1),size(water_mask,2)) :: water_frac
366 integer,
parameter :: lkind = fms_top_kind_
368 if (.not. module_is_initialized)
call topography_init()
370 if (get_water_frac(blon, blat, water_frac) )
then
371 where (water_frac > 0.50_lkind)
376 get_water_mask_2d_ = .true.
378 get_water_mask_2d_ = .false.
383 end function get_water_mask_2d_
387 subroutine interp_topog_1d_( blon, blat, zout, flag)
388 real(kind=fms_top_kind_),
intent(in) :: blon(:), blat(:)
389 real(kind=fms_top_kind_),
intent(out) :: zout(:,:)
390 integer,
intent(in),
optional :: flag
392 real(kind=fms_top_kind_) :: xdat(ipts+1), ydat(jpts+1)
393 real(kind=fms_top_kind_) :: zdat(ipts,jpts)
394 real(kind=fms_top_kind_) :: zout2(
size(zout,1),
size(zout,2))
395 integer,
parameter :: lkind = fms_top_kind_
397 call input_data(topog_index, xdat, ydat, zdat)
399 call horiz_interp( zdat, xdat, ydat, blon, blat, zout )
402 if (
present(flag))
then
403 if (flag == compute_stdev)
then
405 call horiz_interp ( zdat, xdat, ydat, blon, blat, zout2 )
406 zout = zout2 - zout*zout
407 where (zout > 0.0_lkind)
415 end subroutine interp_topog_1d_
419 subroutine interp_topog_2d_( blon, blat, zout, flag )
420 real(kind=fms_top_kind_),
intent(in) :: blon(:,:), blat(:,:)
421 real(kind=fms_top_kind_),
intent(out) :: zout(:,:)
422 integer,
intent(in),
optional :: flag
424 real(kind=fms_top_kind_) :: xdat(ipts+1), ydat(jpts+1)
425 real(kind=fms_top_kind_) :: zdat(ipts,jpts)
426 real(kind=fms_top_kind_) :: zout2(
size(zout,1),
size(zout,2))
427 integer,
parameter :: lkind = fms_top_kind_
429 type (horiz_interp_type) :: Interp
431 call input_data(topog_index, xdat, ydat, zdat)
433 call find_indices( minval(blat), maxval(blat), ydat, js, je )
435 call horiz_interp_new ( interp, xdat, ydat(js:je+1), blon, blat )
436 call horiz_interp ( interp, zdat(:,js:je), zout )
439 if (
present(flag))
then
440 if (flag == compute_stdev)
then
442 call horiz_interp ( interp, zdat(:,js:je), zout2 )
443 zout = zout2 - zout*zout
444 where (zout > 0.0_lkind)
452 call horiz_interp_del( interp )
454 end subroutine interp_topog_2d_
458 subroutine find_indices_( ybeg, yend, ydat, js, je )
459 real(kind=fms_top_kind_),
intent(in) :: ybeg, yend, ydat(:)
460 integer,
intent(out) :: js, je
462 integer,
parameter :: lkind = fms_top_kind_
465 do j = 1,
size(ydat(:))-1
466 if (ybeg >= ydat(j) .and. ybeg <= ydat(j+1))
then
473 do j = js,
size(ydat(:))-1
474 if (yend >= ydat(j) .and. yend <= ydat(j+1))
then
482 end subroutine find_indices_
485 subroutine input_data_( indx, xdat, ydat, zdat )
486 integer,
intent(in) :: indx
487 real(kind=fms_top_kind_),
intent(out) :: xdat(ipts+1), ydat(jpts+1), zdat(ipts,jpts)
489 if( file_is_opened(indx) )
then
490 call read_data(fileobj(indx),
'xdat', xdat)
491 call read_data(fileobj(indx),
'ydat', ydat)
492 call read_data(fileobj(indx),
'zdat', zdat)
495 end subroutine input_data_
499 subroutine interp_water_1d_( blon, blat, zout, do_ocean )
500 real(kind=fms_top_kind_),
intent(in) :: blon(:), blat(:)
501 real(kind=fms_top_kind_),
intent(out) :: zout(:,:)
502 logical,
intent(in),
optional :: do_ocean
503 real(kind=fms_top_kind_) :: xdat(ipts+1), ydat(jpts+1), zdat(ipts,jpts)
504 call input_data ( water_index, xdat, ydat, zdat )
507 if (
present(do_ocean))
then
508 if (do_ocean)
call determine_ocean_points (zdat)
512 call horiz_interp ( zdat, xdat, ydat, blon, blat, zout )
514 end subroutine interp_water_1d_
518 subroutine interp_water_2d_( blon, blat, zout, do_ocean )
519 real(kind=fms_top_kind_),
intent(in) :: blon(:,:), blat(:,:)
520 real(kind=fms_top_kind_),
intent(out) :: zout(:,:)
521 logical,
intent(in),
optional :: do_ocean
522 real(kind=fms_top_kind_) :: xdat(ipts+1), ydat(jpts+1), zdat(ipts,jpts)
524 call input_data ( water_index, xdat, ydat, zdat )
527 if (
present(do_ocean))
then
528 if (do_ocean)
call determine_ocean_points (zdat)
532 call horiz_interp ( zdat, xdat, ydat, blon, blat, zout )
534 end subroutine interp_water_2d_
538 subroutine determine_ocean_points_(pctwater)
539 real(kind=fms_top_kind_),
intent(inout) :: pctwater(:,:)
540 logical :: ocean(size(pctwater,1),size(pctwater,2))
541 integer :: i, j, m, n, im, ip, jm, jp, new
542 integer,
parameter :: lkind = fms_top_kind_
543 real(kind=fms_top_kind_) :: ocean_pct_crit = 0.500_lkind
555 ocean = (pctwater > 0.999_lkind)
567 if (.not.ocean(i,j) .and. pctwater(i,j) > ocean_pct_crit)
then
568 im = i-1; ip = i+1; jm = j-1; jp = j+1
570 if (ip == m+1) ip = 1
572 if (jp == n+1) jp = n
574 if (ocean(im,j ) .or. ocean(ip,j ) .or. ocean(i ,jm) .or. ocean(i ,jp) .or. &
575 ocean(im,jm) .or. ocean(ip,jm) .or. ocean(ip,jp) .or. ocean(im,jp))
then
587 where (.not.ocean) pctwater = 0.0_lkind
589 end subroutine determine_ocean_points_