src/tool/Utilitaire/utvgan.F

   1       subroutine utvgan ( nhvois, nhnoeu, nharet,
   2      >                    option,
   3      >                    ppovos, pvoiso,
   4      >                    ulsort, langue, codret)
   5 c
   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    UTilitaire - VoisinaGe Aretes-Noeuds
  27 c    --           -      -  -      -
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . nhvois . e   . char8  . nom de l'objet voisinage                   .
  33 c . nhnoeu . e   . char8  . nom de l'objet decrivant les noeuds        .
  34 c . nharet . e   . char8  . nom de l'objet decrivant les aretes        .
  35 c . option . e   .   1    . pilotage des voisins des noeuds :          .
  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 . ppovos .   s .   1    . adresse du pointeur des vois. des sommets  .
  41 c . pvoiso .   s .   1    . adresse des voisins des sommets            .
  42 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  43 c . langue . e   .    1   . langue des messages                        .
  44 c .        .     .        . 1 : francais, 2 : anglais                  .
  45 c . codret . es  .    1   . code de retour des modules                 .
  46 c .        .     .        . 0 : pas de probleme                        .
  47 c .        .     .        . 2 : probleme                               .
  48 c ______________________________________________________________________
  49 c
  50 c====
  51 c 0. declarations et dimensionnement
  52 c====
  53 c
  54 c 0.1. ==> generalites
  55 c
  56       implicit none
  57       save
  58 c
  59       character*6 nompro
  60       parameter ( nompro = 'UTVGAN' )
  61 c
  62 #include "nblang.h"
  63 c
  64 c 0.2. ==> communs
  65 c
  66 #include "envex1.h"
  67 c
  68 #include "gmenti.h"
  69 c
  70 #include "nombno.h"
  71 #include "nombar.h"
  72 c
  73 c 0.3. ==> arguments
  74 c
  75       character*8 nhvois, nhnoeu, nharet
  76 c
  77       integer option
  78       integer ppovos, pvoiso
  79 c
  80       integer ulsort, langue, codret
  81 c
  82 c 0.4. ==> variables locales
  83 c
  84       integer iaux
  85       integer codre1, codre2, codre3
  86       integer codre0
  87 c
  88       integer psomar
  89       integer nvosom
  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. 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) = '(''Voisinage aretes-noeuds.'')'
 110       texte(1,5) = '(''Demande : '',i6)'
 111       texte(1,6) = '(''Mauvaise demande.'')'
 112       texte(1,7) = '(''. Objet '',a,'' : '',a)'
 113 c
 114       texte(2,4) = '(''Neighbourhood edges-nodes.'')'
 115       texte(2,5) = '(''Request : '',i6)'
 116       texte(2,6) = '(''Bad request.'')'
 117       texte(2,7) = '(''. Objet '',a,'' : '',a)'
 118 c
 119 #ifdef _DEBUG_HOMARD_
 120       write (ulsort,texte(langue,4))
 121       write (ulsort,texte(langue,5)) option
 122       write (ulsort,texte(langue,7)) 'nhnoeu', nhnoeu
 123       call gmprsx (nompro, nhnoeu )
 124       write (ulsort,texte(langue,7)) 'nharet', nharet
 125       call gmprsx (nompro, nharet )
 126       call gmprot (nompro, nharet//'.ConnDesc', 1, min(2*nbarto,50) )
 127       write (ulsort,texte(langue,7)) 'nhvois', nhvois
 128       call gmprsx (nompro, nhvois )
 129       call gmprsx (nompro, nhvois//'.0D/1D' )
 130 #endif
 131 c
 132       codret = 0
 133 c
 134 c====
 135 c 2. Controle de l'option
 136 c====
 137 c
 138 #ifdef _DEBUG_HOMARD_
 139       write (ulsort,*) '2. Controle option ; codret =',codret
 140 #endif
 141       if ( codret.eq.0 ) then
 142 c
 143       if ( option.lt.-1 .or. option.gt.2 ) then
 144 c
 145         write (ulsort,texte(langue,5)) option
 146         write (ulsort,texte(langue,6))
 147         codret = 2
 148 c
 149       endif
 150 c
 151       endif
 152 c
 153 c====
 154 c 3. recuperation des donnees du maillage d'entree
 155 c    remarque : on relit les nombres d'entites car les communs ne
 156 c               sont pas forcement remplis
 157 c====
 158 #ifdef _DEBUG_HOMARD_
 159       write (ulsort,*) '3. recuperation ; codret =',codret
 160 #endif
 161 c
 162       if ( option.eq.1 .or. option.eq.2 ) then
 163 c
 164         if ( codret.eq.0 ) then
 165 c
 166         call gmliat ( nhnoeu, 1, nbnoto, codre1 )
 167         call gmliat ( nharet, 1, nbarto, codre2 )
 168         call gmadoj ( nharet//'.ConnDesc', psomar, iaux, codre3 )
 169 c
 170         codre0 = min ( codre1, codre2, codre3 )
 171         codret = max ( abs(codre0), codret,
 172      >                 codre1, codre2, codre3 )
 173 c
 174         endif
 175 c
 176       endif
 177 c
 178 c====
 179 c 4. Si on cree ou si on detruit, on commence par supprimer le graphe
 180 c====
 181 c
 182 #ifdef _DEBUG_HOMARD_
 183       write (ulsort,*) '4. suppression ; codret =',codret
 184 #endif
 185 c
 186       if ( option.eq.-1 .or. option.eq.1 .or. option.eq.2 ) then
 187 c
 188         if ( codret.eq.0 ) then
 189 c
 190           call gmobal ( nhvois//'.0D/1D', codre1 )
 191 c
 192           if ( codre1.eq.0 ) then
 193             codret = 0
 194 c
 195           elseif ( codre1.eq.1 ) then
 196 #ifdef _DEBUG_HOMARD_
 197       write (ulsort,*) '.... Suppression de nhvois.0D/1D'
 198 #endif
 199             call gmsgoj ( nhvois//'.0D/1D', codret )
 200 c
 201           else
 202             codret = 2
 203 c
 204           endif
 205 c
 206         endif
 207 c
 208       endif
 209 c
 210 c====
 211 c 5. Creation
 212 c====
 213 c
 214 #ifdef _DEBUG_HOMARD_
 215       write (ulsort,*) '5. Creation ; codret =',codret
 216 #endif
 217 c
 218       if ( option.eq.1 .or. option.eq.2 ) then
 219 c
 220 c 5.1. ==> Allocation de la tete
 221 c
 222         if ( codret.eq.0 ) then
 223 c
 224 #ifdef _DEBUG_HOMARD_
 225       write (ulsort,*) '.... Allocation de nhvois.0D/1D'
 226 #endif
 227 c
 228         call gmaloj ( nhvois//'.0D/1D' , ' ', 0, iaux, codret )
 229 c
 230         endif
 231 c
 232 c 5.2. ==> determination des aretes voisines des noeuds
 233 c
 234 #ifdef _DEBUG_HOMARD_
 235       write (ulsort,*) '5.2. ==> determination ... ; codret =',codret
 236 #endif
 237 c
 238 c 5.2.1. ==> comptage du nombre d'aretes pour chaque noeud
 239 c
 240         if ( codret.eq.0 ) then
 241 c
 242         iaux = nbnoto+1
 243         call gmecat ( nhvois//'.0D/1D', 1, iaux, codre1 )
 244         call gmaloj ( nhvois//'.0D/1D.Pointeur',
 245      >                ' ', iaux, ppovos, codre2 )
 246         codre0 = min ( codre1, codre2 )
 247         codret = max ( abs(codre0), codret,
 248      >                 codre1, codre2 )
 249 c
 250         endif
 251 c
 252         if ( codret.eq.0 ) then
 253 c
 254 #ifdef _DEBUG_HOMARD_
 255         write (ulsort,texte(langue,3)) 'UTVGA1', nompro
 256 #endif
 257 c
 258         call utvga1 ( nbnoto, nbarto, nvosom,
 259      >                imem(psomar), imem(ppovos) )
 260 c
 261         endif
 262 c
 263 c 5.2.2. ==> allocation du tableau des voisines a une taille
 264 c          egale au nombre cumule de voisines des noeuds,
 265 c          puis reperage des aretes voisines
 266 c
 267         if ( codret.eq.0 ) then
 268 c
 269         call gmecat ( nhvois//'.0D/1D', 2, nvosom, codre1 )
 270         call gmaloj ( nhvois//'.0D/1D.Table',
 271      >                ' ', nvosom, pvoiso, codre2 )
 272         codre0 = min ( codre1, codre2 )
 273         codret = max ( abs(codre0), codret,
 274      >                 codre1, codre2 )
 275 c
 276         endif
 277 c
 278         if ( codret.eq.0 ) then
 279 c
 280 #ifdef _DEBUG_HOMARD_
 281 cgn      call gmprsx (nompro, nhvois//'.0D/1D' )
 282 cgn      call gmprot (nompro, nhvois//'.0D/1D.Pointeur', 1, 50 )
 283         write (ulsort,texte(langue,3)) 'UTVGA2', nompro
 284 #endif
 285 c
 286         call utvga2 ( nbnoto, nbarto, nvosom,
 287      >                imem(psomar), imem(ppovos), imem(pvoiso) )
 288 c
 289 #ifdef _DEBUG_HOMARD_
 290       call gmprsx (nompro, nhvois//'.0D/1D' )
 291       call gmprot (nompro, nhvois//'.0D/1D.Pointeur', 1, 50 )
 292       call gmprot (nompro, nhvois//'.0D/1D.Table', 1, 50 )
 293 #endif
 294 c
 295         endif
 296 c
 297       endif
 298 c
 299 c====
 300 c 6. la fin
 301 c====
 302 c
 303       if ( codret.ne.0 ) then
 304 c
 305 #include "envex2.h"
 306 c
 307       write (ulsort,texte(langue,1)) 'Sortie', nompro
 308       write (ulsort,texte(langue,2)) codret
 309 c
 310       endif
 311 c
 312 #ifdef _DEBUG_HOMARD_
 313       write (ulsort,texte(langue,1)) 'Sortie', nompro
 314       call dmflsh (iaux)
 315 #endif
 316 c
 317       end