1 : C KCHAM1 SOURCE CHAT 11/03/16 21:26:04 6902
2 : SUBROUTINE KCHAM1(IPMODL,IPCHPO,IPCHEL)
3 : *____________________________________________________________________*
4 : * *
5 : * transformation de chpoint en mchaml *
6 : * *
7 : * entr{es: *
8 : * ________ *
9 : * *
10 : * ipmodl pointeur sur un mmodel *
11 : * ipchpo pointeur sur le chpoint *
12 : * *
13 : * sorties: *
14 : * ________ *
15 : * *
16 : * ipchel pointeur sur le mchaml resultat *
17 : *____________________________________________________________________*
18 : * *
19 : IMPLICIT REAL*8 (A-H,O-Z)
20 : *
21 : -INC CCOPTIO
22 : -INC CCGEOME
23 : -INC SMCHAML
24 : -INC SMCHPOI
25 : -INC SMMODEL
26 : -INC SMELEME
27 : -INC SMLENTI
28 : *
29 : *
30 : SEGMENT INFO
31 : INTEGER INFELL(JG)
32 : ENDSEGMENT
33 : *
34 : C PARAMETER (NSPG = 9)
35 : PARAMETER (NSPG = 5)
36 : CHARACTER*8 LSPG(NSPG)
37 : CHARACTER*(NCONCH) CONM
38 : CHARACTER*8 SOUTYP,TYPSPG
39 : C
40 : C l'ordre des SPG correspond à l'ordre du KPOIND
41 : C LSPG(1)='NOEUD' -> SOMMET
42 : C LSPG(2)='GRAVITE' -> CENTRE
43 : C LSPG(3)='RIGIDITE'
44 : C LSPG(4)='MASSE'
45 : C LSPG(5)='STRESSES'
46 : C LSPG(6)='THERMIQU'
47 : C LSPG(7)='FACE' -> FACE
48 : C LSPG(8)='P1CENTRE' -> CENTREP1
49 : C LSPG(9)='MSOMMET' -> MSOMMET
50 : LSPG(1)='SOMMET'
51 : LSPG(2)='CENTRE'
52 : LSPG(3)='FACE'
53 : LSPG(4)='CENTREP1'
54 : LSPG(5)='MSOMMET'
55 : *
56 : * le traitement d'harmoniques de fourier n'est pas implemente
57 : *
58 : IPMINT=0
59 : IPCHEL=0
60 : NPINT = 0
61 : IRRT=0
62 : CONM=' '
63 : TYPSPG=' '
64 : *
65 : * activation de l'objet modele
66 : *
67 : MMODEL = IPMODL
67 : CALL LEKMOD(MMODEL,IDOMA,INEFMD)
68 : IF(IERR.NE.0)GOTO 9999
69 : SEGACT,MMODEL
70 : * IDOMA correspond au pointeur de la table domaine
71 : *
72 : * activation du chpoint
73 : *
74 : MCHPOI=IPCHPO
75 : SEGACT,MCHPOI
76 : NSOUPO=IPCHP(/1)
77 : *
78 : * Determination du type de support geometrique
79 : *
80 : DO 20 I=1,NSOUPO
81 : MSOUPO=IPCHP(I)
82 : SEGACT MSOUPO
83 : MLMCHP=IGEOC
84 : SEGDES MSOUPO
84 : CALL KRIPAD(MLMCHP,MLENTI)
85 : C
86 : C TYPSPG = SOMMET, FACE, CENTRE, CENTREP0, CENTREP1 ou MSOMMET
87 : C
88 : DO 10 L=1,NSPG
89 : TYPSPG=LSPG(L)
89 : CALL LEKTAB(IDOMA,TYPSPG,MLMSPG)
89 : CALL KRIPAD(MLMSPG,MLENT1)
90 : IF(IERR.NE.0)GOTO 9999
90 : CALL VERPAD(MLENTI,MLMSPG,IRET1)
90 : CALL VERPAD(MLENT1,MLMCHP,IRET2)
91 : IF(IRET1.EQ.0.AND.IRET2.EQ.0) GOTO 21
92 : 10 CONTINUE
93 : 20 CONTINUE
94 :
95 : WRITE(6,*)'SPG du champoint non trouve : '
96 : WRITE(6,*)'CHPO peut-etre incompatible avec le modele?'
97 : GOTO 666
98 :
99 : 21 CONTINUE
100 :
101 : IPT3=MLMSPG
102 : INFSPG=L
103 : IF(L.GE.3) INFSPG=4+L
104 : IF(INFSPG.EQ.2) SEGACT,IPT3
105 : *
106 : * recherche eventuelle des sous-domaine du maillage
107 : * associe a l'objet modele Navier-Stokes
108 : *
109 : IMACR1=0
110 : DO 11 I=1,MAX(1,KMODEL(/1))
111 : IMODEL=KMODEL(I)
112 : SEGACT,IMODEL
113 : NELE=NEFMOD
114 : IF(NELE.GE.216.AND.NELE.LE.222) IMACR1=IMACR1+1
115 : 11 CONTINUE
116 :
117 :
118 :
118 : CALL LEKTAB(IDOMA,'MAILLAGE',MPERE)
119 : IF(INEFMD.EQ.2.AND.INFSPG.NE.2) THEN
119 : CALL LEKTAB(IDOMA,'MACRO1',MPERE)
120 : ENDIF
120 : IF(IMACR1.EQ.KMODEL(/1)) CALL LEKTAB(IDOMA,'MAILLAGE',MPERE)
121 : C LINE ou LINB avec CENTREP1
122 : IF(INEFMD.EQ.1.OR.INEFMD.EQ.4) THEN
123 : IF(INFSPG.EQ.8) THEN
124 : C Option %m1:8 incompatible avec les données
125 : MOTERR( 1: 8) = TYPSPG
125 : CALL ERREUR(803)
126 : GOTO 666
127 : ENDIF
128 : ENDIF
129 : C Face
130 : IF(INFSPG.EQ.7) THEN
131 : C Option %m1:8 incompatible avec les données
132 : MOTERR( 1: 8) = TYPSPG
132 : CALL ERREUR(803)
133 : GOTO 666
134 : ENDIF
135 : IF(INFSPG.EQ.8) THEN
135 : CALL LEKTAB(IDOMA,'ELTP1NC',IPT4)
136 : SEGACT,IPT4
137 : ENDIF
138 :
139 : MELEME=MPERE
140 : SEGACT MELEME
141 : N1=MAX(1,LISOUS(/1))
142 :
143 : *
144 : * initialisation du segment descripteur du champ par element
145 : *
146 : N3=6
147 : L1=LEN(MTYPOI)
148 : SOUTYP=MTYPOI
149 : SEGINI,MCHELM
150 : TITCHE=SOUTYP
151 : IFOCHE=IFOUR
152 : C
153 : C remplissage des MCHAML
154 : C
155 : ILM1=0
156 : DO 30 I=1,N1
157 : IF(N1.NE.1) THEN
158 : IPT1=LISOUS(I)
159 : SEGACT IPT1
160 : ELSE
161 : IPT1=MELEME
162 : ENDIF
163 : IMACHE(I)=IPT1
164 : CONCHE(I)=CONM
165 : INFCHE(I,6)=INFSPG
166 :
167 : IMODEL=KMODEL(I)
168 : SEGACT,IMODEL
169 : NELE=NEFMOD
170 : N2PTEL=0
171 : N2EL=0
172 : * TYPE SPG DU CHPO : SOMMET
173 : IF(INFSPG.EQ.1) THEN
174 : IMINT=0
175 : N1PTEL=IPT1.NUM(/1)
176 : N1EL=IPT1.NUM(/2)
177 : * TYPE SPG DU CHPO : CENTRE
178 : ELSEIF(INFSPG.EQ.2) THEN
179 : if(infmod(/1).lt.4) then
179 : CALL ELQUOI(NELE,0,INFSPG,IPTR,IMODEL)
180 : INFO=IPTR
181 : IMINT=INFELL(11)
182 : segsup info
183 : else
184 : IMINT=infmod(INFSPG+2)
185 : endif
186 : N1PTEL=1
187 : N1EL=IPT1.NUM(/2)
188 : * IF(INFO.GT.0) SEGSUP INFO
189 : * TYPE SPG DU CHPO : CENTREP1
190 : ELSEIF(INFSPG.EQ.8) THEN
190 : CALL ELQUOI(NELE,0,INFSPG,IPTR,IMODEL)
191 : INFO=IPTR
192 : IMINT=INFELL(11)
193 : N1PTEL=INFELL(8)
194 : N1EL=IPT1.NUM(/2)
195 : SEGSUP INFO
196 : * TYPE SPG DU CHPO : MSOMMET
197 : ELSEIF(INFSPG.EQ.9) THEN
197 : CALL ELQUOI(NELE,0,INFSPG,IPTR,IMODEL)
198 : INFO=IPTR
199 : IMINT=INFELL(11)
200 : N1PTEL=INFELL(8)
201 : N1EL=IPT1.NUM(/2)
202 : SEGSUP INFO
203 : ENDIF
204 :
205 : INFCHE(I,4)=IMINT
206 :
207 : DO 40 J=1,NSOUPO
208 : MSOUPO=IPCHP(J)
209 : SEGACT MSOUPO
210 : N2=NOCOMP(/2)
211 : IPT2=IGEOC
212 : SEGACT,IPT2
212 : CALL KRIPAD(IPT2,MLENT2)
213 : SEGACT,MLENT2
214 : MPOVAL=IPOVAL
215 : SEGACT,MPOVAL
216 : SEGINI,MCHAML
217 : ICHAML(I)=MCHAML
218 :
219 : DO 50 K=1,N2
220 : NOMCHE(K)=NOCOMP(K)
221 : TYPCHE(K)='REAL*8'
222 : SEGINI,MELVAL
223 : IELVAL(K)=MELVAL
224 : DO 70 K70=1,N1EL
225 : DO 80 K80=1,N1PTEL
226 : IF(INFSPG.EQ.1) THEN
227 : II2=IPT1.NUM(K80,K70)
228 : ELSEIF(INFSPG.EQ.2) THEN
229 : II2=IPT3.NUM(K80,(ILM1+K70))
230 : ELSEIF(INFSPG.EQ.8) THEN
231 : II2=IPT4.NUM(K80,(ILM1+K70))
232 : ELSEIF(INFSPG.EQ.9) THEN
233 : IF(INEFMD.EQ.1) II1=K80
234 : IF(INEFMD.EQ.2) II1=(2*K80)-1
235 : IF(INEFMD.EQ.3) II1=(2*K80)-1
236 : IF(INEFMD.EQ.4) II1=K80
237 : II2=IPT1.NUM(II1,K70)
238 : ENDIF
239 : VELCHE(K80,K70)=VPOCHA(MLENT2.LECT(II2),K)
240 : 80 CONTINUE
241 : 70 CONTINUE
242 : SEGDES,MELVAL
243 : 50 CONTINUE
244 : SEGDES,IPT2
245 : SEGDES,MLENT2
246 : SEGDES,MSOUPO
247 : SEGDES,MPOVAL
248 : SEGDES,MCHAML
249 : 40 CONTINUE
250 : ILM1=ILM1+IPT1.NUM(/2)
251 : IF(N1.NE.1) SEGDES,IPT1
252 : SEGDES,IMODEL
253 : 30 CONTINUE
254 :
255 : IPCHEL=MCHELM
256 : SEGDES,MCHELM
257 :
258 : SEGDES,MELEME
259 : 666 CONTINUE
260 : IF(INFSPG.EQ.2) SEGDES,IPT3
261 : IF(INFSPG.EQ.8) SEGDES,IPT4
262 : SEGDES,MCHPOI
263 : SEGDES,MMODEL
264 :
265 : C
266 : 9999 CONTINUE
267 : RETURN
268 : END
269 :
270 :
271 :
272 :
273 :
© Cast3M 2003 - All rights reserved.
Disclaimer