src/tool/Decision/decfs2.F

   1       subroutine decfs2 ( disnoe, ancnoe, nounoe,
   2      >                    hetnoe, famnoe, arenoe,
   3      >                    noehom, coonoe,
   4      >                    np2are, somare,
   5      >                    aretri,
   6      >                    hetqua, arequa, filqua,
   7      >                    tritet, cotrte, aretet,
   8      >                    hethex, filhex, fhpyte,
   9      >                    facpyr, cofapy, arepyr,
  10      >                    hetpen, filpen, fppyte,
  11      >                    typind, iindno, rindno,
  12      >                    ulsort, langue, codret )
  13 c ______________________________________________________________________
  14 c
  15 c                             H O M A R D
  16 c
  17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  18 c
  19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  20 c aupres des huissiers de justice Simart et Lavoir a Clamart
  21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  22 c aupres des huissiers de justice
  23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  24 c
  25 c    HOMARD est une marque deposee d'Electricite de France
  26 c
  27 c Copyright EDF 1996
  28 c Copyright EDF 1998
  29 c Copyright EDF 2002
  30 c Copyright EDF 2020
  31 c ______________________________________________________________________
  32 c
  33 c traitement des DEcisions - mise en ConFormite - Suppression - 2
  34 c                --                  -  -         -             -
  35 c Renumerotation des tableaux lies aux noeuds
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . disnoe . aux . nancno . indicateurs de disparition des noeuds      .
  41 c . ancnoe .   s . nbnoto . anciens numeros des noeuds conserves       .
  42 c . nounoe .   s .0:nbnoto. nouveaux numeros des noeuds conserves      .
  43 c . hetnoe . e/s  . nbnoto . historique de l'etat des noeuds           .
  44 c . np2are . e   . nancar . numero des noeuds p2 milieux d'aretes      .
  45 c . somare . e   .2*nancar. numeros des extremites d'arete             .
  46 c . aretri . e   .nanctr*3. numeros des 3 aretes des triangles         .
  47 c . hetqua . e   . nancqu . historique de l'etat des quadrangles       .
  48 c . arequa . e   .nancqu*3. numeros des 4 aretes des quadrangles       .
  49 c . filqua . e   . nancqu . premier fils des quadrangles               .
  50 c . tritet . e   .nancte*4. numeros des triangles des tetraedres       .
  51 c . cotrte . e   .nancte*4. codes des triangles des tetraedres         .
  52 c . aretet . e   .nancta*6. numeros des 6 aretes des tetraedres        .
  53 c . hethex . e   . nanche . historique de l'etat des hexaedres         .
  54 c . filhex . e   . nanche . premier fils des hexaedres                 .
  55 c . fhpyte . e   .  2**   . fhpyte(1,j) = numero de la 1ere pyramide   .
  56 c .        .     .        . fille de l'hexaedre k tel que filhex(k) =-j.
  57 c .        .     .        . fhpyte(2,j) = numero du 1er tetraedre      .
  58 c .        .     .        . fils de l'hexaedre k tel que filhex(k) = -j.
  59 c . facpyr . e   .nancyf*5. numeros des 5 faces des pyramides          .
  60 c . cofapy . e   .nancyf*5. codes des faces des pyramides              .
  61 c . arepyr . e   .nancya*8. numeros des 8 aretes des pyramides         .
  62 c . hetpen . e   . nancpe . historique de l'etat des pentaedres        .
  63 c . filpen . e   . nancpe . premier fils des pentaedres                .
  64 c . fppyte . e   .  2**   . fppyte(1,j) = numero de la 1ere pyramide   .
  65 c .        .     .        . fille du pentaedre k tel que filpen(k) =-j .
  66 c .        .     .        . fppyte(2,j) = numero du 1er tetraedre      .
  67 c .        .     .        . fils du pentaedre k tel que filpen(k) = -j .
  68 c . typind . e   .   1    . type de valeurs pour l'indicateur          .
  69 c .        .     .        . 0 : aucune                                 .
  70 c .        .     .        . 2 : entieres                               .
  71 c .        .     .        . 3 : reelles                                .
  72 c . iindno . e   .   *    . indicateur entier sur les noeuds           .
  73 c . rindno . e   .   *    . indicateur reel sur les noeuds             .
  74 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  75 c . langue . e   .    1   . langue des messages                        .
  76 c .        .     .        . 1 : francais, 2 : anglais                  .
  77 c . codret . es  .    1   . code de retour des modules                 .
  78 c .        .     .        . 0 : pas de probleme                        .
  79 c .        .     .        . 5 : mauvais type de code de calcul associe .
  80 c ______________________________________________________________________
  81 c
  82 c====
  83 c 0. declarations et dimensionnement
  84 c====
  85 c
  86 c 0.1. ==> generalites
  87 c
  88       implicit none
  89       save
  90 c
  91       character*6 nompro
  92       parameter ( nompro = 'DECFS2' )
  93 c
  94 #include "nblang.h"
  95 c
  96 c 0.2. ==> communs
  97 c
  98 #include "envex1.h"
  99 c
 100 #include "impr02.h"
 101 #include "envca1.h"
 102 #include "nancnb.h"
 103 #include "nombno.h"
 104 #include "nombar.h"
 105 #include "hexcf0.h"
 106 c
 107 c 0.3. ==> arguments
 108 c
 109       integer disnoe(nancno)
 110       integer ancnoe(nbnoto), nounoe(0:nancno)
 111       integer hetnoe(nancno), famnoe(nancno)
 112       integer arenoe(nancno), noehom(nancno)
 113       integer np2are(nancar), somare(2,nancar)
 114       integer aretri(nanctr,3)
 115       integer hetqua(nancqu), arequa(nancqu,4), filqua(nancqu)
 116       integer tritet(nanctf,4), cotrte(nanctf,4), aretet(nancta,6)
 117       integer hethex(nanche), filhex(nanche)
 118       integer fhpyte(2,*)
 119       integer facpyr(nancyf,5), cofapy(nancyf,5), arepyr(nancya,8)
 120       integer hetpen(nancpe), filpen(nancpe)
 121       integer fppyte(2,*)
 122       integer typind, iindno(*)
 123 c
 124       double precision coonoe(nancno,sdim)
 125       double precision rindno(*)
 126 c
 127       integer ulsort, langue, codret
 128 c
 129 c 0.4. ==> variables locales
 130 c
 131       integer iaux, jaux
 132       integer letetr, lapyra, lequad, larete, lenoeu
 133       integer listar(8), listso(5)
 134       integer nbnore, nbp2re, nbimre
 135       integer bindec
 136 c
 137       integer etat
 138 c
 139       integer nbmess
 140       parameter ( nbmess = 10 )
 141       character*80 texte(nblang,nbmess)
 142 c
 143 c 0.5. ==> initialisations
 144 c ______________________________________________________________________
 145 c
 146 c====
 147 c 1. messages
 148 c====
 149 c
 150 #include "impr01.h"
 151 c
 152 #ifdef _DEBUG_HOMARD_
 153       write (ulsort,texte(langue,1)) 'Entree', nompro
 154       call dmflsh (iaux)
 155 #endif
 156 c
 157       texte(1,4) = '(''Binaire du decoupage de conformite :'',i5)'
 158 c
 159       texte(2,4) = '(''Cut for conformity; binary code:'',i5)'
 160 c
 161 #include "impr03.h"
 162 c
 163       codret = 0
 164 c
 165 c====
 166 c 2. Reperage des noeuds a faire disparaitre
 167 c====
 168 #ifdef _DEBUG_HOMARD_
 169       write (ulsort,*) '2. Reperage ; codret = ', codret
 170 #endif
 171 cgn      write (ulsort,90002) nompro//'nancno', nancno
 172 c
 173 c 2.1. ==> A priori, tout reste
 174 c
 175       if ( codret.eq.0 ) then
 176 c
 177       do 21 , iaux = 1 , nancno
 178         disnoe(iaux) = 0
 179         ancnoe(iaux) = iaux
 180    21 continue
 181 c
 182       endif
 183 c
 184 c 2.2. ==> Les noeuds P2 sur les aretes de conformite
 185 c
 186       if ( codret.eq.0 ) then
 187 c
 188       do 22 , iaux = nbarpe+1 , nancar
 189 #ifdef _DEBUG_HOMARD_
 190       write (ulsort,90015) 'noeud sur l''arete', iaux, ':', np2are(iaux)
 191 #endif
 192         disnoe(np2are(iaux)) = 1
 193    22 continue
 194 c
 195       endif
 196 c
 197 c 2.3. ==> Les noeuds centraux des quadrangles coupes en 3 quadrangles
 198 c          . Le noeud central est le second sommet de la derniere arete
 199 c            du fils aine (voir cmcdq5 pour les conventions)
 200 c
 201       if ( codret.eq.0 ) then
 202 c
 203       do 23 , iaux = 1 , nancqu
 204 c
 205         etat = mod(hetqua(iaux),100)
 206 c
 207         if ( ( etat.ge.41 .and. etat.le.44 ) ) then
 208 c
 209 #ifdef _DEBUG_HOMARD_
 210           write (ulsort,90002) mess14(langue,2,4), iaux
 211           write (ulsort,texte(langue,4)) etat
 212 #endif
 213           lequad = filqua(iaux)
 214 #ifdef _DEBUG_HOMARD_
 215           write (ulsort,90002) mess14(langue,2,4), lequad
 216 #endif
 217 c
 218           lenoeu = somare(2,arequa(lequad,4))
 219 #ifdef _DEBUG_HOMARD_
 220           write (ulsort,90002) mess14(langue,2,-1), lenoeu
 221 #endif
 222           disnoe(lenoeu) = 1
 223 c
 224         endif
 225 c
 226    23 continue
 227 c
 228       endif
 229 c
 230 c 2.4. ==> Les noeuds centraux des hexaedres coupes
 231 c          Selon l'etat, il y a ou non un sommet interne
 232 c          . le noeud central est le sommet S1 de chacun des tetraedres
 233 c          . le noeud central est le sommet S5 de chacune des pyramides
 234 c
 235       if ( codret.eq.0 ) then
 236 c
 237       do 24 , iaux = 1 , nanche
 238 c
 239         etat = mod(hethex(iaux),1000)
 240 c
 241         if ( etat.gt.10 ) then
 242 c
 243         bindec = chbiet(etat)
 244         if ( chnp1(bindec).gt.0 ) then
 245 c
 246 #ifdef _DEBUG_HOMARD_
 247           write (ulsort,90002) mess14(langue,2,6), iaux
 248           write (ulsort,texte(langue,4)) bindec
 249 #endif
 250           jaux = filhex(iaux)
 251 c
 252 c 2.4.1. ==> Au moins un tetraedre fils
 253 c
 254           if ( chnte(bindec).gt.0 ) then
 255 c
 256             letetr = fhpyte(2,-jaux)
 257 #ifdef _DEBUG_HOMARD_
 258           write (ulsort,90002) mess14(langue,2,3), letetr
 259 #endif
 260 c
 261             call utaste ( letetr,
 262      >                    nanctr, nanctf, nancta,
 263      >                    somare, aretri,
 264      >                    tritet, cotrte, aretet,
 265      >                    listar, listso )
 266 c
 267             lenoeu = listso(1)
 268 #ifdef _DEBUG_HOMARD_
 269           write (ulsort,90002) mess14(langue,2,-1), lenoeu
 270 #endif
 271             disnoe(lenoeu) = 1
 272 c
 273 c 2.4.2. ==> Au moins une pyramide fille
 274 c
 275           elseif ( chnpy(bindec).gt.0 ) then
 276 c
 277             lapyra = fhpyte(1,-jaux)
 278 #ifdef _DEBUG_HOMARD_
 279           write (ulsort,90002) mess14(langue,2,6), lapyra
 280 #endif
 281 c
 282             call utaspy ( lapyra,
 283      >                    nanctr, nancyf, nancya,
 284      >                    somare, aretri,
 285      >                    facpyr, cofapy, arepyr,
 286      >                    listar, listso )
 287 c
 288             lenoeu = listso(5)
 289 #ifdef _DEBUG_HOMARD_
 290           write (ulsort,90002) mess14(langue,2,-1), lenoeu
 291 #endif
 292             disnoe(lenoeu) = 1
 293 c
 294           endif
 295 c
 296         endif
 297 c
 298         endif
 299 c
 300    24 continue
 301 c
 302       endif
 303 c
 304 c 2.5. ==> Les noeuds centraux des pentaedres coupes selon
 305 c          le mode 3 ou 5
 306 c          . Decoupage selon 2 aretes de triangle : le noeud central est
 307 c            le sommet S1 de chacun des 10 tetraedres
 308 c          . Decoupage selon 1 face de triangle : le noeud central est
 309 c            le sommet S1 du 10eme tetraedre
 310 c
 311       if ( codret.eq.0 ) then
 312 c
 313       do 25 , iaux = 1 , nancpe
 314 c
 315         etat = mod(hetpen(iaux),100)
 316 c
 317         if ( ( etat.ge.31 .and. etat.le.36 ) .or.
 318      >       ( etat.ge.51 .and. etat.le.52 ) ) then
 319 c
 320 #ifdef _DEBUG_HOMARD_
 321           write (ulsort,90002) mess14(langue,2,7), iaux
 322           write (ulsort,texte(langue,4)) etat
 323 #endif
 324           jaux = filpen(iaux)
 325           letetr = fppyte(2,-jaux) + 9
 326 #ifdef _DEBUG_HOMARD_
 327           write (ulsort,90002) mess14(langue,2,3), letetr
 328 #endif
 329 c
 330           call utaste ( letetr,
 331      >                  nanctr, nanctf, nancta,
 332      >                  somare, aretri,
 333      >                  tritet, cotrte, aretet,
 334      >                  listar, listso )
 335 c
 336           lenoeu = listso(1)
 337 #ifdef _DEBUG_HOMARD_
 338           write (ulsort,90002) mess14(langue,2,-1), lenoeu
 339 #endif
 340           disnoe(lenoeu) = 1
 341 c
 342         endif
 343 c
 344    25 continue
 345 c
 346       endif
 347 c
 348 c====
 349 c 3. Suppression des noeuds
 350 c====
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,*) '3. Suppression des noeuds ; codret = ', codret
 353 #endif
 354 c
 355       if ( codret.eq.0 ) then
 356 c
 357 #ifdef _DEBUG_HOMARD_
 358       write (ulsort,texte(langue,3)) 'UTSUNO', nompro
 359 #endif
 360       call utsuno ( nancno, nbnoto, disnoe,
 361      >              hetnoe, ancnoe, nounoe,
 362      >              nbnore, nbp2re, nbimre )
 363 c
 364       endif
 365 c
 366 c====
 367 c 4. Compactage de la numerotation
 368 c    Remarque : c'est un melange de utcnno et utcnar
 369 c    sachant qu'ici les aretes ne changent pas de numero
 370 c====
 371 #ifdef _DEBUG_HOMARD_
 372       write (ulsort,*) '4. Compactage ; codret = ', codret
 373 #endif
 374 c
 375       if ( codret.eq.0 ) then
 376 c
 377 c 4.1. ==> Les tableaux du maillage
 378 c
 379       do 41 , lenoeu = 1 , nbnore
 380 c
 381         if ( ancnoe(lenoeu).ne.lenoeu ) then
 382           do 410, iaux = 1 , sdim
 383             coonoe(lenoeu,iaux) = coonoe(ancnoe(lenoeu),iaux)
 384   410     continue
 385           hetnoe(lenoeu) = hetnoe(ancnoe(lenoeu))
 386           famnoe(lenoeu) = famnoe(ancnoe(lenoeu))
 387           arenoe(lenoeu) = arenoe(ancnoe(lenoeu))
 388         endif
 389 c
 390    41 continue
 391 c
 392 c 4.2. ==> Les eventuels noeuds homologues
 393 c
 394       if ( homolo.ge.1 ) then
 395 c
 396         do 42 , lenoeu = 1 , nbnore
 397           if ( noehom(ancnoe(lenoeu)).ge.0 ) then
 398             noehom(lenoeu) =   nounoe(noehom(ancnoe(lenoeu)))
 399           else
 400             noehom(lenoeu) = - nounoe(abs(noehom(ancnoe(lenoeu))))
 401           endif
 402    42   continue
 403 c
 404       endif
 405 c
 406 c 4.3. ==> La description des aretes
 407 c
 408       do 43 , larete = 1 , nancar
 409 c
 410         somare(1,larete) = nounoe(somare(1,larete))
 411         somare(2,larete) = nounoe(somare(2,larete))
 412         np2are(larete) = nounoe(np2are(larete))
 413 c
 414    43 continue
 415 c
 416 c 4.4. ==> Les eventuels indicateurs d'erreur
 417 c
 418       if ( typind.eq.2 ) then
 419 c
 420         do 441 , lenoeu = 1 , nbnore
 421           if ( ancnoe(lenoeu).ne.lenoeu ) then
 422             iindno(lenoeu) = iindno(ancnoe(lenoeu))
 423           endif
 424   441   continue
 425 c
 426       elseif ( typind.eq.3 ) then
 427 c
 428         do 442 , lenoeu = 1 , nbnore
 429           if ( ancnoe(lenoeu).ne.lenoeu ) then
 430             rindno(lenoeu) = rindno(ancnoe(lenoeu))
 431           endif
 432   442   continue
 433 c
 434       endif
 435 c
 436       endif
 437 c
 438 c====
 439 c 5. la fin
 440 c====
 441 c
 442       if ( codret.ne.0 ) then
 443 c
 444 #include "envex2.h"
 445 c
 446       write (ulsort,texte(langue,1)) 'Sortie', nompro
 447       write (ulsort,texte(langue,2)) codret
 448 c
 449       endif
 450 c
 451 #ifdef _DEBUG_HOMARD_
 452       write (ulsort,texte(langue,1)) 'Sortie', nompro
 453       call dmflsh (iaux)
 454 #endif
 455 c
 456       end