1 : C EXTR13 SOURCE CHAT 09/10/09 21:18:03 6519
2 : SUBROUTINE EXTR13(IRIG,IRET)
3 : IMPLICIT INTEGER(I-N)
4 : IMPLICIT REAL*8(A-H,O-Z)
5 : ************************************************************************
6 : *
7 : * E X T R 1 3
8 : * -----------
9 : *
10 : * FONCTION:
11 : * ---------
12 : *
13 : * Sous-programme pour extraire d'une rigidit{ :
14 : * - les matrices élémentaires symétriques si IRET = 3
15 : * - les matrices élémentaires antisymétriques si IRET = 4
16 : *
17 : * MODULES UTILISES:
18 : * -----------------
19 : *
20 : -INC CCOPTIO
21 : -INC SMRIGID
22 : *
23 : * PARAMETRES: (e)=ENTREE (s)=SORTIE (+ = CONTENU DANS UN COMMUN)
24 : * -----------
25 : *
26 : * IRIG (e) pointeur sur l'objet RIGIDITE.
27 : * IRET (e) = 3 , matrice symétrique.
28 : * = 4 , matrice antisymétrique.
29 : *
30 : * AUTEUR, DATE DE CREATION:
31 : * -------------------------
32 : *
33 : * Lionel VIVAN juin 1991
34 : *
35 : * LANGAGE:
36 : * --------
37 : *
38 : * ESOPE + FORTRAN77
39 : *
40 : ************************************************************************
41 : *
42 : RI1 = IRIG
43 : SEGACT RI1
44 : C ... NRIG1 = taille du tableau d'infos ...
45 : NRIG1 = RI1.IRIGEL(/1)
46 : C ... NRIGE1 = nombre de "sous-matrices" ...
47 : NRIGE1 = RI1.IRIGEL(/2)
48 : ISYM = 0
49 : IANT = 0
50 : IF (NRIG1.GE.7) THEN
51 : DO 10 IN = 1,NRIGE1
52 : IANTI = RI1.IRIGEL(7,IN)
53 : IF (IANTI.EQ.0) ISYM = ISYM + 1
54 : IF (IANTI.EQ.1) IANT = IANT + 1
55 : IF (IANTI.EQ.2) THEN
56 : ISYM = ISYM + 1
57 : IANT = IANT + 1
58 : ENDIF
59 : 10 CONTINUE
60 : ELSE
61 : ISYM = NRIGE1
62 : ENDIF
63 : *
64 : * On extrait les matrices ...
65 : *
66 : NRIGE = NRIG1
67 : IF(IRET.EQ.3) THEN
68 : NRIGEL = ISYM
69 : ELSE IF(IRET.EQ.4) THEN
70 : NRIGEL = IANT
71 : ENDIF
72 : SEGINI MRIGID
73 : IRIS = MRIGID
74 : MTYMAT = RI1.MTYMAT
75 : ICHOLE = 0
76 : IMGEO1 = 0
77 : IMGEO2 = 0
78 : IFORIG = RI1.IFORIG
79 : ISUPEQ = 0
80 : II = 0
81 : DO 20 IN = 1,NRIGE1
82 : IF(NRIG1.GE.7) THEN
83 : IANTI = RI1.IRIGEL(7,IN)
84 : ELSE
85 : IANTI = 0
86 : ENDIF
87 : C ... Si la matrice possède déjà la bonne symétrie,
88 : C on ne fait que recopier les pointeurs, sinon,
89 : C si la matrice est non-symétrique on va en
90 : C extraire ce qu'il faut ...
91 : IF (IANTI.EQ.2.OR.IANTI.EQ.IRET-3) THEN
92 : II = II + 1
93 : COERIG(II) = RI1.COERIG(IN)
94 : DO 22 IN2 = 1,NRIGE
95 : IRIGEL(IN2,II) = RI1.IRIGEL(IN2,IN)
96 : 22 CONTINUE
97 : C ... si la matrice est non-symétrique, il faut
98 : C surcharger le flag de symétrie (N° 7) et
99 : C le pointeur sur IMATRI (N° 4) ...
100 : IF(IANTI.EQ.2) THEN
101 : IRIGEL(7,II) = IRET-3
102 : xMATR1 = RI1.IRIGEL(4,IN)
103 : SEGACT,xMATR1
104 : NELRIG = xmatr1.re(/3)
105 : nligrp = xmatr1.re(/2)
106 : nligrd= xmatr1.re(/1)
107 : SEGINI xMATRI
108 : IRIGEL(4,II) = xMATRI
109 : DO 25 INUMEL = 1,NELRIG
110 : * XMATR1 = IMATR1.IMATTT(INUMEL)
111 : * SEGACT XMATR1
112 : * NLIGRD = XMATR1.RE(/1)
113 : * NLIGRP = XMATR1.RE(/2)
114 : IF(NLIGRD.NE.NLIGRP) THEN
115 : write(*,*) 'Matrice non carrée !!!'
116 : return
117 : ENDIF
118 : * SEGINI XMATRI
119 : * IMATTT(INUMEL) = XMATRI
120 : DO 26 ILIG=1,NLIGRP
121 : DO 27 ICOL=1,NLIGRD
122 : IF(IRET.EQ.3) RE(ICOL,ILIG,inumel) =
123 : & (XMATR1.RE(ICOL,ILIG,inumel)+XMATR1.RE(ILIG,ICOL,inumel))/2.d0
124 : IF(IRET.EQ.4) RE(ICOL,ILIG,inumel) =
125 : & (XMATR1.RE(ICOL,ILIG,inumel)-XMATR1.RE(ILIG,ICOL,inumel))/2.D0
126 : 27 CONTINUE
127 : 26 CONTINUE
128 : * SEGDES XMATRI
129 : * SEGDES XMATR1
130 : 25 CONTINUE
131 : SEGDES xMATR1,xmatri
132 : ENDIF
133 : ENDIF
134 : 20 CONTINUE
135 :
136 : SEGDES MRIGID
137 : SEGDES RI1
137 : CALL ECROBJ('RIGIDITE',IRIS)
138 : *
139 : RETURN
140 : END
141 :
142 :
143 :
144 :
145 :
146 :
147 :
© Cast3M 2003 - All rights reserved.
Disclaimer