1 subroutine ppxma5 ( lgtcmx, tbcoli, ncotbl,
2 > infsup, typcof, typcop, typbor, optnoe,
3 > porpay, zoom, triedr,
6 > nbarvi, nbtrvi, nbquvi,
7 > nnarvi, nntrvi, nnquvi,
9 > nnoeca, nareca, ntreca, nqueca,
10 > fotrva, foquva, vafomi, vafoma, vafodi,
11 > ulvecs, nomflo, lnomfl, ulsost,
12 > ulsort, langue, codret )
13 c ______________________________________________________________________
17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
20 c aupres des huissiers de justice Simart et Lavoir a Clamart
21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
22 c aupres des huissiers de justice
23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
25 c HOMARD est une marque deposee d'Electricite de France
31 c ______________________________________________________________________
33 c Post-Processeur - format Xfig - MAillage - phase 5
35 c voir http://www.xfig.org/userman/fig-format.html
36 c ______________________________________________________________________
38 c . nom . e/s . taille . description .
39 c .____________________________________________________________________.
40 c . lgtcmx . e . 1 . longueur maximale de la table de couleur .
41 c . tbcoli . e . . table de couleur .
42 c . . . (-3: . Les immuables sont : .
43 c . . . lgtcmx). -3 : defaut de xfig .
45 c . . . . -1 : blanc .
46 c . . . . lgtcmx-2 : rouge pour les aretes de bord .
47 c . . . . lgtcmx-1 : un gris pale pour les familles .
48 c . . . . libres et le triedre .
49 c . . . . lgtcmx : un vert pale (cadre de zoom) .
50 c . ncotbl . e . 1 . nombre de couleurs dans la table .
51 c . infsup . e . 1 . information supplementaire a afficher .
52 c . . . . 0 : aucune .
53 c . . . . 1 : numero homard des noeuds .
54 c . . . . 2 : numero du calcul des noeuds .
55 c . . . . 3 : numero homard des faces .
56 c . . . . 4 : numero du calcul des faces .
57 c . . . . 5 : numero homard des aretes .
58 c . . . . 6 : numero du calcul des aretes .
59 c . . . . np : choix n et choix p simultanement .
60 c . typcof . e . 1 . type de coloriage des faces .
61 c . . . . 0 : incolore transparent .
62 c . . . . 1 : incolore opaque .
63 c . . . . 2 : famille HOMARD .
64 c . . . . 3 : famille HOMARD, sans orientation .
65 c . . . . 4/5 : idem 2/3, en niveau de gris .
66 c . . . . +-6 : couleur selon un champ, echelle auto..
67 c . . . . +-7 : idem avec echelle fixe .
68 c . . . . +-8/+-9 : idem +-6/+-7, en niveau de gris .
69 c . . . . 10 : niveau .
70 c . typcop . e . 1 . type de coloriage du perimetre des faces .
71 c . . . . 0 : pas de trace .
73 c . . . . 4 : niveau de la face .
74 c . typbor . e . 1 . type d'affichage du bord .
75 c . . . . 0 : pas de trace .
76 c . . . . 1 : trace en rouge .
77 c . . . . 2 : trace en noir .
78 c . optnoe . e . 1 . 0 : rien de special .
79 c . . . . 1 : trace d'un rond vide sur chaque noeud .
80 c . . . . 2 : trace d'un rond plein sur chaque noeud .
81 c . porpay . e . 1 . 0 : portrait/paysage selon la taille .
82 c . . . . 1 : portrait .
83 c . . . . 2 : paysage .
84 c . zoom . e . 1 . vrai ou faux selon zoom ou non .
85 c . triedr . e . 1 . 0 : pas de trace du triedre .
86 c . . . . 1 : trace du triedre .
87 c . degre . e . 1 . degre du maillage .
88 c . sdim . e . 1 . dimension du maillage initial .
89 c . mailet . e . 1 . maillage etendu .
90 c . titre1 . e . char . premiere ligne de titre .
91 c . titre2 . e . char . seconde ligne de titre .
92 c . nbarvi . e . 1 . nombre d'aretes visualisables .
93 c . nbtrvi . e . 1 . nombre triangles visualisables .
94 c . nbquvi . e . 1 . nombre de quadrangles visualisables .
95 c . nnarvi . e .6*nbarvi. numero des aretes a visualiser .
96 c . . . . 1 : niveau de l'arete a afficher .
97 c . . . . 2 : numero HOMARD de l'arete .
98 c . . . . 3, 4 : numero des 2 noeuds .
99 c . . . . 5 : 0, si isolee, 1 si bord .
100 c . . . . 6 : numero de l'eventuel noeud P2 .
101 c . nntrvi . e .10nbtrvi. 1 : niveau du triangle a afficher .
102 c . . . . 2 : numero HOMARD du triangle .
103 c . . . . 3, 4, 5 : numeros des noeuds p1 .
104 c . . . . 6 : famille du triangle .
105 c . . . . 7, 8, 9 : numeros des noeuds p2 .
106 c . . . . 10 : numero du noeud interne .
107 c . nnquvi . e .12nbquvi. 1 : niveau du quadrangle a afficher .
108 c . . . . 2 : numero HOMARD du quadrangle .
109 c . . . . 3, 4, 5, 6 : numeros des noeuds p1 .
110 c . . . . 7 : famille du quadrangle .
111 c . . . . 8, 9, 10, 11 : numeros des noeuds p2 .
112 c . . . . 12 : numero du noeud interne .
113 c . coopro . e . 3* . coordonnees projetees de : .
114 c . . .nbnot+12. le triedre : -8:O ; -9:I ; -10:J ; -11:K .
115 c . . . . la fenetre de zoom : de -7 a 0 en 3D ou .
116 c . . . . de -3 a 0 en 2D .
117 c . . . . les noeuds de 1 a nbnoto .
118 c . posini . aux . nbquvi . tableau auxiliaire de renumerotation des .
119 c . . .+nbtrvi . faces en fonction de l'affichage .
120 c . nnoeca . e . renoto . noeuds en entree dans le calcul .
121 c . nareca . e . rearto . nro des aretes dans le calcul en entree .
122 c . ntreca . e . retrto . nro des triangles dans le calcul en entree .
123 c . nqueca . e . requto . nro des quads dans le calcul en entree .
124 c . fotrva . e . nbtrvi . fonctions triangles : valeur .
125 c . foquva . e . nbquvi . fonctions quadrangles : valeur .
126 c . vafomi . e . 1 . minimum de l'echelle de la fonction .
127 c . vafoma . e . 1 . maximum de l'echelle de la fonction .
128 c . ulvecs . e . 1 . unite logique du fichier PostScript .
129 c . nomflo . e . * . nom local du fichier .
130 c . lnomfl . e . 1 . longueur du nom local du fichier .
131 c . ulsost . e . 1 . unite logique de la sortie standard .
132 c . ulsort . e . 1 . unite logique de la sortie generale .
133 c . langue . e . 1 . langue des messages .
134 c . . . . 1 : francais, 2 : anglais .
135 c . codret . s . 1 . code de retour des modules .
136 c . . . . 0 : pas de probleme .
137 c ______________________________________________________________________
140 c 0. declarations et dimensionnement
143 c 0.1. ==> generalites
149 parameter ( nompro = 'PPXMA5' )
171 character*(*) titre1, titre2
174 integer tbcoli(-3:lgtcmx)
175 integer infsup, typcof, typcop, typbor, optnoe
176 integer porpay, triedr
177 integer ulvecs, lnomfl, ulsost
178 integer nbarvi, nbtrvi, nbquvi
179 integer nnarvi(6,nbarvi)
180 integer nntrvi(10,nbtrvi)
181 integer nnquvi(12,nbquvi)
182 integer posini(nbtrvi+nbquvi)
183 integer nnoeca(renoto)
184 integer nareca(rearto), ntreca(retrto), nqueca(requto)
185 integer degre, sdim, mailet
190 double precision coopro(3,-11:nbnoto)
191 double precision vafomi, vafoma
192 double precision fotrva(*), foquva(*)
195 integer ulsort, langue, codret
197 c 0.4. ==> variables locales
199 integer nuface, nutr, nuqu
200 integer noeud, noeud1, noeud2
201 integer iaux, jaux, kaux, laux
202 integer infsu1, infsu2, infsu3
203 integer iaux1, iaux2, iaux3, iaux4, iaux5
207 integer lno(9), lglesn, lenoeu
209 integer lacoul, leremp
211 double precision vafodi
212 double precision daux
213 double precision daux1, daux2, daux3, daux4
214 double precision dcotbl
215 double precision factx, facty
216 double precision decalx, decaly
217 double precision tabaur(20)
224 parameter ( nbmess = 10 )
225 character*80 texte(nblang,nbmess)
227 c 0.5. ==> initialisations
228 c_______________________________________________________________________
236 #ifdef _DEBUG_HOMARD_
237 write (ulsort,texte(langue,1)) 'Entree', nompro
241 texte(1,4) = '(''Fonction sur les '',a)'
242 texte(1,5) = '(a,'' : min = '',g12.5,'', max = '',g12.5)'
244 texte(2,4) = '(''Function over '',a)'
245 texte(2,5) = '(a,'' : min = '',g12.5,'', max = '',g12.5)'
254 c 2.1. ==> Informations sur les fonctions
256 if ( abs(typcof).ge.6 .and. abs(typcof).le.9 ) then
258 write (ulsort,texte(langue,4)) mess14(langue,3,iaux)
259 write (ulsort,texte(langue,5)) 'Fonction', vafomi, vafoma
260 if ( ulsost.ne.ulsort ) then
261 write (ulsost,texte(langue,4)) mess14(langue,3,iaux)
262 write (ulsost,texte(langue,5)) 'Fonction', vafomi, vafoma
264 c Reajustement pour tenir compte des erreurs d'arrondi aux bornes
265 if ( abs(typcof).eq.6 .or. abs(typcof).eq.8 ) then
266 daux = vafoma - vafomi
267 vafomi = vafomi - daux*1.d-6
268 vafoma = vafoma + daux*1.d-6
270 #ifdef _DEBUG_HOMARD_
271 write (ulsort,texte(langue,5)) 'Fonction', vafomi, vafoma
272 if ( ulsost.ne.ulsort ) then
273 write (ulsost,texte(langue,5)) 'Fonction', vafomi, vafoma
278 c 2.2. ==> Informations supplementaires
281 cgn do 1789 , nbface = 1,nbtrvi
282 cgn ulvecs = 20 +nbface
283 nbface = nbtrvi + nbquvi
286 infsu1 = mod(infsup,10)
287 if ( infsup.ge.10 ) then
288 iaux = ( infsup-infsu1 ) / 10
289 infsu2 = mod(iaux,10)
290 if ( iaux.ge.10 ) then
291 infsu3 = ( iaux-infsu2 ) / 10
299 cgn print *,'infsu1, infsu2, infsu3 = ', infsu1, infsu2, infsu3
301 c 2.3. ==> Extrema des coordonnees
307 cgn print texte(langue,5), 'X', daux1, daux2
308 cgn print texte(langue,5), 'Y', daux3, daux4
310 do 231 , jaux = 1 , nbarvi
311 lno(1) = nnarvi(3,jaux)
312 lno(2) = nnarvi(4,jaux)
313 do 2311 , iaux = 1 , 2
314 daux1 = min(daux1, coopro(1,lno(iaux)))
315 daux2 = max(daux2, coopro(1,lno(iaux)))
316 daux3 = min(daux3, coopro(2,lno(iaux)))
317 daux4 = max(daux4, coopro(2,lno(iaux)))
320 cgn if ( nbarvi.gt.0 ) print texte(langue,5), 'X', daux1, daux2
321 cgn if ( nbarvi.gt.0 ) print texte(langue,5), 'Y', daux3, daux4
323 do 232 , nuface = 1 , nbface
324 if ( nuface.le.nbtrvi ) then
325 lno(1) = nntrvi(3,nuface)
326 lno(2) = nntrvi(4,nuface)
327 lno(3) = nntrvi(5,nuface)
330 nuqu = nuface - nbtrvi
331 lno(1) = nnquvi(3,nuqu)
332 lno(2) = nnquvi(4,nuqu)
333 lno(3) = nnquvi(5,nuqu)
334 lno(4) = nnquvi(5,nuqu)
337 do 2321 , iaux = 1 , lglesn
338 cgn print *,coopro(1,lno(iaux)), coopro(2,lno(iaux))
339 daux1 = min(daux1, coopro(1,lno(iaux)))
340 daux2 = max(daux2, coopro(1,lno(iaux)))
341 daux3 = min(daux3, coopro(2,lno(iaux)))
342 daux4 = max(daux4, coopro(2,lno(iaux)))
346 cgn if ( nuface.gt.0 ) print texte(langue,5), 'X', daux1, daux2
347 cgn if ( nuface.gt.0 ) print texte(langue,5), 'Y', daux3, daux4
351 if ( sdim.le.2 ) then
356 do 2331 , iaux = jaux , 0
357 daux1 = min(daux1, coopro(1,iaux))
358 daux2 = max(daux2, coopro(1,iaux))
359 daux3 = min(daux3, coopro(2,iaux))
360 daux4 = max(daux4, coopro(2,iaux))
362 cgn print texte(langue,5), 'apres zoom, X', daux1, daux2
363 cgn print texte(langue,5), 'apres zoom, Y', daux3, daux4
367 if ( triedr.eq.1 ) then
369 if ( sdim.le.2 ) then
374 do 2341 , iaux = jaux , -8
375 daux1 = min(daux1, coopro(1,iaux))
376 daux2 = max(daux2, coopro(1,iaux))
377 daux3 = min(daux3, coopro(2,iaux))
378 daux4 = max(daux4, coopro(2,iaux))
380 cgn print texte(langue,5), 'apres triedre, X', daux1, daux2
381 cgn print texte(langue,5), 'apres triedre, Y', daux3, daux4
385 c 2.4. ==> Facteur de proportionnalite
386 c Dans Xfig, un rectangle de 27x18 cm, donc imprimable au
387 c format A4, correspond a des coordonnees 12150x8100, soit un
389 c La figure est dans le rectangle :
390 c daux1 <= X <= daux2
391 c daux3 <= Y <= daux4
392 c Si on n'a pas choisi a priori d'orientation de la page, on la
393 c determine en fonction de la taille de la figure.
394 c On privilegie le paysage ...
396 cgn print texte(langue,5), '==> X', daux1, daux2
397 cgn print texte(langue,5), '==> Y', daux3, daux4
398 if ( porpay.eq.0 ) then
399 if ( (daux4-daux3).gt.1.1d0*(daux2-daux1) ) then
406 c On ramene la figure dans le cadre 27x18, selon l'orientation
409 if ( porpay.eq.1 ) then
410 if ( (daux2-daux1).lt.1.d-10 ) then
411 facty = 27.d0 / (daux4-daux3)
413 elseif ( (daux4-daux3).lt.1.d-10 ) then
414 factx = 18.d0 / (daux2-daux1)
416 factx = 18.d0 / (daux2-daux1)
417 facty = 27.d0 / (daux4-daux3)
418 factx = min(factx,facty)
422 if ( (daux2-daux1).lt.1.d-10 ) then
423 facty = 18.d0 / (daux4-daux3)
425 elseif ( (daux4-daux3).lt.1.d-10 ) then
426 factx = 27.d0 / (daux2-daux1)
428 factx = 27.d0 / (daux2-daux1)
429 facty = 18.d0 / (daux4-daux3)
430 factx = min(factx,facty)
433 cgn print *, 'factx =', factx
434 cgn print *, 'facty =', facty
436 c On termine par le coefficient general
437 c Attention : il faut symetriser en Y ... mystere xfig ...
443 c On cree un decalage pour que le coin soit en (0,0)
449 c 3. impression des en-tetes
452 #ifdef _DEBUG_HOMARD_
453 write (ulsort,90002) '3. impression des en-tetes ; codret', codret
456 write(ulvecs,30000) nuvers
458 if ( porpay.eq.1 ) then
463 write(ulvecs,30010) saux09
464 write(ulvecs,30020) nuvers, titre1, titre2
467 > nomflo(1:lnomfl)//' > '//nomflo(1:lnomfl-3)//'png'
470 c 4. impression du maillage : les faces
471 c attention : on doit placer les faces dans l'ordre
472 c d'affichage qui a ete determine par pppma3. Il faut donc
473 c explorer les caracteristiques de chaque face, contenues dans
474 c nntrvi et/ou nnquvi, via l'indirection donnee par le tableau
478 #ifdef _DEBUG_HOMARD_
479 write (ulsort,90002) '4. impression des faces ; codret', codret
480 write (ulsort,90002) 'nbface',nbface
483 if ( nbface.ne.0 ) then
485 write(ulvecs,31002) nbface
487 dcotbl = dble(ncotbl)
489 do 41 , nuface = 1 , nbface
491 cgn write (ulsort,90112) 'posini', nuface, posini(nuface)
492 if ( posini(nuface).le.nbtrvi ) then
493 nutr = posini(nuface)
497 nuqu = posini(nuface)-nbtrvi
500 c 4.1. ==> couleur de la face
502 c de 6 a 9 ou de -9 a -6 : selon les valeurs de la fonction
503 c 6 ou 7 : couleur de bleu a rouge
504 c 8 ou 9 : niveau de gris (de blanc pour les faibles valeurs
505 c a noir pour les grandes)
507 if ( abs(typcof).ge.6 .and. abs(typcof).le.9 ) then
509 if ( abs(typcof).le.7 ) then
515 if ( nutr.gt.0 ) then
521 if ( daux1.ge.vafoma ) then
522 if ( abs(typcof).ge.8 ) then
525 lacoul = tbcoli(ncotbl)
527 elseif ( daux1.le.vafomi ) then
528 if ( abs(typcof).ge.8 ) then
534 if ( abs(typcof).ge.8 ) then
535 daux1 = 20.d0 * ( vafoma - daux1 ) * vafodi
539 daux1 = dcotbl * ( daux1 -vafomi ) * vafodi
541 lacoul = tbcoli(jaux)
545 c 2 : selon la famille, avec orientation
546 c 3 : selon la famille, sans orientation
547 c couleur -1 : famille 1 (les libres)
548 c couleur 0 : famille 2 et celles d'orientation autre,
549 c couleur 1 : famille suivante et celles d'orientation autre,
552 elseif ( typcof.ge.2 .and. typcof.le.3 ) then
555 if ( nutr.gt.0 ) then
556 if ( nntrvi(6,nutr).gt.lgtcmx ) then
558 elseif ( nntrvi(6,nutr).eq.1 ) then
561 jaux = nntrvi(6,nutr) - 2
564 if ( nnquvi(7,nuqu).gt.lgtcmx ) then
566 elseif ( nnquvi(7,nuqu).eq.1 ) then
569 jaux = nnquvi(7,nuqu) - 2
572 lacoul = tbcoli(jaux)
574 c 4 : selon la famille, avec orientation, noir et blanc
575 c 5 : selon la famille, sans orientation, noir et blanc
576 c blanc : famille 1 (les libres)
577 c gris pale : famille 2 et celles d'orientation autre,
579 c noir au dela de la famille 20
581 elseif ( typcof.ge.4 .and. typcof.le.5 ) then
584 if ( nutr.gt.0 ) then
585 if ( nntrvi(6,nutr).gt.20 ) then
588 leremp = 21 - nntrvi(6,nutr)
591 if ( nnquvi(7,nuqu).gt.20 ) then
594 leremp = 21 - nnquvi(7,nuqu)
598 c 10 : niveau de raffinement
600 elseif ( typcof.eq.10 ) then
602 if ( nutr.gt.0 ) then
603 jaux = nntrvi(1,nutr)
605 jaux = nnquvi(1,nuqu)
607 lacoul = tbcoli(jaux)
612 elseif ( typcof.eq.1 ) then
619 elseif ( typcof.eq.0 .) then
630 c 4.2. ==> couleur du perimetre
633 c 4 : niveau de la face
636 if ( typcop.eq.0 ) then
638 elseif ( typcop.eq.2 ) then
640 elseif ( typcop.eq.4 ) then
641 if ( nutr.gt.0 ) then
642 kaux = nntrvi(1,nutr)
644 kaux = nnquvi(1,nuqu)
652 if ( codret.eq.0 ) then
656 if ( nutr.gt.0 ) then
657 lno(1) = nntrvi(3,nutr)
658 if ( degre.eq.1 ) then
659 lno(2) = nntrvi(4,nutr)
660 lno(3) = nntrvi(5,nutr)
663 lno(2) = nntrvi(7,nutr)
664 lno(3) = nntrvi(4,nutr)
665 lno(4) = nntrvi(8,nutr)
666 lno(5) = nntrvi(5,nutr)
667 lno(6) = nntrvi(9,nutr)
671 lno(1) = nnquvi(3,nuqu)
672 if ( degre.eq.1 ) then
673 lno(2) = nnquvi(4,nuqu)
674 lno(3) = nnquvi(5,nuqu)
675 lno(4) = nnquvi(6,nuqu)
678 lno(2) = nnquvi( 8,nuqu)
679 lno(3) = nnquvi( 4,nuqu)
680 lno(4) = nnquvi( 9,nuqu)
681 lno(5) = nnquvi( 5,nuqu)
682 lno(6) = nnquvi(10,nuqu)
683 lno(7) = nnquvi( 6,nuqu)
684 lno(8) = nnquvi(11,nuqu)
689 cgn write(ulsort,90015) 'face',nuface,' :',
690 cgn > (lno(lenoeu), lenoeu = 1, lglesn)
692 c type de polygone : iaux1
693 c couleur trait : iaux2
694 c couleur remplissage : iaux3
696 c remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %)
697 c fleche en fin : iaux6
699 if ( nutr.gt.0 ) then
700 write(ulvecs,33001) 'triangle'
702 write(ulvecs,33001) 'quadrangle'
707 if ( nutr.gt.0 ) then
714 write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5,
717 do 4131 , lenoeu = 1, lglesn
718 tabaux(2*lenoeu-1) =nint(factx*(decalx+coopro(1,lno(lenoeu))))
719 tabaux(2*lenoeu ) =nint(facty*(decaly+coopro(2,lno(lenoeu))))
722 write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 2*lglesn)
731 c 5. impression du maillage : les aretes
732 c Quand les bords sont demandes, il faut les passer en dernier
733 c pour qu'ils soient clairement visibles
734 c En degre 2, il faut decomposer le trace des aretes de bord ou
735 c isolee pour pouvoir visualiser les effets de courbure
738 #ifdef _DEBUG_HOMARD_
739 write (ulsort,90002) '5. impression des aretes ; codret', codret
740 write (ulsort,90002) 'nbarvi', nbarvi
743 if ( nbarvi.ne.0 ) then
746 cgn do 1222,iaux=-11,nbnoto
747 cgn print 1788,iaux,coopro(1,iaux),coopro(2,iaux)
749 cgn1788 format(i3,4f12.5)
750 if ( typbor.gt.0 ) then
758 do 5 , jaux = 0 , laux
759 cgn print *, 'eeeeeeeeeeeeee',jaux
761 do 51 , iaux = 1 , nbarvi
763 c nnarvi(5,iaux) vaut 0 pour une arete isolee, 1 pour un bord, 2 sinon
764 c . 1ere passe de la boucle 5 (jaux=0) : aretes isolees
765 c . 2nde passe (eventuelle) de la boucle 5 : aretes de bord
767 cgn print *, nnarvi(5,iaux)
768 if ( nnarvi(5,iaux).eq.jaux ) then
772 lno(1) = nnarvi(3,iaux)
773 if ( degre.eq.2 .and. nnarvi(5,iaux).le.1 ) then
774 lno(2) = nnarvi(6,iaux)
779 lno(lglesn) = nnarvi(4,iaux)
780 cgn print *, (lno(lenoeu),lenoeu = 1, lglesn)
782 c type de polygone : iaux1
783 c couleur trait : iaux2
784 c couleur remplissage : iaux3
786 c remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %)
787 c fleche en fin : iaux6
789 c si l'arete est un bord et que le coloriage du bord est demande, la
790 c couleur est celle designee par typbor
791 c si les faces ont ete demandees par niveau, on retient le niveau
792 c sinon : defaut (noir)
794 write(ulvecs,33001) 'segment'
796 if ( jaux.eq.1 ) then
797 if ( typbor.eq.1 ) then
802 elseif ( typcof.eq.10 ) then
803 kaux = nnarvi(1,iaux)
809 if ( jaux.eq.1 ) then
817 write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5,
820 do 511 , lenoeu = 1, lglesn
821 cgn print *, coopro(1,lno(lenoeu)),coopro(2,lno(lenoeu))
823 > nint(factx*(decalx+coopro(1,lno(lenoeu))))
825 > nint(facty*(decaly+coopro(2,lno(lenoeu))))
828 write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 2*lglesn)
837 cc if ( codret.ne.1789) return
840 c 6. impression du maillage : la fenetre de zoom
841 c on trace les segments dans l'ordre des pseudo-noeuds :
842 c 0/-1; -1/-2; -2/-3; -3/0
843 c pour le 3D on poursuit avec :
844 c -4/-5; -5/-6; -6/-7; -7/-4
845 c -4/0; -5/-1; -6/-2; -7/-3
848 #ifdef _DEBUG_HOMARD_
849 write (ulsort,90002) '6. fenetre de zoom ; codret', codret
857 lacoul = tbcoli(kaux)
859 if ( sdim.eq.3 ) then
865 do 61 , iaux = 1 , iaux1
867 if ( iaux.eq.1 ) then
873 do 611 , jaux = 1 , 4
875 if ( iaux.lt. 3 ) then
877 if ( jaux.eq.4 ) then
883 if ( jaux.eq.1 ) then
891 c on calcule les abscisses et les ordonnees.
893 tabaux(1) = nint(factx*(decalx+coopro(1,noeud1)))
894 tabaux(2) = nint(facty*(decaly+coopro(2,noeud1)))
895 tabaux(3) = nint(factx*(decalx+coopro(1,noeud2)))
896 tabaux(4) = nint(facty*(decaly+coopro(2,noeud2)))
898 c type de polygone : iaux1
899 c couleur trait : iaux2
900 c couleur remplissage : iaux3
902 c remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %)
903 c fleche en fin : iaux6
912 write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5,
914 write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 4)
923 c 7. impression du maillage : le triedre
924 c on trace les segments dans l'ordre des pseudo-noeuds :
926 c en 3D : O/I ; O/J ; O/K
929 #ifdef _DEBUG_HOMARD_
930 write (ulsort,90002) '7. triedre ; codret', codret
933 if ( triedr.ne.0 ) then
938 lacoul = tbcoli(kaux)
940 if ( sdim.eq.3 ) then
947 tabaux(1) = nint(factx*(decalx+coopro(1,noeud2)))
948 tabaux(2) = nint(facty*(decaly+coopro(2,noeud2)))
951 do 71 , iaux = 1 , iaux1
953 if ( iaux.eq.1 ) then
957 elseif ( iaux.eq.2 ) then
967 c type de polygone : iaux1
968 c couleur trait : iaux2
969 c couleur remplissage : iaux3
971 c remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %)
972 c fleche en fin : iaux6
981 write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5,
985 tabaux(3) = nint(factx*(decalx+coopro(1,noeud1)))
986 tabaux(4) = nint(facty*(decaly+coopro(2,noeud1)))
988 write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 2*lglesn)
990 tabaux(5) = nint(factx*(decalx+coopro(1,noeud1)))
991 tabaux(6) = nint(facty*(decaly+coopro(2,noeud1)))
993 c couleur texte : iaux1
1002 write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4,
1003 > tabaux(5), tabaux(6), saux09(1:3)
1010 c 8. affichage d'informations supplementaires pour les faces
1011 c Attention : c'est fait seulement maintenant pour ne pas etre cache
1012 c par les faces dessinees
1013 c En numerotation du calcul, on supprime les faces qui ne sont que
1015 c remarque : dans pcmac1, on s'est arrange pour que les elements
1016 c externes soient numerotes par dimension decroissante :
1021 c . les mailles-points
1022 c on affichera ici leur numerotation locale au type d'element
1023 c quand il s'agira de numerotation du calcul
1026 #ifdef _DEBUG_HOMARD_
1027 write (ulsort,90002) '8. affichage suppl faces ; codret', codret
1030 if ( retrto.eq.0 .and. requto.eq.0 ) then
1032 elseif ( infsu1.ge.3 .and. infsu1.le.4 ) then
1034 elseif ( infsu2.ge.3 .and. infsu2.le.4 ) then
1036 elseif ( infsu3.ge.3 .and. infsu3.le.4 ) then
1042 if ( jaux.ne.0 ) then
1046 kaux = nbhexa + nbtetr
1047 laux = nbhexa + nbtetr + nbtria
1049 do 81 , nuface = 1 , nbface
1051 if ( posini(nuface).le.nbtrvi ) then
1052 nutr = posini(nuface)
1056 nuqu = posini(nuface)-nbtrvi
1059 if ( jaux.eq.3 ) then
1060 if ( nutr.gt.0 ) then
1062 tabaux(3) = nntrvi(2,nutr)
1065 tabaux(3) = nnquvi(2,nuqu)
1068 if ( nutr.gt.0 ) then
1070 tabaux(3) = ntreca(nntrvi(2,nutr)) - kaux
1073 tabaux(3) = nqueca(nnquvi(2,nuqu)) - laux
1077 if ( tabaux(3).ne.0 ) then
1079 if ( nutr.gt.0 ) then
1080 lno(1) = nntrvi(3,nutr)
1081 lno(2) = nntrvi(4,nutr)
1082 lno(3) = nntrvi(5,nutr)
1085 lno(1) = nnquvi(3,nuqu)
1086 lno(2) = nnquvi(4,nuqu)
1087 lno(3) = nnquvi(5,nuqu)
1088 lno(4) = nnquvi(6,nuqu)
1091 cgn write(ulsort,90015) 'face',nuface,' :',
1092 cgn > (lno(lenoeu), lenoeu = 1, lglesn)
1094 c on calcule les abscisses et les ordonnees du centre
1098 do 811 , lenoeu = 1, lglesn
1099 tabaur(1) = tabaur(1) + coopro(1,lno(lenoeu))
1100 tabaur(2) = tabaur(2) + coopro(2,lno(lenoeu))
1103 if ( nutr.gt.0 ) then
1109 tabaux(1) = nint( factx*(decalx+tabaur(1)*daux) )
1110 tabaux(2) = nint( facty*(decaly+tabaur(2)*daux) )
1112 call utench ( tabaux(3), 'g', iaux6, saux07,
1113 > ulsort, langue, codret )
1115 if ( codret.eq.0 ) then
1116 saux09(2:1+iaux6) = saux07(1:iaux6)
1123 c couleur texte : iaux1
1124 c profondeur : iaux2
1132 write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4,
1133 > tabaux(1), tabaux(2), saux09(1:1+iaux6)
1142 c 9. affichage d'informations supplementaires pour les noeuds
1143 c Attention : c'est fait seulement maintenant pour ne pas etre cache
1144 c par les faces dessinees
1147 #ifdef _DEBUG_HOMARD_
1148 write (ulsort,90002) '9. affichage supp noeuds ; codret', codret
1149 write(ulsort,90002) 'nbtrvi', nbtrvi
1150 write(ulsort,90002) 'nbquvi', nbquvi
1151 write(ulsort,90002) 'nbnoto', nbnoto
1154 if ( infsu1.ge.1 .and. infsu1.le.2 ) then
1156 elseif ( infsu2.ge.1 .and. infsu2.le.2 ) then
1158 elseif ( infsu3.ge.1 .and. infsu3.le.2 ) then
1164 if ( jaux.ne.0 .or. optnoe.ne.0 ) then
1168 c 9.1. ==> liste des noeuds a tracer
1170 if ( codret.eq.0 ) then
1171 call gmalot ( ntrava, 'entier ', nbnoto, adtrav, codret )
1174 if ( codret.eq.0 ) then
1177 iaux2 = adtrav + nbnoto - 1
1178 do 911 , iaux = iaux1, iaux2
1182 c les noeuds des aretes
1184 do 912 , iaux = 1 , nbarvi
1185 imem(adtrav-1+nnarvi(3,iaux)) = 1
1186 imem(adtrav-1+nnarvi(4,iaux)) = 1
1188 if ( degre.eq.2 ) then
1189 do 913 , iaux = 1 , nbarvi
1190 imem(adtrav-1+nnarvi(6,iaux)) = 2
1193 cgn do 3812 , iaux = 1 , nbarvi
1194 cgn write(ulsort,90015) 'arete',iaux,' :',
1195 cgn < nnarvi(3,iaux),nnarvi(6,iaux),nnarvi(4,iaux)
1198 c les noeuds des faces
1200 if ( degre.eq.1 ) then
1206 do 914 , laux = 1 , iaux1
1207 do 915 , nuface = 1 , nbface
1209 iaux = posini(nuface)
1211 if ( iaux.le.nbtrvi ) then
1212 cgn if ( laux.eq.1 ) write(ulsort,90015) 'triangle',iaux,' :',
1213 cgn < nntrvi(4*laux-1,iaux),
1214 cgn < nntrvi(4*laux ,iaux),
1215 cgn < nntrvi(4*laux+1,iaux)
1216 imem(adtrav-1+nntrvi(4*laux-1,iaux)) = laux
1217 imem(adtrav-1+nntrvi(4*laux ,iaux)) = laux
1218 imem(adtrav-1+nntrvi(4*laux+1,iaux)) = laux
1220 cgn if ( laux.eq.1 ) write(ulsort,90015) 'quadrangle',iaux,' :',
1221 cgn < nnquvi(5*laux-2,iaux-nbtrvi),
1222 cgn < nnquvi(5*laux-1,iaux-nbtrvi),
1223 cgn < nnquvi(5*laux ,iaux-nbtrvi),
1224 cgn < nnquvi(5*laux+1,iaux-nbtrvi)
1225 imem(adtrav-1+nnquvi(5*laux-2,iaux-nbtrvi)) = laux
1226 imem(adtrav-1+nnquvi(5*laux-1,iaux-nbtrvi)) = laux
1227 imem(adtrav-1+nnquvi(5*laux ,iaux-nbtrvi)) = laux
1228 imem(adtrav-1+nnquvi(5*laux+1,iaux-nbtrvi)) = laux
1234 c les noeuds internes aux faces
1236 cgn write(ulsort,*) 'les noeuds internes aux faces'
1237 if ( mod(mailet,2).eq.0 .or.
1238 > mod(mailet,3).eq.0 .or.
1239 > mod(mailet,5).eq.0 ) then
1241 do 916 , nuface = 1 , nbface
1243 iaux = posini(nuface)
1245 if ( iaux.le.nbtrvi ) then
1246 cgn write(ulsort,90015) 'triangle',iaux,' :',nntrvi(10,iaux)
1247 imem(adtrav-1+nntrvi(10,iaux)) = 4
1249 cgn write(ulsort,90015) 'quadrangle',iaux,' :',nnquvi(12,iaux-nbtrvi)
1250 imem(adtrav-1+nnquvi(12,iaux-nbtrvi)) = 4
1252 cgn print *,nntrvi(10,iaux)
1260 c 9.2. ==> affichage
1262 if ( codret.eq.0 ) then
1264 if ( jaux.eq.1 ) then
1272 do 92 , noeud = 1 , nbnoto
1273 cgn print 90002,'noeud',noeud,imem(adtrav-1+noeud)
1274 cgn print 1780,coopro(1,noeud),coopro(2,noeud)
1275 cgn 1780 format(2g15.7)
1277 if ( imem(adtrav-1+noeud).ne.0 ) then
1279 tabaux(1) = nint(factx*(decalx+coopro(1,noeud)))
1280 tabaux(2) = nint(facty*(decaly+coopro(2,noeud)))
1284 if ( jaux.ne.0 ) then
1286 if ( jaux.eq.1 ) then
1289 tabaux(3) = nnoeca(noeud)
1292 call utench ( tabaux(3), 'g', iaux6, saux07,
1293 > ulsort, langue, codret )
1295 if ( codret.eq.0 ) then
1296 saux09(2:1+iaux6) = saux07(1:iaux6)
1301 c couleur texte : iaux1
1302 c profondeur : iaux2
1310 write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4,
1311 > tabaux(1), tabaux(2),
1316 c Affichage d'un rond
1318 if ( optnoe.ne.0 ) then
1320 c couleur trait : iaux1
1321 c profondeur : iaux2
1322 c remplissage : iaux3
1327 if ( optnoe.eq.1 ) then
1333 write(ulvecs,32012) iaux1, iaux1, iaux2, iaux3,
1334 > tabaux(1), tabaux(2),
1336 > tabaux(1), tabaux(2),
1337 > tabaux(1)+iaux4, tabaux(2)
1348 if ( codret.eq.0 ) then
1349 call gmlboj ( ntrava, codret )
1355 c 10. Affichage d'informations supplementaires pour les aretes
1356 c Attention : c'est fait seulement maintenant pour ne pas etre cache
1357 c par les faces dessinees
1358 c En numerotation du calcul, on supprime les aretes qui ne sont que
1359 c des aretes HOMARD.
1360 c remarque : dans pcmac1, on s'est arrange pour que les elements
1361 c externes soient numerotes par dimension decroissante :
1366 c . les mailles-points
1367 c on affichera ici leur numerotation locale au type d'element
1368 c quand il s'agira de numerotation du calcul
1371 #ifdef _DEBUG_HOMARD_
1372 write (ulsort,90002) '10. affichage suppl aretes ; codret', codret
1375 cgn print *,'infsu1, infsu2, infsu3 = ', infsu1, infsu2, infsu3
1376 if ( infsu1.ge.5 .and. infsu1.le.6 ) then
1378 elseif ( infsu2.ge.5 .and. infsu2.le.6 ) then
1380 elseif ( infsu3.ge.5 .and. infsu3.le.6 ) then
1385 if ( jaux.eq.6 .and. rearto.eq.0 ) then
1389 if ( jaux.ne.0 ) then
1393 if ( infsu1.ge.1 .and. infsu1.le.2 ) then
1395 elseif ( infsu2.ge.1 .and. infsu2.le.2 ) then
1397 elseif ( infsu3.ge.1 .and. infsu3.le.2 ) then
1403 do 101 , iaux = 1 , nbarvi
1405 if ( jaux.eq.5 ) then
1407 tabaux(3) = nnarvi(2,iaux)
1410 tabaux(3) = nareca(nnarvi(2,iaux))
1413 if ( tabaux(3).ne.0 ) then
1415 noeud1 = nnarvi(3,iaux)
1416 noeud2 = nnarvi(4,iaux)
1417 tabaur(1) = coopro(1,noeud1) + coopro(1,noeud2)
1418 tabaur(2) = coopro(2,noeud1) + coopro(2,noeud2)
1420 tabaux(1) = nint( factx*(decalx+tabaur(1)*unsde) )
1421 tabaux(2) = nint( facty*(decaly+tabaur(2)*unsde) )
1423 call utench ( tabaux(3), 'g', iaux6, saux07,
1424 > ulsort, langue, codret )
1426 if ( codret.eq.0 ) then
1427 saux09(2:1+iaux6) = saux07(1:iaux6)
1434 c couleur texte : iaux1
1435 c profondeur : iaux2
1443 write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4,
1444 > tabaux(1), tabaux(2), saux09(1:1+iaux6)
1455 #ifdef _DEBUG_HOMARD_
1456 write (ulsort,90002) '11. formats ; codret', codret
1460 > '#FIG 3.2 Produced by HOMARD ',a8)
1461 c string orientation ("Landscape" or "Portrait")
1462 c string justification ("Center" or "Flush Left")
1463 c string units ("Metric" or "Inches")
1464 c string papersize ("Letter", "Legal", "Ledger", "Tabloid",
1465 c "A", "B", "C", "D", "E",
1466 c "A4", "A3", "A2", "A1", "A0" and "B5")
1467 c float magnification (export and print magnification, %)
1468 c string multiple-page ("Single" or "multiple" pages)
1469 c int transparent color (color number for transparent color for GIF
1470 c export. -3=background, -2=None, -1=Default,
1471 c 0-31 for standard colors or 32- for user colors)
1480 c # optional comment (An optional set of comments may be here,
1481 c which are associated with the whole figure)
1483 > '#Creator: HOMARD ',a8,
1485 >/,'#CreationDate:',a)
1486 c int resolution: 1200 ppi (standard)
1487 c coord_system (Fig units/inch and coordinate system:
1488 c 1: origin at lower left corner (NOT USED)
1493 > '# fig2dev -L png -D +1,5,10,41,51 -K ',a)
1497 >/,'# Les segments',
1498 >/,'# ============')
1500 > '# =======================================',
1501 >/,'# Nombre de polygones traces : ',i10
1502 >/,'# =======================================')
1504 > '# ==================================',
1505 >/,'# Fenetre de zoom',
1506 >/,'# ==================================')
1508 > '# ==================================',
1510 >/,'# ==================================')
1512 > '# ==================================',
1513 >/,'# Numeros des faces',
1514 >/,'# ==================================')
1516 > '# ==================================',
1517 >/,'# Numeros des noeuds',
1518 >/,'# ==================================')
1520 > '# ==================================',
1521 >/,'# Numeros des segments',
1522 >/,'# ==================================')
1524 c 1 : 1: cercle/ellipse 2:polygone
1526 c 3:courbe fermee (dernier point = premier), 1:courbe ouverte
1527 c Si cercle/ellipse :
1528 c 1:ellipse definie par les rayons 2:par les diametres
1529 c 3:cercle defini par le rayon 4:par le diametre
1530 c 3 : 0: plein, 1: pointille tiret, 2:pointille point
1531 c 4 : epaisseur du trait
1532 c 5 : couleur du trait (-1: defaut (noir), 0: noir, 4: rouge)
1533 c 6 : couleur du remplissage
1534 c 7 : profondeur (0 = devant, 100 = au fond)
1536 c 9 : -1 : pas de remplissage, n: remplissage a 5n%
1537 c 10 : longueur du pointille (reel)
1539 c 11 : type de jonction 0:pointu, 1:arrondi
1540 c 14 : fin de trait : 0, si normal, 1 si fleche
1541 c 15 : debut de trait : 0, si normal, 1 si fleche
1542 c il y a une ligne de plus decrivant la fleche
1543 c 16 (dernier) : nombre de points
1544 c Si cercle/ellipse :
1546 c 12 : angle avec axes des x (reel)
1551 c 17 : 1er point en x = centre en x
1552 c 18 : 1er point en y = centre en y
1553 c 19 : dernier point en x = centre en x + rayon en x
1554 c 20 : dernier point en y = centre en y
1556 >'2 ',i2,' 0 1 ',3i3,' -1 ',i2,' 0.000 2 0 -1 ',i2,' 0 ',i2)
1558 32003 format('1 1 1.00 60.00 120.00')
1560 >'4 0 ',2i3,' -1 ',2i3,' 0.0000 4 135 165 ',2i8,' ',a,'\001')
1562 >'1 3 0 1',3i3,' -1 ',i3,' 0.000 1 0.000 ',8i8)
1563 33001 format('# ',a,i10)
1569 if ( codret.ne.0 ) then
1573 write (ulsort,texte(langue,1)) 'Sortie', nompro
1574 write (ulsort,texte(langue,2)) codret
1578 #ifdef _DEBUG_HOMARD_
1579 write (ulsort,texte(langue,1)) 'Sortie', nompro