43 private :: cnvtopo_gtopo30
44 private :: cnvtopo_gmted2010
45 private :: cnvtopo_dem50m
46 private :: cnvtopo_smooth
52 character(len=H_SHORT),
private :: cnvtopo_smooth_type =
'LAPLACIAN' 53 real(RP),
private :: cnvtopo_smooth_maxslope
54 real(RP),
private :: cnvtopo_smooth_maxslope_bnd
55 logical,
private :: cnvtopo_smooth_local = .false.
56 integer,
private :: cnvtopo_smooth_itelim = 1000
58 logical,
private :: cnvtopo_copy_parent = .false.
60 real(RP),
private :: cnvtopo_unittile_ddeg
61 real(RP),
private :: cnvtopo_oversampling_factor = 2.0_rp
86 character(len=H_SHORT) :: CNVTOPO_name =
'NONE' 88 namelist / param_cnvtopo / &
93 cnvtopo_unittile_ddeg, &
94 cnvtopo_oversampling_factor, &
95 cnvtopo_smooth_maxslope, &
96 cnvtopo_smooth_maxslope_bnd, &
97 cnvtopo_smooth_local, &
98 cnvtopo_smooth_itelim, &
99 cnvtopo_smooth_type, &
102 real(RP) :: minslope(
ia,
ja)
103 real(RP) :: DXL(
ia-1)
104 real(RP) :: DYL(
ja-1)
105 real(RP) :: DZDX, DZDY
107 real(RP) :: drad(
ia,
ja)
115 if(
io_l )
write(
io_fid_log,*)
'++++++ Module[convert topo] / Categ[preprocess] / Origin[SCALE-RM]' 117 if ( cnvtopo_smooth_local )
then 130 dzdx = atan2( 2.5_rp *
grid_cdz(k), dxl(i) ) / d2r
131 dzdy = atan2( 2.5_rp *
grid_cdz(k), dyl(j) ) / d2r
132 minslope(
is,
js) = min( minslope(
is,
js), dzdx, dzdy )
138 dzdx = atan2( 2.5_rp *
grid_cdz(k), dxl(i) ) / d2r
139 dzdy = atan2( 2.5_rp *
grid_cdz(k), dyl(j) ) / d2r
140 minslope(i,
js) = min( minslope(i,
js), dzdx, dzdy )
147 dzdx = atan2( 2.5_rp *
grid_cdz(k), dxl(i) ) / d2r
148 dzdy = atan2( 2.5_rp *
grid_cdz(k), dyl(j) ) / d2r
149 minslope(
is,j) = min( minslope(
is,j), dzdx, dzdy )
156 dzdx = atan2( 2.5_rp *
grid_cdz(k), dxl(i) ) / d2r
157 dzdy = atan2( 2.5_rp *
grid_cdz(k), dyl(j) ) / d2r
158 minslope(i,j) = min( minslope(i,j), dzdx, dzdy )
163 call comm_horizontal_min( cnvtopo_smooth_maxslope, minslope(:,:) )
165 cnvtopo_smooth_maxslope_bnd = -1.0_rp
171 if(
io_l )
write(
io_fid_log,*)
'*** Not found namelist. Default used.' 172 elseif( ierr > 0 )
then 173 write(*,*)
'xxx Not appropriate names in namelist PARAM_CNVTOPO. Check!' 178 select case(cnvtopo_name)
198 write(*,*)
' xxx Unsupported TYPE:', trim(cnvtopo_name)
206 if(
io_l )
write(
io_fid_log,*)
'*** Use GTOPO, global 30 arcsec. data' 208 if(
io_l )
write(
io_fid_log,*)
'*** Use GMTED2010, new global 5 arcsec. data' 212 if(
io_l )
write(
io_fid_log,*)
'*** Use DEM 50m data for Japan region' 217 if(
io_l )
write(
io_fid_log,*)
'*** Use GMTED2010, new global 5 arcsec. data' 219 if(
io_l )
write(
io_fid_log,*)
'*** Use DEM 50m data for Japan region' 224 if(
io_l )
write(
io_fid_log,*)
'*** Use DEM 50m data, Japan region only' 227 if ( cnvtopo_smooth_maxslope_bnd < 0.0_rp )
then 228 cnvtopo_smooth_maxslope_bnd = cnvtopo_smooth_maxslope
235 call comm_horizontal_min( drad_min, drad(:,:) )
237 if ( cnvtopo_unittile_ddeg > 0.0_rp )
then 238 cnvtopo_oversampling_factor = ( drad_min / d2r ) / cnvtopo_unittile_ddeg
240 cnvtopo_oversampling_factor = max( 1.0_rp, cnvtopo_oversampling_factor )
241 cnvtopo_unittile_ddeg = ( drad_min / d2r ) / cnvtopo_oversampling_factor
243 if(
io_l )
write(
io_fid_log,*)
'*** The size of tile [deg] = ', cnvtopo_unittile_ddeg
244 if(
io_l )
write(
io_fid_log,*)
'*** oversampling factor = ', cnvtopo_oversampling_factor
268 real(RP) :: Zsfc(
ia,
ja,2)
275 if(
io_l )
write(
io_fid_log,*)
'++++++ SKIP CONVERT TOPOGRAPHY DATA ++++++' 278 if(
io_l )
write(
io_fid_log,*)
'++++++ START CONVERT TOPOGRAPHY DATA ++++++' 285 call cnvtopo_gmted2010
293 call cnvtopo_smooth( zsfc(:,:,1), &
294 cnvtopo_smooth_maxslope )
296 zsfc(:,:,2) = zsfc(:,:,1)
297 call cnvtopo_smooth( zsfc(:,:,2), &
298 cnvtopo_smooth_maxslope_bnd )
302 frac = sin( 0.5_rp * pi * max( cbfx(i), cbfy(j) ) )
304 topo_zsfc(i,j) = ( 1.0_rp-frac ) * zsfc(i,j,1) &
305 + ( frac ) * zsfc(i,j,2)
313 if(
io_l )
write(
io_fid_log,*)
'++++++ END CONVERT TOPOGRAPHY DATA ++++++' 324 subroutine cnvtopo_gtopo30
338 character(len=H_LONG) :: GTOPO30_IN_CATALOGUE =
'' 339 character(len=H_LONG) :: GTOPO30_IN_DIR =
'' 341 namelist / param_cnvtopo_gtopo30 / &
342 gtopo30_in_catalogue, &
346 integer,
parameter :: TILE_nlim = 100
348 real(RP) :: TILE_LATS (tile_nlim)
349 real(RP) :: TILE_LATE (tile_nlim)
350 real(RP) :: TILE_LONS (tile_nlim)
351 real(RP) :: TILE_LONE (tile_nlim)
352 character(len=H_LONG) :: TILE_fname(tile_nlim)
355 integer,
parameter :: isize_orig = 4800
356 integer,
parameter :: jsize_orig = 6000
357 integer(2) :: TILE_HEIGHT_orig(isize_orig,jsize_orig)
358 real(RP) :: TILE_DLAT_orig, TILE_DLON_orig
365 integer(2),
allocatable :: TILE_HEIGHT(:,:)
366 real(RP),
allocatable :: TILE_LATH (:)
367 real(RP),
allocatable :: TILE_LONH (:)
368 real(RP) :: TILE_DLAT, TILE_DLON
369 real(RP) :: area, area_fraction
376 real(RP) :: DOMAIN_LATS, DOMAIN_LATE
377 real(RP) :: DOMAIN_LONS, DOMAIN_LONE
378 real(RP) :: topo_sum(
ia,
ja)
379 real(RP) :: area_sum(
ia,
ja)
380 real(RP) :: topo, mask
382 character(len=H_LONG) :: fname
385 logical :: hit_lat, hit_lon
388 integer :: i, j, ii, jj, iii, jjj, t
392 if(
io_l )
write(
io_fid_log,*)
'++++++ Module[convert GTOPO30] / Categ[preprocess] / Origin[SCALE-RM]' 396 read(
io_fid_conf,nml=param_cnvtopo_gtopo30,iostat=ierr)
398 if(
io_l )
write(
io_fid_log,*)
'*** Not found namelist. Default used.' 399 elseif( ierr > 0 )
then 400 write(*,*)
'xxx Not appropriate names in namelist PARAM_CNVTOPO_GTOPO30. Check!' 407 area_sum(i,j) = 0.0_rp
408 topo_sum(i,j) = 0.0_rp
417 jos = nint( 30.0_rp / 60.0_rp / 60.0_rp / cnvtopo_unittile_ddeg - 0.5_rp ) + 1
418 ios = nint( 30.0_rp / 60.0_rp / 60.0_rp / cnvtopo_unittile_ddeg - 0.5_rp ) + 1
419 jsize = jsize_orig * jos
420 isize = isize_orig * ios
422 allocate( tile_height(isize,jsize) )
423 allocate( tile_lath(0:jsize) )
424 allocate( tile_lonh(0:isize) )
426 if(
io_l )
write(
io_fid_log,*)
'*** Oversampling (j) orig = ', jsize_orig,
', use = ', jsize
427 if(
io_l )
write(
io_fid_log,*)
'*** Oversampling (i) orig = ', isize_orig,
', use = ', isize
429 tile_dlat_orig = 30.0_rp / 60.0_rp / 60.0_rp * d2r
430 tile_dlon_orig = 30.0_rp / 60.0_rp / 60.0_rp * d2r
431 if(
io_l )
write(
io_fid_log,*)
'*** TILE_DLAT :', tile_dlat_orig/d2r
432 if(
io_l )
write(
io_fid_log,*)
'*** TILE_DLON :', tile_dlon_orig/d2r
434 tile_dlat = tile_dlat_orig / jos
435 tile_dlon = tile_dlon_orig / ios
436 if(
io_l )
write(
io_fid_log,*)
'*** TILE_DLAT (OS) :', tile_dlat/d2r
437 if(
io_l )
write(
io_fid_log,*)
'*** TILE_DLON (OS) :', tile_dlon/d2r
442 fname = trim(gtopo30_in_dir)//
'/'//trim(gtopo30_in_catalogue)
445 if(
io_l )
write(
io_fid_log,*)
'+++ Input catalogue file:', trim(fname)
449 file = trim(fname), &
450 form =
'formatted', &
454 if ( ierr /= 0 )
then 455 write(*,*)
'xxx catalogue file not found!', trim(fname)
460 read(fid,*,iostat=ierr) index, tile_lats(t), tile_late(t), &
461 tile_lons(t), tile_lone(t), &
463 if ( ierr /= 0 )
exit 474 if ( ( tile_lats(t)*d2r >= domain_lats .AND. tile_lats(t)*d2r < domain_late ) &
475 .OR. ( tile_late(t)*d2r >= domain_lats .AND. tile_late(t)*d2r < domain_late ) )
then 479 if ( ( domain_lats >= tile_lats(t)*d2r .AND. domain_lats < tile_late(t)*d2r ) &
480 .OR. ( domain_late >= tile_lats(t)*d2r .AND. domain_late < tile_late(t)*d2r ) )
then 484 if ( ( tile_lons(t)*d2r >= domain_lons .AND. tile_lons(t)*d2r < domain_lone ) &
485 .OR. ( tile_lone(t)*d2r >= domain_lons .AND. tile_lone(t)*d2r < domain_lone ) )
then 489 if ( ( domain_lons >= tile_lons(t)*d2r .AND. domain_lons < tile_lone(t)*d2r ) &
490 .OR. ( domain_lone >= tile_lons(t)*d2r .AND. domain_lone < tile_lone(t)*d2r ) )
then 494 if ( hit_lat .AND. hit_lon )
then 495 fname = trim(gtopo30_in_dir)//
'/'//trim(tile_fname(t))
498 if(
io_l )
write(
io_fid_log,*)
'+++ Input data file :', trim(fname)
499 if(
io_l )
write(
io_fid_log,*)
'*** Domain (LAT) :', domain_lats/d2r, domain_late/d2r
500 if(
io_l )
write(
io_fid_log,*)
'*** (LON) :', domain_lons/d2r, domain_lone/d2r
501 if(
io_l )
write(
io_fid_log,*)
'*** Tile (LAT) :', tile_lats(t), tile_late(t)
502 if(
io_l )
write(
io_fid_log,*)
'*** (LON) :', tile_lons(t), tile_lone(t)
506 file = trim(fname), &
507 form =
'unformatted', &
510 recl = isize_orig*jsize_orig*2, &
513 if ( ierr /= 0 )
then 514 write(*,*)
'xxx data file not found!' 518 read(fid,rec=1) tile_height_orig(:,:)
522 do jj = 1, jsize_orig
523 do ii = 1, isize_orig
526 jjj = (jj-1) * jos + j
527 iii = (ii-1) * ios + i
529 tile_height(iii,jjj) = tile_height_orig(ii,jsize_orig-jj+1)
535 tile_lath(0) = tile_lats(t) * d2r
537 tile_lath(jj) = tile_lath(jj-1) + tile_dlat
541 tile_lonh(0) = tile_lons(t) * d2r
543 tile_lonh(ii) = tile_lonh(ii-1) + tile_dlon
557 if ( tile_lonh(ii-1) < domain_lons &
558 .OR. tile_lonh(ii-1) >= domain_lone &
559 .OR. tile_lath(jj-1) < domain_lats &
560 .OR. tile_lath(jj-1) >= domain_late )
then 564 jloop:
do j =
js-1,
je+1
565 iloop:
do i =
is-1,
ie+1
566 if ( tile_lonh(ii-1) >=
real_lonx(i-1,j ) &
567 .AND. tile_lonh(ii-1) <
real_lonx(i ,j ) &
568 .AND. tile_lath(jj-1) >=
real_laty(i ,j-1) &
569 .AND. tile_lath(jj-1) <
real_laty(i ,j ) )
then 572 ifrac_l = min(
real_lonx(i,j)-tile_lonh(ii-1), tile_dlon ) / tile_dlon
575 jfrac_b = min(
real_laty(i,j)-tile_lath(jj-1), tile_dlat ) / tile_dlat
582 if( iloc == 1 .AND. jloc == 1 ) cycle
584 topo =
real( TILE_HEIGHT(ii,jj), kind=
rp )
585 mask = 0.5_rp - sign( 0.5_rp, topo )
587 area = radius * radius * tile_dlon * ( sin(tile_lath(jj))-sin(tile_lath(jj-1)) ) * ( 1.0_rp - mask )
591 area_fraction = ( ifrac_l) * ( jfrac_b) * area
592 area_sum(iloc ,jloc ) = area_sum(iloc ,jloc ) + area_fraction
593 topo_sum(iloc ,jloc ) = topo_sum(iloc ,jloc ) + area_fraction * topo
595 area_fraction = (1.0_rp-ifrac_l) * ( jfrac_b) * area
596 area_sum(iloc+1,jloc ) = area_sum(iloc+1,jloc ) + area_fraction
597 topo_sum(iloc+1,jloc ) = topo_sum(iloc+1,jloc ) + area_fraction * topo
599 area_fraction = ( ifrac_l) * (1.0_rp-jfrac_b) * area
600 area_sum(iloc ,jloc+1) = area_sum(iloc ,jloc+1) + area_fraction
601 topo_sum(iloc ,jloc+1) = topo_sum(iloc ,jloc+1) + area_fraction * topo
603 area_fraction = (1.0_rp-ifrac_l) * (1.0_rp-jfrac_b) * area
604 area_sum(iloc+1,jloc+1) = area_sum(iloc+1,jloc+1) + area_fraction
605 topo_sum(iloc+1,jloc+1) = topo_sum(iloc+1,jloc+1) + area_fraction * topo
614 zerosw = 0.5_rp - sign( 0.5_rp, area_sum(i,j)-eps )
615 topo_zsfc(i,j) = topo_sum(i,j) * ( 1.0_rp-zerosw ) / ( area_sum(i,j)-zerosw )
620 end subroutine cnvtopo_gtopo30
624 subroutine cnvtopo_gmted2010
629 end subroutine cnvtopo_gmted2010
633 subroutine cnvtopo_dem50m
647 character(len=H_LONG) :: DEM50M_IN_CATALOGUE =
'' 648 character(len=H_LONG) :: DEM50M_IN_DIR =
'' 650 namelist / param_cnvtopo_dem50m / &
651 dem50m_in_catalogue, &
655 integer,
parameter :: TILE_nlim = 1000
657 real(RP) :: TILE_LATS (tile_nlim)
658 real(RP) :: TILE_LATE (tile_nlim)
659 real(RP) :: TILE_LONS (tile_nlim)
660 real(RP) :: TILE_LONE (tile_nlim)
661 character(len=H_LONG) :: TILE_fname(tile_nlim)
664 integer,
parameter :: isize_orig = 1600
665 integer,
parameter :: jsize_orig = 1600
666 real(SP) :: TILE_HEIGHT_orig(isize_orig,jsize_orig)
667 real(RP) :: TILE_DLAT_orig, TILE_DLON_orig
674 real(SP),
allocatable :: TILE_HEIGHT(:,:)
675 real(RP),
allocatable :: TILE_LATH (:)
676 real(RP),
allocatable :: TILE_LONH (:)
677 real(RP) :: TILE_DLAT, TILE_DLON
678 real(RP) :: area, area_fraction
685 real(RP) :: DOMAIN_LATS, DOMAIN_LATE
686 real(RP) :: DOMAIN_LONS, DOMAIN_LONE
687 real(RP) :: topo_sum(
ia,
ja)
688 real(RP) :: area_sum(
ia,
ja)
689 real(RP) :: topo, mask
691 character(len=H_LONG) :: fname
694 logical :: hit_lat, hit_lon
697 integer :: i, j, ii, jj, iii, jjj, t
701 if(
io_l )
write(
io_fid_log,*)
'++++++ Module[convert DEM50M] / Categ[preprocess] / Origin[SCALE-RM]' 705 read(
io_fid_conf,nml=param_cnvtopo_dem50m,iostat=ierr)
707 if(
io_l )
write(
io_fid_log,*)
'*** Not found namelist. Default used.' 708 elseif( ierr > 0 )
then 709 write(*,*)
'xxx Not appropriate names in namelist PARAM_CNVTOPO_DEM50M. Check!' 716 area_sum(i,j) = 0.0_rp
717 topo_sum(i,j) = 0.0_rp
726 jos = nint( 5.0_rp / 60.0_rp / 200.0_rp / cnvtopo_unittile_ddeg - 0.5_rp ) + 1
727 ios = nint( 7.5_rp / 60.0_rp / 200.0_rp / cnvtopo_unittile_ddeg - 0.5_rp ) + 1
728 jsize = jsize_orig * jos
729 isize = isize_orig * ios
731 allocate( tile_height(isize,jsize) )
732 allocate( tile_lath(0:jsize) )
733 allocate( tile_lonh(0:isize) )
735 if(
io_l )
write(
io_fid_log,*)
'*** Oversampling (j) orig = ', jsize_orig,
', use = ', jsize
736 if(
io_l )
write(
io_fid_log,*)
'*** Oversampling (i) orig = ', isize_orig,
', use = ', isize
738 tile_dlat_orig = 5.0_rp / 60.0_rp / 200.0_rp * d2r
739 tile_dlon_orig = 7.5_rp / 60.0_rp / 200.0_rp * d2r
740 if(
io_l )
write(
io_fid_log,*)
'*** TILE_DLAT :', tile_dlat_orig/d2r
741 if(
io_l )
write(
io_fid_log,*)
'*** TILE_DLON :', tile_dlon_orig/d2r
743 tile_dlat = tile_dlat_orig / jos
744 tile_dlon = tile_dlon_orig / ios
745 if(
io_l )
write(
io_fid_log,*)
'*** TILE_DLAT (OS) :', tile_dlat/d2r
746 if(
io_l )
write(
io_fid_log,*)
'*** TILE_DLON (OS) :', tile_dlon/d2r
751 fname = trim(dem50m_in_dir)//
'/'//trim(dem50m_in_catalogue)
754 if(
io_l )
write(
io_fid_log,*)
'+++ Input catalogue file:', trim(fname)
758 file = trim(fname), &
759 form =
'formatted', &
763 if ( ierr /= 0 )
then 764 write(*,*)
'xxx catalogue file not found!', trim(fname)
769 read(fid,*,iostat=ierr) index, tile_lats(t), tile_late(t), &
770 tile_lons(t), tile_lone(t), &
772 if ( ierr /= 0 )
exit 783 if ( ( tile_lats(t)*d2r >= domain_lats .AND. tile_lats(t)*d2r < domain_late ) &
784 .OR. ( tile_late(t)*d2r >= domain_lats .AND. tile_late(t)*d2r < domain_late ) )
then 788 if ( ( domain_lats >= tile_lats(t)*d2r .AND. domain_lats < tile_late(t)*d2r ) &
789 .OR. ( domain_late >= tile_lats(t)*d2r .AND. domain_late < tile_late(t)*d2r ) )
then 793 if ( ( tile_lons(t)*d2r >= domain_lons .AND. tile_lons(t)*d2r < domain_lone ) &
794 .OR. ( tile_lone(t)*d2r >= domain_lons .AND. tile_lone(t)*d2r < domain_lone ) )
then 798 if ( ( domain_lons >= tile_lons(t)*d2r .AND. domain_lons < tile_lone(t)*d2r ) &
799 .OR. ( domain_lone >= tile_lons(t)*d2r .AND. domain_lone < tile_lone(t)*d2r ) )
then 803 if ( hit_lat .AND. hit_lon )
then 804 fname = trim(dem50m_in_dir)//
'/'//trim(tile_fname(t))
807 if(
io_l )
write(
io_fid_log,*)
'+++ Input data file :', trim(fname)
808 if(
io_l )
write(
io_fid_log,*)
'*** Domain (LAT) :', domain_lats/d2r, domain_late/d2r
809 if(
io_l )
write(
io_fid_log,*)
'*** (LON) :', domain_lons/d2r, domain_lone/d2r
810 if(
io_l )
write(
io_fid_log,*)
'*** Tile (LAT) :', tile_lats(t), tile_late(t)
811 if(
io_l )
write(
io_fid_log,*)
'*** (LON) :', tile_lons(t), tile_lone(t)
815 file = trim(fname), &
816 form =
'unformatted', &
819 recl = isize_orig*jsize_orig*4, &
822 if ( ierr /= 0 )
then 823 write(*,*)
'xxx data file not found!' 827 read(fid,rec=1) tile_height_orig(:,:)
831 do jj = 1, jsize_orig
832 do ii = 1, isize_orig
835 jjj = (jj-1) * jos + j
836 iii = (ii-1) * ios + i
838 tile_height(iii,jjj) = tile_height_orig(ii,jj)
844 tile_lath(0) = tile_lats(t) * d2r
846 tile_lath(jj) = tile_lath(jj-1) + tile_dlat
850 tile_lonh(0) = tile_lons(t) * d2r
852 tile_lonh(ii) = tile_lonh(ii-1) + tile_dlon
866 if ( tile_lonh(ii-1) < domain_lons &
867 .OR. tile_lonh(ii-1) >= domain_lone &
868 .OR. tile_lath(jj-1) < domain_lats &
869 .OR. tile_lath(jj-1) >= domain_late )
then 873 jloop:
do j =
js-1,
je+1
874 iloop:
do i =
is-1,
ie+1
875 if ( tile_lonh(ii-1) >=
real_lonx(i-1,j ) &
876 .AND. tile_lonh(ii-1) <
real_lonx(i ,j ) &
877 .AND. tile_lath(jj-1) >=
real_laty(i ,j-1) &
878 .AND. tile_lath(jj-1) <
real_laty(i ,j ) )
then 881 ifrac_l = min(
real_lonx(i,j)-tile_lonh(ii-1), tile_dlon ) / tile_dlon
884 jfrac_b = min(
real_laty(i,j)-tile_lath(jj-1), tile_dlat ) / tile_dlat
891 if( iloc == 1 .AND. jloc == 1 ) cycle
893 topo =
real( TILE_HEIGHT(ii,jj), kind=
rp )
894 mask = 0.5_rp - sign( 0.5_rp,topo )
896 area = radius * radius * tile_dlon * ( sin(tile_lath(jj))-sin(tile_lath(jj-1)) ) * ( 1.0_rp - mask )
900 area_fraction = ( ifrac_l) * ( jfrac_b) * area
901 area_sum(iloc ,jloc ) = area_sum(iloc ,jloc ) + area_fraction
902 topo_sum(iloc ,jloc ) = topo_sum(iloc ,jloc ) + area_fraction * topo
904 area_fraction = (1.0_rp-ifrac_l) * ( jfrac_b) * area
905 area_sum(iloc+1,jloc ) = area_sum(iloc+1,jloc ) + area_fraction
906 topo_sum(iloc+1,jloc ) = topo_sum(iloc+1,jloc ) + area_fraction * topo
908 area_fraction = ( ifrac_l) * (1.0_rp-jfrac_b) * area
909 area_sum(iloc ,jloc+1) = area_sum(iloc ,jloc+1) + area_fraction
910 topo_sum(iloc ,jloc+1) = topo_sum(iloc ,jloc+1) + area_fraction * topo
912 area_fraction = (1.0_rp-ifrac_l) * (1.0_rp-jfrac_b) * area
913 area_sum(iloc+1,jloc+1) = area_sum(iloc+1,jloc+1) + area_fraction
914 topo_sum(iloc+1,jloc+1) = topo_sum(iloc+1,jloc+1) + area_fraction * topo
923 mask = 0.5_rp + sign( 0.5_rp, area_sum(i,j)-eps )
924 zerosw = 0.5_rp - sign( 0.5_rp, area_sum(i,j)-eps )
925 topo = topo_sum(i,j) * ( 1.0_rp-zerosw ) / ( area_sum(i,j)-zerosw )
932 end subroutine cnvtopo_dem50m
936 subroutine cnvtopo_smooth( &
956 real(RP),
intent(inout) :: Zsfc(
ia,
ja)
957 real(RP),
intent(in) :: smooth_maxslope
959 real(RP) :: DZsfc_DX(1,
ia,
ja,1)
960 real(RP) :: DZsfc_DY(1,
ia,
ja,1)
962 real(RP) :: DXL(
ia-1)
963 real(RP) :: DYL(
ja-1)
965 real(RP) :: FLX_X(
ia,
ja)
966 real(RP) :: FLX_Y(
ia,
ja)
967 real(RP) :: FLX_TMP(
ia,
ja)
969 real(RP) :: slope(
ia,
ja)
973 character(len=H_SHORT) :: varname(1)
980 if(
io_l )
write(
io_fid_log,*)
'*** Apply smoothing. Slope limit = ', cnvtopo_smooth_maxslope
981 if(
io_l )
write(
io_fid_log,*)
'*** Smoothing type = ', cnvtopo_smooth_type
982 if(
io_l )
write(
io_fid_log,*)
'*** Smoothing locally = ', cnvtopo_smooth_local
984 if ( cnvtopo_smooth_local )
then 993 do ite = 1, cnvtopo_smooth_itelim+1
1001 dzsfc_dx(1,i,j,1) = atan2( ( zsfc(i+1,j)-zsfc(i,j) ), dxl(i) ) / d2r
1004 dzsfc_dx(1,
ia,:,1) = 0.0_rp
1007 dzsfc_dy(1,i,j,1) = atan2( ( zsfc(i,j+1)-zsfc(i,j) ), dyl(j) ) / d2r
1010 dzsfc_dy(1,:,
ja,1) = 0.0_rp
1012 slope(:,:) = max( abs(dzsfc_dx(1,:,:,1)), abs(dzsfc_dy(1,:,:,1)) )
1013 call comm_horizontal_max( maxslope, slope(:,:) )
1015 if(
io_l )
write(
io_fid_log,*)
'*** maximum slope [deg] : ', maxslope
1017 if( maxslope < smooth_maxslope )
exit 1019 varname(1) =
"DZsfc_DX" 1021 varname(1) =
"DZsfc_DY" 1024 select case ( cnvtopo_smooth_type )
1030 zsfc(i,j) = ( 0.2500_rp * zsfc(i ,j ) &
1031 + 0.1250_rp * zsfc(i-1,j ) &
1032 + 0.1250_rp * zsfc(i+1,j ) &
1033 + 0.1250_rp * zsfc(i ,j-1) &
1034 + 0.1250_rp * zsfc(i ,j+1) &
1035 + 0.0625_rp * zsfc(i-1,j-1) &
1036 + 0.0625_rp * zsfc(i+1,j-1) &
1037 + 0.0625_rp * zsfc(i-1,j+1) &
1038 + 0.0625_rp * zsfc(i+1,j+1) )
1042 case (
'LAPLACIAN' )
1046 flx_x(i,j) = zsfc(i+1,j) - zsfc(i,j)
1059 flx_y(i,j) = zsfc(i,j+1) - zsfc(i,j)
1071 if ( cnvtopo_smooth_local )
then 1075 + sign(0.5_rp, max( abs(dzsfc_dx(1,i+1,j ,1)), &
1076 abs(dzsfc_dx(1,i ,j ,1)), &
1077 abs(dzsfc_dx(1,i-1,j ,1)), &
1078 abs(dzsfc_dy(1,i+1,j ,1)), &
1079 abs(dzsfc_dy(1,i+1,j-1,1)), &
1080 abs(dzsfc_dy(1,i ,j ,1)), &
1081 abs(dzsfc_dy(1,i ,j-1,1)) &
1082 ) - smooth_maxslope )
1083 flx_x(i,j) = flx_x(i,j) &
1091 + sign(0.5_rp, max( abs(dzsfc_dy(1,i ,j+1,1)), &
1092 abs(dzsfc_dy(1,i ,j ,1)), &
1093 abs(dzsfc_dy(1,i ,j-1,1)), &
1094 abs(dzsfc_dx(1,i ,j+1,1)), &
1095 abs(dzsfc_dx(1,i-1,j+1,1)), &
1096 abs(dzsfc_dx(1,i ,j ,1)), &
1097 abs(dzsfc_dx(1,i-1,j ,1)) &
1098 ) - smooth_maxslope )
1099 flx_y(i,j) = flx_y(i,j) &
1108 zsfc(i,j) = max( 0.0_rp, &
1110 + 0.1_rp * ( ( flx_x(i,j) - flx_x(i-1,j) ) &
1111 + ( flx_y(i,j) - flx_y(i,j-1) ) ) )
1116 write(*,*)
'xxx Invalid smoothing type' 1122 if ( ite > cnvtopo_smooth_itelim )
then 1123 write(*,*)
'xxx not converged' 1129 varname(1) =
"DZsfc_DX" 1131 varname(1) =
"DZsfc_DY" 1137 end subroutine cnvtopo_smooth
subroutine, public topo_write
Write topography.
integer, public is
start point of inner domain: x, local
integer, public je
end point of inner domain: y, local
subroutine, public topo_fillhalo(Zsfc)
HALO Communication.
real(rp), public dy
length in the main region [m]: y
real(rp), public const_huge
huge number
subroutine, public prc_mpistop
Abort MPI.
real(rp), dimension(:), allocatable, public grid_fdy
y-length of grid(j+1) to grid(j) [m]
real(rp), public dx
length in the main region [m]: x
logical, public io_l
output log or not? (this process)
module Convert topography
logical, public cnvtopo_usedem50m
real(rp), public const_radius
radius of the planet [m]
integer, public ke
end point of inner domain: z, local
real(rp), public const_d2r
degree to radian
logical, public cnvtopo_donothing
integer, public ia
of x whole cells (local, with HALO)
integer function, public io_get_available_fid()
search & get available file ID
real(rp), dimension(:,:), allocatable, public real_dlon
delta longitude
integer, public js
start point of inner domain: y, local
real(rp), dimension(:), allocatable, public grid_cbfx
center buffer factor [0-1]: x
real(rp), dimension(:,:), allocatable, public real_dlat
delta latitude
subroutine, public cnvtopo_setup
Setup.
subroutine, public stat_detail(var, varname, supress_globalcomm)
Search global maximum & minimum value.
integer, public ks
start point of inner domain: z, local
subroutine, public cnvtopo
Driver.
logical, public cnvtopo_usegtopo30
subroutine, public copytopo(topo_cd)
Setup and Main.
integer, public ie
end point of inner domain: x, local
real(rp), public const_eps
small number
logical, public io_lnml
output log or not? (for namelist, this process)
real(rp), dimension(:,:), allocatable, public topo_zsfc
absolute ground height [m]
real(rp), dimension(:), allocatable, public grid_cdz
z-length of control volume [m]
real(rp), dimension(:), allocatable, public grid_fdx
x-length of grid(i+1) to grid(i) [m]
real(rp), dimension(:), allocatable, public grid_cbfy
center buffer factor [0-1]: y
real(rp), public const_pi
pi
integer, public io_fid_conf
Config file ID.
integer, public io_fid_log
Log file ID.
integer, parameter, public rp
real(rp), dimension(:,:), allocatable, public real_lonx
longitude at staggered point (uy) [rad,0-2pi]
logical, public cnvtopo_usegmted2010
real(rp), dimension(:,:), allocatable, public real_laty
latitude at staggered point (xv) [rad,-pi,pi]
integer, public ja
of y whole cells (local, with HALO)