FrontISTR 5.2.0
Large-scale structural analysis program with finit element method
Loading...
Searching...
No Matches
_unused_code.f90
Go to the documentation of this file.
1!======================================================================!
2! !
3!======================================================================!
4SUBROUTINE d6dot(T,A,B,N)
5 IMPLICIT NONE
6
7 INTEGER :: jj
8 INTEGER :: l
9 INTEGER :: N
10 DOUBLE PRECISION :: T(9)
11 DOUBLE PRECISION :: A(9,*)
12 DOUBLE PRECISION :: B(9,*)
13 !----------------------------------------------------------------------
14 !
15 ! spdot1 performs inner product of sparse vectors
16 !
17 !
18 ! #coded by t.arakawa of RIST on 040510
19 !
20 !----------------------------------------------------------------------
21 DO l = 1, 9
22 t(l) = 0.0d0
23 ENDDO
24 DO jj = 1, n
25 t(1) = t(1) + a(1,jj)*b(1,jj) + a(4,jj)*b(4,jj) + a(7,jj)*b(7,jj)
26 t(2) = t(2) + a(2,jj)*b(1,jj) + a(5,jj)*b(4,jj) + a(8,jj)*b(7,jj)
27 t(3) = t(3) + a(3,jj)*b(1,jj) + a(6,jj)*b(4,jj) + a(9,jj)*b(7,jj)
28 t(4) = t(4) + a(1,jj)*b(2,jj) + a(4,jj)*b(5,jj) + a(7,jj)*b(8,jj)
29 t(5) = t(5) + a(2,jj)*b(2,jj) + a(5,jj)*b(5,jj) + a(8,jj)*b(8,jj)
30 t(6) = t(6) + a(3,jj)*b(2,jj) + a(6,jj)*b(5,jj) + a(9,jj)*b(8,jj)
31 t(7) = t(7) + a(1,jj)*b(3,jj) + a(4,jj)*b(6,jj) + a(7,jj)*b(9,jj)
32 t(8) = t(8) + a(2,jj)*b(3,jj) + a(5,jj)*b(6,jj) + a(8,jj)*b(9,jj)
33 t(9) = t(9) + a(3,jj)*b(3,jj) + a(6,jj)*b(6,jj) + a(9,jj)*b(9,jj)
34 ENDDO
35END SUBROUTINE d6dot
36!======================================================================!
37! !
38!======================================================================!
39SUBROUTINE d6dotl(T,A,B,N)
40 IMPLICIT NONE
41
42 INTEGER :: jj
43 INTEGER :: l
44 INTEGER :: N
45 DOUBLE PRECISION :: T(6)
46 DOUBLE PRECISION :: A(9,*)
47 DOUBLE PRECISION :: B(9,*)
48 !----------------------------------------------------------------------
49 !
50 ! spdot1 performs inner product of sparse vectors
51 !
52 !
53 ! #coded by t.arakawa of RIST on 040510
54 !
55 !----------------------------------------------------------------------
56 !$dir max_trips(6)
57 DO l = 1, 6
58 t(l) = 0.0d0
59 ENDDO
60 DO jj = 1, n
61 t(1) = t(1) + a(1,jj)*b(1,jj) + a(4,jj)*b(4,jj) + a(7,jj)*b(7,jj)
62 t(2) = t(2) + a(2,jj)*b(1,jj) + a(5,jj)*b(4,jj) + a(8,jj)*b(7,jj)
63 t(3) = t(3) + a(2,jj)*b(2,jj) + a(5,jj)*b(5,jj) + a(8,jj)*b(8,jj)
64 t(4) = t(4) + a(3,jj)*b(1,jj) + a(6,jj)*b(4,jj) + a(9,jj)*b(7,jj)
65 t(5) = t(5) + a(3,jj)*b(2,jj) + a(6,jj)*b(5,jj) + a(9,jj)*b(8,jj)
66 t(6) = t(6) + a(3,jj)*b(3,jj) + a(6,jj)*b(6,jj) + a(9,jj)*b(9,jj)
67 ENDDO
68END SUBROUTINE d6dotl
69!======================================================================!
70! !
71!======================================================================!
72SUBROUTINE d6sdot(Wi,A,B,N)
73 IMPLICIT NONE
74
75 INTEGER :: jj
76 INTEGER :: N
77 DOUBLE PRECISION :: Wi(3)
78 DOUBLE PRECISION :: A(3,*)
79 DOUBLE PRECISION :: B(9,*)
80 !----------------------------------------------------------------------
81 !
82 ! spdot1 performs inner product of sparse vectors
83 !
84 !
85 ! #coded by t.arakawa of RIST on 040510
86 !
87 !----------------------------------------------------------------------
88 DO jj = 1, n
89 wi(1) = wi(1) - a(1,jj)*b(1,jj) - a(2,jj)*b(4,jj) - a(3,jj)*b(7,jj)
90 wi(2) = wi(2) - a(1,jj)*b(2,jj) - a(2,jj)*b(5,jj) - a(3,jj)*b(8,jj)
91 wi(3) = wi(3) - a(1,jj)*b(3,jj) - a(2,jj)*b(6,jj) - a(3,jj)*b(9,jj)
92 ENDDO
93END SUBROUTINE d6sdot
94!======================================================================!
95! !
96!======================================================================!
97SUBROUTINE idntty(Neqns,Invp,Iperm)
98 IMPLICIT NONE
99
100 INTEGER :: i
101 INTEGER :: IDBg1
102 INTEGER :: Neqns
103 INTEGER :: Invp(*)
104 INTEGER :: Iperm(*)
105 COMMON /debug / idbg1
106
107 i = 1
108 DO WHILE ( i<=neqns )
109 WRITE (6,*) 'invp(', i, ')'
110 READ (5,*) invp(i)
111 IF ( invp(i)==0 ) THEN
112 DO i = 1, neqns
113 invp(i) = i
114 iperm(i) = i
115 ENDDO
116 RETURN
117 ELSEIF ( invp(i)<0 ) THEN
118 READ (11,*) (invp(i),i=1,neqns)
119 DO i = 1, neqns
120 iperm(invp(i)) = i
121 ENDDO
122 GOTO 99999
123 ELSE
124 i = i + 1
125 ENDIF
126 ENDDO
127 DO i = 1, neqns
128 iperm(invp(i)) = i
129 ENDDO
130 RETURN
13199999 END SUBROUTINE idntty
132 !======================================================================!
133 ! !
134 !======================================================================!
135SUBROUTINE nusol6(Xlnzr,Colno,Dsln,Zln,Diag,Iperm,B,Wk,Neqns,Nstop)
136 IMPLICIT NONE
137
138 INTEGER :: i
139 INTEGER :: j
140 INTEGER :: joc
141 INTEGER :: k
142 INTEGER :: ke
143 INTEGER :: ks
144 INTEGER :: Neqns
145 INTEGER :: Nstop
146 INTEGER :: Xlnzr(*)
147 INTEGER :: Colno(*)
148 INTEGER :: Iperm(*)
149 !GP: DEBUG 13May04 wk(3 ---> wk(6, b(3 ---> b(6, diag(6 ---> diag(21,
150 !GP: DEBUG 13May04 zln(9 ---> zln(36, dsln(9 ---> dsln(36
151 ! double precision zln(9,*),diag(6,*),b(3,*),wk(3,*),dsln(9,*)
152 DOUBLE PRECISION :: Zln(36,*)
153 DOUBLE PRECISION :: Diag(21,*)
154 DOUBLE PRECISION :: B(6,*)
155 DOUBLE PRECISION :: Wk(6,*)
156 DOUBLE PRECISION :: Dsln(36,*)
157 ! forward
158 DO i = 1, neqns
159 wk(1,i) = b(1,iperm(i))
160 wk(2,i) = b(2,iperm(i))
161 wk(3,i) = b(3,iperm(i))
162 wk(4,i) = b(4,iperm(i))
163 wk(5,i) = b(5,iperm(i))
164 wk(6,i) = b(6,iperm(i))
165 ENDDO
166 joc = 1
167 DO i = 1, neqns
168 ks = xlnzr(i)
169 ke = xlnzr(i+1) - 1
170 IF ( ke>=ks ) CALL s6pdot(wk(1,i),wk,zln,colno,ks,ke)
171 IF ( i>nstop ) THEN
172 ! call d6sdot(wk(1,i),wk(1,nstop),dsln(1,joc),i-nstop)
173 CALL dxsdot(6,wk(1,i),wk(1,nstop),dsln(1,joc),i-nstop)
174 joc = joc + i - nstop
175 ENDIF
176 ENDDO
177 DO i = 1, neqns
178 wk(2,i) = wk(2,i) - wk(1,i)*diag(2,i)
179 wk(3,i) = wk(3,i) - wk(1,i)*diag(4,i) - wk(2,i)*diag(5,i)
180 wk(4,i) = wk(4,i) - wk(1,i)*diag(7,i) - wk(2,i)*diag(8,i) - wk(3,i)*diag(9,i)
181 wk(5,i) = wk(5,i) - wk(1,i)*diag(11,i) - wk(2,i)*diag(12,i) - wk(3,i)*diag(13,i) - wk(4,i)*diag(14,i)
182 wk(6,i) = wk(6,i) - wk(1,i)*diag(16,i) - wk(2,i)*diag(17,i)&
183 - wk(3,i)*diag(18,i) - wk(4,i)*diag(19,i) - wk(6,i)&
184 *diag(20,i)
185 wk(1,i) = wk(1,i)*diag(1,i)
186 wk(2,i) = wk(2,i)*diag(3,i)
187 wk(3,i) = wk(3,i)*diag(6,i)
188 wk(4,i) = wk(4,i)*diag(10,i)
189 wk(5,i) = wk(5,i)*diag(15,i)
190 wk(6,i) = wk(6,i)*diag(21,i)
191 wk(5,i) = wk(5,i) - wk(6,i)*diag(20,i)
192 wk(4,i) = wk(4,i) - wk(6,i)*diag(19,i) - wk(5,i)*diag(14,i)
193 wk(3,i) = wk(3,i) - wk(6,i)*diag(18,i) - wk(5,i)*diag(13,i) - wk(4,i)*diag(9,i)
194 wk(2,i) = wk(2,i) - wk(6,i)*diag(17,i) - wk(5,i)*diag(12,i) - wk(4,i)*diag(8,i) - wk(3,i)*diag(5,i)
195 wk(1,i) = wk(1,i) - wk(6,i)*diag(16,i) - wk(5,i)*diag(11,i)&
196 - wk(4,i)*diag(7,i) - wk(3,i)*diag(4,i) - wk(2,i)&
197 *diag(2,i)
198 ENDDO
199 ! back ward
200 DO i = neqns, 1, -1
201 IF ( i>=nstop ) THEN
202 DO j = i - 1, nstop, -1
203 joc = joc - 1
204 wk(1,j) = wk(1,j) - wk(1,i)*dsln(1,joc) - wk(2,i)&
205 *dsln(2,joc) - wk(3,i)*dsln(3,joc) - wk(4,i)&
206 *dsln(4,joc) - wk(5,i)*dsln(5,joc) - wk(6,i)&
207 *dsln(6,joc)
208 wk(2,j) = wk(2,j) - wk(1,i)*dsln(7,joc) - wk(2,i)&
209 *dsln(8,joc) - wk(3,i)*dsln(9,joc) - wk(4,i)&
210 *dsln(10,joc) - wk(5,i)*dsln(11,joc) - wk(6,i)&
211 *dsln(12,joc)
212 wk(3,j) = wk(3,j) - wk(1,i)*dsln(13,joc) - wk(2,i)&
213 *dsln(14,joc) - wk(3,i)*dsln(15,joc) - wk(4,i)&
214 *dsln(16,joc) - wk(5,i)*dsln(17,joc) - wk(6,i)&
215 *dsln(18,joc)
216 wk(4,j) = wk(4,j) - wk(1,i)*dsln(19,joc) - wk(2,i)&
217 *dsln(20,joc) - wk(3,i)*dsln(21,joc) - wk(4,i)&
218 *dsln(22,joc) - wk(5,i)*dsln(23,joc) - wk(6,i)&
219 *dsln(24,joc)
220 wk(5,j) = wk(5,j) - wk(1,i)*dsln(25,joc) - wk(2,i)&
221 *dsln(26,joc) - wk(3,i)*dsln(27,joc) - wk(4,i)&
222 *dsln(28,joc) - wk(5,i)*dsln(29,joc) - wk(6,i)&
223 *dsln(30,joc)
224 wk(6,j) = wk(6,j) - wk(1,i)*dsln(31,joc) - wk(2,i)&
225 *dsln(32,joc) - wk(3,i)*dsln(33,joc) - wk(4,i)&
226 *dsln(34,joc) - wk(5,i)*dsln(35,joc) - wk(6,i)&
227 *dsln(36,joc)
228 ENDDO
229 ENDIF
230 ks = xlnzr(i)
231 ke = xlnzr(i+1) - 1
232 IF ( ke>=ks ) THEN
233 DO k = ks, ke
234 j = colno(k)
235 wk(1,j) = wk(1,j) - wk(1,i)*zln(1,joc) - wk(2,i)&
236 *zln(2,joc) - wk(3,i)*zln(3,joc) - wk(4,i)&
237 *zln(4,joc) - wk(5,i)*zln(5,joc) - wk(6,i)&
238 *zln(6,joc)
239 wk(2,j) = wk(2,j) - wk(1,i)*zln(7,joc) - wk(2,i)&
240 *zln(8,joc) - wk(3,i)*zln(9,joc) - wk(4,i)&
241 *zln(10,joc) - wk(5,i)*zln(11,joc) - wk(6,i)&
242 *zln(12,joc)
243 wk(3,j) = wk(3,j) - wk(1,i)*zln(13,joc) - wk(2,i)&
244 *zln(14,joc) - wk(3,i)*zln(15,joc) - wk(4,i)&
245 *zln(16,joc) - wk(5,i)*zln(17,joc) - wk(6,i)&
246 *zln(18,joc)
247 wk(4,j) = wk(4,j) - wk(1,i)*zln(19,joc) - wk(2,i)&
248 *zln(20,joc) - wk(3,i)*zln(21,joc) - wk(4,i)&
249 *zln(22,joc) - wk(5,i)*zln(23,joc) - wk(6,i)&
250 *zln(24,joc)
251 wk(5,j) = wk(5,j) - wk(1,i)*zln(25,joc) - wk(2,i)&
252 *zln(26,joc) - wk(3,i)*zln(27,joc) - wk(4,i)&
253 *zln(28,joc) - wk(5,i)*zln(29,joc) - wk(6,i)&
254 *zln(30,joc)
255 wk(6,j) = wk(6,j) - wk(1,i)*zln(31,joc) - wk(2,i)&
256 *zln(32,joc) - wk(3,i)*zln(33,joc) - wk(4,i)&
257 *zln(34,joc) - wk(5,i)*zln(35,joc) - wk(6,i)&
258 *zln(36,joc)
259 ENDDO
260 ENDIF
261 ENDDO
262 ! permutaion
263 DO i = 1, neqns
264 b(1,iperm(i)) = wk(1,i)
265 b(2,iperm(i)) = wk(2,i)
266 b(3,iperm(i)) = wk(3,i)
267 b(4,iperm(i)) = wk(4,i)
268 b(5,iperm(i)) = wk(5,i)
269 b(6,iperm(i)) = wk(6,i)
270 ENDDO
271END SUBROUTINE nusol6
272!======================================================================!
273! !
274!======================================================================!
275SUBROUTINE prt(Ip,N)
276 IMPLICIT NONE
277
278 INTEGER :: i
279 INTEGER :: Ip
280 INTEGER :: N
281 dimension ip(n)
282 WRITE (6,99001) (ip(i),i=1,n)
28399001 FORMAT (10(2x,i4))
284END SUBROUTINE prt
285
286SUBROUTINE vlcpy1(A,N)
287 IMPLICIT NONE
288
289 DOUBLE PRECISION :: A
290 INTEGER :: N
291 dimension a(n)
292 INTEGER :: i
293 INTEGER :: j
294 a(n) = 0
295END SUBROUTINE vlcpy1
296
297!======================================================================!
298! !
299!======================================================================!
300SUBROUTINE verif0(Neqns,Ndeg,Nttbr,Irow,Jcol,Val,Rhs,X)
301 IMPLICIT NONE
302
303 DOUBLE PRECISION :: err
304 DOUBLE PRECISION :: rel
305 DOUBLE PRECISION :: Rhs
306 DOUBLE PRECISION :: Val
307 DOUBLE PRECISION :: X
308 INTEGER :: i
309 INTEGER :: Irow
310 INTEGER :: j
311 INTEGER :: Jcol
312 INTEGER :: k
313 INTEGER :: l
314 INTEGER :: m
315 INTEGER :: Ndeg
316 INTEGER :: Neqns
317 INTEGER :: Nttbr
318 dimension irow(*), jcol(*), val(ndeg,ndeg,*), rhs(ndeg,*), x(ndeg,*)
319 !----------------------------------------------------------------------
320 !
321 ! verify the solution(symmetric matrix)
322 !
323 !----------------------------------------------------------------------
324 rel = 0.0d0
325 DO i = 1, neqns
326 DO l = 1, ndeg
327 rel = rel + dabs(rhs(l,i))
328 ENDDO
329 ENDDO
330 DO k = 1, nttbr
331 i = irow(k)
332 j = jcol(k)
333 DO l = 1, ndeg
334 DO m = 1, ndeg
335 rhs(l,i) = rhs(l,i) - val(l,m,k)*x(m,j)
336 IF ( i/=j ) rhs(l,j) = rhs(l,j) - val(m,l,k)*x(m,i)
337 ENDDO
338 ENDDO
339 ENDDO
340 err = 0.0d0
341 DO i = 1, neqns
342 DO l = 1, ndeg
343 err = err + dabs(rhs(l,i))
344 ENDDO
345 ENDDO
346 WRITE (6,99001) err, rel, err/rel
347 !WINDEBUG
348 ! write(16,6000) err,rel,err/rel
34999001 FORMAT (' ***verification***(symmetric)'/&
350 'norm(Ax-b) = ',&
351 1pd20.10/'norm(b) = ',&
352 1pd20.10/'norm(Ax-b)/norm(b) = ',1pd20.10)
353END SUBROUTINE verif0
354
355!======================================================================!
356! !
357!======================================================================!
358SUBROUTINE v6prod(Zln,Diag,Zz,N)
359 IMPLICIT NONE
360
361 DOUBLE PRECISION :: Diag
362 DOUBLE PRECISION :: Zln
363 DOUBLE PRECISION :: Zz
364 INTEGER :: i
365 INTEGER :: N
366 dimension zln(9,n), diag(6,n), zz(9,n)
367 DO i = 1, n
368 zz(4,i) = zln(4,i) - zln(1,i)*diag(2,i)
369 zz(7,i) = zln(7,i) - zln(1,i)*diag(4,i) - zz(4,i)*diag(5,i)
370 zz(1,i) = zln(1,i)*diag(1,i)
371 zz(4,i) = zz(4,i)*diag(3,i)
372 zz(7,i) = zz(7,i)*diag(6,i)
373 zz(4,i) = zz(4,i) - zz(7,i)*diag(5,i)
374 zz(1,i) = zz(1,i) - zz(4,i)*diag(2,i) - zz(7,i)*diag(4,i)
375 !
376 zz(5,i) = zln(5,i) - zln(2,i)*diag(2,i)
377 zz(8,i) = zln(8,i) - zln(2,i)*diag(4,i) - zz(5,i)*diag(5,i)
378 zz(2,i) = zln(2,i)*diag(1,i)
379 zz(5,i) = zz(5,i)*diag(3,i)
380 zz(8,i) = zz(8,i)*diag(6,i)
381 zz(5,i) = zz(5,i) - zz(8,i)*diag(5,i)
382 zz(2,i) = zz(2,i) - zz(5,i)*diag(2,i) - zz(8,i)*diag(4,i)
383 !
384 zz(6,i) = zln(6,i) - zln(3,i)*diag(2,i)
385 zz(9,i) = zln(9,i) - zln(3,i)*diag(4,i) - zz(6,i)*diag(5,i)
386 zz(3,i) = zln(3,i)*diag(1,i)
387 zz(6,i) = zz(6,i)*diag(3,i)
388 zz(9,i) = zz(9,i)*diag(6,i)
389 zz(6,i) = zz(6,i) - zz(9,i)*diag(5,i)
390 zz(3,i) = zz(3,i) - zz(6,i)*diag(2,i) - zz(9,i)*diag(4,i)
391 ENDDO
392END SUBROUTINE v6prod
subroutine verif0(neqns, ndeg, nttbr, irow, jcol, val, rhs, x)
subroutine d6dotl(t, a, b, n)
subroutine d6sdot(wi, a, b, n)
subroutine idntty(neqns, invp, iperm)
subroutine d6dot(t, a, b, n)
Definition: _unused_code.f90:5
subroutine v6prod(zln, diag, zz, n)
subroutine nusol6(xlnzr, colno, dsln, zln, diag, iperm, b, wk, neqns, nstop)
subroutine prt(ip, n)
subroutine vlcpy1(a, n)