1 : C DECO1 SOURCE CHAT 11/03/16 21:18:48 6902
2 : SUBROUTINE DECO1(IPMODL,IPCHE2,IPCHE1,IPCHL1,IRET)
3 : IMPLICIT INTEGER(I-N)
4 : IMPLICIT REAL*8(A-H,O-Z)
5 : *____________________________________________________________________*
6 : * *
7 : * Sous-programme de l'op{rateur DECO *
8 : * *
9 : * Entr{es: *
10 : * *
11 : * IPMODL Pointeur sur un objet MMODEL *
12 : * IPCHE2 Pointeur sur un MCHAML de FONCTION DE COURANT *
13 : * IPCHE1 Pointeur sur un MCHAML de CARACTERISTIQUES *
14 : * *
15 : * Sortie: *
16 : * *
17 : * IPCHL1 Pointeur sur un MCHAML de courants *
18 : * IRET 1 si succes , 0 sinon *
19 : * *
20 : * Auteurs, date de cr{ation: *
21 : * *
22 : * Yann Stephan, le 22/09/97 *
23 : * *
24 : *____________________________________________________________________*
25 : *
26 : -INC CCOPTIO
27 : -INC CCHAMP
28 : -INC SMCHAML
29 : -INC SMMODEL
30 : -INC SMELEME
31 : -INC SMINTE
32 : -INC SMCOORD
33 : *
34 : SEGMENT,MMAT1
35 : REAL*8 VALMAT(NMATR)
36 : REAL*8 XE(3,NBNN),XE1(3,NBNN)
37 : REAL*8 SHP(6,NBNN),GRAD(NDIM,NBNN,NBPGAU)
38 : REAL*8 COSD1(3),COSD2(3)
39 : ENDSEGMENT
40 : POINTEUR MMAT2.MMAT1,MMATX.MMAT1
41 : *
42 : SEGMENT SGAUSS
43 : REAL*8 XGAUSS(3,NBPGAU)
44 : REAL*8 DX(NBPGAU)
45 : ENDSEGMENT
46 : POINTEUR SGX.SGAUSS,SGY.SGAUSS
47 : *
48 : SEGMENT,MWRK1
49 : REAL*8 XDDL(LRE)
50 : ENDSEGMENT
51 : *
52 : SEGMENT INFO
53 : INTEGER INFELL(JG)
54 : ENDSEGMENT
55 : *
56 : SEGMENT NOTYPE
57 : CHARACTER*16 TYPE(NBTYPE)
58 : ENDSEGMENT
59 : *
60 : SEGMENT MPTVAL
61 : INTEGER IPOS(NS) ,NSOF(NS)
62 : INTEGER IVAL(NCOSOU)
63 : CHARACTER*16 TYVAL(NCOSOU)
64 : ENDSEGMENT
65 : *
66 : CHARACTER*8 CMATE
67 : CHARACTER*(NCONCH) CONM
68 : PARAMETER ( NINF=3 )
69 : INTEGER INFOS(NINF)
70 : LOGICAL lsupgd
71 : *
72 : IRET=1
73 : MWRK1=0
74 : NMAT = 0
75 : ITHER= 0
76 : IMAGN= 0
77 : NHRM = NIFOUR
78 : *
79 : * ACTIVATION DU CHAPEAU DE MODELE
80 : *
81 : MMODEL = IPMODL
82 : SEGACT MMODEL
83 : NSOUS = KMODEL(/1)
84 : *
85 : * Initialisation du CHAMELEM de COURANTS
86 : *
87 : L1 = 8
88 : N1 = NSOUS
89 : N3 = 6
90 : SEGINI,MCHELM
91 : IPCHL1=MCHELM
92 : TITCHE = 'COURANT'
93 : IFOCHE=IFOUR
94 : *
95 : * Boucle sur les zones {l{mentaires du MODELE
96 : *
97 : DO 500 ISOUS=1,NSOUS
98 : *
99 : * QUELQUES INITIALISATIONS
100 : *
101 : NGRA=0
102 : NDEP=0
103 : NCAR = 0
104 : IPMINT=0
105 : IRTD1=1
106 : NSTRS=0
107 : MOGRAD=0
108 : MODEPL=0
109 : MOTEMP=0
110 : MOCARA=0
111 : MOMATR=0
112 : IVAGRA=0
113 : IVADEP=0
114 : IVACAR=0
115 : IVAMAT=0
116 : NMATR=0
117 : NMATF=0
118 : *
119 : IMODEL=KMODEL(ISOUS)
120 : SEGACT IMODEL
121 : MELE=NEFMOD
122 : IPMAIL=IMAMOD
123 : CONM =CONMOD
124 : NFOR=FORMOD(/2)
125 : NMAT=MATMOD(/2)
125 : CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
126 : IF (CMATE.EQ.' ')THEN
126 : CALL ERREUR(251)
127 : SEGDES IMODEL,MMODEL
128 : SEGSUP MCHELM
129 : IRET=0
130 : RETURN
131 : ENDIF
131 : CALL PLACE(FORMOD,FORMOD(/2),IMAGN,'MAGNETODYNAMIQUE')
132 : *
133 : * ACTIVATION DU MAILLAGE
134 : *
135 : MELEME=IPMAIL
136 : SEGACT,MELEME
137 : NBNN =NUM(/1)
138 : NBELEM=NUM(/2)
139 : NBNO=NBNN
140 : *
141 : * INFORMATIONS SUR L'ELEMENT FINI
142 : *
143 : *
144 : IF(IMAGN.NE.0) THEN
145 : *
146 : * CAS MAGNETODYNAMIQUE
147 : *
148 : if(infmod(/1).lt.4) then
148 : CALL ELQUOI(MELE,0,2,IPINF,IMODEL)
149 : *
150 : IF (IERR.NE.0) THEN
151 : SEGDES IMODEL,MMODEL
152 : SEGSUP MCHELM
153 : IRET=0
154 : RETURN
155 : ENDIF
156 : INFO=IPINF
157 : MFR=INFELL(13)
158 : MINTE=INFELL(11)
159 : MINTE1= INFELL(12)
160 : NSTRS =INFELL(16)
161 : LW = INFELL( 7)
162 : LRE = INFELL( 9)
163 : LHOOK =INFELL(10)
164 : * SEGSUP INFO
165 : ELSE
166 : MFR=INFELE(13)
167 : minte=infmod(4)
168 : MINTE1= INFMOD(8)
169 : NSTRS =INFELE(16)
170 : LW = INFELE( 7)
171 : LRE = INFELE( 9)
172 : LHOOK =INFELE(10)
173 : ENDIF
174 : *
175 : ENDIF
176 : *
177 : * ACTIVATION DU SEGMENT D'INTEGRATION
178 : *
179 : SEGACT,MINTE
180 : NBPGAU=POIGAU(/1)
181 : SEGINI SGAUSS
182 : NDIM=IDIM
183 : SEGINI MMAT1
184 : C
185 : C CREATION DU TABLEAU INFOS
186 : C
186 : CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRTD)
187 : IF (IRTD.EQ.0) GOTO 9990
188 : *
189 : * NOMS DE COMPOSANTES OBLIGATOIRES A TROUVER DANS LES CHAMELEMS
190 : *
191 : MDM=MFR
192 : if(lnomid(3).ne.0) then
193 : nomid=lnomid(3)
194 : segact nomid
195 : mograd=nomid
196 : ngra=lesobl(/2)
197 : nfac=lesfac(/2)
198 : lsupgd=.false.
199 : else
200 : IF(IMAGN.NE.0) MDM=69
201 : lsupgd=.true.
201 : CALL IDGRAD(MDM,IFOUR,MOGRAD,NGRA,NFAC)
202 : endif
203 : *
204 : IF(IMAGN.NE.0) THEN
204 : CALL IDFC(MFR,IFOUR,MOFC,NDEP,NFAC)
205 : ENDIF
206 : *
207 : * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
208 : *
209 : NBROBL=0
210 : NBRFAC=0
211 : MOCARA=0
212 : NCAR=0
213 : *
214 : IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
215 : NBROBL=1
216 : NBRFAC=1
217 : SEGINI NOMID
218 : MOCARA=NOMID
219 : LESOBL(1)='EPAI'
220 : LESFAC(1)='EXCE'
221 : NCAR=1
222 : ENDIF
223 : *
224 : * VERIFICATION DE PRESENCE DES COMPOSANTES
225 : *
226 : NBTYPE=1
227 : SEGINI NOTYPE
228 : MOTYPE=NOTYPE
229 : TYPE(1)='REAL*8'
230 : IF(IMAGN.NE.0) THEN
230 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOFC,
231 : 1 MOTYPE,1,INFOS,3,IVADEP)
232 : ENDIF
233 : SEGSUP NOTYPE
234 : IF (IERR.NE.0) THEN
235 : NGRA=0
236 : IF (NCAR.NE.0) THEN
237 : NOMID=MOCARA
238 : SEGSUP NOMID
239 : ENDIF
240 : MOCARA=0
241 : NCAR=0
242 : GOTO 9990
243 : ENDIF
244 : *
245 : IF (NCAR.NE.0) THEN
246 : IF (IPCHE1.NE.0) THEN
247 : NBTYPE=1
248 : SEGINI NOTYPE
249 : MOTYPE=NOTYPE
250 : TYPE(1)='REAL*8'
250 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,
251 : 1 1,INFOS,3,IVACAR)
252 : SEGSUP NOTYPE
253 : ELSE
254 : MOTERR(1:8)='CARACTER'
255 : MOTERR(9:12)=NOMTP(MELE)
256 : MOTERR(13:20)='COURANT'
256 : CALL ERREUR(145)
257 : NCAR=0
258 : NGRA=0
259 : NOMID=MOCARA
260 : SEGSUP NOMID
261 : MOCARA=0
262 : GOTO 9990
263 : ENDIF
264 : ENDIF
265 : IF (IERR.NE.0) GOTO 9990
266 : *
267 : IF(IVACAR.NE.0)THEN
268 : MPTVAL=IVACAR
269 : IPMELV=IVAL(1)
269 : CALL QUELCH(IPMELV,ICONS)
270 : IF(ICONS.NE.0)THEN
270 : CALL ERREUR(566)
271 : GOTO 9990
272 : ENDIF
273 : ENDIF
274 : *
275 : *
276 : NBROBL=0
277 : NBRFAC=0
278 : MOMATR=0
279 : NMATR=0
280 : NMATF=0
281 : *
282 : * CREATION DU MCHAML DE COURANT
283 : *
284 : N2=NGRA
285 : SEGINI,MCHAML
286 : ICHAML(ISOUS)=MCHAML
287 : IMACHE(ISOUS)=MELEME
288 : CONCHE(ISOUS)=CONMOD
289 : C
290 : INFCHE(ISOUS,1)=0
291 : INFCHE(ISOUS,2)=0
292 : INFCHE(ISOUS,3)=NHRM
293 : INFCHE(ISOUS,4)=MINTE
294 : INFCHE(ISOUS,5)=0
295 : IF(IMAGN.NE.0) THEN
296 : INFCHE(ISOUS,6)=2
297 : ENDIF
298 : *
299 : * RECHERCHE DES DIMENSIONS LES PLUS GRANDES
300 : *
301 : N1EL=0
302 : N1PTEL=0
303 : MPTVAL=IVADEP
304 : DO 178 IO=1,NDEP
305 : MELVAL=IVAL(IO)
306 : N1PTEL=MAX(N1PTEL,VELCHE(/1))
307 : N1EL =MAX(N1EL ,VELCHE(/2))
308 : 178 CONTINUE
309 : *
310 : IF (N1PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN
311 : N1PTEL=1
312 : ELSE
313 : N1PTEL=NBPGAU
314 : ENDIF
315 : N1EL =MIN(N1EL ,NBELEM)
316 : *
317 : * CREATION DES MELVAL DU COURANT
318 : *
319 : NS=1
320 : NCOSOU=NGRA
321 : SEGINI MPTVAL
322 : IVAGRA=MPTVAL
323 : NOMID=MOGRAD
324 : SEGACT NOMID
325 : DO 77 IGR=1,NGRA
326 : TYPCHE(IGR)='REAL*8'
327 : NOMCHE(IGR)=LESOBL(IGR)
328 : N2PTEL=0
329 : N2EL=0
330 : SEGINI MELVAL
331 : IELVAL(IGR)=MELVAL
332 : IVAL(IGR)=MELVAL
333 : 77 CONTINUE
334 : SEGDES NOMID
335 : *
336 : IMESS = 0
337 : NBBB=NBNO
338 : IF (MFR.EQ.29) THEN
339 : NDUM=NGRA
340 : NGRA=NDUM*NBBB
341 : SEGINI MWRK1
342 : NGRA=NDUM
343 : ELSE
344 : SEGINI MWRK1
345 : ENDIF
346 : *
347 : * Boucle sur les {l{ments
348 : *
349 : DO 100 IB=1,NBELEM
350 : *
351 : * On cherche les coordonn{es des noeuds de l'{l{ment IB
352 : *
352 : CALL DOXE(XCOOR,IDIM,NBNO,NUM,IB,XE)
353 : *
354 : * On cherche les d{placements ou les temp{ratures
355 : *
356 : IE=1
357 : MPTVAL=IVADEP
358 : NDDD=NDEP
359 : IF (IFOUR.EQ.-3.AND.ITHER.EQ.0) NDDD=NDEP-3
360 : DO 200 IGAU=1,NBNN
361 : DO 200 ICOMP=1,NDDD
362 : MELVAL=IVAL(ICOMP)
363 : IF (MELVAL.NE.0) THEN
364 : IGMN=MIN(IGAU,VELCHE(/1))
365 : IBMN=MIN(IB ,VELCHE(/2))
366 : XDDL(IE)=VELCHE(IGMN,IBMN)
367 : ELSE
368 : XDDL(IE)=0.
369 : ENDIF
370 : IE=IE+1
371 : 200 CONTINUE
372 : *
373 : * On se dirige vers la zone sp{cifique selon l'{l{ment
374 : *
375 : GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
376 : & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
377 : & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
378 : & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
379 : & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
380 : & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
381 : & 99,99,99,99,99,99,99,27),MELE
382 : *
383 : 99 CONTINUE
384 : MOTERR(1:4)=NOMTP(MELE)
385 : MOTERR(9:12)='COURANT'
386 : IMESS = 86
387 : GOTO 9990
388 : *____________________________________________________________________*
389 : * 2/ COQ3 *
390 : *____________________________________________________________________*
391 : 27 CONTINUE
392 : IF(IMAGN.NE.0)THEN
393 : C COQUE MAGNETODYNAMIQUE
393 : CALL COQLOC(NBNN,XE,COSD1,COSD2,XE1)
393 : CALL ELGAUS(MINTE,MMAT1,SGAUSS,IFOIS,IFOI2)
394 : C
395 : IF(IFOIS.NE.0.AND.IFOIS.NE.NBPGAU)THEN
396 : *
397 : * LE JACOBIEN EST NEGATIF ,MAILLAGE INCORRECT
398 : INTERR(1)=IB
398 : CALL ERREUR(195)
399 : GO TO 9990
400 : ELSEIF(IFOI2.EQ.NBPGAU)THEN
401 : *
402 : * CAS OU LE JACOBIEN EST TRES PETIT
403 : *
404 : INTERR(1)=IB
404 : CALL ERREUR (259)
405 : GO TO 9990
406 : ENDIF
407 : DO 5027 IGAU=1,NBPGAU
408 : C
409 : C REMPLISSAGE
410 : C
411 : MPTVAL=IVAGRA
412 : DO 7027 IC=1,NGRA
413 : MELVAL=IVAL(IC)
414 : IBMN=MIN(IB ,VELCHE(/2))
415 : IGMN=MIN(IGAU,VELCHE(/1))
416 : DO 7027 IN=1,NBNN
417 : VELCHE(IGMN,IBMN)=VELCHE(IGMN,IBMN)+
418 : & GRAD(IC,IN,IGAU)*XDDL(IN)
419 : 7027 CONTINUE
420 : 5027 CONTINUE
421 : *
422 : ENDIF
423 : *
424 : 100 CONTINUE
425 : *
426 : * D{sactivation des segments
427 : *
428 : IF (MWRK1.NE.0) SEGSUP,MWRK1
429 : *
429 : CALL DTMVAL(IVADEP,1)
429 : CALL DTMVAL(IVACAR,1)
429 : CALL DTMVAL(IVAMAT,1)
429 : CALL DTMVAL(IVAGRA,1)
430 : *
431 : IF (ITHER.NE.0) THEN
432 : NOMID=MOTEMP
433 : SEGSUP NOMID
434 : ELSE IF(IMAGN.NE.0) THEN
435 : NOMID=MOFC
436 : SEGSUP NOMID
437 : ELSE
438 : NOMID=MODEPL
439 : SEGSUP NOMID
440 : ENDIF
441 : IF (MOCARA.NE.0) THEN
442 : NOMID=MOCARA
443 : SEGSUP NOMID
444 : ENDIF
445 : IF (MOMATR.NE.0) THEN
446 : NOMID=MOMATR
447 : SEGSUP NOMID
448 : ENDIF
449 : NOMID=MOGRAD
450 : if(lsupgd)SEGSUP NOMID
451 : *
452 : * IF(ITHER.EQ.0) SEGSUP INFO
453 : SEGDES,IMODEL,MELEME
454 : SEGDES,MCHAML,MINTE
455 : *
456 : 500 CONTINUE
457 : SEGDES,MMODEL,MCHELM
457 : * CALL DTCHAM(IPCHE2)
458 : *
459 : RETURN
460 : *
461 : 9990 CONTINUE
462 : *
463 : * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
464 : *
465 : IRET=0
466 : *
467 : * Gestion des messages d'erreur
468 : *
469 : IF (IMESS.NE.0) THEN
470 : INTERR(1) = IB
470 : CALL ERREUR(IMESS)
471 : ENDIF
472 : *
473 : IF (MWRK1.NE.0) SEGSUP,MWRK1
474 : SEGSUP MMAT1
475 : SEGSUP SGAUSS
476 : *
476 : CALL DTMVAL(IVADEP,1)
476 : CALL DTMVAL(IVACAR,1)
476 : CALL DTMVAL(IVAMAT,1)
476 : CALL DTMVAL(IVAGRA,3)
477 : *
478 : IF (MODEPL.NE.0) THEN
479 : NOMID=MODEPL
480 : SEGSUP NOMID
481 : ENDIF
482 : IF (MOTEMP.NE.0) THEN
483 : NOMID=MOTEMP
484 : SEGSUP NOMID
485 : ENDIF
486 : IF (MOCARA.NE.0)THEN
487 : NOMID=MOCARA
488 : SEGSUP NOMID
489 : ENDIF
490 : IF (lsupgd.and.MOGRAD.NE.0)THEN
491 : NOMID=MOGRAD
492 : SEGSUP NOMID
493 : ENDIF
494 : IF(MOMATR.NE.0)THEN
495 : NOMID=MOMATR
496 : SEGSUP NOMID
497 : ENDIF
498 : *
499 : SEGDES MELEME
500 : SEGDES IMODEL
501 : *
502 : SEGDES MMODEL
503 : IF (IPCHE1.NE.0) THEN
504 : MCHELM=IPCHE1
505 : SEGDES MCHELM
506 : ENDIF
507 : SEGSUP,MCHAML
508 : SEGSUP,MCHELM
509 : *
509 : * IF (IPCHE2.NE.0) CALL DTCHAM(IPCHE2)
510 : SEGDES MINTE
511 : * IF(ITHER.EQ.0) SEGSUP INFO
512 : RETURN
513 : END
514 :
515 :
516 :
517 :
518 :
519 :
520 :
521 :
522 :
523 :
524 :
525 :
526 :
527 :
528 :
© Cast3M 2003 - All rights reserved.
Disclaimer