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