src/tool/Information/infc34.F

   1       subroutine infc34 ( numcas, nbcomp, nbentc,
   2      >                    profil, vafoti, vafotr,
   3      >                    arequa, perqua, nivqua,
   4      >                    nquaca,
   5      >                    coonoe, somare,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c  INformation - inFormations Complementaires - phase 34
  27 c  --              -          -                       --
  28 c  Valeurs sur les quadrangles
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . numcas . e   .   1    . numero du cas en cours de traitement       .
  34 c .        .     .        . 1 : niveau                                 .
  35 c .        .     .        . 2 : qualite                                .
  36 c .        .     .        . 3 : diametre                               .
  37 c .        .     .        . 4 : parente                                .
  38 c .        .     .        . 5 : voisins des recollements               .
  39 c . nbcomp . e   .   1    . nombre de composantes                      .
  40 c . nbentc . e   .   1    . nombre total d'entites du calcul           .
  41 c . profil .  s  . nbentc . pour chaque entite du calcul :             .
  42 c .        .     .        . 0 : l'entite est absente du profil         .
  43 c .        .     .        . 1 : l'entite est presente dans le profil   .
  44 c . vafoti .  s  . nbentc . tableau temporaire de la fonction          .
  45 c . vafotr .  s  . nbentc . tableau temporaire de la fonction          .
  46 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  47 c . perqua . e   . nbquto . pere des quadrangles                       .
  48 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  49 c . nquaca . e   .   *    . nro des quadrangles dans le calcul         .
  50 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  51 c .        .     . * sdim .                                            .
  52 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  53 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  54 c . langue . e   .    1   . langue des messages                        .
  55 c .        .     .        . 1 : francais, 2 : anglais                  .
  56 c . codret . es  .    1   . code de retour des modules                 .
  57 c .        .     .        . 0 : pas de probleme                        .
  58 c .        .     .        . 5 : mauvais type de code de calcul associe .
  59 c ______________________________________________________________________
  60 c
  61 c====
  62 c 0. declarations et dimensionnement
  63 c====
  64 c
  65 c 0.1. ==> generalites
  66 c
  67       implicit none
  68       save
  69 c
  70       character*6 nompro
  71       parameter ( nompro = 'INFC34' )
  72 c
  73 #include "nblang.h"
  74 c
  75 c 0.2. ==> communs
  76 c
  77 #include "envex1.h"
  78 #include "envca1.h"
  79 #include "impr02.h"
  80 #include "nombno.h"
  81 #include "nombar.h"
  82 #include "nombqu.h"
  83 c
  84 c 0.3. ==> arguments
  85 c
  86       integer numcas
  87       integer nbcomp, nbentc
  88       integer profil(nbentc)
  89       integer vafoti(nbentc)
  90       integer arequa(nbquto,4), perqua(nbquto)
  91       integer nivqua(nbquto)
  92       integer nquaca(*)
  93       integer somare(2,nbarto)
  94 c
  95       double precision coonoe(nbnoto,sdim)
  96       double precision vafotr(nbentc)
  97 c
  98       integer ulsort, langue, codret
  99 c
 100 c 0.4. ==> variables locales
 101 c
 102       integer iaux, jaux
 103 c
 104       double precision qualit, surf, diamet
 105 c
 106       integer nbmess
 107       parameter ( nbmess = 10 )
 108       character*80 texte(nblang,nbmess)
 109 c
 110 c 0.5. ==> initialisations
 111 c ______________________________________________________________________
 112 c
 113 c====
 114 c 1. messages
 115 c====
 116 c
 117 #include "impr01.h"
 118 #include "impr03.h"
 119 c
 120 #ifdef _DEBUG_HOMARD_
 121       write (ulsort,texte(langue,1)) 'Entree', nompro
 122       call dmflsh (iaux)
 123 #endif
 124       texte(1,4) = '(''.. Valeurs sur les '',a)'
 125 c
 126       texte(2,4) = '(''.. Values over the '',a)'
 127 c
 128 #ifdef _DEBUG_HOMARD_
 129       write (ulsort,texte(langue,4)) mess14(langue,3,4)
 130       write (ulsort,90002) 'cas   ', numcas
 131       write (ulsort,90002) 'nbquto', nbquto
 132       write (ulsort,90002) 'nbqupe', nbqupe
 133       write (ulsort,90002) 'nbentc', nbentc
 134 #endif
 135 c
 136       codret = 0
 137 c
 138 c====
 139 c 2. Rien par defaut
 140 c====
 141 c
 142       do 21 , iaux = 1 , nbentc
 143         profil(iaux) = 0
 144    21 continue
 145 c
 146 c====
 147 c 3. Niveau
 148 c====
 149 c
 150       if ( numcas.eq.1 ) then
 151 c
 152 c 3.1. ==> Les quadrangles de depart ou issus d'un decoupage en 4
 153 c
 154         do 31 , iaux = 1 , nbqupe
 155 c
 156           jaux = nquaca(iaux)
 157           if ( jaux.ne.0 ) then
 158             vafotr(jaux) = dble(nivqua(iaux))
 159             profil(jaux) = 1
 160           endif
 161 c
 162    31   continue
 163 c
 164 c 3.2. ==> Les quadrangles issus d'un decoupage de conformite
 165 c
 166         do 32 , iaux = nbqupe+1 , nbquto
 167 c
 168           jaux = nquaca(iaux)
 169           if ( jaux.ne.0 ) then
 170             vafotr(jaux) = dble(nivqua(iaux)) - 0.5d0
 171             profil(jaux) = 1
 172           endif
 173 c
 174    32   continue
 175 c
 176 c====
 177 c 4. Qualite
 178 c====
 179 c
 180       elseif ( numcas.eq.2 ) then
 181 c
 182         do 41 , iaux = 1 , nbquto
 183 c
 184           jaux = nquaca(iaux)
 185           if ( jaux.ne.0 ) then
 186             call utqqua ( iaux, qualit, surf,
 187      >                    coonoe, somare, arequa )
 188             vafotr(jaux) = qualit
 189             profil(jaux) = 1
 190           endif
 191 c
 192    41   continue
 193 c
 194 c====
 195 c 5. Diametre
 196 c====
 197 c
 198       elseif ( numcas.eq.3 ) then
 199 c
 200         do 51 , iaux = 1 , nbquto
 201 c
 202           jaux = nquaca(iaux)
 203           if ( jaux.ne.0 ) then
 204             call utdqua ( iaux, diamet,
 205      >                    coonoe, somare, arequa )
 206             vafotr(jaux) = diamet
 207             profil(jaux) = 1
 208 c
 209           endif
 210 c
 211    51   continue
 212 c
 213 c====
 214 c 6. Parente
 215 c====
 216 c
 217       elseif ( numcas.eq.4 ) then
 218 c
 219         do 61 , iaux = 1 , nbquto
 220 c
 221           jaux = nquaca(iaux)
 222           if ( jaux.ne.0 ) then
 223             vafoti(jaux) = perqua(iaux)
 224             profil(jaux) = 1
 225           endif
 226 c
 227    61   continue
 228 c
 229       endif
 230 c
 231 c====
 232 c 7. la fin
 233 c====
 234 c
 235       if ( codret.ne.0 ) then
 236 c
 237 #include "envex2.h"
 238 c
 239       write (ulsort,texte(langue,1)) 'Sortie', nompro
 240       write (ulsort,texte(langue,2)) codret
 241 c
 242       endif
 243 c
 244 #ifdef _DEBUG_HOMARD_
 245       write (ulsort,texte(langue,1)) 'Sortie', nompro
 246       call dmflsh (iaux)
 247 #endif
 248 c
 249       end