1 : C EXCOMP SOURCE FANDEUR 10/12/14 21:16:19 6812
2 : SUBROUTINE EXCOMP
3 : C=======================================================================
4 : C
5 : C OPERATEUR EXTRACTION D UNE COMPOSANTE D UN CHPOINT
6 : C D UN MCHAML
7 : C DE QUELQUES COMPOSANTES D UN MCHAML
8 : C
9 : C CH2 = EXCO | MOT1 CH1 ('NOID') (MOT2) |
10 : C | |('NATURE'|'INDETER')
11 : C | | |'DIFFUS' )
12 : C | | |'DISCRET');
13 : C | LISM1 CH1 ('NOID') (LISM2) |
14 : C
15 : C=======================================================================
16 : IMPLICIT INTEGER(I-N)
17 : IMPLICIT REAL*8(A-H,O-Z)
18 : -INC CCOPTIO
19 : -INC SMLMOTS
20 : -INC SMCHPOI
21 : CHARACTER*4 NOVE(1),NATU(3),MOT,MOT2,MOT3
22 : DATA NOVE/'NOID'/
23 : DATA NATU/'INDE','DIFF','DISC'/
24 : C
25 : C LISTE DE MOT OU MOT SIMPLE
26 : C
27 : MOT=' '
28 : LISM1=0
29 : LISM2=0
29 : CALL LIROBJ('LISTMOTS',LISM1,0,IRT1)
30 : IF(IRT1.EQ.0) THEN
31 : MOT2='SCAL'
31 : CALL LIRCHA(MOT,1,IRETOU)
32 : IF(IERR.NE.0) RETURN
33 : ELSE
33 : CALL LIROBJ('LISTMOTS',LISM2,0,IRL2)
34 : ENDIF
35 : C
35 : CALL LIRMOT(NOVE,1,NOID,0)
36 : C
36 : CALL LIROBJ('CHPOINT ',IPCH1,0,IRT2)
37 : IF(IRT2.EQ.0) GOTO 100
38 : C-----------------------------------------------
39 : C CAS D'UN CHPO
40 : C
41 : C on essaie de lire le nouveau nom et la nature (facultatif)
41 : CALL LIRCHA(MOT2,0,IRETOU)
42 : MCHPOI = IPCH1
43 : SEGACT MCHPOI
44 : JATT1 = JATTRI(1)+1
45 : IF (IRETOU .GE. 1) THEN
46 : IF (MOT2 .EQ. 'NATU' ) THEN
47 : C jatt va stocker la nature
47 : CALL LIRMOT(NATU,3,JATT1,1)
48 : IF(IERR.NE.0) RETURN
49 : MOT2=' '
50 : ELSE
51 : C mot2 est le nouveau nom de la composante
52 : C on essaie de lire la nature
52 : CALL LIRCHA(MOT3,0,IRETOU)
53 : IF (IRETOU .GE. 1) THEN
54 : IF (MOT3 .EQ. 'NATU' ) THEN
54 : CALL LIRMOT(NATU,3,JATT1,1)
55 : IF(IERR.NE.0) RETURN
56 : ELSE
57 : C natu n'est pas specifie on continue...
57 : CALL REFUS
58 : ENDIF
59 : ENDIF
60 : ENDIF
61 : ENDIF
62 : C
63 : IF (LISM1.EQ.0) THEN
64 : C
65 : C MOT SIMPLE
66 : C
66 : CALL EXCOPP(IPCH1,MOT,IPCH2,MOT2,NOID)
67 : IF(IERR.NE.0) RETURN
68 : ELSE
69 : C
70 : C LISTE DE MOTS
71 : C
72 : MLMOTS=LISM1
73 : SEGACT MLMOTS
74 : IF (LISM2.NE.0) THEN
75 : MLMOT2=LISM2
76 : SEGACT,MLMOT2
77 : IF (MOTS(/2).NE.MLMOT2.MOTS(/2)) THEN
77 : CALL ERREUR(217)
78 : SEGDES MLMOTS,MLMOT2
79 : RETURN
80 : ENDIF
81 : ENDIF
82 : IPCH2=0
83 : DO 51 IM=1,MOTS(/2)
84 : MOT =MOTS(IM)(1:4)
85 : IF (LISM2.NE.0) THEN
86 : MOT2=MLMOT2.MOTS(IM)(1:4)
87 : ELSE
88 : MOT2=MOTS(IM)(1:4)
89 : ENDIF
89 : CALL EXCOPP(IPCH1,MOT,IPCH3,MOT2,NOID)
90 : IF(IERR.NE.0) THEN
91 : SEGDES MLMOTS
92 : IF (LISM2.NE.0) SEGDES MLMOT2
92 : IF(IPCH2.NE.0) CALL DTCHPO(IPCH2)
93 : RETURN
94 : ENDIF
95 : IF(IPCH2.EQ.0) THEN
96 : IPCH2=IPCH3
97 : ELSE
97 : CALL ADCHPO(IPCH2,IPCH3,IPCH2,1D0,1D0)
98 : IF(IERR.NE.0) THEN
98 : IF(IPCH2.NE.0) CALL DTCHPO(IPCH2)
98 : CALL DTCHPO(IPCH3)
99 : SEGDES MLMOTS
100 : IF (LISM2.NE.0) SEGDES MLMOT2
101 : RETURN
102 : ENDIF
103 : ENDIF
104 : 51 CONTINUE
105 : SEGDES MLMOTS
106 : IF (LISM2.NE.0) SEGDES MLMOT2
107 : ENDIF
108 : C
109 : C On ajuste la nature du champ
110 : MCHPOI=IPCH2
111 : SEGACT MCHPOI*MOD
112 : mochde=' chpoint cree par EXCOMP'
113 : mtypoi='SCALAIRE'
114 : JATTRI(1)=JATT1-1
115 : SEGDES MCHPOI
116 : C
116 : CALL ECROBJ('CHPOINT ',IPCH2)
117 : RETURN
118 : C ---------------------------------------------
119 : C CAS D'UN MCHAML
120 : C
121 : 100 CONTINUE
122 : C
122 : CALL LIROBJ('MCHAML',ICHE1,0,IRT3)
123 : IF(IRT3.EQ.0) GO TO 300
123 : CALL LIRCHA(MOT2,0,IRETOU)
124 : IF(IRETOU.EQ.0) MOT2=MOT
125 : C
126 : IF (LISM1.EQ.0) THEN
126 : CALL EXCOC1(ICHE1,MOT,ICHE2,MOT2,NOID)
127 : IF(IERR.NE.0) RETURN
128 : ELSE
129 : MLMOTS=LISM1
130 : SEGACT MLMOTS
131 : IF (LISM2.NE.0) THEN
132 : MLMOT2=LISM2
133 : SEGACT,MLMOT2
134 : IF (MOTS(/2).NE.MLMOT2.MOTS(/2)) THEN
134 : CALL ERREUR(217)
135 : SEGDES MLMOTS,MLMOT2
136 : RETURN
137 : ENDIF
138 : ENDIF
139 : ICHE2=0
140 : DO 201 IM=1,MOTS(/2)
141 : MOT =MOTS(IM)(1:4)
142 : IF (LISM2.NE.0) THEN
143 : MOT2=MLMOT2.MOTS(IM)(1:4)
144 : ELSE
145 : MOT2=MOTS(IM)(1:4)
146 : ENDIF
147 : * write(6,*) 'MOT MOT2 ' , MOT , MOT2 ,NOID
147 : CALL EXCOC1(ICHE1,MOT,ICHE3,MOT2,NOID)
148 : IF(IERR.NE.0) THEN
149 : SEGDES MLMOTS
150 : IF (LISM2.NE.0) SEGDES MLMOT2
150 : IF(ICHE2.NE.0) CALL DTCHAM(ICHE2)
151 : RETURN
152 : ENDIF
153 : IF(ICHE2.EQ.0) THEN
154 : ICHE2=ICHE3
155 : ELSE
155 : CALL FUSCHL(ICHE2,ICHE3,ICHE4)
156 : IF(IERR.NE.0) THEN
156 : * call zpchel (iche2,1)
156 : * call zpchel(iche3,1)
156 : CALL DTCHAM(ICHE2)
156 : CALL DTCHAM(ICHE3)
157 : SEGDES MLMOTS
158 : IF (LISM2.NE.0) SEGDES MLMOT2
159 : RETURN
160 : ENDIF
161 : ICHE2=ICHE4
162 : ENDIF
163 : 201 CONTINUE
164 : SEGDES MLMOTS
165 : IF (LISM2.NE.0) SEGDES MLMOT2
166 : ENDIF
166 : CALL ECROBJ('MCHAML',ICHE2)
167 : RETURN
168 : C
169 : C PAS D OPERANDE CORRECTE TROUVE
170 : C
170 : 300 CALL QUETYP(MOTERR(1:8),0,IRETOU)
171 : IF(IRETOU.NE.0) THEN
171 : CALL ERREUR (39)
172 : ELSE
172 : CALL ERREUR(533)
173 : ENDIF
174 : RETURN
175 : END
176 :
177 :
© Cast3M 2003 - All rights reserved.
Disclaimer