src/tool/ES_Xfig/ppxma5.F

   1       subroutine ppxma5 ( lgtcmx, tbcoli, ncotbl,
   2      >                    infsup, typcof, typcop, typbor, optnoe,
   3      >                    porpay, zoom, triedr,
   4      >                    degre, sdim, mailet,
   5      >                    titre1, titre2,
   6      >                    nbarvi, nbtrvi, nbquvi,
   7      >                    nnarvi, nntrvi, nnquvi,
   8      >                    coopro, posini,
   9      >                    nnoeca, nareca, ntreca, nqueca,
  10      >                    fotrva, foquva, vafomi, vafoma, vafodi,
  11      >                    ulvecs, nomflo, lnomfl, ulsost,
  12      >                    ulsort, langue, codret )
  13 c ______________________________________________________________________
  14 c
  15 c                             H O M A R D
  16 c
  17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  18 c
  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
  24 c
  25 c    HOMARD est une marque deposee d'Electricite de France
  26 c
  27 c Copyright EDF 1996
  28 c Copyright EDF 1998
  29 c Copyright EDF 2002
  30 c Copyright EDF 2020
  31 c ______________________________________________________________________
  32 c
  33 c     Post-Processeur - format Xfig - MAillage - phase 5
  34 c     -    -                   -      --               -
  35 c voir http://www.xfig.org/userman/fig-format.html
  36 c ______________________________________________________________________
  37 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                  .
  44 c .        .     .        .       -2 : noir                            .
  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                         .
  72 c .        .     .        .   2 : noir                                 .
  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 ______________________________________________________________________
 138 c
 139 c====
 140 c 0. declarations et dimensionnement
 141 c====
 142 c
 143 c 0.1. ==> generalites
 144 c
 145       implicit none
 146       save
 147 c
 148       character*6 nompro
 149       parameter ( nompro = 'PPXMA5' )
 150 c
 151 #include "nblang.h"
 152 #include "nuvers.h"
 153 #include "fracta.h"
 154 #include "fractb.h"
 155 #include "fractc.h"
 156 c
 157 c 0.2. ==> communs
 158 c
 159 #include "envex1.h"
 160 c
 161 #include "gmenti.h"
 162 c
 163 #include "impr02.h"
 164 #include "nombno.h"
 165 #include "nomber.h"
 166 #include "nbutil.h"
 167 #include "infini.h"
 168 c
 169 c 0.3. ==> arguments
 170 c
 171       character*(*) titre1, titre2
 172 c
 173       integer lgtcmx
 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
 186       integer nbface
 187 c
 188       logical zoom
 189 c
 190       double precision coopro(3,-11:nbnoto)
 191       double precision vafomi, vafoma
 192       double precision fotrva(*), foquva(*)
 193       character*(*) nomflo
 194 c
 195       integer ulsort, langue, codret
 196 c
 197 c 0.4. ==> variables locales
 198 c
 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
 204       integer iaux6
 205       integer adtrav
 206       integer tabaux(20)
 207       integer lno(9), lglesn, lenoeu
 208       integer ncotbl
 209       integer lacoul, leremp
 210 c
 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)
 218 c
 219       character*7 saux07
 220       character*8 ntrava
 221       character*9 saux09
 222 c
 223       integer nbmess
 224       parameter ( nbmess = 10 )
 225       character*80 texte(nblang,nbmess)
 226 c
 227 c 0.5. ==> initialisations
 228 c_______________________________________________________________________
 229 c
 230 c====
 231 c 1. Messages
 232 c====
 233 c
 234 #include "impr01.h"
 235 c
 236 #ifdef _DEBUG_HOMARD_
 237       write (ulsort,texte(langue,1)) 'Entree', nompro
 238       call dmflsh (iaux)
 239 #endif
 240 c
 241       texte(1,4) = '(''Fonction sur les '',a)'
 242       texte(1,5) = '(a,'' : min = '',g12.5,'', max = '',g12.5)'
 243 c
 244       texte(2,4) = '(''Function over '',a)'
 245       texte(2,5) = '(a,'' : min = '',g12.5,'', max = '',g12.5)'
 246 c
 247 #include "impr03.h"
 248 c
 249       codret = 0
 250 c
 251 c====
 252 c 2. Prealables
 253 c====
 254 c 2.1. ==> Informations sur les fonctions
 255 c
 256       if ( abs(typcof).ge.6 .and. abs(typcof).le.9 ) then
 257         iaux = 8
 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
 263         endif
 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
 269         endif
 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
 274         endif
 275 #endif
 276       endif
 277 c
 278 c 2.2. ==> Informations supplementaires
 279 c
 280 cgn       ulve = ulvecs
 281 cgn       do 1789 , nbface = 1,nbtrvi
 282 cgn       ulvecs = 20 +nbface
 283       nbface = nbtrvi + nbquvi
 284 c
 285 cgn      print *,infsup
 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
 292         else
 293           infsu3 = 0
 294         endif
 295       else
 296         infsu2 = 0
 297         infsu3 = 0
 298       endif
 299 cgn      print *,'infsu1, infsu2, infsu3 = ', infsu1, infsu2, infsu3
 300 c
 301 c 2.3. ==> Extrema des coordonnees
 302 c
 303       daux1 = vinfpo
 304       daux2 = vinfne
 305       daux3 = vinfpo
 306       daux4 = vinfne
 307 cgn       print texte(langue,5), 'X', daux1, daux2
 308 cgn       print texte(langue,5), 'Y', daux3, daux4
 309 c
 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)))
 318  2311   continue
 319   231 continue
 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
 322 c
 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)
 328           lglesn = 3
 329         else
 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)
 335           lglesn = 4
 336         endif
 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)))
 343  2321   continue
 344   232 continue
 345 c
 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
 348 c
 349       if ( zoom ) then
 350 c
 351         if ( sdim.le.2 ) then
 352           jaux = -3
 353         else
 354           jaux = -7
 355         endif
 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))
 361  2331   continue
 362 cgn        print texte(langue,5), 'apres zoom, X', daux1, daux2
 363 cgn        print texte(langue,5), 'apres zoom, Y', daux3, daux4
 364 c
 365       endif
 366 c
 367       if ( triedr.eq.1 ) then
 368 c
 369         if ( sdim.le.2 ) then
 370           jaux = -10
 371         else
 372           jaux = -11
 373         endif
 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))
 379  2341   continue
 380 cgn        print texte(langue,5), 'apres triedre, X', daux1, daux2
 381 cgn        print texte(langue,5), 'apres triedre, Y', daux3, daux4
 382 c
 383       endif
 384 c
 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
 388 c      rapport de 450.
 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 ...
 395 c
 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
 400           porpay = 1
 401         else
 402           porpay = 2
 403         endif
 404       endif
 405 c
 406 c      On ramene la figure dans le cadre 27x18, selon l'orientation
 407 c      demandee :
 408 c     Portrait :
 409       if ( porpay.eq.1 ) then
 410         if ( (daux2-daux1).lt.1.d-10 ) then
 411           facty = 27.d0 / (daux4-daux3)
 412           factx = facty
 413         elseif ( (daux4-daux3).lt.1.d-10 ) then
 414           factx = 18.d0 / (daux2-daux1)
 415         else
 416           factx = 18.d0 / (daux2-daux1)
 417           facty = 27.d0 / (daux4-daux3)
 418           factx = min(factx,facty)
 419         endif
 420 c     Paysage :
 421       else
 422         if ( (daux2-daux1).lt.1.d-10 ) then
 423           facty = 18.d0 / (daux4-daux3)
 424           factx = facty
 425         elseif ( (daux4-daux3).lt.1.d-10 ) then
 426           factx = 27.d0 / (daux2-daux1)
 427         else
 428           factx = 27.d0 / (daux2-daux1)
 429           facty = 18.d0 / (daux4-daux3)
 430           factx = min(factx,facty)
 431         endif
 432       endif
 433 cgn      print *, 'factx =', factx
 434 cgn      print *, 'facty =', facty
 435 c
 436 c     On termine par le coefficient general
 437 c     Attention : il faut symetriser en Y ... mystere xfig ...
 438 c
 439       factx = 450.d0*factx
 440       facty = -factx
 441 cgn      print *, factx
 442 c
 443 c     On cree un decalage pour que le coin soit en (0,0)
 444 c
 445       decalx = -daux1
 446       decaly = -daux4
 447 c
 448 c====
 449 c 3. impression des en-tetes
 450 c====
 451 c
 452 #ifdef _DEBUG_HOMARD_
 453       write (ulsort,90002) '3. impression des en-tetes ; codret', codret
 454 #endif
 455 c
 456       write(ulvecs,30000) nuvers
 457 c
 458       if ( porpay.eq.1 ) then
 459         saux09 = 'Portrait '
 460       else
 461         saux09 = 'Landscape'
 462       endif
 463       write(ulvecs,30010) saux09
 464       write(ulvecs,30020) nuvers, titre1, titre2
 465       write(ulvecs,30030)
 466       write(ulvecs,30031)
 467      > nomflo(1:lnomfl)//' > '//nomflo(1:lnomfl-3)//'png'
 468 c
 469 c====
 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
 475 c    posini.
 476 c====
 477 c
 478 #ifdef _DEBUG_HOMARD_
 479       write (ulsort,90002) '4. impression des faces ; codret', codret
 480       write (ulsort,90002) 'nbface',nbface
 481 #endif
 482 c
 483       if ( nbface.ne.0 ) then
 484 c
 485       write(ulvecs,31002) nbface
 486 c
 487       dcotbl = dble(ncotbl)
 488 c
 489       do 41 , nuface = 1 , nbface
 490 c
 491 cgn        write (ulsort,90112) 'posini', nuface, posini(nuface)
 492         if ( posini(nuface).le.nbtrvi ) then
 493           nutr = posini(nuface)
 494           nuqu = 0
 495         else
 496           nutr = 0
 497           nuqu = posini(nuface)-nbtrvi
 498         endif
 499 c
 500 c 4.1. ==> couleur de la face
 501 c
 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)
 506 c
 507         if ( abs(typcof).ge.6 .and. abs(typcof).le.9 ) then
 508 c
 509           if ( abs(typcof).le.7 ) then
 510             leremp = 20
 511           else
 512             lacoul = tbcoli(-1)
 513           endif
 514 c
 515           if ( nutr.gt.0 ) then
 516             daux1 = fotrva(nutr)
 517           else
 518             daux1 = foquva(nuqu)
 519           endif
 520 c
 521           if ( daux1.ge.vafoma ) then
 522             if ( abs(typcof).ge.8 ) then
 523               leremp = 0
 524             else
 525               lacoul = tbcoli(ncotbl)
 526             endif
 527           elseif ( daux1.le.vafomi ) then
 528             if ( abs(typcof).ge.8 ) then
 529               leremp = 20
 530             else
 531               lacoul = tbcoli(0)
 532             endif
 533           else
 534             if ( abs(typcof).ge.8 ) then
 535               daux1 = 20.d0 * ( vafoma - daux1 ) * vafodi
 536               leremp = nint(daux1)
 537 cgn              print *,leremp
 538             else
 539               daux1 = dcotbl * ( daux1 -vafomi ) * vafodi
 540               jaux = nint(daux1)
 541               lacoul = tbcoli(jaux)
 542             endif
 543           endif
 544 c
 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,
 550 c           etc
 551 c
 552         elseif ( typcof.ge.2 .and. typcof.le.3 ) then
 553 c
 554           leremp = 20
 555           if ( nutr.gt.0 ) then
 556             if ( nntrvi(6,nutr).gt.lgtcmx ) then
 557               jaux = -2
 558             elseif ( nntrvi(6,nutr).eq.1 ) then
 559               jaux = lgtcmx - 1
 560             else
 561               jaux = nntrvi(6,nutr) - 2
 562             endif
 563           else
 564             if ( nnquvi(7,nuqu).gt.lgtcmx ) then
 565               jaux = -2
 566             elseif ( nnquvi(7,nuqu).eq.1 ) then
 567               jaux = lgtcmx - 1
 568             else
 569               jaux = nnquvi(7,nuqu) - 2
 570             endif
 571           endif
 572           lacoul = tbcoli(jaux)
 573 c
 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,
 578 c           etc
 579 c          noir au dela de la famille 20
 580 c
 581         elseif ( typcof.ge.4 .and. typcof.le.5 ) then
 582 c
 583           lacoul = tbcoli(-1)
 584           if ( nutr.gt.0 ) then
 585             if ( nntrvi(6,nutr).gt.20 ) then
 586               leremp = 0
 587             else
 588               leremp = 21 - nntrvi(6,nutr)
 589             endif
 590           else
 591             if ( nnquvi(7,nuqu).gt.20 ) then
 592               leremp = 0
 593             else
 594               leremp = 21 - nnquvi(7,nuqu)
 595             endif
 596           endif
 597 c
 598 c 10 : niveau de raffinement
 599 c
 600         elseif ( typcof.eq.10 ) then
 601 c
 602           if ( nutr.gt.0 ) then
 603             jaux = nntrvi(1,nutr)
 604           else
 605             jaux = nnquvi(1,nuqu)
 606           endif
 607           lacoul = tbcoli(jaux)
 608           leremp = 20
 609 c
 610 c 1 : opaque
 611 c
 612         elseif ( typcof.eq.1 ) then
 613 c
 614           lacoul = tbcoli(-1)
 615           leremp = 20
 616 c
 617 c 0 : invisible
 618 c
 619         elseif ( typcof.eq.0 .) then
 620 c
 621           lacoul = tbcoli(-1)
 622           leremp = -1
 623 c
 624 c autre : erreur
 625 c
 626         else
 627           codret = 1
 628         endif
 629 c
 630 c 4.2. ==> couleur du perimetre
 631 c            0 : pas de trace
 632 c            2 : noir
 633 c            4 : niveau de la face
 634 c        autre : erreur
 635 c
 636         if ( typcop.eq.0 ) then
 637           kaux = 0
 638         elseif ( typcop.eq.2 ) then
 639           kaux = -2
 640         elseif ( typcop.eq.4 ) then
 641           if ( nutr.gt.0 ) then
 642             kaux = nntrvi(1,nutr)
 643           else
 644             kaux = nnquvi(1,nuqu)
 645           endif
 646         else
 647           codret = 1
 648         endif
 649 c
 650 c 4.3. ==> trace
 651 c
 652         if ( codret.eq.0 ) then
 653 c
 654 c       Les noeuds
 655 c
 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)
 661             lglesn = 4
 662           else
 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)
 668             lglesn = 7
 669           endif
 670         else
 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)
 676             lglesn = 5
 677           else
 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)
 685             lglesn = 9
 686           endif
 687         endif
 688         lno(lglesn) = lno(1)
 689 cgn        write(ulsort,90015) 'face',nuface,' :',
 690 cgn     >                      (lno(lenoeu), lenoeu = 1, lglesn)
 691 c
 692 c       type de polygone : iaux1
 693 c       couleur trait : iaux2
 694 c       couleur remplissage : iaux3
 695 c       profondeur : iaux4
 696 c       remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %)
 697 c       fleche en fin : iaux6
 698 c
 699         if ( nutr.gt.0 ) then
 700           write(ulvecs,33001) 'triangle'
 701         else
 702           write(ulvecs,33001) 'quadrangle'
 703         endif
 704         iaux1 = 3
 705         iaux2 = tbcoli(kaux)
 706         iaux3 = lacoul
 707         if ( nutr.gt.0 ) then
 708           iaux4 = 51
 709         else
 710           iaux4 = 52
 711         endif
 712         iaux5 = leremp
 713         iaux6 = 0
 714         write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5,
 715      >                      iaux6, lglesn
 716 c
 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))))
 720  4131   continue
 721 c
 722         write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 2*lglesn)
 723 c
 724         endif
 725 c
 726    41 continue
 727 c
 728       endif
 729 c
 730 c====
 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
 736 c====
 737 c
 738 #ifdef _DEBUG_HOMARD_
 739       write (ulsort,90002) '5. impression des aretes ; codret', codret
 740       write (ulsort,90002) 'nbarvi', nbarvi
 741 #endif
 742 c
 743       if ( nbarvi.ne.0 ) then
 744 c
 745         write(ulvecs,31001)
 746 cgn        do 1222,iaux=-11,nbnoto
 747 cgn       print 1788,iaux,coopro(1,iaux),coopro(2,iaux)
 748 cgn1222   continue
 749 cgn1788   format(i3,4f12.5)
 750         if ( typbor.gt.0 ) then
 751           laux = 1
 752         else
 753           laux = 0
 754         endif
 755 cgn            print *, laux
 756 cgn            print *, typcof
 757 c
 758         do 5 , jaux = 0 , laux
 759 cgn            print *, 'eeeeeeeeeeeeee',jaux
 760 c
 761           do 51 , iaux = 1 , nbarvi
 762 c
 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
 766 c
 767 cgn            print *, nnarvi(5,iaux)
 768             if ( nnarvi(5,iaux).eq.jaux ) then
 769 c
 770 c             Les noeuds
 771 c
 772               lno(1) = nnarvi(3,iaux)
 773               if ( degre.eq.2 .and. nnarvi(5,iaux).le.1 ) then
 774                 lno(2) = nnarvi(6,iaux)
 775                 lglesn = 3
 776               else
 777                 lglesn = 2
 778               endif
 779               lno(lglesn) = nnarvi(4,iaux)
 780 cgn            print *, (lno(lenoeu),lenoeu = 1, lglesn)
 781 c
 782 c       type de polygone : iaux1
 783 c       couleur trait : iaux2
 784 c       couleur remplissage : iaux3
 785 c       profondeur : iaux4
 786 c       remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %)
 787 c       fleche en fin : iaux6
 788 c
 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)
 793 c
 794               write(ulvecs,33001) 'segment'
 795               iaux1 = 1
 796               if ( jaux.eq.1 ) then
 797                 if ( typbor.eq.1 ) then
 798                   kaux = -2
 799                 else
 800                   kaux = lgtcmx-2
 801                 endif
 802               elseif ( typcof.eq.10 ) then
 803                 kaux = nnarvi(1,iaux)
 804               else
 805                 kaux = -2
 806               endif
 807               iaux2 = tbcoli(kaux)
 808               iaux3 = -1
 809               if ( jaux.eq.1 ) then
 810                 iaux4 = 41
 811               else
 812                 iaux4 = 42
 813               endif
 814               iaux5 = -1
 815               iaux6 = 0
 816 c
 817               write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5,
 818      >                            iaux6, lglesn
 819 c
 820               do 511 , lenoeu = 1, lglesn
 821 cgn          print *, coopro(1,lno(lenoeu)),coopro(2,lno(lenoeu))
 822                 tabaux(2*lenoeu-1) =
 823      >                nint(factx*(decalx+coopro(1,lno(lenoeu))))
 824                 tabaux(2*lenoeu  ) =
 825      >                nint(facty*(decaly+coopro(2,lno(lenoeu))))
 826   511         continue
 827 c
 828               write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 2*lglesn)
 829 c
 830             endif
 831 c
 832    51     continue
 833 c
 834     5   continue
 835 c
 836       endif
 837 cc      if ( codret.ne.1789) return
 838 c
 839 c====
 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
 846 c====
 847 c
 848 #ifdef _DEBUG_HOMARD_
 849       write (ulsort,90002) '6. fenetre de zoom ; codret', codret
 850 #endif
 851 c
 852       if ( zoom ) then
 853 c
 854       write(ulvecs,31004)
 855 c
 856       kaux = lgtcmx
 857       lacoul = tbcoli(kaux)
 858 c
 859       if ( sdim.eq.3 ) then
 860         iaux1 = 3
 861       else
 862         iaux1 = 1
 863       endif
 864 c
 865       do 61 , iaux = 1 , iaux1
 866 c
 867         if ( iaux.eq.1 ) then
 868           noeud2 = 0
 869         else
 870           noeud2 = -4
 871         endif
 872 c
 873         do 611 , jaux = 1 , 4
 874 c
 875           if ( iaux.lt. 3 ) then
 876             noeud1 = noeud2
 877             if ( jaux.eq.4 ) then
 878               noeud2 = noeud1 + 3
 879             else
 880               noeud2 = noeud1 - 1
 881             endif
 882           else
 883             if ( jaux.eq.1 ) then
 884               noeud1 = noeud2
 885             else
 886               noeud1 = noeud1 - 1
 887             endif
 888             noeud2 = noeud1 + 4
 889           endif
 890 c
 891 c       on calcule les abscisses et les ordonnees.
 892 c
 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)))
 897 c
 898 c       type de polygone : iaux1
 899 c       couleur trait : iaux2
 900 c       couleur remplissage : iaux3
 901 c       profondeur : iaux4
 902 c       remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %)
 903 c       fleche en fin : iaux6
 904 c
 905           iaux1 = 1
 906           iaux2 = lacoul
 907           iaux3 = -1
 908           iaux4 = 99
 909           iaux5 = -1
 910           iaux6 = 0
 911 c
 912           write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5,
 913      >                        iaux6, 2
 914           write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 4)
 915 c
 916   611   continue
 917 c
 918    61 continue
 919 c
 920       endif
 921 c
 922 c====
 923 c 7. impression du maillage : le triedre
 924 c          on trace les segments dans l'ordre des pseudo-noeuds :
 925 c          en 2D : O/I ; O/J
 926 c          en 3D : O/I ; O/J ; O/K
 927 c====
 928 c
 929 #ifdef _DEBUG_HOMARD_
 930       write (ulsort,90002) '7. triedre ; codret', codret
 931 #endif
 932 c
 933       if ( triedr.ne.0 ) then
 934 c
 935       write(ulvecs,31005)
 936 c
 937       kaux = -2
 938       lacoul = tbcoli(kaux)
 939 c
 940       if ( sdim.eq.3 ) then
 941         iaux1 = 3
 942       else
 943         iaux1 = 2
 944       endif
 945 c
 946       noeud2 = -8
 947       tabaux(1) = nint(factx*(decalx+coopro(1,noeud2)))
 948       tabaux(2) = nint(facty*(decaly+coopro(2,noeud2)))
 949       lglesn = 2
 950 c
 951       do 71 , iaux = 1 , iaux1
 952 c
 953         if ( iaux.eq.1 ) then
 954           noeud1 = -9
 955 c                   123456789
 956           saux09 = '(x)      '
 957         elseif ( iaux.eq.2 ) then
 958           noeud1 = -10
 959 c                   123456789
 960           saux09 = '(y)      '
 961         else
 962           noeud1 = -11
 963 c                   123456789
 964           saux09 = '(z)      '
 965         endif
 966 c
 967 c       type de polygone : iaux1
 968 c       couleur trait : iaux2
 969 c       couleur remplissage : iaux3
 970 c       profondeur : iaux4
 971 c       remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %)
 972 c       fleche en fin : iaux6
 973 c
 974         iaux1 = 1
 975         iaux2 = lacoul
 976         iaux3 = -1
 977         iaux4 = 98
 978         iaux5 = -1
 979         iaux6 = 1
 980 c
 981         write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5,
 982      >                      iaux6, lglesn
 983         write(ulvecs,32003)
 984 c
 985         tabaux(3) = nint(factx*(decalx+coopro(1,noeud1)))
 986         tabaux(4) = nint(facty*(decaly+coopro(2,noeud1)))
 987 c
 988         write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 2*lglesn)
 989 c
 990         tabaux(5) = nint(factx*(decalx+coopro(1,noeud1)))
 991         tabaux(6) = nint(facty*(decaly+coopro(2,noeud1)))
 992 c
 993 c       couleur texte : iaux1
 994 c       profondeur : iaux2
 995 c       police : iaux3
 996 c       taille : iaux4
 997 c
 998         iaux1 = lacoul
 999         iaux2 = 97
1000         iaux3 = 16
1001         iaux4 = 10
1002         write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4,
1003      >                      tabaux(5), tabaux(6), saux09(1:3)
1004 c
1005    71 continue
1006 c
1007       endif
1008 c
1009 c====
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
1014 c     des faces HOMARD.
1015 c     remarque : dans pcmac1, on s'est arrange pour que les elements
1016 c                externes soient numerotes par dimension decroissante :
1017 c            . les tetraedres
1018 c            . les triangles
1019 c            . les quadrangles
1020 c            . les aretes
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
1024 c====
1025 c
1026 #ifdef _DEBUG_HOMARD_
1027       write (ulsort,90002) '8. affichage suppl faces ; codret', codret
1028 #endif
1029 c
1030       if ( retrto.eq.0 .and. requto.eq.0 ) then
1031         jaux = 0
1032       elseif ( infsu1.ge.3 .and. infsu1.le.4 ) then
1033         jaux = infsu1
1034       elseif ( infsu2.ge.3 .and. infsu2.le.4 ) then
1035         jaux = infsu2
1036       elseif ( infsu3.ge.3 .and. infsu3.le.4 ) then
1037         jaux = infsu3
1038       else
1039         jaux = 0
1040       endif
1041 c
1042       if ( jaux.ne.0 ) then
1043 c
1044       write(ulvecs,31006)
1045 c
1046       kaux = nbhexa + nbtetr
1047       laux = nbhexa + nbtetr + nbtria
1048 c
1049       do 81 , nuface = 1 , nbface
1050 c
1051         if ( posini(nuface).le.nbtrvi ) then
1052           nutr = posini(nuface)
1053           nuqu = 0
1054         else
1055           nutr = 0
1056           nuqu = posini(nuface)-nbtrvi
1057         endif
1058 c
1059         if ( jaux.eq.3 ) then
1060           if ( nutr.gt.0 ) then
1061             saux09(1:1) = 't'
1062             tabaux(3) = nntrvi(2,nutr)
1063           else
1064             saux09(1:1) = 'q'
1065             tabaux(3) = nnquvi(2,nuqu)
1066           endif
1067         else
1068           if ( nutr.gt.0 ) then
1069             saux09(1:1) = 'T'
1070             tabaux(3) = ntreca(nntrvi(2,nutr)) - kaux
1071           else
1072             saux09(1:1) = 'Q'
1073             tabaux(3) = nqueca(nnquvi(2,nuqu)) - laux
1074           endif
1075         endif
1076 c
1077         if ( tabaux(3).ne.0 ) then
1078 c
1079           if ( nutr.gt.0 ) then
1080             lno(1) = nntrvi(3,nutr)
1081             lno(2) = nntrvi(4,nutr)
1082             lno(3) = nntrvi(5,nutr)
1083             lglesn = 3
1084           else
1085             lno(1) = nnquvi(3,nuqu)
1086             lno(2) = nnquvi(4,nuqu)
1087             lno(3) = nnquvi(5,nuqu)
1088             lno(4) = nnquvi(6,nuqu)
1089             lglesn = 4
1090           endif
1091 cgn          write(ulsort,90015) 'face',nuface,' :',
1092 cgn     >                        (lno(lenoeu), lenoeu = 1, lglesn)
1093 c
1094 c         on calcule les abscisses et les ordonnees du centre
1095 c
1096           tabaur(1) = 0.d0
1097           tabaur(2) = 0.d0
1098           do 811 , lenoeu = 1, lglesn
1099             tabaur(1) = tabaur(1) + coopro(1,lno(lenoeu))
1100             tabaur(2) = tabaur(2) + coopro(2,lno(lenoeu))
1101   811     continue
1102 c
1103           if ( nutr.gt.0 ) then
1104             daux = unstr
1105           else
1106             daux = unsqu
1107           endif
1108 c
1109           tabaux(1) = nint( factx*(decalx+tabaur(1)*daux) )
1110           tabaux(2) = nint( facty*(decaly+tabaur(2)*daux) )
1111 c
1112           call utench ( tabaux(3), 'g', iaux6, saux07,
1113      >                  ulsort, langue, codret )
1114           saux09(3:9) = '       '
1115           if ( codret.eq.0 ) then
1116             saux09(2:1+iaux6) = saux07(1:iaux6)
1117           else
1118             iaux6 = 0
1119           endif
1120 c
1121           lacoul = tbcoli(-3)
1122 c
1123 c       couleur texte : iaux1
1124 c       profondeur : iaux2
1125 c       police : iaux3
1126 c       taille : iaux4
1127 c
1128           iaux1 = lacoul
1129           iaux2 = 5
1130           iaux3 = 16
1131           iaux4 = 10
1132           write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4,
1133      >                        tabaux(1), tabaux(2), saux09(1:1+iaux6)
1134 c
1135         endif
1136 c
1137    81 continue
1138 c
1139       endif
1140 c
1141 c====
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
1145 c====
1146 c
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
1152 #endif
1153 c
1154       if ( infsu1.ge.1 .and. infsu1.le.2 ) then
1155         jaux = infsu1
1156       elseif ( infsu2.ge.1 .and. infsu2.le.2 ) then
1157         jaux = infsu2
1158       elseif ( infsu3.ge.1 .and. infsu3.le.2 ) then
1159         jaux = infsu3
1160       else
1161         jaux = 0
1162       endif
1163 c
1164       if ( jaux.ne.0 .or. optnoe.ne.0 ) then
1165 c
1166         write(ulvecs,31007)
1167 c
1168 c 9.1. ==> liste des noeuds a tracer
1169 c
1170         if ( codret.eq.0 ) then
1171         call gmalot ( ntrava, 'entier  ', nbnoto, adtrav, codret )
1172         endif
1173 c
1174         if ( codret.eq.0 ) then
1175 c
1176         iaux1 = adtrav
1177         iaux2 = adtrav + nbnoto - 1
1178         do 911 , iaux = iaux1, iaux2
1179           imem(iaux) = 0
1180   911   continue
1181 c
1182 c les noeuds des aretes
1183 c
1184         do 912 , iaux = 1 , nbarvi
1185           imem(adtrav-1+nnarvi(3,iaux)) = 1
1186           imem(adtrav-1+nnarvi(4,iaux)) = 1
1187   912   continue
1188         if ( degre.eq.2 ) then
1189           do 913 , iaux = 1 , nbarvi
1190             imem(adtrav-1+nnarvi(6,iaux)) = 2
1191   913     continue
1192         endif
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)
1196 cgn 3812   continue
1197 c
1198 c les noeuds des faces
1199 c
1200         if ( degre.eq.1 ) then
1201           iaux1 = 1
1202         else
1203           iaux1 = 2
1204         endif
1205 c
1206         do 914 , laux = 1 , iaux1
1207         do 915 , nuface = 1 , nbface
1208 c
1209           iaux = posini(nuface)
1210 c
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
1219           else
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
1229           endif
1230 c
1231   915   continue
1232   914   continue
1233 c
1234 c les noeuds internes aux faces
1235 c
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
1240 c
1241           do 916 , nuface = 1 , nbface
1242 c
1243             iaux = posini(nuface)
1244 c
1245             if ( iaux.le.nbtrvi ) then
1246 cgn      write(ulsort,90015) 'triangle',iaux,' :',nntrvi(10,iaux)
1247               imem(adtrav-1+nntrvi(10,iaux)) = 4
1248             else
1249 cgn      write(ulsort,90015) 'quadrangle',iaux,' :',nnquvi(12,iaux-nbtrvi)
1250               imem(adtrav-1+nnquvi(12,iaux-nbtrvi)) = 4
1251             endif
1252 cgn          print *,nntrvi(10,iaux)
1253 c
1254   916     continue
1255 c
1256         endif
1257 c
1258         endif
1259 c
1260 c 9.2. ==> affichage
1261 c
1262         if ( codret.eq.0 ) then
1263 c
1264         if ( jaux.eq.1 ) then
1265           saux09(1:1) = 'n'
1266         else
1267           saux09(1:1) = 'N'
1268         endif
1269 c
1270         lacoul = tbcoli(-3)
1271 c
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)
1276 c
1277           if ( imem(adtrav-1+noeud).ne.0 ) then
1278 c
1279             tabaux(1) = nint(factx*(decalx+coopro(1,noeud)))
1280             tabaux(2) = nint(facty*(decaly+coopro(2,noeud)))
1281 c
1282 c           Numero du noeud
1283 c
1284             if ( jaux.ne.0 ) then
1285 c
1286               if ( jaux.eq.1 ) then
1287                 tabaux(3) = noeud
1288               else
1289                 tabaux(3) = nnoeca(noeud)
1290               endif
1291 c
1292               call utench ( tabaux(3), 'g', iaux6, saux07,
1293      >                      ulsort, langue, codret )
1294               saux09(3:9) = '       '
1295               if ( codret.eq.0 ) then
1296                 saux09(2:1+iaux6) = saux07(1:iaux6)
1297               else
1298                 iaux6 = 0
1299               endif
1300 c
1301 c       couleur texte : iaux1
1302 c       profondeur : iaux2
1303 c       police : iaux3
1304 c       taille : iaux4
1305 c
1306               iaux1 = lacoul
1307               iaux2 = 1
1308               iaux3 = 16
1309               iaux4 = 10
1310               write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4,
1311      >                            tabaux(1), tabaux(2),
1312      >                            saux09(1:1+iaux6)
1313 c
1314             endif
1315 c
1316 c           Affichage d'un rond
1317 c
1318             if ( optnoe.ne.0 ) then
1319 c
1320 c       couleur trait : iaux1
1321 c       profondeur : iaux2
1322 c       remplissage : iaux3
1323 c       rayon : iaux4
1324 c
1325               iaux1 = lacoul
1326               iaux2 = 2
1327               if ( optnoe.eq.1 ) then
1328                 iaux3 = -1
1329               else
1330                 iaux3 = 20
1331               endif
1332               iaux4 = 50
1333               write(ulvecs,32012) iaux1, iaux1, iaux2, iaux3,
1334      >                            tabaux(1), tabaux(2),
1335      >                            iaux4, iaux4,
1336      >                            tabaux(1), tabaux(2),
1337      >                            tabaux(1)+iaux4, tabaux(2)
1338 c
1339             endif
1340 c
1341 c
1342           endif
1343 c
1344    92   continue
1345 c
1346         endif
1347 c
1348         if ( codret.eq.0 ) then
1349         call gmlboj ( ntrava, codret )
1350         endif
1351 c
1352       endif
1353 c
1354 c====
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 :
1362 c            . les tetraedres
1363 c            . les triangles
1364 c            . les quadrangles
1365 c            . les aretes
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
1369 c====
1370 c
1371 #ifdef _DEBUG_HOMARD_
1372       write (ulsort,90002) '10. affichage suppl aretes ; codret', codret
1373 #endif
1374 c
1375 cgn      print *,'infsu1, infsu2, infsu3 = ', infsu1, infsu2, infsu3
1376       if ( infsu1.ge.5 .and. infsu1.le.6 ) then
1377         jaux = infsu1
1378       elseif ( infsu2.ge.5 .and. infsu2.le.6 ) then
1379         jaux = infsu2
1380       elseif ( infsu3.ge.5 .and. infsu3.le.6 ) then
1381         jaux = infsu3
1382       else
1383         jaux = 0
1384       endif
1385       if ( jaux.eq.6 .and. rearto.eq.0 ) then
1386         jaux = 0
1387       endif
1388 c
1389       if ( jaux.ne.0 ) then
1390 c
1391       write(ulvecs,31008)
1392 c
1393       if ( infsu1.ge.1 .and. infsu1.le.2 ) then
1394         kaux = infsu1
1395       elseif ( infsu2.ge.1 .and. infsu2.le.2 ) then
1396         kaux = infsu2
1397       elseif ( infsu3.ge.1 .and. infsu3.le.2 ) then
1398         kaux = infsu3
1399       else
1400         kaux = 0
1401       endif
1402 c
1403       do 101 , iaux = 1 , nbarvi
1404 c
1405         if ( jaux.eq.5 ) then
1406           saux09(1:1) = 'a'
1407           tabaux(3) = nnarvi(2,iaux)
1408         else
1409           saux09(1:1) = 'A'
1410           tabaux(3) = nareca(nnarvi(2,iaux))
1411         endif
1412 c
1413         if ( tabaux(3).ne.0 ) then
1414 c
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)
1419 c
1420           tabaux(1) = nint( factx*(decalx+tabaur(1)*unsde) )
1421           tabaux(2) = nint( facty*(decaly+tabaur(2)*unsde) )
1422 c
1423           call utench ( tabaux(3), 'g', iaux6, saux07,
1424      >                  ulsort, langue, codret )
1425           saux09(3:9) = '       '
1426           if ( codret.eq.0 ) then
1427             saux09(2:1+iaux6) = saux07(1:iaux6)
1428           else
1429             iaux6 = 0
1430           endif
1431 c
1432           lacoul = tbcoli(-3)
1433 c
1434 c       couleur texte : iaux1
1435 c       profondeur : iaux2
1436 c       police : iaux3
1437 c       taille : iaux4
1438 c
1439           iaux1 = lacoul
1440           iaux2 = 10
1441           iaux3 = 16
1442           iaux4 = 10
1443           write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4,
1444      >                        tabaux(1), tabaux(2), saux09(1:1+iaux6)
1445 c
1446         endif
1447 c
1448   101 continue
1449 c
1450       endif
1451 c
1452 c===
1453 c 11. formats
1454 c===
1455 #ifdef _DEBUG_HOMARD_
1456       write (ulsort,90002) '11. formats ; codret', codret
1457 #endif
1458 c
1459 30000 format(
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)
1472 30010 format(
1473      >  a9,
1474      >/,'Center',
1475      >/,'Metric',
1476      >/,'A4',
1477      >/,'100.00',
1478      >/,'Single',
1479      >/,'-2')
1480 c  # optional comment    (An optional set of comments may be here,
1481 c           which are associated with the whole figure)
1482 30020 format(
1483      >  '#Creator: HOMARD ',a8,
1484      >/,'#Title:',a,
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)
1489 c             2: upper left)
1490 30030 format(
1491      >  '1200 2')
1492 30031 format(
1493      >  '# fig2dev -L png -D +1,5,10,41,51 -K ',a)
1494 c
1495 31001 format(
1496      >  '# ============',
1497      >/,'# Les segments',
1498      >/,'# ============')
1499 31002 format(
1500      >  '# =======================================',
1501      >/,'# Nombre de polygones traces : ',i10
1502      >/,'# =======================================')
1503 31004 format(
1504      >  '# ==================================',
1505      >/,'# Fenetre de zoom',
1506      >/,'# ==================================')
1507 31005 format(
1508      >  '# ==================================',
1509      >/,'# Triedre',
1510      >/,'# ==================================')
1511 31006 format(
1512      >  '# ==================================',
1513      >/,'# Numeros des faces',
1514      >/,'# ==================================')
1515 31007 format(
1516      >  '# ==================================',
1517      >/,'# Numeros des noeuds',
1518      >/,'# ==================================')
1519 31008 format(
1520      >  '# ==================================',
1521      >/,'# Numeros des segments',
1522      >/,'# ==================================')
1523 c
1524 c  1 : 1: cercle/ellipse 2:polygone
1525 c  2 : Si 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)
1535 c  8 : inutile
1536 c  9 : -1 : pas de remplissage, n: remplissage a 5n%
1537 c 10 : longueur du pointille (reel)
1538 c Si polygone :
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 :
1545 c 11 : toujours 1
1546 c 12 : angle avec axes des x (reel)
1547 c 13 : centre en x
1548 c 14 : centre en y
1549 c 15 : rayon en x
1550 c 16 : rayon en y
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
1555 32001 format(
1556      >'2 ',i2,' 0 1 ',3i3,' -1 ',i2,' 0.000 2 0 -1 ',i2,' 0 ',i2)
1557 32002 format(10i8)
1558 32003 format('1 1 1.00 60.00 120.00')
1559 32011 format(
1560      >'4 0 ',2i3,' -1 ',2i3,' 0.0000 4 135 165 ',2i8,' ',a,'\001')
1561 32012 format(
1562      >'1 3 0 1',3i3,' -1 ',i3,' 0.000  1 0.000 ',8i8)
1563 33001 format('# ',a,i10)
1564 c
1565 c====
1566 c 9. la fin
1567 c====
1568 c
1569       if ( codret.ne.0 ) then
1570 c
1571 #include "envex2.h"
1572 c
1573       write (ulsort,texte(langue,1)) 'Sortie', nompro
1574       write (ulsort,texte(langue,2)) codret
1575 c
1576       endif
1577 c
1578 #ifdef _DEBUG_HOMARD_
1579       write (ulsort,texte(langue,1)) 'Sortie', nompro
1580       call dmflsh (iaux)
1581 #endif
1582 c
1583       end