1 subroutine vccfnc ( nbfare, cfaare,
5 > nbfme0, numfam, nomfam,
6 > grfmpo, grfmta, grfmtb,
7 > ulsort, langue, codret )
8 c ______________________________________________________________________
12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
15 c aupres des huissiers de justice Simart et Lavoir a Clamart
16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
17 c aupres des huissiers de justice
18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
20 c HOMARD est une marque deposee d'Electricite de France
26 c ______________________________________________________________________
28 c aVant adaptation - Creation des Familles - Non Conforme
30 c ______________________________________________________________________
32 c . nom . e/s . taille . description .
33 c .____________________________________________________________________.
34 c . nbfare . es . 1 . nombre de familles d'aretes .
35 c . cfaare . es . nctfar*. codes des familles des aretes .
36 c . . . nbfare . 1 : famille MED .
37 c . . . . 2 : type de segment .
38 c . . . . 3 : orientation .
39 c . . . . 4 : famille d'orientation inverse .
40 c . . . . 5 : numero de ligne de frontiere .
41 c . . . . > 0 si concernee par le suivi de frontiere.
42 c . . . . <= 0 si non concernee .
43 c . . . . 6 : famille frontiere active/inactive .
44 c . . . . 7 : numero de surface de frontiere .
45 c . . . . + l : appartenance a l'equivalence l .
46 c . nbfqua . e . 1 . nombre de familles de quadrangles .
47 c . cfaqua . e . nctfqu*. codes des familles des quadrangles .
48 c . . . nbfqua . 1 : famille MED .
49 c . . . . 2 : type de quadrangle .
50 c . . . . 3 : numero de surface de frontiere .
51 c . . . . 4 : famille des aretes internes apres raf.
52 c . . . . 5 : famille des triangles de conformite .
53 c . . . . 6 : famille de sf active/inactive .
54 c . . . . + l : appartenance a l'equivalence l .
55 c . nbftri . e . 1 . nombre de familles de triangles .
56 c . cfatri . e . nctftr*. codes des familles des triangles .
57 c . . . nbftrm . 1 : famille MED .
58 c . . . . 2 : type de triangle .
59 c . . . . 3 : numero de surface de frontiere .
60 c . . . . 4 : famille des aretes internes apres raf.
61 c . . . . + l : appartenance a l'equivalence l .
62 c . faminf . e . 1 . famille med des quad de la face inferieure .
63 c . famsup . e . 1 . famille med des quad de la face superieure .
64 c . nbfme0 . e . 1 . nombre initial de familles med .
65 c . numfam . es . nbfmed . numero des familles .
66 c . nomfam . es .10nbfmed. nom des familles .
67 c . grfmpo . s .nbfmed+1. pointeur des groupes des familles .
68 c . grfmta . s .10ngrouc. taille des groupes des familles .
69 c . grfmtb . s .10ngrouc. table des groupes des familles .
70 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
71 c . langue . e . 1 . langue des messages .
72 c . . . . 1 : francais, 2 : anglais .
73 c . codret . es . 1 . code de retour des modules .
74 c . . . . 0 : pas de probleme .
75 c . . . . 1 : probleme .
76 c ______________________________________________________________________
79 c 0. declarations et dimensionnement
82 c 0.1. ==> generalites
88 parameter ( nompro = 'VCCFNC' )
113 integer cfaare(nctfar,nbfarm)
115 integer cfaqua(nctfqu,nbfqum)
117 integer cfatri(nctftr,nbftrm)
119 integer faminf, famsup
121 integer numfam(nbfmed)
122 integer grfmpo(0:nbfmed)
123 integer grfmta(10*ngrouc)
125 character*8 nomfam(10,nbfmed)
126 character*8 grfmtb(10*ngrouc)
128 integer ulsort, langue, codret
130 c 0.4. ==> variables locales
132 integer iaux, jaux, kaux
138 parameter ( nbmess = 10 )
139 character*80 texte(nblang,nbmess)
141 c 0.5. ==> initialisations
142 c ______________________________________________________________________
150 #ifdef _DEBUG_HOMARD_
151 write (ulsort,texte(langue,1)) 'Entree', nompro
155 texte(1,4) = '(a14,'' : nombre de familles HOMARD : '',i8)'
156 texte(1,5) = '(''Ce nombre est superieur au maximum :'',i8)'
157 texte(1,6) = '(''Modifier le programme UTINCG'')'
158 texte(1,7) = '(''. Famille MED supplementaire'',i2,'' :'',i6)'
159 texte(1,8) = '(/,a14,'' : ajout de la famille MED'',i8)'
160 texte(1,9) = '(''Aucun type n''''a ete trouve pour les '',a)'
162 texte(2,4) = '(a14,'' : number of HOMARD families:'',i8)'
163 texte(2,5) = '(''This number is greater than maximum:'',i8)'
164 texte(2,6) = '(''Modify UTINCG program.'')'
165 texte(2,7) = '(''. Additional MED family #'',i2,'':'',i6)'
166 texte(2,8) = '(/,a14,'' : addition of MED family #'',i8)'
167 texte(2,9) = '(''No type was found for the '',a)'
173 #ifdef _DEBUG_HOMARD_
174 write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare
175 if ( nbtria.ne.0 ) then
176 write (ulsort,texte(langue,4)) mess14(langue,4,2), nbftri
178 if ( nbquad.ne.0 ) then
179 write (ulsort,texte(langue,4)) mess14(langue,4,4), nbfqua
185 c 2. On recherche trois nouveaux numeros de famille MED
187 c 2.1. ==> on cherche le minimum entre tous les numeros de familles MED
188 c deja existant et ceux des faces inf/sup
190 iaux = min (faminf, famsup)
192 do 21 , jaux = 1 , nbfmed-3
194 iaux = min (iaux,numfam(jaux))
202 #ifdef _DEBUG_HOMARD_
203 write (ulsort,texte(langue,7)) 1, nufamd(1)
204 write (ulsort,texte(langue,7)) 2, nufamd(2)
205 write (ulsort,texte(langue,7)) 3, nufamd(3)
209 c 3. On ajoute deux nouvelles familles d'aretes
212 #ifdef _DEBUG_HOMARD_
213 write (ulsort,90002) '3. Ajout fam. aretes ; codret', codret
216 c 3.1. ==> a priori, aucune caracteristique particuliere
218 do 31 , iaux = 1 , nctfar
219 cfaare(iaux,nbfare+1) = 0
220 cfaare(iaux,nbfare+2) = 0
223 c 3.2. ==> La famille MED
225 cfaare(cofamd,nbfare+1) = nufamd(1)
226 cfaare(cofamd,nbfare+2) = nufamd(1)
228 c 3.3. ==> le type des elements est le meme que celui d'une
230 c si aucun n'est trouve, on l'impose
234 do 33 , iaux = 1 , nbfare
236 if ( cfaare(cotyel,iaux).ne.0 ) then
237 kaux = cfaare(cotyel,iaux)
243 #ifdef _DEBUG_HOMARD_
244 write (ulsort,texte(langue,9)) mess14(langue,3,1)
247 if ( degre.eq.1 ) then
255 #ifdef _DEBUG_HOMARD_
256 write (ulsort,90002) 'Type des '//mess14(langue,3,1), kaux
259 cfaare(cotyel,nbfare+1) = kaux
260 cfaare(cotyel,nbfare+2) = kaux
262 c 3.4. ==> les orientations
264 cfaare(coorfa,nbfare+1) = 1
265 cfaare(coorfa,nbfare+2) = -1
267 cfaare(cofifa,nbfare+1) = nbfare+2
268 cfaare(cofifa,nbfare+2) = nbfare+1
270 c 3.5. ==> total des familles
274 #ifdef _DEBUG_HOMARD_
275 write (ulsort,texte(langue,8)) mess14(langue,4,1), nufamd(1)
276 write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare
279 if ( nbfare.gt.nbfarm ) then
280 write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare
281 write (ulsort,texte(langue,5)) nbfarm
282 write (ulsort,texte(langue,6))
287 c 4. On ajoute une nouvelle famille de quadrangles
290 #ifdef _DEBUG_HOMARD_
291 write (ulsort,90002) '4. Ajout fam. quadrangles ; codret', codret
294 if ( nbquad.ne.0 .or. nbhexa.ne.0 .or. nbpent.ne.0 ) then
296 c 4.1. ==> a priori, aucune caracteristique particuliere
298 do 41 , iaux = 1 , nctfqu
299 cfaqua(iaux,nbfqua+1) = 0
302 c 4.2. ==> La famille MED
304 cfaqua(cofamd,nbfqua+1) = nufamd(2)
306 c 4.3. ==> le type des elements est le meme que celui d'une
308 c si aucun n'est trouve, on l'impose
312 do 43 , iaux = 1 , nbfqua
314 if ( cfaqua(cotyel,iaux).ne.0 ) then
315 kaux = cfaqua(cotyel,iaux)
321 #ifdef _DEBUG_HOMARD_
322 write (ulsort,texte(langue,9)) mess14(langue,3,4)
325 if ( degre.eq.1 ) then
333 #ifdef _DEBUG_HOMARD_
334 write (ulsort,90002) 'Type des '//mess14(langue,3,4), kaux
337 cfaqua(cotyel,nbfqua+1) = kaux
339 c 4.4. ==> la famille des aretes tracees : la famille libre
341 cfaqua(cofafa,nbfqua+1) = 1
343 c 4.5. ==> total des familles
347 #ifdef _DEBUG_HOMARD_
348 write (ulsort,texte(langue,8)) mess14(langue,4,4), nufamd(2)
349 write (ulsort,texte(langue,4)) mess14(langue,4,4), nbfqua
352 if ( nbfqua.gt.nbfqum ) then
353 write (ulsort,texte(langue,4)) mess14(langue,4,4), nbfqua
354 write (ulsort,texte(langue,5)) nbfqum
355 write (ulsort,texte(langue,6))
362 c 5. On ajoute une nouvelle famille de triangles
365 #ifdef _DEBUG_HOMARD_
366 write (ulsort,90002) '5. Ajout fam. triangles; codret', codret
369 if ( nbtria.ne.0 .or. nbtetr.ne.0 .or. nbpent.ne.0 ) then
371 c 5.1. ==> a priori, aucune caracteristique particuliere
373 do 51 , iaux = 1 , nctftr
374 cfatri(iaux,nbftri+1) = 0
377 c 5.2. ==> La famille MED
379 cfatri(cofamd,nbftri+1) = nufamd(3)
381 c 5.3. ==> le type des elements est le meme que celui d'une
383 c si aucun n'est trouve, on l'impose
387 do 53 , iaux = 1 , nbftri
389 if ( cfatri(cotyel,iaux).ne.0 ) then
390 kaux = cfatri(cotyel,iaux)
396 #ifdef _DEBUG_HOMARD_
397 write (ulsort,texte(langue,9)) mess14(langue,3,2)
400 if ( degre.eq.1 ) then
408 #ifdef _DEBUG_HOMARD_
409 write (ulsort,90002) 'Type des '//mess14(langue,3,2), kaux
412 cfatri(cotyel,nbftri+1) = kaux
414 c 5.4. ==> la famille des aretes tracees : la famille libre
416 cfatri(cofafa,nbftri+1) = 1
418 c 5.5. ==> total des familles
422 #ifdef _DEBUG_HOMARD_
423 write (ulsort,texte(langue,8)) mess14(langue,4,2), nufamd(3)
424 write (ulsort,texte(langue,4)) mess14(langue,4,2), nbftri
427 if ( nbftri.gt.nbftrm ) then
428 write (ulsort,texte(langue,4)) mess14(langue,4,2), nbftri
429 write (ulsort,texte(langue,5)) nbftrm
430 write (ulsort,texte(langue,6))
437 c 6. modification des structures des familles MED
440 #ifdef _DEBUG_HOMARD_
441 write (ulsort,90002) '6. modification ; codret', codret
444 if ( codret.eq.0 ) then
448 if ( codret.eq.0 ) then
452 do 611 , kaux = 1 , 10
453 nomfam(kaux,jaux) = blan08
456 numfam(jaux) = nufamd(iaux)
457 call utench ( nufamd(iaux), '_', kaux, saux08,
458 > ulsort, langue, codret )
460 nomfam(1,jaux) = 'HOMARD__'
461 nomfam(2,jaux)(1:kaux) = saux08(1:kaux)
463 c un groupe dont le nom est 'HOMARD', mais que l'on astreint a
464 c une longueur totale de 80 caracteres pour etre coherent avec MED
466 grfmpo(jaux) = grfmpo(jaux-1) + 10
467 do 610 , kaux = grfmpo(jaux-1)+1 , grfmpo(jaux)
469 grfmtb(kaux) = blan08
472 grfmtb(grfmpo(jaux-1)+1) = 'HOMARD '
484 if ( codret.ne.0 ) then
488 write (ulsort,texte(langue,1)) 'Sortie', nompro
489 write (ulsort,texte(langue,2)) codret
493 #ifdef _DEBUG_HOMARD_
494 write (ulsort,texte(langue,1)) 'Sortie', nompro