src/tool/Utilitaire/utvgfa.F

   1       subroutine utvgfa ( nhvois, nharet, nhtria, nhquad,
   2      >                    option,
   3      >                    nbfaar, pposif, pfacar,
   4      >                    ulsort, langue, codret)
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c     UTilitaire : VoisinaGes FAces / Aretes
  26 c     --           -      -   -       -
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nhvois . e   . char8  . nom de l'objet voisinage                   .
  32 c . nharet . e   . char8  . nom de l'objet decrivant les aretes        .
  33 c . nhtria . e   . char8  . nom de l'objet decrivant les triangles     .
  34 c . nhquad . e   . char8  . nom de l'objet decrivant les quadrangles   .
  35 c . option . e   .   1    . pilotage des voisins des aretes :          .
  36 c .        .     .        . -1 : on detruit la table.                  .
  37 c .        .     .        . 0 : on ne fait rien.                       .
  38 c .        .     .        . 1 : on construit la table.                 .
  39 c .        .     .        . 2 : on construit la table et on controle   .
  40 c . nbfaar .  s  .   1    . nombre cumule de faces par arete           .
  41 c . pposif .   s .   1    . adresse du pointeur des vois. des aretes   .
  42 c . pfacar .   s .   1    . adresse des voisins des aretes             .
  43 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  44 c . langue . e   .    1   . langue des messages                        .
  45 c .        .     .        . 1 : francais, 2 : anglais                  .
  46 c . codret . es  .    1   . code de retour des modules                 .
  47 c .        .     .        . 0 : pas de probleme                        .
  48 c .        .     .        . 1 : probleme                               .
  49 c ______________________________________________________________________
  50 c
  51 c====
  52 c 0. declarations et dimensionnement
  53 c====
  54 c
  55 c 0.1. ==> generalites
  56 c
  57       implicit none
  58       save
  59 c
  60       character*6 nompro
  61       parameter ( nompro = 'UTVGFA' )
  62 c
  63 #include "nblang.h"
  64 c
  65 c 0.2. ==> communs
  66 c
  67 #include "envex1.h"
  68 c
  69 #include "gmenti.h"
  70 c
  71 c 0.3. ==> arguments
  72 c
  73       character*8 nhvois, nharet, nhtria, nhquad
  74 c
  75       integer option
  76       integer nbfaar, pposif, pfacar
  77 c
  78       integer ulsort, langue, codret
  79 c
  80 c 0.4. ==> variables locales
  81 c
  82       integer iaux
  83       integer codre1, codre2, codre3, codre4, codre5
  84       integer codre0
  85 c
  86       integer nbarto, nbtrto, nbquto
  87       integer paretr, parequ
  88 c
  89       integer nbmess
  90       parameter ( nbmess = 10 )
  91       character*80 texte(nblang,nbmess)
  92 c
  93 c 0.5. ==> initialisations
  94 c ______________________________________________________________________
  95 c
  96 c====
  97 c 1. messages
  98 c====
  99 c
 100 #include "impr01.h"
 101 c
 102 #ifdef _DEBUG_HOMARD_
 103       write (ulsort,texte(langue,1)) 'Entree', nompro
 104       call dmflsh (iaux)
 105 #endif
 106 c
 107       texte(1,4) = '(5x,''Voisinage faces-aretes.'')'
 108       texte(1,5) = '(''Demande : '',i6)'
 109       texte(1,6) = '(''Mauvaise demande.'')'
 110 c
 111       texte(2,4) = '(5x,''Neighbourhood faces-edges.'')'
 112       texte(2,5) = '(''Request : '',i6)'
 113       texte(2,6) = '(''Bad request.'')'
 114 c
 115 #ifdef _DEBUG_HOMARD_
 116       write (ulsort,texte(langue,4))
 117       write (ulsort,texte(langue,5)) option
 118 #endif
 119 c
 120       codret = 0
 121 c
 122 c====
 123 c 2. Controle de l'option
 124 c====
 125 c
 126 #ifdef _DEBUG_HOMARD_
 127       write (ulsort,*) '2. Controle option ; codret =',codret
 128 #endif
 129       if ( codret.eq.0 ) then
 130 c
 131       if ( option.lt.-1 .or. option.gt.2 ) then
 132 c
 133         write (ulsort,texte(langue,5)) option
 134         write (ulsort,texte(langue,6))
 135         codret = 2
 136 c
 137       endif
 138 c
 139       endif
 140 c
 141 c====
 142 c 3. recuperation des donnees du maillage d'entree
 143 c    remarque : on relit les nombres d'entites car les communs ne
 144 c               sont pas forcement remplis
 145 c====
 146 c
 147       if ( option.eq.1 .or. option.eq.2 ) then
 148 c
 149         if ( codret.eq.0 ) then
 150 c
 151         call gmliat ( nharet, 1, nbarto, codre1 )
 152         call gmliat ( nhtria, 1, nbtrto, codre2 )
 153         if ( nbtrto.ne.0 ) then
 154           call gmadoj ( nhtria//'.ConnDesc', paretr, iaux, codre3 )
 155         else
 156           codre3 = 0
 157         endif
 158         call gmliat ( nhquad, 1, nbquto, codre4 )
 159         if ( nbquto.ne.0 ) then
 160           call gmadoj ( nhquad//'.ConnDesc', parequ, iaux, codre5 )
 161         else
 162           codre5 = 0
 163         endif
 164 c
 165         codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 166         codret = max ( abs(codre0), codret,
 167      >                 codre1, codre2, codre3, codre4, codre5 )
 168 c
 169         endif
 170 c
 171       endif
 172 c
 173 c====
 174 c 4. Si on cree ou si on detruit, on commence par supprimer le graphe
 175 c====
 176 c
 177 #ifdef _DEBUG_HOMARD_
 178       write (ulsort,*) '4. suppression ; codret =',codret
 179 #endif
 180 c
 181       if ( option.eq.-1 .or. option.eq.1 .or. option.eq.2 ) then
 182 c
 183         if ( codret.eq.0 ) then
 184 c
 185         call gmobal ( nhvois//'.1D/2D', codre1 )
 186 c
 187         if ( codre1.eq.0 ) then
 188           codret = 0
 189 c
 190         elseif ( codre1.eq.1 ) then
 191 #ifdef _DEBUG_HOMARD_
 192       write (ulsort,*) '.... Suppression de nhvois.1D/2D'
 193 #endif
 194           call gmsgoj ( nhvois//'.1D/2D', codret )
 195 c
 196         else
 197           codret = 2
 198 c
 199         endif
 200 c
 201         endif
 202 c
 203       endif
 204 c
 205 c====
 206 c 5. Creation
 207 c====
 208 c
 209 #ifdef _DEBUG_HOMARD_
 210       write (ulsort,*) '5. Creation ; codret =',codret
 211 #endif
 212 c
 213       if ( option.eq.1 .or. option.eq.2 ) then
 214 c
 215 c 5.1. ==> Allocation de la tete
 216 c
 217         if ( codret.eq.0 ) then
 218 c
 219 #ifdef _DEBUG_HOMARD_
 220       write (ulsort,*) '.... Allocation de nhvois.1D/2D'
 221 #endif
 222         call gmaloj ( nhvois//'.1D/2D' , ' ', 0, iaux, codret )
 223 c
 224         endif
 225 c
 226 c 5.2. ==> determination des faces voisines des aretes
 227 c
 228 #ifdef _DEBUG_HOMARD_
 229       write (ulsort,*) '5.2. ==> determination ... ; codret =',codret
 230 #endif
 231 c
 232 c 5.2.1. ==> comptage du nombre de faces pour chaque arete
 233 c
 234         if ( codret.eq.0 ) then
 235 c
 236         iaux = nbarto+1
 237         call gmecat ( nhvois//'.1D/2D', 1, iaux, codre1 )
 238         call gmaloj ( nhvois//'.1D/2D.Pointeur',
 239      >                ' ', iaux, pposif, codre2 )
 240         codre0 = min ( codre1, codre2 )
 241         codret = max ( abs(codre0), codret,
 242      >                 codre1, codre2 )
 243 c
 244         endif
 245 c
 246         if ( codret.eq.0 ) then
 247 c
 248 #ifdef _DEBUG_HOMARD_
 249       write (ulsort,texte(langue,3)) 'UTFAA1', nompro
 250 #endif
 251         call utfaa1 ( nbarto, nbtrto, nbquto,
 252      >                nbarto, nbtrto, nbquto,
 253      >                imem(paretr), imem(parequ),
 254      >                nbfaar, imem(pposif) )
 255 c
 256         endif
 257 c
 258 c 5.2.2. ==> allocation du tableau des voisines a une taille
 259 c            egale au nombre cumule de voisines des aretes,
 260 c            puis reperage des faces voisines
 261 c
 262         if ( codret.eq.0 ) then
 263 c
 264         call gmecat ( nhvois//'.1D/2D', 2, nbfaar, codre1 )
 265         call gmaloj ( nhvois//'.1D/2D.Table',
 266      >                ' ', nbfaar, pfacar, codre2 )
 267         codre0 = min ( codre1, codre2 )
 268         codret = max ( abs(codre0), codret,
 269      >                 codre1, codre2 )
 270 c
 271         endif
 272 c
 273         if ( codret.eq.0 ) then
 274 c
 275 #ifdef _DEBUG_HOMARD_
 276       write (ulsort,texte(langue,3)) 'UTFAA2', nompro
 277 #endif
 278         call utfaa2 ( nbtrto, nbquto,
 279      >                nbtrto, nbquto,
 280      >                imem(paretr), imem(parequ),
 281      >                nbfaar, imem(pposif), imem(pfacar) )
 282 c
 283 #ifdef _DEBUG_HOMARD_
 284       call gmprsx (nompro, nhvois//'.1D/2D' )
 285       call gmprot (nompro, nhvois//'.1D/2D.Pointeur', 1, 50 )
 286       call gmprot (nompro, nhvois//'.1D/2D.Table', 1, 50 )
 287 #endif
 288 c
 289         endif
 290 c
 291       endif
 292 c
 293 c====
 294 c 6. la fin
 295 c====
 296 c
 297       if ( codret.ne.0 ) then
 298 c
 299 #include "envex2.h"
 300 c
 301       write (ulsort,texte(langue,1)) 'Sortie', nompro
 302       write (ulsort,texte(langue,2)) codret
 303 c
 304       endif
 305 c
 306 #ifdef _DEBUG_HOMARD_
 307       write (ulsort,texte(langue,1)) 'Sortie', nompro
 308       call dmflsh (iaux)
 309 #endif
 310 c
 311       end