src/tool/Information/infc33.F

   1       subroutine infc33 ( numcas, nbcomp, nbentc,
   2      >                    profil, vafoti, vafotr,
   3      >                    tritet, cotrte, aretet,
   4      >                    pertet, pthepe, ntetca,
   5      >                    coonoe, somare,
   6      >                    aretri, nivtri,
   7      >                    nivqua,
   8      >                    quahex, facpen,
   9      >                    npterc, tetrec,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c  INformation - inFormations Complementaires - phase 33
  31 c  --              -          -                       --
  32 c  Valeurs sur les tetraedres
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . numcas . e   .   1    . numero du cas en cours de traitement       .
  38 c .        .     .        . 1 : niveau                                 .
  39 c .        .     .        . 2 : qualite                                .
  40 c .        .     .        . 3 : diametre                               .
  41 c .        .     .        . 4 : parente                                .
  42 c .        .     .        . 5 : voisins des recollements               .
  43 c . nbcomp . e   .   1    . nombre de composantes                      .
  44 c . nbentc . e   .   1    . nombre total d'entites du calcul           .
  45 c . profil .  s  . nbentc . pour chaque entite du calcul :             .
  46 c .        .     .        . 0 : l'entite est absente du profil         .
  47 c .        .     .        . 1 : l'entite est presente dans le profil   .
  48 c . vafoti .  s  . nbentc . tableau temporaire de la fonction          .
  49 c . vafotr .  s  . nbentc . tableau temporaire de la fonction          .
  50 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  51 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  52 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  53 c . pertet . e   . nbteto . pere des tetraedres                        .
  54 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  55 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  56 c . pthepe . e   .    *   . si i <= nbheco : numero de l'hexaedre      .
  57 c .        .     .        . si non : numero du pentaedre               .
  58 c . ntetca . e   .   *    . nro des tetraedres dans le calcul          .
  59 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  60 c .        .     . * sdim .                                            .
  61 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  62 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  63 c . nivtri . e   . nbtrto . niveau dans le raffinement/deraffinement   .
  64 c . nivqua . e   . nbquto . niveau dans le raffinement/deraffinement   .
  65 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  66 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  67 c . npterc . e   .   1    . nombre de paires de tetraedres recolles    .
  68 c . tetrec . e   .3*npterc. paires des tetra. voisins faces a recoller .
  69 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  70 c . langue . e   .    1   . langue des messages                        .
  71 c .        .     .        . 1 : francais, 2 : anglais                  .
  72 c . codret . es  .    1   . code de retour des modules                 .
  73 c .        .     .        . 0 : pas de probleme                        .
  74 c .        .     .        . 5 : mauvais type de code de calcul associe .
  75 c ______________________________________________________________________
  76 c
  77 c====
  78 c 0. declarations et dimensionnement
  79 c====
  80 c
  81 c 0.1. ==> generalites
  82 c
  83       implicit none
  84       save
  85 c
  86       character*6 nompro
  87       parameter ( nompro = 'INFC33' )
  88 c
  89 #include "nblang.h"
  90 c
  91 c 0.2. ==> communs
  92 c
  93 #include "envex1.h"
  94 #include "envca1.h"
  95 #include "impr02.h"
  96 #include "nombno.h"
  97 #include "nombar.h"
  98 #include "nombtr.h"
  99 #include "nombqu.h"
 100 #include "nombte.h"
 101 #include "nombhe.h"
 102 #include "nombpe.h"
 103 c
 104 c 0.3. ==> arguments
 105 c
 106       integer numcas
 107       integer nbcomp, nbentc
 108       integer profil(nbentc)
 109       integer vafoti(nbentc)
 110       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 111       integer pertet(nbteto), pthepe(*), ntetca(*)
 112       integer somare(2,nbarto)
 113       integer aretri(nbtrto,3), nivtri(nbtrto)
 114       integer nivqua(nbquto)
 115       integer quahex(nbhecf,6)
 116       integer facpen(nbpecf,5)
 117       integer npterc, tetrec(3,npterc)
 118 c
 119       double precision coonoe(nbnoto,sdim)
 120       double precision vafotr(nbentc)
 121 c
 122       integer ulsort, langue, codret
 123 c
 124 c 0.4. ==> variables locales
 125 c
 126       integer iaux, jaux, kaux, laux
 127       integer indice
 128 c
 129       double precision niveau, qualit, qualij, volume, diamet
 130 c
 131       integer nbmess
 132       parameter ( nbmess = 10 )
 133       character*80 texte(nblang,nbmess)
 134 c
 135 c 0.5. ==> initialisations
 136 c ______________________________________________________________________
 137 c
 138 c====
 139 c 1. messages
 140 c====
 141 c
 142 #include "impr01.h"
 143 #include "impr03.h"
 144 c
 145 #ifdef _DEBUG_HOMARD_
 146       write (ulsort,texte(langue,1)) 'Entree', nompro
 147       call dmflsh (iaux)
 148 #endif
 149       texte(1,4) = '(''.. Valeurs sur les '',a)'
 150 c
 151       texte(2,4) = '(''.. Values over the '',a)'
 152 c
 153 #ifdef _DEBUG_HOMARD_
 154       write (ulsort,texte(langue,4)) mess14(langue,3,3)
 155       write (ulsort,90002) 'numcas', numcas
 156       write (ulsort,90002) 'nbteto', nbteto
 157       write (ulsort,90002) 'nbtepe', nbtepe
 158       write (ulsort,90002) 'nbtecf', nbtecf
 159       write (ulsort,90002) 'nbcomp', nbcomp
 160       write (ulsort,90002) 'nbentc', nbentc
 161       write (ulsort,90002) 'npterc', npterc
 162 #endif
 163 c
 164       codret = 0
 165 c
 166 c====
 167 c 2. Rien par defaut
 168 c====
 169 c
 170       do 21 , iaux = 1 , nbentc
 171         profil(iaux) = 0
 172    21 continue
 173 c
 174 c====
 175 c 3. Niveau
 176 c====
 177 c
 178       if ( numcas.eq.1 ) then
 179 c
 180 c 3.1. ==> Les tetraedres de depart ou issus d'un decoupage en 8
 181 c          Les faces sont toutes du meme niveau
 182 c          Remarque : ils sont toujours decrits par faces
 183 c
 184         do 31 , iaux = 1 , nbtepe
 185 c
 186 cgn      write (ulsort,90015) 'ntetca(',iaux,') =', ntetca(iaux)
 187 c
 188           jaux = ntetca(iaux)
 189           if ( jaux.ne.0 ) then
 190 cgn      write (ulsort,90015) 'nivtri(',iaux,') =', nivtri(tritet(iaux,1))
 191             vafotr(jaux) = dble(nivtri(tritet(iaux,1)))
 192             profil(jaux) = 1
 193           endif
 194 c
 195    31   continue
 196 c
 197 c 3.2. ==> Les tetraedres issus d'un decoupage de conformite
 198 c          Remarque : ils sont toujours actifs
 199 c
 200         do 32 , iaux = nbtepe+1 , nbteto
 201 c
 202           call utntet ( iaux, niveau,
 203      >                  tritet, pertet, pthepe,
 204      >                  nivtri, nivqua,
 205      >                  quahex, facpen )
 206 c
 207           jaux = ntetca(iaux)
 208           vafotr(jaux) = niveau
 209           profil(jaux) = 1
 210 c
 211    32   continue
 212 c
 213 c====
 214 c 4. Qualite
 215 c====
 216 c
 217       elseif ( numcas.eq.2 ) then
 218 c
 219         do 41 , iaux = 1 , nbteto
 220 c
 221           jaux = ntetca(iaux)
 222           if ( jaux.ne.0 ) then
 223             kaux = iaux
 224             call utqtet ( kaux, qualit, qualij, volume,
 225      >                     coonoe, somare, aretri,
 226      >                     tritet, cotrte, aretet )
 227             vafotr(jaux) = qualit
 228             profil(jaux) = 1
 229           endif
 230 c
 231    41   continue
 232 c
 233 c====
 234 c 5. Diametre
 235 c====
 236 c
 237       elseif ( numcas.eq.3 ) then
 238 c
 239         do 51 , iaux = 1 , nbteto
 240 c
 241           jaux = ntetca(iaux)
 242           if ( jaux.ne.0 ) then
 243             kaux = iaux
 244             call utdtet ( kaux, diamet,
 245      >                    coonoe, somare, aretri,
 246      >                    tritet, cotrte, aretet )
 247             vafotr(jaux) = diamet
 248             profil(jaux) = 1
 249 c
 250           endif
 251 c
 252    51   continue
 253 c
 254 c====
 255 c 6. Parente
 256 c====
 257 c
 258       elseif ( numcas.eq.4 ) then
 259 c
 260         do 61 , iaux = 1 , nbteto
 261 c
 262           jaux = ntetca(iaux)
 263           if ( jaux.ne.0 ) then
 264             vafoti(jaux) = pertet(iaux)
 265             profil(jaux) = 1
 266           endif
 267 c
 268    61   continue
 269 c
 270 c====
 271 c 7. Voisins par recollement
 272 c====
 273 c
 274       elseif ( numcas.eq.5 ) then
 275 c
 276 c 7.1. ==> On met des valeurs nulles par defaut
 277 c
 278         do 71 , iaux = 1 , nbteto
 279 c
 280           jaux = ntetca(iaux)
 281           if ( jaux.ne.0 ) then
 282             indice = nbcomp*(jaux-1) + 1
 283             do 711 , kaux = 1 , nbcomp
 284               vafoti(indice) = 0
 285               indice = indice + 1
 286   711       continue
 287             profil(jaux) = 1
 288           endif
 289 c
 290    71   continue
 291 c
 292 c 7.2. ==> Percours des paires enregistrees
 293 c
 294         do 72 , iaux = 1 , npterc
 295 c
 296           jaux = tetrec(1,iaux)
 297           kaux = tetrec(2,iaux)
 298 cgn          write (ulsort,90002) 'iaux, jaux, kaux, face',
 299 cgn     >                          iaux, jaux, kaux, tetrec(3,iaux)
 300 c
 301           if ( jaux.ne.0 ) then
 302             indice = nbcomp*(jaux-1) + 1
 303             if ( vafoti(indice).eq.0 ) then
 304               vafoti(indice) = kaux
 305               vafoti(indice+1) = tetrec(3,iaux)
 306               profil(jaux) = 1
 307             endif
 308           endif
 309 c
 310           if ( kaux.ne.0 ) then
 311             indice = nbcomp*(kaux-1) + 1
 312             do 723 , laux = 1, 3
 313               if ( vafoti(indice).eq.0 ) then
 314                 vafoti(indice) = jaux
 315                 vafoti(indice+1) = tetrec(3,iaux)
 316                 profil(kaux) = 1
 317                 goto 724
 318               endif
 319               indice = indice + 2
 320   723       continue
 321   724       continue
 322           endif
 323 c
 324    72   continue
 325 c
 326 cgn        do 73 , iaux = 1,nbentc
 327 cgn          write(ulsort,90112)'profil',iaux,profil(iaux)
 328 cgn       write (ulsort,90002) 'indices', nbcomp*(iaux-1)+1,nbcomp*iaux
 329 cgn          write(ulsort,90112)'vafoti',iaux,
 330 cgn     >(vafoti(jaux),jaux=nbcomp*(iaux-1)+1,nbcomp*iaux)
 331 cgn   73 continue
 332 c
 333       endif
 334 c
 335 c====
 336 c 8. la fin
 337 c====
 338 c
 339       if ( codret.ne.0 ) then
 340 c
 341 #include "envex2.h"
 342 c
 343       write (ulsort,texte(langue,1)) 'Sortie', nompro
 344       write (ulsort,texte(langue,2)) codret
 345 c
 346       endif
 347 c
 348 #ifdef _DEBUG_HOMARD_
 349       write (ulsort,texte(langue,1)) 'Sortie', nompro
 350       call dmflsh (iaux)
 351 #endif
 352 c
 353       end