1! { dg-do run } 2! Transformational functions for zero-sized array and array sections 3! Contributed by Francois-Xavier Coudert <coudert@clipper.ens.fr> 4 5subroutine test_cshift 6 real :: tempn(1), tempm(1,2) 7 real,allocatable :: foo(:),bar(:,:),gee(:,:) 8 tempn = 2.0 9 tempm = 1.0 10 allocate(foo(0),bar(2,0),gee(0,7)) 11 if (any(cshift(foo,dim=1,shift=1)/= 0)) call abort 12 if (any(cshift(tempn(2:1),dim=1,shift=1)/= 0)) call abort 13 if (any(cshift(bar,shift=(/1,-1/),dim=1)/= 0)) call abort 14 if (any(cshift(bar,shift=(/1,-1/),dim=2)/= 0)) call abort 15 if (any(cshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort 16 if (any(cshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort 17 if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort 18 deallocate(foo,bar,gee) 19end 20 21subroutine test_eoshift 22 real :: tempn(1), tempm(1,2) 23 real,allocatable :: foo(:),bar(:,:),gee(:,:) 24 tempn = 2.0 25 tempm = 1.0 26 allocate(foo(0),bar(2,0),gee(0,7)) 27 if (any(eoshift(foo,dim=1,shift=1)/= 0)) call abort 28 if (any(eoshift(tempn(2:1),dim=1,shift=1)/= 0)) call abort 29 if (any(eoshift(bar,shift=(/1,-1/),dim=1)/= 0)) call abort 30 if (any(eoshift(bar,shift=(/1,-1/),dim=2)/= 0)) call abort 31 if (any(eoshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort 32 if (any(eoshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort 33 if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort 34 35 if (any(eoshift(foo,dim=1,shift=1,boundary=42.0)/= 0)) call abort 36 if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=42.0)/= 0)) call abort 37 if (any(eoshift(bar,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort 38 if (any(eoshift(bar,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort 39 if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort 40 if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort 41 if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort 42 43 if (any(eoshift(foo,dim=1,shift=1,boundary=42.0)/= 0)) call abort 44 if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=-7.0)/= 0)) call abort 45 if (any(eoshift(bar,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort 46 if (any(eoshift(bar,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort 47 if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort 48 if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort 49 if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort 50 deallocate(foo,bar,gee) 51end 52 53subroutine test_transpose 54 character(len=1) :: tempn(1,2) 55 character(len=1),allocatable :: foo(:,:), bar(:,:) 56 integer :: tempm(1,2) 57 integer,allocatable :: x(:,:), y(:,:) 58 tempn = 'a' 59 allocate(foo(3,0),bar(-2:-4,7:9)) 60 tempm = -42 61 allocate(x(3,0),y(-2:-4,7:9)) 62 if (any(transpose(tempn(-7:-8,:)) /= 'b')) call abort 63 if (any(transpose(tempn(:,9:8)) /= 'b')) call abort 64 if (any(transpose(foo) /= 'b')) call abort 65 if (any(transpose(bar) /= 'b')) call abort 66 if (any(transpose(tempm(-7:-8,:)) /= 0)) call abort 67 if (any(transpose(tempm(:,9:8)) /= 0)) call abort 68 if (any(transpose(x) /= 0)) call abort 69 if (any(transpose(y) /= 0)) call abort 70 deallocate(foo,bar,x,y) 71end 72 73subroutine test_reshape 74 character(len=1) :: tempn(1,2) 75 character(len=1),allocatable :: foo(:,:), bar(:,:) 76 integer :: tempm(1,2) 77 integer,allocatable :: x(:,:), y(:,:) 78 tempn = 'b' 79 tempm = -42 80 allocate(foo(3,0),bar(-2:-4,7:9),x(3,0),y(-2:-4,7:9)) 81 82 if (size(reshape(tempn(-7:-8,:),(/3,3/),pad=(/'a'/))) /= 9 .or. & 83 any(reshape(tempn(-7:-8,:),(/3,3/),pad=(/'a'/)) /= 'a')) call abort 84 if (size(reshape(tempn(-7:-8,:),(/3,3,3/),pad=(/'a'/))) /= 27 .or. & 85 any(reshape(tempn(-7:-8,:),(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort 86 if (size(reshape(tempn(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. & 87 any(reshape(tempn(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort 88 if (size(reshape(foo,(/3,3/),pad=(/'a'/))) /= 9 .or. & 89 any(reshape(foo,(/3,3/),pad=(/'a'/)) /= 'a')) call abort 90 if (size(reshape(foo,(/3,3,3/),pad=(/'a'/))) /= 27 .or. & 91 any(reshape(foo,(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort 92 if (size(reshape(foo,(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. & 93 any(reshape(foo,(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort 94 if (size(reshape(bar,(/3,3/),pad=(/'a'/))) /= 9 .or. & 95 any(reshape(bar,(/3,3/),pad=(/'a'/)) /= 'a')) call abort 96 if (size(reshape(bar,(/3,3,3/),pad=(/'a'/))) /= 27 .or. & 97 any(reshape(bar,(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort 98 if (size(reshape(bar,(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. & 99 any(reshape(bar,(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort 100 101 if (size(reshape(tempm(-7:-8,:),(/3,3/),pad=(/7/))) /= 9 .or. & 102 any(reshape(tempm(-7:-8,:),(/3,3/),pad=(/7/)) /= 7)) call abort 103 if (size(reshape(tempm(-7:-8,:),(/3,3,3/),pad=(/7/))) /= 27 .or. & 104 any(reshape(tempm(-7:-8,:),(/3,3,3/),pad=(/7/)) /= 7)) call abort 105 if (size(reshape(tempm(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. & 106 any(reshape(tempm(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort 107 if (size(reshape(x,(/3,3/),pad=(/7/))) /= 9 .or. & 108 any(reshape(x,(/3,3/),pad=(/7/)) /= 7)) call abort 109 if (size(reshape(x,(/3,3,3/),pad=(/7/))) /= 27 .or. & 110 any(reshape(x,(/3,3,3/),pad=(/7/)) /= 7)) call abort 111 if (size(reshape(x,(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. & 112 any(reshape(x,(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort 113 if (size(reshape(y,(/3,3/),pad=(/7/))) /= 9 .or. & 114 any(reshape(y,(/3,3/),pad=(/7/)) /= 7)) call abort 115 if (size(reshape(y,(/3,3,3/),pad=(/7/))) /= 27 .or. & 116 any(reshape(y,(/3,3,3/),pad=(/7/)) /= 7)) call abort 117 if (size(reshape(y,(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. & 118 any(reshape(y,(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort 119 120 deallocate(foo,bar,x,y) 121end 122 123subroutine test_pack 124 integer :: tempn(1,5) 125 integer,allocatable :: foo(:,:) 126 tempn = 2 127 allocate(foo(0,1:7)) 128 if (size(pack(foo,foo/=0)) /= 0 .or. any(pack(foo,foo/=0) /= -42)) call abort 129 if (size(pack(foo,foo/=0,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & 130 sum(pack(foo,foo/=0,(/1,3,4,5,1,0,7,9/))) /= 30) call abort 131 if (size(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0)) /= 0 .or. & 132 any(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0) /= -42)) call abort 133 if (size(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & 134 sum(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0,(/1,3,4,5,1,0,7,9/))) /= 30) & 135 call abort 136 if (size(pack(foo,.true.)) /= 0 .or. any(pack(foo,.true.) /= -42)) & 137 call abort 138 if (size(pack(foo,.true.,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & 139 sum(pack(foo,.true.,(/1,3,4,5,1,0,7,9/))) /= 30) call abort 140 if (size(pack(tempn(:,-4:-5),.true.)) /= 0 .or. & 141 any(pack(foo,.true.) /= -42)) call abort 142 if (size(pack(tempn(:,-4:-5),.true.,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & 143 sum(pack(tempn(:,-4:-5),.true.,(/1,3,4,5,1,0,7,9/))) /= 30) call abort 144 deallocate(foo) 145end 146 147subroutine test_unpack 148 integer :: tempn(1,5), tempv(5) 149 integer,allocatable :: foo(:,:), bar(:) 150 integer :: zero 151 tempn = 2 152 tempv = 5 153 zero = 0 154 allocate(foo(0,1:7),bar(0:-1)) 155 if (any(unpack(tempv,tempv/=0,tempv) /= 5) .or. & 156 size(unpack(tempv,tempv/=0,tempv)) /= 5) call abort 157 if (any(unpack(tempv(1:0),tempv/=0,tempv) /= 5) .or. & 158 size(unpack(tempv(1:0),tempv/=0,tempv)) /= 5) call abort 159 if (any(unpack(tempv,tempv(1:zero)/=0,tempv) /= -47)) call abort 160 if (any(unpack(tempv(5:4),tempv(1:zero)/=0,tempv) /= -47)) call abort 161 if (any(unpack(bar,foo==foo,foo) /= -47)) call abort 162 deallocate(foo,bar) 163end 164 165subroutine test_spread 166 real :: tempn(1) 167 real,allocatable :: foo(:) 168 tempn = 2.0 169 allocate(foo(0)) 170 if (any(spread(1,dim=1,ncopies=0) /= -17.0) .or. & 171 size(spread(1,dim=1,ncopies=0)) /= 0) call abort 172 if (any(spread(foo,dim=1,ncopies=1) /= -17.0) .or. & 173 size(spread(foo,dim=1,ncopies=1)) /= 0) call abort 174 if (any(spread(tempn(2:1),dim=1,ncopies=1) /= -17.0) .or. & 175 size(spread(tempn(2:1),dim=1,ncopies=1)) /= 0) call abort 176 deallocate(foo) 177end 178 179program test 180 call test_cshift 181 call test_eoshift 182 call test_transpose 183 call test_unpack 184 call test_spread 185 call test_pack 186 call test_reshape 187end 188