src/tool/Utilitaire/utnc04.F

   1       subroutine utnc04 ( nbanci, arreca, arrecb,
   2      >                    nouare, tabaux,
   3      >                    arenoe,
   4      >                    somare, hetare, np2are,
   5      >                    merare, filare, insoar,
   6      >                    coexar, narsho, narsca,
   7      >                    ngenar,
   8      >                    aretri, arequa,
   9      >                    ulsort, langue, codret )
  10 c ______________________________________________________________________
  11 c
  12 c                             H O M A R D
  13 c
  14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  15 c
  16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  17 c aupres des huissiers de justice Simart et Lavoir a Clamart
  18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  19 c aupres des huissiers de justice
  20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  21 c
  22 c    HOMARD est une marque deposee d'Electricite de France
  23 c
  24 c Copyright EDF 1996
  25 c Copyright EDF 1998
  26 c Copyright EDF 2002
  27 c Copyright EDF 2020
  28 c ______________________________________________________________________
  29 c
  30 c    UTilitaire - Non Conformite - phase 04
  31 c    --           -   -                  --
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c .____________________________________________________________________.
  36 c . nbanci . e   .    1   . nombre d'aretes de non conformite initiale .
  37 c .        .     .        . egal au nombre d'aretes recouvrant 2 autres.
  38 c . arreca . es  .2*nbanci. liste des aretes recouvrant une autre      .
  39 c . arrecb . es  .2*nbanci. liste des aretes recouvertes par une autre .
  40 c . nouare . e   . nbarto . nouveau numero des aretes                  .
  41 c . tabaux . a   .   *    . tableau auxiliaire                         .
  42 c . arenoe . es  . nbnoto . 0 pour un sommet, le numero de l'arete pour.
  43 c .        .     .        . un noeud milieu                            .
  44 c . somare . es  .2*nbarto. numeros des extremites d'arete             .
  45 c . hetare . es  . nbarto . historique de l'etat des aretes            .
  46 c . np2are . es  . nbarto . noeud milieux des aretes                   .
  47 c . merare . es  . nbarto . mere des aretes                            .
  48 c . filare . es  . nbarto . premiere fille des aretes                  .
  49 c . insoar . es  . nbarto . information sur les sommets des aretes     .
  50 c . coexar . es  . nbarto*. codes de conditions aux limites portants   .
  51 c .        .     . nctfar . sur les aretes                             .
  52 c . narsho . es  . rsarac . numero des aretes dans HOMARD              .
  53 c . narsca . es  . rsarto . numero des aretes du calcul                .
  54 c . ngenar . es  . nbarto . nombre de generations au-dessus des aretes .
  55 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  56 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  57 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  58 c . langue . e   .    1   . langue des messages                        .
  59 c .        .     .        . 1 : francais, 2 : anglais                  .
  60 c . codret . es  .    1   . code de retour des modules                 .
  61 c .        .     .        . 0 : pas de probleme                        .
  62 c ______________________________________________________________________
  63 c
  64 c====
  65 c 0. declarations et dimensionnement
  66 c====
  67 c
  68 c 0.1. ==> generalites
  69 c
  70       implicit none
  71       save
  72 c
  73       character*6 nompro
  74       parameter ( nompro = 'UTNC04' )
  75 c
  76 #include "nblang.h"
  77 c
  78 c 0.2. ==> communs
  79 c
  80 #include "envex1.h"
  81 c
  82 #include "nombno.h"
  83 #include "nombar.h"
  84 #include "nombtr.h"
  85 #include "nombqu.h"
  86 #include "envca1.h"
  87 #include "dicfen.h"
  88 #include "nbutil.h"
  89 #include "nombsr.h"
  90 c
  91 c 0.3. ==> arguments
  92 c
  93       integer nbanci
  94       integer arreca(2*nbanci), arrecb(2*nbanci)
  95       integer nouare(0:nbarto)
  96       integer tabaux(*)
  97       integer arenoe(nbnoto)
  98       integer somare(2,nbarto), hetare(nbarto), np2are(nbarto)
  99       integer filare(nbarto), merare(nbarto), insoar(nbarto)
 100       integer coexar(nbarto,nctfar)
 101       integer narsho(rsarac), narsca(rsarto)
 102       integer ngenar(nbarto)
 103       integer aretri(nbtrto,3)
 104       integer arequa(nbquto,4)
 105 c
 106       integer ulsort, langue, codret
 107 c
 108 c 0.4. ==> variables locales
 109 c
 110       integer iaux, jaux, kaux
 111       integer ifin
 112 c
 113       logical afaire
 114 c
 115       integer nbmess
 116       parameter ( nbmess = 10 )
 117       character*80 texte(nblang,nbmess)
 118 c
 119 c 0.5. ==> initialisations
 120 c ______________________________________________________________________
 121 c
 122 c====
 123 c 1. preliminaires
 124 c====
 125 c
 126 c 1.1. ==> messages
 127 c
 128 #include "impr01.h"
 129 c
 130 #ifdef _DEBUG_HOMARD_
 131       write (ulsort,texte(langue,1)) 'Entree', nompro
 132       call dmflsh (iaux)
 133
 134 #endif
 135 c
 136       codret = 0
 137 c
 138 c====
 139 c 2. A-t-on vraiment besoin ?
 140 c====
 141 c
 142       afaire = .false.
 143       do 21 , iaux = 1 , nbarto
 144 c
 145         if ( nouare(iaux).ne.iaux ) then
 146 cgn      print *,iaux, nouare(iaux)
 147           afaire = .true.
 148           goto 29
 149         endif
 150 c
 151    21 continue
 152 c
 153    29 continue
 154 cgn      print *, 'afaire = ',afaire
 155 c
 156       if ( afaire ) then
 157 c
 158 c====
 159 c 3. Prise en compte du changement de numerotation des aretes
 160 c    dans les tableaux de reperage des non conformites
 161 c====
 162 c
 163       ifin = 2*nbanci
 164       do 31 , iaux = 1 , ifin
 165 cgn      if ( iaux.eq.10 .or. iaux.eq.15 ) then
 166 cgn          write (ulsort,*) 'arreca(',iaux,') = ',arreca(iaux)
 167 cgn          write (ulsort,*) 'arrecb(',iaux,') = ',arrecb(iaux)
 168 cgn      write (ulsort,*)'nouare(',arreca(iaux),') = ',nouare(arreca(iaux))
 169 cgn      write (ulsort,*)'nouare(',arrecb(iaux),') = ',nouare(arrecb(iaux))
 170 cgn      endif
 171 c
 172         arreca(iaux) = nouare(arreca(iaux))
 173         arrecb(iaux) = nouare(arrecb(iaux))
 174 c
 175    31 continue
 176 c
 177 c====
 178 c 4. Renumerotation des aretes liees aux noeuds
 179 c====
 180 c
 181       do 41 , iaux = 1 , nbnoto
 182 c
 183         arenoe(iaux) = nouare(arenoe(iaux))
 184 c
 185    41 continue
 186 c
 187 c====
 188 c 5. Renumerotation des caracteristiques liees aux aretes
 189 c====
 190 c 5.1. ==> Sommets
 191 c
 192       if ( codret.eq.0 ) then
 193 c
 194       iaux = 1
 195       jaux = 2
 196 #ifdef _DEBUG_HOMARD_
 197       write (ulsort,texte(langue,3)) 'UTCHNU - somare', nompro
 198 #endif
 199       call utchnu ( iaux, nbarto, nouare,
 200      >              jaux, nbarto, somare,
 201      >              tabaux,
 202      >              ulsort, langue, codret )
 203 c
 204       endif
 205 c
 206 c 5.2. ==> Historiques de l'etat
 207 c
 208       if ( codret.eq.0 ) then
 209 c
 210       iaux = 1
 211       jaux = 1
 212 #ifdef _DEBUG_HOMARD_
 213       write (ulsort,texte(langue,3)) 'UTCHNU - hetare', nompro
 214 #endif
 215       call utchnu ( iaux, nbarto, nouare,
 216      >              jaux, nbarto, hetare,
 217      >              tabaux,
 218      >              ulsort, langue, codret )
 219 c
 220       endif
 221 c
 222 c 5.3. ==> Eventuel noeud milieu
 223 c
 224       if ( degre.eq.2 ) then
 225 c
 226         if ( codret.eq.0 ) then
 227 c
 228         iaux = 1
 229         jaux = 1
 230 #ifdef _DEBUG_HOMARD_
 231         write (ulsort,texte(langue,3)) 'UTCHNU - np2are', nompro
 232 #endif
 233         call utchnu ( iaux, nbarto, nouare,
 234      >                jaux, nbarto, np2are,
 235      >                tabaux,
 236      >                ulsort, langue, codret )
 237 c
 238         endif
 239 c
 240       endif
 241 c
 242 c 5.4. ==> Eventuelle information sur les sommets
 243 c
 244       if ( nbelig.gt.0 ) then
 245 c
 246         if ( codret.eq.0 ) then
 247 c
 248         iaux = 1
 249         jaux = 1
 250 #ifdef _DEBUG_HOMARD_
 251         write (ulsort,texte(langue,3)) 'UTCHNU - insoar', nompro
 252 #endif
 253         call utchnu ( iaux, nbarto, nouare,
 254      >                jaux, nbarto, insoar,
 255      >                tabaux,
 256      >                ulsort, langue, codret )
 257 c
 258         endif
 259 c
 260       endif
 261 c
 262 c 5.5. ==> Code externe sur les conditions aux limites
 263 c
 264       if ( codret.eq.0 ) then
 265 c
 266       iaux = 1
 267 #ifdef _DEBUG_HOMARD_
 268       write (ulsort,texte(langue,3)) 'UTCHNU - coexar', nompro
 269 #endif
 270       call utchnu ( iaux, nbarto, nouare,
 271      >              nbarto, nctfar, coexar,
 272      >              tabaux,
 273      >              ulsort, langue, codret )
 274 c
 275       endif
 276 c
 277 c 5.6. ==> Filiation
 278 c
 279       if ( codret.eq.0 ) then
 280 c
 281       do 561 , iaux = 1 , nbarto
 282         filare(iaux) = 0
 283         merare(iaux) = 0
 284   561 continue
 285 c
 286       kaux = 2*nbanci
 287       do 562 , iaux = 1 , kaux
 288         jaux = arreca(iaux)
 289         if ( filare(jaux).eq.0 ) then
 290           filare(jaux) = arrecb(iaux)
 291           hetare(jaux) = 2
 292         else
 293           filare(jaux) = min(arrecb(iaux),filare(jaux))
 294         endif
 295         merare(arrecb(iaux)) = jaux
 296   562 continue
 297 c
 298       endif
 299 cgn        do jaux=1,nbarto
 300 cgn        print *,filare(jaux),merare(jaux)
 301 cgn        enddo
 302 c
 303 c 5.7. ==> Eventuelle renumerotation avec le code de calcul
 304 c
 305       if ( rsarac.gt.0 ) then
 306 c
 307         if ( codret.eq.0 ) then
 308 c
 309         iaux = 2
 310         jaux = 1
 311 #ifdef _DEBUG_HOMARD_
 312         write (ulsort,texte(langue,3)) 'UTCHNU - narsho', nompro
 313 #endif
 314         call utchnu ( iaux, nbarto, nouare,
 315      >                jaux, rsarac, narsho,
 316      >                tabaux,
 317      >                ulsort, langue, codret )
 318 c
 319         endif
 320 c
 321       endif
 322 c
 323       if ( rsarto.gt.0 ) then
 324 c
 325         if ( codret.eq.0 ) then
 326 c
 327         iaux = 1
 328         jaux = 1
 329 #ifdef _DEBUG_HOMARD_
 330         write (ulsort,texte(langue,3)) 'UTCHNU - narsca', nompro
 331 #endif
 332         call utchnu ( iaux, nbarto, nouare,
 333      >                jaux, rsarto, narsca,
 334      >                tabaux,
 335      >                ulsort, langue, codret )
 336 c
 337         endif
 338 c
 339       endif
 340 c
 341 c 5.8. ==> Nombre de generations de l'ascendance
 342 c
 343       if ( codret.eq.0 ) then
 344 c
 345       iaux = 1
 346       jaux = 1
 347 #ifdef _DEBUG_HOMARD_
 348       write (ulsort,texte(langue,3)) 'UTCHNU - ngenar', nompro
 349 #endif
 350       call utchnu ( iaux, nbarto, nouare,
 351      >              jaux, nbarto, ngenar,
 352      >              tabaux,
 353      >              ulsort, langue, codret )
 354 c
 355       endif
 356 c
 357 c====
 358 c 6. Renumerotation des aretes definissant les triangles
 359 c====
 360 c
 361       if ( nbtrto.gt.0 ) then
 362 c
 363         if ( codret.eq.0 ) then
 364 c
 365 #ifdef _DEBUG_HOMARD_
 366         write (ulsort,texte(langue,3)) 'UTCHNU - aretri', nompro
 367 #endif
 368         iaux = 2
 369         jaux = 3
 370         call utchnu ( iaux, nbarto, nouare,
 371      >                nbtrto, jaux, aretri,
 372      >                tabaux,
 373      >                ulsort, langue, codret )
 374 c
 375         endif
 376 cgn        do jaux=1,nbtrto
 377 cgn        print *,(aretri(jaux,iaux),iaux=1,3)
 378 cgn        enddo
 379 c
 380       endif
 381 c
 382 c====
 383 c 7. Renumerotation des aretes definissant les quadrangles
 384 c====
 385 c
 386       if ( nbquto.gt.0 ) then
 387 c
 388         if ( codret.eq.0 ) then
 389 c
 390 #ifdef _DEBUG_HOMARD_
 391         write (ulsort,texte(langue,3)) 'UTCHNU - arequa', nompro
 392 #endif
 393         iaux = 2
 394         jaux = 4
 395         call utchnu ( iaux, nbarto, nouare,
 396      >                nbquto, jaux, arequa,
 397      >                tabaux,
 398      >                ulsort, langue, codret )
 399 c
 400         endif
 401 cgn        do jaux=1,nbquto
 402 cgn        print *,(arequa(jaux,iaux),iaux=1,4)
 403 cgn        enddo
 404 c
 405       endif
 406 c
 407       endif
 408 c
 409 c====
 410 c 8. la fin
 411 c====
 412 c
 413       if ( codret.ne.0 ) then
 414 c
 415 #include "envex2.h"
 416 c
 417       write (ulsort,texte(langue,1)) 'Sortie', nompro
 418       write (ulsort,texte(langue,2)) codret
 419 c
 420       endif
 421 c
 422 #ifdef _DEBUG_HOMARD_
 423       write (ulsort,texte(langue,1)) 'Sortie', nompro
 424       call dmflsh (iaux)
 425 #endif
 426 c
 427       end