src/tool/ES_Xfig/pppma2.F

   1       subroutine pppma2 ( vafomi, vafoma,
   2      >                    typcof, nbtrvi, nbquvi,
   3      >                    fotrva, foquva,
   4      >                    ulsost,
   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 2
  27 c     -    -            -              --               -
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . vafomi .  s  .   1    . minimum de l'echelle de la fonction        .
  33 c . vafoma .  s  .   1    . maximum de l'echelle de la fonction        .
  34 c . typcof . e   .   1    . type de coloriage des faces                .
  35 c .        .     .        .   0 : incolore transparent                 .
  36 c .        .     .        .   1 : incolore opaque                      .
  37 c .        .     .        .   2 : famille HOMARD                       .
  38 c .        .     .        .   3 : famille HOMARD, sans orientation     .
  39 c .        .     .        .   4/5 : idem 2/3, en niveau de gris        .
  40 c .        .     .        . +-6 : couleur selon un champ, echelle auto..
  41 c .        .     .        . +-7 : idem avec echelle fixe               .
  42 c .        .     .        . +-8/+-9 : idem +-6/+-7, en niveau de gris  .
  43 c .        .     .        .  10 : niveau                               .
  44 c . nbtrvi . e   .   1    . nombre triangles visualisables             .
  45 c . nbquvi . e   .   1    . nombre de quadrangles visualisables        .
  46 c . fotrva . e   . nbtrvi . fonctions triangles : valeur               .
  47 c . foquva . e   . nbquvi . fonctions quadrangles : valeur             .
  48 c . ulsost . e   .   1    . unite logique de la sortie standard        .
  49 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  50 c . langue . e   .    1   . langue des messages                        .
  51 c .        .     .        . 1 : francais, 2 : anglais                  .
  52 c . codret .  s  .    1   . code de retour des modules                 .
  53 c .        .     .        . 0 : pas de probleme                        .
  54 c ______________________________________________________________________
  55 c
  56 c====
  57 c 0. declarations et dimensionnement
  58 c====
  59 c
  60 c 0.1. ==> generalites
  61 c
  62       implicit none
  63       save
  64 c
  65       character*6 nompro
  66       parameter ( nompro = 'PPPMA2' )
  67 c
  68 #include "nblang.h"
  69 c
  70 c 0.2. ==> communs
  71 c
  72 #include "envex1.h"
  73 c
  74 #include "impr02.h"
  75 c
  76 c 0.3. ==> arguments
  77 c
  78       integer typcof
  79       integer nbtrvi, nbquvi
  80       integer ulsost
  81 c
  82       double precision vafomi, vafoma
  83       double precision fotrva(nbtrvi), foquva(nbquvi)
  84 c
  85       integer ulsort, langue, codret
  86 c
  87 c 0.4. ==> variables locales
  88 c
  89       integer iaux
  90 c
  91       integer nbmess
  92       parameter ( nbmess = 10 )
  93       character*80 texte(nblang,nbmess)
  94 c
  95 c 0.5. ==> initialisations
  96 c_______________________________________________________________________
  97 c
  98 c====
  99 c 1. les messages
 100 c====
 101 c
 102 #include "impr01.h"
 103 c
 104 #ifdef _DEBUG_HOMARD_
 105       write (ulsort,texte(langue,1)) 'Entree', nompro
 106       call dmflsh (iaux)
 107 #endif
 108 c
 109       texte(1,4) = '(''Type de coloriage :'',i6)'
 110       texte(1,5) = '(''Fonction sur les '',a)'
 111       texte(1,6) = '(''min = '',g12.5,'', max = '',g12.5)'
 112 c
 113       texte(2,4) = '(''Colouring type :'',i6)'
 114       texte(2,5) = '(''Function over '',a)'
 115       texte(2,6) = '(''min = '',g12.5,'', max = '',g12.5)'
 116 c
 117 #include "impr03.h"
 118 c
 119 #ifdef _DEBUG_HOMARD_
 120       write (ulsort,texte(langue,4)) typcof
 121       write (ulsort,90002) 'nbtrvi', nbtrvi
 122       write (ulsort,90002) 'nbquvi', nbquvi
 123 #endif
 124 cgn      write (ulsort,*) 'fotrva'
 125 cgn      write (ulsort,92010) (fotrva(iaux), iaux = 1 , nbtrvi)
 126 cgn      write (ulsort,*) 'foquva'
 127 cgn      write (ulsort,92010) (foquva(iaux), iaux = 1 , nbquvi)
 128 c
 129 c====
 130 c 2. fonction exprimee sur les triangles
 131 c====
 132 c
 133       if ( nbtrvi.ne.0 ) then
 134 c
 135 c 2.1. ==> valeur brute
 136 c
 137         if ( typcof.gt.0 ) then
 138 c
 139           vafomi = fotrva(1)
 140           vafoma = vafomi
 141 c
 142           do 21 , iaux = 2 , nbtrvi
 143             vafomi = min (vafomi,fotrva(iaux))
 144             vafoma = max (vafoma,fotrva(iaux))
 145    21     continue
 146 c
 147 c 2.2. ==> valeur absolue
 148 c
 149         else
 150 c
 151           vafomi = abs(fotrva(1))
 152           vafoma = vafomi
 153 c
 154           do 22 , iaux = 2 , nbtrvi
 155             vafomi = min (vafomi,abs(fotrva(iaux)))
 156             vafoma = max (vafoma,abs(fotrva(iaux)))
 157    22     continue
 158 c
 159         endif
 160 c
 161 #ifdef _DEBUG_HOMARD_
 162         iaux = 2
 163         write (ulsort,texte(langue,5)) mess14(langue,3,iaux)
 164         write (ulsort,texte(langue,6)) vafomi, vafoma
 165         if ( ulsost.ne.ulsort ) then
 166           write (ulsost,texte(langue,5)) mess14(langue,3,iaux)
 167           write (ulsost,texte(langue,6)) vafomi, vafoma
 168         endif
 169 #endif
 170 c
 171       endif
 172 c
 173 c====
 174 c 3. fonction exprimee sur les quadrangles
 175 c====
 176 c
 177       if ( nbquvi.ne.0 ) then
 178 c
 179 c 3.1. ==> valeur brute
 180 c
 181         if ( typcof.gt.0 ) then
 182 c
 183           if ( nbtrvi.eq.0 ) then
 184             vafomi = foquva(1)
 185             vafoma = vafomi
 186           endif
 187 c
 188           do 31 , iaux = 2 , nbquvi
 189             vafomi = min (vafomi,foquva(iaux))
 190             vafoma = max (vafoma,foquva(iaux))
 191    31     continue
 192 c
 193 c 3.2. ==> valeur absolue
 194 c
 195         else
 196 c
 197           if ( nbtrvi.eq.0 ) then
 198             vafomi = abs(foquva(1))
 199             vafoma = vafomi
 200           endif
 201 c
 202           do 32 , iaux = 2 , nbquvi
 203             vafomi = min (vafomi,abs(foquva(iaux)))
 204             vafoma = max (vafoma,abs(foquva(iaux)))
 205    32     continue
 206 c
 207         endif
 208 c
 209       endif
 210 c
 211 #ifdef _DEBUG_HOMARD_
 212       if ( nbquvi.ne.0 ) then
 213 c
 214         if ( nbtrvi.eq.0 ) then
 215           iaux = 4
 216         else
 217           iaux = 8
 218         endif
 219 c
 220         write (ulsort,texte(langue,5)) mess14(langue,3,iaux)
 221         write (ulsost,texte(langue,5)) mess14(langue,3,iaux)
 222         write (ulsort,texte(langue,6)) vafomi, vafoma
 223         write (ulsost,texte(langue,6)) vafomi, vafoma
 224 c
 225       endif
 226 #endif
 227 c
 228 c====
 229 c 4. la fin
 230 c====
 231 c
 232       if ( codret.ne.0 ) then
 233 c
 234 #include "envex2.h"
 235 c
 236       write (ulsort,texte(langue,1)) 'Sortie', nompro
 237       write (ulsort,texte(langue,2)) codret
 238 c
 239       endif
 240 c
 241 #ifdef _DEBUG_HOMARD_
 242       write (ulsort,texte(langue,1)) 'Sortie', nompro
 243       call dmflsh (iaux)
 244 #endif
 245 c
 246       end