! Program to test the ASSOCIATED intrinsic.
|
! Program to test the ASSOCIATED intrinsic.
|
program intrinsic_associated
|
program intrinsic_associated
|
call pointer_to_section ()
|
call pointer_to_section ()
|
call associate_1 ()
|
call associate_1 ()
|
call pointer_to_derived_1 ()
|
call pointer_to_derived_1 ()
|
call associated_2 ()
|
call associated_2 ()
|
end
|
end
|
|
|
subroutine pointer_to_section ()
|
subroutine pointer_to_section ()
|
integer, dimension(5, 5), target :: xy
|
integer, dimension(5, 5), target :: xy
|
integer, dimension(:, :), pointer :: window
|
integer, dimension(:, :), pointer :: window
|
data xy /25*0/
|
data xy /25*0/
|
logical t
|
logical t
|
|
|
window => xy(2:4, 3:4)
|
window => xy(2:4, 3:4)
|
window = 10
|
window = 10
|
window (1, 1) = 0101
|
window (1, 1) = 0101
|
window (3, 2) = 4161
|
window (3, 2) = 4161
|
window (3, 1) = 4101
|
window (3, 1) = 4101
|
window (1, 2) = 0161
|
window (1, 2) = 0161
|
|
|
t = associated (window, xy(2:4, 3:4))
|
t = associated (window, xy(2:4, 3:4))
|
if (.not.t) call abort ()
|
if (.not.t) call abort ()
|
! Check that none of the array got mangled
|
! Check that none of the array got mangled
|
if ((xy(2, 3) .ne. 0101) .or. (xy (4, 4) .ne. 4161) &
|
if ((xy(2, 3) .ne. 0101) .or. (xy (4, 4) .ne. 4161) &
|
.or. (xy(4, 3) .ne. 4101) .or. (xy (2, 4) .ne. 0161)) call abort ()
|
.or. (xy(4, 3) .ne. 4101) .or. (xy (2, 4) .ne. 0161)) call abort ()
|
if (any (xy(:, 1:2) .ne. 0)) call abort ()
|
if (any (xy(:, 1:2) .ne. 0)) call abort ()
|
if (any (xy(:, 5) .ne. 0)) call abort ()
|
if (any (xy(:, 5) .ne. 0)) call abort ()
|
if (any (xy (1, 3:4) .ne. 0)) call abort ()
|
if (any (xy (1, 3:4) .ne. 0)) call abort ()
|
if (any (xy (5, 3:4) .ne. 0)) call abort ()
|
if (any (xy (5, 3:4) .ne. 0)) call abort ()
|
if (xy(3, 3) .ne. 10) call abort ()
|
if (xy(3, 3) .ne. 10) call abort ()
|
if (xy(3, 4) .ne. 10) call abort ()
|
if (xy(3, 4) .ne. 10) call abort ()
|
if (any (xy(2:4, 3:4) .ne. window)) call abort ()
|
if (any (xy(2:4, 3:4) .ne. window)) call abort ()
|
end
|
end
|
|
|
subroutine sub1 (a, ap)
|
subroutine sub1 (a, ap)
|
integer, pointer :: ap(:, :)
|
integer, pointer :: ap(:, :)
|
integer, target :: a(10, 10)
|
integer, target :: a(10, 10)
|
|
|
ap => a
|
ap => a
|
end
|
end
|
|
|
subroutine nullify_pp (a)
|
subroutine nullify_pp (a)
|
integer, pointer :: a(:, :)
|
integer, pointer :: a(:, :)
|
|
|
if (.not. associated (a)) call abort ()
|
if (.not. associated (a)) call abort ()
|
nullify (a)
|
nullify (a)
|
end
|
end
|
|
|
subroutine associate_1 ()
|
subroutine associate_1 ()
|
integer, pointer :: a(:, :), b(:, :)
|
integer, pointer :: a(:, :), b(:, :)
|
interface
|
interface
|
subroutine nullify_pp (a)
|
subroutine nullify_pp (a)
|
integer, pointer :: a(:, :)
|
integer, pointer :: a(:, :)
|
end subroutine nullify_pp
|
end subroutine nullify_pp
|
end interface
|
end interface
|
|
|
allocate (a(80, 80))
|
allocate (a(80, 80))
|
b => a
|
b => a
|
if (.not. associated(a)) call abort ()
|
if (.not. associated(a)) call abort ()
|
if (.not. associated(b)) call abort ()
|
if (.not. associated(b)) call abort ()
|
call nullify_pp (a)
|
call nullify_pp (a)
|
if (associated (a)) call abort ()
|
if (associated (a)) call abort ()
|
if (.not. associated (b)) call abort ()
|
if (.not. associated (b)) call abort ()
|
end
|
end
|
|
|
subroutine pointer_to_derived_1 ()
|
subroutine pointer_to_derived_1 ()
|
type record
|
type record
|
integer :: value
|
integer :: value
|
type(record), pointer :: rp
|
type(record), pointer :: rp
|
end type record
|
end type record
|
|
|
type record1
|
type record1
|
integer value
|
integer value
|
type(record2), pointer :: r1p
|
type(record2), pointer :: r1p
|
end type
|
end type
|
|
|
type record2
|
type record2
|
integer value
|
integer value
|
type(record1), pointer :: r2p
|
type(record1), pointer :: r2p
|
end type
|
end type
|
|
|
type(record), target :: e1, e2, e3
|
type(record), target :: e1, e2, e3
|
type(record1), target :: r1
|
type(record1), target :: r1
|
type(record2), target :: r2
|
type(record2), target :: r2
|
|
|
nullify (r1%r1p, r2%r2p, e1%rp, e2%rp, e3%rp)
|
nullify (r1%r1p, r2%r2p, e1%rp, e2%rp, e3%rp)
|
if (associated (r1%r1p)) call abort ()
|
if (associated (r1%r1p)) call abort ()
|
if (associated (r2%r2p)) call abort ()
|
if (associated (r2%r2p)) call abort ()
|
if (associated (e2%rp)) call abort ()
|
if (associated (e2%rp)) call abort ()
|
if (associated (e1%rp)) call abort ()
|
if (associated (e1%rp)) call abort ()
|
if (associated (e3%rp)) call abort ()
|
if (associated (e3%rp)) call abort ()
|
r1%r1p => r2
|
r1%r1p => r2
|
r2%r2p => r1
|
r2%r2p => r1
|
r1%value = 11
|
r1%value = 11
|
r2%value = 22
|
r2%value = 22
|
e1%rp => e2
|
e1%rp => e2
|
e2%rp => e3
|
e2%rp => e3
|
e1%value = 33
|
e1%value = 33
|
e1%rp%value = 44
|
e1%rp%value = 44
|
e1%rp%rp%value = 55
|
e1%rp%rp%value = 55
|
if (.not. associated (r1%r1p)) call abort ()
|
if (.not. associated (r1%r1p)) call abort ()
|
if (.not. associated (r2%r2p)) call abort ()
|
if (.not. associated (r2%r2p)) call abort ()
|
if (.not. associated (e1%rp)) call abort ()
|
if (.not. associated (e1%rp)) call abort ()
|
if (.not. associated (e2%rp)) call abort ()
|
if (.not. associated (e2%rp)) call abort ()
|
if (associated (e3%rp)) call abort ()
|
if (associated (e3%rp)) call abort ()
|
if (r1%r1p%value .ne. 22) call abort ()
|
if (r1%r1p%value .ne. 22) call abort ()
|
if (r2%r2p%value .ne. 11) call abort ()
|
if (r2%r2p%value .ne. 11) call abort ()
|
if (e1%value .ne. 33) call abort ()
|
if (e1%value .ne. 33) call abort ()
|
if (e2%value .ne. 44) call abort ()
|
if (e2%value .ne. 44) call abort ()
|
if (e3%value .ne. 55) call abort ()
|
if (e3%value .ne. 55) call abort ()
|
if (r1%value .ne. 11) call abort ()
|
if (r1%value .ne. 11) call abort ()
|
if (r2%value .ne. 22) call abort ()
|
if (r2%value .ne. 22) call abort ()
|
|
|
end
|
end
|
|
|
subroutine associated_2 ()
|
subroutine associated_2 ()
|
integer, pointer :: xp(:, :)
|
integer, pointer :: xp(:, :)
|
integer, target :: x(10, 10)
|
integer, target :: x(10, 10)
|
integer, target :: y(100, 100)
|
integer, target :: y(100, 100)
|
interface
|
interface
|
subroutine sub1 (a, ap)
|
subroutine sub1 (a, ap)
|
integer, pointer :: ap(:, :)
|
integer, pointer :: ap(:, :)
|
integer, target :: a(10, 1)
|
integer, target :: a(10, 1)
|
end
|
end
|
endinterface
|
endinterface
|
|
|
xp => y
|
xp => y
|
if (.not. associated (xp)) call abort ()
|
if (.not. associated (xp)) call abort ()
|
call sub1 (x, xp)
|
call sub1 (x, xp)
|
if (associated (xp, y)) call abort ()
|
if (associated (xp, y)) call abort ()
|
if (.not. associated (xp, x)) call abort ()
|
if (.not. associated (xp, x)) call abort ()
|
end
|
end
|
|
|
|
|
