1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
module function_32_mod
contains
function matprod(x, y) result(z)
real(8), intent(in) :: x(:, :)
real(8), intent(in) :: y(:, :)
real(8) :: z(size(x, 1), size(y, 2))
integer :: i, j
z = 1.0_8
end function matprod
function return_type_check(x) result(z)
real(8), intent(in) :: x(:, :)
real(8) :: z(size(x))
z = 1.0_8
end function
end module
program function_32
use function_32_mod
real(8) :: x(5,2)
integer :: iact(2)
integer :: nact
real(8) :: full_size(10)
iact = [2,1]
nact = -1
full_size = return_type_check(x(:,iact)) + 1.0_8
if(any(full_size /= 2.0_8)) error stop
x = matprod(x(:,iact), x(:, iact)) + 1.0_8
if(any(x /= 2.0_8)) error stop
call func(x, iact, nact)
contains
subroutine func(x, iact, nact)
real(8), intent(in) :: x(:,:)
integer, intent(inout) :: iact(:)
integer, intent(inout) :: nact
real(8) :: bmat(2, 2 + size(x,1))
real(8) :: yzmat_c(2, size(x,2))
real(8) :: tmp_x(size(x,1) * size(x,2))
integer :: npt
npt = size(x,1)
bmat(:, 1:npt) = matprod(yzmat_c, transpose(x))
if(any(bmat(:,1:npt) /= 1.0_8)) error stop
tmp_x = return_type_check(x(:,iact)) + 1.0_8
if(any(tmp_x /= 2.0_8)) error stop
yzmat_c = matprod(x(iact, :), x(:, iact)) + 1.0_8
if(any(yzmat_c /= 2.0_8)) error stop
nact = 2
bmat(:, 1:nact) = -matprod(yzmat_c, x(:, 1:nact))
if(any(bmat(:,1:nact) /= -1.0_8)) error stop
end subroutine
end program
|
