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