MoDeNa  1.0
Software framework facilitating sequential multi-scale modelling
matrix_inversion-aux.f90
1 !***********************************************************
2 !* Fortran 90 version of basis_r.cpp, reduced and modified *
3 !* version of basis.c by J-P Moreau, Paris *
4 !* (www.jpmoreau.fr) *
5 !* ------------------------------------------------------- *
6 !* Reference for original basis.c: *
7 !* *
8 !* "Numerical Algorithms with C, By Gisela Engeln-Muellges *
9 !* and Frank Uhlig, Springer-Verlag, 1996" [BIBLI 11]. *
10 !***********************************************************
11  MODULE basis
12 
13  parameter(half=0.5d0,one=1.d0,two=2.d0,three=3.d0)
14 
15  CONTAINS
16 
17  Subroutine normmax(vektor, n, normaxi)
18  REAL*8 normaxi, vektor(0:n-1)
19  !************************************************************************
20  !* Return the maximum norm of a (0..n-1) vector v. *
21  !* *
22  !* global names used: *
23  !* ================== *
24  !* None. *
25  !************************************************************************
26  REAL*8 norm ! local max
27  REAL*8 betrag ! magnitude of a component
28  norm=0.d0
29  do i=0, n-1
30  betrag=dabs(vektor(i))
31  if (betrag > norm) norm = betrag
32  end do
33  normaxi = norm
34  return
35  end subroutine normmax
36 
37  Subroutine copymat(ziel, quelle, n, m)
38  REAL*8 ziel(0:n-1,0:m-1),quelle(0:n-1,0:m-1)
39  !************************************************************************
40  !* copy the n*m elements of the matrix quelle into the matrix ziel. *
41  !* *
42  !* global names used: *
43  !* ================== *
44  !* none *
45  !************************************************************************
46  do i=0, n-1
47  do j=0, m-1
48  ziel(i,j) = quelle(i,j)
49  end do
50  end do
51  return
52  end subroutine copymat
53 
54  !*****************************************
55  ! Read a vector from unit u from index = 0
56  !*****************************************
57  Subroutine readvec (u, n, x)
58  INTEGER u
59  REAL*8 x(0:n-1)
60  read(u,*) (x(i),i=0,n-1)
61  return
62  end subroutine readvec
63 
64  !*****************************************
65  ! Read a vector from unit u from index = 1
66  !*****************************************
67  Subroutine readvec1 (u, n, x)
68  INTEGER u
69  REAL*8 x(1:n)
70  read(u,*) (x(i),i=1,n)
71  return
72  end subroutine readvec1
73 
74  !*****************************
75  ! Put all the components of a
76  ! vector to a given value val
77  !*****************************
78  Subroutine setvec(n,x,val)
79  REAL*8 x(0:n-1)
80  REAL*8 val
81  do i = 0, n-1
82  x(i) = val
83  end do
84  return
85  end subroutine setvec
86 
87  !********************************
88  ! Put all the components of a
89  ! nxm matrix to a given value val
90  !********************************
91  Subroutine setmat(n,m,a,val)
92  REAL*8 a(0:n-1,0:m-1)
93  REAL*8 val
94  do i = 0, n-1
95  do j = 0, m-1
96  a(i,j) = val
97  end do
98  end do
99  return
100  end subroutine setmat
101 
102  Subroutine writevec(u, n, x)
103  INTEGER u, n
104  REAL*8 x(0:n-1)
105 !*====================================================================*
106 !* *
107 !* Put out vector x of length n to output file (10 items per line) *
108 !* Index starts at ZERO. *
109 !* *
110 !*====================================================================*
111 !* *
112 !* Input parameters: *
113 !* ================ *
114 !* *
115 !* n integer n; *
116 !* lenght of vector *
117 !* x REAL*8 x(n) *
118 !* vector *
119 !* *
120 !*====================================================================*
121  write(u,10) (x(i),i=0,n-1)
122  return
123 10 format(10e13.6)
124  end subroutine writevec
125 
126  Subroutine writevec1 (u, n, x)
127  INTEGER u, n
128  REAL*8 x(1:n)
129 !*====================================================================*
130 !* *
131 !* Put out vector x of length n to output file (10 items per line) *
132 !* Index starts at ONE. *
133 !* *
134 !*====================================================================*
135 !* *
136 !* Input parameters: *
137 !* ================ *
138 !* *
139 !* n integer n; *
140 !* lenght of vector *
141 !* x REAL*8 x(n) *
142 !* vector *
143 !* *
144 !*====================================================================*
145  write(u,10) (x(i),i=1,n)
146  return
147 10 format(10e13.6)
148  end subroutine writevec1
149 
150  Subroutine readmat (u,n, m, a)
151 !*====================================================================*
152 !* *
153 !* Read an n x m matrix from input file. *
154 !* *
155 !*====================================================================*
156 !* *
157 !* Input parameters : *
158 !* ================== *
159 !* u integer u; # of unit to read *
160 !* n integer m; ( m > 0 ) *
161 !* number of rows of matrix *
162 !* m integer n; ( n > 0 ) *
163 !* column number of matrix *
164 !* *
165 !* Output parameter: *
166 !* ================ *
167 !* a REAL*8 a(n,m) *
168 !* matrix to read *
169 !* *
170 !* ATTENTION : WE do not allocate storage for a here. *
171 !* *
172 !*====================================================================*
173  INTEGER u, n, m
174  REAL*8 a(0:n-1,0:m-1)
175  Read(u,*) ((a(i,j),j=0,m-1),i=0,n-1)
176  return
177  end subroutine readmat
178 
179  Subroutine readmat1(u,n, m, a)
180 !*====================================================================*
181 !* *
182 !* Read an n x m matrix from input file (index begins at 1) *
183 !* *
184 !*====================================================================*
185 !* *
186 !* Input parameters : *
187 !* ================== *
188 !* u integer u; # of unit to read *
189 !* n integer m; ( m > 0 ) *
190 !* number of rows of matrix *
191 !* m integer n; ( n > 0 ) *
192 !* column number of matrix *
193 !* *
194 !* Output parameter: *
195 !* ================ *
196 !* a REAL*8 a(n,m) *
197 !* matrix to read *
198 !* *
199 !* ATTENTION : WE do not allocate storage for a here. *
200 !* *
201 !*====================================================================*
202  INTEGER u, n, m
203  REAL*8 a(n,m)
204  Read(u,*) ((a(i,j),j=1,m),i=1,n)
205  return
206  end subroutine readmat1
207 
208  Subroutine writemat(u,n, m, a)
209 !*====================================================================*
210 !* *
211 !* Put out an m x n matrix in output file ( 10 items per line ) *
212 !* *
213 !*====================================================================*
214 !* *
215 !* Input parameters: *
216 !* ================ *
217 !* u integer u; # of unit to read *
218 !* n int m; ( m > 0 ) *
219 !* row number of matrix *
220 !* m int n; ( n > 0 ) *
221 !* column number of matrix *
222 !* a REAL*8 a(n,n) *
223 !* matrix to write *
224 !*====================================================================*
225  INTEGER u
226  REAL*8 a(0:n-1,0:m-1)
227  do i=0, n-1
228  write(u,10) (a(i,j),j=0,m-1)
229  enddo
230  return
231  10 format(10e14.6)
232  end subroutine writemat
233 
234  Subroutine writemat1(u,n, m, a)
235 !*====================================================================*
236 !* *
237 !* Put out an m x n matrix in output file ( 10 items per line ) *
238 !* (index begins at one) *
239 !* *
240 !*====================================================================*
241 !* *
242 !* Input parameters: *
243 !* ================ *
244 !* u integer u; # of unit to read *
245 !* n int m; ( m > 0 ) *
246 !* row number of matrix *
247 !* m int n; ( n > 0 ) *
248 !* column number of matrix *
249 !* a REAL*8 a(n,n) *
250 !* matrix to write *
251 !*====================================================================*
252  INTEGER u
253  REAL*8 a(n,m)
254  do i=1, n
255  write(u,10) (a(i,j),j=1,m)
256  enddo
257  return
258  10 format(10e14.6)
259  end subroutine writemat1
260 
261  Subroutine writehead (u, nom)
262 !*====================================================================*
263 !* *
264 !* Put out header with text in unit u . *
265 !* *
266 !*====================================================================*
267 !* *
268 !* Input parameters: *
269 !* ================ *
270 !* u integer u; # of unit to read *
271 !* nom character*(*) nom *
272 !* text of headertext (last byte is a 0) *
273 !* *
274 !* Return value : *
275 !* ============= *
276 !* None *
277 !* *
278 !*====================================================================*
279  INTEGER u
280  CHARACTER*(*) nom
281  Write(u,*) '----------------------------------------------------------'
282  Write(u,*) nom
283  Write(u,*) '----------------------------------------------------------'
284  return
285  end subroutine writehead
286 
287  Subroutine writeend(u)
288 !*====================================================================*
289 !* *
290 !* Put out end of writing onto unit u. *
291 !* *
292 !*====================================================================*
293 !* *
294 !* Return value : *
295 !* ============= *
296 !* None *
297 !* *
298 !*====================================================================*
299  INTEGER u
300  Write(u,*) ' '
301  Write(u,*) '----------------------------------------------------------'
302  return
303  end subroutine writeend
304 
305 !***********************
306 ! Swap two real values
307 !***********************
308  Subroutine swap(a,b)
309  REAL*8 a,b,temp
310  temp=a
311  a=b
312  b=temp
313  return
314  end subroutine swap
315 
316 END MODULE
317 
318 ! end of file basis.f90
319