19 USE ieee_arithmetic,
ONLY: ieee_is_finite
22#include "./base/base_uses.f90"
27 CHARACTER(len=*),
PARAMETER,
PRIVATE :: moduleN =
'lattice_preconditioner_operator'
56 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
57 INTEGER,
DIMENSION(:, :),
INTENT(OUT) :: index_to_cell
58 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(OUT) :: xkp
60 INTEGER :: icell, ix, iy, iz
62 IF (any(lattice_dims <= 0)) cpabort(
"Invalid lattice dimensions")
63 IF (
SIZE(index_to_cell, 1) < 3 .OR.
SIZE(xkp, 1) < 3 .OR. &
64 SIZE(index_to_cell, 2) /= product(lattice_dims) .OR. &
65 SIZE(xkp, 2) /= product(lattice_dims))
THEN
66 cpabort(
"Invalid lattice-grid output shape")
70 DO iz = 0, lattice_dims(3) - 1
71 DO iy = 0, lattice_dims(2) - 1
72 DO ix = 0, lattice_dims(1) - 1
74 index_to_cell(:, icell) = [ix, iy, iz]
75 xkp(:, icell) = [real(ix, kind=
dp)/real(lattice_dims(1), kind=
dp), &
76 REAL(iy, kind=
dp)/real(lattice_dims(2), kind=
dp), &
77 REAL(iz, kind=
dp)/real(lattice_dims(3), kind=
dp)]
96 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(IN) :: operator_matrix
97 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
98 COMPLEX(KIND=dp),
ALLOCATABLE, &
99 DIMENSION(:, :, :),
INTENT(OUT) :: inverse_k
100 REAL(kind=
dp),
INTENT(OUT) :: projection_error
101 LOGICAL,
INTENT(OUT) :: used_fft
102 INTEGER,
INTENT(OUT) :: info
105 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :, :) :: blocks
107 IF (
SIZE(operator_matrix, 1) /=
SIZE(operator_matrix, 2))
THEN
108 cpabort(
"Lattice preconditioner operator must be square")
110 IF (any(lattice_dims <= 0)) cpabort(
"Lattice dimensions must be positive")
111 n =
SIZE(operator_matrix, 1)
112 ncell = product(lattice_dims)
113 IF (
modulo(n, ncell) /= 0)
THEN
114 cpabort(
"AO dimension does not match replicated cells")
116 CALL project_lattice_operator(operator_matrix, lattice_dims, blocks, projection_error)
132 REAL(kind=
dp),
DIMENSION(:, :, :),
INTENT(IN) :: blocks
133 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
134 COMPLEX(KIND=dp),
ALLOCATABLE, &
135 DIMENSION(:, :, :),
INTENT(OUT) :: inverse_k
136 LOGICAL,
INTENT(OUT) :: used_fft
137 INTEGER,
INTENT(OUT) :: info
139 INTEGER :: block_size, ncell
140 INTEGER,
ALLOCATABLE,
DIMENSION(:, :) :: index_to_cell
141 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :) :: xkp
143 IF (any(lattice_dims <= 0)) cpabort(
"Lattice dimensions must be positive")
144 ncell = product(lattice_dims)
145 block_size =
SIZE(blocks, 1)
146 IF (block_size <= 0 .OR.
SIZE(blocks, 2) /= block_size .OR.
SIZE(blocks, 3) /= ncell)
THEN
147 cpabort(
"Projected lattice blocks have inconsistent dimensions")
150 ALLOCATE (index_to_cell(3, ncell), xkp(3, ncell))
152 ALLOCATE (inverse_k(block_size, block_size, ncell))
153 CALL cell_to_k_grid_fft(blocks, index_to_cell, xkp, lattice_dims, inverse_k, used_fft)
154 CALL invert_hermitian_blocks(inverse_k, info)
155 DEALLOCATE (index_to_cell, xkp)
171 correction_indices, operator_columns, coarse_inverse, &
172 corrected_projection_error, info)
174 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(IN) :: operator_matrix
175 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
176 INTEGER,
INTENT(IN) :: local_cell_count
177 INTEGER,
ALLOCATABLE,
DIMENSION(:),
INTENT(OUT) :: correction_indices
178 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :), &
179 INTENT(OUT) :: operator_columns, coarse_inverse
180 REAL(kind=
dp),
INTENT(OUT) :: corrected_projection_error
181 INTEGER,
INTENT(OUT) :: info
183 INTEGER :: block_size, cell, chosen, i, index, &
184 local_rank, n, ncell, row_first, &
186 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: selected_cells
187 LOGICAL,
ALLOCATABLE,
DIMENSION(:) :: selected
188 REAL(kind=
dp) :: denominator
189 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:) :: scores
190 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :) :: projected_operator, residual
191 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :, :) :: blocks
193 IF (
SIZE(operator_matrix, 1) /=
SIZE(operator_matrix, 2))
THEN
194 cpabort(
"Lattice local-correction operator must be square")
196 IF (any(lattice_dims <= 0)) cpabort(
"Lattice dimensions must be positive")
197 n =
SIZE(operator_matrix, 1)
198 ncell = product(lattice_dims)
199 IF (
modulo(n, ncell) /= 0) cpabort(
"AO dimension does not match replicated cells")
200 IF (local_cell_count <= 0 .OR. local_cell_count >= ncell)
THEN
201 cpabort(
"Lattice local correction requires between one and ncell-1 cells")
204 local_rank = local_cell_count*block_size
206 CALL project_lattice_operator(operator_matrix, lattice_dims, blocks, &
207 corrected_projection_error, projected_operator)
209 ALLOCATE (residual(n, n))
210 residual(:, :) = operator_matrix - projected_operator
211 DEALLOCATE (projected_operator)
212 ALLOCATE (scores(ncell), selected(ncell), selected_cells(local_cell_count))
214 DO chosen = 1, local_cell_count
217 IF (selected(cell)) cycle
218 row_first = (cell - 1)*block_size + 1
219 row_last = cell*block_size
220 scores(cell) = sum(residual(row_first:row_last, :)**2) + &
221 sum(residual(:, row_first:row_last)**2) - &
222 sum(residual(row_first:row_last, row_first:row_last)**2)
224 index = maxloc(scores, dim=1, mask=.NOT. selected)
225 selected(index) = .true.
226 selected_cells(chosen) = index
227 row_first = (index - 1)*block_size + 1
228 row_last = index*block_size
229 residual(row_first:row_last, :) = 0.0_dp
230 residual(:, row_first:row_last) = 0.0_dp
233 ALLOCATE (correction_indices(local_rank))
235 DO chosen = 1, local_cell_count
236 cell = selected_cells(chosen)
239 correction_indices(index) = (cell - 1)*block_size + i
243 denominator = sum(operator_matrix**2)
244 corrected_projection_error = sqrt(sum(residual**2)/max(denominator, tiny(denominator)))
246 ALLOCATE (operator_columns(n, local_rank), coarse_inverse(local_rank, local_rank))
247 operator_columns(:, :) = operator_matrix(:, correction_indices)
248 coarse_inverse(:, :) = operator_matrix(correction_indices, correction_indices)
249 CALL dpotrf(
'U', local_rank, coarse_inverse, local_rank, info)
250 IF (info == 0)
CALL dpotri(
'U', local_rank, coarse_inverse, local_rank, info)
252 DO i = 1, local_rank - 1
253 coarse_inverse(i + 1:local_rank, i) = coarse_inverse(i, i + 1:local_rank)
257 DEALLOCATE (residual, scores, selected, selected_cells)
269 SUBROUTINE project_lattice_operator(operator_matrix, lattice_dims, blocks, projection_error, &
272 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(IN) :: operator_matrix
273 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
274 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :, :), &
275 INTENT(OUT) :: blocks
276 REAL(kind=
dp),
INTENT(OUT) :: projection_error
277 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :), &
278 INTENT(OUT),
OPTIONAL :: projected_operator
280 INTEGER :: alpha, beta, block_size, delta_index, &
281 icell, jcell, n, ncell
282 INTEGER,
ALLOCATABLE,
DIMENSION(:, :) :: index_to_cell
283 INTEGER,
DIMENSION(3) :: delta
284 REAL(kind=
dp) :: denominator, difference, numerator
285 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :) :: xkp
287 IF (
SIZE(operator_matrix, 1) /=
SIZE(operator_matrix, 2))
THEN
288 cpabort(
"Lattice preconditioner operator must be square")
290 IF (any(lattice_dims <= 0)) cpabort(
"Lattice dimensions must be positive")
291 n =
SIZE(operator_matrix, 1)
292 ncell = product(lattice_dims)
293 IF (
modulo(n, ncell) /= 0) cpabort(
"AO dimension does not match replicated cells")
296 ALLOCATE (index_to_cell(3, ncell), xkp(3, ncell))
298 ALLOCATE (blocks(block_size, block_size, ncell), source=0.0_dp)
302 delta =
modulo(index_to_cell(:, icell) - index_to_cell(:, jcell), lattice_dims)
303 delta_index = cell_linear_index(delta, lattice_dims)
304 DO beta = 1, block_size
305 DO alpha = 1, block_size
306 blocks(alpha, beta, delta_index) = blocks(alpha, beta, delta_index) + &
307 operator_matrix((icell - 1)*block_size + alpha, &
308 (jcell - 1)*block_size + beta)/ &
315 IF (
PRESENT(projected_operator))
ALLOCATE (projected_operator(n, n))
320 delta =
modulo(index_to_cell(:, icell) - index_to_cell(:, jcell), lattice_dims)
321 delta_index = cell_linear_index(delta, lattice_dims)
322 DO beta = 1, block_size
323 DO alpha = 1, block_size
324 IF (
PRESENT(projected_operator))
THEN
325 projected_operator((icell - 1)*block_size + alpha, &
326 (jcell - 1)*block_size + beta) = &
327 blocks(alpha, beta, delta_index)
329 difference = operator_matrix((icell - 1)*block_size + alpha, &
330 (jcell - 1)*block_size + beta) - &
331 blocks(alpha, beta, delta_index)
332 numerator = numerator + difference*difference
333 denominator = denominator + &
334 operator_matrix((icell - 1)*block_size + alpha, &
335 (jcell - 1)*block_size + beta)**2
340 projection_error = sqrt(numerator/max(denominator, tiny(denominator)))
342 DEALLOCATE (index_to_cell, xkp)
344 END SUBROUTINE project_lattice_operator
357 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
358 INTEGER,
INTENT(IN) :: block_size, rhs_count, num_pe
360 INTEGER :: ncell, nrhs
361 REAL(kind=
dp) :: block_size_real, communication_work, &
362 dense_work, fft_work, matrix_work, &
363 ncell_real, nrhs_real, setup_work
365 ncell = max(1, product(lattice_dims))
366 nrhs = max(1, rhs_count)
367 IF (block_size <= 0)
THEN
371 ncell_real = real(ncell, kind=
dp)
372 nrhs_real = real(nrhs, kind=
dp)
373 block_size_real = real(block_size, kind=
dp)
379 dense_work = (ncell_real*block_size_real)**2*nrhs_real
380 matrix_work = ncell_real*block_size_real**2*nrhs_real
381 fft_work = 4.0_dp*ncell_real*block_size_real*nrhs_real* &
382 log(real(max(2, ncell), kind=
dp))/log(2.0_dp)
383 setup_work = 8.0_dp*ncell_real*block_size_real
384 communication_work = 2.0_dp*ncell_real*block_size_real*nrhs_real* &
385 log(real(max(2, num_pe + 1), kind=
dp))/log(2.0_dp)
386 ratio = (matrix_work + fft_work + setup_work + communication_work)/max(dense_work, tiny(dense_work))
398 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
399 INTEGER,
INTENT(IN) :: operator_count
403 ncell = max(1, product(lattice_dims))
406 ratio = 2.0_dp*real(max(1, operator_count), kind=
dp)/real(ncell, kind=
dp)
419 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
420 INTEGER,
INTENT(IN) :: local_cell_count
423 REAL(kind=
dp) :: local_fraction
425 ncell = max(1, product(lattice_dims))
426 IF (local_cell_count <= 0)
THEN
430 local_fraction = real(local_cell_count, kind=
dp)/real(ncell, kind=
dp)
432 ratio = 2.0_dp*(local_fraction + local_fraction**2)
444 local_cell_count)
RESULT(ratio)
446 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
447 INTEGER,
INTENT(IN) :: operator_count, local_cell_count
450 REAL(kind=
dp) :: local_fraction
452 ncell = max(1, product(lattice_dims))
453 IF (local_cell_count <= 0)
THEN
457 local_fraction = real(local_cell_count, kind=
dp)/real(ncell, kind=
dp)
458 ratio = real(max(1, operator_count), kind=
dp)*(local_fraction + local_fraction**2)
475 num_pe, projection_error, used_fft, info) &
478 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
479 INTEGER,
INTENT(IN) :: block_size, rhs_count, operator_count, &
481 REAL(kind=
dp),
INTENT(IN) :: projection_error
482 LOGICAL,
INTENT(IN) :: used_fft
483 INTEGER,
INTENT(IN) :: info
487 selected = selected .AND. &
505 used_fft, imaginary_residual)
507 COMPLEX(KIND=dp),
DIMENSION(:, :, :),
INTENT(IN) :: inverse_k
508 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
509 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(IN) :: matrix_in
510 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(OUT) :: matrix_out
511 LOGICAL,
INTENT(OUT) :: used_fft
512 REAL(kind=
dp),
INTENT(OUT),
OPTIONAL :: imaginary_residual
514 COMPLEX(KIND=dp),
ALLOCATABLE,
DIMENSION(:, :, :) :: input_k, input_rs, output_k, output_rs
515 INTEGER :: block_size, icell, ncell
516 LOGICAL :: forward_fft, inverse_fft
518 IF (any(lattice_dims <= 0)) cpabort(
"Lattice dimensions must be positive")
519 ncell = product(lattice_dims)
520 block_size =
SIZE(inverse_k, 1)
521 IF (
SIZE(inverse_k, 2) /= block_size .OR.
SIZE(inverse_k, 3) /= ncell)
THEN
522 cpabort(
"Inconsistent inverse blocks in lattice preconditioner")
524 IF (
SIZE(matrix_in, 1) /= block_size*ncell .OR. &
525 any(shape(matrix_out) /= shape(matrix_in)))
THEN
526 cpabort(
"Inconsistent dense matrix shape in lattice preconditioner")
529 ALLOCATE (input_rs(block_size,
SIZE(matrix_in, 2), ncell))
531 input_rs(:, :, icell) = cmplx( &
532 matrix_in((icell - 1)*block_size + 1:icell*block_size, :), 0.0_dp, kind=
dp)
535 ALLOCATE (input_k(block_size,
SIZE(matrix_in, 2), ncell))
536 ALLOCATE (output_k(block_size,
SIZE(matrix_in, 2), ncell))
537 ALLOCATE (output_rs(block_size,
SIZE(matrix_in, 2), ncell))
538 CALL batched_lattice_fft(input_rs, lattice_dims,
bwfft, input_k, forward_fft)
540 output_k(:, :, icell) = matmul(inverse_k(:, :, icell), input_k(:, :, icell))
542 CALL batched_lattice_fft(output_k, lattice_dims,
fwfft, output_rs, inverse_fft)
543 used_fft = forward_fft .AND. inverse_fft
544 IF (
PRESENT(imaginary_residual)) imaginary_residual = maxval(abs(aimag(output_rs)))
547 matrix_out((icell - 1)*block_size + 1:icell*block_size, :) = real(output_rs(:, :, icell), kind=
dp)
550 DEALLOCATE (input_k, input_rs, output_k, output_rs)
565 used_fft, imaginary_residual, state_indices)
567 COMPLEX(KIND=dp),
DIMENSION(:, :, :, :), &
568 INTENT(IN) :: inverse_k
569 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
570 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(IN) :: matrix_in
571 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(OUT) :: matrix_out
572 LOGICAL,
INTENT(OUT) :: used_fft
573 REAL(kind=
dp),
INTENT(OUT),
OPTIONAL :: imaginary_residual
574 INTEGER,
DIMENSION(:),
INTENT(IN),
OPTIONAL :: state_indices
576 COMPLEX(KIND=dp),
ALLOCATABLE,
DIMENSION(:, :, :) :: input_k, input_rs, output_k, output_rs
577 INTEGER :: block_size, icell, j, ncell
578 LOGICAL :: forward_fft, inverse_fft
580 IF (any(lattice_dims <= 0)) cpabort(
"Lattice dimensions must be positive")
581 ncell = product(lattice_dims)
582 block_size =
SIZE(inverse_k, 1)
583 IF (
SIZE(inverse_k, 2) /= block_size .OR.
SIZE(inverse_k, 3) /= ncell)
THEN
584 cpabort(
"Inconsistent state-dependent inverse blocks in lattice preconditioner")
586 IF (
PRESENT(state_indices))
THEN
587 IF (
SIZE(state_indices) /=
SIZE(matrix_in, 2) .OR. &
588 any(state_indices < 1) .OR. any(state_indices >
SIZE(inverse_k, 4)))
THEN
589 cpabort(
"Invalid state indices in lattice preconditioner")
591 ELSE IF (
SIZE(inverse_k, 4) /=
SIZE(matrix_in, 2))
THEN
592 cpabort(
"Inconsistent state-dependent inverse blocks in lattice preconditioner")
594 IF (
SIZE(matrix_in, 1) /= block_size*ncell .OR. &
595 any(shape(matrix_out) /= shape(matrix_in)))
THEN
596 cpabort(
"Inconsistent dense state matrix shape in lattice preconditioner")
599 ALLOCATE (input_rs(block_size,
SIZE(matrix_in, 2), ncell))
601 input_rs(:, :, icell) = cmplx( &
602 matrix_in((icell - 1)*block_size + 1:icell*block_size, :), 0.0_dp, kind=
dp)
605 ALLOCATE (input_k(block_size,
SIZE(matrix_in, 2), ncell))
606 ALLOCATE (output_k(block_size,
SIZE(matrix_in, 2), ncell))
607 ALLOCATE (output_rs(block_size,
SIZE(matrix_in, 2), ncell))
608 CALL batched_lattice_fft(input_rs, lattice_dims,
bwfft, input_k, forward_fft)
610 DO j = 1,
SIZE(matrix_in, 2)
611 IF (
PRESENT(state_indices))
THEN
612 output_k(:, j, icell) = &
613 matmul(inverse_k(:, :, icell, state_indices(j)), input_k(:, j, icell))
615 output_k(:, j, icell) = matmul(inverse_k(:, :, icell, j), input_k(:, j, icell))
619 CALL batched_lattice_fft(output_k, lattice_dims,
fwfft, output_rs, inverse_fft)
620 used_fft = forward_fft .AND. inverse_fft
621 IF (
PRESENT(imaginary_residual)) imaginary_residual = maxval(abs(aimag(output_rs)))
624 matrix_out((icell - 1)*block_size + 1:icell*block_size, :) = real(output_rs(:, :, icell), kind=
dp)
627 DEALLOCATE (input_k, input_rs, output_k, output_rs)
639 SUBROUTINE batched_lattice_fft(values_in, lattice_dims, fsign, values_out, used_fft)
641 COMPLEX(KIND=dp),
DIMENSION(:, :, :),
INTENT(IN) :: values_in
642 INTEGER,
DIMENSION(3),
INTENT(IN) :: lattice_dims
643 INTEGER,
INTENT(IN) :: fsign
644 COMPLEX(KIND=dp),
DIMENSION(:, :, :),
INTENT(OUT) :: values_out
645 LOGICAL,
INTENT(OUT) :: used_fft
647 COMPLEX(KIND=dp),
ALLOCATABLE, &
648 DIMENSION(:, :, :, :) :: grid
649 INTEGER :: attempt, batch_index, d, i, icell, ix, &
650 iy, iz, j, radix_length, stat
651 INTEGER,
DIMENSION(3) :: input_stride, nfft, output_stride, stride
652 LOGICAL :: compatible
653 REAL(kind=
dp) :: normalization
655 IF (any(lattice_dims <= 0) .OR.
SIZE(values_in, 3) /= product(lattice_dims) .OR. &
656 any(shape(values_out) /= shape(values_in)))
THEN
657 cpabort(
"Invalid shape in batched lattice FFT")
660 cpabort(
"Invalid direction in batched lattice FFT")
667 IF (nfft(d) >= 3)
THEN
669 IF (radix_length == nfft(d))
THEN
674 nfft(d) = nfft(d) + lattice_dims(d)
676 IF (.NOT. compatible)
EXIT
678 IF (.NOT. compatible)
THEN
679 values_out = cmplx(0.0_dp, 0.0_dp, kind=
dp)
684 stride = nfft/lattice_dims
687 IF (fsign ==
bwfft) input_stride = stride
688 IF (fsign ==
fwfft) output_stride = stride
689 ALLOCATE (grid(
SIZE(values_in, 1)*
SIZE(values_in, 2), nfft(1), nfft(2), nfft(3)))
690 grid = cmplx(0.0_dp, 0.0_dp, kind=
dp)
692 DO iz = 0, lattice_dims(3) - 1
693 DO iy = 0, lattice_dims(2) - 1
694 DO ix = 0, lattice_dims(1) - 1
696 DO j = 1,
SIZE(values_in, 2)
697 DO i = 1,
SIZE(values_in, 1)
698 batch_index = i +
SIZE(values_in, 1)*(j - 1)
699 grid(batch_index, ix*input_stride(1) + 1, iy*input_stride(2) + 1, &
700 iz*input_stride(3) + 1) = values_in(i, j, icell)
709 CALL transform_grid_dimension(grid, d, fsign, stat)
713 values_out = cmplx(0.0_dp, 0.0_dp, kind=
dp)
719 normalization = 1.0_dp
720 IF (fsign ==
fwfft)
THEN
721 normalization = real(product(nfft), kind=
dp)/real(product(lattice_dims), kind=
dp)
724 DO iz = 0, lattice_dims(3) - 1
725 DO iy = 0, lattice_dims(2) - 1
726 DO ix = 0, lattice_dims(1) - 1
728 DO j = 1,
SIZE(values_out, 2)
729 DO i = 1,
SIZE(values_out, 1)
730 batch_index = i +
SIZE(values_out, 1)*(j - 1)
731 values_out(i, j, icell) = normalization* &
732 grid(batch_index, ix*output_stride(1) + 1, iy*output_stride(2) + 1, &
733 iz*output_stride(3) + 1)
742 END SUBROUTINE batched_lattice_fft
751 SUBROUTINE transform_grid_dimension(grid, direction, fsign, stat)
753 COMPLEX(KIND=dp),
DIMENSION(:, :, :, :), &
754 INTENT(INOUT) :: grid
755 INTEGER,
INTENT(IN) :: direction, fsign
756 INTEGER,
INTENT(OUT) :: stat
758 COMPLEX(KIND=dp),
CONTIGUOUS,
DIMENSION(:, :), &
759 POINTER :: line_in, line_out
760 INTEGER :: ibatch, iline, ix, iy, iz, m, n
761 REAL(kind=
dp) :: scale
763 n =
SIZE(grid, direction + 1)
765 CALL fft_alloc(line_in, [n, m])
766 CALL fft_alloc(line_out, [n, m])
768 SELECT CASE (direction)
770 DO iz = 1,
SIZE(grid, 4)
771 DO iy = 1,
SIZE(grid, 3)
772 DO ibatch = 1,
SIZE(grid, 1)
774 line_in(:, iline) = grid(ibatch, :, iy, iz)
779 DO iz = 1,
SIZE(grid, 4)
780 DO ix = 1,
SIZE(grid, 2)
781 DO ibatch = 1,
SIZE(grid, 1)
783 line_in(:, iline) = grid(ibatch, ix, :, iz)
788 DO iy = 1,
SIZE(grid, 3)
789 DO ix = 1,
SIZE(grid, 2)
790 DO ibatch = 1,
SIZE(grid, 1)
792 line_in(:, iline) = grid(ibatch, ix, iy, :)
797 cpabort(
"Invalid batched FFT grid direction")
801 IF (fsign ==
fwfft) scale = 1.0_dp/real(n, kind=
dp)
802 CALL fft_1d_many(fsign, n, m, .false., .false., n, n, &
803 line_in, line_out, scale, stat)
806 SELECT CASE (direction)
808 DO iz = 1,
SIZE(grid, 4)
809 DO iy = 1,
SIZE(grid, 3)
810 DO ibatch = 1,
SIZE(grid, 1)
812 grid(ibatch, :, iy, iz) = line_out(:, iline)
817 DO iz = 1,
SIZE(grid, 4)
818 DO ix = 1,
SIZE(grid, 2)
819 DO ibatch = 1,
SIZE(grid, 1)
821 grid(ibatch, ix, :, iz) = line_out(:, iline)
826 DO iy = 1,
SIZE(grid, 3)
827 DO ix = 1,
SIZE(grid, 2)
828 DO ibatch = 1,
SIZE(grid, 1)
830 grid(ibatch, ix, iy, :) = line_out(:, iline)
836 CALL fft_dealloc(line_in)
837 CALL fft_dealloc(line_out)
839 END SUBROUTINE transform_grid_dimension
847 PURE INTEGER FUNCTION cell_linear_index(coordinate, lattice_dims)
RESULT(index)
849 INTEGER,
DIMENSION(3),
INTENT(IN) :: coordinate, lattice_dims
851 index = coordinate(1) + lattice_dims(1)*(coordinate(2) + &
852 lattice_dims(2)*coordinate(3)) + 1
854 END FUNCTION cell_linear_index
861 SUBROUTINE invert_hermitian_blocks(blocks, info)
863 COMPLEX(KIND=dp),
DIMENSION(:, :, :), &
864 INTENT(INOUT) :: blocks
865 INTEGER,
INTENT(OUT) :: info
867 COMPLEX(KIND=dp) :: value
868 COMPLEX(KIND=dp),
ALLOCATABLE,
DIMENSION(:) :: solution, work
869 COMPLEX(KIND=dp),
ALLOCATABLE,
DIMENSION(:, :) :: factor, inverse
870 INTEGER :: i, iblock, j, k, m, n
871 REAL(kind=
dp) :: diagonal
874 cpassert(
SIZE(blocks, 2) == n)
875 ALLOCATE (factor(n, n), inverse(n, n), solution(n), work(n))
877 DO iblock = 1,
SIZE(blocks, 3)
878 factor = cmplx(0.0_dp, 0.0_dp, kind=
dp)
879 inverse(:, :) = 0.5_dp*(blocks(:, :, iblock) + &
880 conjg(transpose(blocks(:, :, iblock))))
884 diagonal = real(inverse(j, j), kind=
dp)
886 diagonal = diagonal - abs(factor(m, j))**2
888 IF (.NOT. ieee_is_finite(diagonal) .OR. diagonal <= 0.0_dp)
THEN
890 DEALLOCATE (factor, inverse, solution, work)
893 factor(j, j) = cmplx(sqrt(diagonal), 0.0_dp, kind=
dp)
895 value = inverse(j, k)
897 value =
value - conjg(factor(m, j))*factor(m, k)
899 factor(j, k) =
value/factor(j, j)
906 work = cmplx(0.0_dp, 0.0_dp, kind=
dp)
907 solution = cmplx(0.0_dp, 0.0_dp, kind=
dp)
909 value = cmplx(0.0_dp, 0.0_dp, kind=
dp)
910 IF (i == j)
value = cmplx(1.0_dp, 0.0_dp, kind=
dp)
912 value =
value - conjg(factor(m, i))*work(m)
914 work(i) =
value/conjg(factor(i, i))
919 value =
value - factor(i, m)*solution(m)
921 solution(i) =
value/factor(i, i)
923 inverse(:, j) = solution
925 blocks(:, :, iblock) = 0.5_dp*(inverse + conjg(transpose(inverse)))
927 DEALLOCATE (factor, inverse, solution, work)
929 END SUBROUTINE invert_hermitian_blocks
static GRID_HOST_DEVICE int modulo(int a, int m)
Equivalent of Fortran's MODULO, which always return a positive number. https://gcc....
Defines the basic variable types.
integer, parameter, public dp
Batched lattice Fourier transforms for complete regular k-point grids.
subroutine, public cell_to_k_grid_fft(values_rs, index_to_cell, xkp, nkp_grid, values_k, used_fft, deriv_direction, hmat, selected_kpoints)
Transform a batch of real matrices from image cells to every supplied k point.
Block-circulant inverse operators for replicated-cell OT preconditioners.
real(kind=dp), parameter, public lattice_fft_auto_max_cost_ratio
subroutine, public build_lattice_local_correction(operator_matrix, lattice_dims, local_cell_count, correction_indices, operator_columns, coarse_inverse, corrected_projection_error, info)
Build a balanced local correction for selected non-circulant cell blocks.
subroutine, public apply_lattice_inverse_dense(inverse_k, lattice_dims, matrix_in, matrix_out, used_fft, imaginary_residual)
Apply inverse Fourier blocks to a dense cell-major real matrix.
subroutine, public apply_lattice_state_inverse_dense(inverse_k, lattice_dims, matrix_in, matrix_out, used_fft, imaginary_residual, state_indices)
Apply one inverse Fourier operator to every column of a dense real matrix.
subroutine, public build_lattice_inverse(operator_matrix, lattice_dims, inverse_k, projection_error, used_fft, info)
Project a cell-major SPD operator onto lattice translations and invert its Fourier blocks.
real(kind=dp), parameter, public lattice_fft_auto_max_error
pure real(kind=dp) function, public lattice_local_storage_ratio(lattice_dims, operator_count, local_cell_count)
Estimate balanced-local-correction storage relative to one dense real operator.
pure real(kind=dp) function, public lattice_fft_storage_ratio(lattice_dims, operator_count)
Estimate reciprocal-block storage relative to one dense real operator.
pure logical function, public lattice_fft_auto_select(lattice_dims, block_size, rhs_count, operator_count, num_pe, projection_error, used_fft, info)
Conservative error-, work-, and storage-aware AUTO selector.
subroutine, public lattice_grid(lattice_dims, index_to_cell, xkp)
Enumerate a regular direct/reciprocal lattice with the first direction varying fastest.
integer, parameter, public lattice_fft_auto_min_cells
subroutine, public build_lattice_inverse_from_blocks(blocks, lattice_dims, inverse_k, used_fft, info)
Transform and invert already projected real-space lattice blocks.
pure real(kind=dp) function, public lattice_local_cost_ratio(lattice_dims, local_cell_count)
Estimate balanced-local-correction work relative to a dense inverse application.
pure real(kind=dp) function, public lattice_fft_cost_ratio(lattice_dims, block_size, rhs_count, num_pe)
Estimate lattice-FFT application work relative to a dense inverse application.
real(kind=dp), parameter, public lattice_fft_auto_max_storage_ratio