DISPATCH
vector_mod.f90
1 !|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
2 !> $Id: 4c9f8b6e5c7a752e4af57cd6ac7241a87f335cab $
3 !|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
4 MODULE vector_mod
5  USE io_mod
6  USE trace_mod
7  implicit none
8  public
9  integer, private:: verbose=0
10  interface assignment(=)
11  module procedure vector_assign_scalar
12  end interface
13  interface dot
14  module procedure vector_vector_dot
15  end interface
16  interface operator(*)
17  module procedure vector_scalar_mul, scalar_vector_mul, const3_vector_mul
18  end interface
19  interface operator(+)
20  module procedure vector_scalar_add
21  end interface
22  interface operator(-)
23  module procedure vector_scalar_sub
24  end interface
25  interface operator(/)
26  module procedure vector_scalar_divide
27  end interface
28  interface cross
29  module procedure vector_cross_vector, vector_cross_real4, real4_cross_vector
30  end interface
31 CONTAINS
32 
33 !===============================================================================
34 SUBROUTINE allocate_vectors_a (n, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10)
35  integer:: n(3)
36  real, dimension(:,:,:,:), allocatable, optional:: v1, v2, v3, v4, v5, v6, v7, v8, v9, v10
37  !.............................................................................
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')
59  call trace_end
60 END SUBROUTINE allocate_vectors_a
61 
62 !===============================================================================
63 SUBROUTINE allocate_vectors (n, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10)
64  integer:: n(3)
65  real, dimension(:,:,:,:), pointer, optional:: v1, v2, v3, v4, v5, v6, v7, v8, v9, v10
66  !.............................................................................
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')
88  call trace_end
89 END SUBROUTINE allocate_vectors
90 
91 !===============================================================================
92 SUBROUTINE deallocate_vectors_a (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10)
93  integer:: n(3)
94  real, dimension(:,:,:,:), allocatable, optional:: v1, v2, v3, v4, v5, v6, v7, v8, v9, v10
95  !.............................................................................
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)
117  call trace_end
118 END SUBROUTINE
119 
120 !===============================================================================
121 SUBROUTINE deallocate_vectors (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10)
122  integer:: n(3)
123  real, dimension(:,:,:,:), pointer, optional:: v1, v2, v3, v4, v5, v6, v7, v8, v9, v10
124  !.............................................................................
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)
146  call trace_end
147 END SUBROUTINE
148 
149 !===============================================================================
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
153  out(:,:,:,1) = in
154  out(:,:,:,2) = in
155  out(:,:,:,3) = in
156 END SUBROUTINE vector_assign_scalar
157 
158 !===============================================================================
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
166 
167 !===============================================================================
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
175 END FUNCTION
176 !===============================================================================
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
184 END FUNCTION
185 !===============================================================================
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)
193 END FUNCTION
194 
195 !===============================================================================
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
203 END FUNCTION
204 !===============================================================================
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
212 END FUNCTION
213 !===============================================================================
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
218  !-----------------------------------------------------------------------------
219  out(:,:,:,1) = in(:,:,:,1)/in2
220  out(:,:,:,2) = in(:,:,:,2)/in2
221  out(:,:,:,3) = in(:,:,:,3)/in2
222 END FUNCTION
223 
224 !===============================================================================
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)
229  !-----------------------------------------------------------------------------
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
234 !===============================================================================
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)
239  !-----------------------------------------------------------------------------
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
244 !===============================================================================
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
248  !-----------------------------------------------------------------------------
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
253 
254 !===============================================================================
255 END MODULE vector_mod
Definition: io_mod.f90:4