1! Program to test the ASSOCIATED intrinsic.
2program intrinsic_associated
3   call pointer_to_section ()
4   call associate_1 ()
5   call pointer_to_derived_1 ()
6   call associated_2 ()
7end
8
9subroutine pointer_to_section ()
10   integer, dimension(5, 5), target :: xy
11   integer, dimension(:, :), pointer :: window
12   data xy /25*0/
13   logical t
14
15   window => xy(2:4, 3:4)
16   window = 10
17   window (1, 1) = 0101
18   window (3, 2) = 4161
19   window (3, 1) = 4101
20   window (1, 2) = 0161
21
22   t = associated (window, xy(2:4, 3:4))
23   if (.not.t) call abort ()
24   ! Check that none of the array got mangled
25   if ((xy(2, 3) .ne. 0101) .or. (xy (4, 4) .ne. 4161) &
26       .or. (xy(4, 3) .ne. 4101) .or. (xy (2, 4) .ne. 0161)) call abort ()
27   if (any (xy(:, 1:2) .ne. 0)) call abort ()
28   if (any (xy(:, 5) .ne. 0)) call abort ()
29   if (any (xy (1, 3:4) .ne. 0)) call abort ()
30   if (any (xy (5, 3:4) .ne. 0)) call abort ()
31   if (xy(3, 3) .ne. 10) call abort ()
32   if (xy(3, 4) .ne. 10) call abort ()
33   if (any (xy(2:4, 3:4) .ne. window)) call abort ()
34end
35
36subroutine sub1 (a, ap)
37   integer, pointer :: ap(:, :)
38   integer, target :: a(10, 10)
39
40   ap => a
41end
42
43subroutine nullify_pp (a)
44   integer, pointer :: a(:, :)
45
46   if (.not. associated (a)) call abort ()
47   nullify (a)
48end
49
50subroutine associate_1 ()
51   integer, pointer :: a(:, :), b(:, :)
52   interface
53      subroutine nullify_pp (a)
54         integer, pointer :: a(:, :)
55      end subroutine nullify_pp
56   end interface
57
58   allocate (a(80, 80))
59   b => a
60   if (.not. associated(a)) call abort ()
61   if (.not. associated(b)) call abort ()
62   call nullify_pp (a)
63   if (associated (a)) call abort ()
64   if (.not. associated (b)) call abort ()
65end
66
67subroutine pointer_to_derived_1 ()
68   type record
69      integer :: value
70      type(record), pointer :: rp
71   end type record
72
73   type record1
74      integer value
75      type(record2), pointer :: r1p
76   end type
77
78   type record2
79      integer value
80      type(record1), pointer :: r2p
81   end type
82
83   type(record), target :: e1, e2, e3
84   type(record1), target :: r1
85   type(record2), target :: r2
86
87   nullify (r1%r1p, r2%r2p, e1%rp, e2%rp, e3%rp)
88   if (associated (r1%r1p)) call abort ()
89   if (associated (r2%r2p)) call abort ()
90   if (associated (e2%rp)) call abort ()
91   if (associated (e1%rp)) call abort ()
92   if (associated (e3%rp)) call abort ()
93   r1%r1p => r2
94   r2%r2p => r1
95   r1%value = 11
96   r2%value = 22
97   e1%rp => e2
98   e2%rp => e3
99   e1%value = 33
100   e1%rp%value = 44
101   e1%rp%rp%value = 55
102   if (.not. associated (r1%r1p)) call abort ()
103   if (.not. associated (r2%r2p)) call abort ()
104   if (.not. associated (e1%rp)) call abort ()
105   if (.not. associated (e2%rp)) call abort ()
106   if (associated (e3%rp)) call abort ()
107   if (r1%r1p%value .ne. 22) call abort ()
108   if (r2%r2p%value .ne. 11) call abort ()
109   if (e1%value .ne. 33) call abort ()
110   if (e2%value .ne. 44) call abort ()
111   if (e3%value .ne. 55) call abort ()
112   if (r1%value .ne. 11) call abort ()
113   if (r2%value .ne. 22) call abort ()
114
115end
116
117subroutine associated_2 ()
118   integer, pointer :: xp(:, :)
119   integer, target  :: x(10, 10)
120   integer, target  :: y(100, 100)
121   interface
122      subroutine sub1 (a, ap)
123         integer, pointer :: ap(:, :)
124         integer, target  :: a(10, 10)
125      end
126   endinterface
127
128   xp => y
129   if (.not. associated (xp)) call abort ()
130   call sub1 (x, xp)
131   if (associated (xp, y)) call abort ()
132   if (.not. associated (xp, x)) call abort ()
133end
134
135