9 integer,
private:: verbose=0
10 interface assignment(=)
11 module procedure vector_assign_scalar
14 module procedure vector_vector_dot
17 module procedure vector_scalar_mul, scalar_vector_mul, const3_vector_mul
20 module procedure vector_scalar_add
23 module procedure vector_scalar_sub
26 module procedure vector_scalar_divide
29 module procedure vector_cross_vector, vector_cross_real4, real4_cross_vector
34 SUBROUTINE allocate_vectors_a (n, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10)
36 real,
dimension(:,:,:,:),
allocatable,
optional:: v1, v2, v3, v4, v5, v6, v7, v8, v9, v10
38 call trace_begin(
'allocate_vectors_a')
39 if (
present(v1))
allocate(v1(n(1),n(2),n(3),3))
40 if (
present(v2))
allocate(v2(n(1),n(2),n(3),3))
41 if (
present(v3))
allocate(v3(n(1),n(2),n(3),3))
42 if (
present(v4))
allocate(v4(n(1),n(2),n(3),3))
43 if (
present(v5))
allocate(v5(n(1),n(2),n(3),3))
44 if (
present(v6))
allocate(v6(n(1),n(2),n(3),3))
45 if (
present(v7))
allocate(v7(n(1),n(2),n(3),3))
46 if (
present(v8))
allocate(v8(n(1),n(2),n(3),3))
47 if (
present(v9))
allocate(v9(n(1),n(2),n(3),3))
48 if (
present(v10))
allocate(v10(n(1),n(2),n(3),3))
49 if (
present(v1))
call io%bits_mem(storage_size(v1),product(shape(v1)),
'v1')
50 if (
present(v2))
call io%bits_mem(storage_size(v2),product(shape(v2)),
'v2')
51 if (
present(v3))
call io%bits_mem(storage_size(v3),product(shape(v3)),
'v3')
52 if (
present(v4))
call io%bits_mem(storage_size(v4),product(shape(v4)),
'v4')
53 if (
present(v5))
call io%bits_mem(storage_size(v5),product(shape(v5)),
'v5')
54 if (
present(v6))
call io%bits_mem(storage_size(v6),product(shape(v6)),
'v6')
55 if (
present(v7))
call io%bits_mem(storage_size(v7),product(shape(v7)),
'v7')
56 if (
present(v8))
call io%bits_mem(storage_size(v8),product(shape(v8)),
'v8')
57 if (
present(v9))
call io%bits_mem(storage_size(v9),product(shape(v9)),
'v9')
58 if (
present(v10))
call io%bits_mem(storage_size(v10),product(shape(v10)),
'v10')
60 END SUBROUTINE allocate_vectors_a
63 SUBROUTINE allocate_vectors (n, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10)
65 real,
dimension(:,:,:,:),
pointer,
optional:: v1, v2, v3, v4, v5, v6, v7, v8, v9, v10
67 call trace_begin(
'allocate_vectors')
68 if (
present(v1))
allocate(v1(n(1),n(2),n(3),3))
69 if (
present(v2))
allocate(v2(n(1),n(2),n(3),3))
70 if (
present(v3))
allocate(v3(n(1),n(2),n(3),3))
71 if (
present(v4))
allocate(v4(n(1),n(2),n(3),3))
72 if (
present(v5))
allocate(v5(n(1),n(2),n(3),3))
73 if (
present(v6))
allocate(v6(n(1),n(2),n(3),3))
74 if (
present(v7))
allocate(v7(n(1),n(2),n(3),3))
75 if (
present(v8))
allocate(v8(n(1),n(2),n(3),3))
76 if (
present(v9))
allocate(v9(n(1),n(2),n(3),3))
77 if (
present(v10))
allocate(v10(n(1),n(2),n(3),3))
78 if (
present(v1))
call io%bits_mem(storage_size(v1),product(shape(v1)),
'v1')
79 if (
present(v2))
call io%bits_mem(storage_size(v2),product(shape(v2)),
'v2')
80 if (
present(v3))
call io%bits_mem(storage_size(v3),product(shape(v3)),
'v3')
81 if (
present(v4))
call io%bits_mem(storage_size(v4),product(shape(v4)),
'v4')
82 if (
present(v5))
call io%bits_mem(storage_size(v5),product(shape(v5)),
'v5')
83 if (
present(v6))
call io%bits_mem(storage_size(v6),product(shape(v6)),
'v6')
84 if (
present(v7))
call io%bits_mem(storage_size(v7),product(shape(v7)),
'v7')
85 if (
present(v8))
call io%bits_mem(storage_size(v8),product(shape(v8)),
'v8')
86 if (
present(v9))
call io%bits_mem(storage_size(v9),product(shape(v9)),
'v9')
87 if (
present(v10))
call io%bits_mem(storage_size(v10),product(shape(v10)),
'v10')
89 END SUBROUTINE allocate_vectors
92 SUBROUTINE deallocate_vectors_a (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10)
94 real,
dimension(:,:,:,:),
allocatable,
optional:: v1, v2, v3, v4, v5, v6, v7, v8, v9, v10
96 call trace_begin(
'deallocate_vectors_a')
97 if (
present(v1))
call io%bits_mem(storage_size(v1),-product(shape(v1)),
'v1')
98 if (
present(v2))
call io%bits_mem(storage_size(v2),-product(shape(v2)),
'v2')
99 if (
present(v3))
call io%bits_mem(storage_size(v3),-product(shape(v3)),
'v3')
100 if (
present(v4))
call io%bits_mem(storage_size(v4),-product(shape(v4)),
'v4')
101 if (
present(v5))
call io%bits_mem(storage_size(v5),-product(shape(v5)),
'v5')
102 if (
present(v6))
call io%bits_mem(storage_size(v6),-product(shape(v6)),
'v6')
103 if (
present(v7))
call io%bits_mem(storage_size(v7),-product(shape(v7)),
'v7')
104 if (
present(v8))
call io%bits_mem(storage_size(v8),-product(shape(v8)),
'v8')
105 if (
present(v9))
call io%bits_mem(storage_size(v9),-product(shape(v9)),
'v9')
106 if (
present(v10))
call io%bits_mem(storage_size(v10),-product(shape(v10)),
'v10')
107 if (
present(v1))
deallocate(v1)
108 if (
present(v2))
deallocate(v2)
109 if (
present(v3))
deallocate(v3)
110 if (
present(v4))
deallocate(v4)
111 if (
present(v5))
deallocate(v5)
112 if (
present(v6))
deallocate(v6)
113 if (
present(v7))
deallocate(v7)
114 if (
present(v8))
deallocate(v8)
115 if (
present(v9))
deallocate(v9)
116 if (
present(v10))
deallocate(v10)
121 SUBROUTINE deallocate_vectors (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10)
123 real,
dimension(:,:,:,:),
pointer,
optional:: v1, v2, v3, v4, v5, v6, v7, v8, v9, v10
125 call trace_begin(
'deallocate_vectors')
126 if (
present(v1))
call io%bits_mem(storage_size(v1),-product(shape(v1)),
'v1')
127 if (
present(v2))
call io%bits_mem(storage_size(v2),-product(shape(v2)),
'v2')
128 if (
present(v3))
call io%bits_mem(storage_size(v3),-product(shape(v3)),
'v3')
129 if (
present(v4))
call io%bits_mem(storage_size(v4),-product(shape(v4)),
'v4')
130 if (
present(v5))
call io%bits_mem(storage_size(v5),-product(shape(v5)),
'v5')
131 if (
present(v6))
call io%bits_mem(storage_size(v6),-product(shape(v6)),
'v6')
132 if (
present(v7))
call io%bits_mem(storage_size(v7),-product(shape(v7)),
'v7')
133 if (
present(v8))
call io%bits_mem(storage_size(v8),-product(shape(v8)),
'v8')
134 if (
present(v9))
call io%bits_mem(storage_size(v9),-product(shape(v9)),
'v9')
135 if (
present(v10))
call io%bits_mem(storage_size(v10),-product(shape(v10)),
'v10')
136 if (
present(v1))
deallocate(v1)
137 if (
present(v2))
deallocate(v2)
138 if (
present(v3))
deallocate(v3)
139 if (
present(v4))
deallocate(v4)
140 if (
present(v5))
deallocate(v5)
141 if (
present(v6))
deallocate(v6)
142 if (
present(v7))
deallocate(v7)
143 if (
present(v8))
deallocate(v8)
144 if (
present(v9))
deallocate(v9)
145 if (
present(v10))
deallocate(v10)
150 SUBROUTINE vector_assign_scalar (out, in)
151 real,
dimension(:,:,:),
intent(in):: in
152 real,
dimension(size(in,1),size(in,2),size(in,3),3),
intent(inout):: out
156 END SUBROUTINE vector_assign_scalar
159 FUNCTION vector_vector_dot (in, in2)
RESULT (out)
160 real,
dimension(:,:,:,:),
intent(in):: in,in2
161 real,
dimension(size(in,1),size(in,2),size(in,3),3):: out
162 out = in(:,:,:,1)*in2(:,:,:,1) &
163 + in(:,:,:,2)*in2(:,:,:,2) &
164 + in(:,:,:,3)*in2(:,:,:,3)
165 END FUNCTION vector_vector_dot
168 FUNCTION vector_scalar_mul (in, in2)
RESULT (out)
169 real,
dimension(:,:,:,:),
intent(in):: in
170 real,
dimension(:,:,:),
intent(in):: in2
171 real,
dimension(size(in,1),size(in,2),size(in,3),3):: out
172 out(:,:,:,1) = in(:,:,:,1)*in2
173 out(:,:,:,2) = in(:,:,:,2)*in2
174 out(:,:,:,3) = in(:,:,:,3)*in2
177 FUNCTION scalar_vector_mul (in2, in)
RESULT (out)
178 real,
dimension(:,:,:,:),
intent(in):: in
179 real,
dimension(:,:,:),
intent(in):: in2
180 real,
dimension(size(in,1),size(in,2),size(in,3),3):: out
181 out(:,:,:,1) = in(:,:,:,1)*in2
182 out(:,:,:,2) = in(:,:,:,2)*in2
183 out(:,:,:,3) = in(:,:,:,3)*in2
186 FUNCTION const3_vector_mul (in1, in)
RESULT (out)
187 real,
dimension(:,:,:,:),
intent(in):: in
188 real,
dimension(size(in,1),size(in,2),size(in,3),3):: out
189 real,
dimension(:),
intent(in):: in1
190 out(:,:,:,1) = in(:,:,:,1)*in1(1)
191 out(:,:,:,2) = in(:,:,:,2)*in1(2)
192 out(:,:,:,3) = in(:,:,:,3)*in1(3)
196 FUNCTION vector_scalar_add (in, in2)
RESULT (out)
197 real,
dimension(:,:,:,:),
intent(in):: in
198 real,
dimension(:,:,:),
intent(in):: in2
199 real,
dimension(size(in,1),size(in,2),size(in,3),3):: out
200 out(:,:,:,1) = in(:,:,:,1)+in2
201 out(:,:,:,2) = in(:,:,:,2)+in2
202 out(:,:,:,3) = in(:,:,:,3)+in2
205 FUNCTION vector_scalar_sub (in, in2)
RESULT (out)
206 real,
dimension(:,:,:,:),
intent(in):: in
207 real,
dimension(:,:,:),
intent(in):: in2
208 real,
dimension(size(in,1),size(in,2),size(in,3),3):: out
209 out(:,:,:,1) = in(:,:,:,1)-in2
210 out(:,:,:,2) = in(:,:,:,2)-in2
211 out(:,:,:,3) = in(:,:,:,3)-in2
214 FUNCTION vector_scalar_divide (in,in2)
RESULT (out)
215 real,
dimension(:,:,:,:),
intent(in):: in
216 real,
dimension(:,:,:),
intent(in):: in2
217 real,
dimension(size(in,1),size(in,2),size(in,3),3):: out
219 out(:,:,:,1) = in(:,:,:,1)/in2
220 out(:,:,:,2) = in(:,:,:,2)/in2
221 out(:,:,:,3) = in(:,:,:,3)/in2
225 FUNCTION real4_cross_vector (in1, in)
result (out)
226 real,
dimension(:,:,:,:),
intent(in):: in
227 real,
dimension(size(in,1),size(in,2),size(in,3),3):: out
228 real,
intent(in):: in1(3)
230 out(:,:,:,1) = in1(2)*in(:,:,:,3) - in1(3)*in(:,:,:,2)
231 out(:,:,:,2) = in1(3)*in(:,:,:,1) - in1(1)*in(:,:,:,3)
232 out(:,:,:,3) = in1(1)*in(:,:,:,2) - in1(2)*in(:,:,:,1)
233 END FUNCTION real4_cross_vector
235 FUNCTION vector_cross_real4 (in, in2)
result (out)
236 real,
dimension(:,:,:,:),
intent(in):: in
237 real,
dimension(size(in,1),size(in,2),size(in,3),3):: out
238 real,
intent(in):: in2(3)
240 out(:,:,:,1) = in2(3)*in(:,:,:,2) - in2(2)*in(:,:,:,3)
241 out(:,:,:,2) = in2(1)*in(:,:,:,3) - in2(3)*in(:,:,:,1)
242 out(:,:,:,3) = in2(2)*in(:,:,:,1) - in2(1)*in(:,:,:,2)
243 END FUNCTION vector_cross_real4
245 FUNCTION vector_cross_vector (in, in2)
result (out)
246 real,
dimension(:,:,:,:),
intent(in):: in, in2
247 real,
dimension(size(in,1),size(in,2),size(in,3),3):: out
249 out(:,:,:,1) = in(:,:,:,2)*in2(:,:,:,3) - in(:,:,:,3)*in2(:,:,:,2)
250 out(:,:,:,2) = in(:,:,:,3)*in2(:,:,:,1) - in(:,:,:,1)*in2(:,:,:,3)
251 out(:,:,:,3) = in(:,:,:,1)*in2(:,:,:,2) - in(:,:,:,2)*in2(:,:,:,1)
252 END FUNCTION vector_cross_vector