1 : C VOLOS SOURCE CHAT 07/10/29 21:30:27 5940
2 :
3 : SUBROUTINE VOLOS(IPT1,IPT2,N1,N2,DEN1,DEN2,NBCOU)
4 : C **********************************************************************
5 : C INTERFACE CASTEM 2000
6 : C
7 : C GEO1 = SURF1 VOLOS SURF2 PO1 PO2 (N1) ('DINI' DENS1) ('DFIN' DENS2) ;
8 : C
9 : C
10 : C OBJET :
11 : C _______
12 : C
13 : C L'OPERATEUR VOLOS RACCORDE DES MAILLAGES SURFACIQUES QUI ONT
14 : C DES STRUCTURES DE GRILLES.
15 : C
16 : C
17 : C DATE : 24.10.96
18 : C ______
19 : C
20 : C AUTEURS : O. STAB
21 : C _________
22 : C
23 : C
24 : C **********************************************************************
25 : IMPLICIT INTEGER(I-N)
26 : IMPLICIT REAL*8 (A-H,O-Z)
27 : C
28 : -INC CCOPTIO
29 : -INC SMELEME
30 : -INC SMCOORD
31 : -INC CCGEOME
32 : SEGMENT ITRAVX
33 : INTEGER ITVL (ITOTAI)
34 : ENDSEGMENT
35 : SEGMENT RTRAVX
36 : REAL*8 RTVL (ITOTAR)
37 : ENDSEGMENT
38 : SEGMENT ICPR (XCOOR(/1)/(IDIM+1))
39 : SEGMENT ICPP (XCOOR(/1)/(IDIM+1))
40 : C
41 : INTEGER NITMAX,NRTMAX,IERRDS
42 : C --- VARIABLES INTERNES ---
43 : INTEGER NBN,NBE,IDIMC,NBNMAX,IDE,NBPMAX,NBEMAX,ITRNOE
44 : INTEGER ITRVMX,ICOORD,NBCOOR
45 : INTEGER ITRNO1,ITRNO2,NBE1,NBE2,NBN1,NBN2
46 : INTEGER I,J,IERCOD
47 : C
48 : INTEGER NBNL(4),ICOIN(8),NBLGMX,NBLGMN,NBCOMX,NBCOMN
49 : INTEGER NITNEC,NBRANG,NBCOUC
50 : INTEGER IORDR,ICODE1,ICODE2,ICODE5,INDSO(20),ISENS
51 : INTEGER ITRNO3,NBNO3,NBE3,IDE3,NBN3
52 : INTEGER ITRNO4,NBNO4,NBE4,IDE4,NBN4
53 : INTEGER ITRNO5,NBNO5,NBE5,IDE5
54 : INTEGER ITRTRI,IDEE,NBNMX,NBCMX,NOETRI,ITRAV,NITMX2,NOEMAX
55 : REAL*8 DEN1,DEN2
56 : C
57 : c DO 1111 I=1,50
58 : c WRITE (6,*) I,NOMS(I)
59 : c 1111 CONTINUE
60 : c WRITE(6,*) 'NBCOU = ',NBCOU
61 : C
62 : IERRDS = 0
62 : CALL DSINIT
62 : CALL ELINIT(0)
63 : C ============================
64 : C --- 1.LECTURE DES DENSITES ---
65 : C ============================
66 : IF(DEN1.LT.0)THEN
66 : CALL ERREUR(17)
67 : GOTO 9999
68 : ENDIF
69 : IF(DEN2.LT.0)THEN
69 : CALL ERREUR(17)
70 : GOTO 9999
71 : ENDIF
72 : *
73 : * ============================
74 : * LECTURE DES NUMEROS DES POINTS
75 : * ============================
76 : *
77 : NBANC = XCOOR(/1) /( IDIM+1)
78 : IF((N1.LE.0).OR.(N1.GT.NBANC ))THEN
79 : C WRITE (6,*)'ERREUR IL FAUT UN POINT DE DEPART'
79 : CALL ERREUR(824)
80 : ENDIF
81 : IF((N2.LE.0).OR.(N2.GT.NBANC ))THEN
82 : C WRITE (6,*)'ERREUR IL FAUT UN POINT D ARRIVE'
82 : CALL ERREUR(828)
83 : ENDIF
84 : C ============================
85 : C --- 1.LECTURE DES MAILLAGE 2D ---
86 : C ============================
87 : C
88 : *
89 : * LECTURE DU MAILLAGE 1
90 : * ===========================
90 : IF(IDIM.NE.3) CALL ERREUR(820)
90 : C CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
91 : c WRITE(6,*) ' LECTURE MAILLAGE ' ,IPT1
92 : C IF(IERR.NE.0) RETURN
93 : SEGACT IPT1
93 : IF( IPT1.LISOUS(/1).NE.0) CALL ERREUR(816)
94 : * WRITE(6,*) 'ITYPEL =' , IPT1.ITYPEL
95 : C 8 = QUA4, 10 = QUA8
96 : IORDR = 1
97 : IF( IPT1.ITYPEL.EQ.10 )IORDR = 2
97 : IF((IPT1.ITYPEL.NE.8).AND.(IPT1.ITYPEL.NE.10))CALL ERREUR(823)
98 : * WRITE(6,*) ' IERR ' ,IERR
99 : * WRITE(6,*) ' MCOORD ', MCOORD
100 : IF(IERR.NE.0) THEN
101 : SEGDES IPT1
102 : RETURN
103 : ENDIF
104 : *
105 : *
106 : NBE1 = IPT1.NUM(/2)
107 : *
108 : * LECTURE DU MAILLAGE 2
109 : * ===========================
109 : IF(IDIM.NE.3) CALL ERREUR(820)
109 : C CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
110 : c WRITE(6,*) ' LECTURE MAILLAGE ' ,IPT2
111 : IF(IERR.NE.0) RETURN
112 : SEGACT IPT2
112 : IF( IPT2.LISOUS(/1).NE.0) CALL ERREUR(818)
113 : * WRITE(6,*) 'ITYPEL =' , IPT2.ITYPEL
113 : IF( IPT2.ITYPEL.NE.IPT1.ITYPEL)CALL ERREUR(829)
114 : * WRITE(6,*) ' IERR ' ,IERR
115 : * WRITE(6,*) ' MCOORD ', MCOORD
116 : IF(IERR.NE.0) THEN
117 : SEGDES IPT2
118 : RETURN
119 : ENDIF
120 : C
121 : NBE2 = IPT2.NUM(/2)
122 : NBNMAX = IPT1.NUM(/1)
123 : NBANC = XCOOR(/1) /( IDIM+1)
124 : C
125 : NPOMAX = MAX(50000, NBANC)
126 : NITMAX = MAX((7*NPOMAX), 4*(NBE1+NBE2+NPOMAX))
127 : IF(IORDR.EQ.2)THEN
128 : NITMAX = NITMAX + 8*(NBE1+NBE2)
129 : ENDIF
130 : NRTMAX = 3 * NPOMAX
131 : *
132 : * TRANSFERT DES MAILLAGE
133 : * =====================================
134 : NBNMAX = IPT1.NUM(/1)
135 : NBCMAX = 4
136 : IDE = 2
137 : IDIMC = IDIM
138 : *
139 : * REMPLISSAGE DU TABLEAU DE CONNEXION
140 : * ===================================
141 : ITOTAI= NITMAX
142 : * WRITE(6,*) ' ITOTAI ' , ITOTAI
143 : SEGINI ITRAVX
144 : SEGINI,ICPR,ICPP
145 : ITOTAR = NRTMAX
146 : SEGINI RTRAVX
147 : C
148 : C --- TRANSFERT MAILLAGE --- RTVL, ITVL
149 : C
150 : 10 CONTINUE
151 : ICOORD = 1
152 : ITRNO1 = 1
153 : INO = 0
154 : DO 7764 I=1,NBE1
155 : DO 7764 J=1,NBNMAX
156 : IA = IPT1.NUM(J,I)
157 : IF( ICPR(IA).EQ.0 ) THEN
158 : INO = INO+1
159 : ICPR(IA) = INO
160 : ICPP(INO)= IA
161 : DO 7763 K=1,IDIMC
162 : RTVL((INO-1)*IDIMC+K+ICOORD-1)=
163 : > XCOOR((IA-1)*(IDIM+1)+K)
164 : 7763 CONTINUE
165 : ENDIF
166 : ITVL((I-1)*NBNMAX +J+ITRNO1-1) = ICPR(IA)
167 : 7764 CONTINUE
168 : NBN1 = INO
169 : C
170 : SEGDES IPT1
171 : C
172 : C --- TRANSFERT MAILLAGE --- RTVL, ITVL
173 : C
174 : ITRNO2 = NBE1*NBNMAX+1
175 : DO 7766 I=1,NBE2
176 : DO 7766 J=1,NBNMAX
177 : IA = IPT2.NUM(J,I)
178 : IF( ICPR(IA).EQ.0 ) THEN
179 : INO = INO+1
180 : ICPR(IA) = INO
181 : ICPP(INO)= IA
182 : DO 7765 K=1,IDIMC
183 : RTVL((INO-1)*IDIMC+K+ICOORD-1)=
184 : > XCOOR((IA-1)*(IDIM+1)+K)
185 : 7765 CONTINUE
186 : ENDIF
187 : ITVL((I-1)*NBNMAX +J+ITRNO2-1) = ICPR(IA)
188 : 7766 CONTINUE
189 : C
190 : NBN2 = INO - NBN1
191 : C
192 : SEGDES IPT2
193 : *
194 : C WRITE (6,*) 'MAILLAGE LU : '
195 : C WRITE (6,*) ' NBN1 , NBE1 ',NBN1, NBE1
196 : C WRITE (6,*) ' NBN2 , NBE2 ',NBN2, NBE2
197 :
198 : N1B = ICPR(N1)
199 : N2B = ICPR(N2)
200 : NBCOUC = NBCOU
201 : C
202 : C N2B = NBN1 + 1
203 : C
204 : c WRITE (6,*) 'MAILLAGE 1 NBE1 = ',NBE1
205 : c WRITE (6,*) (ITVL(ITRNO1+I-1),I=1,NBE1*4)
206 : c WRITE (6,*) 'MAILLAGE 2 NBE2 = ',NBE2
207 : c WRITE (6,*) (ITVL(ITRNO2+I-1),I=1,NBE2*4)
208 : c WRITE (6,*) 'COORDONNEES NBCOOR = ',NBN1+NBN2
209 : c WRITE (6,*) (RTVL(ICOORD+I-1),I=1,3*(NBN1+NBN2))
210 : c WRITE (6,*) 'NOEUDS CONNECTE ',N1B,N2B
211 : c WRITE (6,*) 'NOMBRE DE COUCHES = ',NBCOUC
212 : IERRDS = 0
213 : ITRACE = 0
214 : C
215 : C -------------------------
216 : C --- PASSAGE AU LINEAIRE ---
217 : C -------------------------
218 : C
219 : IF(IORDR.EQ.2)THEN
220 : c WRITE(6,*) 'QUADRATIQUE 1'
221 : ITRNO3 = NBNMAX * (NBE1+NBE2) + 1
222 : ICODE1 = 10
223 : ICODE2 = 8
224 : NBNO3 = 4
225 : ISENS = -1
225 : CALL ELSOVO(ICODE1,INDSO,NBSO,NBNO1,IERRDS)
226 : c WRITE(6,*) 'INDSO = ',(INDSO(I),I=1,NBSO)
226 : CALL ELCREE(IDE,ITVL(ITRNO1),NBNMAX,NBE1,
227 : > ICODE2,INDSO,ISENS,IDE3,ITVL(ITRNO3),
228 : > NBNO3,NBE3,IERRDS)
229 : c WRITE(6,*) 'NBNO3,IDE3,IERR = ',NBNO3,IDE3,IERR
230 : c WRITE(6,*)
231 : c > ((ITVL((I-1)*NBNO3+J-1+ITRNO3),J=1,NBNO3)
232 : c > ,'/',I=1,NBE3)
233 : IF( IERRDS.NE.0 )THEN
233 : CALL ESERRO(1,IERRDS,'ESELEC',' APPEL ELCREE')
234 : GOTO 9999
235 : ENDIF
236 : C
237 : ITRNO4 = ITRNO3 + (NBE3 * NBNO3)
238 : NBNO4 = 4
238 : CALL ELCREE(IDE,ITVL(ITRNO2),NBNMAX,NBE2,
239 : > ICODE2,INDSO,ISENS,IDE4,ITVL(ITRNO4),
240 : > NBNO4,NBE4,IERRDS)
241 : c WRITE(6,*) 'NBNO4,IDE4,iIERR = ',NBNO4,IDE4,IERR
242 : c WRITE(6,*)
243 : c > ((ITVL((I-1)*NBNO4+J-1+ITRNO4),J=1,NBNO4)
244 : c > ,'/',I=1,NBE4)
245 : IF( IERRDS.NE.0 )THEN
245 : CALL ESERRO(1,IERRDS,'ESELEC',' APPEL ELCREE')
246 : GOTO 9999
247 : ENDIF
248 :
249 : ELSE
250 : ITRNO3 = ITRNO1
251 : NBE3 = NBE1
252 : ITRNO4 = ITRNO2
253 : NBE4 = NBE2
254 : ICODE1 = 8
255 : ICODE2 = 8
256 : ENDIF
257 : NBN3 = NBN1
258 : NBN4 = NBN2
259 : C
260 : C -------------------------
261 : C --- CALCUL DE LA STRUCTURE ---
262 : C -------------------------
263 : C
264 : NBCOOR = NBN1 + NBN2
265 : NBEMAX = 0
266 : ITRNOE = 1
267 : NBPMAX = 0
268 : ITRAV = ITRNO4 + (NBE4*4)
269 : ITRVMX = NITMAX - ITRAV
270 : NOSUPR = 0
271 : raison=0.d0
272 : C
272 : CALL HEXOS(ITVL(ITRNO3),NBE3,NBN3,ITVL(ITRNO4),NBE4,NBN4,
273 : > RTVL(ICOORD),NBCOOR,
274 : > N1B,N2B,DEN1,DEN2,NBCOUC,
275 : > ITVL(ITRAV),ITRVMX,NOSUPR,
276 : > ITVL(ITRNOE),NBE,NBEMAX,NBPMAX,
277 : > NBNL,ICOIN,ITRACE,IERCOD,IERRDS,raison)
278 : C
279 : c IF(IERRDS.NE.0)
280 : c >WRITE (6,*) 'ERREUR PREMIER APPEL HEXOS',IERRDS
281 : C
282 : C ---- REPRISE SUR MANQUE DE MEMOIRE ----
283 : C
284 : IF( IERRDS.EQ.-2)THEN
285 : IERRDS = 0
286 : ITOTAI = 4*(NBE1+NBE2+NBCOOR)
287 : SEGADJ ITRAVX
288 : GOTO 10
289 : ENDIF
290 : C
291 : C ---- MESSAGES D'ERREUR ----
292 : C
293 : IF( IERRDS.EQ.-1)THEN
294 : IMESS = -IERCOD - 90
294 : CALL MSHEXO('HEXOS ',IMESS,IERRDS,0,0.0,' ')
295 : SEGSUP ITRAVX,RTRAVX,ICPR,ICPP
296 : GOTO 9999
297 : ENDIF
298 : C
299 : C ---- EVALUATION DE LA PLACE NECESSAIRE ----
300 : C
301 : NBLGMX = MAX(NBNL(2),NBNL(4))
302 : NBLGMN = MIN(NBNL(2),NBNL(4))
303 : NBCOMX = MAX(NBNL(1),NBNL(3))
304 : NBCOMN = MIN(NBNL(1),NBNL(3))
305 : NBRANG = NBCOUC+NBLGMX+NBCOMX-NBLGMN-NBCOMN
306 : NITNEC = (NBE1+NBE2)*4 + NBCOOR + NBN1 + NBN2 + MAX( 3*NBCOOR,
307 : > NBCOOR+ 2*(3+NBRANG)*NBCOMX*NBLGMX)
308 : IF(IORDR.EQ.2)THEN
309 : NITNEC = NITNEC + 8*(NBE1+NBE2) +
310 : > (20+8+6)*(NBRANG*NBCOMX*NBLGMX) + 7*NBCOOR
311 : ENDIF
312 : C
313 : IF( ITRACE.GT.0 )THEN
314 : WRITE (6,*) 'PLACE NECESSAIRE POUR LE TRAVAIL :',NITNEC
315 : WRITE (6,*) 'NOMBRE MAXIMUM DE LIGNES : ',NBLGMX
316 : WRITE (6,*) 'NOMBRE MAXIMUM DE COLONNES : ',NBCOMX
317 : WRITE (6,*) 'NOMBRE MAXIMUM DE RANGEES : ',NBRANG
318 : ENDIF
319 : C
320 : ITRNOE = ITRNO4 + (NBE4*4)
321 : NBEMAX = NBRANG*NBCOMX*NBLGMX
322 : ITRAV = ITRNOE + 8*NBEMAX
323 : ITRVMX = NITMAX - ITRAV
324 : NBPMAX = (NRTMAX - (NBCOOR*3)) / 3
325 : NOSUPR = 0
326 : C
327 : C ---- REPRISE SUR MANQUE DE MEMOIRE ----
328 : C
329 : IF( (ITRVMX.LT.NITNEC).OR.
330 : > (NBPMAX.LT.((NBRANG+1)*(NBCOMX+1)*(NBLGMX+1))) )THEN
331 : IERRDS = -2
332 : c WRITE (6,*) 'PLACE NECESSAIRE (ENTIERS): ',
333 : c > (NITNEC+8*NBEMAX)
334 : c WRITE (6,*) 'PLACE NECESSAIRE (REELS) : ',
335 : c > ((NBRANG+1)*(NBCOMX+1)*(NBLGMX+1))
336 : IERDS = 0
337 : ITOTAI = 4*(NBE1+NBE2) + (NITNEC+8*NBEMAX)
338 : SEGADJ ITRAVX
339 : ITOTAR = (NBN1+NBN2)*3 + ((NBRANG+1)*(NBCOMX+1)*(NBLGMX+1))
340 : SEGADJ RTRAVX
341 : GOTO 10
342 : ENDIF
343 : C
343 : CALL HEXOS(ITVL(ITRNO3),NBE3,NBN3,ITVL(ITRNO4),NBE4,NBN4,
344 : > RTVL(ICOORD),NBCOOR,
345 : > N1B,N2B,DEN1,DEN2,NBCOUC,
346 : > ITVL(ITRAV),ITRVMX,NOSUPR,
347 : > ITVL(ITRNOE),NBE,NBEMAX,NBPMAX,
348 : > NBNL,ICOIN,ITRACE,IERCOD,IERRDS,raison)
349 : C
350 : C
351 : C ---- MESSAGES D'ERREUR ----
352 : C
353 : IF( IERRDS.EQ.-1)THEN
354 : IMESS = -IERCOD - 90
354 : CALL MSHEXO('HEXOS ',IMESS,IERRDS,0,0.0,' ')
355 : SEGSUP ITRAVX,RTRAVX,ICPR,ICPP
356 : GOTO 9999
357 : ENDIF
358 : c IF( IERRDS.EQ.-2)THEN
359 : c WRITE (6,*) 'MANQUE DE PLACE : ERREUR ANORMALE'
360 : c ENDIF
361 : C
362 : C -------------------------
363 : C --- PASSAGE AU QUADRATIQUE ---
364 : C -------------------------
365 : C
366 : IF(IORDR.EQ.2)THEN
367 : IDEE = 3
368 : NBNMX5 = 8
369 : NBCMX5 = 6
370 : ITRTRI = ITRNOE + (NBE*NBNMX5)
371 : NOETRI = ITRTRI + (NBE*NBCMX5)
372 : ITRAV = NOETRI + NBCOOR
373 : NITMX2 = NITMAX - ITRAV
374 : c WRITE(6,*) 'NITMX2 = ',NITMX2
375 : NOEMAX = NBCOOR
375 : CALL SMACRE(IDEE,ITVL(ITRNOE),NBE,NBCOOR,
376 : > ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),
377 : > NBCMX5,ITVL(NOETRI),NOEMAX,
378 : > ITVL(ITRAV),NITMX2,IERRDS)
379 : IF( IERRDS.NE.0 )THEN
379 : CALL ESERRO(1,IERRDS,'VOLOS',' APPEL SMACRE')
380 : GOTO 9999
381 : ENDIF
382 : C
383 : C --- INDICE DES SOMMETS ---------------------
384 : C
385 : ICODE5 = 15
385 : CALL ELSOVO(ICODE5,INDSO,NBSO5,NBNO5,IERRDS)
386 : c WRITE(6,*) 'NBNO5 (20) = ',NBNO5
387 : C
388 : C ---- ALLOCATION DE LA MEMOIRE --------------
389 : C
390 : ITRNO5 = ITRAV
391 : ITRAV = ITRNO5 + (NBE * NBNO5)
392 : NITMX2 = NITMAX - ITRAV
393 : C
394 : C ---- CREATION DU MAILLAGE AVEC DES TROUS ---
395 : C
396 : ISENS = 1
396 : CALL ELCREE(IDEE,ITVL(ITRNOE),NBNMX5,NBE,
397 : > ICODE5,INDSO,ISENS,IDE5,ITVL(ITRNO5),
398 : > NBNO5,NBE5,IERRDS)
399 : IF( IERRDS.NE.0 )THEN
399 : CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELCREE')
400 : GOTO 9999
401 : ENDIF
402 : C
403 : C ---- TRANSFERT DES NOEUDS MILIEU --------------
404 : C
405 : c WRITE(6,*) 'AVANT TRANSFERT '
406 : c WRITE(6,*)
407 : c > ((ITVL((I-1)*NBNO5+J-1+ITRNO5),J=1,NBNO5)
408 : c > ,'/',I=1,NBE5)
408 : CALL ELTRNO(ICODE1,IDE1,ITVL(ITRNO1),NBNMAX,NBE1,
409 : > ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),
410 : > NBCMX5,ITVL(NOETRI),NOEMAX,
411 : > ITVL(ITRAV),NITMX2,
412 : > ICODE5,IDE5,ITVL(ITRNO5),NBNO5,NBE5,
413 : > IERRDS)
414 : IF( IERRDS.NE.0 )THEN
414 : CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELTRNO (1)')
415 : GOTO 9999
416 : ENDIF
416 : CALL ELTRNO(ICODE1,IDE2,ITVL(ITRNO2),NBNMAX,NBE2,
417 : > ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),
418 : > NBCMX5,ITVL(NOETRI),NOEMAX,
419 : > ITVL(ITRAV),NITMX2,
420 : > ICODE5,IDE5,ITVL(ITRNO5),NBNO5,NBE5,
421 : > IERRDS)
422 : C
423 : IF( IERRDS.NE.0 )THEN
424 : c WRITE(6,*) 'LE MAILLAGE A TRANSFERER '
425 : c WRITE(6,*)
426 : c > ((ITVL((I-1)*NBNMAX+J-1+ITRNO2),J=1,NBNMAX)
427 : c > ,'/',I=1,NBE2)
428 : c WRITE(6,*) 'LE MAILLAGE TOPOLOGIQUE '
429 : c WRITE(6,*)
430 : c > ((ITVL((I-1)*NBNMX5+J-1+ITRNOE),J=1,NBNMX5)
431 : c > ,'/',I=1,NBE5)
432 : C
432 : CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELTRNO (2)')
433 : GOTO 9999
434 : ENDIF
435 : C
436 : c WRITE(6,*) 'APRES TRANSFERT '
437 : c WRITE(6,*)
438 : c > ((ITVL((I-1)*NBNO5+J-1+ITRNO5),J=1,NBNO5)
439 : c > ,'/',I=1,NBE5)
440 : C
441 : C
442 : C ---- CALCUL DES NOEUDS MILIEU --------------
443 : C
444 : C
444 : CALL ELCCNO(ICODE5,IDE5,ITVL(ITRNO5),NBNO5,NBE5,
445 : > ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),NBCMX5,
446 : > ITVL(ITRAV),NITMX2,
447 : > RTVL(ICOORD),IDIMC,NBCOOR,NBPMAX,IERRDS)
448 : IF( IERRDS.NE.0 )THEN
448 : CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELCCNO')
449 : GOTO 9999
450 : ENDIF
451 : c WRITE(6,*) 'APRES AJOUT NOEUDS '
452 : c WRITE(6,*)
453 : c > ((ITVL((I-1)*NBNO5+J-1+ITRNO5),J=1,NBNO5)
454 : c > ,'/',I=1,NBE5)
455 : ELSE
456 : C -------------------------
457 : C --- ON RESTE EN LINEAIRE ---
458 : C -------------------------
459 : ITRNO5 = ITRNOE
460 : ICODE5 = 14
461 : NBNO5 = 8
462 : NBE5 = NBE
463 : ENDIF
464 : C
465 : *
466 : * REMPLISSAGE NOUVEL OBJET MAILLAGE ET TABLEAU DES COORDONNEES
467 : * ============================================================
468 : C
469 : 40 CONTINUE
470 : c WRITE (6,*) '==== ON SORT ===='
471 : C
472 : C ---- TRANSFERT DES NOUVEAUX NOEUDS ----
473 : C ===============================
474 : *
475 : c WRITE (6,*) 'ECRITURE DES NOEUDS = ',NBCOOR - INO
476 : NBPTS = NBANC + NBCOOR - INO
477 : c WRITE(6,*) ' MCOORD NBCOOR INO ', MCOORD,NBCOOR,INO,NBANC
478 : SEGADJ MCOORD
479 : DO 7781 I=1,NBCOOR-INO
480 : XCOOR((NBANC +I-1)*(IDIM+1)+1) = RTVL((INO+I-1)*IDIMC+1)
481 : XCOOR((NBANC +I-1)*(IDIM+1)+2) = RTVL((INO+I-1)*IDIMC+2)
482 : XCOOR((NBANC +I-1)*(IDIM+1)+3) = RTVL((INO+I-1)*IDIMC+3)
483 : XCOOR((NBANC +I-1)*(IDIM+1)+4) = DENSIT
484 : 7781 CONTINUE
485 : C
486 : C ---- TRANSFERT DES ELEMENTS ----
487 : C ========================
488 : c WRITE (6,*) 'ECRITURE DES ELEMENTS = ',NBE5
489 : c WRITE (6,*) (ITVL(ITRNO5+I-1),I=1,NBE5*NBNO5)
490 : NBNN = NBNO5
491 : NBREF = 0
492 : NBSOUS = 0
493 : NBELEM = NBE5
494 : SEGINI IPT3
495 : C 14 = CUB8, 15 = CU20
496 : IPT3.ITYPEL = ICODE5
497 : DO 7782 I=1,NBE5
498 : DO 7783 J=1,NBNO5
499 : IA=ITVL((I-1)*NBNO5 +J-1+ITRNO5)
500 : C
501 : C ON TESTE SI LE NOEUD EXISTE DEJA POUR RETROUVER LES NUMEROS CASTEM
502 : C
503 : IF ( IA .LE.INO) THEN
504 : IB = ICPP(IA)
505 : ELSE
506 : IB = IA -INO +NBANC
507 : ENDIF
508 : IPT3.NUM(J,I)=IB
509 : 7783 CONTINUE
510 : IPT3.ICOLOR(I) = IDCOUL
511 : 7782 CONTINUE
512 : C
513 : C --- FIN ET ECRITURE ---
514 : C =================
515 : c WRITE (6,*) 'ECRITURE'
515 : CALL ECROBJ('MAILLAGE',IPT3)
516 : c WRITE (6,*) 'DESACTIVATION'
517 : SEGDES IPT3
518 : SEGSUP ITRAVX,RTRAVX,ICPR,ICPP
518 : * CALL ECROBJ('MAILLAGE',IPT3)
519 : C
520 : C
521 : 9999 END
522 :
523 :
524 :
525 :
526 :
527 :
528 :
529 :
© Cast3M 2003 - All rights reserved.
Disclaimer