1 : C CALPAQ SOURCE PV 09/03/12 21:16:13 6325
2 : SUBROUTINE CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,IRET)
3 : *______________________________________________________________________
4 : *
5 : * GESTION DE LA MULTIPLICATION DES CHAMELEMS
6 : * __________________________________________
7 : *
8 : * ENTREES :
9 : * ---------
10 : *
11 : * IPCHE1 POINTEUR SUR UN 1IER MCHAML
12 : * IPCHE2 POINTEUR SUR UN 2IEM MCHAML
13 : *
14 : *
15 : * SORTIES :
16 : * ---------
17 : *
18 : * TITC TITCHE DU MCHAML A CREER
19 : * = ' ' LE MCHAML A CREE EST DONNE PAR NUMCHA
20 : * K TYPE DE MULTIPLICATION 1 SCALAIRE PAR SCALAIRE
21 : * 2 COMPOSANTE PAR SCALAIRE
22 : * 3 COMPOSANTE PAR COMPOSANTE
23 : * 4 MATRICE PAR COMPOSANTE
24 : * 5 GRADIEN PAR GRADIEN
25 : * IPCHE1 <-|
26 : * |-- POINTEUR EVENTUELLEMENT INVERS{
27 : * IPCHE2 <-|
28 : * NUMCHA = 0 LE MCHAML A CREE EST DU TYPE DE IPCHE1 APRES
29 : * INVERSION EVENTUELLE DE IPCHE1 ET IPCHE2
30 : * = X LE MCHAML A CREE EST DU TYPE TITC ,LE TITCHE (TITC
31 : * EST DE LONGEUR X
32 : * IRET = 1 SI OK
33 : * = 0 SINON AVEC GESTION ERREUR
34 : *
35 : * EBERSOLT JANVIER 87
36 : *
37 : * PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 30 10 90
38 : *
39 : *_______________________________________________________________________
40 : *
41 : IMPLICIT INTEGER(I-N)
42 : -INC CCOPTIO
43 : -INC SMCHAML
44 : *
45 : CHARACTER*72 TIT1,TIT2,TITC
46 : PARAMETER (NTIT=22)
47 : CHARACTER*72 TITNOU(NTIT)
48 : *
49 : *
50 : DATA TITNOU / 'NOEUD', 'GRAVITE', 'RIGIDITE', 'MASSE',
51 : 1 'STRESSES', 'DEPLACEMENTS', 'FORCES',
52 : 1 'REACTUALISATION', 'FORCES VOLUMIQUES',
53 : 1 'GRADIENT', 'CONTRAINTES', 'DEFORMATIONS',
54 : 1 'CARACTERISTIQUES', 'BIDON',
55 : 1 'TEMPERATURES', 'CONTRAINTES PRINCIPALES',
56 : 1 'MATRICE DE HOOKE', 'MATRICE DE HOOKE TANGENTE',
57 : 1 'DILATATIONS', 'VARIABLES INTERNES',
58 : 1 'GRADIENT DE FLEXION','VON MISES'/
59 : *
60 : MCHEL1=IPCHE1
61 : MCHEL2=IPCHE2
62 : SEGACT MCHEL1,MCHEL2
63 : TIT1=MCHEL1.TITCHE
64 : TIT2=MCHEL2.TITCHE
65 : *
66 : inuk1=0
67 : inuk2=0
68 : k=0
69 : * write(6,*) 'TIT1' , tit1
70 : IF (TIT1.EQ.'SCALAIRE') THEN
71 : INU1=1
72 : IF (MCHEL1.INFCHE(/2).GE.6) THEN
73 : INU1=MCHEL1.INFCHE(1,6)
74 : IF (INU1.EQ.0) INU1=1
75 : ENDIF
76 : GOTO 1
77 : ENDIF
78 : *
78 : CALL PLACE(TITNOU,NTIT,INU1,TIT1)
79 : * write(6,*) ' inu1 ', inu1
80 : *
81 : if (inu1.eq.0) then
82 : inuk1 = 0
83 : * y a t il une unique composante scalaire?
84 : do lkcha = 1,mchel1.ichaml(/1)
85 : mcham1 = mchel1.ichaml(lkcha)
86 : segact mcham1
87 : if (mcham1.nomche(/2).ne.1.or.mcham1.nomche(1).ne.'SCAL') then
88 : inuk1 = 2
89 : endif
90 : segdes mcham1
91 : enddo
92 : endif
93 : *
94 : 1 CONTINUE
95 : IF (TIT2.EQ.'SCALAIRE') THEN
96 : INU2=1
97 : IF (MCHEL2.INFCHE(/2).GE.6) THEN
98 : INU2=MCHEL2.INFCHE(1,6)
99 : IF (INU2.EQ.0) INU2=1
100 : ENDIF
101 : GOTO 2
102 : ENDIF
103 : *
103 : CALL PLACE(TITNOU,NTIT,INU2,TIT2)
104 : *
105 : if (inu2.eq.0) then
106 : inuk2 = 0
107 : * y a t il une unique composante scalaire?
108 : do lkcha = 1,mchel2.ichaml(/1)
109 : mcham2 = mchel2.ichaml(lkcha)
110 : segact mcham2
111 : if (mcham2.nomche(/2).ne.1.or.mcham2.nomche(1).ne.'SCAL') then
112 : inuk2 = 2
113 : endif
114 : segdes mcham2
115 : enddo
116 : endif
117 : * write(6,*) ' inu1 , inul1,inu2,inuk2', inu1 , inul1,inu2,inuk2
118 : *
119 : * S. PASCAL
120 : * Traitement particulier dans le cas d'un produit de 2 MCHAMLs
121 : * a plusieurs composantes dont certaines sont de type EVOLUTIOn.
122 : * Je cherche dans le MCHEL1 les composantes de type EVOL.
123 : * Si aucune EVOL, INUJ1=0
124 : * Si toute EVOL, INUJ1>0
125 : * Sinon, INUJ1<0
126 : * Idem pour MCHEL2 avec INUJ2
127 : * Je me place dans le cas d'un produit composante par composante :
128 : IF (INU1.EQ.INU2.AND.INU1.GT.5) THEN
129 : NI=MCHEL1.ICHAML(/1)
130 : INUJ1=0
131 : NJ1=0
132 : DO ICHA=1,NI
133 : MCHAM1=MCHEL1.ICHAML(ICHA)
134 : SEGACT MCHAM1
135 : NJ=MCHAM1.IELVAL(/1)
136 : DO JELV=1,NJ
137 : IF (MCHAM1.TYPCHE(JELV).EQ.'POINTEUREVOLUTIO') THEN
138 : INUJ1=ABS(INUJ1)+1
139 : ENDIF
140 : INUJ1=INUJ1*(2*(INUJ1/(JELV+NJ1))-1)
141 : ENDDO
142 : NJ1=NJ1+NJ
143 : ENDDO
144 : NI=MCHEL2.ICHAML(/1)
145 : INUJ2=0
146 : NJ2=0
147 : DO ICHA=1,NI
148 : MCHAM2=MCHEL2.ICHAML(ICHA)
149 : SEGACT MCHAM2
150 : NJ=MCHAM2.IELVAL(/1)
151 : DO JELV=1,NJ
152 : IF (MCHAM2.TYPCHE(JELV).EQ.'POINTEUREVOLUTIO') THEN
153 : INUJ2=ABS(INUJ2)+1
154 : ENDIF
155 : INUJ2=INUJ2*(2*(INUJ2/(JELV+NJ2))-1)
156 : ENDDO
157 : NJ2=NJ2+NJ
158 : ENDDO
159 : ENDIF
160 : *
161 : 2 CONTINUE
162 : SEGDES MCHEL1,MCHEL2
163 : *
164 : IRET=1
165 : K=0
166 : *
167 : IF(INU1.EQ.0.AND.inuk1.EQ.0) THEN
168 : NUMCHA=1
169 : TITC=' '
170 : K=2
171 : inuk1 = IPCHE2
172 : IPCHE2 = IPCHE1
173 : IPCHE1 = inuk1
174 : ELSE IF(INU2.EQ.0.AND.inuk2.EQ.0) THEN
175 : NUMCHA=1
176 : TITC=' '
177 : K=2
178 : ELSE IF(INU1.EQ.0.OR.INU2.EQ.0) THEN
179 : NUMCHA=1
180 : TITC=' '
181 : K=3
182 : ELSE IF(INU1.EQ.INU2.AND.INU1.LE.5.AND.INU1.GE.1) THEN
183 : NUMCHA=1
184 : TITC=' '
185 : K=1
186 : ELSE IF(INU1.EQ.10.AND.INU2.EQ.10) THEN
187 : NUMCHA=8
188 : TITC='GRADIENT'
189 : K=5
190 : ELSE IF(INU1.EQ.10.AND.INU2.EQ.21) THEN
191 : NUMCHA=8
192 : TITC='GRADIENT'
193 : K=5
194 : ELSE IF(INU1.EQ.21.AND.INU2.EQ.10) THEN
195 : NUMCHA=19
196 : TITC='GRADIENT DE FLEXION'
197 : K=5
198 : ELSE IF(INU1.EQ.21.AND.INU2.EQ.21) THEN
199 : NUMCHA=19
200 : TITC='GRADIENT DE FLEXION'
201 : K=5
202 : ELSE IF(INU1.EQ.INU2.AND.INU1.GT.5) THEN
203 : NUMCHA=1
204 : TITC=' '
205 : K=3
206 : ELSE IF(INU1.EQ.INU2.AND.INU1.GT.5.AND.
207 : & ((INUJ1.GT.0).OR.(INUJ2.EQ.0))) THEN
208 : NUMCHA=1
209 : TITC=' '
210 : K=3
211 : ELSE IF(INU1.EQ.INU2.AND.INU1.GT.5.AND.
212 : & INUJ1.EQ.0.AND.INUJ2.NE.0) THEN
213 : NUMCHA=1
214 : TITC=' '
215 : III= IPCHE1
216 : IPCHE1=IPCHE2
217 : IPCHE2=III
218 : K=3
219 : ELSE IF(INU1.EQ.INU2.AND.INU1.GT.5.AND.
220 : & INUJ1.LT.0.AND.INUJ2.GT.0) THEN
221 : NUMCHA=1
222 : TITC=' '
223 : III= IPCHE1
224 : IPCHE1=IPCHE2
225 : IPCHE2=III
226 : K=3
227 : ELSE IF(INU1.EQ.INU2.AND.INU1.GT.5.AND.
228 : & INUJ1.LT.0.AND.INUJ2.LT.0) THEN
229 : NUMCHA=1
230 : TITC=' '
231 : K=3
232 : ELSE IF (INU1.EQ.1.AND.(INU2.EQ.6.OR.INU2.EQ.7)) THEN
233 : NUMCHA=1
234 : TITC=' '
235 : III= IPCHE1
236 : IPCHE1=IPCHE2
237 : IPCHE2=III
238 : K=2
239 : ELSE IF (INU2.EQ.1.AND.(INU1.EQ.6.OR.INU1.EQ.7)) THEN
240 : NUMCHA=1
241 : TITC=' '
242 : K=2
243 : ELSE IF (INU1.EQ.3.AND.
244 : & (INU2.EQ.13.OR.INU2.EQ.14.OR.INU2.EQ.17)) THEN
245 : NUMCHA=1
246 : TITC=' '
247 : III= IPCHE1
248 : IPCHE1=IPCHE2
249 : IPCHE2=III
250 : K=2
251 : ELSE IF (INU2.EQ.3.AND.
252 : & (INU1.EQ.13.OR.INU1.EQ.14.OR.INU1.EQ.17)) THEN
253 : NUMCHA=1
254 : TITC=' '
255 : K=2
256 : ELSE IF (INU1.EQ.5.AND.(INU2.EQ.11.OR.INU2.EQ.12.OR.
257 : & INU2.EQ.15.OR.INU2.EQ.16.OR.INU2.EQ.18)) THEN
258 : NUMCHA=1
259 : TITC=' '
260 : III= IPCHE1
261 : IPCHE1=IPCHE2
262 : IPCHE2=III
263 : K=2
264 : ELSE IF (INU2.EQ.5.AND.(INU1.EQ.11.OR.INU1.EQ.12.OR.
265 : & INU1.EQ.15.OR.INU1.EQ.16.OR.INU1.EQ.18)) THEN
266 : NUMCHA=1
267 : TITC=' '
268 : K=2
269 : ELSE IF (INU1.EQ.11.AND.(INU2.EQ.17.OR.INU2.EQ.18)) THEN
270 : NUMCHA=12
271 : TITC='DEFORMATIONS'
272 : K=4
273 : ELSE IF (INU1.EQ.12.AND.(INU2.EQ.17.OR.INU2.EQ.18)) THEN
274 : NUMCHA=11
275 : TITC='CONTRAINTES'
276 : K=4
277 : ELSE IF (INU2.EQ.11.AND.(INU1.EQ.17.OR.INU1.EQ.18)) THEN
278 : NUMCHA=12
279 : TITC='DEFORMATIONS'
280 : III= IPCHE1
281 : IPCHE1=IPCHE2
282 : IPCHE2=III
283 : K=4
284 : ELSE IF (INU2.EQ.12.AND.(INU1.EQ.17.OR.INU1.EQ.18)) THEN
285 : NUMCHA=11
286 : TITC='CONTRAINTES'
287 : III= IPCHE1
288 : IPCHE1=IPCHE2
289 : IPCHE2=III
290 : K=4
291 : ELSE
292 : IRET=0
293 : ENDIF
294 : IF(IRET.EQ.0) GOTO 166
295 : *
296 : GOTO 666
297 : *
298 : 166 CONTINUE
299 : IRET=0
300 : *
301 : * ERREUR LES CHAMELEM QUE L ON TENTE DE MULTIPLIER
302 : * OU DIVISER SONT INCOMPATIBLES
303 : *
304 : MOTERR(1:16)=TIT1(1:16)
305 : MOTERR(17:32)=TIT2(1:16)
305 : CALL ERREUR(993)
306 : *
307 : 666 CONTINUE
308 : *
309 : RETURN
310 : END
311 :
312 :
313 :
314 :
315 :
316 :
© Cast3M 2003 - All rights reserved.
Disclaimer