65 type(
grid),
target,
intent(in) :: highres
67 real(dp),
intent(in) :: target_resolution
69 type(
grid),
target,
intent(inout) :: lowres
71 type(
gridremapper),
intent(inout),
optional :: highres_lowres_remap
73 real(dp),
dimension(:, :),
allocatable :: areacell0_2d
75 real(dp) :: cellfactor
77 integer(i4) :: iup, idown
81 integer(i4) :: i, j, k, ic, jc
90 if (.not.
allocated(lowres%mask))
then
92 highres%xllcorner, highres%yllcorner, highres%cellsize, &
94 lowres%nrows, lowres%ncols, &
95 lowres%xllcorner, lowres%yllcorner, lowres%cellsize)
97 cellfactor = anint(lowres%cellsize / highres%cellsize)
100 allocate(lowres%mask(lowres%nrows, lowres%ncols))
101 lowres%mask(:, :) = .false.
104 do j = 1, highres%ncols
105 jc = ceiling(real(j, dp) / cellfactor)
106 do i = 1, highres%nrows
107 if (.NOT. highres%mask(i, j)) cycle
108 ic = ceiling(real(i, dp) / cellfactor)
109 lowres%mask(ic, jc) = .true.
114 lowres%nCells = count(lowres%mask)
116 allocate(lowres%Id (lowres%nCells))
117 lowres%Id = (/ (k, k = 1, lowres%nCells) /)
120 if (
present(highres_lowres_remap))
then
122 cellfactor = lowres%cellsize / highres%cellsize
125 allocate(areacell0_2d(highres%nrows, highres%ncols))
126 areacell0_2d(:, :) = unpack(highres%CellArea, highres%mask,
nodata_dp)
128 if (.not.
allocated(lowres%CellCoor))
then
129 allocate(lowres%CellCoor (lowres%nCells, 2))
130 allocate(lowres%CellArea (lowres%nCells))
133 allocate(highres_lowres_remap%lower_bound(lowres%nCells))
134 allocate(highres_lowres_remap%upper_bound(lowres%nCells))
135 allocate(highres_lowres_remap%left_bound (lowres%nCells))
136 allocate(highres_lowres_remap%right_bound(lowres%nCells))
137 allocate(highres_lowres_remap%n_subcells (lowres%nCells))
138 allocate(highres_lowres_remap%lowres_id_on_highres (highres%nrows, highres%ncols))
139 highres_lowres_remap%lowres_id_on_highres =
nodata_i4
141 highres_lowres_remap%high_res_grid => highres
142 highres_lowres_remap%low_res_grid => lowres
145 do jc = 1, lowres%ncols
146 do ic = 1, lowres%nrows
147 if (.NOT. lowres%mask(ic, jc)) cycle
150 lowres%CellCoor(k, 1) = ic
151 lowres%CellCoor(k, 2) = jc
154 iup = (ic - 1) * nint(cellfactor, i4) + 1
155 idown = ic * nint(cellfactor, i4)
156 jl = (jc - 1) * nint(cellfactor, i4) + 1
157 jr = jc * nint(cellfactor, i4)
161 if(idown > highres%nrows) idown = highres%nrows
163 if(jr > highres%ncols) jr = highres%ncols
165 highres_lowres_remap%upper_bound (k) = iup
166 highres_lowres_remap%lower_bound (k) = idown
167 highres_lowres_remap%left_bound (k) = jl
168 highres_lowres_remap%right_bound(k) = jr
171 lowres%CellArea(k) = sum(areacell0_2d(iup : idown, jl : jr), highres%mask(iup : idown, jl : jr))
172 highres_lowres_remap%n_subcells(k) = count(highres%mask(iup : idown, jl : jr))
174 highres_lowres_remap%lowres_id_on_highres(iup : idown, jl : jr) = k
179 deallocate(areacell0_2d)
271 use mo_constants,
only : radiusearth_dp, twopi_dp
275 type(
grid),
intent(inout) :: new_grid
277 real(dp),
dimension(:, :),
allocatable :: areacell_2d
279 integer(i4) :: i, j, k
281 real(dp) :: rdum, degree_to_radian, degree_to_metre
291 new_grid%nCells = count(new_grid%mask)
293 allocate(new_grid%CellCoor(new_grid%nCells, 2))
294 allocate(new_grid%Id(new_grid%nCells))
295 allocate(new_grid%CellArea(new_grid%nCells))
296 allocate(areacell_2d(new_grid%nrows, new_grid%ncols))
298 new_grid%Id = (/ (k, k = 1, new_grid%nCells) /)
304 do j = 1, new_grid%ncols
305 do i = 1, new_grid%nrows
306 if (.NOT. new_grid%mask(i, j)) cycle
308 new_grid%cellCoor(k, 1) = i
309 new_grid%cellCoor(k, 2) = j
317 new_grid%CellArea(:) = new_grid%cellsize * new_grid%cellsize
322 degree_to_radian = twopi_dp / 360.0_dp
323 degree_to_metre = radiusearth_dp * twopi_dp / 360.0_dp
324 do i = new_grid%ncols, 1, -1
325 j = new_grid%ncols - i + 1
327 rdum = new_grid%yllcorner + (real(j, dp) - 0.5_dp) * new_grid%cellsize
329 rdum = rdum * degree_to_radian
331 areacell_2d(:, i) = (new_grid%cellsize * cos(rdum) * degree_to_metre) * (new_grid%cellsize * degree_to_metre)
333 new_grid%CellArea(:) = pack(areacell_2d(:, :), new_grid%mask)
338 deallocate(areacell_2d)
490 nrowsOut, ncolsOut, xllcornerOut, yllcornerOut, cellsizeOut)
492 use mo_message,
only : error_message
493 use mo_string_utils,
only : num2str
498 integer(i4),
intent(in) :: nrowsIn
501 integer(i4),
intent(in) :: ncolsIn
504 real(dp),
intent(in) :: xllcornerIn
507 real(dp),
intent(in) :: yllcornerIn
510 real(dp),
intent(in) :: cellsizeIn
513 real(dp),
intent(in) :: aimingResolution
516 integer(i4),
intent(out) :: nrowsOut
519 integer(i4),
intent(out) :: ncolsOut
522 real(dp),
intent(out) :: xllcornerOut
525 real(dp),
intent(out) :: yllcornerOut
528 real(dp),
intent(out) :: cellsizeOut
530 real(dp) :: cellFactor, rounded
531 integer(i4) :: rounded_int
534 cellfactor = aimingresolution / cellsizein
535 rounded = anint(cellfactor)
536 rounded_int = nint(cellfactor)
538 if (abs(rounded - cellfactor) > 1.e-7_dp)
then
539 call error_message( &
540 '***ERROR: Two resolutions size do not confirm: ', &
541 trim(adjustl(num2str(nint(aimingresolution)))), &
542 trim(adjustl(num2str(nint(cellsizein)))))
545 cellsizeout = aimingresolution
546 ncolsout = nint(real(ncolsin, dp) / cellfactor)
547 nrowsout = nint(real(nrowsin, dp) / cellfactor)
550 if ( ncolsout * rounded_int < ncolsin ) ncolsout = ncolsout + 1_i4
551 if ( nrowsout * rounded_int < nrowsin ) nrowsout = nrowsout + 1_i4
553 xllcornerout = xllcornerin + real(ncolsin, dp) * aimingresolution / rounded - real(ncolsout, dp) * cellsizeout
554 yllcornerout = yllcornerin + real(nrowsin, dp) * aimingresolution / rounded - real(nrowsout, dp) * cellsizeout
subroutine calculate_grid_properties(nrowsin, ncolsin, xllcornerin, yllcornerin, cellsizein, aimingresolution, nrowsout, ncolsout, xllcornerout, yllcornerout, cellsizeout)
Calculates basic grid properties at a required coarser level using information of a given finer level...