213 REAL(kind=
dp),
INTENT(IN) :: dr(3), dh(3, 3), dh_inv(3, 3)
214 LOGICAL,
INTENT(IN) :: ortho
215 REAL(kind=
dp),
INTENT(IN) :: max_radius
217 CHARACTER(LEN=*),
PARAMETER :: routinen =
'init_cube_info'
219 INTEGER :: check_1, check_2, handle, i, igmin, imr, &
220 jg, jg2, jgmin, k, kg, kg2, kgmin, &
222 REAL(kind=
dp) :: drmin, dxi, dy2, dyi, dz2, dzi, radius, &
225 CALL timeset(routinen, handle)
229 info%orthorhombic = ortho
230 info%max_rad_ga = max_radius
234 NULLIFY (info%lb_cube, info%ub_cube, &
235 info%sphere_bounds_count, info%sphere_bounds)
237 IF (.NOT. info%orthorhombic)
THEN
244 info%max_radius = max(maxval(abs(lb)), maxval(abs(ub)))
249 imr = ceiling((max_radius)/drmin)
250 info%max_radius = imr
257 ALLOCATE (info%lb_cube(3, imr), info%ub_cube(3, imr), &
258 info%sphere_bounds_count(imr), info%sphere_bounds(imr))
267 kgmin = do_and_hide_it_1(dzi, i, drmin, 0.0_dp, 0.0_dp, 0, 0)
271 jgmin = do_and_hide_it_1(dyi, i, drmin, dz2, 0.0_dp, kg2, 0)
275 igmin = do_and_hide_it_1(dxi, i, drmin, dz2, dy2, kg2, jg2)
276 check_1 =
modulo((kgmin*97 + jgmin*37 + igmin*113)*check_1 + 1277, 9343)
280 info%sphere_bounds_count(i) = k - 1
281 ALLOCATE (info%sphere_bounds(i)%p(info%sphere_bounds_count(i)))
289 info%lb_cube(:, i) = -1
291 kgmin = do_and_hide_it_1(dzi, i, drmin, 0.0_dp, 0.0_dp, 0, 0)
292 info%lb_cube(3, i) = min(kgmin, info%lb_cube(3, i))
293 info%sphere_bounds(i)%p(k) = kgmin
297 jgmin = do_and_hide_it_1(dyi, i, drmin, dz2, 0.0_dp, kg2, 0)
298 info%lb_cube(2, i) = min(jgmin, info%lb_cube(2, i))
299 info%sphere_bounds(i)%p(k) = jgmin
303 igmin = do_and_hide_it_1(dxi, i, drmin, dz2, dy2, kg2, jg2)
304 check_2 =
modulo((kgmin*97 + jgmin*37 + igmin*113)*check_2 + 1277, 9343)
305 info%lb_cube(1, i) = min(igmin, info%lb_cube(1, i))
306 info%sphere_bounds(i)%p(k) = igmin
310 info%ub_cube(:, i) = 1 - info%lb_cube(:, i)
312 IF (check_1 .NE. check_2)
THEN
313 cpabort(
"Irreproducible fp math caused memory corruption")
318 CALL timestop(handle)