FrontISTR  5.7.1
Large-scale structural analysis program with finit element method
_unused_code.f90
Go to the documentation of this file.
1 !======================================================================!
2 ! !
3 !======================================================================!
4 SUBROUTINE 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
35 END SUBROUTINE d6dot
36 !======================================================================!
37 ! !
38 !======================================================================!
39 SUBROUTINE 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
68 END SUBROUTINE d6dotl
69 !======================================================================!
70 ! !
71 !======================================================================!
72 SUBROUTINE 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
93 END SUBROUTINE d6sdot
94 !======================================================================!
95 ! !
96 !======================================================================!
97 SUBROUTINE 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
131 99999 END SUBROUTINE idntty
132  !======================================================================!
133  ! !
134  !======================================================================!
135 SUBROUTINE 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  ! permutation
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
271 END SUBROUTINE nusol6
272 !======================================================================!
273 ! !
274 !======================================================================!
275 SUBROUTINE 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)
283 99001 FORMAT (10(2x,i4))
284 END SUBROUTINE prt
285 
286 SUBROUTINE 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
295 END SUBROUTINE vlcpy1
296 
297 !======================================================================!
298 ! !
299 !======================================================================!
300 SUBROUTINE 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
349 99001 FORMAT (' ***verification***(symmetric)'/&
350  'norm(Ax-b) = ',&
351  1pd20.10/'norm(b) = ',&
352  1pd20.10/'norm(Ax-b)/norm(b) = ',1pd20.10)
353 END SUBROUTINE verif0
354 
355 !======================================================================!
356 ! !
357 !======================================================================!
358 SUBROUTINE 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
392 END SUBROUTINE v6prod
d6dotl
subroutine d6dotl(T, A, B, N)
Definition: _unused_code.f90:40
nusol6
subroutine nusol6(Xlnzr, Colno, Dsln, Zln, Diag, Iperm, B, Wk, Neqns, Nstop)
Definition: _unused_code.f90:136
d6dot
subroutine d6dot(T, A, B, N)
Definition: _unused_code.f90:5
v6prod
subroutine v6prod(Zln, Diag, Zz, N)
Definition: _unused_code.f90:359
vlcpy1
subroutine vlcpy1(A, N)
Definition: _unused_code.f90:287
verif0
subroutine verif0(Neqns, Ndeg, Nttbr, Irow, Jcol, Val, Rhs, X)
Definition: _unused_code.f90:301
d6sdot
subroutine d6sdot(Wi, A, B, N)
Definition: _unused_code.f90:73
prt
subroutine prt(Ip, N)
Definition: _unused_code.f90:276
idntty
subroutine idntty(Neqns, Invp, Iperm)
Definition: _unused_code.f90:98