src/tool/Utilitaire/utnc06.F

   1       subroutine utnc06 ( option,
   2      >                    nounoe, tabaux, tbdaux,
   3      >                    coonoe, hetnoe, arenoe,
   4      >                    coexno, nnosho, nnosca,
   5      >                    ngenno,
   6      >                    noempo,
   7      >                    somare,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    UTilitaire - Non Conformite - phase 06
  30 c    --           -   -                  --
  31 c    Prise en compte des renumerotations des noeuds
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c .____________________________________________________________________.
  36 c . option . e   .    1   . 0 : on renumerote tout                     .
  37 c .        .     .        . 1 : on ne renumerote pas ngenno            .
  38 c . nounoe . e   . nbarto . nouveau numero des noeuds                  .
  39 c . tabaux . a   .   *    . tableau auxiliaire entier                  .
  40 c . tbdaux . a   .   *    . tableau auxiliaire reel                    .
  41 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  42 c .        .     . * sdim .                                            .
  43 c . hetnoe . es  . nbnoto . historique de l'etat des noeuds            .
  44 c . arenoe . es  . nbnoto . 0 pour un sommet, le numero de l'arete pour.
  45 c .        .     .        . un noeud milieu                            .
  46 c . coexno . es  . nbnoto*. codes de conditions aux limites portants   .
  47 c .        .     . nctfno . sur les noeuds                             .
  48 c . nnosho . es  . rsnoac . numero des noeuds dans HOMARD              .
  49 c . nnosca . es  . rsnoto . numero des noeuds dans le calcul           .
  50 c . ngenno . es  . nbnoto . nombre de generations au-dessus des noeuds .
  51 c . noempo . es  . nbmpto . numeros des noeuds associes aux mailles    .
  52 c . somare . es  .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 ______________________________________________________________________
  59 c
  60 c====
  61 c 0. declarations et dimensionnement
  62 c====
  63 c
  64 c 0.1. ==> generalites
  65 c
  66       implicit none
  67       save
  68 c
  69       character*6 nompro
  70       parameter ( nompro = 'UTNC06' )
  71 c
  72 #include "nblang.h"
  73 c
  74 c 0.2. ==> communs
  75 c
  76 #include "impr02.h"
  77 #include "envex1.h"
  78 c
  79 #include "nombno.h"
  80 #include "nombmp.h"
  81 #include "nombar.h"
  82 #include "envca1.h"
  83 #include "dicfen.h"
  84 #include "nombsr.h"
  85 c
  86 c 0.3. ==> arguments
  87 c
  88       integer option
  89       integer nounoe(0:nbnoto)
  90       integer tabaux(*)
  91       integer hetnoe(nbnoto), arenoe(nbnoto)
  92       integer ngenno(nbnoto)
  93       integer noempo(nbmpto)
  94       integer somare(2,nbarto)
  95       integer coexno(nbnoto,nctfno)
  96       integer nnosho(rsnoac), nnosca(rsnoto)
  97 c
  98       double precision tbdaux(nbnoto,sdim)
  99       double precision coonoe(nbnoto,sdim)
 100 c
 101       integer ulsort, langue, codret
 102 c
 103 c 0.4. ==> variables locales
 104 c
 105       integer iaux, jaux
 106 c
 107       logical afaire
 108 c
 109       integer nbmess
 110       parameter ( nbmess = 10 )
 111       character*80 texte(nblang,nbmess)
 112 c
 113 c 0.5. ==> initialisations
 114 c ______________________________________________________________________
 115 c
 116 c====
 117 c 1. preliminaires
 118 c====
 119 c
 120 c 1.1. ==> messages
 121 c
 122 #include "impr01.h"
 123 c
 124 #ifdef _DEBUG_HOMARD_
 125       write (ulsort,texte(langue,1)) 'Entree', nompro
 126       call dmflsh (iaux)
 127 #endif
 128 c
 129       texte(1,4) =
 130      > '(''Renumerotation complete des tableaux lies aux '',a)'
 131       texte(1,5) =
 132      > '(''Renumerotation des tableaux lies aux '',a,''sauf ngenno'')'
 133       texte(1,6) = '(''Examen du '',a,i10)'
 134 c
 135       texte(2,4) = '(''Total renumbering of arrays connected to '',a)'
 136       texte(2,5) =
 137      > '(''Renumbering of arrays connected to '',a,''except ngenno'')'
 138       texte(2,6) = '(''Examination of '',a,i10)'
 139 c
 140       codret = 0
 141 c
 142 #ifdef _DEBUG_HOMARD_
 143       if ( option.eq.0 ) then
 144         write (ulsort,texte(langue,4)) mess14(langue,3,-1)
 145       else
 146         write (ulsort,texte(langue,5)) mess14(langue,3,-1)
 147       endif
 148 #endif
 149 c
 150 c====
 151 c 2. A-t-on vraiment besoin ?
 152 c====
 153 c
 154       afaire = .false.
 155       do 21 , iaux = 1 , nbnoto
 156 c
 157         if ( nounoe(iaux).ne.iaux ) then
 158 cgn      print *,iaux, nounoe(iaux)
 159           afaire = .true.
 160           goto 29
 161         endif
 162 c
 163    21 continue
 164 c
 165    29 continue
 166 cgn      print *, 'afaire = ',afaire
 167 c
 168       if ( afaire ) then
 169 c
 170 c====
 171 c 3. Renumerotation des caracteristiques liees aux noeuds
 172 c====
 173 c 3.1. ==> Coordonnees
 174 c
 175       if ( codret.eq.0 ) then
 176 c
 177       do 311 , iaux = 1 , nbnoto
 178         do 3111 , jaux = 1 , sdim
 179           tbdaux(iaux,jaux) = coonoe(iaux,jaux)
 180  3111   continue
 181   311 continue
 182 c
 183       do 312 , iaux = 1 , nbnoto
 184 c
 185 cgn      write (ulsort,*) iaux,' ==> ',nounoe(iaux)
 186         if ( nounoe(iaux).ne.iaux ) then
 187 #ifdef _DEBUG_HOMARD_
 188       write (ulsort,texte(langue,6)) mess14(langue,1,-1), iaux
 189 #endif
 190           do 3121 , jaux = 1 , sdim
 191             coonoe(nounoe(iaux),jaux) = tbdaux(iaux,jaux)
 192  3121     continue
 193         endif
 194 c
 195   312 continue
 196 c
 197       endif
 198 c
 199 c 3.2. ==> Historiques de l'etat
 200 c
 201       if ( codret.eq.0 ) then
 202 c
 203       iaux = 1
 204       jaux = 1
 205 #ifdef _DEBUG_HOMARD_
 206       write (ulsort,texte(langue,3)) 'UTCHNU - hetnoe', nompro
 207 #endif
 208       call utchnu ( iaux, nbnoto, nounoe,
 209      >              jaux, nbnoto, hetnoe,
 210      >              tabaux,
 211      >              ulsort, langue, codret )
 212 c
 213       endif
 214 c
 215 c 3.3. ==> Code externe sur les conditions aux limites
 216 c
 217       if ( codret.eq.0 ) then
 218 c
 219       iaux = 1
 220 #ifdef _DEBUG_HOMARD_
 221       write (ulsort,texte(langue,3)) 'UTCHNU - coexno', nompro
 222 #endif
 223       call utchnu ( iaux, nbnoto, nounoe,
 224      >              nbnoto, nctfno, coexno,
 225      >              tabaux,
 226      >              ulsort, langue, codret )
 227 c
 228       endif
 229 c
 230 c 3.4. ==> Arete sur le noeud
 231 c
 232       if ( codret.eq.0 ) then
 233 c
 234       iaux = 1
 235       jaux = 1
 236 #ifdef _DEBUG_HOMARD_
 237       write (ulsort,texte(langue,3)) 'UTCHNU - arenoe', nompro
 238 #endif
 239       call utchnu ( iaux, nbnoto, nounoe,
 240      >              jaux, nbnoto, arenoe,
 241      >              tabaux,
 242      >              ulsort, langue, codret )
 243 c
 244       endif
 245 c
 246 c 3.5. ==> Renumerotation avec le code de calcul
 247 c
 248       if ( codret.eq.0 ) then
 249 c
 250       iaux = 2
 251       jaux = 1
 252 #ifdef _DEBUG_HOMARD_
 253       write (ulsort,texte(langue,3)) 'UTCHNU - nnosho', nompro
 254 #endif
 255       call utchnu ( iaux, nbnoto, nounoe,
 256      >              jaux, rsnoac, nnosho,
 257      >              tabaux,
 258      >              ulsort, langue, codret )
 259 c
 260       endif
 261 c
 262       if ( codret.eq.0 ) then
 263 c
 264       iaux = 1
 265       jaux = 1
 266 #ifdef _DEBUG_HOMARD_
 267       write (ulsort,texte(langue,3)) 'UTCHNU - nnosca', nompro
 268 #endif
 269       call utchnu ( iaux, nbnoto, nounoe,
 270      >              jaux, rsnoto, nnosca,
 271      >              tabaux,
 272      >              ulsort, langue, codret )
 273 c
 274       endif
 275 c
 276 c 3.6. ==> Nombre de generations de l'ascendance
 277 c
 278       if ( codret.eq.0 ) then
 279 c
 280       if ( option.ne.1 ) then
 281 c
 282       iaux = 1
 283       jaux = 1
 284 #ifdef _DEBUG_HOMARD_
 285       write (ulsort,texte(langue,3)) 'UTCHNU - ngenno', nompro
 286 #endif
 287       call utchnu ( iaux, nbnoto, nounoe,
 288      >              jaux, nbnoto, ngenno,
 289      >              tabaux,
 290      >              ulsort, langue, codret )
 291 c
 292       endif
 293 c
 294       endif
 295 c
 296 c====
 297 c 4. Renumerotation des sommets definissant les aretes
 298 c    Il faut corriger eventuellement l'orientation des aretes
 299 c====
 300 c
 301       if ( codret.eq.0 ) then
 302 c
 303 #ifdef _DEBUG_HOMARD_
 304       write (ulsort,texte(langue,3)) 'UTCHNU - somare', nompro
 305 #endif
 306       iaux = 2
 307       jaux = 2
 308       call utchnu ( iaux, nbnoto, nounoe,
 309      >              jaux, nbarto, somare,
 310      >              tabaux,
 311      >              ulsort, langue, codret )
 312 c
 313       endif
 314 c
 315       if ( codret.eq.0 ) then
 316 c
 317       do 41 , iaux = 1 , nbarto
 318         if ( somare(1,iaux).gt.somare(2,iaux) ) then
 319           jaux = somare(1,iaux)
 320           somare(1,iaux) = somare(2,iaux)
 321           somare(2,iaux) = jaux
 322         endif
 323    41 continue
 324 c
 325       endif
 326 c
 327 c====
 328 c 5. Eventuellement, renumerotation des sommets definissant
 329 c    les mailles-points
 330 c====
 331 c
 332       if ( nbmpto.gt.0 ) then
 333 c
 334         if ( codret.eq.0 ) then
 335 c
 336 #ifdef _DEBUG_HOMARD_
 337       write (ulsort,texte(langue,3)) 'UTCHNU - noempo', nompro
 338 #endif
 339         iaux = 2
 340         jaux = 1
 341         call utchnu ( iaux, nbnoto, nounoe,
 342      >                jaux, nbmpto, noempo,
 343      >                tabaux,
 344      >                ulsort, langue, codret )
 345 c
 346         endif
 347 c
 348       endif
 349 c
 350       endif
 351 c
 352 c====
 353 c 6. la fin
 354 c====
 355 c
 356       if ( codret.ne.0 ) then
 357 c
 358 #include "envex2.h"
 359 c
 360       write (ulsort,texte(langue,1)) 'Sortie', nompro
 361       write (ulsort,texte(langue,2)) codret
 362 c
 363       endif
 364 c
 365 #ifdef _DEBUG_HOMARD_
 366       write (ulsort,texte(langue,1)) 'Sortie', nompro
 367       call dmflsh (iaux)
 368 #endif
 369 c
 370       end