src/tool/ES_Xfig/pppma1.F

   1       subroutine pppma1 ( typcof,
   2      >                    lgtcmx, tbcols, tbcoli, ncotbl,
   3      >                    nbtrvi, nbquvi,
   4      >                    nntrvi, nnquvi,
   5      >                    ulsort, langue, codret )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c     Post-Processeur - Preparation du MAillage - phase 1
  27 c     -    -            -              --               -
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . typcof . e   .   1    . type de coloriage des faces                .
  33 c .        .     .        .   0 : incolore transparent                 .
  34 c .        .     .        .   1 : incolore opaque                      .
  35 c .        .     .        .   2 : famille HOMARD                       .
  36 c .        .     .        .   3 : famille HOMARD, sans orientation     .
  37 c .        .     .        .   4/5 : idem 2/3, en niveau de gris        .
  38 c .        .     .        . +-6 : couleur selon un champ, echelle auto..
  39 c .        .     .        . +-7 : idem avec echelle fixe               .
  40 c .        .     .        . +-8/+-9 : idem +-6/+-7, en niveau de gris  .
  41 c .        .     .        .  10 : niveau                               .
  42 c . lgtcmx . e   .   1    . longueur maximale de la table de couleur   .
  43 c . tbcoli . e   .        . table de couleur entier                    .
  44 c . tbcols .  s  .char*17 . table de couleur caracteres                .
  45 c .        .     . (-3:   . Les immuables sont :                       .
  46 c .        .     . lgtcmx).       -3 : defaut de xfig                  .
  47 c .        .     .        .       -2 : noir                            .
  48 c .        .     .        .       -1 : blanc                           .
  49 c .        .     .        . lgtcmx-2 : rouge pour les aretes de bord   .
  50 c .        .     .        . lgtcmx-1 : un gris pale pour les familles  .
  51 c .        .     .        .            libres et le triedre            .
  52 c .        .     .        .  lgtcmx : un vert pale (cadre de zoom)     .
  53 c . ncotbl .  s  .   1    . nombre de couleurs dans la table           .
  54 c . nbtrvi . e   .   1    . nombre triangles visualisables             .
  55 c . nbquvi . e   .   1    . nombre de quadrangles visualisables        .
  56 c . nntrvi . e   .10nbtrvi. 1 : niveau du triangle a afficher          .
  57 c .        .     .        . 2 : numero HOMARD du triangle              .
  58 c .        .     .        . 3, 4, 5 : numeros des noeuds p1            .
  59 c .        .     .        . 6 : famille du triangle                    .
  60 c .        .     .        . 7, 8, 9 : numeros des noeuds p2            .
  61 c .        .     .        . 10 : numero du noeud interne               .
  62 c . nnquvi . e   .12nbquvi. 1 : niveau du quadrangle a afficher        .
  63 c .        .     .        . 2 : numero HOMARD du quadrangle            .
  64 c .        .     .        . 3, 4, 5, 6 : numeros des noeuds p1         .
  65 c .        .     .        . 7 : famille du quadrangle                  .
  66 c .        .     .        . 8, 9, 10, 11 : numeros des noeuds p2       .
  67 c .        .     .        . 12 : numero du noeud interne               .
  68 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  69 c . langue . e   .    1   . langue des messages                        .
  70 c .        .     .        . 1 : francais, 2 : anglais                  .
  71 c . codret .  s  .    1   . code de retour des modules                 .
  72 c .        .     .        . 0 : pas de probleme                        .
  73 c ______________________________________________________________________
  74 c
  75 c====
  76 c 0. declarations et dimensionnement
  77 c====
  78 c
  79 c 0.1. ==> generalites
  80 c
  81       implicit none
  82       save
  83 c
  84       character*6 nompro
  85       parameter ( nompro = 'PPPMA1' )
  86 c
  87 #include "nblang.h"
  88 c
  89 c 0.2. ==> communs
  90 c
  91 #include "envex1.h"
  92 c
  93 c 0.3. ==> arguments
  94 c
  95       integer lgtcmx, typcof, ncotbl
  96       integer nbtrvi, nbquvi
  97       integer nntrvi(10,nbtrvi)
  98       integer nnquvi(12,nbquvi)
  99       integer tbcoli(-3:lgtcmx)
 100 c
 101       character*17 tbcols(-2:lgtcmx)
 102 c
 103       integer ulsort, langue, codret
 104 c
 105 c 0.4. ==> variables locales
 106 c
 107       integer iaux, jaux, kaux, laux
 108       double precision daux
 109 c
 110       character*3 saux03
 111 c
 112       integer nbmess
 113       parameter ( nbmess = 10 )
 114       character*80 texte(nblang,nbmess)
 115 c
 116 c 0.5. ==> initialisations
 117 c      Codification Xfig :
 118 c      -1 = Default
 119 c       0 = Black
 120 c       1 = Blue
 121 c       2 = Green
 122 c       3 = Cyan
 123 c       4 = Red
 124 c       5 = Magenta
 125 c       6 = Yellow
 126 c       7 = White
 127 c    8-11 = four shades of blue (dark to lighter)
 128 c   12-14 = three shades of green (dark to lighter)
 129 c   15-17 = three shades of cyan (dark to lighter)
 130 c   18-20 = three shades of red (dark to lighter)
 131 c   21-23 = three shades of magenta (dark to lighter)
 132 c   24-26 = three shades of brown (dark to lighter)
 133 c   27-30 = four shades of pink (dark to lighter)
 134 c      31 = Gold
 135 c_______________________________________________________________________
 136 c
 137 c====
 138 c 1. les messages
 139 c====
 140 c
 141 #include "impr01.h"
 142 c
 143 #ifdef _DEBUG_HOMARD_
 144       write (ulsort,texte(langue,1)) 'Entree', nompro
 145       call dmflsh (iaux)
 146 #endif
 147 c
 148       codret = 0
 149 c
 150 c====
 151 c 2. les immuables
 152 c          -3 : defaut de xfig
 153 c          -2 : noir
 154 c          -1 : blanc
 155 c    lgtcmx-2 : rouge pour les aretes de bord
 156 c    lgtcmx-1 : un gris pale pour les familles libres et le triedre
 157 c      lgtcmx : un vert pale (pour la fenetre de zoom)
 158 c====
 159 c
 160       tbcols(-2) = '0.000 0.000 0.000'
 161       tbcols(-1) = '1.000 1.000 1.000'
 162 c
 163       tbcols(lgtcmx-2) = '1.000 0.000 0.000'
 164       tbcols(lgtcmx-1) = '0.800 0.800 0.800'
 165       tbcols(lgtcmx)   = '0.100 0.600 0.200'
 166 c
 167       tbcoli(-3) = -1
 168       tbcoli(-2) = 0
 169       tbcoli(-1) = 7
 170 c
 171       tbcoli(lgtcmx-2) = 4
 172       tbcoli(lgtcmx-1) = 30
 173       tbcoli(lgtcmx)   = 14
 174 c
 175 c====
 176 c 3. pour un coloriage par valeur discrete : niveau ou famille
 177 c    typcof compris entre 1 et 5
 178 c====
 179 c 3.1. ==> en couleur ; typcof valant 2, 3 ou 10
 180 c           0 : bleu
 181 c           1 : rouge
 182 c           2 : vert
 183 c           3 : magenta
 184 c           4 : turquoise
 185 c           5 : jaune
 186 c           etc
 187 c           pour xfig on est limite a 31
 188 c
 189       if ( typcof.eq.2 .or. typcof.eq.3 .or. typcof.eq.10 ) then
 190 c
 191         tbcols(0)  = '0.000 0.000 1.000'
 192         tbcoli(0)  = 1
 193         tbcols(1)  = '1.000 0.000 0.000'
 194         tbcoli(1)  = 4
 195         tbcols(2)  = '0.000 1.000 0.000'
 196         tbcoli(2)  = 2
 197         tbcols(3)  = '1.000 0.000 1.000'
 198         tbcoli(3)  = 5
 199         tbcols(4)  = '0.000 1.000 1.000'
 200         tbcoli(4)  = 3
 201         tbcols(5)  = '1.000 1.000 0.000'
 202         tbcoli(5)  = 6
 203         tbcols(6)  = '0.200 0.400 0.600'
 204         tbcoli(6)  = 27
 205         tbcols(7)  = '0.400 0.600 0.200'
 206         tbcoli(7)  = 24
 207         tbcols(8)  = '0.600 0.200 0.400'
 208         tbcoli(8)  = 21
 209         tbcols(9)  = '0.100 0.200 0.800'
 210         tbcoli(9)  = 18
 211         tbcols(10) = '0.800 0.200 0.100'
 212         tbcoli(10)  = 15
 213         kaux = 0
 214         do 311 , iaux = 1 , nbtrvi
 215           kaux = max ( kaux, nntrvi(6,iaux) )
 216   311   continue
 217         do 312 , iaux = 1 , nbquvi
 218           kaux = max ( kaux, nnquvi(7,iaux) )
 219   312   continue
 220         if ( kaux.gt.10 ) then
 221           do 313 , iaux = 11 , kaux
 222             tbcols(iaux) = '0.000 0.000 0.000'
 223             call utench ( iaux, 'g', jaux, saux03,
 224      >                    ulsort, langue, codret )
 225             tbcols(iaux)(3:2+jaux) = saux03(1:jaux)
 226             call utench ( 100+iaux, 'g', jaux, saux03,
 227      >                    ulsort, langue, codret )
 228             tbcols(iaux)(9:8+jaux) = saux03(1:jaux)
 229             call utench ( mod(iaux,100), 'g', jaux, saux03,
 230      >                    ulsort, langue, codret )
 231             tbcols(iaux)(15:14+jaux) = saux03(1:jaux)
 232             if ( mod(iaux-11,18).eq.0 ) then
 233               tbcoli(iaux)  = 8
 234             elseif ( mod(iaux-11,17).eq.1 ) then
 235               tbcoli(iaux)  = 12
 236             elseif ( mod(iaux-11,17).eq.2 ) then
 237               tbcoli(iaux)  = 16
 238             elseif ( mod(iaux-11,17).eq.3 ) then
 239               tbcoli(iaux)  = 19
 240             elseif ( mod(iaux-11,17).eq.4 ) then
 241               tbcoli(iaux)  = 22
 242             elseif ( mod(iaux-11,17).eq.5 ) then
 243               tbcoli(iaux)  = 9
 244             elseif ( mod(iaux-11,17).eq.6 ) then
 245               tbcoli(iaux)  = 13
 246             elseif ( mod(iaux-11,17).eq.7 ) then
 247               tbcoli(iaux)  = 28
 248             elseif ( mod(iaux-11,17).eq.8 ) then
 249               tbcoli(iaux)  = 25
 250             elseif ( mod(iaux-11,17).eq.9 ) then
 251               tbcoli(iaux)  = 10
 252             elseif ( mod(iaux-11,17).eq.10 ) then
 253               tbcoli(iaux)  = 14
 254             elseif ( mod(iaux-11,17).eq.11 ) then
 255               tbcoli(iaux)  = 17
 256             elseif ( mod(iaux-11,17).eq.12 ) then
 257               tbcoli(iaux)  = 29
 258             elseif ( mod(iaux-11,17).eq.13 ) then
 259               tbcoli(iaux)  = 20
 260             elseif ( mod(iaux-11,17).eq.14 ) then
 261               tbcoli(iaux)  = 23
 262             elseif ( mod(iaux-11,17).eq.15 ) then
 263               tbcoli(iaux)  = 26
 264             elseif ( mod(iaux-11,17).eq.16 ) then
 265               tbcoli(iaux)  = 11
 266             elseif ( mod(iaux-11,17).eq.17 ) then
 267               tbcoli(iaux)  = 30
 268             endif
 269   313     continue
 270         endif
 271 c
 272 c 3.2. ==> en niveau de gris ; typcof compris entre 4 et 5
 273 c           0 : blanc
 274 c           1 : gris tres tres clair
 275 c           2 : gris tres clair
 276 c           etc
 277 c
 278       elseif ( typcof.ge.4 .and. typcof.le.5 ) then
 279 c
 280 c
 281         tbcols(0)  = '1.000 1.000 1.000'
 282         tbcoli(0)  = 7
 283         kaux = 0
 284         do 321 , iaux = 1 , nbtrvi
 285           kaux = max ( kaux, nntrvi(6,iaux) )
 286   321   continue
 287         do 322 , iaux = 1 , nbquvi
 288           kaux = max ( kaux, nnquvi(7,iaux) )
 289   322   continue
 290         daux = 999.d0/dble(kaux)
 291         do 333 , iaux = 1 , kaux
 292           tbcols(iaux)  = '0.000 0.000 0.000'
 293           jaux = int ( dble(iaux)*daux )
 294           saux03 = '000'
 295           call utench ( jaux, '0', laux, saux03,
 296      >                 ulsort, langue, codret )
 297           tbcols(iaux)( 3: 6) = saux03
 298           tbcols(iaux)( 9:12) = saux03
 299           tbcols(iaux)(15:17) = saux03
 300           tbcoli(iaux)  = 0
 301   333   continue
 302 c
 303 c====
 304 c 4. pour un coloriage par valeur continue : fonction
 305 c    typcof valant +-6 ou +-7
 306 c====
 307 c
 308       elseif ( abs(typcof).eq.6 .or. abs(typcof).eq.7 ) then
 309 c
 310 c       Pour l'ancien PostScript, pour memoire
 311 c       on fait un degrade du minimum, 0/bleu, au maximum, 22/rouge
 312 c       la progression en RGB est issue des travaux presentes sur :
 313 c       http://the-light.com/colclick.html
 314 c
 315         laux = 39
 316         daux = 1000.d0/(dble(laux+1))
 317 c
 318 c bleu pur
 319 c
 320         tbcols(0)   = '0.000 0.000 1.000'
 321 c
 322 c nuances de bleu a turquoise : on augmente le G
 323 c
 324         ncotbl = 0
 325         do 41 , iaux = 1, laux
 326           kaux = nint(daux*dble(iaux))
 327           call utench ( kaux, '0', jaux, saux03,
 328      >                  ulsort, langue, codret )
 329           ncotbl = ncotbl + 1
 330 c                           12345678901234567
 331           tbcols(ncotbl) = '0.000 0.zzz 1.000'
 332           tbcols(ncotbl)(9:11) = saux03
 333    41   continue
 334 c
 335 c turquoise pur
 336 c
 337         ncotbl = ncotbl + 1
 338         tbcols(ncotbl)   = '0.000 1.000 1.000'
 339 c
 340 c nuances de turquoise a vert : on diminue le B
 341 c
 342         do 42 , iaux = laux , 1, -1
 343           kaux = nint(daux*dble(iaux))
 344           call utench ( kaux, '0', jaux, saux03,
 345      >                  ulsort, langue, codret )
 346           ncotbl = ncotbl + 1
 347 c                           12345678901234567
 348           tbcols(ncotbl) = '0.000 1.000 0.zzz'
 349           tbcols(ncotbl)(15:17) = saux03
 350    42   continue
 351 c
 352 c vert pur
 353 c
 354         ncotbl = ncotbl + 1
 355         tbcols(ncotbl)   = '0.000 1.000 0.000'
 356 c
 357 c nuances de vert a jaune : on augmente le R
 358 c
 359         do 43 , iaux = 1, laux
 360           kaux = nint(daux*dble(iaux))
 361           call utench ( kaux, '0', jaux, saux03,
 362      >                  ulsort, langue, codret )
 363           ncotbl = ncotbl + 1
 364 c                           12345678901234567
 365           tbcols(ncotbl) = '0.zzz 1.000 0.000'
 366           tbcols(ncotbl)(3:5) = saux03
 367    43   continue
 368 c
 369 c jaune pur
 370 c
 371         ncotbl = ncotbl + 1
 372         tbcols(ncotbl)   = '1.000 1.000 0.000'
 373 c
 374 c nuances de jaune a rouge : on diminue le G
 375 c
 376         do 44 , iaux = laux , 1, -1
 377           kaux = nint(daux*dble(iaux))
 378           call utench ( kaux, '0', jaux, saux03,
 379      >                  ulsort, langue, codret )
 380           ncotbl = ncotbl + 1
 381 c                           12345678901234567
 382           tbcols(ncotbl) = '1.000 0.zzz 0.000'
 383           tbcols(ncotbl)(9:11) = saux03
 384    44   continue
 385 c
 386 c rouge pur
 387 c
 388         ncotbl = ncotbl + 1
 389         tbcols(ncotbl)   = '1.000 0.000 0.000'
 390 c
 391 c       Pour Xfig, on fait un degrade du minimum, 0/bleu sombre, au
 392 c       maximum, 7/rouge
 393 c
 394         tbcoli(0) =  8
 395         tbcoli(1) =  1
 396         tbcoli(2) =  3
 397         tbcoli(3) =  2
 398         tbcoli(4) =  6
 399         tbcoli(5) = 31
 400         tbcoli(6) =  4
 401         tbcoli(7) = 18
 402 c
 403         ncotbl = 7
 404 c
 405       endif
 406 c
 407 cgn      print 1789,(tbcols(iaux),iaux=-2,ncotbl)
 408 cgn 1789 format(a17)
 409 cgn        print *,'ncotbl = ',ncotbl
 410 c
 411 c====
 412 c 5. la fin
 413 c====
 414 c
 415       if ( codret.ne.0 ) then
 416 c
 417 #include "envex2.h"
 418 c
 419       write (ulsort,texte(langue,1)) 'Sortie', nompro
 420       write (ulsort,texte(langue,2)) codret
 421 c
 422       endif
 423 c
 424 #ifdef _DEBUG_HOMARD_
 425       write (ulsort,texte(langue,1)) 'Sortie', nompro
 426       call dmflsh (iaux)
 427 #endif
 428 c
 429       end