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) STOP 1
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)) STOP 2
27   if (any (xy(:, 1:2) .ne. 0)) STOP 3
28   if (any (xy(:, 5) .ne. 0)) STOP 4
29   if (any (xy (1, 3:4) .ne. 0)) STOP 5
30   if (any (xy (5, 3:4) .ne. 0)) STOP 6
31   if (xy(3, 3) .ne. 10) STOP 7
32   if (xy(3, 4) .ne. 10) STOP 8
33   if (any (xy(2:4, 3:4) .ne. window)) STOP 9
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)) STOP 10
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)) STOP 11
61   if (.not. associated(b)) STOP 12
62   call nullify_pp (a)
63   if (associated (a)) STOP 13
64   if (.not. associated (b)) STOP 14
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)) STOP 15
89   if (associated (r2%r2p)) STOP 16
90   if (associated (e2%rp)) STOP 17
91   if (associated (e1%rp)) STOP 18
92   if (associated (e3%rp)) STOP 19
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)) STOP 20
103   if (.not. associated (r2%r2p)) STOP 21
104   if (.not. associated (e1%rp)) STOP 22
105   if (.not. associated (e2%rp)) STOP 23
106   if (associated (e3%rp)) STOP 24
107   if (r1%r1p%value .ne. 22) STOP 25
108   if (r2%r2p%value .ne. 11) STOP 26
109   if (e1%value .ne. 33) STOP 27
110   if (e2%value .ne. 44) STOP 28
111   if (e3%value .ne. 55) STOP 29
112   if (r1%value .ne. 11) STOP 30
113   if (r2%value .ne. 22) STOP 31
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)) STOP 32
130   call sub1 (x, xp)
131   if (associated (xp, y)) STOP 33
132   if (.not. associated (xp, x)) STOP 34
133end
134
135