src/tool/ES_Xfig/pppxma.F

   1       subroutine pppxma ( infsup, typcof, typcop, typbor, optnoe,
   2      >                    porpay, zoom, triedr,
   3      >                    degre, sdim, mailet, nivsup,
   4      >                    titre1, titre2,
   5      >                    nbarvi, nbtrvi, nbquvi,
   6      >                    nnarvi, nntrvi, nnquvi,
   7      >                    coopro, posini,
   8      >                    nnoeca, nareca, ntreca, nqueca,
   9      >                    fotrva, foquva, vafomi, vafoma,
  10      >                    ulvecs, nomflo, lnomfl, ulsost,
  11      >                    ulsort, langue, codret )
  12 c ______________________________________________________________________
  13 c
  14 c                             H O M A R D
  15 c
  16 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  17 c
  18 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  19 c aupres des huissiers de justice Simart et Lavoir a Clamart
  20 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  21 c aupres des huissiers de justice
  22 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  23 c
  24 c    HOMARD est une marque deposee d'Electricite de France
  25 c
  26 c Copyright EDF 1996
  27 c Copyright EDF 1998
  28 c Copyright EDF 2002
  29 c Copyright EDF 2020
  30 c ______________________________________________________________________
  31 c
  32 c     Post-Processeur - format Xfig - MAillage
  33 c     -    -                   -      --
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . infsup . e   .   1    . information supplementaire a afficher      .
  39 c .        .     .        . 0 : aucune                                 .
  40 c .        .     .        . 1 : numero homard des noeuds               .
  41 c .        .     .        . 2 : numero du calcul des noeuds            .
  42 c .        .     .        . 3 : numero homard des faces                .
  43 c .        .     .        . 4 : numero du calcul des faces             .
  44 c .        .     .        . 5 : numero homard des aretes               .
  45 c .        .     .        . 6 : numero du calcul des aretes            .
  46 c .        .     .        . np : choix n et choix p simultanement      .
  47 c . typcof . e   .   1    . type de coloriage des faces                .
  48 c .        .     .        .   0 : incolore transparent                 .
  49 c .        .     .        .   1 : incolore opaque                      .
  50 c .        .     .        .   2 : famille HOMARD                       .
  51 c .        .     .        .   3 : famille HOMARD, sans orientation     .
  52 c .        .     .        .   4/5 : idem 2/3, en niveau de gris        .
  53 c .        .     .        . +-6 : couleur selon un champ, echelle auto..
  54 c .        .     .        . +-7 : idem avec echelle fixe               .
  55 c .        .     .        . +-8/+-9 : idem +-6/+-7, en niveau de gris  .
  56 c .        .     .        .  10 : niveau                               .
  57 c . typcop . e   .   1    . type de coloriage du perimetre des faces   .
  58 c .        .     .        .   0 : pas de trace                         .
  59 c .        .     .        .   2 : noir                                 .
  60 c .        .     .        .   4 : niveau de la face                    .
  61 c . typbor . e   .   1    . type d'affichage du bord                   .
  62 c .        .     .        .   0 : pas de trace                         .
  63 c .        .     .        .   1 : trace en rouge                       .
  64 c .        .     .        .   2 : trace en noir                        .
  65 c . optnoe . e   .   1    . 0 : rien de special                        .
  66 c .        .     .        . 1 : trace d'un rond vide sur chaque noeud  .
  67 c .        .     .        . 2 : trace d'un rond plein sur chaque noeud .
  68 c . porpay . e   .   1    . 0 : portrait/paysage selon la taille       .
  69 c .        .     .        . 1 : portrait                               .
  70 c .        .     .        . 2 : paysage                                .
  71 c . zoom   . e   .   1    . vrai ou faux selon zoom ou non             .
  72 c . triedr . e   .   1    . 0 : pas de trace du triedre                .
  73 c .        .     .        . 1 : trace du triedre                       .
  74 c . degre  . e   .   1    . degre du maillage                          .
  75 c . sdim   . e   .   1    . dimension du maillage initial              .
  76 c . mailet . e   .   1    . maillage etendu                            .
  77 c . nivsup . e   .   1    . niveau superieur atteint dans le maillage  .
  78 c . titre1 . e   .  char  . premiere ligne de titre                    .
  79 c . titre2 . e   .  char  . seconde ligne de titre                     .
  80 c . nbarvi . e   .   1    . nombre d'aretes visualisables              .
  81 c . nbtrvi . e   .   1    . nombre triangles visualisables             .
  82 c . nbquvi . e   .   1    . nombre de quadrangles visualisables        .
  83 c . nnarvi . e   .6*nbarvi. numero des aretes a visualiser             .
  84 c .        .     .        . 1 : niveau de l'arete a afficher           .
  85 c .        .     .        . 2 : numero HOMARD de l'arete               .
  86 c .        .     .        . 3, 4 : numero des 2 noeuds                 .
  87 c .        .     .        . 5 : 0, si isolee, 1 si bord                .
  88 c .        .     .        . 6 : numero de l'eventuel noeud P2          .
  89 c . nntrvi . e   .10nbtrvi. 1 : niveau du triangle a afficher          .
  90 c .        .     .        . 2 : numero HOMARD du triangle              .
  91 c .        .     .        . 3, 4, 5 : numeros des noeuds p1            .
  92 c .        .     .        . 6 : famille du triangle                    .
  93 c .        .     .        . 7, 8, 9 : numeros des noeuds p2            .
  94 c .        .     .        . 10 : numero du noeud interne               .
  95 c . nnquvi . e   .12nbquvi. 1 : niveau du quadrangle a afficher        .
  96 c .        .     .        . 2 : numero HOMARD du quadrangle            .
  97 c .        .     .        . 3, 4, 5, 6 : numeros des noeuds p1         .
  98 c .        .     .        . 7 : famille du quadrangle                  .
  99 c .        .     .        . 8, 9, 10, 11 : numeros des noeuds p2       .
 100 c .        .     .        . 12 : numero du noeud interne               .
 101 c . coopro . e   .    3*  . coordonnees projetees de :                 .
 102 c .        .     .nbnot+12. le triedre : -8:O ; -9:I ; -10:J ; -11:K   .
 103 c .        .     .        . la fenetre de zoom : de -7 a 0 en 3D ou    .
 104 c .        .     .        .                      de -3 a 0 en 2D       .
 105 c .        .     .        . les noeuds de 1 a nbnoto                   .
 106 c . posini . aux . nbquvi . tableau auxiliaire de renumerotation des   .
 107 c .        .     .+nbtrvi . faces en fonction de l'affichage           .
 108 c . nnoeca . e   . renoto . noeuds en entree dans le calcul            .
 109 c . nareca . e   . rearto . nro des aretes dans le calcul en entree    .
 110 c . ntreca . e   . retrto . nro des triangles dans le calcul en entree .
 111 c . nqueca . e   . requto . nro des quads dans le calcul en entree     .
 112 c . fotrva . e   . nbtrvi . fonctions triangles : valeur               .
 113 c . foquva . e   . nbquvi . fonctions quadrangles : valeur             .
 114 c . vafomi . e   .   1    . minimum de l'echelle de la fonction        .
 115 c . vafoma . e   .   1    . maximum de l'echelle de la fonction        .
 116 c . ulvecs . e   .   1    . unite logique du fichier PostScript        .
 117 c . nomflo . e   .   *    . nom local du fichier                       .
 118 c . lnomfl . e   .    1   . longueur du nom local du fichier           .
 119 c . ulsost . e   .   1    . unite logique de la sortie standard        .
 120 c . ulsort . e   .   1    . unite logique de la sortie generale        .
 121 c . langue . e   .    1   . langue des messages                        .
 122 c .        .     .        . 1 : francais, 2 : anglais                  .
 123 c . codret .  s  .    1   . code de retour des modules                 .
 124 c .        .     .        . 0 : pas de probleme                        .
 125 c ______________________________________________________________________
 126 c
 127 c====
 128 c 0. declarations et dimensionnement
 129 c====
 130 c
 131 c 0.1. ==> generalites
 132 c
 133       implicit none
 134       save
 135 c
 136       character*6 nompro
 137       parameter ( nompro = 'PPPXMA' )
 138 c
 139 #include "nblang.h"
 140 c
 141 c 0.2. ==> communs
 142 c
 143 #include "envex1.h"
 144 c
 145 #include "gmenti.h"
 146 #include "gmreel.h"
 147 c
 148 #include "nombno.h"
 149 #include "nomber.h"
 150 #include "infini.h"
 151 c
 152 c 0.3. ==> arguments
 153 c
 154       character*(*) titre1, titre2
 155 c
 156       integer infsup, typcof, typcop, typbor, optnoe
 157       integer porpay, triedr
 158       integer ulvecs, lnomfl, ulsost
 159       integer nbarvi, nbtrvi, nbquvi
 160       integer nnarvi(5,nbarvi)
 161       integer nntrvi(10,nbtrvi)
 162       integer nnquvi(12,nbquvi)
 163       integer posini(nbtrvi+nbquvi)
 164       integer nnoeca(renoto)
 165       integer nareca(rearto), ntreca(retrto), nqueca(requto)
 166       integer degre, sdim, mailet, nivsup
 167 c
 168       integer codre1, codre2
 169       integer codre0
 170 c
 171       logical zoom
 172 c
 173       double precision coopro(3,-11:nbnoto)
 174       double precision vafomi, vafoma
 175       double precision fotrva(*), foquva(*)
 176       character*(*) nomflo
 177 c
 178       integer ulsort, langue, codret
 179 c
 180 c 0.4. ==> variables locales
 181 c
 182       integer lgtcmx
 183       parameter ( lgtcmx = 500 )
 184 c
 185       integer iaux
 186       integer ncotbl
 187       integer ptrav1, ptrav2
 188       integer tbcoli(-3:lgtcmx)
 189 c
 190       double precision vafodi
 191 c
 192       character*8 ntrav1, ntrav2
 193       character*17 tbcols(-2:lgtcmx)
 194 c
 195       integer nbmess
 196       parameter ( nbmess = 10 )
 197       character*80 texte(nblang,nbmess)
 198 c
 199 c 0.5. ==> initialisations
 200 c_______________________________________________________________________
 201 c
 202 c====
 203 c 1. initialisations
 204 c====
 205 c
 206 #include "impr01.h"
 207 c
 208 #ifdef _DEBUG_HOMARD_
 209       write (ulsort,texte(langue,1)) 'Entree', nompro
 210       call dmflsh (iaux)
 211 #endif
 212 c
 213       texte(1,10) = '(''Apres pp.ma'',i1,'', codret = '',i4)'
 214 c
 215       texte(2,10) = '(''After pp.ma'',i1,'', codret = '',i4)'
 216 c
 217 #include "impr03.h"
 218 c
 219 #ifdef _DEBUG_HOMARD_
 220       write (ulsort,90002) 'infsup', infsup
 221       write (ulsort,90002) 'typcof', typcof
 222       write (ulsort,90002) 'typcop', typcop
 223       write (ulsort,90002) 'typbor', typbor
 224       write (ulsort,90002) 'optnoe', optnoe
 225       write (ulsort,90002) 'porpay', porpay
 226       write (ulsort,90002) 'triedr', triedr
 227 #endif
 228 c
 229       codret = 0
 230 c
 231 c====
 232 c 2. la table de couleurs
 233 c====
 234 #ifdef _DEBUG_HOMARD_
 235       write (ulsort,90002) '2. table des couleurs ; codret', codret
 236 #endif
 237 c
 238       if ( codret.eq.0 ) then
 239 c
 240 #ifdef _DEBUG_HOMARD_
 241       write (ulsort,texte(langue,3)) 'PPPMA1', nompro
 242 #endif
 243       call pppma1 ( typcof,
 244      >              lgtcmx, tbcols, tbcoli, ncotbl,
 245      >              nbtrvi, nbquvi,
 246      >              nntrvi, nnquvi,
 247      >              ulsort, langue, codret )
 248 c
 249 #ifdef _DEBUG_HOMARD_
 250       write (ulsort,texte(langue,10)) 1, codret
 251 #endif
 252 c
 253       endif
 254 c
 255 c====
 256 c 3. recherche des extrema de la fonction
 257 c====
 258 #ifdef _DEBUG_HOMARD_
 259       write (ulsort,90002) '3. extrema ; codret', codret
 260 #endif
 261 c
 262       if ( codret.eq.0 ) then
 263 c
 264       if ( abs(typcof).eq.6 .or. abs(typcof).eq.8 ) then
 265 c
 266 #ifdef _DEBUG_HOMARD_
 267       write (ulsort,texte(langue,3)) 'PPPMA2', nompro
 268 #endif
 269         call pppma2 ( vafomi, vafoma,
 270      >                typcof, nbtrvi, nbquvi,
 271      >                fotrva, foquva,
 272      >                ulsost,
 273      >                ulsort, langue, codret )
 274 c
 275 #ifdef _DEBUG_HOMARD_
 276         write (ulsort,texte(langue,10)) 2, codret
 277 #endif
 278 c
 279       endif
 280 c
 281 c     remarque : si l'ecart est nul, il faut eviter la division par 0
 282 c                on peut mettre n'importe quelle valeur pour vafodi
 283 c                car elle ne servira pas
 284       if ( abs(typcof).ge.6 .and. abs(typcof).le.9 ) then
 285         if ( (vafoma-vafomi).ge.1.d4*zeroma ) then
 286           vafodi = 1.d0 / ( vafoma - vafomi )
 287         else
 288           vafodi = 0.d0
 289         endif
 290       endif
 291 c
 292       endif
 293 c
 294 c====
 295 c 4. recherche de l'ordre d'affichage des faces
 296 c====
 297 #ifdef _DEBUG_HOMARD_
 298       write (ulsort,90002) '4. ordre affichage ; codret', codret
 299       write (ulsort,90002) 'nbtrvi', nbtrvi
 300       write (ulsort,90002) 'nbquvi', nbquvi
 301       write (ulsort,90002) 'sdim  ', sdim
 302 #endif
 303 c
 304       if ( nbtrvi+nbquvi.gt.0 ) then
 305 c
 306         if ( sdim.eq.3 ) then
 307 c
 308           if ( codret.eq.0 ) then
 309 c
 310           iaux = 9*(nbtrvi+nbquvi)
 311           call gmalot ( ntrav1, 'reel    ', iaux, ptrav1, codre1 )
 312           iaux = nbtrvi+nbquvi
 313           call gmalot ( ntrav2, 'entier  ', iaux, ptrav2, codre2 )
 314 c
 315           codre0 = min ( codre1, codre2 )
 316           codret = max ( abs(codre0), codret,
 317      >                   codre1, codre2 )
 318 c
 319           endif
 320 c
 321         endif
 322 c
 323         if ( codret.eq.0 ) then
 324 c
 325 #ifdef _DEBUG_HOMARD_
 326         write (ulsort,texte(langue,3)) 'PPPMA3', nompro
 327 #endif
 328         call pppma3 ( nbtrvi, nbquvi,
 329      >                nntrvi, nnquvi,
 330      >                coopro,
 331      >                posini, rmem(ptrav1), imem(ptrav2), nivsup,
 332      >                ulsort, langue, codret )
 333 c
 334 #ifdef _DEBUG_HOMARD_
 335         write (ulsort,texte(langue,10)) 4, codret
 336 #endif
 337 c
 338         endif
 339 c
 340         if ( sdim.eq.3 ) then
 341 c
 342           if ( codret.eq.0 ) then
 343 c
 344           call gmlboj ( ntrav1, codre1 )
 345           call gmlboj ( ntrav2, codre2 )
 346 c
 347           codre0 = min ( codre1, codre2 )
 348           codret = max ( abs(codre0), codret,
 349      >                   codre1, codre2 )
 350 c
 351           endif
 352 c
 353         endif
 354 c
 355       endif
 356 c
 357 c====
 358 c 5. impression du maillage sur fichier
 359 c====
 360 #ifdef _DEBUG_HOMARD_
 361       write (ulsort,90002) '5. impression ; codret', codret
 362 #endif
 363 c
 364       if ( codret.eq.0 ) then
 365 c
 366 #ifdef _DEBUG_HOMARD_
 367       write (ulsort,texte(langue,3)) 'PPXMA5', nompro
 368 #endif
 369       call ppxma5 ( lgtcmx, tbcoli, ncotbl,
 370      >              infsup, typcof, typcop, typbor, optnoe,
 371      >              porpay, zoom, triedr,
 372      >              degre, sdim, mailet,
 373      >              titre1, titre2,
 374      >              nbarvi, nbtrvi, nbquvi,
 375      >              nnarvi, nntrvi, nnquvi,
 376      >              coopro, posini,
 377      >              nnoeca, nareca, ntreca, nqueca,
 378      >              fotrva, foquva, vafomi, vafoma, vafodi,
 379      >              ulvecs, nomflo, lnomfl,
 380      >              ulsost,
 381      >              ulsort, langue, codret )
 382 c
 383       endif
 384 c
 385 #ifdef _DEBUG_HOMARD_
 386       write (ulsort,texte(langue,10)) 5, codret
 387 #endif
 388 c
 389 c====
 390 c 6. la fin
 391 c====
 392 c
 393 #ifdef _DEBUG_HOMARD_
 394       write (ulsort,texte(langue,10)) 0, codret
 395 #endif
 396 c
 397       if ( codret.ne.0 ) then
 398 c
 399 #include "envex2.h"
 400 c
 401       write (ulsort,texte(langue,1)) 'Sortie', nompro
 402       write (ulsort,texte(langue,2)) codret
 403 c
 404       endif
 405 c
 406 #ifdef _DEBUG_HOMARD_
 407       write (ulsort,texte(langue,1)) 'Sortie', nompro
 408       call dmflsh (iaux)
 409 #endif
 410 c
 411       end